globals/0000755000176200001440000000000013756514422011706 5ustar liggesusersglobals/NAMESPACE0000644000176200001440000000121413756506462013130 0ustar liggesusers# Generated by roxygen2: do not edit by hand S3method("$<-",Globals) S3method("[",Globals) S3method("names<-",Globals) S3method(as.Globals,Globals) 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/man/0000755000176200001440000000000013730674406012462 5ustar liggesusersglobals/man/globalsByName.Rd0000644000176200001440000000127613557155312015473 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/globalsOf.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{...}{Not used.} } \value{ A \link{Globals} object. } \description{ Locates and retrieves a set of global variables by their names } globals/man/private_length.Rd0000644000176200001440000000103613557155312015761 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/man/packagesOf.Globals.Rd0000644000176200001440000000067213557155312016400 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{\dots}{Not used.} } \value{ Returns a character vector of package names. } \description{ Identify the packages of the globals } globals/man/cleanup.Globals.Rd0000644000176200001440000000075113730674406015765 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{\dots}{Not used} } \description{ Drop certain types of globals } globals/man/Globals.Rd0000644000176200001440000000111513557155312014327 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{\dots}{Not used.} } \value{ An object of class \code{Future}. } \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/globalsOf.Rd0000644000176200001440000000702113730674406014661 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"), substitute = FALSE, unlist = TRUE, trace = FALSE ) globalsOf( expr, envir = parent.frame(), ..., method = c("ordered", "conservative", "liberal"), tweak = NULL, 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{\dots}{Not used.} \item{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".} \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{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.} } \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. 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{\link{codetools}} package is utilized for code inspections. } globals/man/walkAST.Rd0000644000176200001440000000171113573014656014257 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{name}{single-argument function that takes a name expression.} \item{call}{single-argument function that takes a call expression.} \item{pairlist}{single-argument function that takes a pairlist 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/DESCRIPTION0000644000176200001440000000207513756514422013420 0ustar liggesusersPackage: globals Version: 0.14.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@rstudio.com")) Description: Identifies global ("unknown" or "free") objects in R expressions by code inspection using various strategies (ordered, liberal, or conservative). 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 URL: https://github.com/HenrikBengtsson/globals BugReports: https://github.com/HenrikBengtsson/globals/issues RoxygenNote: 7.1.1 NeedsCompilation: no Packaged: 2020-11-22 16:11:06 UTC; hb Author: Henrik Bengtsson [aut, cre, cph], Davis Vaughan [ctb] Maintainer: Henrik Bengtsson Repository: CRAN Date/Publication: 2020-11-22 17:00:02 UTC globals/tests/0000755000176200001440000000000013756506632013054 5ustar liggesusersglobals/tests/incl/0000755000176200001440000000000013756005607013775 5ustar liggesusersglobals/tests/incl/start,load-only.R0000644000176200001440000000154613573014656017157 0ustar liggesuserssource("incl/globals.R") ## Record original state ovars <- ls() oenvs <- oenvs0 <- Sys.getenv() oopts0 <- options() ## Default options for tests oopts <- options() ## Private global 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 assert_identical_sets <- function(a, b) { a <- sort(a) b <- sort(b) if (!identical(a, b)) { stop(sprintf("Non-identical sets: %s != %s", paste(sQuote(a), collapse = ", "), paste(sQuote(b), collapse = ", "))) } } ## WORKAROUND: Make sure tests also work with 'covr' package covr <- ("covr" %in% loadedNamespaces()) if (covr) { globalenv <- function() parent.frame() baseenv <- function() environment(base::sample) } globals/tests/incl/start.R0000644000176200001440000000006413573014656015256 0ustar liggesuserslibrary("globals") source("incl/start,load-only.R") globals/tests/incl/globals.R0000644000176200001440000000104013756005607015536 0ustar liggesusers## 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") }) ) globals/tests/incl/end.R0000644000176200001440000000217313573014656014672 0ustar liggesusers## Undo options ## (a) Added added <- setdiff(names(options()), names(oopts0)) opts <- vector("list", length = length(added)) names(opts) <- added options(opts) ## (b) Modified options(oopts) ## (c) Removed, e.g. future.plan=NULL removed <- setdiff(names(oopts0), names(options())) opts <- oopts0[removed] options(opts) ## (d) Assert that everything was undone stopifnot(identical(options(), oopts0)) ## Undo system environment variables ## (a) Added cenvs <- Sys.getenv() added <- setdiff(names(cenvs), names(oenvs0)) for (name in added) Sys.unsetenv(name) ## (b) Missing missing <- setdiff(names(oenvs0), names(cenvs)) if (length(missing) > 0) do.call(Sys.setenv, as.list(oenvs0[missing])) ## (c) Modified? for (name in intersect(names(cenvs), names(oenvs0))) { ## WORKAROUND: On Linux Wine, base::Sys.getenv() may ## return elements with empty names. /HB 2016-10-06 if (nchar(name) == 0) next if (!identical(cenvs[[name]], oenvs0[[name]])) { do.call(Sys.setenv, as.list(oenvs0[name])) } } ## (d) Assert that everything was undone stopifnot(identical(Sys.getenv(), oenvs0)) ## Undo variables rm(list = c(setdiff(ls(), ovars))) globals/tests/utils.R0000644000176200001440000001032013744645715014336 0ustar liggesuserssource("incl/start.R") 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("* 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() - local objects of 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") source("incl/end.R") globals/tests/zzz.R0000644000176200001440000000003513557155312014024 0ustar liggesusers## Just a dummy place holder globals/tests/conservative.R0000644000176200001440000000365213573014656015712 0ustar liggesuserssource("incl/start.R") ## 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 source("incl/end.R") globals/tests/Globals.R0000644000176200001440000001433313573014656014563 0ustar liggesuserssource("incl/start.R") a <- 1 b <- 2 message("*** Globals() ...") globals0 <- globalsByName(c("a", "rnorm")) globals <- globals0 str(globals) where <- attr(globals, "where") stopifnot( 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( 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( 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( 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( 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( 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( 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 ...") globals <- globals0 globals$a <- globals0["a"] str(globals) where <- attr(globals, "where") stopifnot( length(globals) == 2L, length(where) == length(globals), all(names(globals) == names(globals0)), all(names(globals) == names(where)), identical(globals, globals0) ) globals <- globals0 globals$b <- globals0["a"] str(globals) where <- attr(globals, "where") stopifnot( length(globals) == 3L, length(where) == length(globals), all(names(globals) == c(names(globals0), "b")), all(names(globals) == names(where)), identical(globals$b, globals0$a) ) globals <- globals0 globals$a <- NULL str(globals) where <- attr(globals, "where") stopifnot( length(globals) == 1L, length(where) == length(globals), all(names(globals) == names(globals0)[-1]), all(names(globals) == names(where)), is.null(globals$a) ) globals <- globals0 globals$a <- 1:2 str(globals) where <- attr(globals, "where") stopifnot( length(globals) == 2L, length(where) == length(globals), all(names(globals) == names(globals0)), all(names(globals) == names(where)), identical(globals$a, 1:2) ) 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( 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( 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( 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( length(globals) == 4L, length(where) == length(globals), all(names(globals) == c(names(globals_a), "b", "c")), all(names(globals) == names(where)) ) message("*** Globals() - combining ... DONE") message("*** Globals() - unique ...") globals <- globals0[c(1:2, 1:2, 1:2)] str(globals) where <- attr(globals, "where") stopifnot( 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( 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(identical(globals, globals0)) globals <- as.Globals(unclass(globals0)) stopifnot(identical(globals, globals0)) globals_t <- unclass(globals0) attr(globals_t, "where") <- NULL globals <- as.Globals(globals_t) stopifnot( length(globals) == length(globals0), names(globals) == names(globals0) ) message("*** Globals() - coercion ... DONE") message("*** Globals() - empty ...") globals <- Globals() globals <- Globals(list()) globals <- as.Globals(list()) message("*** Globals() - empty ... 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") source("incl/end.R") globals/tests/findGlobals.R0000644000176200001440000001112313756370054015416 0ustar liggesuserssource("incl/start.R") 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")) globals_i <- findGlobals(function() { a <- a + 1 a }) print(globals_i) assert_identical_sets(globals_i, c("{", "<-", "a", "+")) globals_i <- findGlobals(function() { a a <- a + 1 }) print(globals_i) assert_identical_sets(globals_i, c("{", "a", "<-", "+")) globals_i <- findGlobals(function(x) x <- x) print(globals_i) assert_identical_sets(globals_i, c("<-")) globals_i <- findGlobals(function(x) x[1] <- 0) print(globals_i) assert_identical_sets(globals_i, c("<-", "[", "[<-")) globals_i <- findGlobals(function(x) a <- x$a) print(globals_i) assert_identical_sets(globals_i, c("<-", "$")) globals_i <- findGlobals(function(...) args <- list(...)) print(globals_i) assert_identical_sets(globals_i, c("<-", "list")) globals_i <- findGlobals({ function(x) x; x }, substitute = TRUE) print(globals_i) assert_identical_sets(globals_i, c("{", "x")) message(" ** findGlobals(..., tweak):") tweak_another_expression <- function(expr) { quote({ x <- B B <- 1 y <- C z <- D }) } expr <- exprs$A globals_i <- findGlobals(expr, tweak = tweak_another_expression) assert_identical_sets(globals_i, c("{", "<-", "B", "C", "D")) message(" ** findGlobals(..., trace = TRUE):") expr <- exprs$A globals_i <- findGlobals(expr, trace = TRUE) print(globals_i) assert_identical_sets(globals_i, c("{", "<-", "b", "c", "d", "+", "a", "e")) message(" ** findGlobals(a <- pkg::a):") expr <- exprs$B globals_i <- findGlobals(expr) print(globals_i) assert_identical_sets(globals_i, c("<-", "::")) message(" ** findGlobals(a[1] <- 0) etc.:") globals_i <- findGlobals(a[1] <- 0, substitute = TRUE) print(globals_i) false_globals <- "[" assert_identical_sets(setdiff(globals_i, false_globals), c("<-", "a", "[<-")) globals_i <- findGlobals({ a[1] = 0 }, substitute = TRUE) print(globals_i) false_globals <- "[" assert_identical_sets(setdiff(globals_i, false_globals), c("{", "=", "a", "[<-")) globals_i <- findGlobals(a[b <- 1] <- 0, substitute = TRUE) print(globals_i) false_globals <- "[" assert_identical_sets(setdiff(globals_i, false_globals), c("<-", "a", "[<-")) globals_i <- findGlobals(a[b = 1] <- 0, substitute = TRUE) print(globals_i) false_globals <- "[" assert_identical_sets(setdiff(globals_i, false_globals), c("<-", "a", "[<-")) globals_i <- findGlobals({ a[b <- 1] = 0 }, substitute = TRUE) print(globals_i) false_globals <- "[" assert_identical_sets(setdiff(globals_i, false_globals), c("{", "=", "a", "<-", "[<-")) globals_i <- findGlobals(a$b <- 0, substitute = TRUE) print(globals_i) false_globals <- "$" assert_identical_sets(setdiff(globals_i, false_globals), c("<-", "a", "$<-")) globals_i <- findGlobals({ a$b = 0 }, substitute = TRUE) print(globals_i) false_globals <- "$" assert_identical_sets(setdiff(globals_i, false_globals), c("{", "=", "a", "$<-")) globals_i <- findGlobals(names(a) <- "A", substitute = TRUE) print(globals_i) assert_identical_sets(globals_i, c("<-", "a", "names", "names<-")) globals_i <- findGlobals({ names(a) = "A" }, substitute = TRUE) print(globals_i) assert_identical_sets(globals_i, c("{", "=", "a", "names", "names<-")) ## In order to handle the following case, we have to accept a few ## false positives (`[`, `[[`, `$`, `[<-`, `[[<-`) globals_i <- findGlobals(names(a)[1] <- "A", substitute = TRUE) print(globals_i) false_globals <- c("[", "[<-") assert_identical_sets(setdiff(globals_i, false_globals), c("<-", "a", "names", "names<-")) globals_i <- findGlobals({ names(a)[1] = "A" }, substitute = TRUE) print(globals_i) false_globals <- c("[", "[<-") assert_identical_sets(setdiff(globals_i, false_globals), c("{", "=", "a", "names", "names<-")) # BUG: https://github.com/HenrikBengtsson/globals/issues/60 expr <- as.call(list(function(...) GLOBAL, quote(ARG))) for (method in c("conservative", "liberal", "ordered")) { globals_i <- findGlobals(expr, method = method) print(globals_i) assert_identical_sets(globals_i, c("GLOBAL", "ARG")) } message("*** findGlobals() ... DONE") source("incl/end.R") globals/tests/walkAST.R0000644000176200001440000000571513573014656014512 0ustar liggesuserssource("incl/start.R") 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") } nullify <- function(e) NULL disp <- function(expr) { cat("Expression:\n") print(expr) cat("str():\n") 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") source("incl/end.R") globals/tests/cleanup.R0000644000176200001440000000241413730674406014624 0ustar liggesuserssource("incl/start.R") 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() ... DONE") source("incl/end.R") globals/tests/globalsOf.R0000644000176200001440000001705013756370226015110 0ustar liggesuserssource("incl/start.R") 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 local 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) == 0L) globals <- cleanup(globals) str(globals) assert_identical_sets(names(globals), c("c", "d")) pkgs <- packagesOf(globals) print(pkgs) stopifnot(length(pkgs) == 0L) 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") source("incl/end.R") globals/tests/liberal.R0000644000176200001440000000364213573014656014613 0ustar liggesuserssource("incl/start.R") ## 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 source("incl/end.R") globals/tests/formulas.R0000644000176200001440000000442113740666334015027 0ustar liggesuserssource("incl/start.R") 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") source("incl/end.R") globals/tests/globalsByName.R0000644000176200001440000000507413573014656015721 0ustar liggesuserssource("incl/start.R") 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")) ## 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") source("incl/end.R") globals/tests/dotdotdot.R0000644000176200001440000001412313756366101015177 0ustar liggesuserssource("incl/start.R") options(warn = 1L) exprs <- list( ok1 = quote(function(...) sum(x, ...)), warn1 = quote(sum(x, ...)), ok2 = quote(function(...) sum(x, ..1, ..2, ..3)), 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("\n*** codetools::findGlobals():") fun <- globals:::as_function(expr) print(fun) globals <- codetools::findGlobals(fun) print(globals) assert_identical_sets(globals, c("sum", "x")) 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, exprs = exprs) message("*** function(x, ...) globalsOf() ... DONE") ## Cleanup source("incl/end.R") globals/NEWS0000644000176200001440000002527613756506456012431 0ustar liggesusersPackage: globals ================ 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: o 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: o 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: o 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 function from an in-house package to this package. Version: 0.1.0 [2015-02-07] * Created. globals/R/0000755000176200001440000000000013756367756012127 5ustar liggesusersglobals/R/utils.R0000644000176200001440000002035413756366370013405 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) packageName <- env$.packageName 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() ## From future 1.3.0 mdebug <- function(...) { if (!getOption("globals.debug", FALSE)) return(invisible(FALSE)) message(sprintf(...)) invisible(TRUE) } ## mdebug() #' @importFrom utils capture.output str mstr <- function(...) { bfr <- capture.output(str(...)) bfr <- paste(bfr, collapse = "\n") message(bfr, appendLF = TRUE) } #' @importFrom utils capture.output envname <- function(env) { if (!is.environment(env)) return(NA_character_) name <- environmentName(env) if (name == "") { class <- class(env) if (identical(class, "environment")) { ## e.g. new.env() name <- capture.output(print(env)) } else { ## It might be that 'env' is on a class that extends 'environment', ## e.g. R.oo::Object() or R6::R6Class(). ## IMPORTANT: The unset class must be temporary, because changing ## the class of an environment will name <- local({ on.exit(class(env) <- class) class(env) <- NULL capture.output(print(env)) }) } if (length(name) > 1L) name <- name[1] name <- gsub("(.*: |>)", "", name) } else { ## e.g. globals:::where("plan") name <- gsub("package:", "", name, fixed = TRUE) } name } ## 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, FUN, ...) { n <- .length(X) res <- vector("list", length = n) for (kk in seq_len(n)) { 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/zzz.R0000644000176200001440000000104413557155312013064 0ustar liggesusers## covr: skip=all .onLoad <- function(libname, pkgname) { ## 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/findGlobals.R0000644000176200001440000005662113756367170014476 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) } #' @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) } #' @importFrom codetools walkCode find_globals_ordered <- function(expr, envir, dotdotdot, ..., name = character(), class = character(), trace = FALSE) { selfassign <- getOption("globals.selfassign", TRUE) 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: %s\n", paste(sQuote(hardcoded_locals), collapse = ", ")) 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: %s\n", paste(sQuote(globals), collapse = ", ")) } 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_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: %s\n", paste(sQuote(hardcoded_locals), collapse = ", ")) 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"), paste(sQuote(globals), collapse = ", ")) 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"), paste(sQuote(globals), collapse = ", ")) class <<- c(class, rep("global", times = length(globals))) name <<- c(name, globals) } } } else { if (trace) trace_printf("a function not of interest\n") } } else { if (trace) trace_printf("nothing to else to explore\n") } } 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.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"), paste(sQuote(globals), collapse = ", ")) 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"), paste(sQuote(locals), collapse = ", ")) class <- c(class, rep("locals", times = length(locals))) name <- c(name, locals) } } } } else { if (trace) trace_printf("type = call\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)) { debug && mdebug(" - 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: %s\n", paste(sQuote(globals), collapse = ", ")) } if (length(dotdotdots) > 0L) { dotdotdots <- unique(dotdotdots) if (trace) { trace_printf("dotdotdots: %s\n", paste(sQuote(dotdotdots), collapse = ", ")) } globals <- c(globals, dotdotdots) } globals } #' @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"), substitute = FALSE, unlist = TRUE, trace = FALSE) { method <- match.arg(method, choices = c("ordered", "conservative", "liberal")) dotdotdot <- match.arg(dotdotdot, choices = c("warning", "error", "return", "ignore")) if (substitute) expr <- substitute(expr) if (trace) { trace_msg <- trace_enter("findGlobals(..., dotdotdot = '%s', method = '%s', unlist = %s)", dotdotdot, method, unlist) on.exit(trace_exit(trace_msg)) } debug <- mdebug("findGlobals(..., dotdotdot = '%s', method = '%s', unlist = %s) ...", dotdotdot, method, unlist) 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)) { debug && mdebug(" - 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 <- !(types %in% basicTypes) ## Don't use expr[keep] here, because that may use S3 dispatching ## depending on class(expr) expr <- .subset(expr, keep) ## Early stopping? if (.length(expr) == 0) { debug && mdebug(" - globals found: [0] ") debug && mdebug("findGlobals(..., dotdotdot = '%s', method = '%s', unlist = %s) ... DONE", dotdotdot, method, unlist) #nolint return(character(0L)) } globals <- list_apply(expr, FUN = findGlobals, envir = envir, attributes = attributes, ..., tweak = tweak, dotdotdot = dotdotdot, method = method, substitute = FALSE, unlist = FALSE, trace = trace) keep <- types <- NULL ## Not needed anymore debug && mdebug(" - 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]) } debug && mdebug(" - globals found: [%d] %s", length(globals), hpaste(sQuote(globals))) debug && mdebug("findGlobals(..., dotdotdot = '%s', method = '%s', unlist = %s) ... DONE", dotdotdot, method, unlist) #nolint return(globals) } if (is.function(tweak)) { debug && mdebug(" - tweaking expression using function") expr <- tweak(expr) } 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) ## 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) { 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) debug && mdebug(" - globals found in attributes: [%d] %s", length(attrs_globals), hpaste(sQuote(attrs_globals))) globals <- unique(c(globals, attrs_globals)) } } debug && mdebug(" - globals found: [%d] %s", length(globals), hpaste(sQuote(globals))) debug && mdebug("findGlobals(..., dotdotdot = '%s', method = '%s', unlist = %s) ... DONE", dotdotdot, method, unlist) #nolint 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: %s\n", paste(sQuote(parnames), collapse = ", ")) } formals_clean <- drop_missing_formals(formals) # locals <- findLocalsList(c(list(body), formals_clean)) locals <- findLocalsList(formals_clean) if (trace) { trace_printf("formals_clean: %s\n", paste(sQuote(formals_clean), collapse = ", ")) trace_printf("locals: %s\n", paste(sQuote(locals), collapse = ", ")) } ## Hardcode locals? hardcoded_locals <- c(parnames, locals) if (length(hardcoded_locals) > 0) { if (trace) trace_printf("Add hardcoded local variables %s", paste(sQuote(hardcoded_locals), collapse = ", ")) 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: %s\n", paste(sQuote(names(w$env)), collapse = ", ")) } 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/packagesOf.R0000644000176200001440000000165613557155442014307 0ustar liggesusers#' @export packagesOf <- function(...) UseMethod("packagesOf") #' Identify the packages of the globals #' #' @param globals A Globals object. #' @param \dots Not used. #' #' @return Returns a character vector of package names. #' #' @aliases packagesOf #' @export packagesOf.Globals <- function(globals, ...) { ## Scan 'globals' for which packages needs to be loaded. ## This information is in the environment name of the objects. pkgs <- vapply(globals, FUN = function(obj) { environmentName(environment(obj)) }, FUN.VALUE = "", USE.NAMES = FALSE) ## 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/walkAST.R0000644000176200001440000000701413725237434013543 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 name single-argument function that takes a name expression. #' @param call single-argument function that takes a call expression. #' @param pairlist single-argument function that takes a pairlist 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) %in% c("builtin", "closure", "special", "expression", "S4", "environment")) { ## Nothing to do ## FIXME: ... or can closures and 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/cleanup.R0000644000176200001440000000577113730674406013674 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 \dots 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 && 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/globalsOf.R0000644000176200001440000002251613730674406014151 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 \dots 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 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. #' #' With \code{recursive = TRUE}, globals part of locally defined #' functions will also be found, otherwise not. #' #' @example incl/globalsOf.R #' #' @seealso #' Internally, the \pkg{\link{codetools}} package is utilized for #' code inspections. #' #' @aliases findGlobals #' @export globalsOf <- function(expr, envir = parent.frame(), ..., method = c("ordered", "conservative", "liberal"), tweak = NULL, substitute = FALSE, mustExist = TRUE, unlist = TRUE, recursive = TRUE, skip = NULL) { method <- match.arg(method, choices = c("ordered", "conservative", "liberal")) if (substitute) expr <- substitute(expr) stop_if_not(is.null(skip) || is.list(skip)) debug <- mdebug("globalsOf(..., method = '%s', mustExist = %s, unlist = %s, recursive = %s) ...", method, mustExist, unlist, recursive) #nolint ## 1. Identify global variables (static code inspection) names <- findGlobals(expr, envir = envir, ..., method = method, tweak = tweak, substitute = FALSE, unlist = unlist) debug && mdebug(" - 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) }) debug && mdebug(" - preliminary globals (by value): [%d] %s", length(globals), hpaste(sQuote(names(globals)))) ## 3. Among globals that are closures (functions) and that exist outside ## of namespaces ("packages"), check for additional globals? if (recursive) { debug && mdebug(" - 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())] debug && mdebug(" - 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) { debug && mdebug(" - 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)) { debug && mdebug(" + 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, 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) debug && mdebug(" - updated set of globals found: [%d] %s", length(globals), hpaste(sQuote(names(globals)))) } else { debug && mdebug(" - subset of globals to be scanned: [0]") } debug && mdebug(" - recursive scan of preliminary globals ... DONE") } debug && mdebug(" - globals found: [%d] %s", length(globals), hpaste(sQuote(names(globals)))) debug && mdebug("globalsOf(..., method = '%s', mustExist = %s, unlist = %s, recursive = %s) ... DONE", method, mustExist, unlist, recursive) #nolint globals } ## globalsOf() #' 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 ... Not used. #' #' @return A \link{Globals} object. #' #' @export globalsByName <- function(names, envir = parent.frame(), mustExist = TRUE, ...) { names <- as.character(names) nnames <- length(names) debug <- mdebug("globalsByName(<%d names>, mustExist = %s) ...", nnames, mustExist) debug && mdebug("- search from environment: %s", sQuote(envname(envir))) ## Locate and retrieve the specified globals idxs <- grep("^[.][.]([.]|[0-9]+)$", names) if (length(idxs) > 0L) { dotdotdots <- unique(names[idxs]) names <- names[-idxs] idxs <- NULL debug && mdebug("- dotdotdots: %s", paste(sQuote(dotdotdots), collapse = ", ")) } else { dotdotdots <- NULL debug && mdebug("- dotdotdots: ") } globals <- structure(list(), class = c("Globals", "list")) where <- list() for (kk in seq_along(names)) { name <- names[kk] debug && mdebug("- locating #%d (%s)", kk, sQuote(name)) env <- where(name, envir = envir, inherits = TRUE) debug && mdebug(" + 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) { for (name in dotdotdots) { if (exists(name, envir = envir, inherits = TRUE)) { where[[name]] <- where(name, envir = envir, inherits = TRUE) expr <- substitute(list(arg), list(arg = as.name(name))) ddd <- eval(expr, envir = envir, enclos = envir) } else { where[name] <- list(NULL) ddd <- NA } class(ddd) <- c("DotDotDotList", class(ddd)) globals[[name]] <- ddd } } stop_if_not( is.list(where), length(where) == length(globals), all(names(where) == names(globals)) ) attr(globals, "where") <- where debug && mdebug("globalsByName(<%d names>, mustExist = %s) ... DONE", nnames, mustExist) globals } ## globalsByName() globals/R/where.R0000644000176200001440000000346013557155442013351 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 <- mdebug("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())) { debug && mdebug("- searching %s: %s", sQuote(envname(env)), hpaste(sQuote(ls(envir = env, all.names = TRUE)))) if (exists(x, envir = env, mode = mode, inherits = FALSE)) { debug && mdebug(" + found in location: %s", sQuote(envname(env))) debug && mdebug("where(%s, where = %d, envir = %s, mode = %s, inherits = %s) ... DONE", sQuote(x), where, sQuote(envname(envir)), sQuote(mode), inherits) #nolint return(env) } if (!inherits) { debug && mdebug(" + failed to locate: NULL") debug && mdebug("where(%s, where = %d, envir = %s, mode = %s, inherits = %s) ... DONE", sQuote(x), where, sQuote(envname(envir)), sQuote(mode), inherits) #nolint return(NULL) } env <- parent.env(env) } debug && mdebug("- failed to locate: NULL") debug && mdebug("where(%s, where = %d, envir = %s, mode = %s, inherits = %s) ... DONE", sQuote(x), where, sQuote(envname(envir)), sQuote(mode), inherits) NULL } globals/R/Globals-class.R0000644000176200001440000001040613714064234014714 0ustar liggesusers#' A representation of a set of globals #' #' @usage Globals(object, ...) #' #' @param object A named list. #' @param \dots Not used. #' #' @return An object of class \code{Future}. #' #' @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)) { stop("Argument 'object' is not a list: ", 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.Globals <- function(x, ...) x #' @export as.Globals.list <- function(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 = function(obj) { e <- environment(obj) if (is.null(e)) e <- emptyenv() e }) 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 } #' @export `$<-.Globals` <- function(x, name, value) { where <- attr(x, "where", exact = TRUE) ## Remove an element? if (is.null(value)) { x[[name]] <- NULL where[[name]] <- NULL } else { ## Value must be Globals object of length one if (inherits(value, "Globals")) { if (length(value) != 1) { stop("Cannot assign Globals object of length different than one: ", length(value)) } x[[name]] <- value[[1]] where[[name]] <- attr(value, "where", exact = TRUE)[[1]] } else { w <- environment(value) if (is.null(w)) w <- emptyenv() x[[name]] <- value where[[name]] <- w } } attr(x, "where") <- where 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 = function(obj) { e <- environment(obj) if (is.null(e)) e <- emptyenv() e }) names(w) <- names } else { if (is.null(name)) { stop("Can only append named objects to Globals list: ", sQuote(mode(g))) } g <- structure(list(g), names = name) e <- environment(g) if (is.null(e)) e <- emptyenv() w <- structure(list(e), names = name) } where <- c(where, w) x <- c(x, g) } class(x) <- clazz attr(x, "where") <- where 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/MD50000644000176200001440000000342313756514422012220 0ustar liggesusersccf164e694c5a1fde1717844d1b0c15c *DESCRIPTION f970927a5b8b055c0645488e58362a8d *NAMESPACE 0b8c26737a398d0f18af14c32a54cd8c *NEWS f9352d37cfd133fc12bca7b5165675cf *R/Globals-class.R 565f40ff5e73a439c85d095b47fa24bc *R/cleanup.R 67a1d6d19f822cbab8e584a418e11869 *R/findGlobals.R 371f839efc6d3a3ec251e9d1e1522df1 *R/globalsOf.R a809c2d87122ac1e7f1132e0c6a03428 *R/packagesOf.R 4c8470b9d9fed5be6d7740fa70de3182 *R/utils.R ee09ba3da4cc0e4d2c9c96835953aad2 *R/walkAST.R 5377d3f92fe155b5af0bb80fed72a1ab *R/where.R 6c105aa7e1191c6f71b3c39dcd71df6c *R/zzz.R 8715ad369b73467f165df1ddb9d46071 *inst/WORDLIST abec206d57e9f3f4d34bb4a875d35490 *man/Globals.Rd fd97c59539a927f4cd6e8622710be2c0 *man/cleanup.Globals.Rd fc7000ee5990508042e8b53ede23dae1 *man/globalsByName.Rd 41e00c77055d3e44bebd7bfe6ab403b7 *man/globalsOf.Rd 71d33dd463fd36bf678fcf037e0d62aa *man/packagesOf.Globals.Rd 8f535a3461ee9bf48f75947b66fa71d9 *man/private_length.Rd ee2b14c67dbce787ab9b683a2c820b23 *man/walkAST.Rd 7cd7521a621a4963c0cee095dc890a14 *tests/Globals.R 9618ce7d596f088b3433a3a6bd21d775 *tests/cleanup.R 4e14f10dce37601443615ffb1963c470 *tests/conservative.R 69ae42be19651785a09006513b190dfe *tests/dotdotdot.R 17d0b4a54acaef23d807feeed8e65a34 *tests/findGlobals.R 326c30ef110b6c7903184c36124c6a19 *tests/formulas.R de77337d9770e5337bd1c5aab09b65f5 *tests/globalsByName.R f6c91947dc4d94a95849d3d8b5bf838b *tests/globalsOf.R de96a98bbdd939c26009df32797ffa39 *tests/incl/end.R 46f29003ba132d4fb3c07385c787296b *tests/incl/globals.R c7740b7f891890f7103006f2a64b37f0 *tests/incl/start,load-only.R f178ec5ea5fda0b908700cc54550bf66 *tests/incl/start.R 344290e5ff01b892969ffaf91d20fc14 *tests/liberal.R 7967bddd14a1d7774ab2fe4a7f00fe49 *tests/utils.R 4d6835d9ab2dd497461bdb1aa2cb93d0 *tests/walkAST.R 7af53138f87e6ef0f9333c9b8176c51d *tests/zzz.R globals/inst/0000755000176200001440000000000013740666341012664 5ustar liggesusersglobals/inst/WORDLIST0000644000176200001440000000033113740666341014053 0ustar liggesusersAppVeyor AST CMD macOS pre Pre dotdotdot expr TBD enterLocal env envir envname findGlobals fst getGlobals globals Globals globalsByName globalsOf mustExist na NativeSymbolInfo nnn NULLs packagesOf purrr vapply walkAST