R/call_find_globals_with_dotdotdot.R

In globals: Identify Global Objects in R Expressions

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
}


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
}