Update 70 packages

renv/activate.R

@@ -2,7 +2,7 @@
 local({
 
   # the requested version of renv
-  version <- "1.0.7"
+  version <- "1.1.0"
   attr(version, "sha") <- NULL
 
   # the project directory
@@ -42,7 +42,7 @@ local({
       return(FALSE)
 
     # next, check environment variables
-    # TODO: prefer using the configuration one in the future
+    # prefer using the configuration one in the future
     envvars <- c(
       "RENV_CONFIG_AUTOLOADER_ENABLED",
       "RENV_AUTOLOADER_ENABLED",
@@ -98,6 +98,66 @@ local({
     unloadNamespace("renv")
 
   # load bootstrap tools   
+  ansify <- function(text) {
+    if (renv_ansify_enabled())
+      renv_ansify_enhanced(text)
+    else
+      renv_ansify_default(text)
+  }
+
+  renv_ansify_enabled <- function() {
+
+    override <- Sys.getenv("RENV_ANSIFY_ENABLED", unset = NA)
+    if (!is.na(override))
+      return(as.logical(override))
+
+    pane <- Sys.getenv("RSTUDIO_CHILD_PROCESS_PANE", unset = NA)
+    if (identical(pane, "build"))
+      return(FALSE)
+
+    testthat <- Sys.getenv("TESTTHAT", unset = "false")
+    if (tolower(testthat) %in% "true")
+      return(FALSE)
+
+    iderun <- Sys.getenv("R_CLI_HAS_HYPERLINK_IDE_RUN", unset = "false")
+    if (tolower(iderun) %in% "false")
+      return(FALSE)
+
+    TRUE
+
+  }
+
+  renv_ansify_default <- function(text) {
+    text
+  }
+
+  renv_ansify_enhanced <- function(text) {
+
+    # R help links
+    pattern <- "`\\?(renv::(?:[^`])+)`"
+    replacement <- "`\033]8;;ide:help:\\1\a?\\1\033]8;;\a`"
+    text <- gsub(pattern, replacement, text, perl = TRUE)
+
+    # runnable code
+    pattern <- "`(renv::(?:[^`])+)`"
+    replacement <- "`\033]8;;ide:run:\\1\a\\1\033]8;;\a`"
+    text <- gsub(pattern, replacement, text, perl = TRUE)
+
+    # return ansified text
+    text
+
+  }
+
+  renv_ansify_init <- function() {
+
+    envir <- renv_envir_self()
+    if (renv_ansify_enabled())
+      assign("ansify", renv_ansify_enhanced, envir = envir)
+    else
+      assign("ansify", renv_ansify_default, envir = envir)
+
+  }
+
   `%||%` <- function(x, y) {
     if (is.null(x)) y else x
   }
@@ -142,12 +202,11 @@ local({
     # compute common indent
     indent <- regexpr("[^[:space:]]", lines)
     common <- min(setdiff(indent, -1L)) - leave
-    paste(substring(lines, common), collapse = "\n")
+    text <- paste(substring(lines, common), collapse = "\n")
 
-  }
+    # substitute in ANSI links for executable renv code
+    ansify(text)
 
-  startswith <- function(string, prefix) {
-    substring(string, 1, nchar(prefix)) == prefix
   }
 
   bootstrap <- function(version, library) {
@@ -305,8 +364,11 @@ local({
       quiet    = TRUE
     )
 
-    if ("headers" %in% names(formals(utils::download.file)))
-      args$headers <- renv_bootstrap_download_custom_headers(url)
+    if ("headers" %in% names(formals(utils::download.file))) {
+      headers <- renv_bootstrap_download_custom_headers(url)
+      if (length(headers) && is.character(headers))
+        args$headers <- headers
+    }
 
     do.call(utils::download.file, args)
 
@@ -385,10 +447,21 @@ local({
     for (type in types) {
       for (repos in renv_bootstrap_repos()) {
 
+        # build arguments for utils::available.packages() call
+        args <- list(type = type, repos = repos)
+
+        # add custom headers if available -- note that
+        # utils::available.packages() will pass this to download.file()
+        if ("headers" %in% names(formals(utils::download.file))) {
+          headers <- renv_bootstrap_download_custom_headers(repos)
+          if (length(headers) && is.character(headers))
+            args$headers <- headers
+        }
+
         # retrieve package database
         db <- tryCatch(
           as.data.frame(
-            utils::available.packages(type = type, repos = repos),
+            do.call(utils::available.packages, args),
             stringsAsFactors = FALSE
           ),
           error = identity
@@ -470,23 +543,34 @@ local({
 
   }
 
+  renv_bootstrap_github_token <- function() {
+    for (envvar in c("GITHUB_TOKEN", "GITHUB_PAT", "GH_TOKEN")) {
+      envval <- Sys.getenv(envvar, unset = NA)
+      if (!is.na(envval))
+        return(envval)
+    }
+  }
+
   renv_bootstrap_download_github <- function(version) {
 
     enabled <- Sys.getenv("RENV_BOOTSTRAP_FROM_GITHUB", unset = "TRUE")
     if (!identical(enabled, "TRUE"))
       return(FALSE)
 
     # prepare download options
-    pat <- Sys.getenv("GITHUB_PAT")
-    if (nzchar(Sys.which("curl")) && nzchar(pat)) {
+    token <- renv_bootstrap_github_token()
+    if (is.null(token))
+      token <- ""
+
+    if (nzchar(Sys.which("curl")) && nzchar(token)) {
       fmt <- "--location --fail --header \"Authorization: token %s\""
-      extra <- sprintf(fmt, pat)
+      extra <- sprintf(fmt, token)
       saved <- options("download.file.method", "download.file.extra")
       options(download.file.method = "curl", download.file.extra = extra)
       on.exit(do.call(base::options, saved), add = TRUE)
-    } else if (nzchar(Sys.which("wget")) && nzchar(pat)) {
+    } else if (nzchar(Sys.which("wget")) && nzchar(token)) {
       fmt <- "--header=\"Authorization: token %s\""
-      extra <- sprintf(fmt, pat)
+      extra <- sprintf(fmt, token)
       saved <- options("download.file.method", "download.file.extra")
       options(download.file.method = "wget", download.file.extra = extra)
       on.exit(do.call(base::options, saved), add = TRUE)
@@ -866,8 +950,14 @@ local({
   }
 
   renv_bootstrap_validate_version_dev <- function(version, description) {
+
     expected <- description[["RemoteSha"]]
-    is.character(expected) && startswith(expected, version)
+    if (!is.character(expected))
+      return(FALSE)
+
+    pattern <- sprintf("^\\Q%s\\E", version)
+    grepl(pattern, expected, perl = TRUE)
+
   }
 
   renv_bootstrap_validate_version_release <- function(version, description) {
@@ -1047,10 +1137,10 @@ local({
 
   renv_bootstrap_exec <- function(project, libpath, version) {
     if (!renv_bootstrap_load(project, libpath, version))
-      renv_bootstrap_run(version, libpath)
+      renv_bootstrap_run(project, libpath, version)
   }
 
-  renv_bootstrap_run <- function(version, libpath) {
+  renv_bootstrap_run <- function(project, libpath, version) {
 
     # perform bootstrap
     bootstrap(version, libpath)
@@ -1061,7 +1151,7 @@ local({
 
     # try again to load
     if (requireNamespace("renv", lib.loc = libpath, quietly = TRUE)) {
-      return(renv::load(project = getwd()))
+      return(renv::load(project = project))
     }
 
     # failed to download or load renv; warn the user
@@ -1107,98 +1197,101 @@ local({
     jsonlite::fromJSON(txt = text, simplifyVector = FALSE)
   }
 
-  renv_json_read_default <- function(file = NULL, text = NULL) {
-
-    # find strings in the JSON
-    text <- paste(text %||% readLines(file, warn = FALSE), collapse = "\n")
-    pattern <- '["](?:(?:\\\\.)|(?:[^"\\\\]))*?["]'
-    locs <- gregexpr(pattern, text, perl = TRUE)[[1]]
-
-    # if any are found, replace them with placeholders
-    replaced <- text
-    strings <- character()
-    replacements <- character()
-
-    if (!identical(c(locs), -1L)) {
-
-      # get the string values
-      starts <- locs
-      ends <- locs + attr(locs, "match.length") - 1L
-      strings <- substring(text, starts, ends)
-
-      # only keep those requiring escaping
-      strings <- grep("[[\\]{}:]", strings, perl = TRUE, value = TRUE)
-
-      # compute replacements
-      replacements <- sprintf('"\032%i\032"', seq_along(strings))
-
-      # replace the strings
-      mapply(function(string, replacement) {
-        replaced <<- sub(string, replacement, replaced, fixed = TRUE)
-      }, strings, replacements)
+  renv_json_read_patterns <- function() {
+
+    list(
+
+      # objects
+      list("{", "\t\n\tobject(\t\n\t"),
+      list("}", "\t\n\t)\t\n\t"),
+
+      # arrays
+      list("[", "\t\n\tarray(\t\n\t"),
+      list("]", "\n\t\n)\n\t\n"),
+
+      # maps
+      list(":", "\t\n\t=\t\n\t")
+
+    )
+
+  }
 
+  renv_json_read_envir <- function() {
+
+    envir <- new.env(parent = emptyenv())
+
+    envir[["+"]] <- `+`
+    envir[["-"]] <- `-`
+
+    envir[["object"]] <- function(...) {
+      result <- list(...)
+      names(result) <- as.character(names(result))
+      result
     }
-
-    # transform the JSON into something the R parser understands
-    transformed <- replaced
-    transformed <- gsub("{}", "`names<-`(list(), character())", transformed, fixed = TRUE)
-    transformed <- gsub("[[{]", "list(", transformed, perl = TRUE)
-    transformed <- gsub("[]}]", ")", transformed, perl = TRUE)
-    transformed <- gsub(":", "=", transformed, fixed = TRUE)
-    text <- paste(transformed, collapse = "\n")
-
-    # parse it
-    json <- parse(text = text, keep.source = FALSE, srcfile = NULL)[[1L]]
-
-    # construct map between source strings, replaced strings
-    map <- as.character(parse(text = strings))
-    names(map) <- as.character(parse(text = replacements))
-
-    # convert to list
-    map <- as.list(map)
-
-    # remap strings in object
-    remapped <- renv_json_read_remap(json, map)
-
-    # evaluate
-    eval(remapped, envir = baseenv())
-
+
+    envir[["array"]] <- list
+
+    envir[["true"]]  <- TRUE
+    envir[["false"]] <- FALSE
+    envir[["null"]]  <- NULL
+
+    envir
+
   }
 
-  renv_json_read_remap <- function(json, map) {
-
-    # fix names
-    if (!is.null(names(json))) {
-      lhs <- match(names(json), names(map), nomatch = 0L)
-      rhs <- match(names(map), names(json), nomatch = 0L)
-      names(json)[rhs] <- map[lhs]
+  renv_json_read_remap <- function(object, patterns) {
+
+    # repair names if necessary
+    if (!is.null(names(object))) {
+
+      nms <- names(object)
+      for (pattern in patterns)
+        nms <- gsub(pattern[[2L]], pattern[[1L]], nms, fixed = TRUE)
+      names(object) <- nms
+
     }
-
-    # fix values
-    if (is.character(json))
-      return(map[[json]] %||% json)
-
-    # handle true, false, null
-    if (is.name(json)) {
-      text <- as.character(json)
-      if (text == "true")
-        return(TRUE)
-      else if (text == "false")
-        return(FALSE)
-      else if (text == "null")
-        return(NULL)
+
+    # repair strings if necessary
+    if (is.character(object)) {
+      for (pattern in patterns)
+        object <- gsub(pattern[[2L]], pattern[[1L]], object, fixed = TRUE)
     }
+
+    # recurse for other objects
+    if (is.recursive(object))
+      for (i in seq_along(object))
+        object[i] <- list(renv_json_read_remap(object[[i]], patterns))
+
+    # return remapped object
+    object
+
+  }
 
-    # recurse
-    if (is.recursive(json)) {
-      for (i in seq_along(json)) {
-        json[i] <- list(renv_json_read_remap(json[[i]], map))
-      }
-    }
+  renv_json_read_default <- function(file = NULL, text = NULL) {
 
-    json
+    # read json text
+    text <- paste(text %||% readLines(file, warn = FALSE), collapse = "\n")
+
+    # convert into something the R parser will understand
+    patterns <- renv_json_read_patterns()
+    transformed <- text
+    for (pattern in patterns)
+      transformed <- gsub(pattern[[1L]], pattern[[2L]], transformed, fixed = TRUE)
+
+    # parse it
+    rfile <- tempfile("renv-json-", fileext = ".R")
+    on.exit(unlink(rfile), add = TRUE)
+    writeLines(transformed, con = rfile)
+    json <- parse(rfile, keep.source = FALSE, srcfile = NULL)[[1L]]
 
+    # evaluate in safe environment
+    result <- eval(json, envir = renv_json_read_envir())
+
+    # fix up strings if necessary
+    renv_json_read_remap(result, patterns)
+
   }
+
 
   # load the renv profile, if any
   renv_bootstrap_profile_load(project)