globals/0000755000176200001440000000000015007071223011672 5ustar liggesusersglobals/tests/0000755000176200001440000000000015004026770013040 5ustar liggesusersglobals/tests/test-globalsByName.R0000644000176200001440000000024015007027243016652 0ustar liggesusers## This runs testme test script inst/testme/test-globalsByName.R ## Don't edit - it was autogenerated by inst/testme/deploy.R globals:::testme("globalsByName") globals/tests/test-utils.R0000644000176200001440000000022015007027243015271 0ustar liggesusers## This runs testme test script inst/testme/test-utils.R ## Don't edit - it was autogenerated by inst/testme/deploy.R globals:::testme("utils") globals/tests/test-conservative.R0000644000176200001440000000023615007027243016650 0ustar liggesusers## This runs testme test script inst/testme/test-conservative.R ## Don't edit - it was autogenerated by inst/testme/deploy.R globals:::testme("conservative") globals/tests/test-cleanup.R0000644000176200001440000000022415007027243015564 0ustar liggesusers## This runs testme test script inst/testme/test-cleanup.R ## Don't edit - it was autogenerated by inst/testme/deploy.R globals:::testme("cleanup") globals/tests/test-walkAST.R0000644000176200001440000000022415007027243015443 0ustar liggesusers## This runs testme test script inst/testme/test-walkAST.R ## Don't edit - it was autogenerated by inst/testme/deploy.R globals:::testme("walkAST") globals/tests/test-Globals.R0000644000176200001440000000022415007027243015520 0ustar liggesusers## This runs testme test script inst/testme/test-Globals.R ## Don't edit - it was autogenerated by inst/testme/deploy.R globals:::testme("Globals") globals/tests/test-zzz.R0000644000176200001440000000021415007027243014771 0ustar liggesusers## This runs testme test script inst/testme/test-zzz.R ## Don't edit - it was autogenerated by inst/testme/deploy.R globals:::testme("zzz") globals/tests/test-globalsOf.R0000644000176200001440000000023015007027243016042 0ustar liggesusers## This runs testme test script inst/testme/test-globalsOf.R ## Don't edit - it was autogenerated by inst/testme/deploy.R globals:::testme("globalsOf") globals/tests/test-findGlobals.R0000644000176200001440000000023415007027243016362 0ustar liggesusers## This runs testme test script inst/testme/test-findGlobals.R ## Don't edit - it was autogenerated by inst/testme/deploy.R globals:::testme("findGlobals") globals/tests/test-liberal.R0000644000176200001440000000022415007027243015547 0ustar liggesusers## This runs testme test script inst/testme/test-liberal.R ## Don't edit - it was autogenerated by inst/testme/deploy.R globals:::testme("liberal") globals/tests/test-globalsOf,locals.R0000644000176200001440000000024615007027243017323 0ustar liggesusers## This runs testme test script inst/testme/test-globalsOf,locals.R ## Don't edit - it was autogenerated by inst/testme/deploy.R globals:::testme("globalsOf,locals") globals/tests/test-formulas.R0000644000176200001440000000022615007027243015767 0ustar liggesusers## This runs testme test script inst/testme/test-formulas.R ## Don't edit - it was autogenerated by inst/testme/deploy.R globals:::testme("formulas") globals/tests/test-findGlobals,dfs.R0000644000176200001440000000024415007027243017134 0ustar liggesusers## This runs testme test script inst/testme/test-findGlobals,dfs.R ## Don't edit - it was autogenerated by inst/testme/deploy.R globals:::testme("findGlobals,dfs") globals/tests/test-codetools-bug16.R0000644000176200001440000000024415007027243017054 0ustar liggesusers## This runs testme test script inst/testme/test-codetools-bug16.R ## Don't edit - it was autogenerated by inst/testme/deploy.R globals:::testme("codetools-bug16") globals/tests/test-dotdotdot.R0000644000176200001440000000023015007027243016136 0ustar liggesusers## This runs testme test script inst/testme/test-dotdotdot.R ## Don't edit - it was autogenerated by inst/testme/deploy.R globals:::testme("dotdotdot") globals/MD50000644000176200001440000001075215007071223012207 0ustar liggesusersa9b5fd5a17447d9b39e0d198105b0aac *DESCRIPTION 9c19ce5a6375cbd0508fcdecf48c051a *NAMESPACE 9d62ea87975ba6daf938ab033232439a *NEWS.md 8717cd60bbc08a5201d4cf3ee8e9873d *R/Globals-class.R 2fb40285b8760cf1189e87317b496f23 *R/call_find_globals_with_dotdotdot.R e06d79d612abf0bd68cdffb81fd02cd1 *R/cleanup.R 5bb75d96c97b94726f58cd1e0019dfcd *R/environment_of.R 5264456f1e0da09aa6629ab3e15723b2 *R/findGlobals.R 2f6a7905a272e3de98fb76797aa8be55 *R/findGlobalsDFS.R 8bc55d5852726bad892b73b7b2e083a0 *R/find_globals_conservative.R 063db36a94503f386796fcb95d337330 *R/find_globals_liberal.R 94f8a68f9d9213d9f3765c5adea46987 *R/find_globals_ordered.R a174920e10d929f52df0d053debeca43 *R/globalsByName.R aaa082f2a8c99ac193cd948dc438bfe4 *R/globalsOf.R 04b75e721fdd6e157724fc6f92c2b61a *R/options.R 516f61b38da5250393dfd6b648904571 *R/packagesOf.R e49b82f25ef99a63ff73ed1eb442a76e *R/testme.R b69719062063a46e519aa5df90a8700e *R/utils,codetools-bugfix.R abd64988cf1c93b0d4714db5aa63609b *R/utils,conditions.R c0135dc8f04f33e944b2b34c0f10bf40 *R/utils-debug.R 88e0dad32d20b79ccb3d858594ed8474 *R/utils.R b94de59be1d9d35e67d40fe512200c39 *R/walkAST.R 28bc00f0cb86330ee46613540a7eaeb3 *R/where.R 063cc1d50a8d5dd7d2b184b0c26e88a0 *R/zzz.R 19193315e2561b6ae105558833599968 *inst/WORDLIST 7c8a020554782543b549163045b31d1c *inst/testme/_epilogue/002.undo-state.R 3573c72602ff98dc7224652fb1114010 *inst/testme/_epilogue/090.gc.R 351d953a6347d4187a40fa5f99ae4501 *inst/testme/_epilogue/099.session_info.R 26e3c1291e3360b94e8d6360193048d2 *inst/testme/_epilogue/995.detritus-connections.R e8e91653a7f7ce9042b12d143bd1f672 *inst/testme/_epilogue/999.detritus-files.R 403f603bcdde48be3c914ba0eb047d7a *inst/testme/_prologue/001.load.R 9fc3930b860f6cbe363a713986a14094 *inst/testme/_prologue/005.globals.R e154dfc8601570c94bd1eadf4e3e6015 *inst/testme/_prologue/010.record-state.R 4af134d3a23279830a4f12578bdc5a1b *inst/testme/_prologue/030.imports.R 942a74966b29c8fb0ba9379745fa293f *inst/testme/_prologue/050.utils.R 91edf3301dc1c86e9c9a2d5b425b168a *inst/testme/_prologue/090.context.R 0be9b50d75b4ee6da361ca23c350f76d *inst/testme/_prologue/090.options.R 7edb111665d86a61d26829e991655825 *inst/testme/_prologue/091.envvars.R b084169193945c304a02575ef52bb5f9 *inst/testme/_prologue/995.detrius-connections.R 23755d07e02bff6381888b5fd976394a *inst/testme/deploy.R 60b8c65a881c7b0e9118edab43fba2de *inst/testme/run.R b78fde79476d66b4885b557661c76d77 *inst/testme/test-Globals.R 8de06dc66ea24fdc26fdade50d570b76 *inst/testme/test-cleanup.R 22aa118e8e29f4e27daf6b39fe4c8ad6 *inst/testme/test-codetools-bug16.R 9de3ded1b10d6944d9c464a52b9492b1 *inst/testme/test-conservative.R 008689ea59af6eb7937b676370510c88 *inst/testme/test-dotdotdot.R 658998d02402680aa1a5ac3e70470424 *inst/testme/test-findGlobals,dfs.R 859b7f43895b78b32e12d16cf7d829f8 *inst/testme/test-findGlobals.R 7cdb459a351ba26ab4698855e1238618 *inst/testme/test-formulas.R 838cc4f427fafda9ecdb228d81385a17 *inst/testme/test-globalsByName.R 53555f695d48514251046e3117664029 *inst/testme/test-globalsOf,locals.R f011b532b4834b2e4ab200ab8b1c46c8 *inst/testme/test-globalsOf.R 943b3d89175cd49e9116a22dc5560e69 *inst/testme/test-liberal.R c592e21de002ebc370be5cc4bfc2efad *inst/testme/test-utils.R 2c5ca2b3c401520f39134861ff7d694a *inst/testme/test-walkAST.R ad6f3e6981878302d85cbba7e87fe1ab *inst/testme/test-zzz.R fa1f524670483d229b4b840992c970d0 *man/Globals.Rd 18aa740b5a87c2fdf192f5377d26dae4 *man/cleanup.Globals.Rd 688699e1bfd1f560294f70dc9d9cc7e1 *man/globalsByName.Rd 2229913577bc1014090f8143c08039f8 *man/globalsOf.Rd 37c591b6da31531b001eae278235d459 *man/packagesOf.Globals.Rd 8f535a3461ee9bf48f75947b66fa71d9 *man/private_length.Rd e36b8a123a5d7dc214afc33d9362bc22 *man/walkAST.Rd d5954c310d6c157332415d321e487e1d *tests/test-Globals.R 89b42153e13bc11b7a6183a192c50b74 *tests/test-cleanup.R 2bf5b1081357fecdca7580efe2ca0318 *tests/test-codetools-bug16.R a78af27398b9d216fe9052adc287894f *tests/test-conservative.R 0509c41a6f9ef0a1e8249005390bbcd0 *tests/test-dotdotdot.R cd7f199a088b8d5a0ef668072f2a56f8 *tests/test-findGlobals,dfs.R 8e82762d1f2986f679d2d6dbe6021a65 *tests/test-findGlobals.R db7eb7128f5366427cbfe3357b7c501e *tests/test-formulas.R e47e75edaac1651933fa69ae853f3e5c *tests/test-globalsByName.R de26e4f6a2320fa6c073156496ca4f99 *tests/test-globalsOf,locals.R 436eb4f15556c4741a88c46786647e6d *tests/test-globalsOf.R 72d98042b942e3bb6b125921e66799cb *tests/test-liberal.R 28cc085f6c2b57950ca3d5cb7400ab41 *tests/test-utils.R ff1d63c49fe429319a23d65eb7a49004 *tests/test-walkAST.R 4df679e0067ad113bc533d7b73bd1f85 *tests/test-zzz.R globals/R/0000755000176200001440000000000015007060724012077 5ustar liggesusersglobals/R/findGlobalsDFS.R0000644000176200001440000004670315007060724015015 0ustar liggesusersdframe <- function(name = NA_character_, bound = character(0L), unbound = character(0L), type = NA_character_, comment = NA_character_) { res <- data.frame(name = name, bound = NA, unbound = NA, type = type, comment = comment) bound <- unique(bound) unbound <- unique(unbound) stopifnot(is.character(bound)) stopifnot(is.character(unbound)) res[[1, "bound"]] <- list(bound) res[[1, "unbound"]] <- list(unbound) res } ## dframe() findGlobals_dfs_symbol <- function(expr, ..., debug = FALSE) { if (debug) { mdebugf_push("findGlobals_dfs_symbol() ...") mprint(expr) mdebugf("typeof: %s, class: %s", typeof(expr), class(expr)[1]) on.exit({ mprint(globals) mdebugf_pop("findGlobals_dfs_symbol() ... done") }) } name <- as.character(expr) if (nzchar(name)) { globals <- dframe(name = name, unbound = name, type = "symbol", comment = "symbol") } else { globals <- dframe(name = "", type = "symbol", comment = "symbol") } globals } findGlobals_dfs_atomic <- function(expr, ..., debug = FALSE) { if (debug) { mdebugf_push("findGlobals_dfs_atomic() ...") mprint(expr) mdebugf("typeof: %s, class: %s", typeof(expr), class(expr)[1]) on.exit({ mprint(globals) mdebugf_pop("findGlobals_dfs_atomic() ... done") }) } name <- as.character(expr) typeof <- typeof(expr) if (typeof %in% c("logical", "integer", "double", "complex", "character", "raw", "NULL")) { if (debug) mdebugf("Skipping because typeof = %s", sQuote(typeof)) ## Basic types that cannot contain unbound variables if (inherits(expr, "srcref")) { name <- "" } else if (length(name) != 1L) { name <- NA_character_ } globals <- dframe(name = name, type = "constant", comment = "atomic") } else { bound <- unbound <- character(0L) if (grepl("^[[:alpha:]]", name, ignore.case = TRUE)) { bound <- name unbound <- name } globals <- dframe(name = name, bound = bound, unbound = unbound, type = "constant", comment = "atomic") } globals } findGlobals_dfs_pairlist <- function(expr, ..., debug = FALSE) { if (debug) { mdebugf_push("findGlobals_dfs_pairlist() ...") mprint(expr) on.exit({ mprint(globals) mdebugf_pop("findGlobals_dfs_pairlist() ... done") }) } n <- length(expr) if (n == 0) return(NULL) globals <- list() for (name in names(expr)) { globals[[name]] <- dframe(name = name, type = typeof(expr[[name]]), comment = "pairlist element") } globals <- do.call(rbind, args = globals) globals } findGlobals_dfs_call <- function(expr, ..., debug = FALSE) { if (debug) { mdebugf_push("findGlobals_dfs_call() ...") mprint(expr) mdebugf("typeof: %s, class: %s", typeof(expr), class(expr)[1]) on.exit({ mprint(globals) mdebugf_pop("findGlobals_dfs_call() ... done") }) } n <- length(expr) globals <- list() op <- expr[[1]] typeof <- typeof(op) mstr(list(op = op, typeof = typeof, length = length(op))) if (typeof %in% c("builtin", "closure")) { if (debug) mdebug_push("Function call via %s ...", typeof) globals <- list() for (kk in seq_len(n)) { globals[[kk]] <- findGlobals_dfs(expr[[kk]], debug = debug) } if (debug) mdebug_pop("Function call via %s ... done", typeof) } else if (typeof == "symbol" && (as.character(op) %in% c("for", "function"))) { if (as.character(op) == "for") { if (debug) mdebug_push("For loop ...") globals[[1]] <- dframe(unbound = "for", type = "for-loop", comment = "for-loop") globals_iter <- findGlobals_dfs(expr[[2]], debug = debug) globals_iter[["bound"]] <- globals_iter[["unbound"]] globals_iter[["unbound"]] <- list(character(0L)) globals_iter[["comment"]] <- "for-loop iterator" globals[[2]] <- globals_iter globals_args <- findGlobals_dfs(expr[[3]], debug = debug) globals_args[["comment"]] <- "for-loop arguments" globals[[3]] <- globals_args globals_body <- findGlobals_dfs(expr[[4]], debug = debug) globals_body[["comment"]] <- "for-loop body" globals[[4]] <- globals_body if (debug) mdebug_pop("For loop ... done") } else if (as.character(op) == "function") { if (debug) mdebug_push("Function call via function ...") globals[[1]] <- dframe(type = "closure", comment = "function definition") stopifnot(n >= 3L) if (debug) mdebugf("Function definition:") ## Arguments globals_args <- findGlobals_dfs(expr[[2]], debug = debug) if (debug) { mdebugf("Function arguments:") mprint(globals_args) } globals_args[["comment"]] <- "arguments" name_args <- globals_args[["name"]] bound_args <- unlist(globals_args[["bound"]]) unbound_args <- unlist(globals_args[["unbound"]]) ## Body globals_body <- findGlobals_dfs(expr[[3]], debug = debug) if (debug) { mdebugf("Function body:") mprint(globals_body) } globals_body[["comment"]] <- "body" bound_body <- unlist(globals_body[["bound"]]) unbound_body <- unlist(globals_body[["unbound"]]) unbound_body <- setdiff(unbound_body, name_args) globals_body[["bound"]] <- list(bound_body) globals_body[["unbound"]] <- list(unbound_body) if (debug) { mdebugf("globals_body:") mprint(globals_body) } globals_args[["bound"]] <- list(bound_args) globals_args[["unbound"]] <- list(setdiff(unbound_args, bound_args)) if (debug) { mdebugf("globals_args:") mprint(globals_args) } ## Consolidate globals[[2]] <- globals_args globals[[3]] <- globals_body if (debug) mdebug_pop("Function call via function ... done") } } else { if (typeof %in% c("call", "language")) { op_name <- as.character(op[[1]]) name <- NA_character_ } else { op_name <- character(0L) name <- as.character(op) } if (debug) { mdebug_push("Function call in other ways ...") mdebugf("n = %d", n) } if (n == 1) { globals[[1]] <- findGlobals_dfs(op, debug = debug) } else if (n >= 2) { if (is.call(op)) { if (debug) mdebug_push("Function call whose function is a call ...") globals[[1]] <- findGlobals_dfs_call(op, debug = debug) if (debug) mdebug_pop("Function call whose function is a call ... done") } else { if (is.na(name)) name <- character(0L) globals[[1]] <- dframe(name = "function", unbound = c(name, op_name), type = "function", comment = "function call") } if (debug) { mdebug("---------------------------------") mprint(globals) mdebug("---------------------------------") } if (name %in% c("::", ":::")) { if (debug) mdebugf("%s", name) } else { for (kk in 2:n) globals[[kk]] <- findGlobals_dfs(expr[[kk]], debug = debug) if (name %in% c("$", "@")) { if (debug) mdebugf("LHS%sRHS", name) ## LHS$RHS, LHS@RHS globals_lhs <- globals[[2]] globals_rhs <- globals[[3]] rhs <- expr[[3]] if (is.symbol(rhs)) { globals_rhs[["unbound"]] <- list(character(0L)) globals[[3]] <- globals_rhs } } else if (name %in% c("=", "<-", "<<-")) { if (debug) mdebugf("LHS %s RHS", name) ## LHS <- RHS globals_op <- globals[[1]] ## e.g. `=`, `<-`, `<<-` globals_lhs <- globals[[2]] globals_rhs <- globals[[3]] lhs <- expr[[2]] if (length(lhs) >= 2) { ## From the R Language Definition, we have that: ## ## names(x) <- c("a", "b") ## ## is equivalent to: ## ## `*tmp*` <- x ## x <- "names<-"(`*tmp*`, value=c("a","b")) ## rm(`*tmp*`) ## ## We also have that: ## ## names(x)[3] <- "Three" ## ## is equivalent to: ## ## `*tmp*` <- x ## x <- "names<-"(`*tmp*`, value="[<-"(names(`*tmp*`), 3, value="Three")) ## rm(`*tmp*`) ## ## One way to confirm that the R engine transpiles the original ## expression this way is to check which symbols the byte ## compiler produces, e.g. ## ## expr <- quote(names(x)[2] <- "b") ## bytecode <- compiler::compile(expr) ## utils::capture.output(file = nullfile(), { ## parts <- compiler::disassemble(bytecode)[[3]] ## }) ## is_symbol <- vapply(parts, FUN.VALUE = FALSE, FUN = is.symbol) ## symbols <- parts[is_symbol] ## str(symbols) ## #> List of 4 ## #> $ : symbol x ## #> $ : symbol names ## #> $ : symbol names<- ## #> $ : symbol *vtmp* ## if (debug) mdebugf_push("Replacement function ...") ## Cases: ## ## 1. a[1] <- 0 => `[<-` ## 2. names(a) <- "x" => `names<-` ## 3. names(a)[1] <- "x" => `[<-`, `names<-` ## if (name == "=") name <- "<-" rhs <- expr[[3]] if (debug) { mdebugf("LHS: [n=%d] %s", length(lhs), commaq(as.character(lhs))) mprint(globals_lhs) mdebugf("RHS: [n=%d] %s", length(rhs), commaq(as.character(rhs))) mprint(globals_rhs) } ## We don't want the last element, e.g. `1`, `a` lhs_fcns <- lhs[-length(lhs)] if (debug) { mdebug("Possible functions to become replacement functions:") mstr(as.list(lhs_fcns)) } if (length(lhs_fcns) == 1L) { ## names(x) <- ... => `names<-` lhs_fcns <- lhs_fcns[[1]] } else if (length(lhs_fcns) == 2L) { ## x[1] <- ... ## names(x)[1] <- ... ## base::names(x)[1] <- ... first <- lhs_fcns[[1]] ## `[`, `[[`, `$`, `@` second <- lhs_fcns[[2]] ## `x`, `names(x)`, `base::names(x)` if (is.call(second)) { ## names(x)[1] <- ... ## base::names(x)[1] <- ... call <- second if (length(call[[1]]) == 1L) { ## names(x)[1] <- ... ## => keep lhs_fcns == lhs_fcns[1:2] } else if (length(call[[1]]) == 3L) { ## base::names(x)[1] <- ... ## => drop lhs_fcns[2] lhs_fcns <- lhs_fcns[-2] ## `[` } } else { ## x[1] <- 1 lhs_fcns <- lhs_fcns[-2] ## `[` } } if (debug) { mdebug("Functions to become replacement functions:") mstr(as.list(lhs_fcns)) } fcns <- vapply(lhs_fcns, FUN.VALUE = NA_character_, FUN = function(x) { as.character(as.list(x)[[1]]) }) repl_fcns <- sprintf("%s%s", fcns, name) fcns <- fcns[1] if (debug) { mdebugf("Replacement function and arguments: [n=%d] `%s`", length(fcns), commaq(fcns)) mdebugf("Replacement function(s): [n=%d] `%s`", length(repl_fcns), commaq(repl_fcns)) } globals_op[["unbound"]] <- list(repl_fcns) globals_lhs[["unbound"]] <- list(setdiff(unlist(globals_lhs[["unbound"]]), fcns)) globals[[1]] <- globals_op globals[[2]] <- globals_lhs if (debug) mdebugf_pop("Replacement function ... done") } name_lhs <- globals_lhs[["name"]] bound_lhs <- unlist(globals_lhs[["bound"]]) unbound_lhs <- unlist(globals_lhs[["unbound"]]) bound_rhs <- unlist(globals_rhs[["bound"]]) unbound_rhs <- unlist(globals_rhs[["unbound"]]) ## Example a <- a + 1 if (name_lhs %in% unbound_rhs) { } else { bound_lhs <- unique(c(name_lhs, bound_lhs)) unbound_lhs <- setdiff(unbound_lhs, bound_lhs) } globals_lhs[["bound"]] <- list(bound_lhs) globals_lhs[["unbound"]] <- list(unbound_lhs) globals[[2]] <- globals_lhs } } } else { } ## if (n >= 2) if (debug) mdebug_pop("Function call in other ways ... done") } if (length(globals) == 1) { globals <- globals[[1]] } else { if (debug) { mprint(globals) mdebugf_push("Consolidate ...") mprint(expr) } bound <- unbound <- character(0L) for (kk in seq_along(globals)) { globals_kk <- globals[[kk]] bound_kk <- unlist(globals_kk[["bound"]]) unbound_kk <- unlist(globals_kk[["unbound"]]) ## Bound previously? unbound_kk <- setdiff(unbound_kk, bound) bound <- unique(c(bound, bound_kk)) unbound <- unique(c(unbound, unbound_kk)) } name <- NA_character_ globals <- dframe(name = name, bound = bound, unbound = unbound, type = "language", comment = "consolidated") if (debug) { mdebugf_pop("Consolidate ... done") } } globals } findGlobals_dfs_environment <- function(expr, ..., debug = FALSE) { if (debug) { mdebugf_push("findGlobals_dfs_environment() ...") mprint(expr) mdebugf("typeof: %s, class: %s", typeof(expr), class(expr)[1]) on.exit({ mprint(globals) mdebugf_pop("findGlobals_dfs_environment() ... done") }) } ## NOTE: Do *not* look for types that we are interested in, but instead ## look for types that we are *not* interested. The reason for this that ## in future versions of R there might be new types added that may contain ## globals and with this approach those types will also be scanned. basicTypes <- c("logical", "integer", "double", "complex", "character", "raw", "NULL") ## Skip elements in 'expr' of basic types that cannot contain globals ## FIXME: The below can lead to infinite, recursive calls /HB 2025-04-27 globals <- dframe(type = "environment", comment = "environment") return(globals) types <- unlist(list_apply(expr, FUN = typeof), use.names = TRUE) keep <- names(types)[!(types %in% basicTypes)] ## Early stopping? if (length(keep) == 0) { if (debug) mdebug("globals found: [0] ") globals <- dframe(type = "environment", comment = "environment") } else { ## FIXME: This can lead to infinite recursive calls /HB 2025-04-27 if (FALSE) { globals <- list_apply(expr, subset = keep, FUN = findGlobals_dfs, ..., debug = debug) globals <- do.call(rbind, args = globals) } globals <- dframe(type = "environment", comment = "environment") } globals } findGlobals_dfs_expression <- function(expr, ..., debug = FALSE) { if (debug) { mdebugf_push("findGlobals_dfs_expression() ...") mprint(expr) mdebugf("typeof: %s, class: %s", typeof(expr), class(expr)[1]) on.exit({ mprint(globals) mdebugf_pop("findGlobals_dfs_expression() ... done") }) } ## NOTE: Do *not* look for types that we are interested in, but instead ## look for types that we are *not* interested. The reason for this that ## in future versions of R there might be new types added that may contain ## globals and with this approach those types will also be scanned. basicTypes <- c("logical", "integer", "double", "complex", "character", "raw", "NULL") ## Skip elements in 'expr' of basic types that cannot contain globals types <- unlist(list_apply(expr, FUN = typeof), use.names = FALSE) keep <- which(!(types %in% basicTypes)) ## Early stopping? if (length(keep) == 0) { if (debug) mdebug("globals found: [0] ") globals <- dframe(type = "expression", comment = "expression") } else { globals <- list_apply(expr, subset = keep, FUN = findGlobals_dfs, ..., debug = debug) globals <- do.call(rbind, args = globals) } globals } findGlobals_dfs_function <- function(expr, ..., debug = FALSE) { if (debug) { mdebugf_push("findGlobals_dfs_function() ...") mprint(expr) mdebugf("typeof: %s, class: %s", typeof(expr), class(expr)[1]) on.exit({ mprint(globals) mdebugf_pop("findGlobals_dfs_function() ... done") }) } arg_names <- names(formals(expr)) if (is.null(arg_names)) { arg_names <- character(0L) } globals_args <- dframe(bound = arg_names, type = "environment", comment = "environment") globals_body <- findGlobals_dfs(body(expr), ..., debug = debug) ## Consolidate bound_args <- unlist(globals_args[["bound"]]) unbound_args <- unlist(globals_args[["unbound"]]) bound_body <- unlist(globals_body[["bound"]]) unbound_body <- unlist(globals_body[["unbound"]]) ## Variables in the body are not unbound, if they are ## arguments of the function unbound_body <- setdiff(unbound_body, bound_args) ## Unbound variables may exist both in the arguments and the body unbound <- unique(c(unbound_args, unbound_body)) globals <- dframe(unbound = unbound, type = "function", comment = "consolidated") globals } findGlobals_dfs_object <- function(expr, ..., debug = FALSE) { if (debug) { mdebugf_push("findGlobals_dfs_object() ...") mprint(expr) mdebugf("typeof: %s, class: %s", typeof(expr), class(expr)[1]) on.exit({ mprint(globals) mdebugf_pop("findGlobals_dfs_object() ... done") }) } ## FIXME: Should we search for globals in 'object':s? globals <- dframe(type = typeof(expr), comment = typeof(expr)) globals } findGlobals_dfs <- function(expr, ..., debug = FALSE) { debug <- isTRUE(getOption("globals.debug")) if (debug) { mdebugf_push("findGlobals_dfs() ...") mprint(expr) on.exit({ mdebugf_pop("findGlobals_dfs() ... done") }) } if (is.null(expr)) { globals <- dframe(type = "NULL", comment = "empty") } else if (is.symbol(expr)) { globals <- findGlobals_dfs_symbol(expr, debug = debug) } else if (is.atomic(expr)) { globals <- findGlobals_dfs_atomic(expr, debug = debug) } else if (is.call(expr)) { globals <- findGlobals_dfs_call(expr, debug = debug) } else if (is.pairlist(expr)) { globals <- findGlobals_dfs_pairlist(expr, debug = debug) } else if (is.environment(expr)) { globals <- findGlobals_dfs_environment(expr, debug = debug) } else if (is.expression(expr)) { globals <- findGlobals_dfs_expression(expr, debug = debug) } else if (is.function(expr)) { globals <- findGlobals_dfs_function(expr, debug = debug) } else if (is.list(expr)) { names <- findGlobals(expr, method = "dfs", debug = debug) globals <- dframe(unbound = names, type = "list", comment = "list") } else if (typeof(expr) %in% c("object", "S4")) { globals <- findGlobals_dfs_object(expr, debug = debug) } else if (typeof(expr) %in% c("externalptr")) { globals <- dframe(type = "externalptr", comment = "externalptr") } else { mprint(expr) mstr(expr) stop(sprintf("Do not know how to identify globals for an object of type '%s' and class '%s'", typeof(expr), class(expr)[1])) } globals } ## findGlobals_dfs() findGlobalsDFS <- function(expr, ..., debug = FALSE) { data <- findGlobals_dfs(expr, debug = debug) globals <- unlist(data[["unbound"]]) ## FIXME: Should never get NA_character_:s here, but just in case ... isNA <- is.na(globals) if (any(isNA)) globals <- globals[!isNA] globals } globals/R/testme.R0000644000176200001440000000063215007027243013523 0ustar liggesusers## This runs 'testme' test inst/testme/test-.R scripts ## Don't edit - it was autogenerated by inst/testme/deploy.R testme <- function(name) { path <- system.file(package = 'globals', 'testme', mustWork = TRUE) Sys.setenv(R_TESTME_PATH = path) Sys.setenv(R_TESTME_PACKAGE = 'globals') Sys.setenv(R_TESTME_NAME = name) on.exit(Sys.unsetenv('R_TESTME_NAME')) source(file.path(path, 'run.R')) } globals/R/call_find_globals_with_dotdotdot.R0000644000176200001440000001002215004026770020752 0ustar liggesuserscall_find_globals_with_dotdotdot <- function(FUN, expr, envir, dotdotdot = "error", trace = FALSE, debug = FALSE) { if (trace) { trace_msg <- trace_enter("call_find_globals_with_dotdotdot(dotdotdot = %s)", sQuote(dotdotdot)) on.exit(trace_exit(trace_msg)) } ## Is there a need for global '...', '..1', '..2', etc.? dotdotdots <- character(0L) globals <- withCallingHandlers({ oopts <- options(warn = 0L) on.exit(options(oopts), add = TRUE) FUN(expr, envir = envir, dotdotdot = dotdotdot, trace = trace) }, warning = function(w) { ## Warned about '...', '..1', '..2', etc.? ## NOTE: The warning we're looking for is the one generated by ## codetools::findGlobals(). That warning is _not_ translated, ## meaning this approach should work as is as long as the message ## is not modified by codetools itself. If codetools ever changes ## this such that the below string matching fails, then the package ## tests (tests/dotdotdot.R) will detect that. In other words, ## such a change will not go unnoticed. /HB 2017-03-08 msg <- w$message pattern <- ".* ([.][.]([.]|[0-9]+)) may be used in an incorrect context.*" if (grepl(pattern, msg, fixed = FALSE)) { if (debug) mdebug("Warning message detected: %s", dQuote(trim(msg))) if (dotdotdot %in% c("ignore", "return", "warning")) { if (dotdotdot != "ignore") { dotdotdots <<- c(dotdotdots, gsub(pattern, "\\1", msg)) } if (dotdotdot != "warning") { ## Consume / muffle warning invokeRestart("muffleWarning") } } else if (dotdotdot == "error") { e <- simpleError(msg, w$call) stop(e) } } }) if (trace) { trace_printf("globals: [n=%d] %s\n", length(globals), commaq(globals)) } if (length(dotdotdots) > 0L) { dotdotdots <- unique(dotdotdots) if (trace) { trace_printf("dotdotdots: [n=%d] %s\n", length(dotdotdot), commaq(dotdotdots)) } globals <- c(globals, dotdotdots) } globals } call_find_globals_with_dotdotdot <- function(FUN, expr, envir, dotdotdot = "error", trace = FALSE, debug = FALSE) { if (trace) { trace_msg <- trace_enter("call_find_globals_with_dotdotdot(dotdotdot = %s)", sQuote(dotdotdot)) on.exit(trace_exit(trace_msg)) } ## Is there a need for global '...', '..1', '..2', etc.? dotdotdots <- character(0L) globals <- withCallingHandlers({ oopts <- options(warn = 0L) on.exit(options(oopts), add = TRUE) FUN(expr, envir = envir, dotdotdot = dotdotdot, trace = trace) }, warning = function(w) { ## Warned about '...', '..1', '..2', etc.? ## NOTE: The warning we're looking for is the one generated by ## codetools::findGlobals(). That warning is _not_ translated, ## meaning this approach should work as is as long as the message ## is not modified by codetools itself. If codetools ever changes ## this such that the below string matching fails, then the package ## tests (tests/dotdotdot.R) will detect that. In other words, ## such a change will not go unnoticed. /HB 2017-03-08 msg <- w$message pattern <- ".* ([.][.]([.]|[0-9]+)) may be used in an incorrect context.*" if (grepl(pattern, msg, fixed = FALSE)) { if (debug) mdebug("Warning message detected: %s", dQuote(trim(msg))) if (dotdotdot %in% c("ignore", "return", "warning")) { if (dotdotdot != "ignore") { dotdotdots <<- c(dotdotdots, gsub(pattern, "\\1", msg)) } if (dotdotdot != "warning") { ## Consume / muffle warning invokeRestart("muffleWarning") } } else if (dotdotdot == "error") { e <- simpleError(msg, w$call) stop(e) } } }) if (trace) { trace_printf("globals: [n=%d] %s\n", length(globals), commaq(globals)) } if (length(dotdotdots) > 0L) { dotdotdots <- unique(dotdotdots) if (trace) { trace_printf("dotdotdots: [n=%d] %s\n", length(dotdotdot), commaq(dotdotdots)) } globals <- c(globals, dotdotdots) } globals } globals/R/findGlobals.R0000644000176200001440000003022715006040432014443 0ustar liggesusers#' @param attributes If TRUE (default), attributes of `expr` are also searched. #' If FALSE, they are not. #' If a character vector, then attributes with matching names are searched. #' Note, the attributes of the attributes elements are not searched, that is, #' attributes are not searched recursively. Also, attributes are searched #' with `dotdotdot = "ignore". #' #' @param dotdotdot TBD. #' #' @param trace TBD. #' #' @return \code{findGlobals()} returns a character vector. #' #' @rdname globalsOf #' @export findGlobals <- function(expr, envir = parent.frame(), ..., attributes = TRUE, tweak = NULL, dotdotdot = c("warning", "error", "return", "ignore"), method = c("ordered", "conservative", "liberal", "dfs"), substitute = FALSE, unlist = TRUE, trace = FALSE) { if (missing(method)) method <- method[1] method <- match.arg(method, choices = c("ordered", "conservative", "liberal", "dfs"), several.ok = TRUE) dotdotdot <- match.arg(dotdotdot, choices = c("warning", "error", "return", "ignore")) if (substitute) expr <- substitute(expr) if (trace) { methods <- sprintf("'%s'", method) if (length(method) > 1) methods <- sprintf("c(%s)", paste(methods, collapse = ", ")) trace_msg <- trace_enter("findGlobals(..., dotdotdot = '%s', method = %s, unlist = %s)", dotdotdot, methods, unlist) on.exit(trace_exit(trace_msg)) } debug <- isTRUE(getOption("globals.debug")) if (debug) { methods <- sprintf("'%s'", method) if (length(method) > 1) methods <- sprintf("c(%s)", paste(methods, collapse = ", ")) mdebugf_push("findGlobals(..., dotdotdot = '%s', method = %s, unlist = %s) ...", dotdotdot, methods, unlist) on.exit(mdebugf_pop("findGlobals(..., dotdotdot = '%s', method = %s, unlist = %s) ... done", dotdotdot, methods, unlist), add = TRUE) } if (length(method) > 1) { if (!unlist) { stop("Argument 'unlist' must be TRUE if more than one 'method' is specified: ", commaq(method)) } if (is.function(tweak)) { if (debug) mdebug("tweaking expression using function") expr <- tweak(expr) } globals <- list() for (mtd in method) { globals[[mtd]] <- findGlobals( expr, substitute = FALSE, envir = envir, ..., attributes = attributes, tweak = NULL, dotdotdot = dotdotdot, method = mtd, unlist = TRUE, trace = trace ) } globals <- unlist(globals, use.names = FALSE) globals <- globals[!duplicated(globals)] return(globals) } ## if (length(method) > 1) if (is.logical(attributes)) { stop_if_not(length(attributes) == 1L, !is.na(attributes)) if (!attributes) attributes <- character(0L) } else { stop_if_not(is.character(attributes), !anyNA(attributes)) } if (is.list(expr)) { if (debug) mdebugf("expr: ", .length(expr)) ## NOTE: Do *not* look for types that we are interested in, but instead ## look for types that we are *not* interested. The reason for this that ## in future versions of R there might be new types added that may contain ## globals and with this approach those types will also be scanned. basicTypes <- c("logical", "integer", "double", "complex", "character", "raw", "NULL") ## Skip elements in 'expr' of basic types that cannot contain globals types <- unlist(list_apply(expr, FUN = typeof), use.names = FALSE) keep <- which(!(types %in% basicTypes)) ## Early stopping? if (length(keep) == 0) { if (debug) mdebug("globals found: [0] ") return(character(0L)) } globals <- list_apply(expr, subset = keep, FUN = findGlobals, envir = envir, attributes = attributes, ..., tweak = tweak, dotdotdot = dotdotdot, method = method, substitute = FALSE, unlist = FALSE, trace = trace) keep <- types <- NULL ## Not needed anymore if (debug) mdebugf("preliminary globals found: [%d] %s", length(globals), hpaste(sQuote(names(globals)))) if (unlist) { globals <- unlist(globals, use.names = FALSE) if (length(globals) > 1L) globals <- unique(globals) ## Move any ..., ..1, ..2, etc. to the very end idxs <- grep("^[.][.]([.]|[0-9]+)$", globals) if (length(idxs) > 0L) globals <- c(globals[-idxs], globals[idxs]) } if (debug) mdebugf("globals found: [%d] %s", length(globals), hpaste(sQuote(globals))) return(globals) } if (is.function(tweak)) { if (debug) mdebug("tweaking expression using function") expr <- tweak(expr) } if (method == "dfs") { globals <- findGlobalsDFS(expr) } else { if (hasCodetoolsBug16()) { if (debug) mdebug("workaround 'codetools' bug #16") expr <- walkAST(expr, call = tweakCodetoolsBug16) } if (is.expression(expr)) { return(findGlobals(expr[[1]], substitute = substitute, envir = envir, attributes = attributes, tweak = tweak, ..., dotdotdot = dotdotdot, method = method, unlist = unlist, trace = trace)) } if (method == "ordered") { find_globals_t <- find_globals_ordered } else if (method == "conservative") { find_globals_t <- find_globals_conservative } else if (method == "liberal") { find_globals_t <- find_globals_liberal } globals <- call_find_globals_with_dotdotdot(find_globals_t, expr = expr, envir = envir, dotdotdot = dotdotdot, trace = trace, debug = debug) idx <- which(globals == "codetools.bugfix16:::$<-") if (length(idx) > 0) { globals[idx] <- "$<-" globals <- unique(globals) } } ## if (method == ...) ## Search attributes? if (length(attributes) > 0) { attrs <- attributes(expr) if (is.character(attributes)) { attrs <- attrs[names(attrs) %in% attributes] } ## Attributes to be searched, if any if (length(attrs) > 0) { if (debug) mdebug("searching attributes") attrs_globals <- list_apply(attrs, FUN = findGlobals, envir = envir, ## Don't look for attributes recursively attributes = FALSE, tweak = tweak, ..., ## Don't complain about '...', '..1', etc. dotdotdot = "ignore", method = method, substitute = FALSE, unlist = FALSE, trace = trace) if (unlist) attrs_globals <- unlist(attrs_globals, use.names = FALSE) if (length(attrs_globals) > 1L) attrs_globals <- unique(attrs_globals) if (debug) mdebugf("globals found in attributes: [%d] %s", length(attrs_globals), hpaste(sQuote(attrs_globals))) globals <- unique(c(globals, attrs_globals)) } } if (debug) mdebugf("globals found: [%d] %s", length(globals), hpaste(sQuote(globals))) globals } ## Utility functions adopted from codetools:::dropMissing() ## and codetools:::collectUsageFun() drop_missing_formals <- function(x) { nx <- length(x) ix <- logical(length = nx) for (i in seq_len(nx)) { tmp <- x[[i]] if (!missing(tmp)) ix[i] <- TRUE } x[ix] } #' @importFrom codetools walkCode findLocalsList collect_usage_function <- function(fun, name, w, trace = FALSE) { if (trace) { trace_msg <- trace_enter("collect_usage_function()") on.exit(trace_exit(trace_msg)) } formals <- formals(fun) body <- body(fun) w$name <- c(w$name, name) parnames <- names(formals) if (trace) { trace_printf("parnames: [n=%d] %s\n", length(parnames), commaq(parnames)) } formals_clean <- drop_missing_formals(formals) # locals <- findLocalsList(c(list(body), formals_clean)) locals <- findLocalsList(formals_clean) if (trace) { trace_printf("formals_clean: [n=%d] %s\n", length(formals_clean), commaq(formals_clean)) trace_printf("locals: [n=%d] %s\n", length(locals), commaq(locals)) } ## Hardcode locals? hardcoded_locals <- c(parnames, locals) if (length(hardcoded_locals) > 0) { if (trace) trace_printf("Add hardcoded local variables %s", commaq(hardcoded_locals)) w$env <- new.env(hash = TRUE, parent = w$env) for (n in hardcoded_locals) assign(n, TRUE, w$env) } if (trace) { trace_printf("hardcoded locals: [n=%d] %s\n", length(w$env), commaq(names(w$env))) } for (a in formals_clean) { if (trace) trace_enter("walkCode(%s)", sQuote(a)) walkCode(a, w) if (trace) trace_exit("walkCode(%s)", sQuote(a)) } if (trace) trace_enter("walkCode(body)") res <- walkCode(body, w) if (trace) trace_exit("walkCode(body)") res } inject_tracer_to_function <- function(fcn, name) { b <- body(fcn) f <- formals(fcn) args <- setdiff(names(f), c("w", "...")) if (length(args) > 0L) { args <- grep("^[.][.][0-9]+$", args, invert = TRUE, value = TRUE) } title <- sprintf("%s()", name) b <- bquote({ ## Import private functions ns <- getNamespace("globals") trace_str <- get("trace_str", envir = ns, mode = "function") trace_exit <- get("trace_exit", envir = ns, mode = "function") trace_printf <- get("trace_printf", envir = ns, mode = "function") trace_print <- get("trace_print", envir = ns, mode = "function") trace_msg <- trace_enter("%s", .(title)) trace_indent <- attr(trace_msg, "indent") if (length(.(args)) > 0) trace_str(mget(.(args)), indent = trace_indent) if (!exists("w", mode = "list")) { trace_exit(trace_msg) return() } env <- environment(w$enterLocal) n <- length(env$name) value <- .(b) nnew <- (length(env$name) - n) if (nnew) { trace_printf("variables:\n", indent = trace_indent) trace_print(data.frame( name = env$name, class = env$class, added = c(rep(FALSE, times = n), rep(TRUE, times = nnew)), stringsAsFactors = FALSE ), indent = trace_indent) } trace_printf("result: ", indent = trace_indent) trace_str(value, indent = trace_indent) trace_exit(trace_msg) value }) body(fcn) <- b fcn } inject_tracer_to_walker <- function(w) { if (is.null(w$startCollectLocals)) { w$startCollectLocals <- function(parnames, locals, ...) { NULL } } if (is.null(w$finishCollectLocals)) { w$finishCollectLocals <- function(w, ...) { NULL } } if (is.null(w$enterInternal)) { w$enterInternal <- function(type, v, e, ...) { NULL } } for (key in names(w)) { fcn <- w[[key]] if (!is.function(fcn)) next # fcn <- inject_tracer_to_function(fcn, key) w[[key]] <- fcn } w } #' @importFrom codetools makeUsageCollector walkCode make_usage_collector <- local({ ## WORKAROUND: Avoid calling codetools::collectUsageCall() if it hits the ## https://bugs.r-project.org/bugzilla/show_bug.cgi?id=17935 bug in the ## stats:::`[.formula` function ## See also: https://github.com/HenrikBengtsson/globals/issues/64 if (getRversion() <= "4.0.3" || is.null(ver <- R.version$`svn rev`) || is.na(ver <- as.integer(ver)) || ver < 79355) { ## Local copy of codetools:::collectUsageCall() .collectUsageCall <- NULL collectUsageCall <- function(e, w) { e1 <- e[[1]] if (is.symbol(e1) && inherits(e, "formula") && is.null(e[[2]])) { ## From codetools:::collectUsageCall() fn <- as.character(e1) if (w$isLocal(fn, w)) { w$enterLocal("function", fn, e, w) } else { w$enterGlobal("function", fn, e, w) } } else { .collectUsageCall(e, w) } } function(...) { w <- makeUsageCollector(...) w$env <- new.env(parent = w$env) if (is.function(w$call)) { ## Memoize? (to avoid importing a private 'codetools' function) if (is.null(.collectUsageCall)) .collectUsageCall <<- w$call ## Patch w$call <- collectUsageCall } w } } else { function(...) { w <- makeUsageCollector(...) w$env <- new.env(hash = TRUE, parent = w$env) w } } }) globals/R/options.R0000644000176200001440000000641515006157406013726 0ustar liggesuserssetOption <- function(name, value) { oldValue <- getOption(name) args <- list(value) names(args) <- name do.call(options, args = args) invisible(oldValue) } # Set an R option from an environment variable update_package_option <- function(name, mode = "character", default = NULL, split = NULL, trim = TRUE, disallow = c("NA"), force = FALSE, debug = FALSE) { if (debug) { mdebug_push("update_package_option() ...") on.exit(mdebug_pop("update_package_option() ... done")) } ## Nothing to do? value <- getOption(name, NULL) if (!force && !is.null(value)) return(getOption(name, default = default)) ## name="pkg.foo.bar" => env="R_PKG_FOO_BAR" env <- gsub(".", "_", toupper(name), fixed = TRUE) env <- paste("R_", env, sep = "") env_value <- value <- Sys.getenv(env, unset = NA_character_) ## Nothing to do? if (is.na(value)) { if (debug) mdebugf("Environment variable %s not set", sQuote(env)) if (!is.null(default)) setOption(name, default) return(getOption(name, default = default)) } if (debug) mdebugf("%s=%s", env, sQuote(value)) ## Trim? if (trim) value <- trim(value) ## Nothing to do? if (!nzchar(value)) { if (!is.null(default)) setOption(name, default) return(getOption(name, default = default)) } ## Split? if (!is.null(split)) { value <- strsplit(value, split = split, fixed = TRUE) value <- unlist(value, use.names = FALSE) if (trim) value <- trim(value) } ## Coerce? mode0 <- storage.mode(value) if (mode0 != mode) { suppressWarnings({ storage.mode(value) <- mode }) if (debug) { mdebugf("Coercing from %s to %s: %s", mode0, mode, commaq(value)) } } if (length(disallow) > 0) { if ("NA" %in% disallow) { if (any(is.na(value))) { stopf("Coercing environment variable %s=%s to %s would result in missing values for option %s: %s", sQuote(env), sQuote(env_value), sQuote(mode), sQuote(name), commaq(value)) } } if (is.numeric(value)) { if ("non-positive" %in% disallow) { if (any(value <= 0, na.rm = TRUE)) { stopf("Environment variable %s=%s specifies a non-positive value for option %s: %s", sQuote(env), sQuote(env_value), sQuote(name), commaq(value)) } } if ("negative" %in% disallow) { if (any(value < 0, na.rm = TRUE)) { stopf("Environment variable %s=%s specifies a negative value for option %s: %s", sQuote(env), sQuote(env_value), sQuote(name), commaq(value)) } } } } if (debug) { mdebugf("=> options(%s = %s) [n=%d, mode=%s]", dQuote(name), commaq(value), length(value), storage.mode(value)) } setOption(name, value) getOption(name, default = default) } ## Set package options based on environment variables update_package_options <- function(debug = FALSE) { ## WARNING: All but R option 'globals.debug' are internal options ## that may be changed or removed at anytime. update_package_option("globals.globalsOf.locals", mode = "logical", debug = debug) update_package_option("globals.selfassign", mode = "logical", debug = debug) update_package_option("globals.walkAST.onUnknownType", debug = debug) update_package_option("globals.debug.indent", mode = "character", default = " ", debug = debug) } globals/R/find_globals_conservative.R0000644000176200001440000000305014763342025017440 0ustar liggesusers## This function is equivalent to: ## fun <- as_function(expr, envir = envir, ...) ## codetools::findGlobals(fun, merge = TRUE) ## but we expand it here to make it more explicit ## what is going on. #' @importFrom codetools findLocalsList walkCode find_globals_conservative <- function(expr, envir, dotdotdot, ..., trace = FALSE) { objs <- character() enter <- function(type, v, e, w) { objs <<- c(objs, v) } if (is.function(expr)) { if (typeof(expr) != "closure") return(character(0L)) # e.g. `<-` fun <- expr w <- make_usage_collector(fun, name = "", enterGlobal = enter) if (trace) w <- inject_tracer_to_walker(w) collect_usage_function(fun, name = "", w, trace = trace) } else if (is.call(expr) && is.function(expr[[1]])) { ## AD HOC: Fixes https://github.com/HenrikBengtsson/globals/issues/60 for (e in list(expr[[1]], expr[-1])) { globals <- find_globals_conservative(expr = e, envir = envir, dotdotdot = dotdotdot, ..., trace = trace) if (length(globals) > 0) objs <- c(objs, globals) } } else { ## From codetools::findGlobals(): fun <- as_function(expr, envir = envir, ...) # codetools::collectUsage(fun, enterGlobal = enter) ## The latter becomes equivalent to (after cleanup): w <- make_usage_collector(fun, name = "", enterGlobal = enter) if (trace) w <- inject_tracer_to_walker(w) locals <- findLocalsList(list(expr)) for (name in locals) assign(name, value = TRUE, envir = w$env) walkCode(expr, w) } unique(objs) } globals/R/zzz.R0000644000176200001440000000135514763342025013070 0ustar liggesusers## covr: skip=all .onLoad <- function(libname, pkgname) { update_package_option("globals.debug", mode = "logical") debug <- getOption("globals.debug", FALSE) ## Set future options based on environment variables update_package_options(debug = debug) ## Memoize: Already here, when the package is loaded, record whether ## some packages are 'base' packages or not. ## Packages that most likely are 'base' packages: pkgs <- c("base", "compiler", "datasets", "graphics", "grDevices", "grid", "methods", "parallel", "splines", "stats", "stats4", "tcltk", "tools", "utils") ## This package and other packags already loaded (incl. it's dependencies) pkgs <- c(pkgs, pkgname, loadedNamespaces()) is_base_pkg(pkgs) } globals/R/where.R0000644000176200001440000000303715004026770013337 0ustar liggesusers## Emulates R internal findVar1mode() function ## https://svn.r-project.org/R/trunk/src/main/envir.c where <- function(x, where = -1, envir = if (missing(frame)) { if (where < 0) parent.frame(-where) else as.environment(where) } else sys.frame(frame), frame, mode = "any", inherits = TRUE) { ## Validate arguments stop_if_not(is.environment(envir)) stop_if_not(is.character(mode), length(mode) == 1L) inherits <- as.logical(inherits) stop_if_not(inherits %in% c(FALSE, TRUE)) debug <- isTRUE(getOption("globals.future")) if (debug) { mdebugf_push("where(%s, where = %d, envir = %s, mode = %s, inherits = %s) ...", sQuote(x), where, sQuote(envname(envir)), sQuote(mode), inherits) on.exit(mdebugf_pop("where(%s, where = %d, envir = %s, mode = %s, inherits = %s) ...", sQuote(x), where, sQuote(envname(envir)), sQuote(mode), inherits)) } ## Search env <- envir while (!identical(env, emptyenv())) { if (debug) mdebugf("searching %s: %s", sQuote(envname(env)), hpaste(sQuote(ls(envir = env, all.names = TRUE)))) if (exists(x, envir = env, mode = mode, inherits = FALSE)) { if (debug) mdebugf("+ found in location: %s", sQuote(envname(env))) return(env) } if (!inherits) { if (debug) mdebug("+ failed to locate: NULL") return(NULL) } env <- parent.env(env) } if (debug) mdebug("failed to locate: NULL") NULL } globals/R/find_globals_liberal.R0000644000176200001440000000207214763342025016345 0ustar liggesusers#' @importFrom codetools walkCode find_globals_liberal <- function(expr, envir, dotdotdot, ..., trace = FALSE) { objs <- character() enter <- function(type, v, e, w) { objs <<- c(objs, v) } if (is.function(expr)) { if (typeof(expr) != "closure") return(character(0L)) ## e.g. `<-` fun <- expr w <- make_usage_collector(fun, name = "", enterGlobal = enter) if (trace) w <- inject_tracer_to_walker(w) collect_usage_function(fun, name = "", w, trace = trace) } else if (is.call(expr) && is.function(expr[[1]])) { ## AD HOC: Fixes https://github.com/HenrikBengtsson/globals/issues/60 for (e in list(expr[[1]], expr[-1])) { globals <- find_globals_liberal(expr = e, envir = envir, dotdotdot = dotdotdot, ..., trace = trace) if (length(globals) > 0) objs <- c(objs, globals) } } else { fun <- as_function(expr, envir = envir, ...) w <- make_usage_collector(fun, name = "", enterGlobal = enter) if (trace) w <- inject_tracer_to_walker(w) walkCode(expr, w) } unique(objs) } globals/R/globalsOf.R0000644000176200001440000002043415004026770014135 0ustar liggesusers#' Get all global objects of an expression #' #' @param expr An R expression. #' #' @param envir The environment from where to search for globals. #' #' @param \ldots Not used. #' #' @param method A character string specifying what type of search algorithm #' to use. #' #' @param tweak An optional function that takes an expression #' and returns a tweaked expression. #' #' @param locals Should globals part of any "local" environment of #' a function be included or not? #' #' @param substitute If TRUE, the expression is \code{substitute()}:ed, #' otherwise not. #' #' @param mustExist If TRUE, an error is thrown if the object of the #' identified global cannot be located. Otherwise, the global #' is not returned. #' #' @param unlist If TRUE, a list of unique objects is returned. #' If FALSE, a list of \code{length(expr)} sublists. #' #' @param recursive If TRUE, globals that are closures (functions) and that #' exist outside of namespaces ("packages"), will be recursively #' scanned for globals. #' #' @param skip (internal) A list of globals not to be searched for #' additional globals. Ignored unless \code{recursive} is TRUE. #' #' @return \code{globalsOf()} returns a \link{Globals} object. #' #' @details #' There currently three strategies for identifying global objects. #' #' The \code{method = "ordered"} search method identifies globals such that #' a global variable preceding a local variable with the same name #' is not dropped (which the \code{"conservative"} method would). #' #' The \code{method = "conservative"} search method tries to keep the number #' of false positive to a minimum, i.e. the identified objects are #' most likely true global objects. At the same time, there is #' a risk that some true globals are not identified (see example). #' This search method returns the exact same result as the #' \code{\link[codetools]{findGlobals}()} function of the #' \pkg{codetools} package. #' #' The \code{method = "liberal"} search method tries to keep the #' true-positive ratio as high as possible, i.e. the true globals #' are most likely among the identified ones. At the same time, #' there is a risk that some false positives are also identified. #' #' The \code{method = "dfs"} search method identifies globals in #' the abstract syntax tree (AST) using a depth-first search, which #' better emulates how the R engine identifies global variables. #' #' With \code{recursive = TRUE}, globals part of locally defined #' functions will also be found, otherwise not. #' #' @example incl/globalsOf.R #' #' @seealso #' Internally, the \pkg{codetools} package is utilized for #' code inspections. #' #' @aliases findGlobals #' @export globalsOf <- function(expr, envir = parent.frame(), ..., method = c("ordered", "conservative", "liberal", "dfs"), tweak = NULL, locals = NA, substitute = FALSE, mustExist = TRUE, unlist = TRUE, recursive = TRUE, skip = NULL) { if (missing(method)) method <- method[1] method <- match.arg(method, choices = c("ordered", "conservative", "liberal", "dfs"), several.ok = TRUE) if (is.na(locals)) locals <- getOption("globals.globalsOf.locals", TRUE) stop_if_not(is.logical(locals), length(locals) == 1L, !is.na(locals)) if (substitute) expr <- substitute(expr) stop_if_not(is.null(skip) || is.list(skip)) debug <- isTRUE(getOption("globals.debug")) if (debug) { methods <- sprintf("'%s'", method) if (length(method) > 1) methods <- sprintf("c(%s)", paste(methods, collapse = ", ")) mdebugf_push("globalsOf(..., method = %s, mustExist = %s, unlist = %s, recursive = %s) ...", methods, mustExist, unlist, recursive) on.exit(mdebugf_pop("globalsOf(..., method = %s, mustExist = %s, unlist = %s, recursive = %s) ... done", methods, mustExist, unlist, recursive)) } ## 1. Identify global variables (static code inspection) names <- findGlobals(expr, envir = envir, ..., method = method, tweak = tweak, substitute = FALSE, unlist = unlist) if (debug) mdebugf("preliminary globals (by name): [%d] %s", length(names), hpaste(sQuote(names))) ## 2. Locate them (run time) globals <- tryCatch({ globalsByName(names, envir = envir, mustExist = mustExist) }, error = function(ex) { ## HACK: Tweak error message to also include the expression inspected. msg <- conditionMessage(ex) msg <- sprintf("Identified global objects via static code inspection (%s). %s", hexpr(expr), msg) #nolint ex$message <- msg stop(ex) }) if (debug) mdebugf("preliminary globals (by value): [%d] %s", length(globals), hpaste(sQuote(names(globals)))) ## If a function, drop any globals that are part of any of the functions ## local environments, e.g. 'a' in f <- local({ a <- 1; function() a }) if (!locals && is.function(expr) && length(globals) > 0) { env <- environment(expr) ## the environment of the function eenv <- emptyenv() genv <- globalenv() where <- attr(globals, "where", exact = TRUE) while (length(where) > 0 && !identical(env, eenv) && !identical(env, genv)) { ## Any 'where' for the current environment? keep <- !vapply(where, FUN.VALUE = FALSE, FUN = identical, env) where <- where[keep] env <- parent.env(env) } ## Anything to drop? if (length(where) != length(globals)) globals <- globals[names(where)] } ## 3. Among globals that are closures (functions) and that exist outside ## of namespaces ("packages"), check for additional globals? if (recursive) { if (debug) mdebug_push("recursive scan of preliminary globals ...") ## Don't enter functions in namespaces / packages where <- attr(globals, "where", exact = TRUE) stop_if_not(length(where) == length(globals)) where <- vapply(where, FUN = envname, FUN.VALUE = NA_character_, USE.NAMES = FALSE) globals_t <- globals[!(where %in% loadedNamespaces())] if (debug) mdebugf("subset of globals to be scanned (not in loaded namespaces): [%d] %s", length(globals_t), hpaste(sQuote(names(globals_t)))) #nolint ## Enter only functions ## NOTE: This excludes functions "not found", but also primitives ## not dropped above. globals_t <- globals_t[vapply(globals_t, FUN = typeof, FUN.VALUE = NA_character_, USE.NAMES = FALSE) == "closure"] if (length(globals_t) > 0) { if (debug) mdebugf("subset of globals to be scanned: [%d] %s", length(globals_t), hpaste(sQuote(names(globals_t)))) names_t <- names(globals_t) ## Avoid recursive scanning of already scanned ("known") globals skip_t <- c(skip, globals_t) for (gg in seq_along(globals_t)) { if (debug) mdebugf("+ scanning global #%d (%s) ...", gg, sQuote(names_t[[gg]])) fcn <- globals_t[[gg]] ## Is function 'fcn' among the already identified globals? already_scanned <- any(vapply(skip, FUN = identical, fcn, FUN.VALUE = NA, USE.NAMES = FALSE)) if (already_scanned) next; env <- environment(fcn) ## was 'env <- envir' in globals 0.8.0. globals_gg <- globalsOf(fcn, envir = env, ..., method = method, tweak = tweak, locals = locals, substitute = FALSE, mustExist = mustExist, unlist = unlist, recursive = recursive, skip = skip_t) if (length(globals_gg) > 0) { globals <- c(globals, globals_gg) skip_gg <- globals_gg[vapply(globals_gg, FUN = typeof, FUN.VALUE = NA_character_, USE.NAMES = FALSE) == "closure"] skip_t <- c(skip_t, skip_gg) } } globals <- unique(globals) if (debug) mdebugf("updated set of globals found: [%d] %s", length(globals), hpaste(sQuote(names(globals)))) } else { if (debug) mdebug("subset of globals to be scanned: [0]") } if (debug) mdebug_pop("recursive scan of preliminary globals ... done") } if (debug) mdebugf("globals found: [%d] %s", length(globals), hpaste(sQuote(names(globals)))) globals } ## globalsOf() globals/R/utils,conditions.R0000644000176200001440000000051314777644360015550 0ustar liggesusersstopf <- function(fmt, ..., call. = TRUE, domain = NULL) { #nolint msg <- sprintf(fmt, ...) msg <- .makeMessage(msg, domain = domain) if (is.call(call.)) { call <- call. } else if (isTRUE(call)) { call <- sys.call(which = -1L) } else { call <- NULL } cond <- simpleError(msg, call = call) stop(cond) } globals/R/cleanup.R0000644000176200001440000000601214777644360013671 0ustar liggesusers#' @export cleanup <- function(...) UseMethod("cleanup") #' Drop certain types of globals #' #' @param globals A Globals object. #' @param drop A character vector specifying what type of globals to drop. #' @param \ldots Not used #' #' @aliases cleanup #' @export cleanup.Globals <- function(globals, drop = c("missing", "base-packages", "nativesymbolinfo"), ...) { where <- attr(globals, "where", exact = TRUE) names <- names(globals) keep <- rep(TRUE, times = length(globals)) names(keep) <- names ## Drop non-found objects drop_missing <- "missing" %in% drop ## Drop objects that are part of one of the "base" packages drop_base <- "base-packages" %in% drop ## Drop objects that are primitive functions drop_primitives <- "primitives" %in% drop ## Drop objects that calls .Internal() drop_internals <- "internals" %in% drop ## Drop objects that are of class NativeSymbolInfo used in calls ## to .Call(), .Call.graphics(), .External(), .External2(), and ## .External.graphics() drop_native_symbol_info <- "nativesymbolinfo" %in% drop for (name in names) { env <- where[[name]] if (drop_missing && is.null(env)) { keep[[name]] <- FALSE next } ## Never drop globals that are not in package environments. ## This will drop local copies of package objects, e.g. ## myView <- utils::View and format.aspell <- utils:::format.aspell if (is.environment(env) && !isPackageNamespace(env)) { next } env_name <- environmentName(env) env_name <- gsub("^package:", "", env_name) ## Never drop a global that is copy of an exported package object but ## has different name than the exported object. This avoids dropping ## local, renamed copies of package objects in a list, e.g. ## globals <- globals::as.Globals(list( ## identity = base::identity, ## my_identity = base::identity, ## should be kept ## print.aspell = utils:::print.aspell, ## should be kept ## my_print.aspell = utils:::print.aspell ## should be kept ## )) ## https://github.com/HenrikBengtsson/globals/issues/57 ## Is the global an exported package object? is_exported <- exists(name, envir = asPkgEnvironment(env_name)) if (is_exported && drop_base && is_base_pkg(env_name)) { keep[[name]] <- FALSE next } global <- globals[[name]] ## Example: base::rm() if (is_exported && drop_primitives && is.primitive(global)) { keep[[name]] <- FALSE next } ## Example: base::quit() if (is_exported && drop_internals && is_internal(global)) { keep[[name]] <- FALSE next } ## Is the the global a non-exported package object? is_private <- !is_exported && !is.null(env) && exists(name, envir = env) ## Example: base::.C_R_addTaskCallback if ((is_exported || is_private) && drop_native_symbol_info && is_native_symbol_info(global)) { keep[[name]] <- FALSE next } } if (!all(keep)) { globals <- globals[keep] } globals } globals/R/find_globals_ordered.R0000644000176200001440000002507315004026770016360 0ustar liggesusers#' @importFrom codetools walkCode find_globals_ordered <- function(expr, envir, dotdotdot, ..., name = character(), class = character(), trace = FALSE) { selfassign <- getOption("globals.selfassign", TRUE) ## Identified objects are recorded in (name, class), which ## are located in this executation environment enter_local <- function(type, v, e, w) { hardcoded_locals <- names(w$env) if (trace) { trace_msg <- trace_enter("enter_local(type=%s, v=%s)", sQuote(type), sQuote(v)) trace_printf("before:\n") trace_print(data.frame(name=name, class=class, stringsAsFactors = FALSE)) trace_printf("hardcoded locals: [n=%d] %s\n", length(hardcoded_locals), commaq(hardcoded_locals)) on.exit(local({ trace_printf("after:\n") trace_print(data.frame(name=name, class=class, stringsAsFactors = FALSE)) trace_exit(trace_msg) })) } is_already_local <- (v %in% hardcoded_locals) if (is_already_local) { if (trace) trace_printf("variable is a hardcoded local: %s\n", sQuote(v)) } ## LHS <- RHS: Handle cases where a global variable exists in RHS and LHS ## assigns a local variable with the same name, e.g. x <- x + 1. ## In such case we want to detect 'x' as a global variable. if (selfassign && (type == "<-" || type == "=")) { if (trace) trace_printf("LHS <- RHS:\n") rhs <- e[[3]] globals <- call_find_globals_with_dotdotdot(find_globals_ordered, expr = rhs, envir = w$env, dotdotdot = "ignore", trace = trace) if (trace) { trace_printf("RHS globals: [n=%d] %s\n", length(globals), commaq(globals)) trace_printf("hardcoded locals: [n=%d] %s\n", length(w$env), commaq(names(w$env))) } if (length(rhs) == 3 && globals[1] %in% c("::", ":::")) { ## Case: a <- pkg::a } else if (v %in% globals) { v_class <- if (v %in% hardcoded_locals) "local" else "global" if (trace) trace_printf("Add %s variable %s\n", sQuote(v_class), sQuote(v)) class <<- c(class, v_class) name <<- c(name, v) } } if (trace) trace_printf("Add %s variable %s\n", sQuote("local"), sQuote(v)) class <<- c(class, "local") name <<- c(name, v) } ## enter_local() enter_global <- function(type, v, e, w) { hardcoded_locals <- names(w$env) if (trace) { trace_msg <- trace_enter("enter_global(type=%s, v=%s)", sQuote(type), sQuote(v)) trace_printf("before:\n") trace_print(data.frame(name=name, class=class, stringsAsFactors = FALSE)) trace_printf("hardcoded locals: [n=%d] %s\n", length(hardcoded_locals), commaq(hardcoded_locals)) on.exit(local({ trace_printf("after:\n") trace_print(data.frame(name=name, class=class, stringsAsFactors = FALSE)) trace_exit(trace_msg) })) } is_already_local <- (v %in% hardcoded_locals) if (is_already_local) { if (trace) { trace_printf("variable is a hardcoded local: %s\n", sQuote(v)) } } v_class <- if (is_already_local) "local" else "global" if (trace) trace_printf("Add %s variable %s\n", sQuote(v_class), sQuote(v)) class <<- c(class, v_class) name <<- c(name, v) ## Also walk formulas to identify globals if (type == "function") { if (v == "~") { if (trace) trace_printf("type = ~ (formula)\n") stop_if_not(length(e) >= 2L, identical(e[[1]], as.symbol("~"))) ## Ignoring dots overrides the default of silently returning ## them from formulas ## Fixes https://github.com/HenrikBengtsson/globals/issues/63 if (dotdotdot == "ignore") { formula_dotdotdot <- "ignore" } else { formula_dotdotdot <- "return" } for (kk in 2:length(e)) { globals <- call_find_globals_with_dotdotdot(find_globals_ordered, expr = e[[kk]], envir = w$env, dotdotdot = formula_dotdotdot, trace = trace) if (length(globals) > 0) { if (trace) trace_printf("Add %s variables %s\n", sQuote("global"), commaq(globals)) class <<- c(class, rep("global", times = length(globals))) name <<- c(name, globals) } } } else if (selfassign && (v == "<-" || v == "=")) { ## LHS <- RHS: Handle cases where a global variable exists in LHS in ## the form of x[1] <- 0, which will cause 'x' to be called ## a local variable later unless called global here. if (trace) trace_printf("LHS <- RHS:\n") lhs <- e[[2]] if (length(lhs) >= 2) { ## Cases: a[1] <- 0, names(a) <- "x", names(a)[1] <- "x" ## Skip first symbol, because it'll be handled up later as ## an assignment function, e.g. `[<-` and `names<-` globals <- find_globals_ordered(expr = lhs, envir = w$env, dotdotdot = dotdotdot, name = hardcoded_locals, class = rep("local", times = length(hardcoded_locals)), trace = trace) if (length(globals) > 0) { if (trace) trace_printf("Add %s variables %s\n", sQuote("global"), commaq(globals)) class <<- c(class, rep("global", times = length(globals))) name <<- c(name, globals) } } } else { if (trace) trace_printf("=> A function, but not of interest\n") } } else { if (trace) trace_printf("=> Nothing to else to explore\n") } } ## enter_global() # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # Main # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - if (trace) { trace_msg <- trace_enter("find_globals_ordered()") on.exit(trace_exit(trace_msg)) } ## A function or an expression? if (is.function(expr)) { if (typeof(expr) != "closure") { if (trace) trace_printf("typeof != closure\n") return(character(0L)) ## e.g. `<-` } if (trace) trace_printf("type = function\n") fun <- expr w <- make_usage_collector(fun, name = "", enterLocal = enter_local, enterGlobal = enter_global) if (trace) w <- inject_tracer_to_walker(w) collect_usage_function(fun, name = "", w, trace = trace) } else if (is.expression(expr)) { if (trace) trace_printf("type = expression\n") } else if (is.call(expr) && is.function(expr[[1]])) { if (trace) trace_printf("type = a call to a function\n") ## AD HOC: Fixes https://github.com/HenrikBengtsson/globals/issues/60 for (e in list(expr[[1]], expr[-1])) { globals <- find_globals_ordered(expr = e, envir = envir, dotdotdot = dotdotdot, ..., trace = trace) if (length(globals) > 0) { class <- c(class, rep("global", times = length(globals))) name <- c(name, globals) } } } else if (is.call(expr) && is.symbol(expr[[1]]) && expr[[1]] == "{") { if (trace) trace_printf("type = {\n") class <- c(class, "global") name <- c(name, "{") nexpr <- length(expr) if (trace) trace_printf("length(expr) = %d\n", nexpr) if (nexpr >= 2) { for (kk in 2:nexpr) { e <- expr[[kk]] globals <- find_globals_ordered(expr = e, envir = envir, dotdotdot = dotdotdot, ..., trace = trace) if (length(globals) > 0) { if (trace) trace_printf("Add %s variable %s\n", sQuote("global"), commaq(globals)) class <- c(class, rep("global", times = length(globals))) name <- c(name, globals) } locals <- codetools::findLocals(e) if (length(locals) > 0) { if (trace) trace_printf("Add %s variable %s\n", sQuote("local"), commaq(locals)) class <- c(class, rep("locals", times = length(locals))) name <- c(name, locals) } } } } else { if (trace) trace_printf("type = call\n") if (trace) trace_printf("Convert to an anonymous function:\n") fun <- as_function(expr, envir = envir, ...) if (trace) trace_print(fun) w <- make_usage_collector(fun, name = "", enterLocal = enter_local, enterGlobal = enter_global) if (trace) w <- inject_tracer_to_walker(w) walkCode(expr, w) } if (trace) local({ trace_printf("variables (with duplicates):\n") trace_print(data.frame(name=name, class=class, stringsAsFactors = FALSE)) }) ## Drop duplicated names dups <- duplicated(name) class <- class[!dups] name <- name[!dups] if (trace) local({ trace_printf("variables (no duplicates):\n") trace_print(data.frame(name=name, class=class, stringsAsFactors = FALSE)) }) unique(name[class == "global"]) } call_find_globals_with_dotdotdot <- function(FUN, expr, envir, dotdotdot = "error", trace = FALSE, debug = FALSE) { if (trace) { trace_msg <- trace_enter("call_find_globals_with_dotdotdot(dotdotdot = %s)", sQuote(dotdotdot)) on.exit(trace_exit(trace_msg)) } ## Is there a need for global '...', '..1', '..2', etc.? dotdotdots <- character(0L) globals <- withCallingHandlers({ oopts <- options(warn = 0L) on.exit(options(oopts), add = TRUE) FUN(expr, envir = envir, dotdotdot = dotdotdot, trace = trace) }, warning = function(w) { ## Warned about '...', '..1', '..2', etc.? ## NOTE: The warning we're looking for is the one generated by ## codetools::findGlobals(). That warning is _not_ translated, ## meaning this approach should work as is as long as the message ## is not modified by codetools itself. If codetools ever changes ## this such that the below string matching fails, then the package ## tests (tests/dotdotdot.R) will detect that. In other words, ## such a change will not go unnoticed. /HB 2017-03-08 msg <- w$message pattern <- ".* ([.][.]([.]|[0-9]+)) may be used in an incorrect context.*" if (grepl(pattern, msg, fixed = FALSE)) { if (debug) mdebug("Warning message detected: %s", dQuote(trim(msg))) if (dotdotdot %in% c("ignore", "return", "warning")) { if (dotdotdot != "ignore") { dotdotdots <<- c(dotdotdots, gsub(pattern, "\\1", msg)) } if (dotdotdot != "warning") { ## Consume / muffle warning invokeRestart("muffleWarning") } } else if (dotdotdot == "error") { e <- simpleError(msg, w$call) stop(e) } } }) if (trace) { trace_printf("globals: [n=%d] %s\n", length(globals), commaq(globals)) } if (length(dotdotdots) > 0L) { dotdotdots <- unique(dotdotdots) if (trace) { trace_printf("dotdotdots: [n=%d] %s\n", length(dotdotdot), commaq(dotdotdots)) } globals <- c(globals, dotdotdots) } globals } globals/R/Globals-class.R0000644000176200001440000001336114777644360014735 0ustar liggesusers#' A representation of a set of globals #' #' @usage Globals(object, ...) #' #' @param object A named list. #' #' @param \ldots Not used. #' #' @return An object of class \code{Globals}, which is a \emph{named} list #' of the value of the globals, where the element names are the names of #' the globals. Attribute \code{where} is a named list of the same length #' and with the same names. #' #' @seealso #' The \code{\link{globalsOf}()} function identifies globals #' from an R expression and returns a Globals object. #' #' @aliases as.Globals as.Globals.Globals as.Globals.list [.Globals names #' @export Globals <- function(object = list(), ...) { if (!is.list(object)) { stopf("Argument 'object' is not a list: %s", class(object)[1]) } if (length(object) > 0) { names <- names(object) if (is.null(names)) { stop("Argument 'object' must be a named list.") } else if (!all(nzchar(names))) { stop("Argument 'object' specifies globals with empty names.") } } where <- attr(object, "where", exact = TRUE) if (length(object) == 0 && is.null(where)) { attr(object, "where") <- where <- list() } stop_if_not(is.list(where)) stop_if_not( is.list(where), length(where) == length(object), length(names(where)) == length(names(object)) ) structure(object, class = c("Globals", class(object))) } #' @export as.Globals <- function(x, ...) UseMethod("as.Globals") #' @export as.Globals.default <- function(x, ...) { stopf("Don't know how to coerce a %s to Globals", class(x)[1]) } #' @export as.Globals.Globals <- function(x, ...) x #' @export as.Globals.list <- function(x, ...) { if (length(x) > 0L) { stop_if_not(!is.null(names(x))) ## Use the globals environments as the locals? ## (with emptyenv() as the fallback) where <- attr(x, "where", exact = TRUE) if (is.null(where)) { where <- lapply(x, FUN = environment_of) names(where) <- names(x) attr(x, "where") <- where } } Globals(x, ...) } #' @export `names<-.Globals` <- function(x, value) { x <- NextMethod() where <- attr(x, "where", exact = TRUE) names(where) <- names(x) attr(x, "where") <- where invisible(x) } #' @export `[.Globals` <- function(x, i) { where <- attr(x, "where", exact = TRUE) res <- NextMethod() attr(res, "where") <- where[i] class(res) <- class(x) where <- attr(res, "where", exact = TRUE) stop_if_not( is.list(where), length(where) == length(res), length(names(where)) == length(names(res)) ) res } assign_Globals <- function(x, name, value) { stop_if_not(is.character(name), !is.na(name), nchar(name) > 0L) where <- attr(x, "where", exact = TRUE) stop_if_not(!is.null(where)) ## Remove an element? if (is.null(value)) { where[[name]] <- NULL } else { ## Value must be Globals object of length one if (inherits(value, "Globals")) { if (length(value) != 1) { stopf("Cannot assign Globals object of length different than one: %s", length(value)) } where[[name]] <- attr(value, "where", exact = TRUE)[[1]] value <- value[[1]] } else { where[[name]] <- environment_of(value) } } attr(x, "where") <- where ## Avoid call this function recursively class <- class(x) class(x) <- NULL x[[name]] <- value class(x) <- class invisible(x) } #' @export `[<-.Globals` <- function(x, names, value) { stop_if_not( length(names) == length(value), is.character(names), !anyNA(names), all(nchar(names) > 0) ) if (inherits(value, "Globals")) { where <- attr(value, "where") } else if (is.list(value)) { where <- lapply(value, FUN = environment_of) } else { stopf("Unsupported class of 'value': %s", class(value)[1]) } stop_if_not(length(where) == length(value)) x_where <- attr(x, "where", exact = TRUE) stop_if_not(!is.null(x_where)) class <- class(x) class(x) <- NULL attr(x, "where") <- NULL for (kk in seq_along(value)) { name <- names[kk] value_kk <- value[[kk]] if (is.null(value_kk)) { x[name] <- list(NULL) } else { x[[name]] <- value_kk } x_where[[name]] <- where[[kk]] } stop_if_not(length(x_where) == length(x)) attr(x, "where") <- x_where class(x) <- class invisible(x) } #' @export `$<-.Globals` <- function(x, name, value) { x <- assign_Globals(x, name = name, value = value) invisible(x) } #' @export `[[<-.Globals` <- function(x, name, value) { x <- assign_Globals(x, name = name, value = value) invisible(x) } #' @export c.Globals <- function(x, ...) { args <- list(...) where <- attr(x, "where", exact = TRUE) clazz <- class(x) class(x) <- NULL for (kk in seq_along(args)) { g <- args[[kk]] name <- names(args)[kk] if (inherits(g, "Globals")) { w <- attr(g, "where", exact = TRUE) } else if (is.list(g)) { ## Nothing to do? if (length(g) == 0) next names <- names(g) stop_if_not(!is.null(names)) w <- lapply(g, FUN = environment_of) names(w) <- names } else { if (is.null(name)) { stopf("Can only append named objects to Globals list: %s", sQuote(mode(g))) } e <- environment_of(g) g <- structure(list(g), names = name) w <- structure(list(e), names = name) } where <- c(where, w) x <- c(x, g) } attr(x, "where") <- where class(x) <- clazz stop_if_not( length(where) == length(x), all(names(where) == names(x)) ) x } #' @export unique.Globals <- function(x, ...) { names <- names(x) dups <- duplicated(names) if (any(dups)) { where <- attr(x, "where", exact = TRUE) where <- where[!dups] x <- x[!dups] attr(x, "where") <- where stop_if_not( length(where) == length(x), all(names(where) == names(x)) ) } x } globals/R/environment_of.R0000644000176200001440000000050714763342025015261 0ustar liggesusers# A safe version of base::environment() that returns emptyenv() # if NULL is passed, instead of the calling environment. # Related to https://github.com/HenrikBengtsson/globals/issues/79 environment_of <- function(obj) { if (is.null(obj)) return(emptyenv()) e <- environment(obj) if (is.null(e)) return(emptyenv()) e } globals/R/utils.R0000644000176200001440000002040715004026770013365 0ustar liggesusersas_function <- function(expr, envir = parent.frame(), enclos = baseenv(), ...) { fun_expr <- substitute(function() x, list(x = expr)) eval(fun_expr, envir = envir, enclos = enclos, ...) } # Although the set of "base" packages rarely changes, it has happened # in R's history. Beause of this, we avoid hardcoding the set of known # "base" packages and instead always look them up by the 'Priority' # field in their DESCRIPTION data and cache the results. #' @importFrom utils packageDescription is_base_pkg <- local({ cache <- list( R_EmptyEnv = FALSE, R_GlobalEnv = FALSE ) function(pkgs) { pkgs <- gsub("^package:", "", pkgs) npkgs <- length(pkgs) res <- rep(FALSE, times = npkgs) for (kk in seq_len(npkgs)) { pkg <- pkgs[kk] if (nzchar(pkg)) { value <- cache[[pkg]] if (is.null(value)) { prio <- suppressWarnings(packageDescription(pkg, fields = "Priority")) value <- (!is.na(prio) && prio == "base") cache[[pkg]] <<- value } } else { value <- FALSE } res[kk] <- value } res } }) # cf. is.primitive() is.base <- function(x) { if (typeof(x) != "closure") return(FALSE) is_base_pkg(environmentName(environment(x))) } # cf. is.primitive() is_internal <- function(x) { if (typeof(x) != "closure") return(FALSE) body <- deparse(body(x)) any(grepl(".Internal", body, fixed = TRUE)) } # Example: base::.C_R_removeTaskCallback is_native_symbol_info <- function(x) { if (!inherits(x, "NativeSymbolInfo")) return(FALSE) if (typeof(x) != "list") return(FALSE) address <- x$address if (!inherits(address, "RegisteredNativeSymbol")) return(FALSE) TRUE } isPackageNamespace <- function(env) { if (!is.environment(env)) return(FALSE) name <- environmentName(env) if (name == "base") return(TRUE) if (exists(".packageName", mode = "character", envir = env, inherits = FALSE)) { packageName <- get(".packageName", mode = "character", envir = env, inherits = FALSE) if (identical(name, packageName)) return(TRUE) } if (!grepl("^package:", name)) return(FALSE) (name %in% search()) } # From future 1.18.0 asPkgEnvironment <- function(pkg) { name <- sprintf("package:%s", pkg) if (!name %in% search()) return(emptyenv()) as.environment(name) } ## From R.utils 2.0.2 (2015-05-23) hpaste <- function(..., sep="", collapse=", ", last_collapse=NULL, max_head=if (missing(last_collapse)) 3 else Inf, max_tail=if (is.finite(max_head)) 1 else Inf, abbreviate="...") { max_head <- as.double(max_head) max_tail <- as.double(max_tail) if (is.null(last_collapse)) last_collapse <- collapse # Build vector 'x' x <- paste(..., sep = sep) n <- length(x) # Nothing todo? if (n == 0) return(x) if (is.null(collapse)) return(x) # Abbreviate? if (n > max_head + max_tail + 1) { head <- x[seq_len(max_head)] tail <- rev(rev(x)[seq_len(max_tail)]) x <- c(head, abbreviate, tail) n <- length(x) } if (!is.null(collapse) && n > 1) { if (last_collapse == collapse) { x <- paste(x, collapse = collapse) } else { x_head <- paste(x[1:(n - 1)], collapse = collapse) x <- paste(x_head, x[n], sep = last_collapse) } } x } ## From future 0.11.0 trim <- function(s) { sub("[\t\n\f\r ]+$", "", sub("^[\t\n\f\r ]+", "", s)) } # trim() ## From future 0.11.0 hexpr <- function(expr, trim = TRUE, collapse = "; ", max_head = 6L, max_tail = 3L, ...) { code <- deparse(expr) if (trim) code <- trim(code) hpaste(code, collapse = collapse, max_head = max_head, max_tail = max_tail, ...) } # hexpr() #' @importFrom utils capture.output envname <- function(env) { if (!is.environment(env)) return(NA_character_) name <- environmentName(env) if (name == "") { ## NOTE: I might be that: ## 1. 'env' is of a class that extends 'environment', e.g. ## R.oo::Object() or R6::R6Class(), or ## 2. another package defines print() for 'environment' ## Because of this, we call print.default() instead of generic print(). name <- capture.output(print.default(env)) if (length(name) > 1L) name <- name[1] name <- gsub("(.*: |>)", "", name) } else { ## e.g. globals:::where("plan") name <- gsub("package:", "", name, fixed = TRUE) } name } commaq <- function(x, sep = ", ") paste(sQuote(x), collapse = sep) if (getRversion() < "4.0.0") { ## When 'default' is specified, this is 30x faster than ## base::getOption(). The difference is that here we use ## use names(.Options) whereas in 'base' names(options()) ## is used. getOption <- local({ go <- base::getOption function(x, default = NULL) { if (missing(default) || match(x, table = names(.Options), nomatch = 0L) > 0L) go(x) else default } }) } stop_if_not <- function(...) { res <- list(...) n <- length(res) if (n == 0L) return() for (ii in 1L:n) { res_ii <- .subset2(res, ii) if (length(res_ii) != 1L || is.na(res_ii) || !res_ii) { mc <- match.call() call <- deparse(mc[[ii + 1]], width.cutoff = 60L) if (length(call) > 1L) call <- paste(call[1L], "...") stop(sQuote(call), " is not TRUE", call. = FALSE, domain = NA) } } } #' Gets the length of an object without dispatching #' #' @param x Any \R object. #' #' @return A non-negative integer. #' #' @details #' This function returns \code{length(unclass(x))}, but tries to avoid #' calling \code{unclass(x)} unless necessary. #' #' @seealso \code{\link{.subset}()} and \code{\link{.subset2}()}. #' #' @keywords internal #' @rdname private_length #' @importFrom utils getS3method .length <- function(x) { nx <- length(x) ## Can we trust base::length(x), i.e. is there a risk that there is ## a method that overrides with another definition? classes <- class(x) if (length(classes) == 1L && classes == "list") return(nx) ## Identify all length() methods for this object for (class in classes) { fun <- getS3method("length", class, optional = TRUE) if (!is.null(fun)) { nx <- length(unclass(x)) break } } nx } ## .length() ## An lapply(X) without internal X <- as.list(X), without setting names, ## and without dispatching using `[[`. list_apply <- function(X, subset = NULL, FUN, ...) { if (is.null(subset)) { n <- .length(X) } else { n <- length(subset) } res <- vector("list", length = n) if (is.environment(X)) { if (is.null(subset)) subset <- names(X) for (name in subset) { res[[name]] <- FUN(.subset2(X, name), ...) } } else { if (is.null(subset)) subset <- seq_len(n) for (kk in subset) { res[[kk]] <- FUN(.subset2(X, kk), ...) } } res } .trace <- new.env() .trace$indent <- 0L trace_indent <- function(x = "", indent = .trace$indent) { # utils::str(list(indent = indent)) # indent <- max(0L, indent) prefix <- paste(rep(" ", times = 3*indent), collapse = "") paste(prefix, x, sep = "") } trace_printf <- function(..., indent = .trace$indent, collapse = "\n", appendLF = FALSE) { msg <- sprintf(...) out <- trace_indent(msg, indent = indent) out <- paste(out, collapse = collapse) message(out, appendLF = appendLF) invisible(msg) } #' @importFrom utils capture.output trace_print <- function(..., envir = parent.frame(), indent = .trace$indent, collapse = "\n", appendLF = TRUE) { bfr <- eval(capture.output(print(...)), envir = envir) trace_printf(bfr, indent = indent, collapse = collapse, appendLF = appendLF) } #' @importFrom utils capture.output str trace_str <- function(..., envir = parent.frame(), indent = .trace$indent, collapse = "\n", appendLF = TRUE) { bfr <- eval(capture.output(str(...)), envir = envir) trace_printf(bfr, indent = indent, collapse = collapse, appendLF = appendLF) } trace_enter <- function(..., appendLF = TRUE) { msg <- trace_printf(..., appendLF = FALSE) message(" ...", appendLF = appendLF) .trace$indent <- .trace$indent + 1L attr(msg, "indent") <- .trace$indent invisible(msg) } trace_exit <- function(fmtstr, ..., appendLF = TRUE) { indent <- attr(fmtstr, "indent") if (!is.null(indent)) .trace$indent <- indent .trace$indent <- .trace$indent - 1L msg <- trace_printf(fmtstr, ..., appendLF = FALSE) message(" ... done", appendLF = appendLF) # stop_if_not(.trace$indent >= 0L) invisible(msg) } globals/R/utils-debug.R0000644000176200001440000000514215006157343014453 0ustar liggesusersnow <- function(x = Sys.time(), format = "[%H:%M:%OS3] ") { ## format(x, format = format) ## slower format(as.POSIXlt(x, tz = ""), format = format) } debug_indent <- local({ symbols <- rep(c("|", ":", ".", "'", ",", ";", "`"), times = 10L) function() { depth <- length(.debug[["stack"]]) if (depth == 0) return("") indent <- getOption("globals.debug.indent", " ") paste(paste(symbols[seq_len(depth)], indent, sep = ""), collapse = "") } }) if (!exists(".debug", inherits = FALSE)) .debug <- new.env(parent = emptyenv()) if (!"stack" %in% names(".debug")) .debug$stack <- list() mdebug_push <- function(..., debug = isTRUE(getOption("globals.debug"))) { if (!debug) return() msg <- mdebug(..., debug = debug) .debug$stack <- c(.debug$stack, msg) invisible(msg) } mdebugf_push <- function(..., debug = isTRUE(getOption("globals.debug"))) { if (!debug) return() msg <- mdebugf(..., debug = debug) .debug$stack <- c(.debug$stack, msg) invisible(msg) } mdebug_pop <- function(..., debug = isTRUE(getOption("globals.debug"))) { if (!debug) return() n <- length(.debug$stack) msg <- .debug$stack[n] .debug$stack <- .debug$stack[-n] mdebug(sprintf("%s done", msg), debug = debug) } mdebugf_pop <- function(..., debug = isTRUE(getOption("globals.debug"))) { if (!debug) return() n <- length(.debug$stack) msg <- .debug$stack[n] .debug$stack <- .debug$stack[-n] mdebug(sprintf("%s done", msg), debug = debug) } mdebug <- function(..., prefix = now(), debug = isTRUE(getOption("globals.debug"))) { if (!debug) return() prefix <- paste(prefix, debug_indent(), sep = "") msg <- paste(..., sep = "") message(sprintf("%s%s", prefix, msg)) invisible(msg) } mdebugf <- function(..., appendLF = TRUE, prefix = now(), debug = isTRUE(getOption("globals.debug"))) { if (!debug) return() prefix <- paste(prefix, debug_indent(), sep = "") msg <- sprintf(...) message(sprintf("%s%s", prefix, msg), appendLF = appendLF) invisible(msg) } #' @importFrom utils capture.output mprint <- function(..., appendLF = TRUE, prefix = now(), debug = isTRUE(getOption("globals.debug"))) { if (!debug) return() prefix <- paste(prefix, debug_indent(), sep = "") message(paste(prefix, capture.output(print(...)), sep = "", collapse = "\n"), appendLF = appendLF) } #' @importFrom utils capture.output str mstr <- function(..., appendLF = TRUE, prefix = now(), debug = isTRUE(getOption("globals.debug"))) { if (!debug) return() prefix <- paste(prefix, debug_indent(), sep = "") message(paste(prefix, capture.output(str(...)), sep = "", collapse = "\n"), appendLF = appendLF) } globals/R/globalsByName.R0000644000176200001440000000774015004026770014751 0ustar liggesusers#' Locates and retrieves a set of global variables by their names #' #' @param names A character vector of global variable names. #' #' @param envir The environment from where to search for globals. #" #' @param mustExist If TRUE, an error is thrown if the object of the #' identified global cannot be located. Otherwise, the global #' is not returned. #' #' @param \ldots Not used. #' #' @section Special "argument" globals: #' If `names` specifies `"..."`, `"..1"`, `"..2"`, ..., then they #' are interpreted as arguments `...`, `..1`, `..2`, ..., respectively. #' If specified, then the corresponding elements in the results are #' lists of class `DotDotDotList` comprising the value of the latter. #' If the special argument does not exist, then the value is `NA`, and #' the corresponding `where` attributes is `NULL`. #' #' @return A \link{Globals} object of named elements and an attribute #' `where` with named elements. Both of sets have names according to #' `names`. #' #' @example incl/globalsByName.R #' #' @export globalsByName <- function(names, envir = parent.frame(), mustExist = TRUE, ...) { names <- as.character(names) nnames <- length(names) namesOrg <- names debug <- isTRUE(getOption("globals.debug")) if (debug) { info <- hpaste(sprintf('"%s"', names)) if (nnames > 1L) info <- sprintf("<%s> [n=%d]", info, nnames) info <- sprintf("%s, mustExist = %s", info, mustExist) mdebugf_push("globalsByName(%s) ...", info) mdebug("search from environment: %s", sQuote(envname(envir))) on.exit(mdebugf_pop("globalsByName(%s) ... done", info)) } ## Locate and retrieve the specified globals idxs <- grep("^[.][.]([.]|[0-9]+)$", names) if (length(idxs) > 0L) { dotdotdots <- unique(names[idxs]) names <- names[-idxs] idxs <- NULL if (debug) mdebugf("dotdotdots: %s", commaq(dotdotdots)) } else { dotdotdots <- NULL if (debug) mdebug("dotdotdots: ") } globals <- structure(vector("list", length = nnames), names = namesOrg) where <- structure(vector("list", length = nnames), names = namesOrg) for (kk in seq_along(names)) { name <- names[kk] if (debug) mdebugf("locating #%d (%s)", kk, sQuote(name)) env <- where(name, envir = envir, inherits = TRUE) if (debug) mdebugf("+ found in environment: %s", sQuote(envname(env))) if (!is.null(env)) { where[[name]] <- env value <- get(name, envir = env, inherits = FALSE) if (is.null(value)) { globals[name] <- list(NULL) } else { globals[[name]] <- value } } else { globals[name] <- list(NULL) where[name] <- list(NULL) if (mustExist) { stop(sprintf("Failed to locate global object in the relevant environments: %s", sQuote(name))) #nolint } } } if (length(dotdotdots) > 0L) { where... <- NULL has... <- exists("...", envir = envir, inherits = TRUE) if (has...) { where... <- where("...", envir = envir, inherits = TRUE) } for (name in dotdotdots) { where[name] <- list(where...) ## FIXME: If '...' in environment 'envir' specifies non-existing ## symbols, then we must not call list(...), list(..1), etc., ## because that will produce an "object not found" error. ## /HB 2023-05-19 if (has...) { expr <- substitute(list(arg), list(arg = as.name(name))) ddd <- eval(expr, envir = envir, enclos = envir) } else { ddd <- NA } class(ddd) <- c("DotDotDotList", class(ddd)) globals[[name]] <- ddd } } stop_if_not( length(names(globals)) == nnames, all(names(globals) %in% namesOrg), identical(names(globals), namesOrg) ) stop_if_not( is.list(where), length(where) == length(globals), all(names(where) == names(globals)) ) attr(globals, "where") <- where class(globals) <- c("Globals", class(globals)) if (debug) { mdebug("Globals collected:") mstr(globals) } globals } ## globalsByName() globals/R/walkAST.R0000644000176200001440000000701515005424660013534 0ustar liggesusers#' Walk the Abstract Syntax Tree (AST) of an R Expression #' #' @param expr R \link[base]{expression}. #' @param atomic,name,call,pairlist single-argument function that takes an #' atomic, name, call and pairlist expression, respectively. Have to #' return a valid R expression. #' @param substitute If TRUE, \code{expr} is #' \code{\link[base]{substitute}()}:ed. #' #' @return R \link[base]{expression}. #' #' @export #' @keywords programming internal walkAST <- function(expr, atomic = NULL, name = NULL, call = NULL, pairlist = NULL, substitute = FALSE) { if (substitute) expr <- substitute(expr) if (is.atomic(expr)) { if (is.function(atomic)) expr <- atomic(expr) } else if (is.name(expr)) { if (is.function(name)) expr <- name(expr) } else if (is.call(expr)) { ## message("call") for (cc in seq_along(expr)) { ## AD HOC: The following is needed to handle x[, 1]. /HB 2016-09-06 if (is.name(expr[[cc]]) && expr[[cc]] == "") next e <- walkAST(expr[[cc]], atomic = atomic, name = name, call = call, pairlist = pairlist, substitute = FALSE) if (is.null(e)) { expr[cc] <- list(NULL) } else { expr[[cc]] <- e } } if (is.function(call)) expr <- call(expr) } else if (is.pairlist(expr)) { ## message("pairlist") for (pp in seq_along(expr)) { ## AD HOC: The following is needed to handle '...'. /HB 2016-09-06 if (is.name(expr[[pp]]) && expr[[pp]] == "") next e <- walkAST(expr[[pp]], atomic = atomic, name = name, call = call, pairlist = pairlist, substitute = FALSE) if (is.null(e)) { expr[pp] <- list(NULL) } else { expr[[pp]] <- e } } ## WORKAROUND: Since expr[i] <- list(NULL) turns pairlist 'expr' into ## a list we have to make sure to it is a pairlist also afterward, cf. ## https://stat.ethz.ch/pipermail/r-devel/2016-October/073263.html ## /HB 2016-10-12 expr <- as.pairlist(expr) } else if (is.list(expr)) { ## FIXME: Should we have a specific function for this, or is atomic() ok? ## https://github.com/HenrikBengtsson/globals/issues/27 if (is.function(atomic)) expr <- atomic(expr) } else if (typeof(expr) == "closure") { body <- body(expr) body <- walkAST(body, atomic = atomic, name = name, call = call, pairlist = pairlist, substitute = FALSE) body(expr) <- body } else if (typeof(expr) %in% c("builtin", "environment", "expression", "externalptr", "S4", "special", "object")) { ## Nothing to do ## FIXME: ... or can specials be "walked"? /HB 2017-03-21 ## FIXME: Should "promise", "char", "...", "any", "externalptr", ## "bytecode", and "weakref" (cf. ?typeof) also be added? /2017-07-01 return(expr) } else { msg <- paste("Cannot walk expression. Unknown object type", sQuote(typeof(expr))) onUnknownType <- getOption("globals.walkAST.onUnknownType", "error") if (onUnknownType == "error") { stop(msg, call. = FALSE) } else if (onUnknownType == "warning") { warning(msg, call. = FALSE) } ## Skip below assertion return(expr) } ## Assert that the tweak functions return a valid object if (!missing(expr)) { stop_if_not(is.atomic(expr) || is.list(expr) || is.name(expr) || is.call(expr) || is.pairlist(expr) || typeof(expr) %in% c("builtin", "closure", "special")) } expr } ## walkAST() globals/R/packagesOf.R0000644000176200001440000000270614777644360014313 0ustar liggesusers#' @export packagesOf <- function(...) UseMethod("packagesOf") #' Identify the packages of the globals #' #' @param globals A Globals object. #' @param \ldots Not used. #' #' @return Returns a character vector of package names. #' #' @aliases packagesOf #' @export packagesOf.Globals <- function(globals, ...) { ## Scan 'globals' for which packages they are from. This information is ## in the name of the environment as given by the 'where' attribute with ## a fallback to the global object. where <- attr(globals, "where") pkgs <- rep(NA_character_, times = length(globals)) for (kk in seq_along(globals)) { obj <- globals[[kk]] env <- environment_of(obj) ## If not found, it could be an object in package without a closure if (identical(env, emptyenv())) { w <- where[[kk]] if (is.environment(w)) { pkg <- environmentName(w) if (grepl("^package:", pkg)) pkg <- sub("^package:", "", pkg) } else { pkg <- environmentName(env) } } else { pkg <- environmentName(env) } pkgs[kk] <- pkg } ## Drop "missing" packages, e.g. globals in globalenv(). pkgs <- pkgs[nzchar(pkgs)] ## Drop global environment pkgs <- pkgs[pkgs != "R_GlobalEnv"] ## Keep only names matching loaded namespaces pkgs <- intersect(pkgs, loadedNamespaces()) ## Packages to be loaded pkgs <- unique(pkgs) ## Sanity check stop_if_not(all(nzchar(pkgs))) pkgs } # packagesOf() globals/R/utils,codetools-bugfix.R0000644000176200001440000000271614777644360016663 0ustar liggesusers# Dynamically check if the 'codetools' bug has been fixed hasCodetoolsBug16 <- local({ hasBug <- NA function() { if (is.na(hasBug)) { ## Construct function with the bug, without triggering the ## bug when 'R CMD check' runs f <- eval(quote(function() NULL %% `$<-`(NULL, NULL))) hasBug <<- tryCatch({ codetools::findGlobals(f) FALSE }, error = function(ex) TRUE) } hasBug } }) # This tweaks the future expression to work around a bug [1,2] in the # 'codetools' package affecting expression for format: # # LHS INFIX_OPERATOR `$<-`(name, value) # # [1] https://github.com/futureverse/globals/issues/94 # [2] https://gitlab.com/luke-tierney/codetools/-/issues/16 tweakCodetoolsBug16 <- function(expr) { if (!is.call(expr)) return(expr) expr <- unclass(expr) op <- expr[[1]] if (!is.symbol(op)) return(expr) ## An infix operator? op <- as.character(op) if (!grepl("^%[^%]*%$", op)) return(expr) n <- length(expr) if (n != 3) return(expr) ## Can this every happen? rhs <- expr[[3]] ## Is RHS a call? if (!is.call(rhs)) return(expr) ## Is RHS a call to `$<-`? rhs_op <- rhs[[1]] if (!is.symbol(rhs_op)) return(expr) if (rhs_op != as.name("$<-")) return(expr) ## Replace `$<-` with something unique, e.g. `codetools.bugfix16:::$<-` rhs <- as.list(rhs) rhs[[1]] <- as.name("codetools.bugfix16:::$<-") rhs <- as.call(rhs) expr[[3]] <- rhs expr } ## tweakCodetoolsBug16() globals/NAMESPACE0000644000176200001440000000133214372744677013140 0ustar liggesusers# Generated by roxygen2: do not edit by hand S3method("$<-",Globals) S3method("[",Globals) S3method("[<-",Globals) S3method("[[<-",Globals) S3method("names<-",Globals) S3method(as.Globals,Globals) S3method(as.Globals,default) S3method(as.Globals,list) S3method(c,Globals) S3method(cleanup,Globals) S3method(packagesOf,Globals) S3method(unique,Globals) export(Globals) export(as.Globals) export(cleanup) export(findGlobals) export(globalsByName) export(globalsOf) export(packagesOf) export(walkAST) importFrom(codetools,findLocalsList) importFrom(codetools,makeUsageCollector) importFrom(codetools,walkCode) importFrom(utils,capture.output) importFrom(utils,getS3method) importFrom(utils,packageDescription) importFrom(utils,str) globals/NEWS.md0000644000176200001440000003540315007060724013001 0ustar liggesusers# Version 0.18.0 [2025-05-06] ## New Features * Add `findGlobals(..., method = "dfs")`, which finds globals in R expressions by walking its abstract syntax tree (AST) using depth-first search. This new approach does a better job in emulating how the R engine identifies global variables. For example, the new `"dfs"` method picks up `x` in `local({ function(x) x; x })` as a global variable, which the `"ordered"` method fails to do. Analogously, `globalsOf()` gained support for `method = "dfs"` * Now `findGlobals()` supports `expression` objects, e.g. `findGlobals(expression(x + y))`. * It is now possible to specify multiple `method` search algorithms for `findGlobals()` and `globalsOf()`, which then will combine the results from all of them, e.g. `findGlobals(expr, method = c("dfs", "ordered"))`. ## Bug Fixes * `walkAST()` did not recognize objects of type `externalptr`, leading to an error on `Cannot walk expression. Unknown object type 'externalptr'`. # Version 0.17.0 [2025-04-15] ## New Features * `walkAST()` now walks also the body of closures ("functions"). ## Bug Fixes * `walkAST()` did not recognize objects of type `object`, leading to an error on `Cannot walk expression. Unknown object type 'object'`. * `findGlobals()` would produce `Error in e[[4]] : subscript out of expressions of format` for expressions of type ``LHS INFIX_OP `$<-`(name, value)``, e.g. ``x %>% `$<-`("a", 42)``. This is due to a bug in the **codetools** package, which `findGlobals()` now works around internally. # Version 0.16.3 [2024-03-07] ## Bug Fixes * `globalsByName()`, and therefore also `globalsOf()`, did not support special arguments `..1`, `..2`, etc. * `cleanup(globals, drop)` on a `Globals` object with non-existing globals and where `drop` did _not_ specify `"missing"` would throw an `Error in exists(name, envir = env) : use of NULL environment is defunct`. Now the non-existing ("missing") globals are preserved. # Version 0.16.2 [2022-11-21] ## Documentation * Drop duplicated arguments from `help("walkAST")`. # Version 0.16.1 [2022-08-28] ## Bug Fixes * `packagesOf()` for `Globals` failed to return the package of the globals if the global doesn't have a closure, e.g. `base::pi` and `data.table::.N`. # Version 0.16.0 [2022-08-05] ## New Features * Add `[[<-` and `[<-` for `Globals`, to complement `$<-`. ## Reproducibility * All functions modifying a `Globals` object guarantee that the `where` and the `class` attributes are always the last two attributes and in that order. ## Bug Fixes * `c()` for `Globals` would lose the `where` environment for any functions appended. # Version 0.15.1 [2022-06-24] ## Bug Fixes * `cleanup()` assumed it was safe to call `env$.packageName` on each scanned environment, but that might not be true. A classed environment could be such that `$()` gives an error, rather than returning something. # Version 0.15.0 [2022-05-08] ## New Features * `globalsOf()` gained argument `locals`, which controls whether globals that exist in "local" environments of a function should be considered or not, e.g. in `f <- local({ a <- 1; function() a })`, should `a` be considered a global of `f()` or not. For backward compatibility reasons, the default is `locals = TRUE`, but this might become `locals = FALSE` in a later release. * Any `globals.*` options specific to this packages can now be set via environment variables `R_GLOBALS_*` when the package is loaded. For example, `R_GLOBALS_DEBUG=true` sets option `globals.debug = TRUE`. ## Bug Fixes * `as.Globals(list(a = NULL))` and `c(Globals(), list(a = NULL))` would include the calling environment instead of an empty environment as part of the `where` attribute. # Version 0.14.0 [2020-11-22] ## New Features * Now `findGlobals(function(x) x <- x)` identifies `x` as a global variable. * Now `findGlobals(function(x) x[1] <- 0)` identifies `x` as a global variable. Same for other variants like `x[[1]] <- 0` and `x$a <- 0`. * Now `findGlobals(function(z) x <- z$x)` identifies `x` as a global variable. * Now `findGlobals(quote({ f <- function(x) x; x }))` identifies `x` as a global variable. Previously, the `x` of the function would hide the global `x`. # Version 0.13.1 [2020-10-11] ## Bug Fixes * `globalsOf()` could produce "Error in vapply(where, FUN = envname, FUN.VALUE = NA_character_, USE.NAMES = FALSE) : values must be length 1, but FUN(X[[2]]) result is length 10". This would happen if for instance argument `envir` has attributes set. * `findGlobals()` works around a bug in `stats:::[.formula` of R (< 4.1.0) that revealed itself when scanning formulas with NULL components. * `findGlobals()` would not pass down argument `dotdotdot` when recursively parsing assignments. * `findGlobals()` could return `...` as a global also when used in formulas. Now it respects argument `dotdotdot = "ignore"` and parses formulas accordingly, otherwise formulas will be parsed using `dotdotdot = "return"`. # Version 0.13.0 [2020-09-16] ## Significant Changes * `findGlobals(expr)` now also scans any attributes of `expr` for globals, e.g. `purrr::partial()` puts the original function in attribute `body`. Argument `attributes` controls which attributes, if any, should be scanned. Default is to scan all attributes. * `findGlobals()`, `globalsOf()`, and `globalsByName()` now recognizes and returns values for `..1`, `..2`, etc. like they do for `...`. * `cleanup()` now also drop exported and non-exported `NativeSymbolInfo` objects. ## New Features * `cleanup()` gained support for dropping `NativeSymbolInfo` objects. ## Bug Fixes * `findGlobals()` did not pass down argument `method` in recursive calls. * `findGlobals(expr)` would fail to identify globals in anonymous function calls, e.g. `expr <- as.call(list(function(...) NOT_FOUND, quote(FOUND)))`. * Calls like `findGlobals(~ NULL)` with NULLs on the right-hand side could throw "Error in if (length(ans) == 0L || as.character(ans[[1L]])[1L] == "~") { : missing value where TRUE/FALSE needed". Solved by working around what looks like a bug in the **stats** package causing subsetting on formulas with NULLs to fail. * `cleanup(..., drop = c(..., "base-packages"))` for `Globals` would drop base R objects with names not exported by the corresponding base R package. Similarly, `drop = c(..., "primitive")` would drop primitive R objects with names not exported by any base R package. * `findGlobals()`, `globalsOf()`, and `globalsByName()` did not handle `..1`, `..2`, etc. * `findGlobals()` and `globalsOf()` produces warnings on ': ... may be used in an incorrect context' when formulas had `...`, `..1`, `..2`, etc. * `findGlobals(function() NULL, substitute = TRUE, trace = TRUE)` would throw "Error in environment(w$enterLocal) : object 'w' not found". # Version 0.12.5 [2019-12-07] ## Bug Fixes * `findGlobals(function() { a; a <- a + 1 })` would fail to identify `a` as a global variable whereas it was properly identified with `{ a <- a + 1; a }`. # Version 0.12.4 [2018-10-11] ## Bug Fixes * `globalsOf()` could produce "Error in vapply(where, FUN = envname, FUN.VALUE = NA_character_, USE.NAMES = FALSE) : values must be length 1, but FUN(X[[...]]) result is length ...". This was because the internal `envname(env)` did not always handle when `class(env) != "environment"`. # Version 0.12.3 [2018-09-16] ## New Features * `findGlobals()`, `globalsOf()`, and `packagesOf()` no longer return elements sorted by name. ## Bug Fixes * globals::`findGlobals()` would not identify `a` as a global in expressions of type `a[1] = ...` and `names(a) = ...` although it did for `a[1] <- ...` and `names(a) <- ...`. # Version 0.12.2 [2018-08-25] ## Performance * `cleanup()` for `Globals` should now be much faster. Previously, it could be very slow the first time it was called in a fresh R session, especially if the user had a large number of packages installed and/or the package libraries were on slow drives. ## Documentation * Added help for `globals::findGlobals()`. ## Bug Fixes * `globals::findGlobals(x)`, where `x` is a list, iterated over `x` incorrectly assuming no method dispatching on `x` would take place. For instance, if `x` contained an `fst::fst_table` object, then "Error in .subset2(x, i, exact = exact) : subscript out of bounds" would be produced. * globals::`findGlobals()` could produce a "Warning in is.na(x): is.na() applied to non-(list or vector) of type 'NULL'" in R (< 3.5.0). # Version 0.12.1 [2018-06-24] ## Performance * globals::`findGlobals()` is now significantly faster for elements that are long lists with many elements of basic data types. This is because elements of such basic data type cannot contain globals and can therefore be skipped early in the search for globals. # Version 0.12.0 [2018-06-12] ## New Features * Now globals::`findGlobals()` identifies `a` as a global also when it is part of LHS expressions of type `a[1] <- ...` and `names(a) <- ...`. ## Bug Fixes * globals::`findGlobals()` incorrectly identified `a` as a global in expression of type `a <- pkg::a`. * If `...` was passed to `globalsByName(names)`, an error would be produced unless it was the last entry in `names`. # Version 0.11.0 [2018-01-09] ## New Features * Now `findGlobals()` identifies `x` as a global variable in `x <- x + 1` and likewise for `x + 1 -> x`. Note that ditto using `<<-` and `->>` was already identifying `x` as a global. ## Bug Fixes * `findGlobals(..., trace = TRUE)` now outputs only to standard error. Previously, some of the output went to standard output. # Version 0.10.3 [2017-10-12] ## Bug Fixes * `globalsOf(..., recursive = TRUE)` would result in "Error in match.fun(FUN) : node stack overflow" if one of the globals identified was a function that called itself recursively (either directly or indirectly). # Version 0.10.2 [2017-08-08] ## Bug Fixes * `walkAST()` could produce error "Cannot walk expression. Unknown object type '...'" for objects of type `environment`. # Version 0.10.1 [2017-07-01] ## Bug Fixes * `walkAST()` could produce error "Cannot walk expression. Unknown object type '...'" for objects of type `list`, `expression` and `S4`. # Version 0.10.0 [2017-04-16] ## New Features * Globals that are part of a formula are now identified. * `findGlobals(..., trace = TRUE)` will now show low-level parse information as the abstract syntax tree (AST) is walked. SOFTWARE QUALITY: * Enabled more internal sanity checks. ## Bug Fixes * `walkAST()` could produce error "Cannot walk expression. Unknown object type 'nnn'" for expressions of type `builtin`, `closure` and `special`. # Version 0.9.0 [2017-03-09] ## New Features * Added option `globals.debug`, which when TRUE enables debugging output. ## Bug Fixes * `globalsOf(..., recursive = TRUE)` would in some cases scan an incorrect subset of already identified globals. * `globalsOf(..., recursive = TRUE)` failed to skip objects part of package namespaces that where defined via a `local()` statement. # Version 0.8.0 [2017-01-14] ## New Features * `globalsOf()` identifies also globals in locally defined functions. This can be disabled with argument `recursive = FALSE`. * `findGlobals()` now takes both closures (functions) and expressions. # Version 0.7.2 [2016-12-28] ## Bug Fixes * `c(x, list())` where `x` is a `Globals` object would give an error reporting that the list does not have named elements. # Version 0.7.1 [2016-10-13] ## New Features * `Globals()` and `as.Globals()` now accepts an empty list as input as well. ## Bug Fixes * `walkAST(quote( function(x=NULL) 0 ))` would give a sanity check error due to the NULL argument. Thank you GitHub user 'billy34' for reporting on this. # Version 0.7.0 [2016-09-08] ## New Features * Added `walkAST()`, which can be used to tweak expressions. * Added `globalsByName()` for locating and retrieving a set of known global variables. * Added `c()`, `$<-()`, `names()`, `unique()` for `Globals` objects. * Improved `as.Globals()` for lists. # Version 0.6.1 [2016-01-31] ## New Features * Now the error message of `globalsOf(..., mustExist = TRUE)` when it fails to locate a global also gives information on the expression that is problematic. ## Bug Fixes * `cleanup()` for `Globals` did not cleanup functions in core package environments named `package:`. # Version 0.6.0 [2015-12-12] ## New Features * `findGlobals()` is updated to handle the case where a local variable is overwriting a global one with the same name, e.g. `{ a <- b; b <- 1 }`. Now `b` is correctly identified as a global object. Previously it would have been missed. For backward compatibility, the previous behavior can be obtained using argument `method = "conservative"`. # Version 0.5.0 [2015-10-13] ## New Features * `globalsOf()` now returns attribute `where` specifying where each global object is located. ## Bug Fixes * `cleanup()` now only drops objects that are *located* in one of the "base" packages; previously it would also drop copies of such objects, e.g. `FUN <- base::sample`. # Version 0.4.1 [2015-10-05] ## Bug Fixes * `globalsOf()` failed to return global variables with value NULL. They were identified but silently dropped. # Version 0.4.0 [2015-09-12] ## New Features * `findGlobals()` and `globalsOf()` gained argument `dotdotdot`. # Version 0.3.1 [2015-06-10] * More test coverage. # Version 0.3.0 [2015-06-08] ## New Features * Renamed `getGlobals()` to `globalsOf()`. # Version 0.2.3 [2015-06-08] ## New Features * Added `[()` for `Globals`. * `findGlobals()` and `getGlobals()` gained argument `substitute`. * Added `cleanup(..., method = "internals")`. # Version 0.2.2 [2015-05-20] ## New Features * Added `Globals` class with methods `cleanup()` and `packagesOf()`. * Added `as.Globals()` to coerce lists to `Globals` objects. # Version 0.2.1 [2015-05-20] ## New Features * `getGlobals()` gained argument `mustExist` for controlling whether to give an error when the corresponding object for an identified global cannot be found or to silently drop the missing global. * `findGlobals()` and `getGlobals()` gained argument `method` for controlling whether a `"conservative"` or a `"liberal"` algorithm for identifying true globals should be used. # Version 0.2.0 [2015-05-19] * Moved "globals" functions from an in-house package to this package. # Version 0.1.0 [2015-02-07] * Created. globals/inst/0000755000176200001440000000000014777644367012703 5ustar liggesusersglobals/inst/testme/0000755000176200001440000000000015007060724014154 5ustar liggesusersglobals/inst/testme/test-globalsByName.R0000644000176200001440000000547214777644360020024 0ustar liggesuserslibrary(globals) message("*** globalsByName() ...") globals_c <- globalsByName(c("{", "<-", "c", "d")) str(globals_c) assert_identical_sets(names(globals_c), c("{", "<-", "c", "d")) globals_c <- cleanup(globals_c) str(globals_c) assert_identical_sets(names(globals_c), c("c", "d")) where <- attr(globals_c, "where") stopifnot( length(where) == length(globals_c), identical(where$c, globalenv()), identical(where$d, globalenv()) ) foo <- globals::Globals globals <- globalsByName(c("{", "foo", "list"), recursive = FALSE) str(globals) assert_identical_sets(names(globals), c("{", "foo", "list")) where <- attr(globals, "where") stopifnot(length(where) == length(globals)) if (!covr) stopifnot( identical(where$`{`, baseenv()), identical(where$foo, globalenv()), identical(where$list, baseenv()) ) globals <- cleanup(globals) str(globals) assert_identical_sets(names(globals), c("foo")) globals <- cleanup(globals, drop = "internals") str(globals) assert_identical_sets(names(globals), c("foo")) pkgs <- packagesOf(globals) stopifnot(pkgs == "globals") ## Also '...' myGlobals <- function(x, ...) { globalsByName(c("a", "x", "...")) } globals <- myGlobals(x = 2, y = 3, z = 4) str(globals) assert_identical_sets(names(globals), c("a", "x", "...")) assert_identical_sets(names(globals[["..."]]), c("y", "z")) ## And '..1', '..2', etc. myGlobals <- function(x, ...) { globalsByName(c("a", "x", "..1", "..2")) } globals <- myGlobals(x = 2, y = 3, 4) str(globals) assert_identical_sets(names(globals), c("a", "x", "..1", "..2")) stopifnot( globals[["..1"]] == 3, globals[["..2"]] == 4 ) ## BUG FIX: Assert that '...' does not have to be specified at the end myGlobals <- function(x, ...) { globalsByName(c("a", "...", "x")) } globals <- myGlobals(x = 2, y = 3, z = 4) str(globals) assert_identical_sets(names(globals), c("a", "x", "...")) assert_identical_sets(names(globals[["..."]]), c("y", "z")) ## Test with arguments defaulting to other arguments myGlobals <- function(x, y, z = y) { globalsByName(c("a", "x", "y", "z")) } globals <- myGlobals(x = 2, y = 3) assert_identical_sets(names(globals), c("a", "x", "y", "z")) stopifnot(globals$y == 3, identical(globals$z, globals$y)) globals <- myGlobals(x = 2, y = 3, z = 4) assert_identical_sets(names(globals), c("a", "x", "y", "z")) stopifnot(globals$y == 3, globals$z == 4) myGlobals <- function(x, ...) { globalsByName(c("a", "x", "...")) } globals <- myGlobals(x = 2, y = 3) assert_identical_sets(names(globals), c("a", "x", "...")) assert_identical_sets(names(globals[["..."]]), c("y")) stopifnot(globals[["..."]]$y == 3) globals <- myGlobals(x = 2, y = 3, z = 4) assert_identical_sets(names(globals), c("a", "x", "...")) assert_identical_sets(names(globals[["..."]]), c("y", "z")) stopifnot(globals[["..."]]$y == 3, globals[["..."]]$z == 4) message("*** globalsByName() ... DONE") globals/inst/testme/test-utils.R0000644000176200001440000001063114777644360016436 0ustar liggesuserslibrary(globals) message("*** utils ...") message("- envname() ...") name <- envname(NULL) print(name) stopifnot(is.character(name), length(name) == 1L, is.na(name)) env <- new.env() print(env) name <- utils::capture.output(print(env)) stopifnot(is.character(name), length(name) == 1L) name <- envname(env) print(name) stopifnot(is.character(name), length(name) == 1L, !is.na(name), class(env) == "environment") env <- structure(new.env(), class = "foo") print.foo <- function(x, ...) { str(as.list(letters[1:3])); invisible(x) } print(env) name <- utils::capture.output(print(env)) stopifnot(is.character(name), length(name) > 1L) name <- envname(env) print(name) stopifnot(is.character(name), length(name) == 1L, !is.na(name), class(env) == "foo") env <- structure(new.env(), handlers = "foo") print(env) name <- utils::capture.output(print(env)) stopifnot(is.character(name), length(name) > 1L) name <- envname(env) print(name) stopifnot(is.character(name), length(name) == 1L, !is.na(name)) message("- envname() ... DONE") message("* hpaste() ...") printf <- function(...) cat(sprintf(...)) hpaste <- globals:::hpaste # Some vectors x <- 1:6 y <- 10:1 z <- LETTERS[x] # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # Abbreviation of output vector # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - printf("x = %s.\n", hpaste(x)) ## x = 1, 2, 3, ..., 6. printf("x = %s.\n", hpaste(x, max_head = 2)) ## x = 1, 2, ..., 6. printf("x = %s.\n", hpaste(x, max_head = 3)) # Default ## x = 1, 2, 3, ..., 6. # It will never output 1, 2, 3, 4, ..., 6 printf("x = %s.\n", hpaste(x, max_head = 4)) ## x = 1, 2, 3, 4, 5 and 6. # Showing the tail printf("x = %s.\n", hpaste(x, max_head = 1, max_tail = 2)) ## x = 1, ..., 5, 6. # Turning off abbreviation printf("y = %s.\n", hpaste(y, max_head = Inf)) ## y = 10, 9, 8, 7, 6, 5, 4, 3, 2, 1 ## ...or simply printf("y = %s.\n", paste(y, collapse = ", ")) ## y = 10, 9, 8, 7, 6, 5, 4, 3, 2, 1 # Change last separator printf("x = %s.\n", hpaste(x, last_collapse = " and ")) ## x = 1, 2, 3, 4, 5 and 6. # No collapse stopifnot(all(hpaste(x, collapse = NULL) == x)) # Empty input stopifnot(identical(hpaste(character(0)), character(0))) message("* hpaste() ... DONE") message("* as_function() ...") fcn <- as_function({ 1 }) print(fcn()) stopifnot(fcn() == 1) message("* is_base_pkg() ...") base_pkgs <- c("base") for (pkg in base_pkgs) { stopifnot(is_base_pkg(pkg)) } stopifnot(!is_base_pkg("globals")) message("* isPackageNamespace() ... Bug #80") `$.strict_env` <- function(x, name) get(name, envir = x, inherits = FALSE) env <- structure(new.env(), class = "strict_env") res <- globals:::isPackageNamespace(env) stopifnot(!res) message("* is.base() & is_internal() ...") stopifnot(is.base(base::library)) stopifnot(!is.base(globals::globalsOf)) stopifnot(!is.base(NULL)) stopifnot(is_internal(print.default)) stopifnot(!is_internal(globals::globalsOf)) stopifnot(!is_internal(NULL)) message("* where() ...") env <- where("sample", where = 1L) str(env) env <- where("sample", frame = 1L) str(env) message("- where('sample') ...") env <- where("sample", mode = "function") print(env) if (!"covr" %in% loadedNamespaces()) { stopifnot(identical(env, baseenv())) } obj <- get("sample", mode = "function", envir = env, inherits = FALSE) stopifnot(identical(obj, base::sample)) message("- where('sample', mode = 'integer') ...") env <- where("sample", mode = "integer") print(env) stopifnot(is.null(env)) message("- where('sample2') ...") sample2 <- base::sample env <- where("sample2", mode = "function") print(env) stopifnot(identical(env, environment())) obj <- get("sample2", mode = "function", envir = env, inherits = FALSE) stopifnot(identical(obj, sample2)) message("- where() - objects inside functions ...") aa <- 1 foo <- function() { bb <- 2 #nolint list(aa = where("aa"), bb = where("bb"), cc = where("cc"), envir = environment()) } envs <- foo() str(envs) stopifnot(identical(envs$aa, globalenv())) stopifnot(identical(envs$bb, envs$envir)) stopifnot(is.null(envs$cc)) message("- where() - missing ...") env <- where("non-existing-object", inherits = FALSE) stopifnot(is.null(env)) rm(list = c("aa", "envs", "foo", "env", "obj", "where")) message("* where() ... DONE") message("- mdebug() ...") mdebug("Message A") oopts <- options(globals.debug = TRUE) mdebug("Message B") options(oopts) message("* mdebug() ... DONE") message("*** utils ... DONE") globals/inst/testme/test-conservative.R0000644000176200001440000000361714777644360020014 0ustar liggesuserslibrary(globals) ## WORKAROUND: Avoid problem reported in testthat Issue #229, which ## causes covr::package_coverage() to given an error. /HB 2015-02-16 suppressWarnings({ rm(list = c("a", "b", "c", "x", "y", "z", "square", "pathname", "url", "filename")) }) message("Setting up expressions") exprs <- list( A = quote({ Sys.sleep(1) x <- 0.1 }), B = quote({ y <- 0.2 }), C = quote({ z <- a + 0.3 }), D = quote({ pathname <- file.path(dirname(url), filename) }), E = quote({ b <- c }), F = quote({ a <- { runif(1) } b <- { rnorm(1) } x <- a * b abs(x) }), G = quote({ y <- square(a) }), H = quote({ b <- a a <- 1 }) ) atleast <- list( A = c(), B = c(), C = c("a"), D = c("filename"), E = c("c"), F = c(), G = c("a", "square"), H = c() ## FIXME: Should be c("a"), cf. Issue #5. ) not <- list( A = c("x"), B = c("y"), C = c("z"), D = c("pathname"), E = c("b"), F = c("a", "b", "x"), G = c(), H = c() ) ## Define globals a <- 3.14 c <- 2.71 square <- function(x) x ^ 2 filename <- "index.html" # Yes, pretend we forget 'url' message("Find globals") for (kk in seq_along(exprs)) { key <- names(exprs)[kk] expr <- exprs[[key]] cat(sprintf("Expression #%d ('%s'):\n", kk, key)) print(expr) names <- findGlobals(expr, method = "conservative") cat(sprintf("Globals: %s\n", paste(sQuote(names), collapse = ", "))) stopifnot(all(atleast[[key]] %in% names)) stopifnot(!any(names %in% not[[key]])) globals <- globalsOf(expr, method = "conservative") cat(sprintf("Globals: %s\n", paste(sQuote(names(globals)), collapse = ", "))) stopifnot(all(atleast[[key]] %in% names(globals))) stopifnot(!any(names(globals) %in% not[[key]])) str(globals) cat("\n") } names <- findGlobals(exprs, method = "conservative", unlist = TRUE) cat(sprintf("Globals: %s\n", paste(sQuote(names), collapse = ", "))) ## Cleanup globals/inst/testme/test-cleanup.R0000644000176200001440000000363514777644360016733 0ustar liggesuserslibrary(globals) message("*** cleanup() ...") message("- cleanup() with remapped base functions") ## Don't clean out renamed base functions ## https://github.com/HenrikBengtsson/globals/issues/57 globals <- list( my_fcn = function(x) x, ## should not be deleted identity = base::identity, my_identity = base::identity ## should not be deleted ) expected <- c("my_fcn", "my_identity") ## Add an example of an internal/non-exported package object from 'utils'. ## Such objects need to be kept because they will not be on the search path ## even if the package is attached ns <- asNamespace("utils") pkg <- as.environment("package:utils") internals <- setdiff(ls(ns, all.names = TRUE), ls(pkg, all.names = TRUE)) internals <- grep("^print", internals, value = TRUE) if (length(internals) > 0L) { name <- internals[1] obj <- get(name, envir = ns, inherits = FALSE) stopifnot(!exists(name, envir = pkg, inherits = FALSE)) globals[[name]] <- obj expected <- c(expected, name) name <- sprintf("my-%s", name) globals[[name]] <- obj expected <- c(expected, name) } globals <- as.Globals(globals) str(globals) globals <- cleanup(globals) str(globals) assert_identical_sets(names(globals), expected) message("- cleanup() with missing globals") rm(list = "b") expr <- quote(a <- b) print(expr) globals <- globalsOf(expr, mustExist = FALSE) str(globals) stopifnot(identical(names(globals), c("<-", "b"))) message("- cleanup(globals) with missing globals") pruned <- cleanup(globals) str(pruned) stopifnot(length(pruned) == 0L) message("- cleanup(globals, drop = 'missing') with missing globals") pruned <- cleanup(globals, drop = "missing") str(pruned) stopifnot(identical(names(pruned), c("<-"))) message("- cleanup(globals, drop = 'base-packages') with missing globals") pruned <- cleanup(globals, drop = "base-packages") str(pruned) stopifnot(identical(names(pruned), c("b"))) message("*** cleanup() ... DONE") globals/inst/testme/run.R0000755000176200001440000001721015004026770015107 0ustar liggesusers#!/usr/bin/env Rscript #' Run a 'testme' Test Script #' #' R usage: #' future::testme("") #' #' Command-line usage: #' Rscript tests/test-.R #' #' Command-line usage without package re-install: #' Rscript inst/testme/run.R --name= cmd_args <- commandArgs(trailingOnly = TRUE) pattern <- "--package=([[:alpha:][:alnum:]]+)" idx <- grep(pattern, cmd_args) if (length(idx) > 0L) { stopifnot(length(idx) == 1L) testme_package <- gsub(pattern, "\\1", cmd_args[idx]) cmd_args <- cmd_args[-idx] } else { testme_package <- Sys.getenv("R_TESTME_PACKAGE", NA_character_) if (is.na(testme_package)) { desc <- read.dcf("DESCRIPTION") testme_package <- desc[1, "Package"] } } pattern <- "--path=([[:alpha:][:alnum:]]+)" idx <- grep(pattern, cmd_args) if (length(idx) > 0L) { stopifnot(length(idx) == 1L) path <- gsub(pattern, "\\1", cmd_args[idx]) cmd_args <- cmd_args[-idx] } else { path <- Sys.getenv("R_TESTME_PATH", NA_character_) if (is.na(path)) { path <- file.path("inst", "testme") } if (!utils::file_test("-d", path)) { stop("There exist no such 'R_TESTME_PATH' folder: ", sQuote(path)) } } Sys.setenv(R_TESTME_PATH = path) pattern <- "--name=([[:alpha:][:alnum:]]+)" idx <- grep(pattern, cmd_args) if (length(idx) > 0L) { stopifnot(length(idx) == 1L) testme_name <- gsub(pattern, "\\1", cmd_args[idx]) cmd_args <- cmd_args[-idx] } else { testme_name <- NULL } ## Fallback for 'testme_name'? if (is.null(testme_name)) { if (length(cmd_args) > 0) { stopifnot(length(cmd_args) == 1L) file <- cmd_args[1] if (utils::file_test("-f", file)) { testme_name <- gsub("(^test-|[.]R$)", "", basename(file)) } else { stop("No such file: ", file) } } else { testme_name <- Sys.getenv("R_TESTME_NAME", NA_character_) if (is.na(testme_name)) { stop("testme: Environment variable 'R_TESTME_NAME' is not set") } } } testme_file <- file.path(path, sprintf("test-%s.R", testme_name)) if (!utils::file_test("-f", testme_file)) { stop("There exist no such 'testme' file: ", sQuote(testme_file)) } ## ----------------------------------------------------------------- ## testme environment ## ----------------------------------------------------------------- on_cran <- function() { not_cran <- Sys.getenv("NOT_CRAN", NA_character_) if (is.na(not_cran)) { not_cran <- FALSE } else { not_cran <- isTRUE(as.logical(not_cran)) } !interactive() && !not_cran } ## on_cran() ## Get test script tags tags <- local({ lines <- readLines(testme_file, warn = FALSE) pattern <- "^#'[[:blank:]]+@tags[[:blank:]]+" lines <- grep(pattern, lines, value = TRUE) tags <- sub(pattern, "", lines) tags }) if (length(tags) > 0) { tags <- sub("[[:blank:]]*$", "", tags) tags <- unlist(strsplit(tags, split = "[[:blank:]]+")) tags <- sort(unique(tags)) } else { tags <- character(0L) } ## Create 'testme' environment on the search() path testme_config <- list( package = testme_package, name = testme_name, tags = tags, status = "created", start = proc.time(), script = testme_file, on_cran = on_cran(), debug = isTRUE(as.logical(Sys.getenv("R_TESTME_DEBUG"))) ) if ("testme" %in% search()) detach(name = "testme") testme <- attach(testme_config, name = "testme", warn.conflicts = FALSE) rm(list = c("tags", "testme_package", "testme_name", "testme_file")) ## ----------------------------------------------------------------- ## Filters ## ----------------------------------------------------------------- ## Skip on CRAN? To run these tests, set env var NOT_CRAN=true if ("skip_on_cran" %in% tags && on_cran()) { testme[["status"]] <- "skipped" } code <- Sys.getenv("R_TESTME_FILTER_NAME", NA_character_) if (!is.na(code)) { expr <- tryCatch(parse(text = code), error = identity) if (inherits(expr, "error")) { stop("Syntax error in R_TESTME_FILTER_NAME: ", sQuote(code)) } keep <- tryCatch(eval(expr, envir = testme), error = identity) if (inherits(keep, "error")) { stop("Evaluation of R_TESTME_FILTER_NAME=%s produced an error: %s", sQuote(code), conditionMessage(keep)) } if (!isTRUE(keep)) testme[["status"]] <- "skipped" } code <- Sys.getenv("R_TESTME_FILTER_TAGS", NA_character_) if (!is.na(code)) { expr <- tryCatch(parse(text = code), error = identity) if (inherits(expr, "error")) { stop("Syntax error in R_TESTME_FILTER_TAGS: ", sQuote(code)) } keep <- tryCatch(eval(expr, envir = testme), error = identity) if (inherits(keep, "error")) { stop("Evaluation of R_TESTME_FILTER_TAGS=%s produced an error: %s", sQuote(code), conditionMessage(keep)) } if (!isTRUE(keep)) testme[["status"]] <- "skipped" } message(sprintf("Test %s ...", sQuote(testme[["name"]]))) if (testme[["debug"]]) { message("testme:") message(paste(utils::capture.output(utils::str(as.list(testme))), collapse = "\n")) } ## Process prologue scripts, if they exist if (testme[["status"]] != "skipped" && utils::file_test("-d", file.path(path, "_prologue"))) { testme[["status"]] <- "prologue" local({ ## Find all prologue scripts files <- dir(file.path(path, "_prologue"), pattern = "*[.]R$", full.names = TRUE) files <- sort(files) testme[["prologue_scripts"]] <- files ## Source all prologue scripts inside the 'testme' environment expr <- quote({ files <- prologue_scripts message(sprintf("Sourcing %d prologue scripts ...", length(files))) for (kk in seq_along(files)) { file <- files[kk] message(sprintf("%02d/%02d prologue script %s", kk, length(files), sQuote(file))) source(file, local = TRUE) } message(sprintf("Sourcing %d prologue scripts ... done", length(files))) rm(list = c("kk", "file", "files")) }) eval(expr, envir = testme) }) # ## In case prologue scripts overwrote some elements in 'testme' # for (name in names(testme_config)) { # testme[[name]] <- testme_config[[name]] # } } ## Run test script ## Note, prologue scripts may trigger test to be skipped if (testme[["status"]] != "skipped") { message("Running test script: ", sQuote(testme[["script"]])) testme[["status"]] <- "failed" source(testme[["script"]], echo = TRUE) testme[["status"]] <- "success" # ## In case test script overwrote some elements in 'testme' # for (name in names(testme_config)) { # testme[[name]] <- testme_config[[name]] # } } ## Process epilogue scripts, if they exist ## Note, epilogue scripts may change status or produce check errors if (testme[["status"]] == "success" && utils::file_test("-d", file.path(path, "_epilogue"))) { testme[["status"]] <- "epilogue" local({ ## Find all epilogue scripts files <- dir(file.path(path, "_epilogue"), pattern = "*[.]R$", full.names = TRUE) files <- sort(files) testme[["epilogue_scripts"]] <- files ## Source all epilogue scripts inside the 'testme' environment expr <- quote({ files <- epilogue_scripts message(sprintf("Sourcing %d epilogue scripts ...", length(files))) for (kk in seq_along(files)) { file <- files[kk] message(sprintf("%02d/%02d epilogue script %s", kk, length(files), sQuote(file))) source(file, local = TRUE) } message(sprintf("Sourcing %d epilogue scripts ... done", length(files))) rm(list = c("kk", "file", "files")) }) eval(expr, envir = testme) }) testme[["status"]] <- "success" } testme[["stop"]] <- proc.time() dt <- testme[["stop"]] - testme[["start"]] dt_str <- sprintf("%s=%.1gs", names(dt), dt) message("Test time: ", paste(dt_str, collapse = ", ")) message(sprintf("Test %s ... %s", sQuote(testme[["name"]]), testme[["status"]])) if ("testme" %in% search()) detach(name = "testme") globals/inst/testme/test-walkAST.R0000644000176200001440000000577714777644360016623 0ustar liggesuserslibrary(globals) message("*** walkAST() ...") exprs <- list( null = quote(NULL), atomic = quote(1), atomic = quote("a"), atomic = quote(TRUE), assign = quote(a <- 1), assign = quote(1 -> a), assign = quote(a <- b + 1), assign = quote(x <- rnorm(20, mu = 0)), index = quote(x[1, 1]), index = quote(x[1:2, 1:2]), index = quote(x[, 1:2]), index = quote(x[, 1]), fcn = quote(function(a = 1, b = 2) sum(c(a, b))), fcn = quote(function(a = 1, b) sum(c(a, b))), fcn = quote(function(a = 1, b = 2, ...) sum(c(a, b, ...))), fcn = quote(function(a = NULL) a), ok = quote(function(...) sum(x, ...)), warn = quote(sum(x, ...)), null = quote(NULL), builtin = base::length, closure = function() NULL, closure = function() a, closure = function(x = 0) a * x, special = base::log, list = substitute(FUN(a = A), list(A = list())), pairlist = substitute(FUN(a = A), list(A = pairlist(a = 1))), expression = substitute(FUN(a = A), list(A = expression())) # environment = new.env() ) if (requireNamespace("methods")) { exprs$s4 <- methods::getClass("MethodDefinition") exprs$s7 <- asS3(methods::getClass("S4")@prototype, complete = FALSE) } nullify <- function(e) NULL disp <- function(expr) { cat("Expression:\n") print(expr) cat("str():\n") try(str(expr)) cat(sprintf("typeof: %s\n", typeof(expr))) if (is.recursive(expr)) { cat("as.list():\n") str(as.list(expr)) } expr } ## disp() for (kk in seq_along(exprs)) { name <- names(exprs)[kk] message(sprintf("- walkAST() ...", kk, sQuote(name))) expr <- exprs[[kk]] disp(expr) ## Assert identity (default behavior) expr_i <- walkAST(expr) disp(expr_i) stopifnot(length(expr_i) == length(expr), identical(expr_i, expr)) ## Display the AST tree walkAST(expr, atomic = disp, name = disp, call = disp, pairlist = disp) ## Nullify expr_n <- walkAST(expr, atomic = nullify, name = nullify, call = nullify, pairlist = nullify) disp(expr_n) message("*** walkAST() - nullify ... DONE") message(sprintf("- walkAST() ... DONE", kk, sQuote(name))) } ## for (name ...) message("*** walkAST() - substitute = TRUE ...") expr <- walkAST(a <- 1, substitute = TRUE) print(expr) message("*** walkAST() - substitute = TRUE ... DONE") message("*** walkAST() - exceptions ...") f <- function(...) get("...") expr <- f(NULL) options(globals.walkAST.onUnknownType = "error") res <- tryCatch({ walkAST(expr) }, error = identity) print(res) stopifnot(inherits(res, "simpleError")) options(globals.walkAST.onUnknownType = "warning") foo <- walkAST(expr) res <- tryCatch({ walkAST(expr) }, warning = identity) print(res) stopifnot(inherits(res, "simpleWarning")) options(globals.walkAST.onUnknownType = "error") message("*** walkAST() - exceptions ... DONE") message("*** walkAST() ... DONE") globals/inst/testme/test-Globals.R0000644000176200001440000002460314777644360016665 0ustar liggesuserslibrary(globals) assert_attributes <- function(globals) { attrs <- attributes(globals) names <- names(attrs) stopifnot( length(attrs) >= 2L, "class" %in% names, "where" %in% names, ## 'where' and 'class' should be the last two (reproducibility) names[length(names) - 1L] == "where", names[length(names) ] == "class", inherits(globals, "Globals") ) invisible(TRUE) } a <- 1 b <- 2 message("*** Globals() ...") globals0 <- globalsByName(c("a", "rnorm")) globals <- globals0 str(globals) where <- attr(globals, "where") stopifnot( assert_attributes(globals), length(globals) == 2L, length(where) == length(globals), all(names(globals) == c("a", "rnorm")), all(names(globals) == names(where)) ) message("*** Globals() - names ...") globals <- globals0 str(globals) where <- attr(globals, "where") stopifnot( assert_attributes(globals), length(globals) == 2L, length(where) == length(globals), all(names(globals) == c(names(globals0))), all(names(globals) == names(where)) ) names(globals)[1] <- "A" str(globals) where <- attr(globals, "where") stopifnot( assert_attributes(globals), length(globals) == 2L, length(where) == length(globals), all(names(globals) == c("A", names(globals0)[-1])), all(names(globals) == names(where)) ) message("*** Globals() - names ... DONE") message("*** Globals() - subsetting ...") globals <- globals0[1] str(globals) where <- attr(globals, "where") stopifnot( assert_attributes(globals), length(globals) == 1L, length(where) == length(globals), all(names(globals) == c("a")), all(names(globals) == names(where)) ) globals <- globals0[2] str(globals) where <- attr(globals, "where") stopifnot( assert_attributes(globals), length(globals) == 1L, length(where) == length(globals), all(names(globals) == c("rnorm")), all(names(globals) == names(where)) ) globals <- globals0[2:1] str(globals) where <- attr(globals, "where") stopifnot( assert_attributes(globals), length(globals) == 2L, length(where) == length(globals), all(names(globals) == c("rnorm", "a")), all(names(globals) == names(where)) ) ## rev() works automatically thanks to `[`() :) globals <- rev(globals0) str(globals) where <- attr(globals, "where") stopifnot( assert_attributes(globals), length(globals) == 2L, length(where) == length(globals), all(names(globals) == rev(names(globals0))), all(names(globals) == names(where)), identical(rev(globals), globals0) ) message("*** Globals() - subsetting ... DONE") message("*** Globals() - subsetted assignment ...") message("1.") globals <- globals0 globals$a <- globals0["a"] str(globals) where <- attr(globals, "where") stopifnot( assert_attributes(globals), length(globals) == 2L, length(where) == length(globals), all(names(globals) == names(globals0)), all(names(globals) == names(where)), identical(globals, globals0) ) message("2.") globals <- globals0 globals[["a"]] <- globals0["a"] str(globals) where <- attr(globals, "where") stopifnot( assert_attributes(globals), length(globals) == 2L, length(where) == length(globals), all(names(globals) == names(globals0)), all(names(globals) == names(where)), identical(globals, globals0) ) message("3.") globals <- globals0 globals$b <- globals0["a"] str(globals) where <- attr(globals, "where") stopifnot( assert_attributes(globals), length(globals) == 3L, length(where) == length(globals), all(names(globals) == c(names(globals0), "b")), all(names(globals) == names(where)), identical(globals$b, globals0$a) ) message("4.") globals <- globals0 globals[["b"]] <- globals0["a"] str(globals) where <- attr(globals, "where") stopifnot( assert_attributes(globals), length(globals) == 3L, length(where) == length(globals), all(names(globals) == c(names(globals0), "b")), all(names(globals) == names(where)), identical(globals$b, globals0$a) ) message("5.") globals <- globals0 globals["b"] <- globals0["a"] str(globals) where <- attr(globals, "where") stopifnot( assert_attributes(globals), length(globals) == 3L, length(where) == length(globals), all(names(globals) == c(names(globals0), "b")), all(names(globals) == names(where)), identical(globals$b, globals0$a) ) message("6.") globals <- globals0 globals["b"] <- list(globals0[["a"]]) str(globals) where <- attr(globals, "where") stopifnot( assert_attributes(globals), length(globals) == 3L, length(where) == length(globals), all(names(globals) == c(names(globals0), "b")), all(names(globals) == names(where)), identical(globals$b, globals0$a) ) message("7.") globals <- globals0 globals$a <- NULL str(globals) where <- attr(globals, "where") stopifnot( assert_attributes(globals), length(globals) == 1L, length(where) == length(globals), all(names(globals) == names(globals0)[-1]), all(names(globals) == names(where)), is.null(globals$a) ) message("8.") globals <- globals0 globals$a <- 1:2 str(globals) where <- attr(globals, "where") stopifnot( assert_attributes(globals), length(globals) == 2L, length(where) == length(globals), all(names(globals) == names(globals0)), all(names(globals) == names(where)), identical(globals$a, 1:2) ) message("9.") globals <- globals0 globals[c("b", "a")] <- list(1:3, 42) str(globals) where <- attr(globals, "where") stopifnot( assert_attributes(globals), length(globals) == 3L, length(where) == length(globals), all(names(globals) == c(names(globals0), "b")), all(names(globals) == names(where)), identical(globals$b, 1:3), identical(globals$a, 42) ) message("10.") globals <- Globals() globals["empty"] <- list(NULL) str(globals) where <- attr(globals, "where") stopifnot( assert_attributes(globals), length(globals) == 1L, length(where) == length(globals), all(names(globals) == "empty"), is.null(globals[["empty"]]) ) message("*** Globals() - subsetted assignment ... DONE") message("*** Globals() - combining ...") globals_a <- globals0[1:2] globals_b <- globals0[1:2] globals <- c(globals_a, globals_b) str(globals) where <- attr(globals, "where") stopifnot( assert_attributes(globals), length(globals) == 4L, length(where) == length(globals), all(names(globals) == c(names(globals_a), names(globals_b))), all(names(globals) == names(where)) ) globals_a <- globals0[1:2] globals_b <- list(b = 1, c = letters) globals <- c(globals_a, globals_b) str(globals) where <- attr(globals, "where") stopifnot( assert_attributes(globals), length(globals) == 4L, length(where) == length(globals), all(names(globals) == c(names(globals_a), names(globals_b))), all(names(globals) == names(where)) ) globals_a <- globals0[1:2] globals_b <- list() globals <- c(globals_a, globals_b) str(globals) where <- attr(globals, "where") stopifnot( assert_attributes(globals), length(globals) == 2L, length(where) == length(globals), all(names(globals) == c(names(globals_a), names(globals_b))), all(names(globals) == names(where)) ) globals_a <- globals0[1:2] globals <- c(globals_a, b = 1, c = letters) str(globals) where <- attr(globals, "where") stopifnot( assert_attributes(globals), length(globals) == 4L, length(where) == length(globals), all(names(globals) == c(names(globals_a), "b", "c")), all(names(globals) == names(where)) ) globals <- Globals() globals_1 <- c(globals, fcn = median) str(globals_1) globals_2 <- globals globals_2$fcn <- median str(globals_2) stopifnot(identical(globals_2, globals_1)) message("*** Globals() - combining ... DONE") message("*** Globals() - unique ...") globals <- globals0[c(1:2, 1:2, 1:2)] str(globals) where <- attr(globals, "where") stopifnot( assert_attributes(globals), length(globals) == 6L, length(where) == length(globals), all(names(globals) == rep(names(globals0), times = 3L)), all(names(globals) == names(where)) ) globals <- unique(globals) str(globals) where <- attr(globals, "where") stopifnot( assert_attributes(globals), length(globals) == length(globals0), length(where) == length(globals), all(names(globals) == names(globals0)), all(names(globals) == names(where)) ) message("*** Globals() - unique ... DONE") message("*** Globals() - coercion ...") globals <- as.Globals(globals0) stopifnot( assert_attributes(globals), identical(globals, globals0) ) globals <- as.Globals(unclass(globals0)) stopifnot( assert_attributes(globals), identical(globals, globals0) ) globals_t <- unclass(globals0) attr(globals_t, "where") <- NULL globals <- as.Globals(globals_t) stopifnot( assert_attributes(globals), length(globals) == length(globals0), names(globals) == names(globals0) ) message("*** Globals() - coercion ... DONE") message("*** Globals() - empty ...") globals <- Globals() stopifnot( assert_attributes(globals), length(globals) == 0L ) globals <- Globals(list()) stopifnot( assert_attributes(globals), length(globals) == 0L ) globals <- as.Globals(list()) stopifnot( assert_attributes(globals), length(globals) == 0L ) message("*** Globals() - empty ... DONE") message("*** Globals() - NULL ...") ## https://github.com/HenrikBengtsson/globals/issues/79 denv <- getOption("globals.environment_of.default", emptyenv()) globals <- as.Globals(list(a = NULL)) str(globals) where <- attr(globals, "where") stopifnot( assert_attributes(globals), length(globals) == 1L, length(where) == length(globals), all(names(where) == names(globals)), identical(names(globals), c("a")), is.null(globals[["a"]]), identical(where[["a"]], denv) ) globals <- c(Globals(), list(a = NULL)) str(globals) where <- attr(globals, "where") stopifnot( assert_attributes(globals), length(globals) == 1L, length(where) == length(globals), all(names(where) == names(globals)), identical(names(globals), c("a")), is.null(globals[["a"]]), identical(where[["a"]], denv) ) message("*** Globals() - NULL ... DONE") message("*** Globals() - exceptions ...") res <- tryCatch({ Globals(NULL) }, error = identity) stopifnot(inherits(res, "simpleError")) res <- tryCatch({ Globals(list(1, 2)) }, error = identity) stopifnot(inherits(res, "simpleError")) res <- tryCatch({ Globals(list(a = 1, 2)) }, error = identity) stopifnot(inherits(res, "simpleError")) ## Assigning more than one element globals <- globals0 res <- tryCatch({ globals$a <- globals0[2:1] }, error = identity) stopifnot(inherits(res, "simpleError")) ## Appending unnamed objects res <- tryCatch({ c(globals0, 2) }, error = identity) stopifnot(inherits(res, "simpleError")) message("*** Globals() - exceptions ... DONE") message("*** Globals() ... DONE") globals/inst/testme/deploy.R0000755000176200001440000000437315004026770015605 0ustar liggesusers#!/usr/bin/env Rscript source <- "./inst/testme" if (!utils::file_test("-d", source)) { stop("Source 'testme' folder not found: ", sQuote(source)) } target <- "./tests" if (!utils::file_test("-d", target)) { stop("Target 'tests' folder not found: ", sQuote(target)) } r_path <- "./R" if (!utils::file_test("-d", r_path)) { stop("Target 'R' folder not found: ", sQuote(r_path)) } desc <- "./DESCRIPTION" if (!utils::file_test("-f", desc)) { stop("'DESCRIPTION' file not found: ", sQuote(desc)) } pkgname <- read.dcf(desc)[, "Package"] if (is.na(pkgname) || !nzchar(pkgname)) { stop("Failed to infer package name from 'DESCRIPTION' file: ", sQuote(pkgname)) } else if (!requireNamespace(pkgname)) { stop("Package fail to load: ", sQuote(pkgname)) } files <- dir(path = source, pattern = "^test-.*[.]R$", full.names = TRUE) message(sprintf("Deploying %d test scripts ...", length(files))) ## Generate R unit test script code <- c( "## This runs 'testme' test inst/testme/test-.R scripts", "## Don't edit - it was autogenerated by inst/testme/deploy.R", "testme <- function(name) {", sprintf(" path <- system.file(package = '%s', 'testme', mustWork = TRUE)", pkgname), " Sys.setenv(R_TESTME_PATH = path)", sprintf(" Sys.setenv(R_TESTME_PACKAGE = '%s')", pkgname), " Sys.setenv(R_TESTME_NAME = name)", " on.exit(Sys.unsetenv('R_TESTME_NAME'))", " source(file.path(path, 'run.R'))", "}" ) writeLines(code, con = file.path("./R/testme.R")) for (kk in seq_along(files)) { file <- files[kk] source_file <- basename(file) name <- sub("^test-", "", sub("[.]R$", "", source_file)) target_file <- file.path(target, source_file) message(sprintf("%02d/%02d test script %s", kk, length(files), sQuote(target_file))) ## Assert that testme script can be parsed res <- tryCatch(parse(file = file), error = identity) if (inherits(res, "error")) { stop("Syntax error: ", sQuote(file)) } ## Generate R unit test script code <- c( sprintf("## This runs testme test script inst/testme/test-%s.R", name), "## Don't edit - it was autogenerated by inst/testme/deploy.R", sprintf('%s:::testme("%s")', pkgname, name) ) writeLines(code, con = target_file) } message(sprintf("Deploying %d test scripts ... done", length(files))) globals/inst/testme/test-zzz.R0000644000176200001440000000005014777644360016125 0ustar liggesusersglobals:::.onLoad("globals", "globals") globals/inst/testme/test-globalsOf.R0000644000176200001440000001737115003536035017174 0ustar liggesuserslibrary(globals) message("*** globalsOf() ...") message(" ** globalsOf(..., method = 'conservative'):") expr <- exprs$A globals_c <- globalsOf(expr, method = "conservative") str(globals_c) assert_identical_sets(names(globals_c), c("{", "<-", "c", "d", "+")) globals_c <- cleanup(globals_c) str(globals_c) assert_identical_sets(names(globals_c), c("c", "d")) where <- attr(globals_c, "where") stopifnot( length(where) == length(globals_c), identical(where$c, globalenv()), identical(where$d, globalenv()) ) message(" ** globalsOf(..., method = 'liberal'):") expr <- exprs$A globals_l <- globalsOf(expr, method = "liberal") str(globals_l) assert_identical_sets(names(globals_l), c("{", "<-", "b", "c", "d", "+", "a", "e")) globals_l <- cleanup(globals_l) str(globals_l) assert_identical_sets(names(globals_l), c("b", "c", "d", "a", "e")) where <- attr(globals_l, "where") stopifnot( length(where) == length(globals_l), identical(where$b, globalenv()), identical(where$c, globalenv()), identical(where$d, globalenv()) ) message(" ** globalsOf(..., method = 'ordered'):") expr <- exprs$A globals_i <- globalsOf(expr, method = "ordered") str(globals_i) assert_identical_sets(names(globals_i), c("{", "<-", "b", "c", "d", "+", "a", "e")) globals_i <- cleanup(globals_i) str(globals_i) assert_identical_sets(names(globals_i), c("b", "c", "d", "a", "e")) where <- attr(globals_i, "where") stopifnot( length(where) == length(globals_i), identical(where$b, globalenv()), identical(where$c, globalenv()), identical(where$d, globalenv()) ) globals_i <- globalsOf(function(x) x <- x) print(globals_i) globals_i <- cleanup(globals_i) str(globals_i) assert_identical_sets(names(globals_i), character(0L)) where <- attr(globals_i, "where") stopifnot( length(where) == length(globals_i), identical(where, setNames(list(), character(0L))) ) globals_i <- globalsOf(function(x) x[1] <- 0) print(globals_i) globals_i <- cleanup(globals_i) str(globals_i) assert_identical_sets(names(globals_i), character(0L)) where <- attr(globals_i, "where") stopifnot( length(where) == length(globals_i), identical(where, setNames(list(), character(0L))) ) globals_i <- globalsOf(function(x) a <- x$a) print(globals_i) globals_i <- cleanup(globals_i) str(globals_i) assert_identical_sets(names(globals_i), character(0L)) where <- attr(globals_i, "where") stopifnot( length(where) == length(globals_i), identical(where, setNames(list(), character(0L))) ) globals_i <- globalsOf(function(...) args <- list(...)) print(globals_i) globals_i <- cleanup(globals_i) str(globals_i) assert_identical_sets(names(globals_i), character(0L)) where <- attr(globals_i, "where") stopifnot( length(where) == length(globals_i), identical(where, setNames(list(), character(0L))) ) x <- 1 globals_i <- globalsOf({ function(x) x; x }, substitute = TRUE) print(globals_i) globals_i <- cleanup(globals_i) str(globals_i) assert_identical_sets(names(globals_i), "x") where <- attr(globals_i, "where") stopifnot( length(where) == length(globals_i) ) message(" ** globalsOf() w/ globals in functions:") a <- 1 bar <- function(x) x - a foo <- function(x) bar(x) for (method in c("ordered", "conservative", "liberal")) { globals <- globalsOf({ foo(3) }, substitute = TRUE, method = method, recursive = FALSE, mustExist = FALSE) assert_identical_sets(names(globals), c("{", "foo")) stopifnot(!any("a" %in% names(globals))) globals <- cleanup(globals) str(globals) assert_identical_sets(names(globals), c("foo")) stopifnot(!any("a" %in% names(globals))) globals <- globalsOf({ foo(3) }, substitute = TRUE, method = "ordered", recursive = TRUE, mustExist = FALSE) assert_identical_sets(names(globals), c("{", "foo", "bar", "-", "a")) globals <- cleanup(globals) str(globals) assert_identical_sets(names(globals), c("foo", "bar", "a")) globals <- globalsOf({ foo(3) }, substitute = TRUE, recursive = TRUE, mustExist = FALSE) assert_identical_sets(names(globals), c("{", "foo", "bar", "-", "a")) globals <- cleanup(globals) str(globals) assert_identical_sets(names(globals), c("foo", "bar", "a")) } message(" ** globalsOf() w/ recursive functions:") ## "Easy" f <- function() Recall() globals <- globalsOf(f) str(globals) ## Direct recursive call f <- function() f() globals <- globalsOf(f) str(globals) ## Indirect recursive call f <- function() g() g <- function() f() globals_f <- globalsOf(f) str(globals_f) globals_g <- globalsOf(g) str(globals_g) globals_f <- globals_f[order(names(globals_f))] globals_g <- globals_g[order(names(globals_g))] stopifnot(identical(globals_g, globals_f)) message("*** globalsOf() ... DONE") message("*** Subsetting of Globals:") expr <- exprs$A globals_l <- globalsOf(expr, method = "liberal") globals_s <- globals_l[-1] stopifnot(length(globals_s) == length(globals_l) - 1L) stopifnot(identical(class(globals_s), class(globals_l))) where_l <- attr(globals_l, "where") where_s <- attr(globals_s, "where") stopifnot(length(where_s) == length(where_l) - 1L) stopifnot(identical(where_s, where_l[-1])) message("*** cleanup() & packagesOf():") expr <- exprs$A globals <- globalsOf(expr, method = "conservative") str(globals) assert_identical_sets(names(globals), c("{", "<-", "c", "d", "+")) globals <- as.Globals(globals) str(globals) assert_identical_sets(names(globals), c("{", "<-", "c", "d", "+")) globals <- as.Globals(unclass(globals)) str(globals) assert_identical_sets(names(globals), c("{", "<-", "c", "d", "+")) pkgs <- packagesOf(globals) print(pkgs) stopifnot( length(pkgs) == 1L, identical(pkgs, c("base")) ) globals <- cleanup(globals) str(globals) assert_identical_sets(names(globals), c("c", "d")) pkgs <- packagesOf(globals) print(pkgs) stopifnot(length(pkgs) == 0L) globals <- globalsOf(quote(pi)) stopifnot( length(globals) == 1L, identical(names(globals), "pi") ) pkgs <- packagesOf(globals) print(pkgs) stopifnot( length(pkgs) == 1L, identical(pkgs, c("base")) ) message("*** globalsOf() and package functions:") foo <- globals::Globals expr <- exprs$C globals <- globalsOf(expr, recursive = FALSE) str(globals) assert_identical_sets(names(globals), c("{", "foo", "list")) where <- attr(globals, "where") stopifnot(length(where) == length(globals)) if (!covr) stopifnot( identical(where$`{`, baseenv()), identical(where$foo, globalenv()), identical(where$list, baseenv()) ) globals <- cleanup(globals) str(globals) assert_identical_sets(names(globals), c("foo")) pkgs <- packagesOf(globals) stopifnot(pkgs == "globals") message("*** globalsOf() and core-package functions:") sample2 <- base::sample sum2 <- base::sum expr <- exprs$D globals <- globalsOf(expr, recursive = FALSE) str(globals) assert_identical_sets(names(globals), c("{", "<-", "sample", "sample2", "sessionInfo", "sum", "sum2", "isNamespaceLoaded")) where <- attr(globals, "where") stopifnot(length(where) == length(globals)) if (!covr) stopifnot( identical(where$`<-`, baseenv()), identical(where$sample, baseenv()), identical(where$sample2, globalenv()) ) globals <- cleanup(globals, drop = "primitives") str(globals) assert_identical_sets(names(globals), c("sample", "sample2", "sum2", "sessionInfo", "isNamespaceLoaded")) globals <- cleanup(globals, drop = "internals") str(globals) assert_identical_sets(names(globals), c("sample", "sample2", "sum2", "sessionInfo")) globals <- cleanup(globals) str(globals) assert_identical_sets(names(globals), c("sample2", "sum2")) where <- attr(globals, "where") stopifnot(length(where) == length(globals)) if (!covr) stopifnot(identical(where$sample2, globalenv())) message("*** globalsOf() - exceptions ...") rm(list = "a") res <- try({ globals <- globalsOf({ x <- a }, substitute = TRUE, mustExist = TRUE) }, silent = TRUE) stopifnot(inherits(res, "try-error")) message("*** globalsOf() - exceptions ... DONE") globals/inst/testme/_prologue/0000755000176200001440000000000015007065645016156 5ustar liggesusersglobals/inst/testme/_prologue/995.detrius-connections.R0000644000176200001440000000331614777644360022642 0ustar liggesusersget_connections <- function() { cons <- lapply(getAllConnections(), FUN = function(idx) { tryCatch({ con <- getConnection(idx) as.data.frame(c(index = idx, summary(con))) }, error = function(e) { NULL }) }) do.call(rbind, cons) } diff_connections <- function(after, before) { index <- NULL ## To please R CMD check ## Nothing to do? if (length(before) + length(after) == 0L) { return(c(added = NULL, removed = NULL, replaced = NULL)) } idxs <- setdiff(after[["index"]], before[["index"]]) if (length(idxs) > 0) { added <- subset(after, index %in% idxs) after <- subset(after, ! index %in% idxs) } else { added <- NULL } idxs <- setdiff(before[["index"]], after[["index"]]) if (length(idxs) > 0) { removed <- subset(before, index %in% idxs) before <- subset(before, ! index %in% idxs) } else { removed <- NULL } idxs <- intersect(before[["index"]], after[["index"]]) if (length(idxs) > 0) { replaced <- list() for (idx in idxs) { before_idx <- subset(before, index == idx) after_idx <- subset(after, index == idx) if (!identical(before_idx, after_idx)) { for (name in colnames(after_idx)) { value <- after_idx[[name]] if (!identical(before_idx[[name]], value)) { value <- sprintf("%s (was %s)", value, before_idx[[name]]) after_idx[[name]] <- value } } replaced <- c(replaced, list(after_idx)) } } replaced <- do.call(rbind, replaced) } else { replaced <- NULL } list(added = added, removed = removed, replaced = replaced) } testme <- as.environment("testme") testme[["testme_connections"]] <- get_connections() globals/inst/testme/_prologue/090.options.R0000644000176200001440000000042514777644360020316 0ustar liggesusers## Default options oopts <- options( warn = 1L, showNCalls = 500L, mc.cores = 2L, future.debug = TRUE, ## Reset the following during testing in case ## they are set on the test system future.availableCores.system = NULL, future.availableCores.fallback = NULL ) globals/inst/testme/_prologue/091.envvars.R0000644000176200001440000000223714777644360020313 0ustar liggesusers## Comment: The below should be set automatically whenever the future package ## is loaded and 'R CMD check' runs. The below is added in case R is changed ## in the future and we fail to detect 'R CMD check'. Sys.setenv(R_PARALLELLY_MAKENODEPSOCK_CONNECTTIMEOUT = 2 * 60) Sys.setenv(R_PARALLELLY_MAKENODEPSOCK_TIMEOUT = 2 * 60) Sys.setenv(R_PARALLELLY_MAKENODEPSOCK_SESSIONINFO_PKGS = TRUE) Sys.setenv(R_FUTURE_WAIT_INTERVAL = 0.01) ## 0.01s (instead of default 0.2s) ## Label PSOCK cluster workers (to help troubleshooting) test_script <- grep("[.]R$", commandArgs(), value = TRUE)[1] if (is.na(test_script)) test_script <- "UNKNOWN" worker_label <- sprintf("future/tests/%s:%s:%s:%s", test_script, Sys.info()[["nodename"]], Sys.info()[["user"]], Sys.getpid()) Sys.setenv(R_PARALLELLY_MAKENODEPSOCK_RSCRIPT_LABEL = worker_label) ## Reset the following during testing in case ## they are set on the test system oenvs2 <- Sys.unsetenv(c( "R_PARALLELLY_AVAILABLECORES_SYSTEM", "R_PARALLELLY_AVAILABLECORES_FALLBACK", ## SGE "NSLOTS", "PE_HOSTFILE", ## Slurm "SLURM_CPUS_PER_TASK", ## TORQUE / PBS "NCPUS", "PBS_NUM_PPN", "PBS_NODEFILE", "PBS_NP", "PBS_NUM_NODES" )) globals/inst/testme/_prologue/010.record-state.R0000644000176200001440000000015614777644360021210 0ustar liggesusers## Record original state ovars <- ls(envir = globalenv()) oenvs <- oenvs0 <- Sys.getenv() oopts0 <- options() globals/inst/testme/_prologue/050.utils.R0000644000176200001440000000037015004026770017735 0ustar liggesusersassert_identical_sets <- function(a, b) { a <- sort(a) b <- sort(b) if (!identical(a, b)) { stop(sprintf("Non-identical sets: c(%s) != c(%s)", paste(sQuote(a), collapse = ", "), paste(sQuote(b), collapse = ", "))) } } globals/inst/testme/_prologue/030.imports.R0000644000176200001440000000037114777644360020312 0ustar liggesusers## Private future functions as_function <- globals:::as_function is_base_pkg <- globals:::is_base_pkg is.base <- globals:::is.base is_internal <- globals:::is_internal where <- globals:::where mdebug <- globals:::mdebug envname <- globals:::envname globals/inst/testme/_prologue/005.globals.R0000644000176200001440000000112514777644360020240 0ustar liggesuserseval(envir = globalenv(), quote({ ## Define some globals a <- 0 b <- 2 c <- 3 d <- NULL e <- function() TRUE ## Expression with globals exprs <- list( A = quote({ x <- b b <- 1 y <- c z <- d a <- a + 1 e <- e() }), B = substitute(a <- pkg::a, env=environment()), C = quote({ foo(list(a = 1)) }), D = quote({ x <- sample(10) y <- sum(x) x2 <- sample2(10) y2 <- sum2(x) s <- sessionInfo() ns <- isNamespaceLoaded("foobar") }) ) })) ## eval(...) globals/inst/testme/_prologue/090.context.R0000644000176200001440000000046614777644360020314 0ustar liggesusersfullTest <- (Sys.getenv("_R_CHECK_FULL_") != "") covr <- ("covr" %in% loadedNamespaces()) on_macos <- grepl("^darwin", R.version$os) on_githubactions <- as.logical(Sys.getenv("GITHUB_ACTIONS", "FALSE")) if (covr) { globalenv <- function() parent.frame() baseenv <- function() environment(base::sample) } globals/inst/testme/_prologue/001.load.R0000644000176200001440000000010614777644360017526 0ustar liggesuserstestme <- as.environment("testme") loadNamespace(testme[["package"]]) globals/inst/testme/_epilogue/0000755000176200001440000000000014777644360016145 5ustar liggesusersglobals/inst/testme/_epilogue/090.gc.R0000644000176200001440000000046414777644360017174 0ustar liggesusers## Travis CI specific: Explicit garbage collection because it ## looks like Travis CI might run out of memory during 'covr' ## testing and we now have so many tests. /HB 2017-01-11 if ("covr" %in% loadedNamespaces()) { res <- gc() testme <- as.environment("testme") if (testme[["debug"]]) print(res) } globals/inst/testme/_epilogue/995.detritus-connections.R0000644000176200001440000000045514777644360023004 0ustar liggesusers## Look for detritus files testme <- as.environment("testme") local({ delta <- diff_connections(get_connections(), testme[["testme_connections"]]) if (any(lengths(delta) > 0)) { message(sprintf("Detritus connections generated by test %s:", sQuote(testme[["name"]]))) print(delta) } }) globals/inst/testme/_epilogue/999.detritus-files.R0000644000176200001440000000215714777644360021571 0ustar liggesusers## Look for detritus files testme <- as.environment("testme") local({ path <- dirname(tempdir()) if (basename(path) == "working_dir") { files <- dir(pattern = "^Rscript", path = path, all.files = TRUE, full.names = TRUE) if (length(files) > 0L) { message(sprintf("Detritus 'Rscript*' files generated by test %s:", sQuote(testme[["name"]]))) print(files) ## Remove detritus files produced by this test script, so that ## other test scripts will not fail because of these files. unlink(files) ## Signal the problem msg <- sprintf("Detected 'Rscript*' files: [n=%d] %s", length(files), paste(sQuote(basename(files)), collapse = ", ")) ## Are detritus files files expected by design on MS Windows? ## If so, produce a warning, otherwise an error if ("detritus-files" %in% testme[["tags"]] && .Platform[["OS.type"]] == "windows") { warning(msg, immediate. = TRUE) } else { stop(msg) } } } else { message(sprintf("Skipping, because path appears not to be an 'R CMD check' folder: %s", sQuote(path))) } }) globals/inst/testme/_epilogue/002.undo-state.R0000644000176200001440000000504314777644360020655 0ustar liggesuserstestme <- as.environment("testme") hpaste <- globals:::hpaste ## Undo options ## (a) Reset options(oopts0) ## (b) Remove added local({ added <- setdiff(names(options()), names(oopts0)) opts <- vector("list", length = length(added)) names(opts) <- added options(opts) }) ## (c) Assert that everything was undone if (!identical(options(), oopts0)) { message("Failed to undo options:") oopts <- options() message(sprintf(" - Expected options: [n=%d] %s", length(oopts0), hpaste(sQuote(names(oopts0))))) extra <- setdiff(names(oopts), names(oopts0)) message(paste(sprintf(" - Options still there: [n=%d]", length(extra)), hpaste(sQuote(extra)))) missing <- setdiff(names(oopts0), names(oopts)) message(paste(sprintf(" - Options missing: [n=%d]", length(missing)), hpaste(sQuote(missing)))) message("Differences option by option:") void <- lapply(names(oopts0), FUN = function(name) { value0 <- oopts0[[name]] value <- oopts[[name]] if (!identical(value, value0)) { if (testme[["debug"]]) { utils::str(list(name = name, expected = value0, actual = value)) } } }) } ## Undo system environment variables ## (a) Reset do.call(Sys.setenv, args=as.list(oenvs0)) ## (b) Removed added added <- setdiff(names(Sys.getenv()), names(oenvs0)) Sys.unsetenv(added) ## (c) Assert that everything was undone if (!identical(Sys.getenv(), oenvs0)) { message("Failed to undo environment variables:") oenvs <- Sys.getenv() message(sprintf(" - Expected environment variables: [n=%d] %s", length(oenvs0), hpaste(sQuote(names(oenvs0))))) extra <- setdiff(names(oenvs), names(oenvs0)) message(paste(sprintf(" - Environment variables still there: [n=%d]", length(extra)), hpaste(sQuote(extra)))) missing <- setdiff(names(oenvs0), names(oenvs)) message(paste(sprintf(" - Environment variables missing: [n=%d]", length(missing)), hpaste(sQuote(missing)))) message("Differences environment variable by environment variable:") void <- lapply(names(oenvs0), FUN = function(name) { value0 <- unname(oenvs0[name]) value <- unname(oenvs[name]) if (!identical(value, value0)) { if (testme[["debug"]]) { utils::str(list(name = name, expected = value0, actual = value)) } } }) } ## Assert undo was successful if (testme[["debug"]]) { stopifnot(identical(options(), oopts0)) } ## Undo variables if (!covr) { rm(list = c(setdiff(ls(envir = globalenv()), ovars)), envir = globalenv()) } globals/inst/testme/_epilogue/099.session_info.R0000644000176200001440000000021514777644360021304 0ustar liggesuserstestme <- as.environment("testme") if (testme[["debug"]]) { info <- utils::sessionInfo() message("Session information:") print(info) } globals/inst/testme/test-findGlobals.R0000644000176200001440000002646415006163156017516 0ustar liggesuserslibrary(globals) message("*** findGlobals() ...") message(" ** findGlobals(..., method = 'conservative'):") expr <- exprs$A globals_c <- findGlobals(expr, method = "conservative") print(globals_c) assert_identical_sets(globals_c, c("{", "<-", "c", "d", "+")) message(" ** findGlobals(..., method = 'liberal'):") expr <- exprs$A globals_l <- findGlobals(expr, method = "liberal") print(globals_l) assert_identical_sets(globals_l, c("{", "<-", "b", "c", "d", "+", "a", "e")) message(" ** findGlobals(..., method = 'ordered'):") expr <- exprs$A globals_i <- findGlobals(expr, method = "ordered") print(globals_i) assert_identical_sets(globals_i, c("{", "<-", "b", "c", "d", "+", "a", "e")) message(" ** findGlobals(..., method = 'dfs'):") expr <- exprs$A print(expr) globals_t <- findGlobals(expr, method = "dfs") print(globals_t) if (getRversion() < "4.0.0") globals_t <- setdiff(globals_t, c("x", "y", "z")) assert_identical_sets(globals_t, c("{", "<-", "b", "c", "d", "+", "a", "e")) fcn <- function() { a <- a + 1 a } print(fcn) globals_i <- globals::findGlobals(fcn) print(globals_i) assert_identical_sets(globals_i, c("{", "<-", "a", "+")) globals_t <- findGlobals(fcn, method = "dfs") print(globals_t) assert_identical_sets(globals_t, c("{", "<-", "a", "+")) fcn <- function() { a a <- a + 1 } print(fcn) globals_i <- findGlobals(fcn) print(globals_i) assert_identical_sets(globals_i, c("{", "a", "<-", "+")) globals_t <- findGlobals(fcn, method = "dfs") print(globals_t) assert_identical_sets(globals_t, c("{", "a", "<-", "+")) fcn <- function(x) x <- x print(fcn) globals_i <- findGlobals(fcn) print(globals_i) assert_identical_sets(globals_i, c("<-")) globals_t <- findGlobals(fcn, method = "dfs") print(globals_t) assert_identical_sets(globals_t, c("<-")) fcn <- function(x) x[1] <- 0 print(fcn) globals_i <- findGlobals(fcn) print(globals_i) assert_identical_sets(globals_i, c("<-", "[", "[<-")) globals_t <- findGlobals(fcn, method = "dfs") print(globals_t) assert_identical_sets(globals_t, c("[<-")) fcn <- function(x) a <- x$a print(fcn) globals_i <- findGlobals(fcn) print(globals_i) assert_identical_sets(globals_i, c("<-", "$")) globals_t <- findGlobals(fcn, method = "dfs") print(globals_t) if (getRversion() < "4.0.0") globals_t <- setdiff(globals_t, "a") assert_identical_sets(globals_t, c("<-", "$")) fcn <- function(...) args <- list(...) print(fcn) globals_i <- findGlobals(fcn) print(globals_i) assert_identical_sets(globals_i, c("<-", "list")) globals_t <- findGlobals(fcn, method = "dfs") print(globals_t) if (getRversion() < "4.0.0") globals_t <- setdiff(globals_t, "args") assert_identical_sets(globals_t, c("<-", "list")) fcn <- function() args <- list(...) print(fcn) globals_i <- findGlobals(fcn) print(globals_i) assert_identical_sets(globals_i, c("<-", "list", "...")) globals_t <- findGlobals(fcn, method = "dfs") print(globals_t) if (getRversion() < "4.0.0") globals_t <- setdiff(globals_t, "args") assert_identical_sets(globals_t, c("<-", "list", "...")) expr <- quote({ function(x) x; x }) print(expr) globals_i <- findGlobals(expr) print(globals_i) assert_identical_sets(globals_i, c("{", "x")) globals_t <- findGlobals(expr, method = "dfs") print(globals_t) assert_identical_sets(globals_t, c("{", "x")) expr <- quote({ "x" <- 1; x }) globals_i <- findGlobals(expr) print(globals_i) assert_identical_sets(globals_i, c("{", "<-")) globals_t <- findGlobals(expr, method = "dfs") if (getRversion() < "4.0.0") globals_t <- setdiff(globals_t, "x") print(globals_t) assert_identical_sets(globals_t, c("{", "<-")) x <- list() globals <- findGlobals(x) print(globals) assert_identical_sets(globals, character(0L)) globals_t <- findGlobals(x, method = "dfs") print(globals_t) assert_identical_sets(globals_t, character(0L)) expr <- quote(list()) attr(expr, "abc") <- quote({ a }) attr(expr, "def") <- quote({ d }) globals <- findGlobals(expr) print(globals) assert_identical_sets(globals, c("list", "{", "a", "d")) globals_t <- findGlobals(expr, method = "dfs") print(globals_t) assert_identical_sets(globals_t, c("list", "{", "a", "d")) globals <- findGlobals(expr, attributes = "abc") print(globals) assert_identical_sets(globals, c("list", "{", "a")) globals_t <- findGlobals(expr, method = "dfs") print(globals_t) assert_identical_sets(globals_t, c("list", "{", "a", "d")) message(" ** findGlobals(..., tweak):") tweak_another_expression <- function(expr) { quote({ x <- B B <- 1 y <- C z <- D }) } expr <- exprs$A print(expr) globals_i <- findGlobals(expr, tweak = tweak_another_expression) assert_identical_sets(globals_i, c("{", "<-", "B", "C", "D")) globals_t <- findGlobals(expr, tweak = tweak_another_expression, method = "dfs") print(globals_t) if (getRversion() < "4.0.0") globals_t <- setdiff(globals_t, c("x", "y", "z")) assert_identical_sets(globals_t, c("{", "<-", "B", "C", "D")) message(" ** findGlobals(..., trace = TRUE):") expr <- exprs$A print(expr) globals_i <- findGlobals(expr, trace = TRUE) print(globals_i) assert_identical_sets(globals_i, c("{", "<-", "b", "c", "d", "+", "a", "e")) globals_t <- findGlobals(expr, method = "dfs") print(globals_t) if (getRversion() < "4.0.0") globals_t <- setdiff(globals_t, c("x", "y", "z")) assert_identical_sets(globals_t, c("{", "<-", "b", "c", "d", "+", "a", "e")) message(" ** findGlobals(a <- pkg::a):") expr <- exprs$B print(expr) globals_i <- findGlobals(expr) print(globals_i) assert_identical_sets(globals_i, c("<-", "::")) globals_t <- findGlobals(expr, method = "dfs") print(globals_t) if (getRversion() < "4.0.0") globals_t <- setdiff(globals_t, "a") assert_identical_sets(globals_t, c("<-", "::")) message(" ** findGlobals(a[1] <- 0) etc.:") expr <- quote(a[1] <- 0) print(expr) globals_i <- findGlobals(expr) print(globals_i) false_globals <- "[" assert_identical_sets(setdiff(globals_i, false_globals), c("<-", "a", "[<-")) globals_t <- findGlobals(expr, method = "dfs") print(globals_t) assert_identical_sets(globals_t, c("a", "[<-")) expr <- quote({ a[1] = 0 }) print(expr) globals_i <- findGlobals(expr) print(globals_i) false_globals <- "[" assert_identical_sets(setdiff(globals_i, false_globals), c("{", "=", "a", "[<-")) globals_t <- findGlobals(expr, method = "dfs") print(globals_t) assert_identical_sets(globals_t, c("{", "a", "[<-")) expr <- quote(a[b <- 1] <- 0) print(expr) globals_i <- findGlobals(expr) print(globals_i) false_globals <- "[" assert_identical_sets(setdiff(globals_i, false_globals), c("<-", "a", "[<-")) globals_t <- findGlobals(expr, method = "dfs") print(globals_t) if (getRversion() < "4.0.0") globals_t <- setdiff(globals_t, "b") assert_identical_sets(globals_t, c("<-", "a", "[<-")) expr <- quote(a[b = 1] <- 0) print(expr) globals_i <- findGlobals(expr) print(globals_i) false_globals <- "[" assert_identical_sets(setdiff(globals_i, false_globals), c("<-", "a", "[<-")) globals_t <- findGlobals(expr, method = "dfs") print(globals_t) if (getRversion() < "4.0.0") globals_t <- setdiff(globals_t, "b") assert_identical_sets(globals_t, c("a", "[<-")) expr <- quote({ a[b <- 1] = 0 }) print(expr) globals_i <- findGlobals(expr) print(globals_i) false_globals <- "[" assert_identical_sets(setdiff(globals_i, false_globals), c("{", "=", "a", "<-", "[<-")) globals_t <- findGlobals(expr, method = "dfs") print(globals_t) if (getRversion() < "4.0.0") globals_t <- setdiff(globals_t, "b") assert_identical_sets(globals_t, c("{", "a", "<-", "[<-")) expr <- quote(a$b <- 0) print(expr) globals_i <- findGlobals(expr) print(globals_i) false_globals <- "$" assert_identical_sets(setdiff(globals_i, false_globals), c("<-", "a", "$<-")) globals_t <- findGlobals(expr, method = "dfs") print(globals_t) assert_identical_sets(globals_t, c("a", "$<-")) expr <- quote({ a$b = 0 }) print(expr) globals_i <- findGlobals(expr) print(globals_i) false_globals <- "$" assert_identical_sets(setdiff(globals_i, false_globals), c("{", "=", "a", "$<-")) globals_t <- findGlobals(expr, method = "dfs") print(globals_t) assert_identical_sets(setdiff(globals_t, false_globals), c("{", "a", "$<-")) expr <- quote(names(a) <- "A") print(expr) globals_i <- findGlobals(expr) print(globals_i) assert_identical_sets(globals_i, c("<-", "a", "names", "names<-")) globals_t <- findGlobals(expr, method = "dfs") print(globals_t) assert_identical_sets(globals_t, c("a", "names<-")) expr <- quote({ names(a) = "A" }) print(expr) globals_i <- findGlobals(expr) print(globals_i) assert_identical_sets(globals_i, c("{", "=", "a", "names", "names<-")) globals_t <- findGlobals(expr, method = "dfs") print(globals_t) assert_identical_sets(globals_t, c("{", "a", "names<-")) ## In order to handle the following case, we have to accept a few ## false positives (`[`, `[[`, `$`, `[<-`, `[[<-`) expr <- quote(names(a)[1] <- "A") print(expr) globals_i <- findGlobals(expr) print(globals_i) false_globals <- c("[", "[<-") assert_identical_sets(setdiff(globals_i, false_globals), c("<-", "a", "names", "names<-")) globals_t <- findGlobals(expr, method = "dfs") print(globals_t) assert_identical_sets(globals_t, c("names<-", "a", "[<-", "names")) expr <- quote({ names(a)[1] = "A" }) print(expr) globals_i <- findGlobals(expr) print(globals_i) false_globals <- c("[", "[<-") assert_identical_sets(setdiff(globals_i, false_globals), c("{", "=", "a", "names", "names<-")) globals_t <- findGlobals(expr, method = "dfs") print(globals_t) assert_identical_sets(globals_t, c("{", "names<-", "a", "[<-", "names")) expr <- expression(x) print(expr) globals_i <- findGlobals(expr) print(globals_i) assert_identical_sets(globals_i, c("x")) globals_t <- findGlobals(expr, method = "dfs") print(globals_t) assert_identical_sets(globals_t, c("x")) expr <- expression(x + y) print(expr) globals_i <- findGlobals(expr) print(globals_i) assert_identical_sets(globals_i, c("+", "x", "y")) globals_t <- findGlobals(expr, method = "dfs") print(globals_t) assert_identical_sets(globals_t, c("+", "x", "y")) # BUG: https://github.com/HenrikBengtsson/globals/issues/60 expr <- as.call(list(function(...) GLOBAL, quote(ARG))) print(expr) for (method in c("conservative", "liberal", "ordered", "dfs")) { message(sprintf("method=%s", sQuote(method))) globals_i <- findGlobals(expr, method = method) print(globals_i) assert_identical_sets(globals_i, c("GLOBAL", "ARG")) } expr <- quote({ a * b }) globals <- findGlobals(expr, trace = TRUE) print(globals) assert_identical_sets(globals, c("{", "*", "a", "b")) globals_t <- findGlobals(expr, method = "dfs") print(globals_t) assert_identical_sets(globals_t, c("{", "*", "a", "b")) # BUG: https://github.com/HenrikBengtsson/globals/issues/93 expr <- asS3(methods::getClass("S4")@prototype, complete = FALSE) print(expr) globals <- findGlobals(expr, trace = TRUE) print(globals) assert_identical_sets(globals, character(0L)) globals_t <- findGlobals(expr, method = "dfs") print(globals_t) assert_identical_sets(globals, character(0L)) message("*** findGlobals() - multiple 'method's ...") expr <- quote({ a + 1; a <- 1 }) globals <- findGlobals(expr, method = c("ordered", "dfs")) print(globals) assert_identical_sets(globals, c("{", "+", "a", "<-")) expr <- quote({ for (x in NULL) NULL }) globals <- findGlobals(expr, method = c("ordered", "dfs")) print(globals) assert_identical_sets(globals, c("{", "for")) expr <- quote({ for (x in NULL) x }) globals <- findGlobals(expr, method = c("ordered", "dfs")) print(globals) assert_identical_sets(globals, c("{", "for")) message("*** findGlobals() - multiple 'method's ... DONE") message("*** findGlobals() ... DONE") globals/inst/testme/test-liberal.R0000644000176200001440000000360714777644360016715 0ustar liggesuserslibrary(globals) ## WORKAROUND: Avoid problem reported in testthat Issue #229, which ## causes covr::package_coverage() to given an error. /HB 2015-02-16 suppressWarnings({ rm(list = c("a", "b", "c", "x", "y", "z", "square", "pathname", "url", "filename")) }) message("Setting up expressions") exprs <- list( A = quote({ Sys.sleep(1) x <- 0.1 }), B = quote({ y <- 0.2 }), C = quote({ z <- a + 0.3 }), D = quote({ pathname <- file.path(dirname(url), filename) }), E = quote({ b <- c }), F = quote({ a <- { runif(1) } b <- { rnorm(1) } x <- a * b abs(x) }), G = quote({ y <- square(a) }), H = quote({ b <- a a <- 1 }) ) atleast <- list( A = c(), B = c(), C = c("a"), D = c("filename"), E = c("c"), F = c(), G = c("a", "square"), H = c() ## FIXME: Should be c("a"), cf. Issue #5. ) not <- list( A = c("x"), B = c("y"), C = c("z"), D = c("pathname"), E = c("b"), F = c(), G = c(), H = c() ) ## Define globals a <- 3.14 c <- 2.71 square <- function(x) x ^ 2 filename <- "index.html" # Yes, pretend we forget 'url' message("Find globals") for (kk in seq_along(exprs)) { key <- names(exprs)[kk] expr <- exprs[[key]] cat(sprintf("Expression #%d ('%s'):\n", kk, key)) print(expr) names <- findGlobals(expr, method = "liberal") cat(sprintf("Globals: %s\n", paste(sQuote(names), collapse = ", "))) stopifnot(all(atleast[[key]] %in% names)) stopifnot(!any(names %in% not[[key]])) globals <- globalsOf(expr, method = "liberal", mustExist = FALSE) cat(sprintf("Globals: %s\n", paste(sQuote(names(globals)), collapse = ", "))) stopifnot(all(atleast[[key]] %in% names(globals))) stopifnot(!any(names(globals) %in% not[[key]])) str(globals) cat("\n") } names <- findGlobals(exprs, method = "liberal", unlist = TRUE) cat(sprintf("Globals: %s\n", paste(sQuote(names), collapse = ", "))) ## Cleanup globals/inst/testme/test-globalsOf,locals.R0000644000176200001440000000240514777644360020460 0ustar liggesuserslibrary(globals) message("*** globalsOf() w/ local() ...") for (locals in c(TRUE, FALSE)) { message(sprintf("- locals=%s", locals)) f <- local({ a <- 42 function() a }) globals <- globalsOf(quote(f), locals = locals) str(globals) where <- attr(globals, "where") if (locals) { stopifnot( length(globals) == 2L, identical(sort(names(globals)), c("a", "f")), identical(where[["a"]], environment(globals[["f"]])) ) } else { stopifnot( length(globals) == 1L, identical(names(globals), "f") ) } message(sprintf("- locals=%s with nested local():s", locals)) f <- local({ b <- 3.14 local({ a <- 42 function() a + b }) }) globals <- globalsOf(quote(f), locals = locals) globals <- cleanup(globals) str(globals) where <- attr(globals, "where") if (locals) { stopifnot( length(globals) == 3L, identical(sort(names(globals)), c("a", "b", "f")), identical(where[["a"]], environment(globals[["f"]])), identical(where[["b"]], parent.env(environment(globals[["f"]]))) ) } else { stopifnot( length(globals) == 1L, identical(names(globals), "f") ) } } # for (locals ...) message("*** globalsOf() w/ local() ... DONE") globals/inst/testme/test-formulas.R0000644000176200001440000000436614777644360017136 0ustar liggesuserslibrary(globals) message("findGlobals() with formula ...") g <- findGlobals(. ~ x + y : z, substitute = TRUE) print(g) assert_identical_sets(g, c("~", ".", "+", "x", ":", "y", "z")) g <- findGlobals(map(1L, ~ typeof(.x)), substitute = TRUE) print(g) assert_identical_sets(g, c("map", "~", "typeof", ".x")) message("- findGlobals() with NULL in the formula ...") ## BUG: https://github.com/HenrikBengtsson/globals/issues/59 for (substitute in c(TRUE, FALSE)) { message("- substitute = ", substitute) g <- findGlobals(. ~ NULL, substitute = substitute) print(g) assert_identical_sets(g, c(".", "~")) g <- findGlobals(NULL ~ NULL, substitute = substitute) print(g) assert_identical_sets(g, c("~")) g <- findGlobals(~ NULL, substitute = substitute) print(g) assert_identical_sets(g, c("~")) g <- findGlobals(NULL ~ ., substitute = substitute) print(g) assert_identical_sets(g, c("~", ".")) } # ## substitute=FALSE # Browse[2]> str(expr) # language ~NULL # # ## substitute=TRUE # Browse[2]> str(expr) # Class 'formula' language ~NULL # ..- attr(*, ".Environment")= message("- findGlobals() with ellipsis in formulas ...") ## BUG: https://github.com/HenrikBengtsson/globals/issues/62 g <- findGlobals(list(..., ..3) ~ list(., .x, ..., ..1, ..2)) print(g) assert_identical_sets(g, c("~", "list", "...", "..3", ".", ".x", "..1", "..2")) message("- findGlobals() with NULL in formulas ...") ## BUG: https://github.com/HenrikBengtsson/globals/issues/64 env <- new.env(parent = globalenv()) env$`~` <- function(...) "OVERRIDE!" x <- ~ NULL g <- eval(quote(findGlobals(x)), env) assert_identical_sets(g, "~") x <- list(~ NULL) g <- eval(quote(findGlobals(x)), env) assert_identical_sets(g, "~") x <- list(NULL ~ NULL) g <- eval(quote(findGlobals(x)), env) assert_identical_sets(g, "~") x <- list(NULL ~ b) g <- eval(quote(findGlobals(x)), env) assert_identical_sets(g, c("~", "b")) message("findGlobals() with formula ... DONE") message("globalsOf() with formula ...") foo <- function(x) { map(1L, ~ typeof(x + .x)) } g <- globalsOf(foo(1L), substitute = TRUE, mustExist = FALSE) str(g) assert_identical_sets(names(g), c("foo", "map", "{", "~", "typeof", "+", "x", ".x")) message("globalsOf() with formula ... DONE") globals/inst/testme/test-findGlobals,dfs.R0000644000176200001440000001446515007060724020263 0ustar liggesusersoptions(globals.debug = (.Platform[["OS.type"]] == "windows")) commaq <- globals:::commaq exprs <- list() truths <- list() append_expr <- function(expr, substitute = TRUE, truth = character(0L)) { if (substitute) expr <- substitute(expr) truth <- sort(truth) exprs <<- c(exprs, list(expr)) truths <<- c(truths, list(truth)) invisible(length(exprs)) } append_expr(42, truth = character(0L)) append_expr(a, truth = c("a")) append_expr(a <- 42, truth = c("<-", if (getRversion() < "4.0.0") c("a"))) append_expr({ a + b }, truth = c("{", "+", "a", "b")) append_expr({ a <- 42 a + b }, truth = c("{", "<-", "+", "b", if (getRversion() < "4.0.0") "a")) append_expr({ c() }, truth = c("{", "c")) append_expr({ c(1:3) }, truth = c("{", "c", ":")) append_expr({ pi }, truth = c("{", "pi")) append_expr({ base::pi }, truth = c("{", "::")) append_expr({ base:::pi }, truth = c("{", ":::")) append_expr(a$b, truth = c("a", "$")) append_expr(a$b(), truth = c("a", "$")) append_expr(a$b(2), truth = c("a", "$")) append_expr(a()$b, truth = c("a", "$")) append_expr(a(2)$b, truth = c("a", "$")) append_expr(a@b, truth = c("a", "@")) append_expr(a@b(), truth = c("a", "@")) append_expr(a@b(2), truth = c("a", "@")) append_expr(a()@b, truth = c("a", "@")) append_expr(a(2)@b, truth = c("a", "@")) append_expr(a[1], truth = c("a", "[")) append_expr(a[NA], truth = c("a", "[")) append_expr(a[NA_character_], truth = c("a", "[")) append_expr(a[Inf], truth = c("a", "[")) append_expr(a[], truth = c("a", "[")) append_expr(a[1,], truth = c("a", "[")) append_expr(a[,1], truth = c("a", "[")) append_expr(a[1] <- 0, truth = c("a", "[<-")) append_expr(a[b <- 1] <- 0, truth = c("a", "[<-", "<-", if (getRversion() < "4.0.0") c("b"))) append_expr({ a[b <- 1] <- 0 }, truth = c("{", "a", "[<-", "<-", if (getRversion() < "4.0.0") c("b"))) append_expr({ a$b <- 0 }, truth = c("{", "a", "$<-")) append_expr({ a@b <- 0 }, truth = c("{", "a", "@<-")) append_expr(names(a) <- "A", truth = c("a", "names<-")) append_expr({ a[1] = 0 }, truth = c("{", "a", "[<-")) append_expr({ a[b = 1] = 0 }, truth = c("{", "a", "[<-")) append_expr({ a$b = 0 }, truth = c("{", "a", "$<-")) append_expr({ names(a) = "A" }, truth = c("{", "a", "names<-")) append_expr({ names(a)[1] = "A" }, truth = c("{", "names<-", "a", "[<-", "names")) append_expr(x[is.na(x)] <- 0, truth = c("[<-", "is.na", "x")) append_expr({ x[is.na(x)] = 0 }, truth = c("{", "[<-", "is.na", "x")) append_expr(function(a) a, truth = character(0L)) append_expr(function(a) a + b, truth = c("+", "b")) append_expr(function(a, b) a + b, truth = c("+")) append_expr(function(a, b = 1) a + b, truth = c("+")) append_expr({ g <- function(a) a g(a) }, truth = c("{", "<-", "a", if (getRversion() < "4.0.0") "g")) append_expr({ x <- 1 y <- function(a) { b <- 3 a + b + x } z <- y(2 * x) }, truth = c("{", "<-", "+", "*", if (getRversion() < "4.0.0") c("b", "x", "y", "z"))) append_expr({ y <- function(a) a + x x <- 1 z <- y(2 * x) }, truth = c("{", "<-", "x", "+", "*", if (getRversion() < "4.0.0") c("y", "z"))) append_expr({ lapply(1:3, function (i) { G <- function(a,b,c) c(a, b, c) G(a, b, c) }) }, truth = c(":", "{", "<-", "a", "b", "c", "lapply", if (getRversion() < "4.0.0") "G")) append_expr({ base::lapply(1:3, function (i) { G <- function(a,b,c) c(a, b, c) G(a, b, c) }) }, truth = c("::", ":", "{", "<-", "a", "b", "c", if (getRversion() < "4.0.0") "G")) append_expr(~ x, substitute = FALSE, truth = c("~", "x")) append_expr(. ~ x, substitute = FALSE, truth = c("~", ".", "x")) append_expr(y ~ x + 1, truth = c("~", "y", "+", "x")) env <- new.env(parent = emptyenv()) append_expr(env, substitute = FALSE, truth = character(0L)) fcn <- function() a * x append_expr(fcn, substitute = FALSE, truth = c("*", "a", "x")) fcn <- function(a) a * x append_expr(fcn, substitute = FALSE, truth = c("*", "x")) fcn <- function(a, b = 1) a * x + b append_expr(fcn, substitute = FALSE, truth = c("*", "x", "+")) fcn <- function(...) NULL append_expr(fcn, substitute = FALSE, truth = character(0L)) fcn <- function(...) list(...) append_expr(fcn, substitute = FALSE, truth = c("list")) fcn <- function() list(...) append_expr(fcn, substitute = FALSE, truth = c("list", "...")) fcn <- function(a, ...) base::list(a = a, ...) append_expr(fcn, substitute = FALSE, truth = c("::")) fcn <- function(a, ...) c(a = a, ...) append_expr(fcn, substitute = FALSE, truth = c("c")) expr <- expression(x) append_expr(expr, substitute = FALSE, truth = c("x")) expr <- expression(x + y) append_expr(expr, substitute = FALSE, truth = c("+", "x", "y")) # BUG: https://github.com/HenrikBengtsson/globals/issues/93 expr <- asS3(methods::getClass("S4")@prototype, complete = FALSE) append_expr(expr, substitute = FALSE, truth = character(0L)) con <- rawConnection(raw()) append_expr(con, substitute = FALSE, truth = character(0L)) close(con) expr <- quote(for (x in NULL) NULL) append_expr(expr, substitute = FALSE, truth = c("for")) expr <- quote(for (x in NULL) x) append_expr(expr, substitute = FALSE, truth = c("for")) expr <- quote(base::names(x)[1] <- 0) append_expr(expr, substitute = FALSE, truth = c("::", "x", "[<-")) for (kk in seq_along(exprs)) { message(sprintf("\n*** Expression #%d ***", kk)) expr <- exprs[[kk]] truth <- truths[[kk]] print(expr) globals <- sort(globals::findGlobals(expr, method = "ordered")) message(sprintf(" findGlobals(..., type = 'ordered'): [n=%d] %s", length(globals), commaq(globals))) globals <- sort(globals::findGlobals(expr, method = "dfs")) msg <- sprintf("findGlobals(..., type = 'dfs' ): [n=%d] %s", length(globals), commaq(globals)) if (is.null(truth)) { message(sprintf("[SKIP] %s", msg)) } else { missed <- setdiff(truth, globals) extra <- setdiff(globals, truth) if (length(extra) + length(missed) > 0) { info <- character(0L) if (length(extra) > 0) { info <- c(info, sprintf("extra: [n=%d] %s", length(extra), commaq(extra))) } if (length(missed) > 0) { info <- c(info, sprintf("missing: [n=%d] %s", length(missed), commaq(missed))) } info <- paste(info, collapse = "; ") message(sprintf("[FAIL] %s; which is unexpected (%s)", msg, info)) stop("Unexpected results") } else { message(sprintf("[ OK ] %s", msg)) } } } ## for (kk ...) globals/inst/testme/test-codetools-bug16.R0000644000176200001440000000104714777644360020214 0ustar liggesuserslibrary(globals) message("*** codetools::findGlobals() bug #16 ...") exprs <- list( A = quote(x %% `$<-`("abc", 42)), B = quote(function() x %% `$<-`("abc", 42)) ) for (name in names(exprs)) { expr <- exprs[[name]] print(expr) globals <- globals::findGlobals(expr) print(globals) diffA <- setdiff(c("%%", "x", "$<-"), globals) print(diffA) stopifnot(length(diffA) == 0) diffB <- setdiff(globals, c("%%", "x", "$<-")) print(diffB) stopifnot(length(diffB) == 0) } message("*** codetools::findGlobals() bug #16 ... done") globals/inst/testme/test-dotdotdot.R0000644000176200001440000001432514777644360017306 0ustar liggesuserslibrary(globals) options(warn = 2L) exprs <- list( ok1 = quote(function(...) sum(x, ...)), ok2 = quote(function(...) sum(x, ..1, ..2, ..3)), warn1 = quote(sum(x, ...)), warn2 = quote(sum(x, ..1, ..2, ..3)) ) truth <- list( ok1 = c("sum", "x"), ok2 = c("sum", "x"), warn1 = c("sum", "x", "..."), warn2 = c("sum", "x", "..1", "..2", "..3") ) message("*** findGlobals() ...") for (name in names(exprs)) { expr <- exprs[[name]] message(sprintf("\n*** codetools::findGlobals() - step %s:", sQuote(name))) print(expr) fun <- globals:::as_function(expr) print(fun) ## Suppress '... may be used in an incorrect context' warnings suppressWarnings({ globals <- codetools::findGlobals(fun) }) print(globals) assert_identical_sets(globals, c("sum", "x")) next message("\n*** findGlobals(dotdotdot = 'ignore'):") cat(sprintf("Expression '%s':\n", name)) print(expr) globals <- findGlobals(expr, dotdotdot = "ignore") print(globals) assert_identical_sets(globals, c("sum", "x")) message("\n*** findGlobals(dotdotdot = 'return'):") cat(sprintf("Expression '%s':\n", name)) print(expr) globals <- findGlobals(expr, dotdotdot = "return") print(globals) assert_identical_sets(globals, truth[[name]]) message("\n*** findGlobals(dotdotdot = 'warning'):") cat(sprintf("Expression '%s':\n", name)) print(expr) globals <- findGlobals(expr, dotdotdot = "warning") print(globals) assert_identical_sets(globals, truth[[name]]) message("\n*** findGlobals(dotdotdot = 'error'):") cat(sprintf("Expression '%s':\n", name)) print(expr) globals <- tryCatch(findGlobals(expr, dotdotdot = "error"), error = identity) if (name %in% c("ok1", "ok2")) { assert_identical_sets(globals, truth[[name]]) } else { stopifnot(inherits(globals, "error")) } } # for (name ...) message("\n*** findGlobals(, dotdotdot = 'return'):") print(exprs) globals <- findGlobals(exprs, dotdotdot = "return") print(globals) assert_identical_sets(globals, unique(unlist(truth, use.names = FALSE))) message("\n*** findGlobals(, dotdotdot = 'return'):") formula_attr <- bquote(~ .(call("fn", quote(...)))) x <- structure(integer(), formula_attr = formula_attr) print(x) # Attributes always use `dotdotdot = "ignore"` globals <- findGlobals(x, dotdotdot = "return", attributes = TRUE) print(globals) assert_identical_sets(globals, c("~", "fn")) message("*** findGlobals() ... DONE") message("*** globalsOf() ...") x <- 1:2 for (name in names(exprs)) { expr <- exprs[[name]] message("\n*** globalsOf(dotdotdot = 'ignore'):") cat(sprintf("Expression '%s':\n", name)) print(expr) globals <- globalsOf(expr, dotdotdot = "ignore") print(globals) assert_identical_sets(names(globals), c("sum", "x")) stopifnot(all.equal(globals$sum, base::sum)) stopifnot(all.equal(globals$x, x)) message("\n*** globalsOf(dotdotdot = 'return'):") cat(sprintf("Expression '%s':\n", name)) print(expr) globals <- globalsOf(expr, dotdotdot = "return") print(globals) assert_identical_sets(names(globals), truth[[name]]) if (name == "warn1") { stopifnot(!is.list(globals$`...`) && is.na(globals$`...`)) } stopifnot(all.equal(globals$sum, base::sum)) stopifnot(all.equal(globals$x, x)) message("\n*** globalsOf(dotdotdot = 'warning'):") cat(sprintf("Expression '%s':\n", name)) print(expr) globals <- globalsOf(expr, dotdotdot = "warning") print(globals) assert_identical_sets(names(globals), truth[[name]]) if (name == "warn1") { stopifnot(!is.list(globals$`...`) && is.na(globals$`...`)) } stopifnot(all.equal(globals$sum, base::sum)) stopifnot(all.equal(globals$x, x)) message("\n*** globalsOf(dotdotdot = 'error'):") cat(sprintf("Expression '%s':\n", name)) print(expr) globals <- tryCatch(globalsOf(expr, dotdotdot = "error"), error = identity) if (name %in% c("ok1", "ok2")) { assert_identical_sets(names(globals), truth[[name]]) stopifnot(all.equal(globals$sum, base::sum)) stopifnot(all.equal(globals$x, x)) } else { stopifnot(inherits(globals, "error")) } } # for (name ...) message("\n*** globalsOf(, dotdotdot = 'return'):") print(exprs) globals <- globalsOf(exprs, dotdotdot = "return") print(globals) message("*** globalsOf() ... DONE") message("*** function(x, ...) globalsOf() ...") aux <- function(x, ..., exprs) { args <- list(...) for (name in names(exprs)) { expr <- exprs[[name]] message("\n*** globalsOf(dotdotdot = 'ignore'):") cat(sprintf("Expression '%s':\n", name)) print(expr) globals <- globalsOf(expr, dotdotdot = "ignore") print(globals) assert_identical_sets(names(globals), c("sum", "x")) stopifnot(all.equal(globals$sum, base::sum)) stopifnot(all.equal(globals$x, x)) message("\n*** globalsOf(dotdotdot = 'return'):") cat(sprintf("Expression '%s':\n", name)) print(expr) globals <- globalsOf(expr, dotdotdot = "return") print(globals) assert_identical_sets(names(globals), truth[[name]]) if (name == "warn1") { stopifnot(all.equal(globals$`...`, args, check.attributes = FALSE)) } stopifnot(all.equal(globals$sum, base::sum)) stopifnot(all.equal(globals$x, x)) message("\n*** globalsOf(dotdotdot = 'warning'):") cat(sprintf("Expression '%s':\n", name)) print(expr) globals <- globalsOf(expr, dotdotdot = "warning") print(globals) assert_identical_sets(names(globals), truth[[name]]) if (name == "warn1") { stopifnot(all.equal(globals$`...`, args, check.attributes = FALSE)) } stopifnot(all.equal(globals$sum, base::sum)) stopifnot(all.equal(globals$x, x)) message("\n*** globalsOf(dotdotdot = 'error'):") cat(sprintf("Expression '%s':\n", name)) print(expr) globals <- tryCatch(globalsOf(expr, dotdotdot = "error"), error = identity) if (name %in% c("ok1", "ok2")) { assert_identical_sets(names(globals), truth[[name]]) stopifnot(all.equal(globals$sum, base::sum)) stopifnot(all.equal(globals$x, x)) } else { stopifnot(inherits(globals, "error")) } } # for (name ...) message("\n*** globalsOf(, dotdotdot = 'return'):") print(exprs) globals <- globalsOf(exprs, dotdotdot = "return") print(globals) } # aux() aux(x = 3:4, y = 1, z = 42L, 3.14, exprs = exprs) message("*** function(x, ...) globalsOf() ... DONE") ## Cleanup globals/inst/WORDLIST0000644000176200001440000000034414777644367014076 0ustar liggesusersAST AppVeyor CMD Globals NULLs NativeSymbolInfo Pre TBD codetools dotdotdot enterLocal env envir envname expr findGlobals fst getGlobals globals globalsByName globalsOf macOS mustExist na nnn packagesOf pre purrr vapply walkAST globals/man/0000755000176200001440000000000015004026770012451 5ustar liggesusersglobals/man/walkAST.Rd0000644000176200001440000000136214372744677014274 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/walkAST.R \name{walkAST} \alias{walkAST} \title{Walk the Abstract Syntax Tree (AST) of an R Expression} \usage{ walkAST( expr, atomic = NULL, name = NULL, call = NULL, pairlist = NULL, substitute = FALSE ) } \arguments{ \item{expr}{R \link[base]{expression}.} \item{atomic, name, call, pairlist}{single-argument function that takes an atomic, name, call and pairlist expression, respectively. Have to return a valid R expression.} \item{substitute}{If TRUE, \code{expr} is \code{\link[base]{substitute}()}:ed.} } \value{ R \link[base]{expression}. } \description{ Walk the Abstract Syntax Tree (AST) of an R Expression } \keyword{internal} \keyword{programming} globals/man/Globals.Rd0000644000176200001440000000142314777644360014344 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/Globals-class.R \name{Globals} \alias{Globals} \alias{as.Globals} \alias{as.Globals.Globals} \alias{as.Globals.list} \alias{[.Globals} \alias{names} \title{A representation of a set of globals} \usage{ Globals(object, ...) } \arguments{ \item{object}{A named list.} \item{\ldots}{Not used.} } \value{ An object of class \code{Globals}, which is a \emph{named} list of the value of the globals, where the element names are the names of the globals. Attribute \code{where} is a named list of the same length and with the same names. } \description{ A representation of a set of globals } \seealso{ The \code{\link{globalsOf}()} function identifies globals from an R expression and returns a Globals object. } globals/man/cleanup.Globals.Rd0000644000176200001440000000075214777644360015776 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/cleanup.R \name{cleanup.Globals} \alias{cleanup.Globals} \alias{cleanup} \title{Drop certain types of globals} \usage{ \method{cleanup}{Globals}(globals, drop = c("missing", "base-packages", "nativesymbolinfo"), ...) } \arguments{ \item{globals}{A Globals object.} \item{drop}{A character vector specifying what type of globals to drop.} \item{\ldots}{Not used} } \description{ Drop certain types of globals } globals/man/packagesOf.Globals.Rd0000644000176200001440000000067314777644360016414 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/packagesOf.R \name{packagesOf.Globals} \alias{packagesOf.Globals} \alias{packagesOf} \title{Identify the packages of the globals} \usage{ \method{packagesOf}{Globals}(globals, ...) } \arguments{ \item{globals}{A Globals object.} \item{\ldots}{Not used.} } \value{ Returns a character vector of package names. } \description{ Identify the packages of the globals } globals/man/globalsOf.Rd0000644000176200001440000000751415004026770014657 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/findGlobals.R, R/globalsOf.R \name{findGlobals} \alias{findGlobals} \alias{globalsOf} \title{Get all global objects of an expression} \usage{ findGlobals( expr, envir = parent.frame(), ..., attributes = TRUE, tweak = NULL, dotdotdot = c("warning", "error", "return", "ignore"), method = c("ordered", "conservative", "liberal", "dfs"), substitute = FALSE, unlist = TRUE, trace = FALSE ) globalsOf( expr, envir = parent.frame(), ..., method = c("ordered", "conservative", "liberal", "dfs"), tweak = NULL, locals = NA, substitute = FALSE, mustExist = TRUE, unlist = TRUE, recursive = TRUE, skip = NULL ) } \arguments{ \item{expr}{An R expression.} \item{envir}{The environment from where to search for globals.} \item{attributes}{If TRUE (default), attributes of \code{expr} are also searched. If FALSE, they are not. If a character vector, then attributes with matching names are searched. Note, the attributes of the attributes elements are not searched, that is, attributes are not searched recursively. Also, attributes are searched with `dotdotdot = "ignore".} \item{tweak}{An optional function that takes an expression and returns a tweaked expression.} \item{dotdotdot}{TBD.} \item{method}{A character string specifying what type of search algorithm to use.} \item{substitute}{If TRUE, the expression is \code{substitute()}:ed, otherwise not.} \item{unlist}{If TRUE, a list of unique objects is returned. If FALSE, a list of \code{length(expr)} sublists.} \item{trace}{TBD.} \item{locals}{Should globals part of any "local" environment of a function be included or not?} \item{mustExist}{If TRUE, an error is thrown if the object of the identified global cannot be located. Otherwise, the global is not returned.} \item{recursive}{If TRUE, globals that are closures (functions) and that exist outside of namespaces ("packages"), will be recursively scanned for globals.} \item{skip}{(internal) A list of globals not to be searched for additional globals. Ignored unless \code{recursive} is TRUE.} \item{\ldots}{Not used.} } \value{ \code{findGlobals()} returns a character vector. \code{globalsOf()} returns a \link{Globals} object. } \description{ Get all global objects of an expression } \details{ There currently three strategies for identifying global objects. The \code{method = "ordered"} search method identifies globals such that a global variable preceding a local variable with the same name is not dropped (which the \code{"conservative"} method would). The \code{method = "conservative"} search method tries to keep the number of false positive to a minimum, i.e. the identified objects are most likely true global objects. At the same time, there is a risk that some true globals are not identified (see example). This search method returns the exact same result as the \code{\link[codetools]{findGlobals}()} function of the \pkg{codetools} package. The \code{method = "liberal"} search method tries to keep the true-positive ratio as high as possible, i.e. the true globals are most likely among the identified ones. At the same time, there is a risk that some false positives are also identified. The \code{method = "dfs"} search method identifies globals in the abstract syntax tree (AST) using a depth-first search, which better emulates how the R engine identifies global variables. With \code{recursive = TRUE}, globals part of locally defined functions will also be found, otherwise not. } \examples{ b <- 2 expr <- substitute({ a <- b; b <- 1 }) ## Will _not_ identify 'b' (because it's also a local) globalsC <- globalsOf(expr, method = "conservative") print(globalsC) ## Will identify 'b' globalsL <- globalsOf(expr, method = "liberal") print(globalsL) } \seealso{ Internally, the \pkg{codetools} package is utilized for code inspections. } globals/man/globalsByName.Rd0000644000176200001440000000340514777644360015502 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/globalsByName.R \name{globalsByName} \alias{globalsByName} \title{Locates and retrieves a set of global variables by their names} \usage{ globalsByName(names, envir = parent.frame(), mustExist = TRUE, ...) } \arguments{ \item{names}{A character vector of global variable names.} \item{envir}{The environment from where to search for globals.} \item{mustExist}{If TRUE, an error is thrown if the object of the identified global cannot be located. Otherwise, the global is not returned.} \item{\ldots}{Not used.} } \value{ A \link{Globals} object of named elements and an attribute \code{where} with named elements. Both of sets have names according to \code{names}. } \description{ Locates and retrieves a set of global variables by their names } \section{Special "argument" globals}{ If \code{names} specifies \code{"..."}, \code{"..1"}, \code{"..2"}, ..., then they are interpreted as arguments \code{...}, \code{..1}, \code{..2}, ..., respectively. If specified, then the corresponding elements in the results are lists of class \code{DotDotDotList} comprising the value of the latter. If the special argument does not exist, then the value is \code{NA}, and the corresponding \code{where} attributes is \code{NULL}. } \examples{ f <- function(x = 42, ...) { globalsByName("x") } globals <- f() str(globals) globals <- f(3.14) str(globals) g <- function(x = 42, ...) { globalsByName("...") } globals <- g() str(globals) globals <- g(3.14) str(globals) globals <- g(3.14, 1L, b = 2L, c = 3L) str(globals) h <- function(x = 42, ...) { globalsByName("..2") } globals <- h(x = 3.14, a = 1, b = 2) str(globals) globals <- g(3.14) str(globals) globals <- g(3.14, 1L, b = 2L, c = 3L) str(globals) } globals/man/private_length.Rd0000644000176200001440000000103614372744677015777 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/utils.R \name{.length} \alias{.length} \title{Gets the length of an object without dispatching} \usage{ .length(x) } \arguments{ \item{x}{Any \R object.} } \value{ A non-negative integer. } \description{ Gets the length of an object without dispatching } \details{ This function returns \code{length(unclass(x))}, but tries to avoid calling \code{unclass(x)} unless necessary. } \seealso{ \code{\link{.subset}()} and \code{\link{.subset2}()}. } \keyword{internal} globals/DESCRIPTION0000644000176200001440000000222115007071223013375 0ustar liggesusersPackage: globals Version: 0.18.0 Depends: R (>= 3.1.2) Imports: codetools Title: Identify Global Objects in R Expressions Authors@R: c( person("Henrik", "Bengtsson", role=c("aut", "cre", "cph"), email="henrikb@braju.com"), person("Davis","Vaughan", role="ctb", email="davis@posit.co")) Description: Identifies global ("unknown" or "free") objects in R expressions by code inspection using various strategies (ordered, liberal, conservative, or deep-first search). The objective of this package is to make it as simple as possible to identify global objects for the purpose of exporting them in parallel, distributed compute environments. License: LGPL (>= 2.1) LazyLoad: TRUE ByteCompile: TRUE Language: en-US Encoding: UTF-8 URL: https://globals.futureverse.org, https://github.com/futureverse/globals BugReports: https://github.com/futureverse/globals/issues RoxygenNote: 7.3.2 NeedsCompilation: no Packaged: 2025-05-08 08:30:29 UTC; henrik Author: Henrik Bengtsson [aut, cre, cph], Davis Vaughan [ctb] Maintainer: Henrik Bengtsson Repository: CRAN Date/Publication: 2025-05-08 09:00:03 UTC