Merge pull request #252 from r-lib/bugfix/global-source

Always handle `source()` when `envir` is the global environment

NEWS.md

@@ -26,8 +26,12 @@
   order even if they are registered with `on.exit()`) and standalone
   versions of `defer()`.
 
-* `source()` support now requires setting `options(withr.hook_source = TRUE)`.
-  It is disabled by default to avoid a performance penalty when not needed.
+* When `source()` is used with a local environment, as opposed to
+  `globalenv()` (the default), you now need to set
+  `options(withr.hook_source = TRUE)` to get proper withr support
+  (running `defer()` or `local_` functions at top-level of a script).
+  THis support is disabled by default in local environments to avoid a
+  performance penalty in normal usage of withr features.
 
 * `with_language()` now properly resets the translation cache (#213).
 

R/defer-exit.R

@@ -22,16 +22,21 @@ knitr_exit_frame <- function(envir) {
 }
 
 source_exit_frame <- function(envir) {
-  frames <- as.list(sys.frames())
+  source_exit_frame_option(envir) %||% envir
+}
+
+# Returns an environment if expression is called directly from `source()`.
+# Otherwise returns `NULL`.
+source_exit_frame_option <- function(envir, frames = as.list(sys.frames())) {
   calls <- as.list(sys.calls())
 
   i <- frame_loc(envir, frames)
   if (!i) {
-    return(envir)
+    return(NULL)
   }
 
   if (i < 4) {
-    return(envir)
+    return(NULL)
   }
 
   is_call <- function(x, fn) {
@@ -40,16 +45,16 @@ source_exit_frame <- function(envir) {
   calls <- as.list(calls)
 
   if (!is_call(calls[[i - 3]], quote(source))) {
-    return(envir)
+    return(NULL)
   }
   if (!is_call(calls[[i - 2]], quote(withVisible))) {
-    return(envir)
+    return(NULL)
   }
   if (!is_call(calls[[i - 1]], quote(eval))) {
-    return(envir)
+    return(NULL)
   }
   if (!is_call(calls[[i - 0]], quote(eval))) {
-    return(envir)
+    return(NULL)
   }
 
   frames[[i - 3]]

R/defer.R

@@ -18,10 +18,13 @@ NULL
 #' registered handlers on this environment.
 #'
 #' @section Running handlers within `source()`:
-#' `r lifecycle::badge("experimental")` Set `options(withr.hook_source
-#' = TRUE)` to enable top-level usage of withr tools in scripts
-#' sourced with `base::source()`. The cleanup expressions are run when
-#' `source()` exits (either normally or early due to an error).
+#' withr handlers run within `source()` are run when `source()` exits
+#' rather than line by line.
+#'
+#' This is only the case when the script is sourced in `globalenv()`.
+#' For a local environment, the caller needs to set
+#' `options(withr.hook_source = TRUE)`. This is to avoid paying the
+#' penalty of detecting `source()` in the normal usage of `defer()`.
 #'
 #' @details
 #' `defer()` works by attaching handlers to the requested environment (as an
@@ -65,14 +68,28 @@ NULL
 #'   print(attributes(environment()))
 #' })
 #'
-#' # note that examples lack function scoping so deferred calls will
-#' # will be executed immediately
+#' # Note that examples lack function scoping so deferred calls might
+#' # be executed immediately. This is currently the case on websites
+#' # built with pkgdown
 #' defer(print("one"))
 #' defer(print("two"))
 defer <- function(expr, envir = parent.frame(), priority = c("first", "last")) {
-  if (is_top_level_global_env(envir)) {
-    global_defer(expr, priority = priority)
-    return(invisible(NULL))
+  if (identical(envir, globalenv())) {
+    source_frame <- source_exit_frame_option(envir)
+    if (!is.null(source_frame)) {
+      # Automatically enable `source()` special-casing for the global
+      # environment. This is the default for `source()` and the normal
+      # case when users run scripts. This also happens in R CMD check
+      # when withr is used inside an example because an R example is
+      # run inside `withAutoprint()` which uses `source()`.
+      local_options(withr.hook_source = TRUE)
+      # And fallthrough to the default `defer()` handling. Within
+      # `source()` we don't require manual calling of
+      # `deferred_run()`.
+    } else if (is_top_level_global_env(envir)) {
+      global_defer(expr, priority = priority)
+      return(invisible(NULL))
+    }
   }
 
   priority <- match.arg(priority, choices = c("first", "last"))

revdep/README.md

@@ -41,11 +41,3 @@
 |terraTCGAdata     |?       |      |        |     |
 |zellkonverter     |?       |      |        |     |
 
-## New problems (3)
-
-|package  |version |error  |warning |note |
-|:--------|:-------|:------|:-------|:----|
-|[lintr](problems.md#lintr)|3.1.1   |__+1__ |        |1    |
-|[rsi](problems.md#rsi)|0.1.0   |__+1__ |        |     |
-|[testthat](problems.md#testthat)|3.2.1   |__+1__ |        |1    |
-

revdep/cran.md

@@ -2,20 +2,6 @@
 
 We checked 614 reverse dependencies (578 from CRAN + 36 from Bioconductor), comparing R CMD check results across CRAN and dev versions of this package.
 
- * We saw 3 new problems
+ * We saw 0 new problems
  * We failed to check 0 packages
 
-Issues with CRAN packages are summarised below.
-
-### New problems
-(This reports the first line of each new failure)
-
-* lintr
-  checking examples ... ERROR
-
-* rsi
-  checking tests ... ERROR
-
-* testthat
-  checking re-building of vignette outputs ... ERROR
-

revdep/problems.md

@@ -1,140 +1 @@
-# lintr
-
-<details>
-
-* Version: 3.1.1
-* GitHub: https://github.com/r-lib/lintr
-* Source code: https://github.com/cran/lintr
-* Date/Publication: 2023-11-07 16:10:02 UTC
-* Number of recursive dependencies: 73
-
-Run `revdepcheck::cloud_details(, "lintr")` for more info
-
-</details>
-
-## Newly broken
-
-*   checking examples ... ERROR
-    ```
-    Running examples in ‘lintr-Ex.R’ failed
-    The error most likely occurred in:
-    
-    > ### Name: get_r_string
-    > ### Title: Extract text from 'STR_CONST' nodes
-    > ### Aliases: get_r_string
-    > 
-    > ### ** Examples
-    > 
-    > ## Don't show: 
-    ...
-    + # more importantly, extract strings under R>=4 raw strings
-    + ## Don't show: 
-    + }) # examplesIf
-    > tmp <- withr::local_tempfile(lines = "c('a', 'b')")
-    > expr_as_xml <- get_source_expressions(tmp)$expressions[[1L]]$xml_parsed_content
-    Warning in file(con, "r") :
-      cannot open file '/tmp/RtmpKeEwV5/fileb911a9320f5': No such file or directory
-    Error in file(con, "r") : cannot open the connection
-    Calls: <Anonymous> ... read_lines -> withCallingHandlers -> readLines -> file
-    Execution halted
-    ```
-
-## In both
-
-*   checking package dependencies ... NOTE
-    ```
-    Package which this enhances but not available for checking: ‘data.table’
-    ```
-
-# rsi
-
-<details>
-
-* Version: 0.1.0
-* GitHub: https://github.com/Permian-Global-Research/rsi
-* Source code: https://github.com/cran/rsi
-* Date/Publication: 2024-01-10 14:00:02 UTC
-* Number of recursive dependencies: 78
-
-Run `revdepcheck::cloud_details(, "rsi")` for more info
-
-</details>
-
-## Newly broken
-
-*   checking tests ... ERROR
-    ```
-      Running ‘testthat.R’
-    Running the tests in ‘tests/testthat.R’ failed.
-    Complete output:
-      > # This file is part of the standard setup for testthat.
-      > # It is recommended that you do not modify it.
-      > #
-      > # Where should you do additional test configuration?
-      > # Learn more about the roles of various files in:
-      > # * https://r-pkgs.org/testing-design.html#sec-tests-files-overview
-      > # * https://testthat.r-lib.org/articles/special-files.html
-    ...
-       3. │   └─rlang::eval_bare(values, get_env(fn))
-       4. ├─base::unique(...)
-       5. ├─base::unlist(spectral_indices(download_indices = FALSE, update_cache = FALSE)$platforms)
-       6. └─rsi::spectral_indices(download_indices = FALSE, update_cache = FALSE)
-       7.   ├─tibble::as_tibble(readRDS(indices_path))
-       8.   └─base::readRDS(indices_path)
-      
-      [ FAIL 1 | WARN 1 | SKIP 18 | PASS 49 ]
-      Error: Test failures
-      Execution halted
-    ```
-
-# testthat
-
-<details>
-
-* Version: 3.2.1
-* GitHub: https://github.com/r-lib/testthat
-* Source code: https://github.com/cran/testthat
-* Date/Publication: 2023-12-02 11:50:05 UTC
-* Number of recursive dependencies: 81
-
-Run `revdepcheck::cloud_details(, "testthat")` for more info
-
-</details>
-
-## Newly broken
-
-*   checking re-building of vignette outputs ... ERROR
-    ```
-    Error(s) in re-building vignettes:
-    --- re-building ‘custom-expectation.Rmd’ using rmarkdown
-    --- finished re-building ‘custom-expectation.Rmd’
-    
-    --- re-building ‘parallel.Rmd’ using rmarkdown
-    --- finished re-building ‘parallel.Rmd’
-    
-    --- re-building ‘skipping.Rmd’ using rmarkdown
-    --- finished re-building ‘skipping.Rmd’
-    
-    ...
-    --- failed re-building ‘test-fixtures.Rmd’
-    
-    --- re-building ‘third-edition.Rmd’ using rmarkdown
-    --- finished re-building ‘third-edition.Rmd’
-    
-    SUMMARY: processing the following file failed:
-      ‘test-fixtures.Rmd’
-    
-    Error: Vignette re-building failed.
-    Execution halted
-    ```
-
-## In both
-
-*   checking installed package size ... NOTE
-    ```
-      installed size is 12.0Mb
-      sub-directories of 1Mb or more:
-        R      1.9Mb
-        libs   8.5Mb
-    ```
-
+*Wow, no problems at all. :)*

tests/testthat/_snaps/standalone-defer.md

@@ -9,3 +9,12 @@
         * On demand, if you call `withr::deferred_run()`.
       i Use `withr::deferred_clear()` to clear them without executing.
 
+# don't need to enable source for the global env
+
+    Code
+      source(file, local = globalenv())
+    Output
+      1
+      2
+      deferred
+

tests/testthat/test-standalone-defer.R

@@ -190,6 +190,22 @@ test_that("defer works within source()", {
   ))
 })
 
+test_that("don't need to enable source for the global env", {
+  local_options(withr.hook_source = NULL)
+
+  file <- local_tempfile()
+
+  cat(file = file, "
+    writeLines('1')
+    withr::defer(writeLines('deferred'))
+    writeLines('2')
+  ")
+
+  expect_snapshot({
+    source(file, local = globalenv())
+  })
+})
+
 test_that("defer works within knitr::knit()", {
   skip_if_not_installed("knitr")
   out <- NULL