1## This function is equivalent to: 2## fun <- as_function(expr, envir = envir, ...) 3## codetools::findGlobals(fun, merge = TRUE) 4## but we expand it here to make it more explicit 5## what is going on. 6#' @importFrom codetools findLocalsList walkCode 7find_globals_conservative <- function(expr, envir, dotdotdot, ..., trace = FALSE) { 8 objs <- character() 9 10 enter <- function(type, v, e, w) { 11 objs <<- c(objs, v) 12 } 13 14 if (is.function(expr)) { 15 if (typeof(expr) != "closure") return(character(0L)) # e.g. `<-` 16 fun <- expr 17 w <- make_usage_collector(fun, name = "<anonymous>", enterGlobal = enter) 18 if (trace) w <- inject_tracer_to_walker(w) 19 collect_usage_function(fun, name = "<anonymous>", w, trace = trace) 20 } else if (is.call(expr) && is.function(expr[[1]])) { 21 ## AD HOC: Fixes https://github.com/HenrikBengtsson/globals/issues/60 22 for (e in list(expr[[1]], expr[-1])) { 23 globals <- find_globals_conservative(expr = e, envir = envir, dotdotdot = dotdotdot, ..., trace = trace) 24 if (length(globals) > 0) objs <- c(objs, globals) 25 } 26 } else { 27 ## From codetools::findGlobals(): 28 fun <- as_function(expr, envir = envir, ...) 29 # codetools::collectUsage(fun, enterGlobal = enter) 30 31 ## The latter becomes equivalent to (after cleanup): 32 w <- make_usage_collector(fun, name = "<anonymous>", enterGlobal = enter) 33 if (trace) w <- inject_tracer_to_walker(w) 34 35 locals <- findLocalsList(list(expr)) 36 for (name in locals) assign(name, value = TRUE, envir = w$env) 37 walkCode(expr, w) 38 } 39 40 unique(objs) 41} 42 43 44#' @importFrom codetools walkCode 45find_globals_liberal <- function(expr, envir, dotdotdot, ..., trace = FALSE) { 46 objs <- character() 47 48 enter <- function(type, v, e, w) { 49 objs <<- c(objs, v) 50 } 51 52 if (is.function(expr)) { 53 if (typeof(expr) != "closure") return(character(0L)) ## e.g. `<-` 54 fun <- expr 55 w <- make_usage_collector(fun, name = "<anonymous>", enterGlobal = enter) 56 if (trace) w <- inject_tracer_to_walker(w) 57 collect_usage_function(fun, name = "<anonymous>", w, trace = trace) 58 } else if (is.call(expr) && is.function(expr[[1]])) { 59 ## AD HOC: Fixes https://github.com/HenrikBengtsson/globals/issues/60 60 for (e in list(expr[[1]], expr[-1])) { 61 globals <- find_globals_liberal(expr = e, envir = envir, dotdotdot = dotdotdot, ..., trace = trace) 62 if (length(globals) > 0) objs <- c(objs, globals) 63 } 64 } else { 65 fun <- as_function(expr, envir = envir, ...) 66 w <- make_usage_collector(fun, name = "<anonymous>", enterGlobal = enter) 67 if (trace) w <- inject_tracer_to_walker(w) 68 walkCode(expr, w) 69 } 70 71 unique(objs) 72} 73 74 75#' @importFrom codetools walkCode 76find_globals_ordered <- function(expr, envir, dotdotdot, ..., name = character(), class = character(), trace = FALSE) { 77 selfassign <- getOption("globals.selfassign", TRUE) 78 79 enter_local <- function(type, v, e, w) { 80 hardcoded_locals <- names(w$env) 81 if (trace) { 82 trace_msg <- trace_enter("enter_local(type=%s, v=%s)", sQuote(type), sQuote(v)) 83 trace_printf("before:\n") 84 trace_print(data.frame(name=name, class=class, stringsAsFactors = FALSE)) 85 trace_printf("hardcoded locals: %s\n", paste(sQuote(hardcoded_locals), collapse = ", ")) 86 on.exit(local({ 87 trace_printf("after:\n") 88 trace_print(data.frame(name=name, class=class, stringsAsFactors = FALSE)) 89 trace_exit(trace_msg) 90 })) 91 } 92 93 is_already_local <- (v %in% hardcoded_locals) 94 if (is_already_local) { 95 if (trace) trace_printf("variable is a hardcoded local: %s\n", sQuote(v)) 96 } 97 98 ## LHS <- RHS: Handle cases where a global variable exists in RHS and LHS 99 ## assigns a local variable with the same name, e.g. x <- x + 1. 100 ## In such case we want to detect 'x' as a global variable. 101 if (selfassign && (type == "<-" || type == "=")) { 102 if (trace) trace_printf("LHS <- RHS:\n") 103 rhs <- e[[3]] 104 globals <- call_find_globals_with_dotdotdot(find_globals_ordered, expr = rhs, envir = w$env, dotdotdot = "ignore", trace = trace) 105 if (trace) { 106 trace_printf("RHS globals: %s\n", paste(sQuote(globals), collapse = ", ")) 107 } 108 109 if (length(rhs) == 3 && globals[1] %in% c("::", ":::")) { 110 ## Case: a <- pkg::a 111 } else if (v %in% globals) { 112 v_class <- if (v %in% hardcoded_locals) "local" else "global" 113 if (trace) trace_printf("Add %s variable %s\n", sQuote(v_class), sQuote(v)) 114 class <<- c(class, v_class) 115 name <<- c(name, v) 116 } 117 } 118 119 if (trace) trace_printf("Add %s variable %s\n", sQuote("local"), sQuote(v)) 120 class <<- c(class, "local") 121 name <<- c(name, v) 122 } 123 124 enter_global <- function(type, v, e, w) { 125 hardcoded_locals <- names(w$env) 126 if (trace) { 127 trace_msg <- trace_enter("enter_global(type=%s, v=%s)", sQuote(type), sQuote(v)) 128 trace_printf("before:\n") 129 trace_print(data.frame(name=name, class=class, stringsAsFactors = FALSE)) 130 trace_printf("hardcoded locals: %s\n", paste(sQuote(hardcoded_locals), collapse = ", ")) 131 on.exit(local({ 132 trace_printf("after:\n") 133 trace_print(data.frame(name=name, class=class, stringsAsFactors = FALSE)) 134 trace_exit(trace_msg) 135 })) 136 } 137 138 is_already_local <- (v %in% hardcoded_locals) 139 if (is_already_local) { 140 if (trace) { 141 trace_printf("variable is a hardcoded local: %s\n", sQuote(v)) 142 } 143 } 144 145 v_class <- if (is_already_local) "local" else "global" 146 if (trace) trace_printf("Add %s variable %s\n", sQuote(v_class), sQuote(v)) 147 class <<- c(class, v_class) 148 name <<- c(name, v) 149 150 ## Also walk formulas to identify globals 151 if (type == "function") { 152 if (v == "~") { 153 if (trace) trace_printf("type = ~ (formula)\n") 154 stop_if_not(length(e) >= 2L, identical(e[[1]], as.symbol("~"))) 155 ## Ignoring dots overrides the default of silently returning 156 ## them from formulas 157 ## Fixes https://github.com/HenrikBengtsson/globals/issues/63 158 if (dotdotdot == "ignore") { 159 formula_dotdotdot <- "ignore" 160 } else { 161 formula_dotdotdot <- "return" 162 } 163 for (kk in 2:length(e)) { 164 globals <- call_find_globals_with_dotdotdot(find_globals_ordered, expr = e[[kk]], envir = w$env, dotdotdot = formula_dotdotdot, trace = trace) 165 if (length(globals) > 0) { 166 if (trace) trace_printf("Add %s variables %s\n", sQuote("global"), paste(sQuote(globals), collapse = ", ")) 167 class <<- c(class, rep("global", times = length(globals))) 168 name <<- c(name, globals) 169 } 170 } 171 } else if (selfassign && (v == "<-" || v == "=")) { 172 ## LHS <- RHS: Handle cases where a global variable exists in LHS in 173 ## the form of x[1] <- 0, which will cause 'x' to be called 174 ## a local variable later unless called global here. 175 if (trace) trace_printf("LHS <- RHS:\n") 176 lhs <- e[[2]] 177 if (length(lhs) >= 2) { 178 ## Cases: a[1] <- 0, names(a) <- "x", names(a)[1] <- "x" 179 ## Skip first symbol, because it'll be handled up later as 180 ## an assignment function, e.g. `[<-` and `names<-` 181 globals <- find_globals_ordered(expr = lhs, envir = w$env, dotdotdot = dotdotdot, name = hardcoded_locals, class = rep("local", times = length(hardcoded_locals)), trace = trace) 182 if (length(globals) > 0) { 183 if (trace) trace_printf("Add %s variables %s\n", sQuote("global"), paste(sQuote(globals), collapse = ", ")) 184 class <<- c(class, rep("global", times = length(globals))) 185 name <<- c(name, globals) 186 } 187 } 188 } else { 189 if (trace) trace_printf("a function not of interest\n") 190 } 191 } else { 192 if (trace) trace_printf("nothing to else to explore\n") 193 } 194 } 195 196 if (trace) { 197 trace_msg <- trace_enter("find_globals_ordered()") 198 on.exit(trace_exit(trace_msg)) 199 } 200 201 ## A function or an expression? 202 if (is.function(expr)) { 203 if (typeof(expr) != "closure") { 204 if (trace) trace_printf("typeof != closure\n") 205 return(character(0L)) ## e.g. `<-` 206 } 207 if (trace) trace_printf("type = function\n") 208 fun <- expr 209 w <- make_usage_collector(fun, name = "<anonymous>", 210 enterLocal = enter_local, 211 enterGlobal = enter_global) 212 if (trace) w <- inject_tracer_to_walker(w) 213 collect_usage_function(fun, name = "<anonymous>", w, trace = trace) 214 } else if (is.call(expr) && is.function(expr[[1]])) { 215 if (trace) trace_printf("type = a call to a function\n") 216 ## AD HOC: Fixes https://github.com/HenrikBengtsson/globals/issues/60 217 for (e in list(expr[[1]], expr[-1])) { 218 globals <- find_globals_ordered(expr = e, envir = envir, dotdotdot = dotdotdot, ..., trace = trace) 219 if (length(globals) > 0) { 220 class <- c(class, rep("global", times = length(globals))) 221 name <- c(name, globals) 222 } 223 } 224 } else if (is.call(expr) && is.symbol(expr[[1]]) && expr[[1]] == "{") { 225 if (trace) trace_printf("type = {\n") 226 class <- c(class, "global") 227 name <- c(name, "{") 228 nexpr <- length(expr) 229 if (trace) trace_printf("length(expr) = %d\n", nexpr) 230 if (nexpr >= 2) { 231 for (kk in 2:nexpr) { 232 e <- expr[[kk]] 233 globals <- find_globals_ordered(expr = e, envir = envir, dotdotdot = dotdotdot, ..., trace = trace) 234 if (length(globals) > 0) { 235 if (trace) trace_printf("Add %s variable %s\n", sQuote("global"), paste(sQuote(globals), collapse = ", ")) 236 class <- c(class, rep("global", times = length(globals))) 237 name <- c(name, globals) 238 } 239 locals <- codetools::findLocals(e) 240 if (length(locals) > 0) { 241 if (trace) trace_printf("Add %s variable %s\n", sQuote("local"), paste(sQuote(locals), collapse = ", ")) 242 class <- c(class, rep("locals", times = length(locals))) 243 name <- c(name, locals) 244 } 245 } 246 } 247 } else { 248 if (trace) trace_printf("type = call\n") 249 fun <- as_function(expr, envir = envir, ...) 250 if (trace) trace_print(fun) 251 w <- make_usage_collector(fun, name = "<anonymous>", 252 enterLocal = enter_local, 253 enterGlobal = enter_global) 254 if (trace) w <- inject_tracer_to_walker(w) 255 walkCode(expr, w) 256 } 257 258 if (trace) local({ 259 trace_printf("variables (with duplicates):\n") 260 trace_print(data.frame(name=name, class=class, stringsAsFactors = FALSE)) 261 }) 262 263 ## Drop duplicated names 264 dups <- duplicated(name) 265 class <- class[!dups] 266 name <- name[!dups] 267 268 if (trace) local({ 269 trace_printf("variables (no duplicates):\n") 270 trace_print(data.frame(name=name, class=class, stringsAsFactors = FALSE)) 271 }) 272 273 unique(name[class == "global"]) 274} 275 276 277call_find_globals_with_dotdotdot <- function(FUN, expr, envir, dotdotdot = "error", trace = FALSE, debug = FALSE) { 278 if (trace) { 279 trace_msg <- trace_enter("call_find_globals_with_dotdotdot(dotdotdot = %s)", sQuote(dotdotdot)) 280 on.exit(trace_exit(trace_msg)) 281 } 282 283 ## Is there a need for global '...', '..1', '..2', etc.? 284 dotdotdots <- character(0L) 285 286 globals <- withCallingHandlers({ 287 oopts <- options(warn = 0L) 288 on.exit(options(oopts), add = TRUE) 289 FUN(expr, envir = envir, dotdotdot = dotdotdot, trace = trace) 290 }, warning = function(w) { 291 ## Warned about '...', '..1', '..2', etc.? 292 ## NOTE: The warning we're looking for is the one generated by 293 ## codetools::findGlobals(). That warning is _not_ translated, 294 ## meaning this approach should work as is as long as the message 295 ## is not modified by codetools itself. If codetools ever changes 296 ## this such that the below string matching fails, then the package 297 ## tests (tests/dotdotdot.R) will detect that. In other words, 298 ## such a change will not go unnoticed. /HB 2017-03-08 299 msg <- w$message 300 pattern <- ".* ([.][.]([.]|[0-9]+)) may be used in an incorrect context.*" 301 if (grepl(pattern, msg, fixed = FALSE)) { 302 debug && mdebug(" - detected: %s", dQuote(trim(msg))) 303 if (dotdotdot %in% c("ignore", "return", "warning")) { 304 if (dotdotdot != "ignore") { 305 dotdotdots <<- c(dotdotdots, gsub(pattern, "\\1", msg)) 306 } 307 if (dotdotdot != "warning") { 308 ## Consume / muffle warning 309 invokeRestart("muffleWarning") 310 } 311 } else if (dotdotdot == "error") { 312 e <- simpleError(msg, w$call) 313 stop(e) 314 } 315 } 316 }) 317 318 if (trace) { 319 trace_printf("globals: %s\n", paste(sQuote(globals), collapse = ", ")) 320 } 321 322 if (length(dotdotdots) > 0L) { 323 dotdotdots <- unique(dotdotdots) 324 if (trace) { 325 trace_printf("dotdotdots: %s\n", paste(sQuote(dotdotdots), collapse = ", ")) 326 } 327 globals <- c(globals, dotdotdots) 328 } 329 330 globals 331} 332 333 334#' @param attributes If TRUE (default), attributes of `expr` are also searched. 335#' If FALSE, they are not. 336#' If a character vector, then attributes with matching names are searched. 337#' Note, the attributes of the attributes elements are not searched, that is, 338#' attributes are not searched recursively. Also, attributes are searched 339#' with `dotdotdot = "ignore". 340#' 341#' @param dotdotdot TBD. 342#' 343#' @param trace TBD. 344#' 345#' @return \code{findGlobals()} returns a character vector. 346#' 347#' @rdname globalsOf 348#' @export 349findGlobals <- function(expr, envir = parent.frame(), ..., 350 attributes = TRUE, 351 tweak = NULL, 352 dotdotdot = c("warning", "error", "return", "ignore"), 353 method = c("ordered", "conservative", "liberal"), 354 substitute = FALSE, unlist = TRUE, trace = FALSE) { 355 method <- match.arg(method, choices = c("ordered", "conservative", "liberal")) 356 dotdotdot <- match.arg(dotdotdot, choices = c("warning", "error", "return", "ignore")) 357 358 if (substitute) expr <- substitute(expr) 359 360 if (trace) { 361 trace_msg <- trace_enter("findGlobals(..., dotdotdot = '%s', method = '%s', unlist = %s)", dotdotdot, method, unlist) 362 on.exit(trace_exit(trace_msg)) 363 } 364 365 debug <- mdebug("findGlobals(..., dotdotdot = '%s', method = '%s', unlist = %s) ...", dotdotdot, method, unlist) 366 367 if (is.logical(attributes)) { 368 stop_if_not(length(attributes) == 1L, !is.na(attributes)) 369 if (!attributes) attributes <- character(0L) 370 } else { 371 stop_if_not(is.character(attributes), !anyNA(attributes)) 372 } 373 374 if (is.list(expr)) { 375 debug && mdebug(" - expr: <a list of length %d>", .length(expr)) 376 377 ## NOTE: Do *not* look for types that we are interested in, but instead 378 ## look for types that we are *not* interested. The reason for this that 379 ## in future versions of R there might be new types added that may contain 380 ## globals and with this approach those types will also be scanned. 381 basicTypes <- c("logical", "integer", "double", "complex", "character", 382 "raw", "NULL") 383 384 ## Skip elements in 'expr' of basic types that cannot contain globals 385 types <- unlist(list_apply(expr, FUN = typeof), use.names = FALSE) 386 keep <- !(types %in% basicTypes) 387 388 ## Don't use expr[keep] here, because that may use S3 dispatching 389 ## depending on class(expr) 390 expr <- .subset(expr, keep) 391 392 ## Early stopping? 393 if (.length(expr) == 0) { 394 debug && mdebug(" - globals found: [0] <none>") 395 debug && mdebug("findGlobals(..., dotdotdot = '%s', method = '%s', unlist = %s) ... DONE", dotdotdot, method, unlist) #nolint 396 return(character(0L)) 397 } 398 399 globals <- list_apply(expr, FUN = findGlobals, envir = envir, 400 attributes = attributes, ..., 401 tweak = tweak, dotdotdot = dotdotdot, 402 method = method, 403 substitute = FALSE, unlist = FALSE, 404 trace = trace) 405 406 keep <- types <- NULL ## Not needed anymore 407 408 debug && mdebug(" - preliminary globals found: [%d] %s", 409 length(globals), hpaste(sQuote(names(globals)))) 410 411 if (unlist) { 412 globals <- unlist(globals, use.names = FALSE) 413 if (length(globals) > 1L) globals <- unique(globals) 414 ## Move any ..., ..1, ..2, etc. to the very end 415 idxs <- grep("^[.][.]([.]|[0-9]+)$", globals) 416 if (length(idxs) > 0L) globals <- c(globals[-idxs], globals[idxs]) 417 } 418 419 debug && mdebug(" - globals found: [%d] %s", 420 length(globals), hpaste(sQuote(globals))) 421 debug && mdebug("findGlobals(..., dotdotdot = '%s', method = '%s', unlist = %s) ... DONE", dotdotdot, method, unlist) #nolint 422 423 return(globals) 424 } 425 426 if (is.function(tweak)) { 427 debug && mdebug(" - tweaking expression using function") 428 expr <- tweak(expr) 429 } 430 431 if (method == "ordered") { 432 find_globals_t <- find_globals_ordered 433 } else if (method == "conservative") { 434 find_globals_t <- find_globals_conservative 435 } else if (method == "liberal") { 436 find_globals_t <- find_globals_liberal 437 } 438 439 globals <- call_find_globals_with_dotdotdot(find_globals_t, expr = expr, envir = envir, dotdotdot = dotdotdot, trace = trace, debug = debug) 440 441 ## Search attributes? 442 if (length(attributes) > 0) { 443 attrs <- attributes(expr) 444 if (is.character(attributes)) { 445 attrs <- attrs[names(attrs) %in% attributes] 446 } 447 448 ## Attributes to be searched, if any 449 if (length(attrs) > 0) { 450 debug && mdebug(" - searching attributes") 451 attrs_globals <- list_apply(attrs, FUN = findGlobals, envir = envir, 452 ## Don't look for attributes recursively 453 attributes = FALSE, 454 tweak = tweak, 455 ..., 456 ## Don't complain about '...', '..1', etc. 457 dotdotdot = "ignore", 458 method = method, 459 substitute = FALSE, unlist = FALSE, 460 trace = trace) 461 if (unlist) attrs_globals <- unlist(attrs_globals, use.names = FALSE) 462 if (length(attrs_globals) > 1L) attrs_globals <- unique(attrs_globals) 463 debug && mdebug(" - globals found in attributes: [%d] %s", 464 length(attrs_globals), hpaste(sQuote(attrs_globals))) 465 globals <- unique(c(globals, attrs_globals)) 466 } 467 } 468 469 debug && mdebug(" - globals found: [%d] %s", length(globals), hpaste(sQuote(globals))) 470 debug && mdebug("findGlobals(..., dotdotdot = '%s', method = '%s', unlist = %s) ... DONE", dotdotdot, method, unlist) #nolint 471 472 globals 473} 474 475 476## Utility functions adopted from codetools:::dropMissing() 477## and codetools:::collectUsageFun() 478drop_missing_formals <- function(x) { 479 nx <- length(x) 480 ix <- logical(length = nx) 481 for (i in seq_len(nx)) { 482 tmp <- x[[i]] 483 if (!missing(tmp)) ix[i] <- TRUE 484 } 485 x[ix] 486} 487 488#' @importFrom codetools walkCode findLocalsList 489collect_usage_function <- function(fun, name, w, trace = FALSE) { 490 if (trace) { 491 trace_msg <- trace_enter("collect_usage_function()") 492 on.exit(trace_exit(trace_msg)) 493 } 494 495 formals <- formals(fun) 496 body <- body(fun) 497 498 w$name <- c(w$name, name) 499 parnames <- names(formals) 500 if (trace) { 501 trace_printf("parnames: %s\n", paste(sQuote(parnames), collapse = ", ")) 502 } 503 504 formals_clean <- drop_missing_formals(formals) 505# locals <- findLocalsList(c(list(body), formals_clean)) 506 locals <- findLocalsList(formals_clean) 507 508 if (trace) { 509 trace_printf("formals_clean: %s\n", paste(sQuote(formals_clean), collapse = ", ")) 510 trace_printf("locals: %s\n", paste(sQuote(locals), collapse = ", ")) 511 } 512 513 ## Hardcode locals? 514 hardcoded_locals <- c(parnames, locals) 515 if (length(hardcoded_locals) > 0) { 516 if (trace) trace_printf("Add hardcoded local variables %s", paste(sQuote(hardcoded_locals), collapse = ", ")) 517 w$env <- new.env(hash = TRUE, parent = w$env) 518 for (n in hardcoded_locals) assign(n, TRUE, w$env) 519 } 520 521 if (trace) { 522 trace_printf("hardcoded locals: %s\n", paste(sQuote(names(w$env)), collapse = ", ")) 523 } 524 525 for (a in formals_clean) { 526 if (trace) trace_enter("walkCode(%s)", sQuote(a)) 527 walkCode(a, w) 528 if (trace) trace_exit("walkCode(%s)", sQuote(a)) 529 } 530 531 if (trace) trace_enter("walkCode(body)") 532 res <- walkCode(body, w) 533 if (trace) trace_exit("walkCode(body)") 534 535 res 536} 537 538 539inject_tracer_to_function <- function(fcn, name) { 540 b <- body(fcn) 541 f <- formals(fcn) 542 args <- setdiff(names(f), c("w", "...")) 543 if (length(args) > 0L) { 544 args <- grep("^[.][.][0-9]+$", args, invert = TRUE, value = TRUE) 545 } 546 title <- sprintf("%s()", name) 547 b <- bquote({ 548 ## Import private functions 549 ns <- getNamespace("globals") 550 trace_str <- get("trace_str", envir = ns, mode = "function") 551 trace_exit <- get("trace_exit", envir = ns, mode = "function") 552 trace_printf <- get("trace_printf", envir = ns, mode = "function") 553 trace_print <- get("trace_print", envir = ns, mode = "function") 554 555 trace_msg <- trace_enter("%s", .(title)) 556 trace_indent <- attr(trace_msg, "indent") 557 if (length(.(args)) > 0) trace_str(mget(.(args)), indent = trace_indent) 558 if (!exists("w", mode = "list")) { 559 trace_exit(trace_msg) 560 return() 561 } 562 env <- environment(w$enterLocal) 563 n <- length(env$name) 564 value <- .(b) 565 nnew <- (length(env$name) - n) 566 if (nnew) { 567 trace_printf("variables:\n", indent = trace_indent) 568 trace_print(data.frame( 569 name = env$name, 570 class = env$class, 571 added = c(rep(FALSE, times = n), rep(TRUE, times = nnew)), 572 stringsAsFactors = FALSE 573 ), indent = trace_indent) 574 } 575 trace_printf("result: ", indent = trace_indent) 576 trace_str(value, indent = trace_indent) 577 trace_exit(trace_msg) 578 value 579 }) 580 body(fcn) <- b 581 fcn 582} 583 584inject_tracer_to_walker <- function(w) { 585 if (is.null(w$startCollectLocals)) { 586 w$startCollectLocals <- function(parnames, locals, ...) { NULL } 587 } 588 if (is.null(w$finishCollectLocals)) { 589 w$finishCollectLocals <- function(w, ...) { NULL } 590 } 591 if (is.null(w$enterInternal)) { 592 w$enterInternal <- function(type, v, e, ...) { NULL } 593 } 594 595 for (key in names(w)) { 596 fcn <- w[[key]] 597 if (!is.function(fcn)) next 598# fcn <- inject_tracer_to_function(fcn, key) 599 w[[key]] <- fcn 600 } 601 602 w 603} 604 605 606#' @importFrom codetools makeUsageCollector walkCode 607make_usage_collector <- local({ 608 ## WORKAROUND: Avoid calling codetools::collectUsageCall() if it hits the 609 ## https://bugs.r-project.org/bugzilla/show_bug.cgi?id=17935 bug in the 610 ## stats:::`[.formula` function 611 ## See also: https://github.com/HenrikBengtsson/globals/issues/64 612 if (getRversion() <= "4.0.3" || is.null(ver <- R.version$`svn rev`) || 613 is.na(ver <- as.integer(ver)) || ver < 79355) { 614 ## Local copy of codetools:::collectUsageCall() 615 .collectUsageCall <- NULL 616 617 collectUsageCall <- function(e, w) { 618 e1 <- e[[1]] 619 if (is.symbol(e1) && inherits(e, "formula") && is.null(e[[2]])) { 620 ## From codetools:::collectUsageCall() 621 fn <- as.character(e1) 622 if (w$isLocal(fn, w)) { 623 w$enterLocal("function", fn, e, w) 624 } else { 625 w$enterGlobal("function", fn, e, w) 626 } 627 } else { 628 .collectUsageCall(e, w) 629 } 630 } 631 632 function(...) { 633 w <- makeUsageCollector(...) 634 w$env <- new.env(parent = w$env) 635 if (is.function(w$call)) { 636 ## Memoize? (to avoid importing a private 'codetools' function) 637 if (is.null(.collectUsageCall)) .collectUsageCall <<- w$call 638 ## Patch 639 w$call <- collectUsageCall 640 } 641 w 642 } 643 } else { 644 function(...) { 645 w <- makeUsageCollector(...) 646 w$env <- new.env(hash = TRUE, parent = w$env) 647 w 648 } 649 } 650}) 651