wch · August 7, 2012 01:17 · Aug 7, 2012 · Aug 7, 2012 · Aug 7, 2012 · Aug 7, 2012
diff --git a/unlockEnvironment.r b/unlockEnvironment.r
@@ -1,7 +1,9 @@
 library(inline)
 
 inc <- '
-/* This is taken from envir.c in the R 2.15.1 source */
+/* This is taken from envir.c in the R 2.15.1 source 
+   https://github.com/SurajGupta/r-source/blob/master/src/main/envir.c
+*/
 #define FRAME_LOCK_MASK (1<<14)
 #define FRAME_IS_LOCKED(e) (ENVFLAGS(e) & FRAME_LOCK_MASK)
 #define UNLOCK_FRAME(e) SET_ENVFLAGS(e, ENVFLAGS(e) & (~ FRAME_LOCK_MASK))
@@ -103,4 +105,4 @@ export_env <- ns_env$.__NAMESPACE__.$exports
 ls(export_env)
 export_env$foo <- c(foo="foo")
 devtools::foo # OK
-devtools::foo() # returns contents of devtools, including non-exported objects
+devtools::foo() # returns contents of devtools, including non-exported objects
diff --git a/unlockEnvironment.r b/unlockEnvironment.r
@@ -32,8 +32,9 @@ unlockEnvironment(new.env()) # TRUE
 unlockEnvironment('foo') # error
 
 # TODO: Write proper R wrapper function
-# Wrapper function should return(invisible(TRUE)) if successful, error otherwise.
-# Wrapper function should also check type
+# - should return(invisible(TRUE)) if successful, error otherwise.
+# - should also check type is environment
+# - add 'bindings' option to also unlock bindings
 
 # ============== test unlocking bindings
 
@@ -71,3 +72,35 @@ bindingIsLocked('x', e)  # FALSE
 bindingIsLocked('y', e)  # FALSE
 e$y <- 8 # OK
 e$z <- 9 # OK
+
+
+# =============== test on a real package
+# Modify devtools namespace
+# We'll insert a function 'foo()' into the namespace env and package env,
+# and also add it to the namespace's exports
+
+library(devtools)
+
+# Add something to namespace environment
+ns_env <- asNamespace('devtools')
+unlockEnvironment(ns_env)
+ns_env$foo <- function() {
+  ls(parent.env(environment()))
+}
+environment(ns_env$foo) <- ns_env # Set the environment of the function to the namespace
+devtools:::foo  # prints function, with environment
+devtools:::foo() # returns contents of devtools, including non-exported objects
+
+# Add to package environment
+pkg_env <- as.environment('package:devtools')
+unlockEnvironment(pkg_env)
+pkg_env$foo <- ns_env$foo
+pkg_env$foo # OK
+devtools::foo # Error: 'foo' is not an exported object from 'namespace:devtools'
+
+# Add to exports for devtools
+export_env <- ns_env$.__NAMESPACE__.$exports
+ls(export_env)
+export_env$foo <- c(foo="foo")
+devtools::foo # OK
+devtools::foo() # returns contents of devtools, including non-exported objects
diff --git a/unlockEnvironment.r b/unlockEnvironment.r
@@ -31,6 +31,7 @@ unlockEnvironment(new.env()) # TRUE
 
 unlockEnvironment('foo') # error
 
+# TODO: Write proper R wrapper function
 # Wrapper function should return(invisible(TRUE)) if successful, error otherwise.
 # Wrapper function should also check type
 
@@ -68,5 +69,5 @@ e$x <- 7 # OK
 
 bindingIsLocked('x', e)  # FALSE
 bindingIsLocked('y', e)  # FALSE
-e$y <- 8 
-e$z <- 9
+e$y <- 8 # OK
+e$z <- 9 # OK
diff --git a/unlockEnvironment.r b/unlockEnvironment.r
@@ -1,7 +1,7 @@
 library(inline)
 
 inc <- '
-/* This is taken from envir.c in the R source */
+/* This is taken from envir.c in the R 2.15.1 source */
 #define FRAME_LOCK_MASK (1<<14)
 #define FRAME_IS_LOCKED(e) (ENVFLAGS(e) & FRAME_LOCK_MASK)
 #define UNLOCK_FRAME(e) SET_ENVFLAGS(e, ENVFLAGS(e) & (~ FRAME_LOCK_MASK))

diff --git a/unlockEnvironment.r b/unlockEnvironment.r
@@ -0,0 +1,72 @@
+library(inline)
+
+inc <- '
+/* This is taken from envir.c in the R source */
+#define FRAME_LOCK_MASK (1<<14)
+#define FRAME_IS_LOCKED(e) (ENVFLAGS(e) & FRAME_LOCK_MASK)
+#define UNLOCK_FRAME(e) SET_ENVFLAGS(e, ENVFLAGS(e) & (~ FRAME_LOCK_MASK))
+'
+
+src <- '
+  if (TYPEOF(env) == NILSXP)
+    error("use of NULL environment is defunct");
+  if (TYPEOF(env) != ENVSXP)
+    error("not an environment");
+
+  UNLOCK_FRAME(env);
+
+  // Return TRUE if unlocked; FALSE otherwise
+  SEXP result = PROTECT( Rf_allocVector(LGLSXP, 1) );
+  LOGICAL(result)[0] = FRAME_IS_LOCKED(env) == 0;
+  UNPROTECT(1);
+
+  return result;
+'
+
+unlockEnvironment <- cfunction(signature(env = "environment"),
+                        includes = inc,
+                        body = src)
+
+unlockEnvironment(new.env()) # TRUE
+
+unlockEnvironment('foo') # error
+
+# Wrapper function should return(invisible(TRUE)) if successful, error otherwise.
+# Wrapper function should also check type
+
+# ============== test unlocking bindings
+
+e <- new.env()
+e$x <- 5
+e$x # 5
+lockEnvironment(e, bindings = TRUE)
+e$x <- 6 # ERROR
+
+environmentIsLocked(e) # TRUE
+e$y <- 6 # ERROR
+
+bindingIsLocked('x', e)  # TRUE
+unlockBinding('x', e)
+bindingIsLocked('x', e)  # FALSE
+e$x <- 7 # OK
+
+# Re-lock environment and bindings
+lockEnvironment(e, bindings = TRUE)
+e$y <- 6 # ERROR
+
+
+# Run our custom function
+unlockEnvironment(e) # TRUE
+environmentIsLocked(e) # FALSE
+e$y <- 8 # OK
+
+bindingIsLocked('x', e)  # TRUE
+e$x <- 7 # ERROR
+
+unlockBinding(ls(e, all.names=TRUE), e)
+e$x <- 7 # OK
+
+bindingIsLocked('x', e)  # FALSE
+bindingIsLocked('y', e)  # FALSE
+e$y <- 8 
+e$z <- 9