public
Last active

Sample code for unlocking environments in R

  • Download Gist
unlockEnvironment.r
R
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108
library(inline)
 
inc <- '
/* 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))
'
 
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
 
# TODO: Write proper R wrapper function
# - should return(invisible(TRUE)) if successful, error otherwise.
# - should also check type is environment
# - add 'bindings' option to also unlock bindings
 
# ============== 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 # 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

Please sign in to comment on this gist.

Something went wrong with that request. Please try again.