globals/0000755000176200001440000000000014336764452011713 5ustar liggesusersglobals/NAMESPACE0000644000176200001440000000133214273240134013113 0ustar liggesusers# Generated by roxygen2: do not edit by hand S3method("$<-",Globals) S3method("[",Globals) S3method("[<-",Globals) S3method("[[<-",Globals) S3method("names<-",Globals) S3method(as.Globals,Globals) S3method(as.Globals,default) S3method(as.Globals,list) S3method(c,Globals) S3method(cleanup,Globals) S3method(packagesOf,Globals) S3method(unique,Globals) export(Globals) export(as.Globals) export(cleanup) export(findGlobals) export(globalsByName) export(globalsOf) export(packagesOf) export(walkAST) importFrom(codetools,findLocalsList) importFrom(codetools,makeUsageCollector) importFrom(codetools,walkCode) importFrom(utils,capture.output) importFrom(utils,getS3method) importFrom(utils,packageDescription) importFrom(utils,str) globals/man/0000755000176200001440000000000014334274433012457 5ustar liggesusersglobals/man/globalsByName.Rd0000644000176200001440000000127614030212707015460 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.Rd0000644000176200001440000000103614030212707015746 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.Rd0000644000176200001440000000067214030212707016365 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.Rd0000644000176200001440000000075114030212707015747 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.Rd0000644000176200001440000000142214236216353014326 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{Globals}, which is a \emph{named} list of the value of the globals, where the element names are the names of the globals. Attribute \code{where} is a named list of the same length and with the same names. } \description{ A representation of a set of globals } \seealso{ The \code{\link{globalsOf}()} function identifies globals from an R expression and returns a Globals object. } globals/man/globalsOf.Rd0000644000176200001440000000720114236216353014654 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, locals = NA, substitute = FALSE, mustExist = TRUE, unlist = TRUE, recursive = TRUE, skip = NULL ) } \arguments{ \item{expr}{An R expression.} \item{envir}{The environment from where to search for globals.} \item{\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{locals}{Should globals part of any "local" environment of a function be included or not?} \item{mustExist}{If TRUE, an error is thrown if the object of the identified global cannot be located. Otherwise, the global is not returned.} \item{recursive}{If TRUE, globals that are closures (functions) and that exist outside of namespaces ("packages"), will be recursively scanned for globals.} \item{skip}{(internal) A list of globals not to be searched for additional globals. Ignored unless \code{recursive} is TRUE.} } \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.Rd0000644000176200001440000000136214334274433014256 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/walkAST.R \name{walkAST} \alias{walkAST} \title{Walk the Abstract Syntax Tree (AST) of an R Expression} \usage{ walkAST( expr, atomic = NULL, name = NULL, call = NULL, pairlist = NULL, substitute = FALSE ) } \arguments{ \item{expr}{R \link[base]{expression}.} \item{atomic, name, call, pairlist}{single-argument function that takes an atomic, name, call and pairlist expression, respectively. Have to return a valid R expression.} \item{substitute}{If TRUE, \code{expr} is \code{\link[base]{substitute}()}:ed.} } \value{ R \link[base]{expression}. } \description{ Walk the Abstract Syntax Tree (AST) of an R Expression } \keyword{internal} \keyword{programming} globals/DESCRIPTION0000644000176200001440000000214614336764452013424 0ustar liggesusersPackage: globals Version: 0.16.2 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://globals.futureverse.org, https://github.com/HenrikBengtsson/globals BugReports: https://github.com/HenrikBengtsson/globals/issues RoxygenNote: 7.2.2 NeedsCompilation: no Packaged: 2022-11-21 20:18:24 UTC; hb Author: Henrik Bengtsson [aut, cre, cph], Davis Vaughan [ctb] Maintainer: Henrik Bengtsson Repository: CRAN Date/Publication: 2022-11-21 21:10:02 UTC globals/tests/0000755000176200001440000000000014302737657013055 5ustar liggesusersglobals/tests/incl/0000755000176200001440000000000014030212707013760 5ustar liggesusersglobals/tests/incl/start,load-only.R0000644000176200001440000000154614030212707017141 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.R0000644000176200001440000000006414030212707015240 0ustar liggesuserslibrary("globals") source("incl/start,load-only.R") globals/tests/incl/globals.R0000644000176200001440000000104014030212707015521 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.R0000644000176200001440000000217314030212707014654 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.R0000644000176200001440000001066414255465026014342 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("* isPackageNamespace() ... Bug #80") `$.strict_env` <- function(x, name) get(name, envir = x, inherits = FALSE) env <- structure(new.env(), class = "strict_env") res <- globals:::isPackageNamespace(env) stopifnot(!res) message("* is.base() & is_internal() ...") stopifnot(is.base(base::library)) stopifnot(!is.base(globals::globalsOf)) stopifnot(!is.base(NULL)) stopifnot(is_internal(print.default)) stopifnot(!is_internal(globals::globalsOf)) stopifnot(!is_internal(NULL)) message("* where() ...") env <- where("sample", where = 1L) str(env) env <- where("sample", frame = 1L) str(env) message("- where('sample') ...") env <- where("sample", mode = "function") print(env) if (!"covr" %in% loadedNamespaces()) { stopifnot(identical(env, baseenv())) } obj <- get("sample", mode = "function", envir = env, inherits = FALSE) stopifnot(identical(obj, base::sample)) message("- where('sample', mode = 'integer') ...") env <- where("sample", mode = "integer") print(env) stopifnot(is.null(env)) message("- where('sample2') ...") sample2 <- base::sample env <- where("sample2", mode = "function") print(env) stopifnot(identical(env, environment())) obj <- get("sample2", mode = "function", envir = env, inherits = FALSE) stopifnot(identical(obj, sample2)) message("- where() - objects inside functions ...") aa <- 1 foo <- function() { bb <- 2 #nolint list(aa = where("aa"), bb = where("bb"), cc = where("cc"), envir = environment()) } envs <- foo() str(envs) stopifnot(identical(envs$aa, globalenv())) stopifnot(identical(envs$bb, envs$envir)) stopifnot(is.null(envs$cc)) message("- where() - missing ...") env <- where("non-existing-object", inherits = FALSE) stopifnot(is.null(env)) rm(list = c("aa", "envs", "foo", "env", "obj", "where")) message("* where() ... DONE") message("- mdebug() ...") mdebug("Message A") oopts <- options(globals.debug = TRUE) mdebug("Message B") options(oopts) message("* mdebug() ... DONE") message("*** utils ... DONE") source("incl/end.R") globals/tests/zzz.R0000644000176200001440000000003514030212707014011 0ustar liggesusers## Just a dummy place holder globals/tests/conservative.R0000644000176200001440000000365214030212707015674 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.R0000644000176200001440000002463614273240134014560 0ustar liggesuserssource("incl/start.R") assert_attributes <- function(globals) { attrs <- attributes(globals) names <- names(attrs) stopifnot( length(attrs) >= 2L, "class" %in% names, "where" %in% names, ## 'where' and 'class' should be the last two (reproducibility) names[length(names) - 1L] == "where", names[length(names) ] == "class", inherits(globals, "Globals") ) invisible(TRUE) } a <- 1 b <- 2 message("*** Globals() ...") globals0 <- globalsByName(c("a", "rnorm")) globals <- globals0 str(globals) where <- attr(globals, "where") stopifnot( assert_attributes(globals), length(globals) == 2L, length(where) == length(globals), all(names(globals) == c("a", "rnorm")), all(names(globals) == names(where)) ) message("*** Globals() - names ...") globals <- globals0 str(globals) where <- attr(globals, "where") stopifnot( assert_attributes(globals), length(globals) == 2L, length(where) == length(globals), all(names(globals) == c(names(globals0))), all(names(globals) == names(where)) ) names(globals)[1] <- "A" str(globals) where <- attr(globals, "where") stopifnot( assert_attributes(globals), length(globals) == 2L, length(where) == length(globals), all(names(globals) == c("A", names(globals0)[-1])), all(names(globals) == names(where)) ) message("*** Globals() - names ... DONE") message("*** Globals() - subsetting ...") globals <- globals0[1] str(globals) where <- attr(globals, "where") stopifnot( assert_attributes(globals), length(globals) == 1L, length(where) == length(globals), all(names(globals) == c("a")), all(names(globals) == names(where)) ) globals <- globals0[2] str(globals) where <- attr(globals, "where") stopifnot( assert_attributes(globals), length(globals) == 1L, length(where) == length(globals), all(names(globals) == c("rnorm")), all(names(globals) == names(where)) ) globals <- globals0[2:1] str(globals) where <- attr(globals, "where") stopifnot( assert_attributes(globals), length(globals) == 2L, length(where) == length(globals), all(names(globals) == c("rnorm", "a")), all(names(globals) == names(where)) ) ## rev() works automatically thanks to `[`() :) globals <- rev(globals0) str(globals) where <- attr(globals, "where") stopifnot( assert_attributes(globals), length(globals) == 2L, length(where) == length(globals), all(names(globals) == rev(names(globals0))), all(names(globals) == names(where)), identical(rev(globals), globals0) ) message("*** Globals() - subsetting ... DONE") message("*** Globals() - subsetted assignment ...") message("1.") globals <- globals0 globals$a <- globals0["a"] str(globals) where <- attr(globals, "where") stopifnot( assert_attributes(globals), length(globals) == 2L, length(where) == length(globals), all(names(globals) == names(globals0)), all(names(globals) == names(where)), identical(globals, globals0) ) message("2.") globals <- globals0 globals[["a"]] <- globals0["a"] str(globals) where <- attr(globals, "where") stopifnot( assert_attributes(globals), length(globals) == 2L, length(where) == length(globals), all(names(globals) == names(globals0)), all(names(globals) == names(where)), identical(globals, globals0) ) message("3.") globals <- globals0 globals$b <- globals0["a"] str(globals) where <- attr(globals, "where") stopifnot( assert_attributes(globals), length(globals) == 3L, length(where) == length(globals), all(names(globals) == c(names(globals0), "b")), all(names(globals) == names(where)), identical(globals$b, globals0$a) ) message("4.") globals <- globals0 globals[["b"]] <- globals0["a"] str(globals) where <- attr(globals, "where") stopifnot( assert_attributes(globals), length(globals) == 3L, length(where) == length(globals), all(names(globals) == c(names(globals0), "b")), all(names(globals) == names(where)), identical(globals$b, globals0$a) ) message("5.") globals <- globals0 globals["b"] <- globals0["a"] str(globals) where <- attr(globals, "where") stopifnot( assert_attributes(globals), length(globals) == 3L, length(where) == length(globals), all(names(globals) == c(names(globals0), "b")), all(names(globals) == names(where)), identical(globals$b, globals0$a) ) message("6.") globals <- globals0 globals["b"] <- list(globals0[["a"]]) str(globals) where <- attr(globals, "where") stopifnot( assert_attributes(globals), length(globals) == 3L, length(where) == length(globals), all(names(globals) == c(names(globals0), "b")), all(names(globals) == names(where)), identical(globals$b, globals0$a) ) message("7.") globals <- globals0 globals$a <- NULL str(globals) where <- attr(globals, "where") stopifnot( assert_attributes(globals), length(globals) == 1L, length(where) == length(globals), all(names(globals) == names(globals0)[-1]), all(names(globals) == names(where)), is.null(globals$a) ) message("8.") globals <- globals0 globals$a <- 1:2 str(globals) where <- attr(globals, "where") stopifnot( assert_attributes(globals), length(globals) == 2L, length(where) == length(globals), all(names(globals) == names(globals0)), all(names(globals) == names(where)), identical(globals$a, 1:2) ) message("9.") globals <- globals0 globals[c("b", "a")] <- list(1:3, 42) str(globals) where <- attr(globals, "where") stopifnot( assert_attributes(globals), length(globals) == 3L, length(where) == length(globals), all(names(globals) == c(names(globals0), "b")), all(names(globals) == names(where)), identical(globals$b, 1:3), identical(globals$a, 42) ) message("10.") globals <- Globals() globals["empty"] <- list(NULL) str(globals) where <- attr(globals, "where") stopifnot( assert_attributes(globals), length(globals) == 1L, length(where) == length(globals), all(names(globals) == "empty"), is.null(globals[["empty"]]) ) message("*** Globals() - subsetted assignment ... DONE") message("*** Globals() - combining ...") globals_a <- globals0[1:2] globals_b <- globals0[1:2] globals <- c(globals_a, globals_b) str(globals) where <- attr(globals, "where") stopifnot( assert_attributes(globals), length(globals) == 4L, length(where) == length(globals), all(names(globals) == c(names(globals_a), names(globals_b))), all(names(globals) == names(where)) ) globals_a <- globals0[1:2] globals_b <- list(b = 1, c = letters) globals <- c(globals_a, globals_b) str(globals) where <- attr(globals, "where") stopifnot( assert_attributes(globals), length(globals) == 4L, length(where) == length(globals), all(names(globals) == c(names(globals_a), names(globals_b))), all(names(globals) == names(where)) ) globals_a <- globals0[1:2] globals_b <- list() globals <- c(globals_a, globals_b) str(globals) where <- attr(globals, "where") stopifnot( assert_attributes(globals), length(globals) == 2L, length(where) == length(globals), all(names(globals) == c(names(globals_a), names(globals_b))), all(names(globals) == names(where)) ) globals_a <- globals0[1:2] globals <- c(globals_a, b = 1, c = letters) str(globals) where <- attr(globals, "where") stopifnot( assert_attributes(globals), length(globals) == 4L, length(where) == length(globals), all(names(globals) == c(names(globals_a), "b", "c")), all(names(globals) == names(where)) ) globals <- Globals() globals_1 <- c(globals, fcn = median) str(globals_1) globals_2 <- globals globals_2$fcn <- median str(globals_2) stopifnot(identical(globals_2, globals_1)) message("*** Globals() - combining ... DONE") message("*** Globals() - unique ...") globals <- globals0[c(1:2, 1:2, 1:2)] str(globals) where <- attr(globals, "where") stopifnot( assert_attributes(globals), length(globals) == 6L, length(where) == length(globals), all(names(globals) == rep(names(globals0), times = 3L)), all(names(globals) == names(where)) ) globals <- unique(globals) str(globals) where <- attr(globals, "where") stopifnot( assert_attributes(globals), length(globals) == length(globals0), length(where) == length(globals), all(names(globals) == names(globals0)), all(names(globals) == names(where)) ) message("*** Globals() - unique ... DONE") message("*** Globals() - coercion ...") globals <- as.Globals(globals0) stopifnot( assert_attributes(globals), identical(globals, globals0) ) globals <- as.Globals(unclass(globals0)) stopifnot( assert_attributes(globals), identical(globals, globals0) ) globals_t <- unclass(globals0) attr(globals_t, "where") <- NULL globals <- as.Globals(globals_t) stopifnot( assert_attributes(globals), length(globals) == length(globals0), names(globals) == names(globals0) ) message("*** Globals() - coercion ... DONE") message("*** Globals() - empty ...") globals <- Globals() stopifnot( assert_attributes(globals), length(globals) == 0L ) globals <- Globals(list()) stopifnot( assert_attributes(globals), length(globals) == 0L ) globals <- as.Globals(list()) stopifnot( assert_attributes(globals), length(globals) == 0L ) message("*** Globals() - empty ... DONE") message("*** Globals() - NULL ...") ## https://github.com/HenrikBengtsson/globals/issues/79 denv <- getOption("globals.environment_of.default", emptyenv()) globals <- as.Globals(list(a = NULL)) str(globals) where <- attr(globals, "where") stopifnot( assert_attributes(globals), length(globals) == 1L, length(where) == length(globals), all(names(where) == names(globals)), identical(names(globals), c("a")), is.null(globals[["a"]]), identical(where[["a"]], denv) ) globals <- c(Globals(), list(a = NULL)) str(globals) where <- attr(globals, "where") stopifnot( assert_attributes(globals), length(globals) == 1L, length(where) == length(globals), all(names(where) == names(globals)), identical(names(globals), c("a")), is.null(globals[["a"]]), identical(where[["a"]], denv) ) message("*** Globals() - NULL ... DONE") message("*** Globals() - exceptions ...") res <- tryCatch({ Globals(NULL) }, error = identity) stopifnot(inherits(res, "simpleError")) res <- tryCatch({ Globals(list(1, 2)) }, error = identity) stopifnot(inherits(res, "simpleError")) res <- tryCatch({ Globals(list(a = 1, 2)) }, error = identity) stopifnot(inherits(res, "simpleError")) ## Assigning more than one element globals <- globals0 res <- tryCatch({ globals$a <- globals0[2:1] }, error = identity) stopifnot(inherits(res, "simpleError")) ## Appending unnamed objects res <- tryCatch({ c(globals0, 2) }, error = identity) stopifnot(inherits(res, "simpleError")) message("*** Globals() - exceptions ... DONE") message("*** Globals() ... DONE") source("incl/end.R") globals/tests/findGlobals.R0000644000176200001440000001132114236216353015411 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")) globals_i <- findGlobals({ "x" <- 1; x }, substitute = TRUE) print(globals_i) assert_identical_sets(globals_i, c("{", "<-")) 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.R0000644000176200001440000000571514030212707014474 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.R0000644000176200001440000000241414255005734014617 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.R0000644000176200001440000001742414302737657015120 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 functions:") a <- 1 bar <- function(x) x - a foo <- function(x) bar(x) for (method in c("ordered", "conservative", "liberal")) { globals <- globalsOf({ foo(3) }, substitute = TRUE, method = method, recursive = FALSE, mustExist = FALSE) assert_identical_sets(names(globals), c("{", "foo")) stopifnot(!any("a" %in% names(globals))) globals <- cleanup(globals) str(globals) assert_identical_sets(names(globals), c("foo")) stopifnot(!any("a" %in% names(globals))) globals <- globalsOf({ foo(3) }, substitute = TRUE, method = "ordered", recursive = TRUE, mustExist = FALSE) assert_identical_sets(names(globals), c("{", "foo", "bar", "-", "a")) globals <- cleanup(globals) str(globals) assert_identical_sets(names(globals), c("foo", "bar", "a")) globals <- globalsOf({ foo(3) }, substitute = TRUE, recursive = TRUE, mustExist = FALSE) assert_identical_sets(names(globals), c("{", "foo", "bar", "-", "a")) globals <- cleanup(globals) str(globals) assert_identical_sets(names(globals), c("foo", "bar", "a")) } message(" ** globalsOf() w/ recursive functions:") ## "Easy" f <- function() Recall() globals <- globalsOf(f) str(globals) ## Direct recursive call f <- function() f() globals <- globalsOf(f) str(globals) ## Indirect recursive call f <- function() g() g <- function() f() globals_f <- globalsOf(f) str(globals_f) globals_g <- globalsOf(g) str(globals_g) globals_f <- globals_f[order(names(globals_f))] globals_g <- globals_g[order(names(globals_g))] stopifnot(identical(globals_g, globals_f)) message("*** globalsOf() ... DONE") message("*** Subsetting of Globals:") expr <- exprs$A globals_l <- globalsOf(expr, method = "liberal") globals_s <- globals_l[-1] stopifnot(length(globals_s) == length(globals_l) - 1L) stopifnot(identical(class(globals_s), class(globals_l))) where_l <- attr(globals_l, "where") where_s <- attr(globals_s, "where") stopifnot(length(where_s) == length(where_l) - 1L) stopifnot(identical(where_s, where_l[-1])) message("*** cleanup() & packagesOf():") expr <- exprs$A globals <- globalsOf(expr, method = "conservative") str(globals) assert_identical_sets(names(globals), c("{", "<-", "c", "d", "+")) globals <- as.Globals(globals) str(globals) assert_identical_sets(names(globals), c("{", "<-", "c", "d", "+")) globals <- as.Globals(unclass(globals)) str(globals) assert_identical_sets(names(globals), c("{", "<-", "c", "d", "+")) pkgs <- packagesOf(globals) print(pkgs) stopifnot( length(pkgs) == 1L, identical(pkgs, c("base")) ) globals <- cleanup(globals) str(globals) assert_identical_sets(names(globals), c("c", "d")) pkgs <- packagesOf(globals) print(pkgs) stopifnot(length(pkgs) == 0L) globals <- globalsOf(quote(pi)) stopifnot( length(globals) == 1L, identical(names(globals), "pi") ) pkgs <- packagesOf(globals) print(pkgs) stopifnot( length(pkgs) == 1L, identical(pkgs, c("base")) ) message("*** globalsOf() and package functions:") foo <- globals::Globals expr <- exprs$C globals <- globalsOf(expr, recursive = FALSE) str(globals) assert_identical_sets(names(globals), c("{", "foo", "list")) where <- attr(globals, "where") stopifnot(length(where) == length(globals)) if (!covr) stopifnot( identical(where$`{`, baseenv()), identical(where$foo, globalenv()), identical(where$list, baseenv()) ) globals <- cleanup(globals) str(globals) assert_identical_sets(names(globals), c("foo")) pkgs <- packagesOf(globals) stopifnot(pkgs == "globals") message("*** globalsOf() and core-package functions:") sample2 <- base::sample sum2 <- base::sum expr <- exprs$D globals <- globalsOf(expr, recursive = FALSE) str(globals) assert_identical_sets(names(globals), c("{", "<-", "sample", "sample2", "sessionInfo", "sum", "sum2", "isNamespaceLoaded")) where <- attr(globals, "where") stopifnot(length(where) == length(globals)) if (!covr) stopifnot( identical(where$`<-`, baseenv()), identical(where$sample, baseenv()), identical(where$sample2, globalenv()) ) globals <- cleanup(globals, drop = "primitives") str(globals) assert_identical_sets(names(globals), c("sample", "sample2", "sum2", "sessionInfo", "isNamespaceLoaded")) globals <- cleanup(globals, drop = "internals") str(globals) assert_identical_sets(names(globals), c("sample", "sample2", "sum2", "sessionInfo")) globals <- cleanup(globals) str(globals) assert_identical_sets(names(globals), c("sample2", "sum2")) where <- attr(globals, "where") stopifnot(length(where) == length(globals)) if (!covr) stopifnot(identical(where$sample2, globalenv())) message("*** globalsOf() - exceptions ...") rm(list = "a") res <- try({ globals <- globalsOf({ x <- a }, substitute = TRUE, mustExist = TRUE) }, silent = TRUE) stopifnot(inherits(res, "try-error")) message("*** globalsOf() - exceptions ... DONE") source("incl/end.R") globals/tests/liberal.R0000644000176200001440000000364214030212707014575 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.R0000644000176200001440000000442114030212707015007 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.R0000644000176200001440000000507414030212707015703 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/globalsOf,locals.R0000644000176200001440000000244014236216353016351 0ustar liggesuserssource("incl/start.R") message("*** globalsOf() w/ local() ...") for (locals in c(TRUE, FALSE)) { message(sprintf("- locals=%s", locals)) f <- local({ a <- 42 function() a }) globals <- globalsOf(quote(f), locals = locals) str(globals) where <- attr(globals, "where") if (locals) { stopifnot( length(globals) == 2L, identical(sort(names(globals)), c("a", "f")), identical(where[["a"]], environment(globals[["f"]])) ) } else { stopifnot( length(globals) == 1L, identical(names(globals), "f") ) } message(sprintf("- locals=%s with nested local():s", locals)) f <- local({ b <- 3.14 local({ a <- 42 function() a + b }) }) globals <- globalsOf(quote(f), locals = locals) globals <- cleanup(globals) str(globals) where <- attr(globals, "where") if (locals) { stopifnot( length(globals) == 3L, identical(sort(names(globals)), c("a", "b", "f")), identical(where[["a"]], environment(globals[["f"]])), identical(where[["b"]], parent.env(environment(globals[["f"]]))) ) } else { stopifnot( length(globals) == 1L, identical(names(globals), "f") ) } } # for (locals ...) message("*** globalsOf() w/ local() ... DONE") source("incl/end.R") globals/tests/dotdotdot.R0000644000176200001440000001426214236216353015200 0ustar liggesuserssource("incl/start.R") options(warn = 2L) 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) ## Suppress '... may be used in an incorrect context' warnings suppressWarnings({ 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/R/0000755000176200001440000000000014334754410012103 5ustar liggesusersglobals/R/utils.R0000644000176200001440000002120514334274433013370 0ustar liggesusersas_function <- function(expr, envir = parent.frame(), enclos = baseenv(), ...) { fun_expr <- substitute(function() x, list(x = expr)) eval(fun_expr, envir = envir, enclos = enclos, ...) } # Although the set of "base" packages rarely changes, it has happened # in R's history. Beause of this, we avoid hardcoding the set of known # "base" packages and instead always look them up by the 'Priority' # field in their DESCRIPTION data and cache the results. #' @importFrom utils packageDescription is_base_pkg <- local({ cache <- list( R_EmptyEnv = FALSE, R_GlobalEnv = FALSE ) function(pkgs) { pkgs <- gsub("^package:", "", pkgs) npkgs <- length(pkgs) res <- rep(FALSE, times = npkgs) for (kk in seq_len(npkgs)) { pkg <- pkgs[kk] if (nzchar(pkg)) { value <- cache[[pkg]] if (is.null(value)) { prio <- suppressWarnings(packageDescription(pkg, fields = "Priority")) value <- (!is.na(prio) && prio == "base") cache[[pkg]] <<- value } } else { value <- FALSE } res[kk] <- value } res } }) # cf. is.primitive() is.base <- function(x) { if (typeof(x) != "closure") return(FALSE) is_base_pkg(environmentName(environment(x))) } # cf. is.primitive() is_internal <- function(x) { if (typeof(x) != "closure") return(FALSE) body <- deparse(body(x)) any(grepl(".Internal", body, fixed = TRUE)) } # Example: base::.C_R_removeTaskCallback is_native_symbol_info <- function(x) { if (!inherits(x, "NativeSymbolInfo")) return(FALSE) if (typeof(x) != "list") return(FALSE) address <- x$address if (!inherits(address, "RegisteredNativeSymbol")) return(FALSE) TRUE } isPackageNamespace <- function(env) { if (!is.environment(env)) return(FALSE) name <- environmentName(env) if (name == "base") return(TRUE) if (exists(".packageName", mode = "character", envir = env, inherits = FALSE)) { packageName <- get(".packageName", mode = "character", envir = env, inherits = FALSE) if (identical(name, packageName)) return(TRUE) } if (!grepl("^package:", name)) return(FALSE) (name %in% search()) } # From future 1.18.0 asPkgEnvironment <- function(pkg) { name <- sprintf("package:%s", pkg) if (!name %in% search()) return(emptyenv()) as.environment(name) } ## From R.utils 2.0.2 (2015-05-23) hpaste <- function(..., sep="", collapse=", ", last_collapse=NULL, max_head=if (missing(last_collapse)) 3 else Inf, max_tail=if (is.finite(max_head)) 1 else Inf, abbreviate="...") { max_head <- as.double(max_head) max_tail <- as.double(max_tail) if (is.null(last_collapse)) last_collapse <- collapse # Build vector 'x' x <- paste(..., sep = sep) n <- length(x) # Nothing todo? if (n == 0) return(x) if (is.null(collapse)) return(x) # Abbreviate? if (n > max_head + max_tail + 1) { head <- x[seq_len(max_head)] tail <- rev(rev(x)[seq_len(max_tail)]) x <- c(head, abbreviate, tail) n <- length(x) } if (!is.null(collapse) && n > 1) { if (last_collapse == collapse) { x <- paste(x, collapse = collapse) } else { x_head <- paste(x[1:(n - 1)], collapse = collapse) x <- paste(x_head, x[n], sep = last_collapse) } } x } ## From future 0.11.0 trim <- function(s) { sub("[\t\n\f\r ]+$", "", sub("^[\t\n\f\r ]+", "", s)) } # trim() ## From future 0.11.0 hexpr <- function(expr, trim = TRUE, collapse = "; ", max_head = 6L, max_tail = 3L, ...) { code <- deparse(expr) if (trim) code <- trim(code) hpaste(code, collapse = collapse, max_head = max_head, max_tail = max_tail, ...) } # hexpr() now <- function(x = Sys.time(), format = "[%H:%M:%OS3] ") { ## format(x, format = format) ## slower format(as.POSIXlt(x, tz = ""), format = format) } ## From future 1.3.0 mdebug <- function(...) { if (!getOption("globals.debug", FALSE)) return(invisible(FALSE)) message(sprintf(...)) invisible(TRUE) } ## mdebug() mdebugf <- function(..., appendLF = TRUE, prefix = now(), debug = getOption("globals.debug", FALSE)) { if (!debug) return() message(prefix, sprintf(...), appendLF = appendLF) } #' @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 == "") { ## NOTE: I might be that: ## 1. 'env' is of a class that extends 'environment', e.g. ## R.oo::Object() or R6::R6Class(), or ## 2. another package defines print() for 'environment' ## Because of this, we call print.default() instead of generic print(). name <- capture.output(print.default(env)) if (length(name) > 1L) name <- name[1] name <- gsub("(.*: |>)", "", name) } else { ## e.g. globals:::where("plan") name <- gsub("package:", "", name, fixed = TRUE) } name } commaq <- function(x, sep = ", ") paste(sQuote(x), collapse = sep) if (getRversion() < "4.0.0") { ## When 'default' is specified, this is 30x faster than ## base::getOption(). The difference is that here we use ## use names(.Options) whereas in 'base' names(options()) ## is used. getOption <- local({ go <- base::getOption function(x, default = NULL) { if (missing(default) || match(x, table = names(.Options), nomatch = 0L) > 0L) go(x) else default } }) } stop_if_not <- function(...) { res <- list(...) n <- length(res) if (n == 0L) return() for (ii in 1L:n) { res_ii <- .subset2(res, ii) if (length(res_ii) != 1L || is.na(res_ii) || !res_ii) { mc <- match.call() call <- deparse(mc[[ii + 1]], width.cutoff = 60L) if (length(call) > 1L) call <- paste(call[1L], "...") stop(sQuote(call), " is not TRUE", call. = FALSE, domain = NA) } } } #' Gets the length of an object without dispatching #' #' @param x Any \R object. #' #' @return A non-negative integer. #' #' @details #' This function returns \code{length(unclass(x))}, but tries to avoid #' calling \code{unclass(x)} unless necessary. #' #' @seealso \code{\link{.subset}()} and \code{\link{.subset2}()}. #' #' @keywords internal #' @rdname private_length #' @importFrom utils getS3method .length <- function(x) { nx <- length(x) ## Can we trust base::length(x), i.e. is there a risk that there is ## a method that overrides with another definition? classes <- class(x) if (length(classes) == 1L && classes == "list") return(nx) ## Identify all length() methods for this object for (class in classes) { fun <- getS3method("length", class, optional = TRUE) if (!is.null(fun)) { nx <- length(unclass(x)) break } } nx } ## .length() ## An lapply(X) without internal X <- as.list(X), without setting names, ## and without dispatching using `[[`. list_apply <- function(X, 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.R0000644000176200001440000000135514236216353013067 0ustar liggesusers## covr: skip=all .onLoad <- function(libname, pkgname) { update_package_option("globals.debug", mode = "logical") debug <- getOption("globals.debug", FALSE) ## Set future options based on environment variables update_package_options(debug = debug) ## Memoize: Already here, when the package is loaded, record whether ## some packages are 'base' packages or not. ## Packages that most likely are 'base' packages: pkgs <- c("base", "compiler", "datasets", "graphics", "grDevices", "grid", "methods", "parallel", "splines", "stats", "stats4", "tcltk", "tools", "utils") ## This package and other packags already loaded (incl. it's dependencies) pkgs <- c(pkgs, pkgname, loadedNamespaces()) is_base_pkg(pkgs) } globals/R/findGlobals.R0000644000176200001440000002532614334754410014462 0ustar liggesusers#' @param attributes If TRUE (default), attributes of `expr` are also searched. #' If FALSE, they are not. #' If a character vector, then attributes with matching names are searched. #' Note, the attributes of the attributes elements are not searched, that is, #' attributes are not searched recursively. Also, attributes are searched #' with `dotdotdot = "ignore". #' #' @param dotdotdot TBD. #' #' @param trace TBD. #' #' @return \code{findGlobals()} returns a character vector. #' #' @rdname globalsOf #' @export findGlobals <- function(expr, envir = parent.frame(), ..., attributes = TRUE, tweak = NULL, dotdotdot = c("warning", "error", "return", "ignore"), method = c("ordered", "conservative", "liberal"), 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: [n=%d] %s\n", length(parnames), commaq(parnames)) } formals_clean <- drop_missing_formals(formals) # locals <- findLocalsList(c(list(body), formals_clean)) locals <- findLocalsList(formals_clean) if (trace) { trace_printf("formals_clean: [n=%d] %s\n", length(formals_clean), commaq(formals_clean)) trace_printf("locals: [n=%d] %s\n", length(locals), commaq(locals)) } ## Hardcode locals? hardcoded_locals <- c(parnames, locals) if (length(hardcoded_locals) > 0) { if (trace) trace_printf("Add hardcoded local variables %s", commaq(hardcoded_locals)) w$env <- new.env(hash = TRUE, parent = w$env) for (n in hardcoded_locals) assign(n, TRUE, w$env) } if (trace) { trace_printf("hardcoded locals: [n=%d] %s\n", length(w$env), commaq(names(w$env))) } for (a in formals_clean) { if (trace) trace_enter("walkCode(%s)", sQuote(a)) walkCode(a, w) if (trace) trace_exit("walkCode(%s)", sQuote(a)) } if (trace) trace_enter("walkCode(body)") res <- walkCode(body, w) if (trace) trace_exit("walkCode(body)") res } inject_tracer_to_function <- function(fcn, name) { b <- body(fcn) f <- formals(fcn) args <- setdiff(names(f), c("w", "...")) if (length(args) > 0L) { args <- grep("^[.][.][0-9]+$", args, invert = TRUE, value = TRUE) } title <- sprintf("%s()", name) b <- bquote({ ## Import private functions ns <- getNamespace("globals") trace_str <- get("trace_str", envir = ns, mode = "function") trace_exit <- get("trace_exit", envir = ns, mode = "function") trace_printf <- get("trace_printf", envir = ns, mode = "function") trace_print <- get("trace_print", envir = ns, mode = "function") trace_msg <- trace_enter("%s", .(title)) trace_indent <- attr(trace_msg, "indent") if (length(.(args)) > 0) trace_str(mget(.(args)), indent = trace_indent) if (!exists("w", mode = "list")) { trace_exit(trace_msg) return() } env <- environment(w$enterLocal) n <- length(env$name) value <- .(b) nnew <- (length(env$name) - n) if (nnew) { trace_printf("variables:\n", indent = trace_indent) trace_print(data.frame( name = env$name, class = env$class, added = c(rep(FALSE, times = n), rep(TRUE, times = nnew)), stringsAsFactors = FALSE ), indent = trace_indent) } trace_printf("result: ", indent = trace_indent) trace_str(value, indent = trace_indent) trace_exit(trace_msg) value }) body(fcn) <- b fcn } inject_tracer_to_walker <- function(w) { if (is.null(w$startCollectLocals)) { w$startCollectLocals <- function(parnames, locals, ...) { NULL } } if (is.null(w$finishCollectLocals)) { w$finishCollectLocals <- function(w, ...) { NULL } } if (is.null(w$enterInternal)) { w$enterInternal <- function(type, v, e, ...) { NULL } } for (key in names(w)) { fcn <- w[[key]] if (!is.function(fcn)) next # fcn <- inject_tracer_to_function(fcn, key) w[[key]] <- fcn } w } #' @importFrom codetools makeUsageCollector walkCode make_usage_collector <- local({ ## WORKAROUND: Avoid calling codetools::collectUsageCall() if it hits the ## https://bugs.r-project.org/bugzilla/show_bug.cgi?id=17935 bug in the ## stats:::`[.formula` function ## See also: https://github.com/HenrikBengtsson/globals/issues/64 if (getRversion() <= "4.0.3" || is.null(ver <- R.version$`svn rev`) || is.na(ver <- as.integer(ver)) || ver < 79355) { ## Local copy of codetools:::collectUsageCall() .collectUsageCall <- NULL collectUsageCall <- function(e, w) { e1 <- e[[1]] if (is.symbol(e1) && inherits(e, "formula") && is.null(e[[2]])) { ## From codetools:::collectUsageCall() fn <- as.character(e1) if (w$isLocal(fn, w)) { w$enterLocal("function", fn, e, w) } else { w$enterGlobal("function", fn, e, w) } } else { .collectUsageCall(e, w) } } function(...) { w <- makeUsageCollector(...) w$env <- new.env(parent = w$env) if (is.function(w$call)) { ## Memoize? (to avoid importing a private 'codetools' function) if (is.null(.collectUsageCall)) .collectUsageCall <<- w$call ## Patch w$call <- collectUsageCall } w } } else { function(...) { w <- makeUsageCollector(...) w$env <- new.env(hash = TRUE, parent = w$env) w } } }) globals/R/packagesOf.R0000644000176200001440000000270514302737657014306 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 they are from. This information is ## in the name of the environment as given by the 'where' attribute with ## a fallback to the global object. where <- attr(globals, "where") pkgs <- rep(NA_character_, times = length(globals)) for (kk in seq_along(globals)) { obj <- globals[[kk]] env <- environment_of(obj) ## If not found, it could be an object in package without a closure if (identical(env, emptyenv())) { w <- where[[kk]] if (is.environment(w)) { pkg <- environmentName(w) if (grepl("^package:", pkg)) pkg <- sub("^package:", "", pkg) } else { pkg <- environmentName(env) } } else { pkg <- environmentName(env) } pkgs[kk] <- pkg } ## Drop "missing" packages, e.g. globals in globalenv(). pkgs <- pkgs[nzchar(pkgs)] ## Drop global environment pkgs <- pkgs[pkgs != "R_GlobalEnv"] ## Keep only names matching loaded namespaces pkgs <- intersect(pkgs, loadedNamespaces()) ## Packages to be loaded pkgs <- unique(pkgs) ## Sanity check stop_if_not(all(nzchar(pkgs))) pkgs } # packagesOf() globals/R/environment_of.R0000644000176200001440000000050714302662334015256 0ustar liggesusers# A safe version of base::environment() that returns emptyenv() # if NULL is passed, instead of the calling environment. # Related to https://github.com/HenrikBengtsson/globals/issues/79 environment_of <- function(obj) { if (is.null(obj)) return(emptyenv()) e <- environment(obj) if (is.null(e)) return(emptyenv()) e } globals/R/options.R0000644000176200001440000000605114236216353013723 0ustar liggesuserssetOption <- function(name, value) { oldValue <- getOption(name) args <- list(value) names(args) <- name do.call(options, args = args) invisible(oldValue) } # Set an R option from an environment variable update_package_option <- function(name, mode = "character", default = NULL, split = NULL, trim = TRUE, disallow = c("NA"), force = FALSE, debug = FALSE) { ## Nothing to do? value <- getOption(name, NULL) if (!force && !is.null(value)) return(getOption(name, default = default)) ## name="pkg.foo.bar" => env="R_PKG_FOO_BAR" env <- gsub(".", "_", toupper(name), fixed = TRUE) env <- paste("R_", env, sep = "") env_value <- value <- Sys.getenv(env, unset = NA_character_) ## Nothing to do? if (is.na(value)) { if (debug) mdebugf("Environment variable %s not set", sQuote(env)) if (!is.null(default)) setOption(name, default) return(getOption(name, default = default)) } if (debug) mdebugf("%s=%s", env, sQuote(value)) ## Trim? if (trim) value <- trim(value) ## Nothing to do? if (!nzchar(value)) { if (!is.null(default)) setOption(name, default) return(getOption(name, default = default)) } ## Split? if (!is.null(split)) { value <- strsplit(value, split = split, fixed = TRUE) value <- unlist(value, use.names = FALSE) if (trim) value <- trim(value) } ## Coerce? mode0 <- storage.mode(value) if (mode0 != mode) { suppressWarnings({ storage.mode(value) <- mode }) if (debug) { mdebugf("Coercing from %s to %s: %s", mode0, mode, commaq(value)) } } if (length(disallow) > 0) { if ("NA" %in% disallow) { if (any(is.na(value))) { stopf("Coercing environment variable %s=%s to %s would result in missing values for option %s: %s", sQuote(env), sQuote(env_value), sQuote(mode), sQuote(name), commaq(value)) } } if (is.numeric(value)) { if ("non-positive" %in% disallow) { if (any(value <= 0, na.rm = TRUE)) { stopf("Environment variable %s=%s specifies a non-positive value for option %s: %s", sQuote(env), sQuote(env_value), sQuote(name), commaq(value)) } } if ("negative" %in% disallow) { if (any(value < 0, na.rm = TRUE)) { stopf("Environment variable %s=%s specifies a negative value for option %s: %s", sQuote(env), sQuote(env_value), sQuote(name), commaq(value)) } } } } if (debug) { mdebugf("=> options(%s = %s) [n=%d, mode=%s]", dQuote(name), commaq(value), length(value), storage.mode(value)) } setOption(name, value) getOption(name, default = default) } ## Set package options based on environment variables update_package_options <- function(debug = FALSE) { ## WARNING: All but R option 'globals.debug' are internal options ## that may be changed or removed at anytime. update_package_option("globals.globalsOf.locals", mode = "logical", debug = debug) update_package_option("globals.selfassign", mode = "logical", debug = debug) update_package_option("globals.walkAST.onUnknownType", debug = debug) } globals/R/walkAST.R0000644000176200001440000000646214334274433013546 0ustar liggesusers#' Walk the Abstract Syntax Tree (AST) of an R Expression #' #' @param expr R \link[base]{expression}. #' @param atomic,name,call,pairlist single-argument function that takes an #' atomic, name, call and pairlist expression, respectively. Have to #' return a valid R expression. #' @param substitute If TRUE, \code{expr} is #' \code{\link[base]{substitute}()}:ed. #' #' @return R \link[base]{expression}. #' #' @export #' @keywords programming internal walkAST <- function(expr, atomic = NULL, name = NULL, call = NULL, pairlist = NULL, substitute = FALSE) { if (substitute) expr <- substitute(expr) if (is.atomic(expr)) { if (is.function(atomic)) expr <- atomic(expr) } else if (is.name(expr)) { if (is.function(name)) expr <- name(expr) } else if (is.call(expr)) { ## message("call") for (cc in seq_along(expr)) { ## AD HOC: The following is needed to handle x[, 1]. /HB 2016-09-06 if (is.name(expr[[cc]]) && expr[[cc]] == "") next e <- walkAST(expr[[cc]], atomic = atomic, name = name, call = call, pairlist = pairlist, substitute = FALSE) if (is.null(e)) { expr[cc] <- list(NULL) } else { expr[[cc]] <- e } } if (is.function(call)) expr <- call(expr) } else if (is.pairlist(expr)) { ## message("pairlist") for (pp in seq_along(expr)) { ## AD HOC: The following is needed to handle '...'. /HB 2016-09-06 if (is.name(expr[[pp]]) && expr[[pp]] == "") next e <- walkAST(expr[[pp]], atomic = atomic, name = name, call = call, pairlist = pairlist, substitute = FALSE) if (is.null(e)) { expr[pp] <- list(NULL) } else { expr[[pp]] <- e } } ## WORKAROUND: Since expr[i] <- list(NULL) turns pairlist 'expr' into ## a list we have to make sure to it is a pairlist also afterward, cf. ## https://stat.ethz.ch/pipermail/r-devel/2016-October/073263.html ## /HB 2016-10-12 expr <- as.pairlist(expr) } else if (is.list(expr)) { ## FIXME: Should we have a specific function for this, or is atomic() ok? ## https://github.com/HenrikBengtsson/globals/issues/27 if (is.function(atomic)) expr <- atomic(expr) } else if (typeof(expr) %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/find_globals_ordered.R0000644000176200001440000002472014334754201016360 0ustar liggesusers#' @importFrom codetools walkCode find_globals_ordered <- function(expr, envir, dotdotdot, ..., name = character(), class = character(), trace = FALSE) { selfassign <- getOption("globals.selfassign", TRUE) ## Identified objects are recorded in (name, class), which ## are located in this executation environment enter_local <- function(type, v, e, w) { hardcoded_locals <- names(w$env) if (trace) { trace_msg <- trace_enter("enter_local(type=%s, v=%s)", sQuote(type), sQuote(v)) trace_printf("before:\n") trace_print(data.frame(name=name, class=class, stringsAsFactors = FALSE)) trace_printf("hardcoded locals: [n=%d] %s\n", length(hardcoded_locals), commaq(hardcoded_locals)) on.exit(local({ trace_printf("after:\n") trace_print(data.frame(name=name, class=class, stringsAsFactors = FALSE)) trace_exit(trace_msg) })) } is_already_local <- (v %in% hardcoded_locals) if (is_already_local) { if (trace) trace_printf("variable is a hardcoded local: %s\n", sQuote(v)) } ## LHS <- RHS: Handle cases where a global variable exists in RHS and LHS ## assigns a local variable with the same name, e.g. x <- x + 1. ## In such case we want to detect 'x' as a global variable. if (selfassign && (type == "<-" || type == "=")) { if (trace) trace_printf("LHS <- RHS:\n") rhs <- e[[3]] globals <- call_find_globals_with_dotdotdot(find_globals_ordered, expr = rhs, envir = w$env, dotdotdot = "ignore", trace = trace) if (trace) { trace_printf("RHS globals: [n=%d] %s\n", length(globals), commaq(globals)) trace_printf("hardcoded locals: [n=%d] %s\n", length(w$env), commaq(names(w$env))) } if (length(rhs) == 3 && globals[1] %in% c("::", ":::")) { ## Case: a <- pkg::a } else if (v %in% globals) { v_class <- if (v %in% hardcoded_locals) "local" else "global" if (trace) trace_printf("Add %s variable %s\n", sQuote(v_class), sQuote(v)) class <<- c(class, v_class) name <<- c(name, v) } } if (trace) trace_printf("Add %s variable %s\n", sQuote("local"), sQuote(v)) class <<- c(class, "local") name <<- c(name, v) } ## enter_local() enter_global <- function(type, v, e, w) { hardcoded_locals <- names(w$env) if (trace) { trace_msg <- trace_enter("enter_global(type=%s, v=%s)", sQuote(type), sQuote(v)) trace_printf("before:\n") trace_print(data.frame(name=name, class=class, stringsAsFactors = FALSE)) trace_printf("hardcoded locals: [n=%d] %s\n", length(hardcoded_locals), commaq(hardcoded_locals)) on.exit(local({ trace_printf("after:\n") trace_print(data.frame(name=name, class=class, stringsAsFactors = FALSE)) trace_exit(trace_msg) })) } is_already_local <- (v %in% hardcoded_locals) if (is_already_local) { if (trace) { trace_printf("variable is a hardcoded local: %s\n", sQuote(v)) } } v_class <- if (is_already_local) "local" else "global" if (trace) trace_printf("Add %s variable %s\n", sQuote(v_class), sQuote(v)) class <<- c(class, v_class) name <<- c(name, v) ## Also walk formulas to identify globals if (type == "function") { if (v == "~") { if (trace) trace_printf("type = ~ (formula)\n") stop_if_not(length(e) >= 2L, identical(e[[1]], as.symbol("~"))) ## Ignoring dots overrides the default of silently returning ## them from formulas ## Fixes https://github.com/HenrikBengtsson/globals/issues/63 if (dotdotdot == "ignore") { formula_dotdotdot <- "ignore" } else { formula_dotdotdot <- "return" } for (kk in 2:length(e)) { globals <- call_find_globals_with_dotdotdot(find_globals_ordered, expr = e[[kk]], envir = w$env, dotdotdot = formula_dotdotdot, trace = trace) if (length(globals) > 0) { if (trace) trace_printf("Add %s variables %s\n", sQuote("global"), commaq(globals)) class <<- c(class, rep("global", times = length(globals))) name <<- c(name, globals) } } } else if (selfassign && (v == "<-" || v == "=")) { ## LHS <- RHS: Handle cases where a global variable exists in LHS in ## the form of x[1] <- 0, which will cause 'x' to be called ## a local variable later unless called global here. if (trace) trace_printf("LHS <- RHS:\n") lhs <- e[[2]] if (length(lhs) >= 2) { ## Cases: a[1] <- 0, names(a) <- "x", names(a)[1] <- "x" ## Skip first symbol, because it'll be handled up later as ## an assignment function, e.g. `[<-` and `names<-` globals <- find_globals_ordered(expr = lhs, envir = w$env, dotdotdot = dotdotdot, name = hardcoded_locals, class = rep("local", times = length(hardcoded_locals)), trace = trace) if (length(globals) > 0) { if (trace) trace_printf("Add %s variables %s\n", sQuote("global"), commaq(globals)) class <<- c(class, rep("global", times = length(globals))) name <<- c(name, globals) } } } else { if (trace) trace_printf("=> A function, but not of interest\n") } } else { if (trace) trace_printf("=> Nothing to else to explore\n") } } ## enter_global() # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # Main # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - if (trace) { trace_msg <- trace_enter("find_globals_ordered()") on.exit(trace_exit(trace_msg)) } ## A function or an expression? if (is.function(expr)) { if (typeof(expr) != "closure") { if (trace) trace_printf("typeof != closure\n") return(character(0L)) ## e.g. `<-` } if (trace) trace_printf("type = function\n") fun <- expr w <- make_usage_collector(fun, name = "", enterLocal = enter_local, enterGlobal = enter_global) if (trace) w <- inject_tracer_to_walker(w) collect_usage_function(fun, name = "", w, trace = trace) } else if (is.call(expr) && is.function(expr[[1]])) { if (trace) trace_printf("type = a call to a function\n") ## AD HOC: Fixes https://github.com/HenrikBengtsson/globals/issues/60 for (e in list(expr[[1]], expr[-1])) { globals <- find_globals_ordered(expr = e, envir = envir, dotdotdot = dotdotdot, ..., trace = trace) if (length(globals) > 0) { class <- c(class, rep("global", times = length(globals))) name <- c(name, globals) } } } else if (is.call(expr) && is.symbol(expr[[1]]) && expr[[1]] == "{") { if (trace) trace_printf("type = {\n") class <- c(class, "global") name <- c(name, "{") nexpr <- length(expr) if (trace) trace_printf("length(expr) = %d\n", nexpr) if (nexpr >= 2) { for (kk in 2:nexpr) { e <- expr[[kk]] globals <- find_globals_ordered(expr = e, envir = envir, dotdotdot = dotdotdot, ..., trace = trace) if (length(globals) > 0) { if (trace) trace_printf("Add %s variable %s\n", sQuote("global"), commaq(globals)) class <- c(class, rep("global", times = length(globals))) name <- c(name, globals) } locals <- codetools::findLocals(e) if (length(locals) > 0) { if (trace) trace_printf("Add %s variable %s\n", sQuote("local"), commaq(locals)) class <- c(class, rep("locals", times = length(locals))) name <- c(name, locals) } } } } else { if (trace) trace_printf("type = call\n") if (trace) trace_printf("Convert to an anonymous function:\n") fun <- as_function(expr, envir = envir, ...) if (trace) trace_print(fun) w <- make_usage_collector(fun, name = "", enterLocal = enter_local, enterGlobal = enter_global) if (trace) w <- inject_tracer_to_walker(w) walkCode(expr, w) } if (trace) local({ trace_printf("variables (with duplicates):\n") trace_print(data.frame(name=name, class=class, stringsAsFactors = FALSE)) }) ## Drop duplicated names dups <- duplicated(name) class <- class[!dups] name <- name[!dups] if (trace) local({ trace_printf("variables (no duplicates):\n") trace_print(data.frame(name=name, class=class, stringsAsFactors = FALSE)) }) unique(name[class == "global"]) } call_find_globals_with_dotdotdot <- function(FUN, expr, envir, dotdotdot = "error", trace = FALSE, debug = FALSE) { if (trace) { trace_msg <- trace_enter("call_find_globals_with_dotdotdot(dotdotdot = %s)", sQuote(dotdotdot)) on.exit(trace_exit(trace_msg)) } ## Is there a need for global '...', '..1', '..2', etc.? dotdotdots <- character(0L) globals <- withCallingHandlers({ oopts <- options(warn = 0L) on.exit(options(oopts), add = TRUE) FUN(expr, envir = envir, dotdotdot = dotdotdot, trace = trace) }, warning = function(w) { ## Warned about '...', '..1', '..2', etc.? ## NOTE: The warning we're looking for is the one generated by ## codetools::findGlobals(). That warning is _not_ translated, ## meaning this approach should work as is as long as the message ## is not modified by codetools itself. If codetools ever changes ## this such that the below string matching fails, then the package ## tests (tests/dotdotdot.R) will detect that. In other words, ## such a change will not go unnoticed. /HB 2017-03-08 msg <- w$message pattern <- ".* ([.][.]([.]|[0-9]+)) may be used in an incorrect context.*" if (grepl(pattern, msg, fixed = FALSE)) { 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: [n=%d] %s\n", length(globals), commaq(globals)) } if (length(dotdotdots) > 0L) { dotdotdots <- unique(dotdotdots) if (trace) { trace_printf("dotdotdots: [n=%d] %s\n", length(dotdotdot), commaq(dotdotdots)) } globals <- c(globals, dotdotdots) } globals } globals/R/cleanup.R0000644000176200001440000000577114235352605013667 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.R0000644000176200001440000002466114334754335014155 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 locals Should globals part of any "local" environment of #' a function be included or not? #' #' @param substitute If TRUE, the expression is \code{substitute()}:ed, #' otherwise not. #' #' @param mustExist If TRUE, an error is thrown if the object of the #' identified global cannot be located. Otherwise, the global #' is not returned. #' #' @param unlist If TRUE, a list of unique objects is returned. #' If FALSE, a list of \code{length(expr)} sublists. #' #' @param recursive If TRUE, globals that are closures (functions) and that #' exist outside of namespaces ("packages"), will be recursively #' scanned for globals. #' #' @param skip (internal) A list of globals not to be searched for #' additional globals. Ignored unless \code{recursive} is TRUE. #' #' @return \code{globalsOf()} returns a \link{Globals} object. #' #' @details #' There currently three strategies for identifying global objects. #' #' The \code{method = "ordered"} search method identifies globals such that #' a global variable preceding a local variable with the same name #' is not dropped (which the \code{"conservative"} method would). #' #' The \code{method = "conservative"} search method tries to keep the number #' of false positive to a minimum, i.e. the identified objects are #' most likely true global objects. At the same time, there is #' a risk that some true globals are not identified (see example). #' This search method returns the exact same result as the #' \code{\link[codetools]{findGlobals}()} function of the #' \pkg{codetools} package. #' #' The \code{method = "liberal"} search method tries to keep the #' true-positive ratio as high as possible, i.e. the true globals #' are most likely among the identified ones. At the same time, #' there is a risk that some false positives are also identified. #' #' 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, locals = NA, substitute = FALSE, mustExist = TRUE, unlist = TRUE, recursive = TRUE, skip = NULL) { method <- match.arg(method, choices = c("ordered", "conservative", "liberal")) if (is.na(locals)) locals <- getOption("globals.globalsOf.locals", TRUE) stop_if_not(is.logical(locals), length(locals) == 1L, !is.na(locals)) if (substitute) expr <- substitute(expr) stop_if_not(is.null(skip) || is.list(skip)) debug <- 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)))) ## If a function, drop any globals that are part of any of the functions ## local environments, e.g. 'a' in f <- local({ a <- 1; function() a }) if (!locals && is.function(expr) && length(globals) > 0) { env <- environment(expr) ## the environment of the function eenv <- emptyenv() genv <- globalenv() where <- attr(globals, "where", exact = TRUE) while (length(where) > 0 && !identical(env, eenv) && !identical(env, genv)) { ## Any 'where' for the current environment? keep <- !vapply(where, FUN.VALUE = FALSE, FUN = identical, env) where <- where[keep] env <- parent.env(env) } ## Anything to drop? if (length(where) != length(globals)) globals <- globals[names(where)] } ## 3. Among globals that are closures (functions) and that exist outside ## of namespaces ("packages"), check for additional globals? if (recursive) { 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, locals = locals, substitute = FALSE, mustExist = mustExist, unlist = unlist, recursive = recursive, skip = skip_t) if (length(globals_gg) > 0) { globals <- c(globals, globals_gg) skip_gg <- globals_gg[vapply(globals_gg, FUN = typeof, FUN.VALUE = NA_character_, USE.NAMES = FALSE) == "closure"] skip_t <- c(skip_t, skip_gg) } } globals <- unique(globals) 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", commaq(dotdotdots)) } else { dotdotdots <- NULL debug && mdebug("- dotdotdots: ") } 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 class(globals) <- c("Globals", class(globals)) debug && mdebug("globalsByName(<%d names>, mustExist = %s) ... DONE", nnames, mustExist) globals } ## globalsByName() globals/R/find_globals_liberal.R0000644000176200001440000000207214334605331016341 0ustar liggesusers#' @importFrom codetools walkCode find_globals_liberal <- function(expr, envir, dotdotdot, ..., trace = FALSE) { objs <- character() enter <- function(type, v, e, w) { objs <<- c(objs, v) } if (is.function(expr)) { if (typeof(expr) != "closure") return(character(0L)) ## e.g. `<-` fun <- expr w <- make_usage_collector(fun, name = "", enterGlobal = enter) if (trace) w <- inject_tracer_to_walker(w) collect_usage_function(fun, name = "", w, trace = trace) } else if (is.call(expr) && is.function(expr[[1]])) { ## AD HOC: Fixes https://github.com/HenrikBengtsson/globals/issues/60 for (e in list(expr[[1]], expr[-1])) { globals <- find_globals_liberal(expr = e, envir = envir, dotdotdot = dotdotdot, ..., trace = trace) if (length(globals) > 0) objs <- c(objs, globals) } } else { fun <- as_function(expr, envir = envir, ...) w <- make_usage_collector(fun, name = "", enterGlobal = enter) if (trace) w <- inject_tracer_to_walker(w) walkCode(expr, w) } unique(objs) } globals/R/where.R0000644000176200001440000000346014030212707013332 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.R0000644000176200001440000001336014273240134014712 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{Globals}, which is a \emph{named} list #' of the value of the globals, where the element names are the names of #' the globals. Attribute \code{where} is a named list of the same length #' and with the same names. #' #' @seealso #' The \code{\link{globalsOf}()} function identifies globals #' from an R expression and returns a Globals object. #' #' @aliases as.Globals as.Globals.Globals as.Globals.list [.Globals names #' @export Globals <- function(object = list(), ...) { if (!is.list(object)) { stopf("Argument 'object' is not a list: %s", class(object)[1]) } if (length(object) > 0) { names <- names(object) if (is.null(names)) { stop("Argument 'object' must be a named list.") } else if (!all(nzchar(names))) { stop("Argument 'object' specifies globals with empty names.") } } where <- attr(object, "where", exact = TRUE) if (length(object) == 0 && is.null(where)) { attr(object, "where") <- where <- list() } stop_if_not(is.list(where)) stop_if_not( is.list(where), length(where) == length(object), length(names(where)) == length(names(object)) ) structure(object, class = c("Globals", class(object))) } #' @export as.Globals <- function(x, ...) UseMethod("as.Globals") #' @export as.Globals.default <- function(x, ...) { stopf("Don't know how to coerce a %s to Globals", class(x)[1]) } #' @export as.Globals.Globals <- function(x, ...) x #' @export as.Globals.list <- function(x, ...) { if (length(x) > 0L) { stop_if_not(!is.null(names(x))) ## Use the globals environments as the locals? ## (with emptyenv() as the fallback) where <- attr(x, "where", exact = TRUE) if (is.null(where)) { where <- lapply(x, FUN = environment_of) names(where) <- names(x) attr(x, "where") <- where } } Globals(x, ...) } #' @export `names<-.Globals` <- function(x, value) { x <- NextMethod() where <- attr(x, "where", exact = TRUE) names(where) <- names(x) attr(x, "where") <- where invisible(x) } #' @export `[.Globals` <- function(x, i) { where <- attr(x, "where", exact = TRUE) res <- NextMethod() attr(res, "where") <- where[i] class(res) <- class(x) where <- attr(res, "where", exact = TRUE) stop_if_not( is.list(where), length(where) == length(res), length(names(where)) == length(names(res)) ) res } assign_Globals <- function(x, name, value) { stop_if_not(is.character(name), !is.na(name), nchar(name) > 0L) where <- attr(x, "where", exact = TRUE) stop_if_not(!is.null(where)) ## Remove an element? if (is.null(value)) { where[[name]] <- NULL } else { ## Value must be Globals object of length one if (inherits(value, "Globals")) { if (length(value) != 1) { stopf("Cannot assign Globals object of length different than one: %s", length(value)) } where[[name]] <- attr(value, "where", exact = TRUE)[[1]] value <- value[[1]] } else { where[[name]] <- environment_of(value) } } attr(x, "where") <- where ## Avoid call this function recursively class <- class(x) class(x) <- NULL x[[name]] <- value class(x) <- class invisible(x) } #' @export `[<-.Globals` <- function(x, names, value) { stop_if_not( length(names) == length(value), is.character(names), !anyNA(names), all(nchar(names) > 0) ) if (inherits(value, "Globals")) { where <- attr(value, "where") } else if (is.list(value)) { where <- lapply(value, FUN = environment_of) } else { stopf("Unsupported class of 'value': %s", class(value)[1]) } stop_if_not(length(where) == length(value)) x_where <- attr(x, "where", exact = TRUE) stop_if_not(!is.null(x_where)) class <- class(x) class(x) <- NULL attr(x, "where") <- NULL for (kk in seq_along(value)) { name <- names[kk] value_kk <- value[[kk]] if (is.null(value_kk)) { x[name] <- list(NULL) } else { x[[name]] <- value_kk } x_where[[name]] <- where[[kk]] } stop_if_not(length(x_where) == length(x)) attr(x, "where") <- x_where class(x) <- class invisible(x) } #' @export `$<-.Globals` <- function(x, name, value) { x <- assign_Globals(x, name = name, value = value) invisible(x) } #' @export `[[<-.Globals` <- function(x, name, value) { x <- assign_Globals(x, name = name, value = value) invisible(x) } #' @export c.Globals <- function(x, ...) { args <- list(...) where <- attr(x, "where", exact = TRUE) clazz <- class(x) class(x) <- NULL for (kk in seq_along(args)) { g <- args[[kk]] name <- names(args)[kk] if (inherits(g, "Globals")) { w <- attr(g, "where", exact = TRUE) } else if (is.list(g)) { ## Nothing to do? if (length(g) == 0) next names <- names(g) stop_if_not(!is.null(names)) w <- lapply(g, FUN = environment_of) names(w) <- names } else { if (is.null(name)) { stopf("Can only append named objects to Globals list: %s", sQuote(mode(g))) } e <- environment_of(g) g <- structure(list(g), names = name) w <- structure(list(e), names = name) } where <- c(where, w) x <- c(x, g) } attr(x, "where") <- where class(x) <- clazz stop_if_not( length(where) == length(x), all(names(where) == names(x)) ) x } #' @export unique.Globals <- function(x, ...) { names <- names(x) dups <- duplicated(names) if (any(dups)) { where <- attr(x, "where", exact = TRUE) where <- where[!dups] x <- x[!dups] attr(x, "where") <- where stop_if_not( length(where) == length(x), all(names(where) == names(x)) ) } x } globals/R/utils,conditions.R0000644000176200001440000000176614255465026015552 0ustar liggesusersstopf <- function(fmt, ..., call. = TRUE, domain = NULL) { #nolint msg <- sprintf(fmt, ...) msg <- .makeMessage(msg, domain = domain) if (is.call(call.)) { call <- call. } else if (isTRUE(call)) { call <- sys.call(which = -1L) } else { call <- NULL } cond <- simpleError(msg, call = call) stop(cond) } warnf <- function(fmt, ..., call. = TRUE, immediate. = FALSE, domain = NULL) { #nolint msg <- sprintf(fmt, ...) ## Cannot tweak 'call' when immediate. = TRUE if (isTRUE(immediate.)) { warning(msg, call. = call., immediate. = immediate., domain = domain) } else { msg <- .makeMessage(msg, domain = domain) if (is.call(call.)) { call <- call. } else if (isTRUE(call)) { call <- sys.call(which = -1L) } else { call <- NULL } cond <- simpleWarning(msg, call = call) warning(cond) } } msgf <- function(fmt, ..., appendLF = FALSE, domain = NULL) { #nolint message(sprintf(fmt, ...), appendLF = appendLF, domain = domain) } globals/R/call_find_globals_with_dotdotdot.R0000644000176200001440000000776414334754270021005 0ustar liggesuserscall_find_globals_with_dotdotdot <- function(FUN, expr, envir, dotdotdot = "error", trace = FALSE, debug = FALSE) { if (trace) { trace_msg <- trace_enter("call_find_globals_with_dotdotdot(dotdotdot = %s)", sQuote(dotdotdot)) on.exit(trace_exit(trace_msg)) } ## Is there a need for global '...', '..1', '..2', etc.? dotdotdots <- character(0L) globals <- withCallingHandlers({ oopts <- options(warn = 0L) on.exit(options(oopts), add = TRUE) FUN(expr, envir = envir, dotdotdot = dotdotdot, trace = trace) }, warning = function(w) { ## Warned about '...', '..1', '..2', etc.? ## NOTE: The warning we're looking for is the one generated by ## codetools::findGlobals(). That warning is _not_ translated, ## meaning this approach should work as is as long as the message ## is not modified by codetools itself. If codetools ever changes ## this such that the below string matching fails, then the package ## tests (tests/dotdotdot.R) will detect that. In other words, ## such a change will not go unnoticed. /HB 2017-03-08 msg <- w$message pattern <- ".* ([.][.]([.]|[0-9]+)) may be used in an incorrect context.*" if (grepl(pattern, msg, fixed = FALSE)) { 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: [n=%d] %s\n", length(globals), commaq(globals)) } if (length(dotdotdots) > 0L) { dotdotdots <- unique(dotdotdots) if (trace) { trace_printf("dotdotdots: [n=%d] %s\n", length(dotdotdot), commaq(dotdotdots)) } globals <- c(globals, dotdotdots) } globals } call_find_globals_with_dotdotdot <- function(FUN, expr, envir, dotdotdot = "error", trace = FALSE, debug = FALSE) { if (trace) { trace_msg <- trace_enter("call_find_globals_with_dotdotdot(dotdotdot = %s)", sQuote(dotdotdot)) on.exit(trace_exit(trace_msg)) } ## Is there a need for global '...', '..1', '..2', etc.? dotdotdots <- character(0L) globals <- withCallingHandlers({ oopts <- options(warn = 0L) on.exit(options(oopts), add = TRUE) FUN(expr, envir = envir, dotdotdot = dotdotdot, trace = trace) }, warning = function(w) { ## Warned about '...', '..1', '..2', etc.? ## NOTE: The warning we're looking for is the one generated by ## codetools::findGlobals(). That warning is _not_ translated, ## meaning this approach should work as is as long as the message ## is not modified by codetools itself. If codetools ever changes ## this such that the below string matching fails, then the package ## tests (tests/dotdotdot.R) will detect that. In other words, ## such a change will not go unnoticed. /HB 2017-03-08 msg <- w$message pattern <- ".* ([.][.]([.]|[0-9]+)) may be used in an incorrect context.*" if (grepl(pattern, msg, fixed = FALSE)) { 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: [n=%d] %s\n", length(globals), commaq(globals)) } if (length(dotdotdots) > 0L) { dotdotdots <- unique(dotdotdots) if (trace) { trace_printf("dotdotdots: [n=%d] %s\n", length(dotdotdot), commaq(dotdotdots)) } globals <- c(globals, dotdotdots) } globals } globals/R/find_globals_conservative.R0000644000176200001440000000305014334605317017440 0ustar liggesusers## This function is equivalent to: ## fun <- as_function(expr, envir = envir, ...) ## codetools::findGlobals(fun, merge = TRUE) ## but we expand it here to make it more explicit ## what is going on. #' @importFrom codetools findLocalsList walkCode find_globals_conservative <- function(expr, envir, dotdotdot, ..., trace = FALSE) { objs <- character() enter <- function(type, v, e, w) { objs <<- c(objs, v) } if (is.function(expr)) { if (typeof(expr) != "closure") return(character(0L)) # e.g. `<-` fun <- expr w <- make_usage_collector(fun, name = "", enterGlobal = enter) if (trace) w <- inject_tracer_to_walker(w) collect_usage_function(fun, name = "", w, trace = trace) } else if (is.call(expr) && is.function(expr[[1]])) { ## AD HOC: Fixes https://github.com/HenrikBengtsson/globals/issues/60 for (e in list(expr[[1]], expr[-1])) { globals <- find_globals_conservative(expr = e, envir = envir, dotdotdot = dotdotdot, ..., trace = trace) if (length(globals) > 0) objs <- c(objs, globals) } } else { ## From codetools::findGlobals(): fun <- as_function(expr, envir = envir, ...) # codetools::collectUsage(fun, enterGlobal = enter) ## The latter becomes equivalent to (after cleanup): w <- make_usage_collector(fun, name = "", enterGlobal = enter) if (trace) w <- inject_tracer_to_walker(w) locals <- findLocalsList(list(expr)) for (name in locals) assign(name, value = TRUE, envir = w$env) walkCode(expr, w) } unique(objs) } globals/NEWS.md0000644000176200001440000003142414336755774013024 0ustar liggesusers# Version 0.16.2 [2022-11-21] ## Documentation * Drop duplicated arguments from `help("walkAST")`. # Version 0.16.1 [2022-08-28] ## Bug Fixes * `packagesOf()` for `Globals` failed to return the package of the globals if the global doesn't have a closure, e.g. `base::pi` and `data.table::.N`. # Version 0.16.0 [2022-08-05] ## New Features * Add `[[<-` and `[<-` for `Globals`, to complement `$<-`. ## Reproducibility * All functions modifying a `Globals` object guarantee that the `where` and the `class` attributes are always the last two attributes and in that order. ## Bug Fixes * `c()` for `Globals` would lose the `where` environment for any functions appended. # Version 0.15.1 [2022-06-24] ## Bug Fixes * `cleanup()` assumed it was safe to call `env$.packageName` on each scanned environment, but that might not be true. A classed environment could be such that `$()` gives an error, rather than returning something. # Version 0.15.0 [2022-05-08] ## New Features * `globalsOf()` gained argument `locals`, which controls whether globals that exist in "local" environments of a function should be considered or not, e.g. in `f <- local({ a <- 1; function() a })`, should `a` be considered a global of `f()` or not. For backward compatibility reasons, the default is `locals = TRUE`, but this might become `locals = FALSE` in a later release. * Any `globals.*` options specific to this packages can now be set via environment variables `R_GLOBALS_*` when the package is loaded. For example, `R_GLOBALS_DEBUG=true` sets option `globals.debug = TRUE`. ## Bug Fixes * `as.Globals(list(a = NULL))` and `c(Globals(), list(a = NULL))` would include the calling environment instead of an empty environment as part of the `where` attribute. # Version 0.14.0 [2020-11-22] ## New Features * Now `findGlobals(function(x) x <- x)` identifies `x` as a global variable. * Now `findGlobals(function(x) x[1] <- 0)` identifies `x` as a global variable. Same for other variants like `x[[1]] <- 0` and `x$a <- 0`. * Now `findGlobals(function(z) x <- z$x)` identifies `x` as a global variable. * Now `findGlobals(quote({ f <- function(x) x; x }))` identifies `x` as a global variable. Previously, the `x` of the function would hide the global `x`. # Version 0.13.1 [2020-10-11] ## Bug Fixes * `globalsOf()` could produce "Error in vapply(where, FUN = envname, FUN.VALUE = NA_character_, USE.NAMES = FALSE) : values must be length 1, but FUN(X[[2]]) result is length 10". This would happen if for instance argument `envir` has attributes set. * `findGlobals()` works around a bug in `stats:::[.formula` of R (< 4.1.0) that revealed itself when scanning formulas with NULL components. * `findGlobals()` would not pass down argument `dotdotdot` when recursively parsing assignments. * `findGlobals()` could return `...` as a global also when used in formulas. Now it respects argument `dotdotdot = "ignore"` and parses formulas accordingly, otherwise formulas will be parsed using `dotdotdot = "return"`. # Version 0.13.0 [2020-09-16] ## Significant Changes * `findGlobals(expr)` now also scans any attributes of `expr` for globals, e.g. `purrr::partial()` puts the original function in attribute `body`. Argument `attributes` controls which attributes, if any, should be scanned. Default is to scan all attributes. * `findGlobals()`, `globalsOf()`, and `globalsByName()` now recognizes and returns values for `..1`, `..2`, etc. like they do for `...`. * `cleanup()` now also drop exported and non-exported `NativeSymbolInfo` objects. ## New Features * `cleanup()` gained support for dropping `NativeSymbolInfo` objects. ## Bug Fixes * `findGlobals()` did not pass down argument `method` in recursive calls. * `findGlobals(expr)` would fail to identify globals in anonymous function calls, e.g. `expr <- as.call(list(function(...) NOT_FOUND, quote(FOUND)))`. * Calls like `findGlobals(~ NULL)` with NULLs on the right-hand side could throw "Error in if (length(ans) == 0L || as.character(ans[[1L]])[1L] == "~") { : missing value where TRUE/FALSE needed". Solved by working around what looks like a bug in the **stats** package causing subsetting on formulas with NULLs to fail. * `cleanup(..., drop = c(..., "base-packages"))` for `Globals` would drop base R objects with names not exported by the corresponding base R package. Similarly, `drop = c(..., "primitive")` would drop primitive R objects with names not exported by any base R package. * `findGlobals()`, `globalsOf()`, and `globalsByName()` did not handle `..1`, `..2`, etc. * `findGlobals()` and `globalsOf()` produces warnings on ': ... may be used in an incorrect context' when formulas had `...`, `..1`, `..2`, etc. * `findGlobals(function() NULL, substitute = TRUE, trace = TRUE)` would throw "Error in environment(w$enterLocal) : object 'w' not found". # Version 0.12.5 [2019-12-07] ## Bug Fixes * `findGlobals(function() { a; a <- a + 1 })` would fail to identify `a` as a global variable whereas it was properly identified with `{ a <- a + 1; a }`. # Version 0.12.4 [2018-10-11] ## Bug Fixes * `globalsOf()` could produce "Error in vapply(where, FUN = envname, FUN.VALUE = NA_character_, USE.NAMES = FALSE) : values must be length 1, but FUN(X[[...]]) result is length ...". This was because the internal `envname(env)` did not always handle when `class(env) != "environment"`. # Version 0.12.3 [2018-09-16] ## New Features * `findGlobals()`, `globalsOf()`, and `packagesOf()` no longer return elements sorted by name. ## Bug Fixes * globals::`findGlobals()` would not identify `a` as a global in expressions of type `a[1] = ...` and `names(a) = ...` although it did for `a[1] <- ...` and `names(a) <- ...`. # Version 0.12.2 [2018-08-25] ## Performance * `cleanup()` for `Globals` should now be much faster. Previously, it could be very slow the first time it was called in a fresh R session, especially if the user had a large number of packages installed and/or the package libraries were on slow drives. ## Documentation * Added help for `globals::findGlobals()`. ## Bug Fixes * `globals::findGlobals(x)`, where `x` is a list, iterated over `x` incorrectly assuming no method dispatching on `x` would take place. For instance, if `x` contained an `fst::fst_table` object, then "Error in .subset2(x, i, exact = exact) : subscript out of bounds" would be produced. * globals::`findGlobals()` could produce a "Warning in is.na(x): is.na() applied to non-(list or vector) of type 'NULL'" in R (< 3.5.0). # Version 0.12.1 [2018-06-24] ## Performance * globals::`findGlobals()` is now significantly faster for elements that are long lists with many elements of basic data types. This is because elements of such basic data type cannot contain globals and can therefore be skipped early in the search for globals. # Version 0.12.0 [2018-06-12] ## New Features * Now globals::`findGlobals()` identifies `a` as a global also when it is part of LHS expressions of type `a[1] <- ...` and `names(a) <- ...`. ## Bug Fixes * globals::`findGlobals()` incorrectly identified `a` as a global in expression of type `a <- pkg::a`. * If `...` was passed to `globalsByName(names)`, an error would be produced unless it was the last entry in `names`. # Version 0.11.0 [2018-01-09] ## New Features * Now `findGlobals()` identifies `x` as a global variable in `x <- x + 1` and likewise for `x + 1 -> x`. Note that ditto using `<<-` and `->>` was already identifying `x` as a global. ## Bug Fixes * `findGlobals(..., trace = TRUE)` now outputs only to standard error. Previously, some of the output went to standard output. # Version 0.10.3 [2017-10-12] ## Bug Fixes * `globalsOf(..., recursive = TRUE)` would result in "Error in match.fun(FUN) : node stack overflow" if one of the globals identified was a function that called itself recursively (either directly or indirectly). # Version 0.10.2 [2017-08-08] ## Bug Fixes * `walkAST()` could produce error "Cannot walk expression. Unknown object type '...'" for objects of type `environment`. # Version 0.10.1 [2017-07-01] ## Bug Fixes * `walkAST()` could produce error "Cannot walk expression. Unknown object type '...'" for objects of type `list`, `expression` and `S4`. # Version 0.10.0 [2017-04-16] ## New Features * Globals that are part of a formula are now identified. * `findGlobals(..., trace = TRUE)` will now show low-level parse information as the abstract syntax tree (AST) is walked. SOFTWARE QUALITY: * Enabled more internal sanity checks. ## Bug Fixes * `walkAST()` could produce error "Cannot walk expression. Unknown object type 'nnn'" for expressions of type `builtin`, `closure` and `special`. # Version 0.9.0 [2017-03-09] ## New Features * Added option `globals.debug`, which when TRUE enables debugging output. ## Bug Fixes * `globalsOf(..., recursive = TRUE)` would in some cases scan an incorrect subset of already identified globals. * `globalsOf(..., recursive = TRUE)` failed to skip objects part of package namespaces that where defined via a `local()` statement. # Version 0.8.0 [2017-01-14] ## New Features * `globalsOf()` identifies also globals in locally defined functions. This can be disabled with argument `recursive = FALSE`. * `findGlobals()` now takes both closures (functions) and expressions. # Version 0.7.2 [2016-12-28] ## Bug Fixes * `c(x, list())` where `x` is a `Globals` object would give an error reporting that the list does not have named elements. # Version 0.7.1 [2016-10-13] ## New Features * `Globals()` and `as.Globals()` now accepts an empty list as input as well. ## Bug Fixes * `walkAST(quote( function(x=NULL) 0 ))` would give a sanity check error due to the NULL argument. Thank you GitHub user 'billy34' for reporting on this. # Version 0.7.0 [2016-09-08] ## New Features * Added `walkAST()`, which can be used to tweak expressions. * Added `globalsByName()` for locating and retrieving a set of known global variables. * Added `c()`, `$<-()`, `names()`, `unique()` for `Globals` objects. * Improved `as.Globals()` for lists. # Version 0.6.1 [2016-01-31] ## New Features * Now the error message of `globalsOf(..., mustExist = TRUE)` when it fails to locate a global also gives information on the expression that is problematic. ## Bug Fixes * `cleanup()` for `Globals` did not cleanup functions in core package environments named `package:`. # Version 0.6.0 [2015-12-12] ## New Features * `findGlobals()` is updated to handle the case where a local variable is overwriting a global one with the same name, e.g. `{ a <- b; b <- 1 }`. Now `b` is correctly identified as a global object. Previously it would have been missed. For backward compatibility, the previous behavior can be obtained using argument `method = "conservative"`. # Version 0.5.0 [2015-10-13] ## New Features * `globalsOf()` now returns attribute `where` specifying where each global object is located. ## Bug Fixes * `cleanup()` now only drops objects that are *located* in one of the "base" packages; previously it would also drop copies of such objects, e.g. `FUN <- base::sample`. # Version 0.4.1 [2015-10-05] ## Bug Fixes * `globalsOf()` failed to return global variables with value NULL. They were identified but silently dropped. # Version 0.4.0 [2015-09-12] ## New Features * `findGlobals()` and `globalsOf()` gained argument `dotdotdot`. # Version 0.3.1 [2015-06-10] * More test coverage. # Version 0.3.0 [2015-06-08] ## New Features * Renamed `getGlobals()` to `globalsOf()`. # Version 0.2.3 [2015-06-08] ## New Features * Added `[()` for `Globals`. * `findGlobals()` and `getGlobals()` gained argument `substitute`. * Added `cleanup(..., method = "internals")`. # Version 0.2.2 [2015-05-20] ## New Features * Added `Globals` class with methods `cleanup()` and `packagesOf()`. * Added `as.Globals()` to coerce lists to `Globals` objects. # Version 0.2.1 [2015-05-20] ## New Features * `getGlobals()` gained argument `mustExist` for controlling whether to give an error when the corresponding object for an identified global cannot be found or to silently drop the missing global. * `findGlobals()` and `getGlobals()` gained argument `method` for controlling whether a `"conservative"` or a `"liberal"` algorithm for identifying true globals should be used. # Version 0.2.0 [2015-05-19] * Moved "globals" functions from an in-house package to this package. # Version 0.1.0 [2015-02-07] * Created. globals/MD50000644000176200001440000000435014336764452012225 0ustar liggesusersc8e6d7f923a5f217a799100d2f567007 *DESCRIPTION 9c19ce5a6375cbd0508fcdecf48c051a *NAMESPACE 90c9eb32f0683d755bda85a88a11924d *NEWS.md f80b1402e55947ece0df39ff89645b39 *R/Globals-class.R 9d96578517a287de8472d79d0b6a1319 *R/call_find_globals_with_dotdotdot.R 565f40ff5e73a439c85d095b47fa24bc *R/cleanup.R 5bb75d96c97b94726f58cd1e0019dfcd *R/environment_of.R fb56b3824be79c2cacd92bdb416d9c57 *R/findGlobals.R 8bc55d5852726bad892b73b7b2e083a0 *R/find_globals_conservative.R 063db36a94503f386796fcb95d337330 *R/find_globals_liberal.R e3ae16f3632b3e79d9362bb88d2d57ab *R/find_globals_ordered.R 600dfb071fdaeff21300ba14a12295d3 *R/globalsOf.R 0ac3ed0fedf975a941f7138ccb8e7ff5 *R/options.R 0703434ef16210f21128935bad9f8ca4 *R/packagesOf.R 803b446897dc95401f17ad56de402fe5 *R/utils,conditions.R b562a56e897095e954b3ec2ec87f111f *R/utils.R 0cb85d1fe03099d67ab18e085187fbe7 *R/walkAST.R 5377d3f92fe155b5af0bb80fed72a1ab *R/where.R 063cc1d50a8d5dd7d2b184b0c26e88a0 *R/zzz.R 8715ad369b73467f165df1ddb9d46071 *inst/WORDLIST da333f536e79c5fb1621fa9882282551 *man/Globals.Rd fd97c59539a927f4cd6e8622710be2c0 *man/cleanup.Globals.Rd fc7000ee5990508042e8b53ede23dae1 *man/globalsByName.Rd a7e0979f7fedcd339c5426e2280713e4 *man/globalsOf.Rd 71d33dd463fd36bf678fcf037e0d62aa *man/packagesOf.Globals.Rd 8f535a3461ee9bf48f75947b66fa71d9 *man/private_length.Rd e36b8a123a5d7dc214afc33d9362bc22 *man/walkAST.Rd 7b5c8fc44e5f39750c4da0ddb189afcc *tests/Globals.R 9618ce7d596f088b3433a3a6bd21d775 *tests/cleanup.R 4e14f10dce37601443615ffb1963c470 *tests/conservative.R e3b8f0e8791101cbe7a4289596cafabf *tests/dotdotdot.R 970fe48c3d2f16f39cf4c5d71683cdff *tests/findGlobals.R 326c30ef110b6c7903184c36124c6a19 *tests/formulas.R de77337d9770e5337bd1c5aab09b65f5 *tests/globalsByName.R e1f5c886d9ef3768319e7d6fdb69adb9 *tests/globalsOf,locals.R 367ca9b4690d333e16378f2ed0d9d504 *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 c9e701a499f796c7357c63cdf1cce799 *tests/utils.R 4d6835d9ab2dd497461bdb1aa2cb93d0 *tests/walkAST.R 7af53138f87e6ef0f9333c9b8176c51d *tests/zzz.R globals/inst/0000755000176200001440000000000014133660336012657 5ustar liggesusersglobals/inst/WORDLIST0000644000176200001440000000033114133660337014047 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