r-lib / pak

Compare 02b289a ... +249 ... 3758d1b

No flags found

Use flags to group coverage reports by test type, project and/or folders.
Then setup custom commit statuses and notifications for each flag.

e.g., #unittest #integration

#production #enterprise

#frontend #backend

Learn more about Codecov Flags here.

Showing 28 of 113 files from the diff.
Newly tracked file
R/safe-cran-install.R created.
Newly tracked file
R/cran-install-order.R created.
Newly tracked file
R/push-packages.R created.
Newly tracked file
R/compat-vctrs.R created.
Newly tracked file
R/embed-lib.R created.
Newly tracked file
R/embed-ca-certs.R created.
Newly tracked file
R/lockfile.R created.
Newly tracked file
R/build-pak-binary.R created.
Other files ignored by Codecov
man/lib_status.Rd has changed.
.gitignore has changed.
man/local_deps.Rd has changed.
man/cache.Rd has changed.
R/json.R is new.
man/metadata.Rd has changed.
_pkgdown.yml has changed.
README.md has changed.
NEWS.md has changed.
R/docs.R is new.
man/pkg_status.Rd has changed.
man/repo_add.Rd has changed.
.Rbuildignore has changed.
tests/testthat.R has changed.
man/faq.Rd is new.
inst/WORDLIST has changed.
NAMESPACE has changed.
man/pkg_deps.Rd has changed.
README.Rmd has changed.
man/pak_update.Rd has changed.
DESCRIPTION has changed.
man/pkg_search.Rd has changed.

@@ -0,0 +1,11 @@
Loading
1 +
2 +
# copy this to pak_sitrep_data.R as well
3 +
4 +
default_cran_mirror <- function() {
5 +
  mirror <- getOption("repos")["CRAN"]
6 +
  if (is.null(mirror) || is.na(mirror) || mirror == "@CRAN@") {
7 +
    c(CRAN = "https://cran.rstudio.com")
8 +
  } else {
9 +
    c(CRAN = unname(mirror))
10 +
  }
11 +
}

