Add accessor methods

hadley · hadley · commit 52fc62615224 · 2016-10-27T08:47:38.000-05:00
diff --git a/NAMESPACE b/NAMESPACE
@@ -1,5 +1,8 @@
 # Generated by roxygen2: do not edit by hand
 
+S3method("[",blob)
+S3method("[<-",blob)
+S3method("[[<-",blob)
 S3method(as.blob,character)
 S3method(as.blob,integer)
 S3method(as.blob,list)
diff --git a/R/accessors.R b/R/accessors.R
@@ -0,0 +1,22 @@
+#' @export
+`[.blob` <- function(x, i, ...) {
+  new_blob(NextMethod())
+}
+
+#' @export
+`[<-.blob` <- function(x, i, ..., value) {
+  if (!is_raw_list(value)) {
+    stop("RHS must be list of raw vectors", call. = FALSE)
+  }
+
+  NextMethod()
+}
+
+#' @export
+`[[<-.blob` <- function(x, i, ..., value) {
+  if (!is.raw(value)) {
+    stop("RHS must be raw vector", call. = FALSE)
+  }
+
+  NextMethod()
+}
diff --git a/R/blob.R b/R/blob.R
@@ -22,7 +22,9 @@ blob <- function(...) {
 #' @export
 #' @rdname blob
 new_blob <- function(x) {
-  check_blob(x)
+  if (!is_raw_list(x)) {
+    stop("`x` must be a list of raw vectors", call. = FALSE)
+  }
   structure(x, class = "blob")
 }
 
diff --git a/R/util.R b/R/util.R
@@ -1,5 +1,10 @@
-check_blob <- function(x) {
-  if (!is.list(x) || !all(vapply(x, is.raw, logical(1)))) {
-    stop("`x` must be a list of raw vectors", call. = FALSE)
-  }
+is_raw_list <- function(x) {
+  if (!is.list(x))
+    return(FALSE)
+
+  all_raw <- all(vapply(x, is.raw, logical(1)))
+  if (!all_raw)
+    return(FALSE)
+
+  TRUE
 }
diff --git a/tests/testthat/test-accessors.R b/tests/testthat/test-accessors.R
@@ -0,0 +1,13 @@
+context("accessors")
+
+test_that("subsetting blob returns blob", {
+  x <- as.blob(1:5)
+  expect_s3_class(x[1], "blob")
+})
+
+test_that("can't insert objects of incorrect type", {
+  x <- as.blob(1:5)
+
+  expect_error(x[[1]] <- 1, "must be raw vector")
+  expect_error(x[1] <- 1, "must be list of raw vectors")
+})