@@ -1,6 +1,48 @@
Loading
1 1
2 -
pak_repo <- function() {
3 -
  "https://r-lib.github.io/p/pak/dev/"
2 +
detect_platform <- function() {
3 +
  me <- list(
4 +
    os = R.Version()$os,
5 +
    arch = R.Version()$arch,
6 +
    rver = get_minor_r_version(getRversion())
7 +
  )
8 +
9 +
  if (me$os %in% c("linux-dietlibc", "linux-gnu", "linux-musl",
10 +
                   "linux-uclibc", "linux-unknown")) {
11 +
    me$os <- "linux"
12 +
  }
13 +
  me
14 +
}
15 +
16 +
pak_stream <- function(stream) {
17 +
  if (stream == "auto") {
18 +
    version <- unclass(package_version(utils::packageVersion("pak")))[[1]]
19 +
    stream <- if (length(version) >= 4 && version[4] == 9999) {
20 +
      "rc"
21 +
    } else if (length(version) >= 4 && version[4] >= 9000) {
22 +
      "devel"
23 +
    } else {
24 +
      "stable"
25 +
    }
26 +
  }
27 +
  stream
28 +
}
29 +
30 +
pak_repo <- function(stream = "auto") {
31 +
  stream <- pak_stream(stream)
32 +
  paste0("https://r-lib.github.io/p/pak/", stream, "/")
33 +
}
34 +
35 +
pak_repo_metadata <- function(repo = NULL, stream = "auto") {
36 +
  repo <- repo %||% pak_repo(stream)
37 +
  url <- paste0(repo, "metadata.json")
38 +
  tmp <- tempfile()
39 +
  on.exit(unlink(tmp), add = TRUE)
40 +
  utils::download.file(url, tmp, mode = "wb", quiet = TRUE)
41 +
  df <- json$parse_file(tmp)
42 +
  meta <- do.call(rbind, lapply(df, as.data.frame, stringsAsFactors = FALSE))
43 +
  rver <- sub("R ", "", sapply(strsplit(meta$Built, ";"), "[[", 1))
44 +
  meta$RVersion <- get_minor_r_version(rver)
45 +
  meta
4 46
}
5 47
6 48
#' Update pak itself
@@ -9,107 +51,157 @@
Loading
9 51
#'
10 52
#' @param force Whether to force an update, even if no newer version is
11 53
#'   available.
54 +
#' @param stream Whether to update to the
55 +
#'   * `"stable"`,
56 +
#'   * `"rc"` (release candidate) or
57 +
#'   * `"devel"` (development) version.
58 +
#'   * `"auto"` updates to the same stream as the current one.
59 +
#'
60 +
#'   Often there is no release candidate version, then `"rc"` also
61 +
#'   installs the stable version.
12 62
#'
13 63
#' @return Nothing.
14 64
#'
15 65
#' @export
16 66
17 -
pak_update <- function(force = FALSE) {
67 +
pak_update <- function(
68 +
  force = FALSE,
69 +
  stream = c("auto", "stable", "rc", "devel")) {
70 +
71 +
  stopifnot(is_flag(force))
72 +
  stream <- match.arg(stream)
73 +
  stream <- pak_stream(stream)
74 +
18 75
  repo <- pak_repo()
19 76
20 -
  os <- get_os()
21 -
  if (os %in% c("win", "mac")) {
22 -
    av <- utils::available.packages(
23 -
      repos = repo,
24 -
      type = "binary",
25 -
      fields = c("Built", "File")
77 +
  if (!is.null(.getNamespace("pak")$.__DEVTOOLS__)) {
78 +
    lib <- .libPaths()[1]
79 +
    warning(
80 +
      "`load_all()`-d pak package, updating in default library at\n  ",
81 +
      "`", lib, "`",
82 +
      immediate. = TRUE
26 83
    )
27 84
  } else {
28 -
    av <- utils::available.packages(
29 -
      repos = repo,
30 -
      type = "source",
31 -
      filters = list(
32 -
        add = TRUE,
33 -
        "R_version",
34 -
        "OS_type",
35 -
        "subarch",
36 -
        av_filter,
37 -
        "duplicates"
38 -
      ),
39 -
      fields = c("Built", "File")
40 -
    )
85 +
    lib <- dirname(getNamespaceInfo("pak", "path"))
41 86
  }
42 87
43 -
  if (nrow(av) == 0) {
44 -
    stop("Cannot find a pak binary for this platform. :(")
88 +
  repo <- pak_repo(stream)
89 +
  meta <- pak_repo_metadata(repo)
90 +
91 +
  me <- detect_platform()
92 +
  cand <- which(
93 +
    meta$OS == me$os &
94 +
    meta$Arch == me$arch &
95 +
    meta$RVersion == me$rver
96 +
  )
97 +
98 +
  if (length(cand) == 0) {
99 +
    pak_update_unsupported_platform(stream, me, meta)
100 +
  } else if (length(cand) > 1) {
101 +
    warning("Multiple pak candidates are available for this platform, ",
102 +
            "this should not happen. Using the first one.")
103 +
    cand <- cand[1]
45 104
  }
105 +
  check_mac_cran_r(me, meta)
46 106
47 -
  upd <- should_update_to(av)
107 +
  upd <- should_update_to(meta[cand, , drop = FALSE])
48 108
  if (!upd && !force) {
49 109
    message("\nCurrent version is the latest, no need to update.")
50 110
    return(invisible())
51 111
  }
52 112
53 -
  message("\nUpdating to version ", av[1, "Version"], "\n")
113 +
  url <- paste0(repo, me$os, "/", me$arch, "/", meta$File[cand])
114 +
  tgt <- file.path(tempdir(), meta$File[cand])
115 +
  utils::download.file(url, tgt, mode = "wb")
54 116
55 -
  url <- paste0(av[1, "Repository"], "/", av[1, "File"])
56 -
  tgt <- file.path(tempdir(), av[1, "File"])
57 -
  utils::download.file(url, tgt)
117 +
  date <- get_built_date(meta$Built[cand])
118 +
  message("\nUpdating to version ", meta$Version[cand], " (", date, ")\n")
58 119
59 120
  # Otherwise the subprocess might be locking some DLLs
60 121
  try(pkg_data$remote$kill(), silent = TRUE)
61 122
62 -
  lib <- dirname(getNamespaceInfo("pak", "path"))
123 +
  # Windows cannot install binaries with arbitrary names, apparently.
124 +
  ext <- tools::file_ext(tgt)
125 +
  if (.Platform$OS.type == "windows" && ext == "zip") {
126 +
    dir.create(tmp <- tempfile(), recursive = TRUE)
127 +
    on.exit(unlink(tmp, recursive = TRUE), add = TRUE)
128 +
    tgt2 <- file.path(tmp, "pak.zip")
129 +
    if (!file.copy(tgt, tgt2)) {
130 +
      stop("Failed to copy downloaded file :(")
131 +
    }
132 +
    tgt <- tgt2
133 +
  }
63 134
  utils::install.packages(tgt, repos = NULL, type = "source", lib = lib)
64 135
65 136
  attached <- "package:pak" %in% search()
66 137
  message("\nReloading pak.")
67 -
  eapply(asNamespace("pak"), force, all.names = TRUE)
68 -
  unloadNamespace("pak")
69 -
  loadNamespace("pak")
70 -
  if (attached) library(pak)
71 138
72 139
  # Try to use it to see if it was successful
73 -
  tryCatch(
74 -
    suppressWarnings(tools::Rd_db(package = "pak")),
75 -
    error = function(err) {
76 -
      message("\nFailed to reload pak. Please restart your R session.")
77 -
    }
78 -
  )
140 +
  suppressWarnings(tryCatch({
141 +
    eapply(asNamespace("pak"), base::force, all.names = TRUE)
142 +
    unloadNamespace("pak")
143 +
    loadNamespace("pak")
144 +
    if (attached) library(pak)
145 +
    suppressWarnings(tools::Rd_db(package = "pak"))
146 +
  }, error = function(err) {
147 +
    message("\nFailed to reload pak. Please restart your R session.")
148 +
  }))
79 149
80 150
  invisible()
81 151
}
82 152
83 -
av_filter <- function(av) {
84 -
  if (! "File" %in% colnames(av)) return(av)
85 -
  file <- sub("[.]tar[.]gz$", "", av[, "File"])
86 -
  pcs <- strsplit(file, "_", fixed = TRUE)
87 -
  arch <- vcapply(pcs, function(x) paste(x[-(1:3)], collapse = "_"))
88 -
  curr <- R.Version()$platform
89 -
  mtch <- vlapply(arch, platform_match, curr)
90 -
  av[mtch, , drop = FALSE]
153 +
pak_update_unsupported_platform <- function(stream, me, meta) {
154 +
  message("pak has ", stream, " binaries for the following platforms:")
155 +
  meta$OS <- sub("^darwin", "macOS darwin", meta$OS)
156 +
  meta$OS <- sub("^mingw32", "Windows (mingw32)", meta$OS)
157 +
  pl <- paste0(meta$OS, ", ", meta$Arch)
158 +
  rv <- tapply(
159 +
    meta$RVersion,
160 +
    pl,
161 +
    function(x) paste0("R ", sort(x), ".x"),
162 +
    simplify = FALSE
163 +
  )
164 +
  pl2 <- sapply(rv, paste, collapse = ", ")
165 +
  message(paste0(" * ", names(pl2), ", ", pl2, "\n"))
166 +
  stop(
167 +
    "pak is not available for ", me$os, ", ",
168 +
    me$arch, ", R ", me$rver, ".x. Aborting now"
169 +
  )
170 +
  # TODO: tell how to install from source
171 +
}
172 +
173 +
check_mac_cran_r <- function(me, meta) {
174 +
  if (! grepl("^darwin", me$os)) return()
175 +
  if (.Platform$pkgType == "source") {
176 +
    stop(
177 +
      "pak only has binaries for the CRAN build of R, and this ",
178 +
      "seems to be a brew or another non-CRAN build."
179 +
    )
180 +
    # TODO: tell how to install from source
181 +
  }
91 182
}
92 183
93 -
should_update_to <- function(av) {
184 +
should_update_to <- function(new) {
94 185
  # check if the right platform was installed
95 -
  current <-R.Version()$platform
186 +
  current <- R.Version()$platform
96 187
  if (!platform_match(pak_sitrep_data$platform, current)) {
97 188
    message("\npak platform mismatch, trying to update to fix this...")
98 189
    return(TRUE)
99 190
  }
100 191
101 192
  # otherwise use version number first
102 193
  dsc <- utils::packageDescription("pak")
103 -
  if (package_version(dsc$Version) < av[1, "Version"]) return(TRUE)
194 +
  if (package_version(dsc$Version) < new$Version) return(TRUE)
104 195
105 196
  # or the build date
106 197
  blt_cur <- get_built_date(dsc$Built)
107 -
  blt_new <- get_built_date(av[1, "Built"])
108 -
  if (blt_cur < blt_new) return(TRUE)
198 +
  blt_new <- get_built_date(new$Built)
199 +
  if (is.na(blt_cur) || blt_cur < blt_new) return(TRUE)
109 200
  FALSE
110 201
}
111 202
112 203
get_built_date <- function(x) {
204 +
  if (!is_string(x)) return(NA_character_)
113 205
  # We can compare these dates as strings, so no need to parse
114 206
  strsplit(x, "[ ]*;[ ]*")[[1]][3]
115 207
}

@@ -5,7 +5,10 @@
Loading
5 5
# using rlang's functions for errors.
6 6
#
7 7
# The canonical location of this file is in the processx package:
8 -
# https://github.com/r-lib/processx/master/R/errors.R
8 +
# https://github.com/r-lib/processx/blob/main/R/errors.R
9 +
#
10 +
# ## Dependencies
11 +
# - rstudio-detect.R for better printing in RStudio
9 12
#
10 13
# ## Features
11 14
#
@@ -29,13 +32,23 @@
Loading
29 32
# ## API
30 33
#
31 34
# ```
32 -
# new_cond(..., call. = TRUE, domain = NULL)
33 -
# new_error(..., call. = TRUE, domain = NULL)
34 -
# throw(cond, parent = NULL)
35 -
# catch_rethrow(expr, ...)
36 -
# rethrow(expr, cond)
37 -
# rethrow_call(.NAME, ...)
38 -
# add_trace_back(cond)
35 +
# new_cond(..., call. = TRUE, srcref = NULL, domain = NA)
36 +
# new_error(..., call. = TRUE, srcref = NULL, domain = NA)
37 +
# throw(cond, parent = NULL, frame = environment())
38 +
# throw_error(cond, parent = NULL, frame = environment())
39 +
# chain_error(expr, err, call = sys.call(-1))
40 +
# chain_call(.NAME, ...)
41 +
# chain_clean_call(.NAME, ...)
42 +
# onload_hook()
43 +
# add_trace_back(cond, frame = NULL)
44 +
# format$advice(x)
45 +
# format$call(call)
46 +
# format$class(x)
47 +
# format$error(x, trace = FALSE, class = FALSE, advice = !trace, ...)
48 +
# format$error_heading(x, prefix = NULL)
49 +
# format$header_line(x, prefix = NULL)
50 +
# format$srcref(call, srcref = NULL)
51 +
# format$trace(x, ...)
39 52
# ```
40 53
#
41 54
# ## Roadmap:
@@ -89,9 +102,43 @@
Loading
89 102
# ### 1.2.3 -- 2021-03-06
90 103
#
91 104
# * Use cli instead of crayon
105 +
#
106 +
# ### 1.2.4 -- 2021-04-01
107 +
#
108 +
# * Allow omitting the call with call. = FALSE in `new_cond()`, etc.
109 +
#
110 +
# ### 1.3.0 -- 2021-04-19
111 +
#
112 +
# * Avoid embedding calls in trace with embed = FALSE.
113 +
#
114 +
# ### 2.0.0 -- 2021-04-19
115 +
#
116 +
# * Versioned classes and print methods
117 +
#
118 +
# ### 2.0.1 -- 2021-06-29
119 +
#
120 +
# * Do not convert error messages to native encoding before printing,
121 +
#   to be able to print UTF-8 error messages on Windows.
122 +
#
123 +
# ### 2.0.2 -- 2021-09-07
124 +
#
125 +
# * Do not translate error messages, as this converts them to the native
126 +
#   encoding. We keep messages in UTF-8 now.
127 +
#
128 +
# ### 3.0.0 -- 2022-04-19
129 +
#
130 +
# * Major rewrite, use rlang compatible error objects. New API.
131 +
#
132 +
# ##3 3.0.1 -- 2022-06-17
133 +
#
134 +
# * Remove the `rlang_error` and `rlang_trace` classes, because our new
135 +
#   deparsed `call` column in the trace is not compatible with rlang.
92 136
93 137
err <- local({
94 138
139 +
  # -- dependencies -----------------------------------------------------
140 +
  rstudio_detect <- rstudio$detect
141 +
95 142
  # -- condition constructors -------------------------------------------
96 143
97 144
  #' Create a new condition
@@ -101,15 +148,20 @@
Loading
101 148
  #'   character and then concatenated, like in [stop()].
102 149
  #' @param call. A call object to include in the condition, or `TRUE`
103 150
  #'   or `NULL`, meaning that [throw()] should add a call object
104 -
  #'   automatically.
105 -
  #' @param domain Translation domain, see [stop()].
151 +
  #'   automatically. If `FALSE`, then no call is added.
152 +
  #' @param srcref Alternative source reference object to use instead of
153 +
  #'   the one of `call.`.
154 +
  #' @param domain Translation domain, see [stop()]. We set this to
155 +
  #'   `NA` by default, which means that no translation occurs. This
156 +
  #'   has the benefit that the error message is not re-encoded into
157 +
  #'   the native locale.
106 158
  #' @return Condition object. Currently a list, but you should not rely
107 159
  #'   on that.
108 160
109 -
  new_cond <- function(..., call. = TRUE, domain = NULL) {
161 +
  new_cond <- function(..., call. = TRUE, srcref = NULL, domain = NA) {
110 162
    message <- .makeMessage(..., domain = domain)
111 163
    structure(
112 -
      list(message = message, call = call.),
164 +
      list(message = message, call = call., srcref = srcref),
113 165
      class = c("condition"))
114 166
  }
115 167
@@ -120,13 +172,14 @@
Loading
120 172
  #' @noRd
121 173
  #' @param ... Passed to [new_cond()].
122 174
  #' @param call. Passed to [new_cond()].
175 +
  #' @param srcref Passed tp [new_cond()].
123 176
  #' @param domain Passed to [new_cond()].
124 177
  #' @return Error condition object with classes `rlib_error`, `error`
125 178
  #'   and `condition`.
126 179
127 -
  new_error <- function(..., call. = TRUE, domain = NULL) {
128 -
    cond <- new_cond(..., call. = call., domain = domain)
129 -
    class(cond) <- c("rlib_error", "error", "condition")
180 +
  new_error <- function(..., call. = TRUE, srcref = NULL, domain = NA) {
181 +
    cond <- new_cond(..., call. = call., domain = domain, srcref = srcref)
182 +
    class(cond) <- c("rlib_error_3_0", "rlib_error", "error", "condition")
130 183
    cond
131 184
  }
132 185
@@ -141,56 +194,51 @@
Loading
141 194
  #' @noRd
142 195
  #' @param cond Condition object to throw. If it is an error condition,
143 196
  #'   then it calls [stop()].
144 -
  #' @param parent Parent condition. Use this within [rethrow()] and
145 -
  #'   [catch_rethrow()].
197 +
  #' @param parent Parent condition.
198 +
  #' @param frame The throwing context. Can be used to hide frames from
199 +
  #'   the backtrace.
146 200
147 -
  throw <- function(cond, parent = NULL) {
201 +
  throw <- throw_error <- function(cond, parent = NULL, frame = environment()) {
148 202
    if (!inherits(cond, "condition")) {
149 -
      throw(new_error("You can only throw conditions"))
203 +
      cond <- new_error(cond)
150 204
    }
151 205
    if (!is.null(parent) && !inherits(parent, "condition")) {
152 206
      throw(new_error("Parent condition must be a condition object"))
153 207
    }
154 208
155 209
    if (isTRUE(cond$call)) {
156 210
      cond$call <- sys.call(-1) %||% sys.call()
211 +
    } else if (identical(cond$call, FALSE)) {
212 +
      cond$call <- NULL
157 213
    }
158 214
159 -
    # Eventually the nframe numbers will help us print a better trace
160 -
    # When a child condition is created, the child will use the parent
161 -
    # error object to make note of its own nframe. Here we copy that back
162 -
    # to the parent.
163 -
    if (is.null(cond$`_nframe`)) cond$`_nframe` <- sys.nframe()
215 +
    cond <- process_call(cond)
216 +
164 217
    if (!is.null(parent)) {
165 -
      cond$parent <- parent
166 -
      cond$call <- cond$parent$`_childcall`
167 -
      cond$`_nframe` <- cond$parent$`_childframe`
168 -
      cond$`_ignore` <- cond$parent$`_childignore`
218 +
      cond$parent <- process_call(parent)
169 219
    }
170 220
171 221
    # We can set an option to always add the trace to the thrown
172 222
    # conditions. This is useful for example in context that always catch
173 223
    # errors, e.g. in testthat tests or knitr. This options is usually not
174 224
    # set and we signal the condition here
175 225
    always_trace <- isTRUE(getOption("rlib_error_always_trace"))
226 +
    .hide_from_trace <- 1L
227 +
    # .error_frame <- cond
176 228
    if (!always_trace) signalCondition(cond)
177 229
178 -
    # If this is not an error, then we'll just return here. This allows
179 -
    # throwing interrupt conditions for example, with the same UI.
180 -
    if (! inherits(cond, "error")) return(invisible())
181 -
182 230
    if (is.null(cond$`_pid`)) cond$`_pid` <- Sys.getpid()
183 231
    if (is.null(cond$`_timestamp`)) cond$`_timestamp` <- Sys.time()
184 232
185 233
    # If we get here that means that the condition was not caught by
186 234
    # an exiting handler. That means that we need to create a trace.
187 235
    # If there is a hand-constructed trace already in the error object,
188 236
    # then we'll just leave it there.
189 -
    if (is.null(cond$trace)) cond <- add_trace_back(cond)
237 +
    if (is.null(cond$trace)) cond <- add_trace_back(cond, frame = frame)
190 238
191 239
    # Set up environment to store .Last.error, it will be just before
192 240
    # baseenv(), so it is almost as if it was in baseenv() itself, like
193 -
    # .Last.value. We save the print methos here as well, and then they
241 +
    # .Last.value. We save the print methods here as well, and then they
194 242
    # will be found automatically.
195 243
    if (! "org:r-lib" %in% search()) {
196 244
      do.call("attach", list(new.env(), pos = length(search()),
@@ -203,155 +251,79 @@
Loading
203 251
    # If we always wanted a trace, then we signal the condition here
204 252
    if (always_trace) signalCondition(cond)
205 253
254 +
    # If this is not an error, then we'll just return here. This allows
255 +
    # throwing interrupt conditions for example, with the same UI.
256 +
    if (! inherits(cond, "error")) return(invisible())
257 +
    .hide_from_trace <- NULL
258 +
206 259
    # Top-level handler, this is intended for testing only for now,
207 260
    # and its design might change.
208 261
    if (!is.null(th <- getOption("rlib_error_handler")) &&
209 262
        is.function(th)) {
210 -
      th(cond)
211 -
212 -
    } else {
213 -
214 -
      if (is_interactive()) {
215 -
        # In interactive mode, we print the error message through
216 -
        # conditionMessage() and also add a note about .Last.error.trace.
217 -
        # R will potentially truncate the error message, so we make sure
218 -
        # that the note is shown. Ideally we would print the error
219 -
        # ourselves, but then RStudio would not highlight it.
220 -
        max_msg_len <- as.integer(getOption("warning.length"))
221 -
        if (is.na(max_msg_len)) max_msg_len <- 1000
222 -
        msg <- conditionMessage(cond)
223 -
        adv <- style_advice(
224 -
          "\nType .Last.error.trace to see where the error occurred"
225 -
        )
226 -
        dots <- "\033[0m\n[...]"
227 -
        if (bytes(msg) + bytes(adv) + bytes(dots) + 5L> max_msg_len) {
228 -
          msg <- paste0(
229 -
            substr(msg, 1, max_msg_len - bytes(dots) - bytes(adv) - 5L),
230 -
            dots
231 -
          )
232 -
        }
233 -
        cond$message <- paste0(msg, adv)
234 -
235 -
      } else {
236 -
        # In non-interactive mode, we print the error + the traceback
237 -
        # manually, to make sure that it won't be truncated by R's error
238 -
        # message length limit.
239 -
        cat("\n", file = stderr())
240 -
        cat(style_error(gettext("Error: ")), file = stderr())
241 -
        out <- capture_output(print(cond))
242 -
        cat(out, file = stderr(), sep = "\n")
243 -
        out <- capture_output(print(cond$trace))
244 -
        cat(out, file = stderr(), sep = "\n")
245 -
246 -
        # Turn off the regular error printing to avoid printing
247 -
        # the error twice.
248 -
        opts <- options(show.error.messages = FALSE)
249 -
        on.exit(options(opts), add = TRUE)
250 -
      }
251 -
252 -
      # Dropping the classes and adding "duplicate_condition" is a workaround
253 -
      # for the case when we have non-exiting handlers on throw()-n
254 -
      # conditions. These would get the condition twice, because stop()
255 -
      # will also signal it. If we drop the classes, then only handlers
256 -
      # on "condition" objects (i.e. all conditions) get duplicate signals.
257 -
      # This is probably quite rare, but for this rare case they can also
258 -
      # recognize the duplicates from the "duplicate_condition" extra class.
259 -
      class(cond) <- c("duplicate_condition", "condition")
260 -
261 -
      stop(cond)
263 +
      return(th(cond))
262 264
    }
263 -
  }
264 -
265 -
  # -- rethrowing conditions --------------------------------------------
266 265
267 -
  #' Catch and re-throw conditions
268 -
  #'
269 -
  #' See [rethrow()] for a simpler interface that handles `error`
270 -
  #' conditions automatically.
271 -
  #'
272 -
  #' @noRd
273 -
  #' @param expr Expression to evaluate.
274 -
  #' @param ... Condition handler specification, the same way as in
275 -
  #'   [withCallingHandlers()]. You are supposed to call [throw()] from
276 -
  #'   the error handler, with a new error object, setting the original
277 -
  #'   error object as parent. See examples below.
278 -
  #' @param call Logical flag, whether to add the call to
279 -
  #'   `catch_rethrow()` to the error.
280 -
  #' @examples
281 -
  #' f <- function() {
282 -
  #'   ...
283 -
  #'   err$catch_rethrow(
284 -
  #'     ... code that potentially errors ...,
285 -
  #'     error = function(e) {
286 -
  #'       throw(new_error("This will be the child error"), parent = e)
287 -
  #'     }
288 -
  #'   )
289 -
  #' }
290 -
291 -
  catch_rethrow <- function(expr, ..., call = TRUE) {
292 -
    realcall <- if (isTRUE(call)) sys.call(-1) %||% sys.call()
293 -
    realframe <- sys.nframe()
294 -
    parent <- parent.frame()
295 -
296 -
    cl <- match.call()
297 -
    cl[[1]] <- quote(withCallingHandlers)
298 -
    handlers <- list(...)
299 -
    for (h in names(handlers)) {
300 -
      cl[[h]] <- function(e) {
301 -
        # This will be NULL if the error is not throw()-n
302 -
        if (is.null(e$`_nframe`)) e$`_nframe` <- length(sys.calls())
303 -
        e$`_childcall` <- realcall
304 -
        e$`_childframe` <- realframe
305 -
        # We drop after realframe, until the first withCallingHandlers
306 -
        wch <- find_call(sys.calls(), quote(withCallingHandlers))
307 -
        if (!is.na(wch)) e$`_childignore` <- list(c(realframe + 1L, wch))
308 -
        handlers[[h]](e)
309 -
      }
310 -
    }
311 -
    eval(cl, envir = parent)
266 +
    # In non-interactive mode, we print the error + the traceback
267 +
    # manually, to make sure that it won't be truncated by R's error
268 +
    # message length limit.
269 +
    out <- format(
270 +
      cond,
271 +
      trace = !is_interactive(),
272 +
      class = FALSE,
273 +
      full = !is_interactive()
274 +
    )
275 +
    writeLines(out, con = default_output())
276 +
277 +
    # Dropping the classes and adding "duplicate_condition" is a workaround
278 +
    # for the case when we have non-exiting handlers on throw()-n
279 +
    # conditions. These would get the condition twice, because stop()
280 +
    # will also signal it. If we drop the classes, then only handlers
281 +
    # on "condition" objects (i.e. all conditions) get duplicate signals.
282 +
    # This is probably quite rare, but for this rare case they can also
283 +
    # recognize the duplicates from the "duplicate_condition" extra class.
284 +
    class(cond) <- c("duplicate_condition", "condition")
285 +
286 +
    # Turn off the regular error printing to avoid printing
287 +
    # the error twice.
288 +
    opts <- options(show.error.messages = FALSE)
289 +
    on.exit(options(opts), add = TRUE)
290 +
291 +
    stop(cond)
312 292
  }
313 293
314 -
  find_call <- function(calls, call) {
315 -
    which(vapply(
316 -
      calls, function(x) length(x) >= 1 && identical(x[[1]], call),
317 -
      logical(1)))[1]
318 -
  }
294 +
  # -- rethrow with parent -----------------------------------------------
319 295
320 -
  #' Catch and re-throw conditions
296 +
  #' Re-throw an error with a better error message
321 297
  #'
322 -
  #' `rethrow()` is similar to [catch_rethrow()], but it has a simpler
323 -
  #' interface. It catches conditions with class `error`, and re-throws
324 -
  #' `cond` instead, using the original condition as the parent.
298 +
  #' Evaluate `expr` and if it errors, then throw a new error `err`,
299 +
  #' with the original error set as its parent.
325 300
  #'
326 301
  #' @noRd
327 302
  #' @param expr Expression to evaluate.
328 -
  #' @param ... Condition handler specification, the same way as in
329 -
  #'   [withCallingHandlers()].
330 -
  #' @param call Logical flag, whether to add the call to
331 -
  #'   `rethrow()` to the error.
332 -
333 -
  rethrow <- function(expr, cond, call = TRUE) {
334 -
    realcall <- if (isTRUE(call)) sys.call(-1) %||% sys.call()
335 -
    realframe <- sys.nframe()
336 -
    withCallingHandlers(
337 -
      expr,
338 -
      error = function(e) {
339 -
        # This will be NULL if the error is not throw()-n
340 -
        if (is.null(e$`_nframe`)) e$`_nframe` <- length(sys.calls())
341 -
        e$`_childcall` <- realcall
342 -
        e$`_childframe` <- realframe
343 -
        # We just ignore the withCallingHandlers call, and the tail
344 -
        e$`_childignore` <- list(
345 -
          c(realframe + 1L, realframe + 1L),
346 -
          c(e$`_nframe` + 1L, sys.nframe() + 1L))
347 -
        throw(cond, parent = e)
303 +
  #' @param err Error object or message to use for the child error.
304 +
  #' @param call Call to use in the re-thrown error. See [throw()].
305 +
306 +
  chain_error <- function(expr, err, call = sys.call(-1)) {
307 +
    .hide_from_trace <- 1
308 +
    force(call)
309 +
    srcref <- utils::getSrcref(sys.call())
310 +
    withCallingHandlers({
311 +
      expr
312 +
    }, error = function(e) {
313 +
      .hide_from_trace <- 0:1
314 +
      e$srcref <- srcref
315 +
      if (!inherits(err, "condition")) {
316 +
        err <- new_error(err, call. = call)
348 317
      }
349 -
    )
318 +
      throw_error(err, parent = e)
319 +
    })
350 320
  }
351 321
322 +
  # -- rethrowing conditions from C code ---------------------------------
323 +
352 324
  #' Version of .Call that throw()s errors
353 325
  #'
354 -
  #' It re-throws error from interpreted code. If the error had class
326 +
  #' It re-throws error from compiled code. If the error had class
355 327
  #' `simpleError`, like all errors, thrown via `error()` in C do, it also
356 328
  #' adds the `c_error` class.
357 329
  #'
@@ -360,29 +332,31 @@
Loading
360 332
  #' @param ... Function arguments, see [.Call()].
361 333
  #' @return Result of the call.
362 334
363 -
  rethrow_call <- function(.NAME, ...) {
335 +
  chain_call <- function(.NAME, ...) {
336 +
    .hide_from_trace <- 1:3 # withCallingHandlers + do.call + .handleSimpleError (?)
364 337
    call <- sys.call()
365 -
    nframe <- sys.nframe()
338 +
    call1 <- sys.call(-1)
339 +
    srcref <- utils::getSrcref(call)
366 340
    withCallingHandlers(
367 -
      # do.call to work around an R CMD check issue
368 341
      do.call(".Call", list(.NAME, ...)),
369 342
      error = function(e) {
370 -
        e$`_nframe` <- nframe
343 +
        .hide_from_trace <- 0:1
344 +
        e$srcref <- srcref
371 345
        e$call <- call
372 -
        if (inherits(e, "simpleError")) {
373 -
          class(e) <- c("c_error", "rlib_error", "error", "condition")
374 -
        }
375 -
        e$`_ignore` <- list(c(nframe + 1L, sys.nframe() + 1L))
376 -
        throw(e)
346 +
        name <- native_name(.NAME)
347 +
        err <- new_error("Native call to `", name, "` failed", call. = call1)
348 +
        cerror <- if (inherits(e, "simpleError")) "c_error"
349 +
        class(err) <- c(cerror, "rlib_error_3_0", "rlib_error", "error", "condition")
350 +
        throw_error(err, parent = e)
377 351
      }
378 352
    )
379 353
  }
380 354
381 355
  package_env <- topenv()
382 356
383 -
  #' Version of rethrow_call that supports cleancall
357 +
  #' Version of entrace_call that supports cleancall
384 358
  #'
385 -
  #' This function is the same as [rethrow_call()], except that it
359 +
  #' This function is the same as [entrace_call()], except that it
386 360
  #' uses cleancall's [.Call()] wrapper, to enable resource cleanup.
387 361
  #' See https://github.com/r-lib/cleancall#readme for more about
388 362
  #' resource cleanup.
@@ -392,19 +366,22 @@
Loading
392 366
  #' @param ... Function arguments, see [.Call()].
393 367
  #' @return Result of the call.
394 368
395 -
  rethrow_call_with_cleanup <- function(.NAME, ...) {
369 +
  chain_clean_call <- function(.NAME, ...) {
370 +
    .hide_from_trace <- 1:3
396 371
    call <- sys.call()
397 -
    nframe <- sys.nframe()
372 +
    call1 <- sys.call(-1)
373 +
    srcref <- utils::getSrcref(call)
398 374
    withCallingHandlers(
399 375
      package_env$call_with_cleanup(.NAME, ...),
400 376
      error = function(e) {
401 -
        e$`_nframe` <- nframe
377 +
        .hide_from_trace <- 0:1
378 +
        e$srcref <- srcref
402 379
        e$call <- call
403 -
        if (inherits(e, "simpleError")) {
404 -
          class(e) <- c("c_error", "rlib_error", "error", "condition")
405 -
        }
406 -
        e$`_ignore` <- list(c(nframe + 1L, sys.nframe() + 1L))
407 -
        throw(e)
380 +
        name <- native_name(.NAME)
381 +
        err <- new_error("Native call to `", name, "` failed", call. = call1)
382 +
        cerror <- if (inherits(e, "simpleError")) "c_error"
383 +
        class(err) <- c(cerror, "rlib_error_3_0", "rlib_error", "error", "condition")
384 +
        throw_error(err, parent = e)
408 385
      }
409 386
    )
410 387
  }
@@ -417,74 +394,153 @@
Loading
417 394
  #' so there is currently not much use to call it directly.
418 395
  #'
419 396
  #' @param cond Condition to add the trace to
397 +
  #' @param frame Use this context to hide some frames from the traceback.
420 398
  #'
421 399
  #' @return A condition object, with the trace added.
422 400
423 -
  add_trace_back <- function(cond) {
401 +
  add_trace_back <- function(cond, frame = NULL) {
402 +
424 403
    idx <- seq_len(sys.parent(1L))
425 404
    frames <- sys.frames()[idx]
426 405
427 -
    parents <- sys.parents()[idx]
406 +
    # TODO: remove embedded objects from calls
428 407
    calls <- as.list(sys.calls()[idx])
429 -
    envs <- lapply(frames, env_label)
430 -
    topenvs <- lapply(
408 +
    parents <- sys.parents()[idx]
409 +
    namespaces <- unlist(lapply(
431 410
      seq_along(frames),
432 -
      function(i) env_label(topenvx(environment(sys.function(i)))))
433 -
    nframes <- if (!is.null(cond$`_nframe`)) cond$`_nframe` else sys.parent()
434 -
    messages <- list(conditionMessage(cond))
435 -
    ignore <- cond$`_ignore`
436 -
    classes <- class(cond)
437 -
    pids <- rep(cond$`_pid` %||% Sys.getpid(), length(calls))
438 -
439 -
    if (is.null(cond$parent)) {
440 -
      # Nothing to do, no parent
441 -
442 -
    } else if (is.null(cond$parent$trace) ||
443 -
               !inherits(cond$parent, "rlib_error")) {
444 -
      # If the parent does not have a trace, that means that it is using
445 -
      # the same trace as us. We ignore traces from non-r-lib errors.
446 -
      # E.g. rlang errors have a trace, but we do not use that.
447 -
      parent <- cond
448 -
      while (!is.null(parent <- parent$parent)) {
449 -
        nframes <- c(nframes, parent$`_nframe`)
450 -
        messages <- c(messages, list(conditionMessage(parent)))
451 -
        ignore <- c(ignore, parent$`_ignore`)
411 +
      function(i) {
412 +
        env_label(topenvx(environment(sys.function(i))))
452 413
      }
414 +
    ))
415 +
    pids <- rep(cond$`_pid` %||% Sys.getpid(), length(calls))
453 416
417 +
    mch <- match(format(frame), sapply(frames, format))
418 +
    if (is.na(mch)) {
419 +
      visibles <- TRUE
454 420
    } else {
455 -
      # If it has a trace, that means that it is coming from another
456 -
      # process or top level evaluation. In this case we'll merge the two
457 -
      # traces.
458 -
      pt <- cond$parent$trace
459 -
      parents <- c(parents, pt$parents + length(calls))
460 -
      nframes <- c(nframes, pt$nframes + length(calls))
461 -
      ignore <- c(ignore, lapply(pt$ignore, function(x) x + length(calls)))
462 -
      envs <- c(envs, pt$envs)
463 -
      topenvs <- c(topenvs, pt$topenvs)
464 -
      calls <- c(calls, pt$calls)
465 -
      messages <- c(messages, pt$messages)
466 -
      pids <- c(pids, pt$pids)
421 +
      visibles <- c(rep(TRUE, mch), rep(FALSE, length(frames) - mch))
467 422
    }
468 423
424 +
    scopes <- vapply(idx, FUN.VALUE = character(1), function(i) {
425 +
      tryCatch(
426 +
        get_call_scope(calls[[i]], namespaces[[i]]),
427 +
        error = function(e) ""
428 +
      )
429 +
    })
430 +
431 +
    namespaces <- ifelse(scopes %in% c("::", ":::"), namespaces, NA_character_)
432 +
    funs <- ifelse(
433 +
      is.na(namespaces),
434 +
      ifelse(scopes != "", paste0(scopes, " "), ""),
435 +
      paste0(namespaces, scopes)
436 +
    )
437 +
    funs <- paste0(
438 +
      funs,
439 +
      vapply(calls, function(x) format_name(x[[1]])[1], character(1))
440 +
    )
441 +
    visibles <- visibles & mark_invisible_frames(funs, frames)
442 +
443 +
    pcs <- lapply(calls, function(c) process_call(list(call = c)))
444 +
    calls <- lapply(pcs, "[[", "call")
445 +
    srcrefs <- I(lapply(pcs, "[[", "srcref"))
446 +
469 447
    cond$trace <- new_trace(
470 -
      calls, parents, envs, topenvs, nframes, messages, ignore, classes,
471 -
      pids)
448 +
      calls,
449 +
      parents,
450 +
      visibles = visibles,
451 +
      namespaces = namespaces,
452 +
      scopes = scopes,
453 +
      srcrefs = srcrefs,
454 +
      pids
455 +
    )
472 456
473 457
    cond
474 458
  }
475 459
460 +
  mark_invisible_frames <- function(funs, frames) {
461 +
    visibles <- rep(TRUE, length(frames))
462 +
    hide <- lapply(frames, "[[", ".hide_from_trace")
463 +
    w_hide <- unlist(mapply(seq_along(hide), hide, FUN = function(i, w) {
464 +
      i + w
465 +
    }, SIMPLIFY = FALSE))
466 +
    w_hide <- w_hide[w_hide <= length(frames)]
467 +
    visibles[w_hide] <- FALSE
468 +
469 +
    hide_from <- which(funs %in% names(invisible_frames))
470 +
    for (start in hide_from) {
471 +
      hide_this <- invisible_frames[[ funs[start] ]]
472 +
      for (i in seq_along(hide_this)) {
473 +
        if (start + i > length(funs)) break
474 +
        if (funs[start + i] != hide_this[i]) break
475 +
        visibles[start + i] <- FALSE
476 +
      }
477 +
    }
478 +
479 +
    visibles
480 +
  }
481 +
482 +
  invisible_frames <- list(
483 +
    "base::source" = c("base::withVisible", "base::eval", "base::eval"),
484 +
    "base::stop" = "base::.handleSimpleError",
485 +
    "cli::cli_abort" = c(
486 +
      "rlang::abort",
487 +
      "rlang:::signal_abort",
488 +
      "base::signalCondition"),
489 +
    "rlang::abort" = c("rlang:::signal_abort", "base::signalCondition")
490 +
  )
491 +
492 +
  call_name <- function(x) {
493 +
    if (is.call(x)) {
494 +
      if (is.symbol(x[[1]])) {
495 +
        as.character(x[[1]])
496 +
      } else if (x[[1]][[1]] == quote(`::`) || x[[1]][[1]] == quote(`:::`)) {
497 +
        as.character(x[[1]][[2]])
498 +
      } else {
499 +
        NULL
500 +
      }
501 +
    } else {
502 +
      NULL
503 +
    }
504 +
  }
505 +
506 +
  get_call_scope <- function(call, ns) {
507 +
    if (is.na(ns)) return("global")
508 +
    if (!is.call(call)) return("")
509 +
    if (is.call(call[[1]]) &&
510 +
        (call[[1]][[1]] == quote(`::`) || call[[1]][[1]] == quote(`:::`))) return("")
511 +
    if (ns == "base") return("::")
512 +
    if (! ns %in% loadedNamespaces()) return("")
513 +
    name <- call_name(call)
514 +
    nsenv <- asNamespace(ns)$.__NAMESPACE__.
515 +
    if (is.null(nsenv)) return("::")
516 +
    if (is.null(nsenv$exports)) return(":::")
517 +
    if (exists(name, envir = nsenv$exports, inherits = FALSE)) {
518 +
      "::"
519 +
    } else if (exists(name, envir = asNamespace(ns), inherits = FALSE)) {
520 +
      ":::"
521 +
    } else {
522 +
      "local"
523 +
    }
524 +
  }
525 +
476 526
  topenvx <- function(x) {
477 527
    topenv(x, matchThisEnv = err_env)
478 528
  }
479 529
480 -
  new_trace <- function (calls, parents, envs, topenvs, nframes, messages,
481 -
                         ignore, classes, pids) {
482 -
    indices <- seq_along(calls)
483 -
    structure(
484 -
      list(calls = calls, parents = parents, envs = envs, topenvs = topenvs,
485 -
           indices = indices, nframes = nframes, messages = messages,
486 -
           ignore = ignore, classes = classes, pids = pids),
487 -
      class = "rlib_trace")
530 +
  new_trace <- function (calls, parents, visibles, namespaces, scopes, srcrefs, pids) {
531 +
    trace <- data.frame(
532 +
      stringsAsFactors = FALSE,
533 +
      parent = parents,
534 +
      visible = visibles,
535 +
      namespace = namespaces,
536 +
      scope = scopes,
537 +
      srcref = srcrefs,
538 +
      pid = pids
539 +
    )
540 +
    trace$call <- calls
541 +
542 +
    class(trace) <- c("rlib_trace_3_0", "rlib_trace", "tbl", "data.frame")
543 +
    trace
488 544
  }
489 545
490 546
  env_label <- function(env) {
@@ -503,270 +559,571 @@
Loading
503 559
504 560
  env_name <- function(env) {
505 561
    if (identical(env, err_env)) {
506 -
      return("")
562 +
      return(env_name(package_env))
507 563
    }
508 564
    if (identical(env, globalenv())) {
509 -
      return("global")
565 +
      return(NA_character_)
510 566
    }
511 567
    if (identical(env, baseenv())) {
512 -
      return("namespace:base")
568 +
      return("base")
513 569
    }
514 570
    if (identical(env, emptyenv())) {
515 571
      return("empty")
516 572
    }
517 573
    nm <- environmentName(env)
518 574
    if (isNamespace(env)) {
519 -
      return(paste0("namespace:", nm))
575 +
      return(nm)
520 576
    }
521 577
    nm
522 578
  }
523 579
524 -
  # -- printing ---------------------------------------------------------
580 +
  # -- S3 methods -------------------------------------------------------
525 581
526 -
  print_this <- function(x, ...) {
527 -
    msg <- conditionMessage(x)
528 -
    call <- conditionCall(x)
529 -
    cl <- class(x)[1L]
530 -
    if (!is.null(call)) {
531 -
      cat("<", cl, " in ", format_call(call), ":\n ", msg, ">\n", sep = "")
582 +
  format_error <- function(x, trace = FALSE, class = FALSE,
583 +
                           advice = !trace, full = trace, header = TRUE,
584 +
                           ...) {
585 +
    if (has_cli()) {
586 +
      format_error_cli(x, trace, class, advice, full, header, ...)
532 587
    } else {
533 -
      cat("<", cl, ": ", msg, ">\n", sep = "")
588 +
      format_error_plain(x, trace, class, advice, full, header, ...)
534 589
    }
590 +
  }
535 591
536 -
    print_srcref(x$call)
592 +
  print_error <- function(x, trace = TRUE, class = TRUE,
593 +
                          advice = !trace,  ...) {
594 +
    writeLines(format_error(x, trace, class, advice, ...))
595 +
  }
537 596
538 -
    if (!identical(x$`_pid`, Sys.getpid())) {
539 -
      cat(" in process", x$`_pid`, "\n")
597 +
  format_trace <- function(x, ...) {
598 +
    if (has_cli()) {
599 +
      format_trace_cli(x, ...)
600 +
    } else {
601 +
      format_trace_plain(x, ...)
540 602
    }
603 +
  }
541 604
542 -
    invisible(x)
605 +
  print_trace <- function(x, ...) {
606 +
    writeLines(format_trace(x, ...))
543 607
  }
544 608
545 -
  print_parents <- function(x, ...) {
546 -
    if (!is.null(x$parent)) {
547 -
      cat("-->\n")
548 -
      print(x$parent)
549 -
    }
550 -
    invisible(x)
609 +
  cnd_message <- function(cond) {
610 +
    paste(cnd_message_(cond, full = FALSE), collapse = "\n")
551 611
  }
552 612
553 -
  print_rlib_error <- function(x, ...) {
554 -
    print_this(x, ...)
555 -
    print_parents(x, ...)
613 +
  cnd_message_ <- function(cond, full = FALSE) {
614 +
    if (has_cli()) {
615 +
      cnd_message_cli(cond, full)
616 +
    } else {
617 +
      cnd_message_plain(cond, full)
618 +
    }
556 619
  }
557 620
558 -
  print_rlib_trace <- function(x, ...) {
559 -
    cl <- paste0(" Stack trace:")
560 -
    cat(sep = "", "\n", style_trace_title(cl), "\n\n")
561 -
    calls <- map2(x$calls, x$topenv, namespace_calls)
562 -
    callstr <- vapply(calls, format_call_src, character(1))
563 -
    callstr[x$nframes] <-
564 -
      paste0(callstr[x$nframes], "\n", style_error_msg(x$messages), "\n")
565 -
    callstr <- enumerate(callstr)
621 +
  # -- format API -------------------------------------------------------
566 622
567 -
    # Ignore what we were told to ignore
568 -
    ign <- integer()
569 -
    for (iv in x$ignore) {
570 -
      if (iv[2] == Inf) iv[2] <- length(callstr)
571 -
      ign <- c(ign, iv[1]:iv[2])
623 +
  format_advice <- function(x) {
624 +
    if (has_cli()) {
625 +
      format_advice_cli(x)
626 +
    } else {
627 +
      format_advice_plain(x)
572 628
    }
629 +
  }
573 630
574 -
    # Plus always ignore the tail. This is not always good for
575 -
    # catch_rethrow(), but should be good otherwise
576 -
    last_err_frame <- x$nframes[length(x$nframes)]
577 -
    if (!is.na(last_err_frame) && last_err_frame < length(callstr)) {
578 -
      ign <- c(ign, (last_err_frame+1):length(callstr))
631 +
  format_call <- function(call) {
632 +
    if (has_cli()) {
633 +
      format_call_cli(call)
634 +
    } else {
635 +
      format_call_plain(call)
579 636
    }
637 +
  }
580 638
581 -
    ign <- unique(ign)
582 -
    if (length(ign)) callstr <- callstr[-ign]
639 +
  format_class <- function(x) {
640 +
    if (has_cli()) {
641 +
      format_class_cli(x)
642 +
    } else {
643 +
      format_class_plain(x)
644 +
    }
645 +
  }
583 646
584 -
    # Add markers for subprocesses
585 -
    if (length(unique(x$pids)) >= 2) {
586 -
      pids <- x$pids[-ign]
587 -
      pid_add <- which(!duplicated(pids))
588 -
      pid_str <- style_process(paste0("Process ", pids[pid_add], ":"))
589 -
      callstr[pid_add] <- paste0(" ", pid_str, "\n", callstr[pid_add])
647 +
  format_error_heading <- function(x, prefix = NULL) {
648 +
    if (has_cli()) {
649 +
      format_error_heading_cli(x, prefix)
650 +
    } else {
651 +
      format_error_heading_plain(x, prefix)
590 652
    }
653 +
  }
591 654
592 -
    cat(callstr, sep = "\n")
593 -
    invisible(x)
655 +
  format_header_line <- function(x, prefix = NULL) {
656 +
    if (has_cli()) {
657 +
      format_header_line_cli(x, prefix)
658 +
    } else {
659 +
      format_header_line_plain(x, prefix)
660 +
    }
594 661
  }
595 662
596 -
  capture_output <- function(expr) {
663 +
  format_srcref <- function(call, srcref = NULL) {
597 664
    if (has_cli()) {
598 -
      opts <- options(cli.num_colors = cli::num_ansi_colors())
599 -
      on.exit(options(opts), add = TRUE)
665 +
      format_srcref_cli(call, srcref)
666 +
    } else {
667 +
      format_srcref_plain(call, srcref)
668 +
    }
669 +
  }
670 +
671 +
  # -- condition message with cli ---------------------------------------
672 +
673 +
  cnd_message_cli <- function(cond, full = FALSE) {
674 +
    exp <- paste0(cli::col_yellow("!"), " ")
675 +
    add_exp <- is.null(names(cond$message))
676 +
677 +
    c(
678 +
      paste0(if (add_exp) exp, cond$message),
679 +
      if (inherits(cond$parent, "condition")) {
680 +
        msg <- if (full && inherits(cond$parent, "rlib_error_3_0")) {
681 +
          format(cond$parent,
682 +
                 trace = FALSE,
683 +
                 full = TRUE,
684 +
                 class = FALSE,
685 +
                 header = FALSE,
686 +
                 advice = FALSE
687 +
          )
688 +
        } else {
689 +
          conditionMessage(cond$parent)
690 +
        }
691 +
        add_exp <- substr(cli::ansi_strip(msg[1]), 1, 1) != "!"
692 +
        if (add_exp) msg[1] <- paste0(exp, msg[1])
693 +
        c(format_header_line_cli(cond$parent, prefix = "Caused by error"),
694 +
          msg
695 +
        )
696 +
      }
697 +
    )
698 +
  }
699 +
700 +
  # -- condition message w/o cli ----------------------------------------
701 +
702 +
  cnd_message_plain <- function(cond, full = FALSE) {
703 +
    exp <- "! "
704 +
    add_exp <- is.null(names(cond$message))
705 +
    c(
706 +
      paste0(if (add_exp) exp, cond$message),
707 +
      if (inherits(cond$parent, "condition")) {
708 +
        msg <- if (full && inherits(cond$parent, "rlib_error_3_0")) {
709 +
          format(cond$parent,
710 +
                 trace = FALSE,
711 +
                 full = TRUE,
712 +
                 class = FALSE,
713 +
                 header = FALSE,
714 +
                 advice = FALSE
715 +
          )
716 +
        } else {
717 +
          conditionMessage(cond$parent)
718 +
        }
719 +
        add_exp <- substr(msg[1], 1, 1) != "!"
720 +
        if (add_exp) {
721 +
          msg[1] <- paste0(exp, msg[1])
722 +
        }
723 +
        c(format_header_line_plain(cond$parent, prefix = "Caused by error"),
724 +
          msg
725 +
        )
726 +
      }
727 +
    )
728 +
  }
729 +
730 +
  # -- printing error with cli ------------------------------------------
731 +
732 +
  # Error parts:
733 +
  # - "Error:" or "Error in " prefix, the latter if the error has a call
734 +
  # - the call, possibly syntax highlightedm possibly trimmed (?)
735 +
  # - source ref, with link to the file, potentially in a new line in cli
736 +
  # - error message, just `conditionMessage()`
737 +
  # - advice about .Last.error and/or .Last.error.trace
738 +
739 +
  format_error_cli <- function(x, trace = TRUE, class = TRUE,
740 +
                               advice = !trace, full = trace,
741 +
                               header = TRUE, ...) {
742 +
    p_class <- if (class) format_class_cli(x)
743 +
    p_header <- if (header) format_header_line_cli(x)
744 +
    p_msg <- cnd_message_cli(x, full)
745 +
    p_advice <- if (advice) format_advice_cli(x) else NULL
746 +
    p_trace <- if (trace && !is.null(x$trace)) {
747 +
      c("---", "Backtrace:", format_trace_cli(x$trace))
600 748
    }
601 749
602 -
    out <- NULL
603 -
    file <- textConnection("out", "w", local = TRUE)
604 -
    sink(file)
605 -
    on.exit(sink(NULL), add = TRUE)
750 +
    c(p_class,
751 +
      p_header,
752 +
      p_msg,
753 +
      p_advice,
754 +
      p_trace)
755 +
  }
606 756
607 -
    expr
608 -
    if (is.null(out)) invisible(NULL) else out
757 +
  format_header_line_cli <- function(x, prefix = NULL) {
758 +
    p_error <- format_error_heading_cli(x, prefix)
759 +
    p_call <- format_call_cli(x$call)
760 +
    p_srcref <- format_srcref_cli(conditionCall(x), x$srcref)
761 +
    paste0(p_error, p_call, p_srcref, if (!is.null(conditionCall(x))) ":")
609 762
  }
610 763
611 -
  is_interactive <- function() {
612 -
    opt <- getOption("rlib_interactive")
613 -
    if (isTRUE(opt)) {
614 -
      TRUE
615 -
    } else if (identical(opt, FALSE)) {
616 -
      FALSE
617 -
    } else if (tolower(getOption("knitr.in.progress", "false")) == "true") {
618 -
      FALSE
619 -
    } else if (tolower(getOption("rstudio.notebook.executing", "false")) == "true") {
620 -
      FALSE
621 -
    } else if (identical(Sys.getenv("TESTTHAT"), "true")) {
622 -
      FALSE
764 +
  format_class_cli <- function(x) {
765 +
    cls <- unique(setdiff(class(x), "condition"))
766 +
    cls # silence codetools
767 +
    cli::format_inline("{.cls {cls}}")
768 +
  }
769 +
770 +
  format_error_heading_cli <- function(x, prefix = NULL) {
771 +
    str_error <- if (is.null(prefix)) {
772 +
      cli::style_bold(cli::col_yellow("Error"))
623 773
    } else {
624 -
      interactive()
774 +
      cli::style_bold(paste0(prefix))
775 +
    }
776 +
    if (is.null(conditionCall(x))) {
777 +
      paste0(str_error, ": ")
778 +
    } else {
779 +
      paste0(str_error, " in ")
625 780
    }
626 781
  }
627 782
628 -
  onload_hook <- function() {
629 -
    reg_env <- Sys.getenv("R_LIB_ERROR_REGISTER_PRINT_METHODS", "TRUE")
630 -
    if (tolower(reg_env) != "false") {
631 -
      registerS3method("print", "rlib_error", print_rlib_error, baseenv())
632 -
      registerS3method("print", "rlib_trace", print_rlib_trace, baseenv())
783 +
  format_call_cli <- function(call) {
784 +
    if (is.null(call)) {
785 +
      NULL
786 +
    } else {
787 +
      cl <- trimws(format(call))
788 +
      if (length(cl) > 1) cl <- paste0(cl[1], " ", cli::symbol$ellipsis)
789 +
      cli::format_inline("{.code {cl}}")
633 790
    }
634 791
  }
635 792
636 -
  namespace_calls <- function(call, env) {
637 -
    if (length(call) < 1) return(call)
638 -
    if (typeof(call[[1]]) != "symbol") return(call)
639 -
    pkg <- strsplit(env, "^namespace:")[[1]][2]
640 -
    if (is.na(pkg)) return(call)
641 -
    call[[1]] <- substitute(p:::f, list(p = as.symbol(pkg), f = call[[1]]))
642 -
    call
793 +
  format_srcref_cli <- function(call, srcref = NULL) {
794 +
    ref <- get_srcref(call, srcref)
795 +
    if (is.null(ref)) return("")
796 +
797 +
    link <- if (ref$file != "") {
798 +
      cli::style_hyperlink(
799 +
        cli::format_inline("{basename(ref$file)}:{ref$line}:{ref$col}"),
800 +
        paste0("file://", ref$file),
801 +
        params = c(line = ref$line, col = ref$col)
802 +
      )
803 +
804 +
    } else {
805 +
      paste0("line ", ref$line)
806 +
    }
807 +
808 +
    cli::col_silver(paste0(" at ", link))
643 809
  }
644 810
645 -
  print_srcref <- function(call) {
646 -
    src <- format_srcref(call)
647 -
    if (length(src)) cat(sep = "", " ", src, "\n")
811 +
  str_advice <- "Type .Last.error to see the more details."
812 +
813 +
  format_advice_cli <- function(x) {
814 +
    cli::col_silver(str_advice)
648 815
  }
649 816
650 -
  `%||%` <- function(l, r) if (is.null(l)) r else l
817 +
  format_trace_cli <- function(x, ...) {
818 +
    x$num <- seq_len(nrow(x))
651 819
652 -
  format_srcref <- function(call) {
653 -
    if (is.null(call)) return(NULL)
654 -
    file <- utils::getSrcFilename(call)
655 -
    if (!length(file)) return(NULL)
656 -
    dir <- utils::getSrcDirectory(call)
657 -
    if (length(dir) && nzchar(dir) && nzchar(file)) {
658 -
      srcfile <- attr(utils::getSrcref(call), "srcfile")
659 -
      if (isTRUE(srcfile$isFile)) {
660 -
        file <- file.path(dir, file)
661 -
      } else {
662 -
        file <- file.path("R", file)
663 -
      }
820 +
    scope <- ifelse(
821 +
      is.na(x$namespace),
822 +
      ifelse(x$scope != "", paste0(x$scope, " "), ""),
823 +
      paste0(x$namespace, x$scope)
824 +
    )
825 +
826 +
    visible <- if ("visible" %in% names(x)) {
827 +
      x$visible
664 828
    } else {
665 -
      file <- "??"
829 +
      rep(TRUE, nrow(x))
830 +
    }
831 +
832 +
    srcref <- if ("srcref" %in% names(x)) {
833 +
      vapply(
834 +
        seq_len(nrow(x)),
835 +
        function(i) format_srcref_cli(x$call[[i]], x$srcref[[i]]),
836 +
        character(1)
837 +
      )
838 +
    } else {
839 +
      unname(vapply(x$call, format_srcref_cli, character(1)))
840 +
    }
841 +
842 +
    lines <- paste0(
843 +
      cli::col_silver(format(x$num), ". "),
844 +
      ifelse (visible, "", "| "),
845 +
      scope,
846 +
      vapply(x$call, format_trace_call_cli, character(1)),
847 +
      srcref
848 +
    )
849 +
850 +
    lines[!visible] <- cli::col_silver(cli::ansi_strip(
851 +
      lines[!visible],
852 +
      link = FALSE
853 +
    ))
854 +
855 +
    lines
856 +
  }
857 +
858 +
  format_trace_call_cli <- function(call) {
859 +
    cl <- trimws(format(call))
860 +
    if (length(cl) > 1) { cl <- paste0(cl[1], " ", cli::symbol$ellipsis) }
861 +
    fmc <- cli::code_highlight(cl)[1]
862 +
    cli::ansi_strtrim(fmc, cli::console_width() - 5)
863 +
  }
864 +
865 +
  # ----------------------------------------------------------------------
866 +
867 +
  format_error_plain <- function(x, trace = TRUE, class = TRUE,
868 +
                                 advice = !trace, full = trace, header = TRUE,
869 +
                                 ...) {
870 +
    p_class <- if (class) format_class_plain(x)
871 +
    p_header <- if (header) format_header_line_plain(x)
872 +
    p_msg <- cnd_message_plain(x, full)
873 +
    p_advice <- if (advice) format_advice_plain(x) else NULL
874 +
    p_trace <- if (trace && !is.null(x$trace)) {
875 +
      c("---", "Backtrace:", format_trace_plain(x$trace))
666 876
    }
667 -
    line <- utils::getSrcLocation(call) %||% "??"
668 -
    col <- utils::getSrcLocation(call, which = "column") %||% "??"
669 -
    style_srcref(paste0(file, ":", line, ":", col))
877 +
878 +
    c(p_class,
879 +
      p_header,
880 +
      p_msg,
881 +
      p_advice,
882 +
      p_trace)
670 883
  }
671 884
672 -
  format_call <- function(call) {
673 -
    width <- getOption("width")
674 -
    str <- format(call)
675 -
    callstr <- if (length(str) > 1 || nchar(str[1]) > width) {
676 -
      paste0(substr(str[1], 1, width - 5), " ...")
885 +
  format_trace_plain <- function(x, ...) {
886 +
    x$num <- seq_len(nrow(x))
887 +
888 +
    scope <- ifelse(
889 +
      is.na(x$namespace),
890 +
      ifelse(x$scope != "", paste0(x$scope, " "), ""),
891 +
      paste0(x$namespace, x$scope)
892 +
    )
893 +
894 +
    visible <- if ("visible" %in% names(x)) {
895 +
      x$visible
896 +
    } else {
897 +
      rep(TRUE, nrow(x))
898 +
    }
899 +
900 +
    srcref <- if ("srcref" %in% names(x)) {
901 +
      vapply(
902 +
        seq_len(nrow(x)),
903 +
        function(i) format_srcref_plain(x$call[[i]], x$srcref[[i]]),
904 +
        character(1)
905 +
      )
677 906
    } else {
678 -
      str[1]
907 +
      unname(vapply(x$call, format_srcref_plain, character(1)))
908 +
    }
909 +
910 +
    lines <- paste0(
911 +
      paste0(format(x$num), ". "),
912 +
      ifelse (visible, "", "| "),
913 +
      scope,
914 +
      vapply(x$call, format_trace_call_plain, character(1)),
915 +
      srcref
916 +
    )
917 +
918 +
    lines
919 +
  }
920 +
921 +
  format_advice_plain <- function(x, ...) {
922 +
    str_advice
923 +
  }
924 +
925 +
  format_header_line_plain <- function(x, prefix = NULL) {
926 +
    p_error <- format_error_heading_plain(x, prefix)
927 +
    p_call <- format_call_plain(x$call)
928 +
    p_srcref <- format_srcref_plain(conditionCall(x), x$srcref)
929 +
    paste0(p_error, p_call, p_srcref, if (!is.null(conditionCall(x))) ":")
930 +
  }
931 +
932 +
  format_error_heading_plain <- function(x, prefix = NULL) {
933 +
    str_error <- if (is.null(prefix)) "Error" else prefix
934 +
    if (is.null(conditionCall(x))) {
935 +
      paste0(str_error, ": ")
936 +
    } else {
937 +
      paste0(str_error, " in ")
938 +
    }
939 +
  }
940 +
941 +
  format_class_plain <- function(x) {
942 +
    cls <- unique(setdiff(class(x), "condition"))
943 +
    paste0("<", paste(cls, collapse = "/"), ">")
944 +
  }
945 +
946 +
  format_call_plain <- function(call) {
947 +
    if (is.null(call)) {
948 +
      NULL
949 +
    } else {
950 +
      cl <- trimws(format(call))
951 +
      if (length(cl) > 1) cl <- paste0(cl[1], " ...")
952 +
      paste0("`", cl, "`")
679 953
    }
680 -
    style_call(callstr)
681 954
  }
682 955
683 -
  format_call_src <- function(call) {
684 -
    callstr <- format_call(call)
685 -
    src <- format_srcref(call)
686 -
    if (length(src)) callstr <- paste0(callstr, "\n    ", src)
687 -
    callstr
956 +
  format_srcref_plain <- function(call, srcref = NULL) {
957 +
    ref <- get_srcref(call, srcref)
958 +
    if (is.null(ref)) return("")
959 +
960 +
    link <- if (ref$file != "") {
961 +
      paste0(basename(ref$file), ":", ref$line, ":", ref$col)
962 +
    } else {
963 +
      paste0("line ", ref$line)
964 +
    }
965 +
966 +
    paste0(" at ", link)
688 967
  }
689 968
690 -
  enumerate <- function(x) {
691 -
    paste0(style_numbers(paste0(" ", seq_along(x), ". ")), x)
969 +
  format_trace_call_plain <- function(call) {
970 +
    fmc <- trimws(format(call)[1])
971 +
    if (length(fmc) > 1) { fmc <- paste0(fmc[1], " ...") }
972 +
    strtrim(fmc, getOption("width") - 5)
692 973
  }
693 974
694 -
  map2 <- function (.x, .y, .f, ...) {
695 -
    mapply(.f, .x, .y, MoreArgs = list(...), SIMPLIFY = FALSE,
696 -
           USE.NAMES = FALSE)
975 +
  # -- utilities ---------------------------------------------------------
976 +
977 +
  cli_version <- function() {
978 +
    # this loads cli!
979 +
    package_version(asNamespace("cli")[[".__NAMESPACE__."]]$spec[["version"]])
697 980
  }
698 981
982 +
  has_cli <- function() {
983 +
    "cli" %in% loadedNamespaces() && cli_version() >= "3.3.0"
984 +
  }
985 +
986 +
  `%||%` <- function(l, r) if (is.null(l)) r else l
987 +
699 988
  bytes <- function(x) {
700 989
    nchar(x, type = "bytes")
701 990
  }
702 991
703 -
  # -- printing, styles -------------------------------------------------
704 -
705 -
  has_cli <- function() "cli" %in% loadedNamespaces()
992 +
  process_call <- function(cond) {
993 +
    cond[c("call", "srcref")] <- list(
994 +
      call = if (is.null(cond$call)) {
995 +
        NULL
996 +
      } else if (is.character(cond$call)) {
997 +
        cond$call
998 +
      } else {
999 +
        deparse(cond$call, nlines = 2)
1000 +
      },
1001 +
      srcref = get_srcref(cond$call, cond$srcref)
1002 +
    )
1003 +
    cond
1004 +
  }
706 1005
707 -
  style_numbers <- function(x) {
708 -
    if (has_cli()) cli::col_silver(x) else x
1006 +
  get_srcref <- function(call, srcref = NULL) {
1007 +
    ref <- srcref %||% utils::getSrcref(call)
1008 +
    if (is.null(ref)) return(NULL)
1009 +
    if (inherits(ref, "processed_srcref")) return(ref)
1010 +
    file <- utils::getSrcFilename(ref, full.names = TRUE)[1]
1011 +
    if (is.na(file)) file <- ""
1012 +
    line <- utils::getSrcLocation(ref) %||% ""
1013 +
    col <- utils::getSrcLocation(ref, which = "column") %||% ""
1014 +
    structure(
1015 +
      list(file = file, line = line, col = col),
1016 +
      class = "processed_srcref"
1017 +
    )
709 1018
  }
710 1019
711 -
  style_advice <- function(x) {
712 -
    if (has_cli()) cli::col_silver(x) else x
1020 +
  is_interactive <- function() {
1021 +
    opt <- getOption("rlib_interactive")
1022 +
    if (isTRUE(opt)) {
1023 +
      TRUE
1024 +
    } else if (identical(opt, FALSE)) {
1025 +
      FALSE
1026 +
    } else if (tolower(getOption("knitr.in.progress", "false")) == "true") {
1027 +
      FALSE
1028 +
    } else if (tolower(getOption("rstudio.notebook.executing", "false")) == "true") {
1029 +
      FALSE
1030 +
    } else if (identical(Sys.getenv("TESTTHAT"), "true")) {
1031 +
      FALSE
1032 +
    } else {
1033 +
      interactive()
1034 +
    }
713 1035
  }
714 1036
715 -
  style_srcref <- function(x) {
716 -
    if (has_cli()) cli::style_italic(cli::col_cyan(x))
1037 +
  no_sink <- function() {
1038 +
    sink.number() == 0 && sink.number("message") == 2
717 1039
  }
718 1040
719 -
  style_error <- function(x) {
720 -
    if (has_cli()) cli::style_bold(cli::col_red(x)) else x
1041 +
  rstudio_stdout <- function() {
1042 +
    rstudio <- rstudio_detect()
1043 +
    rstudio$type %in% c(
1044 +
      "rstudio_console",
1045 +
      "rstudio_console_starting",
1046 +
      "rstudio_build_pane",
1047 +
      "rstudio_job",
1048 +
      "rstudio_render_pane"
1049 +
    )
721 1050
  }
722 1051
723 -
  style_error_msg <- function(x) {
724 -
    sx <- paste0("\n x ", x, " ")
725 -
    style_error(sx)
1052 +
  default_output <- function() {
1053 +
    if ((is_interactive() || rstudio_stdout()) && no_sink()) {
1054 +
      stdout()
1055 +
    } else {
1056 +
      stderr()
1057 +
    }
726 1058
  }
727 1059
728 -
  style_trace_title <- function(x) {
729 -
    x
1060 +
  onload_hook <- function() {
1061 +
    reg_env <- Sys.getenv("R_LIB_ERROR_REGISTER_PRINT_METHODS", "TRUE")
1062 +
    if (tolower(reg_env) != "false") {
1063 +
      registerS3method("format", "rlib_error_3_0", format_error, baseenv())
1064 +
      registerS3method("format", "rlib_trace_3_0", format_trace, baseenv())
1065 +
      registerS3method("print", "rlib_error_3_0", print_error, baseenv())
1066 +
      registerS3method("print", "rlib_trace_3_0", print_trace, baseenv())
1067 +
      registerS3method("conditionMessage", "rlib_error_3_0", cnd_message, baseenv())
1068 +
    }
730 1069
  }
731 1070
732 -
  style_process <- function(x) {
733 -
    if (has_cli()) cli::style_bold(x) else x
1071 +
  native_name <- function(x) {
1072 +
    if (inherits(x, "NativeSymbolInfo")) {
1073 +
      x$name
1074 +
    } else {
1075 +
      format(x)
1076 +
    }
734 1077
  }
735 1078
736 -
  style_call <- function(x) {
737 -
    if (!has_cli()) return(x)
738 -
    call <- sub("^([^(]+)[(].*$", "\\1", x)
739 -
    rest <- sub("^[^(]+([(].*)$", "\\1", x)
740 -
    if (call == x || rest == x) return(x)
741 -
    paste0(cli::col_yellow(call), rest)
1079 +
  # There is no format() for 'name' in R 3.6.x and before
1080 +
  format_name <- function(x) {
1081 +
    if (is.name(x)) {
1082 +
      as.character(x)
1083 +
    } else {
1084 +
      format(x)
1085 +
    }
742 1086
  }
743 1087
1088 +
  # -- public API --------------------------------------------------------
1089 +
744 1090
  err_env <- environment()
745 1091
  parent.env(err_env) <- baseenv()
746 1092
747 1093
  structure(
748 1094
    list(
749 -
      .internal      = err_env,
750 -
      new_cond       = new_cond,
751 -
      new_error      = new_error,
752 -
      throw          = throw,
753 -
      rethrow        = rethrow,
754 -
      catch_rethrow  = catch_rethrow,
755 -
      rethrow_call   = rethrow_call,
756 -
      add_trace_back = add_trace_back,
757 -
      onload_hook    = onload_hook,
758 -
      print_this     = print_this,
759 -
      print_parents  = print_parents
1095 +
      .internal        = err_env,
1096 +
      new_cond         = new_cond,
1097 +
      new_error        = new_error,
1098 +
      throw            = throw,
1099 +
      throw_error      = throw_error,
1100 +
      chain_error      = chain_error,
1101 +
      chain_call       = chain_call,
1102 +
      chain_clean_call = chain_clean_call,
1103 +
      add_trace_back   = add_trace_back,
1104 +
      process_call     = process_call,
1105 +
      onload_hook      = onload_hook,
1106 +
      format = list(
1107 +
        advice        = format_advice,
1108 +
        call          = format_call,
1109 +
        class         = format_class,
1110 +
        error         = format_error,
1111 +
        error_heading = format_error_heading,
1112 +
        header_line   = format_header_line,
1113 +
        srcref        = format_srcref,
1114 +
        trace         = format_trace
1115 +
      )
760 1116
    ),
761 1117
    class = c("standalone_errors", "standalone"))
762 1118
})
763 1119
764 1120
# These are optional, and feel free to remove them if you prefer to
765 1121
# call them through the `err` object.
766 1122
767 -
new_cond  <- err$new_cond
768 -
new_error <- err$new_error
769 -
throw     <- err$throw
770 -
rethrow   <- err$rethrow
771 -
rethrow_call <- err$rethrow_call
772 -
rethrow_call_with_cleanup <- err$.internal$rethrow_call_with_cleanup
1123 +
new_cond         <- err$new_cond
1124 +
new_error        <- err$new_error
1125 +
throw            <- err$throw
1126 +
throw_error      <- err$throw_error
1127 +
chain_error      <- err$chain_error
1128 +
chain_call       <- err$chain_call
1129 +
chain_clean_call <- err$chain_clean_call

@@ -0,0 +1,89 @@
Loading
1 +
2 +
# default_cran_mirror
3 +
4 +
safe_cran_install <- local({
5 +
6 +
  install_one <- function(pkg, lib = .libPaths()[1], INSTALL_opts = "", ...) {
7 +
8 +
    # On Windows, system() knows to handle "R", so we just use that, otherwise
9 +
    # the escaping might be tricky. On Unix, system() does not know about "R",
10 +
    # so we need the full path, and the full path probably does not have a space.
11 +
    rbin <- if (.Platform$OS.type == "unix") file.path(R.home("bin"), "R") else "R"
12 +
    rcmd <- sprintf("loadNamespace('%s', lib.loc = '%s')", pkg, lib)
13 +
    cmd <- sprintf("%s -q -e \"%s\"", rbin, rcmd)
14 +
    if (system(cmd) == 0) return()
15 +
16 +
    old <- options(
17 +
      warn = 2,
18 +
      repos = default_cran_mirror(),
19 +
      install.packages.compile.from.source = "always"
20 +
    )
21 +
    on.exit(options(old), add = TRUE)
22 +
23 +
    done <- FALSE
24 +
    # try binary first, this might be an older version, but never mind
25 +
    if (getOption("pkgType") != "source") {
26 +
      tryCatch({
27 +
        install.packages(
28 +
          pkg,
29 +
          lib = lib,
30 +
          dependencies = FALSE,
31 +
          INSTALL_opts = INSTALL_opts,
32 +
          ...
33 +
        )
34 +
        done <- TRUE
35 +
      }, error = function(err) print(err))
36 +
    }
37 +
38 +
    # try the canonical macos mirror as well, on macOS
39 +
    if (!done &&
40 +
        Sys.info()[["sysname"]] == "Darwin" &&
41 +
        getOption("pkgType") != "source") {
42 +
      options(repos = c(CRAN = "https://mac.r-project.org"))
43 +
      tryCatch({
44 +
        install.packages(
45 +
          pkg,
46 +
          lib = lib,
47 +
          dependencies = FALSE,
48 +
          INSTALL_opts = INSTALL_opts,
49 +
          ...
50 +
        )
51 +
        done <- TRUE
52 +
      }, error = function(err) print(err))
53 +
      options(repos = default_cran_mirror())
54 +
    }
55 +
56 +
    # source
57 +
    if (!done) {
58 +
      tryCatch({
59 +
        install.packages(
60 +
          pkg,
61 +
          lib = lib,
62 +
          dependencies = FALSE,
63 +
          type = "source",
64 +
          INSTALL_opts = INSTALL_opts,
65 +
          ...
66 +
        )
67 +
        done <- TRUE
68 +
      }, error = function(err) print(err))
69 +
    }
70 +
71 +
    if (!done) {
72 +
      unlink(file.path(lib, pkg), recursive = TRUE)
73 +
      stop("Failed to install ", pkg)
74 +
    }
75 +
  }
76 +
77 +
  function(pkgs, lib = .libPaths()[1], exclude = character()) {
78 +
    dir.create(lib, showWarnings = FALSE, recursive = TRUE)
79 +
    alldeps <- cran_install_order(pkgs)
80 +
    alldeps0 <- setdiff(alldeps, exclude)
81 +
    for (pkg in alldeps0) {
82 +
      install_one(
83 +
        pkg,
84 +
        lib = lib,
85 +
        INSTALL_opts = "--without-keep.source --no-html --no-help --no-data"
86 +
      )
87 +
    }
88 +
  }
89 +
})

@@ -0,0 +1,65 @@
Loading
1 +
2 +
# default_cran_mirror
3 +
4 +
cran_install_order <- local({
5 +
6 +
  base_packages <- function() {
7 +
    c("base", "compiler", "datasets", "graphics", "grDevices", "grid",
8 +
      "methods", "parallel", "splines", "stats", "stats4", "tcltk",
9 +
      "tools", "utils"
10 +
    )
11 +
  }
12 +
13 +
  parse_dep_fields <- function(flds) {
14 +
    flds[is.na(flds)] <- ""
15 +
    flds <- gsub("\\s+", "", flds)
16 +
    flds <- gsub("\\([^)]+\\)", "", flds)
17 +
    notempty <- nzchar(flds)
18 +
    res <- replicate(length(flds), character())
19 +
    flds <- flds[notempty]
20 +
    flds <- strsplit(flds, ",", fixed = TRUE)
21 +
22 +
    base <- base_packages()
23 +
    flds <- lapply(flds, setdiff, y = c("R", base))
24 +
25 +
    res[notempty] <- flds
26 +
    res
27 +
  }
28 +
29 +
  extract_deps <- function(pkg, db) {
30 +
    dep_types <- c("Depends", "Imports", "LinkingTo")
31 +
    fields <- db[ db[, "Package"] %in% pkg, dep_types]
32 +
    unlist(parse_dep_fields(fields))
33 +
  }
34 +
35 +
36 +
  calculate_deps <- function(pkgs) {
37 +
    db <- available.packages(repos = default_cran_mirror())
38 +
    current <- character()
39 +
    deps <- list()
40 +
    new <- pkgs
41 +
    while (length(new) > 0) {
42 +
      deps[new] <- lapply(new, extract_deps, db = db)
43 +
      new <- setdiff(unlist(deps[new]), names(deps))
44 +
    }
45 +
    deps
46 +
  }
47 +
48 +
  topo_deps <- function(deps) {
49 +
    pkgs <- character()
50 +
    while (length(deps) > 0) {
51 +
      ndeps <- vapply(deps, length, integer(1))
52 +
      nxt <- names(deps)[ndeps == 0]
53 +
      pkgs <- c(pkgs, nxt)
54 +
      deps <- deps[! names(deps) %in% nxt]
55 +
      deps[] <- lapply(deps, setdiff, nxt)
56 +
    }
57 +
    pkgs
58 +
  }
59 +
60 +
  function(pkgs) {
61 +
    deps <- calculate_deps(pkgs)
62 +
    topo_deps(deps)
63 +
  }
64 +
65 +
})

Click to load this diff.
Loading diff...

Click to load this diff.
Loading diff...

Click to load this diff.
Loading diff...

Click to load this diff.
Loading diff...

Click to load this diff.
Loading diff...

Click to load this diff.
Loading diff...

Click to load this diff.
Loading diff...

Click to load this diff.
Loading diff...

Click to load this diff.
Loading diff...

Click to load this diff.
Loading diff...

Click to load this diff.
Loading diff...

Click to load this diff.
Loading diff...

Click to load this diff.
Loading diff...

Click to load this diff.
Loading diff...

Click to load this diff.
Loading diff...

Click to load this diff.
Loading diff...

Click to load this diff.
Loading diff...

Click to load this diff.
Loading diff...

Click to load this diff.
Loading diff...

Click to load this diff.
Loading diff...

Click to load this diff.
Loading diff...

Click to load this diff.
Loading diff...

Click to load this diff.
Loading diff...

Learn more Showing 11 files with coverage changes found.

Changes in R/private-lib.R
-1
+1
Loading file...
New file R/embed-ca-certs.R
New
Loading file...
New file R/safe-cran-install.R
New
Loading file...
New file R/cran-install-order.R
New
Loading file...
New file R/default-cran-mirror.R
New
Loading file...
New file R/push-packages.R
New
Loading file...
New file R/embed-lib.R
New
Loading file...
New file R/compat-vctrs.R
New
Loading file...
New file R/lockfile.R
New
Loading file...
New file R/build-pak-binary.R
New
Loading file...
Changes in R/utils.R
-4
+4
Loading file...

251 Commits

Hiding 6 contexual commits
+1
+1
+62
-62
Hiding 1 contexual commits
Hiding 3 contexual commits
-62
+62
Hiding 1 contexual commits Hiding 2 contexual commits Hiding 2 contexual commits
+1
+2
-1
+1
+1
Hiding 8 contexual commits
+75
-75
Hiding 2 contexual commits
Hiding 14 contexual commits
+4
-62
+66
Hiding 2 contexual commits
+62
-62
Hiding 1 contexual commits
Hiding 2 contexual commits
Hiding 1 contexual commits Hiding 5 contexual commits
+2
+2
Hiding 17 contexual commits
+11
-48
+59
+8
+8