diff --git a/R/.lintr b/R/.lintr index d0769c3d0..8e8bd81e4 100644 --- a/R/.lintr +++ b/R/.lintr @@ -1,5 +1,6 @@ linters: linters_with_defaults( line_length_linter(120), + indentation_linter(4), cyclocomp_linter = NULL, object_name_linter = NULL, object_usage_linter = NULL) diff --git a/R/help/getAliases.R b/R/help/getAliases.R index d76e67c3a..8d0b27e20 100644 --- a/R/help/getAliases.R +++ b/R/help/getAliases.R @@ -2,18 +2,18 @@ add_lib_paths <- Sys.getenv("VSCR_LIB_PATHS") if (nzchar(add_lib_paths)) { - add_lib_paths <- strsplit(add_lib_paths, "\n", fixed = TRUE)[[1L]] - .paths <- c(.paths, add_lib_paths) + add_lib_paths <- strsplit(add_lib_paths, "\n", fixed = TRUE)[[1L]] + .paths <- c(.paths, add_lib_paths) } use_renv_lib_path <- Sys.getenv("VSCR_USE_RENV_LIB_PATH") use_renv_lib_path <- if (nzchar(use_renv_lib_path)) as.logical(use_renv_lib_path) else FALSE if (use_renv_lib_path) { - if (requireNamespace("renv", quietly = TRUE)) { - .paths <- c(.paths, renv::paths$cache()) - } else { - warning("renv package is not installed. Please install renv to use renv library path.") - } + if (requireNamespace("renv", quietly = TRUE)) { + .paths <- c(.paths, renv::paths$cache()) + } else { + warning("renv package is not installed. Please install renv to use renv library path.") + } } .libPaths(.paths) @@ -27,27 +27,27 @@ ord <- order(ip[, "Priority"]) ip <- ip[ord, ] ret <- lapply(rownames(ip), function(row) { - libPath <- ip[row, "LibPath"] - pkg <- ip[row, "Package"] - filename <- file.path(libPath, pkg, "help", "aliases.rds") - info <- list( - package = pkg, - libPath = libPath, - aliasFile = filename, - aliases = NULL - ) - if (file.exists(filename)) { - res <- tryCatch( - expr = as.list(readRDS(filename)), - error = conditionMessage + libPath <- ip[row, "LibPath"] + pkg <- ip[row, "Package"] + filename <- file.path(libPath, pkg, "help", "aliases.rds") + info <- list( + package = pkg, + libPath = libPath, + aliasFile = filename, + aliases = NULL ) - if (is.list(res)) { - info$aliases <- res - } else { - info$error <- res + if (file.exists(filename)) { + res <- tryCatch( + expr = as.list(readRDS(filename)), + error = conditionMessage + ) + if (is.list(res)) { + info$aliases <- res + } else { + info$error <- res + } } - } - info + info }) names(ret) <- rownames(ip) diff --git a/R/help/helpServer.R b/R/help/helpServer.R index 006dd72ad..e657965a9 100644 --- a/R/help/helpServer.R +++ b/R/help/helpServer.R @@ -2,18 +2,18 @@ add_lib_paths <- Sys.getenv("VSCR_LIB_PATHS") if (nzchar(add_lib_paths)) { - add_lib_paths <- strsplit(add_lib_paths, "\n", fixed = TRUE)[[1L]] - .paths <- c(.paths, add_lib_paths) + add_lib_paths <- strsplit(add_lib_paths, "\n", fixed = TRUE)[[1L]] + .paths <- c(.paths, add_lib_paths) } use_renv_lib_path <- Sys.getenv("VSCR_USE_RENV_LIB_PATH") use_renv_lib_path <- if (nzchar(use_renv_lib_path)) as.logical(use_renv_lib_path) else FALSE if (use_renv_lib_path) { - if (requireNamespace("renv", quietly = TRUE)) { - .paths <- c(.paths, renv::paths$cache()) - } else { - warning("renv package is not installed. Please install renv to use renv library path.") - } + if (requireNamespace("renv", quietly = TRUE)) { + .paths <- c(.paths, renv::paths$cache()) + } else { + warning("renv package is not installed. Please install renv to use renv library path.") + } } .libPaths(.paths) diff --git a/R/help/rdToHtml.R b/R/help/rdToHtml.R index 12e111db0..e2523efad 100644 --- a/R/help/rdToHtml.R +++ b/R/help/rdToHtml.R @@ -1,4 +1,3 @@ - #' Converts an .Rd file to HTML (output is printed to stdout) #' #' Execute this with the following trailing commandline args: diff --git a/R/languageServer.R b/R/languageServer.R index 88030cb81..4df0c3c05 100644 --- a/R/languageServer.R +++ b/R/languageServer.R @@ -2,25 +2,25 @@ add_lib_paths <- Sys.getenv("VSCR_LIB_PATHS") if (nzchar(add_lib_paths)) { - add_lib_paths <- strsplit(add_lib_paths, "\n", fixed = TRUE)[[1L]] - .paths <- c(.paths, add_lib_paths) + add_lib_paths <- strsplit(add_lib_paths, "\n", fixed = TRUE)[[1L]] + .paths <- c(.paths, add_lib_paths) } use_renv_lib_path <- Sys.getenv("VSCR_USE_RENV_LIB_PATH") use_renv_lib_path <- if (nzchar(use_renv_lib_path)) as.logical(use_renv_lib_path) else FALSE if (use_renv_lib_path) { - if (requireNamespace("renv", quietly = TRUE)) { - .paths <- c(.paths, renv::paths$cache()) - } else { - warning("renv package is not installed. Please install renv to use renv library path.") - } + if (requireNamespace("renv", quietly = TRUE)) { + .paths <- c(.paths, renv::paths$cache()) + } else { + warning("renv package is not installed. Please install renv to use renv library path.") + } } .libPaths(.paths) message("R library paths: ", paste(.libPaths(), collapse = "\n")) if (!requireNamespace("languageserver", quietly = TRUE)) { - q(save = "no", status = 10) + q(save = "no", status = 10) } debug <- Sys.getenv("VSCR_LSP_DEBUG") diff --git a/R/rmarkdown/templates.R b/R/rmarkdown/templates.R index 93a7a0a81..f226a6975 100644 --- a/R/rmarkdown/templates.R +++ b/R/rmarkdown/templates.R @@ -4,19 +4,19 @@ loadNamespace("yaml") pkgs <- .packages(all.available = TRUE) templates <- new.env() template_dirs <- lapply(pkgs, function(pkg) { - dir <- system.file("rmarkdown/templates", package = pkg) - if (dir.exists(dir)) { - ids <- list.dirs(dir, full.names = FALSE, recursive = FALSE) - for (id in ids) { - file <- file.path(dir, id, "template.yaml") - if (file.exists(file)) { - data <- yaml::read_yaml(file) - data$id <- id - data$package <- pkg - templates[[paste0(pkg, "::", id)]] <- data - } + dir <- system.file("rmarkdown/templates", package = pkg) + if (dir.exists(dir)) { + ids <- list.dirs(dir, full.names = FALSE, recursive = FALSE) + for (id in ids) { + file <- file.path(dir, id, "template.yaml") + if (file.exists(file)) { + data <- yaml::read_yaml(file) + data$id <- id + data$package <- pkg + templates[[paste0(pkg, "::", id)]] <- data + } + } } - } }) template_list <- unname(as.list(templates)) diff --git a/R/session/init.R b/R/session/init.R index b44cc6c96..8cde02cb4 100644 --- a/R/session/init.R +++ b/R/session/init.R @@ -7,32 +7,33 @@ dir_init <- getwd() # This function is run at the beginning of R's startup sequence # Code that is meant to be run at the end of the startup should go in `init_last` init_first <- function() { - # return early if not a vscode term session - if ( - !interactive() - || Sys.getenv("RSTUDIO") != "" - || Sys.getenv("TERM_PROGRAM") != "vscode" - ) { - return() - } + # return early if not a vscode term session + if ( + !interactive() + || Sys.getenv("RSTUDIO") != "" + || Sys.getenv("TERM_PROGRAM") != "vscode" + ) { + return() + } - # check requried packages - required_packages <- c("jsonlite", "rlang") - missing_packages <- required_packages[ - !vapply(required_packages, requireNamespace, - logical(1L), quietly = TRUE) - ] + # check requried packages + required_packages <- c("jsonlite", "rlang") + missing_packages <- required_packages[ + !vapply(required_packages, requireNamespace, + logical(1L), quietly = TRUE + ) + ] - if (length(missing_packages)) { - message( - "VSCode R Session Watcher requires ", - toString(missing_packages), ". ", - "Please install manually in order to use VSCode-R." - ) - } else { - # Initialize vsc utils after loading other default packages - assign(".First.sys", init_last, envir = globalenv()) - } + if (length(missing_packages)) { + message( + "VSCode R Session Watcher requires ", + toString(missing_packages), ". ", + "Please install manually in order to use VSCode-R." + ) + } else { + # Initialize vsc utils after loading other default packages + assign(".First.sys", init_last, envir = globalenv()) + } } old.First.sys <- .First.sys @@ -42,62 +43,62 @@ old.First.sys <- .First.sys # Will be assigned to and called from the global environment, # Will be run with wd being the user's working directory (!) init_last <- function() { - old.First.sys() + old.First.sys() - # cleanup previous version - removeTaskCallback("vscode-R") - options(vscodeR = NULL) - .vsc.name <- "tools:vscode" - if (.vsc.name %in% search()) { - detach(.vsc.name, character.only = TRUE) - } + # cleanup previous version + removeTaskCallback("vscode-R") + options(vscodeR = NULL) + .vsc.name <- "tools:vscode" + if (.vsc.name %in% search()) { + detach(.vsc.name, character.only = TRUE) + } - # Source vsc utils in new environmeent - .vsc <- new.env() - source(file.path(dir_init, "vsc.R"), local = .vsc) + # Source vsc utils in new environmeent + .vsc <- new.env() + source(file.path(dir_init, "vsc.R"), local = .vsc) - # attach functions that are meant to be called by the user/vscode - exports <- local({ - .vsc <- .vsc - .vsc.attach <- .vsc$attach - .vsc.view <- .vsc$show_dataview - .vsc.browser <- .vsc$show_browser - .vsc.viewer <- .vsc$show_viewer - .vsc.page_viewer <- .vsc$show_page_viewer - View <- .vsc.view - environment() - }) - attach(exports, name = .vsc.name, warn.conflicts = FALSE) + # attach functions that are meant to be called by the user/vscode + exports <- local({ + .vsc <- .vsc + .vsc.attach <- .vsc$attach + .vsc.view <- .vsc$show_dataview + .vsc.browser <- .vsc$show_browser + .vsc.viewer <- .vsc$show_viewer + .vsc.page_viewer <- .vsc$show_page_viewer + View <- .vsc.view + environment() + }) + attach(exports, name = .vsc.name, warn.conflicts = FALSE) - # overwrite S3 bindings from other packages - suppressWarnings({ - if (!identical(getOption("vsc.helpPanel", "Two"), FALSE)) { - # Overwrite print function for results of `?` - .vsc$.S3method( - "print", - "help_files_with_topic", - .vsc$print.help_files_with_topic - ) - # Overwrite print function for results of `??` - .vsc$.S3method( - "print", - "hsearch", - .vsc$print.hsearch - ) - } - # Further S3 overwrites can go here - # ... - }) + # overwrite S3 bindings from other packages + suppressWarnings({ + if (!identical(getOption("vsc.helpPanel", "Two"), FALSE)) { + # Overwrite print function for results of `?` + .vsc$.S3method( + "print", + "help_files_with_topic", + .vsc$print.help_files_with_topic + ) + # Overwrite print function for results of `??` + .vsc$.S3method( + "print", + "hsearch", + .vsc$print.hsearch + ) + } + # Further S3 overwrites can go here + # ... + }) - # remove this function from globalenv() - suppressWarnings( - rm(".First.sys", envir = globalenv()) - ) + # remove this function from globalenv() + suppressWarnings( + rm(".First.sys", envir = globalenv()) + ) - # Attach to vscode - exports$.vsc.attach() + # Attach to vscode + exports$.vsc.attach() - invisible() + invisible() } init_first() diff --git a/R/session/profile.R b/R/session/profile.R index 3b25c0d93..dafdf298b 100644 --- a/R/session/profile.R +++ b/R/session/profile.R @@ -1,33 +1,33 @@ # Source the original .Rprofile local({ - try_source <- function(file) { - if (file.exists(file)) { - source(file) - TRUE - } else { - FALSE + try_source <- function(file) { + if (file.exists(file)) { + source(file) + TRUE + } else { + FALSE + } } - } - r_profile <- Sys.getenv("R_PROFILE_USER_OLD") - Sys.setenv( - R_PROFILE_USER_OLD = "", - R_PROFILE_USER = r_profile - ) + r_profile <- Sys.getenv("R_PROFILE_USER_OLD") + Sys.setenv( + R_PROFILE_USER_OLD = "", + R_PROFILE_USER = r_profile + ) - if (nzchar(r_profile)) { - try_source(r_profile) - } else { - try_source(".Rprofile") || try_source(file.path("~", ".Rprofile")) - } + if (nzchar(r_profile)) { + try_source(r_profile) + } else { + try_source(".Rprofile") || try_source(file.path("~", ".Rprofile")) + } - invisible() + invisible() }) # Run vscode initializer local({ - init_file <- Sys.getenv("VSCODE_INIT_R") - if (nzchar(init_file)) { - source(init_file, chdir = TRUE, local = TRUE) - } + init_file <- Sys.getenv("VSCODE_INIT_R") + if (nzchar(init_file)) { + source(init_file, chdir = TRUE, local = TRUE) + } }) diff --git a/R/session/rstudioapi.R b/R/session/rstudioapi.R index 15cbf9912..107ff89b0 100644 --- a/R/session/rstudioapi.R +++ b/R/session/rstudioapi.R @@ -39,7 +39,8 @@ insertText <- function(location, text, id = NULL) { )) } else if (missing(location)) { ## handling insertText(text = "text") - return(invisible(rstudioapi_call("replace_text_in_current_selection", + return(invisible(rstudioapi_call( + "replace_text_in_current_selection", text = text, id = id ))) diff --git a/R/session/rstudioapi_util.R b/R/session/rstudioapi_util.R index f46c950dc..da5fe0ff6 100644 --- a/R/session/rstudioapi_util.R +++ b/R/session/rstudioapi_util.R @@ -157,8 +157,7 @@ normalise_pos_or_range_arg <- function(location) { lapply( location, function(a_location) { - if (rstudioapi::is.document_position(a_location) || - rstudioapi::is.document_range(a_location)) { + if (rstudioapi::is.document_position(a_location) || rstudioapi::is.document_range(a_location)) { a_location } else if (is_positionable(a_location)) { rstudioapi::as.document_position(a_location) @@ -209,33 +208,33 @@ update_addin_registry <- function(addin_registry) { ) description_result <- tryCatch({ - addin_description <- - as.data.frame(read.dcf(package_dcf), - stringsAsFactors = FALSE - ) - - if (ncol(addin_description) < 4) { - NULL - } - ## if less than 4 columns it's malformed - ## a NULL will be ignored in the rbind - - addin_description$package <- package - names(addin_description) <- addin_description_names - - addin_description[, addin_description_names] - ## this filters out any extra columns - }, - error = function(cond) { - message( - "addins.dcf file for ", package, - " could not be read from R library. ", - "The RStudio addin picker will not ", - "contain it's addins" + addin_description <- + as.data.frame(read.dcf(package_dcf), + stringsAsFactors = FALSE ) + if (ncol(addin_description) < 4) { NULL } + ## if less than 4 columns it's malformed + ## a NULL will be ignored in the rbind + + addin_description$package <- package + names(addin_description) <- addin_description_names + + addin_description[, addin_description_names] + ## this filters out any extra columns + }, + error = function(cond) { + message( + "addins.dcf file for ", package, + " could not be read from R library. ", + "The RStudio addin picker will not ", + "contain it's addins" + ) + + NULL + } ) description_result diff --git a/R/session/vsc.R b/R/session/vsc.R index 5a13f993b..5ab461394 100644 --- a/R/session/vsc.R +++ b/R/session/vsc.R @@ -2,7 +2,7 @@ pid <- Sys.getpid() wd <- getwd() tempdir <- tempdir() homedir <- Sys.getenv( - if (.Platform$OS.type == "windows") "USERPROFILE" else "HOME" + if (.Platform$OS.type == "windows") "USERPROFILE" else "HOME" ) dir_watcher <- Sys.getenv("VSCODE_WATCHER_DIR", file.path(homedir, ".vscode-R")) request_file <- file.path(dir_watcher, "request.log") @@ -11,346 +11,347 @@ settings_file <- file.path(dir_watcher, "settings.json") user_options <- names(options()) logger <- if (getOption("vsc.debug", FALSE)) { - function(...) cat(..., "\n", sep = "") + function(...) cat(..., "\n", sep = "") } else { - function(...) invisible() + function(...) invisible() } load_settings <- function() { - if (!file.exists(settings_file)) { - return(FALSE) - } - - setting <- function(x, ...) { - switch(EXPR = x, ..., x) - } - - mapping <- quote(list( - vsc.use_webserver = session$useWebServer, - vsc.use_httpgd = plot$useHttpgd, - vsc.show_object_size = workspaceViewer$showObjectSize, - vsc.rstudioapi = session$emulateRStudioAPI, - vsc.str.max.level = setting(session$levelOfObjectDetail, Minimal = 0, Normal = 1, Detailed = 2), - vsc.object_length_limit = session$objectLengthLimit, - vsc.object_timeout = session$objectTimeout, - vsc.globalenv = session$watchGlobalEnvironment, - vsc.plot = setting(session$viewers$viewColumn$plot, Disable = FALSE), - vsc.dev.args = plot$devArgs, - vsc.browser = setting(session$viewers$viewColumn$browser, Disable = FALSE), - vsc.viewer = setting(session$viewers$viewColumn$viewer, Disable = FALSE), - vsc.page_viewer = setting(session$viewers$viewColumn$pageViewer, Disable = FALSE), - vsc.row_limit = session$data$rowLimit, - vsc.view = setting(session$viewers$viewColumn$view, Disable = FALSE), - vsc.helpPanel = setting(session$viewers$viewColumn$helpPanel, Disable = FALSE) - )) - - vsc_settings <- tryCatch(jsonlite::read_json(settings_file), error = function(e) { - message("Error occurs when reading VS Code settings: ", conditionMessage(e)) - }) - - if (is.null(vsc_settings)) { - return(FALSE) - } - - ops <- eval(mapping, vsc_settings) - - # exclude options set by user on startup - r_options <- ops[!(names(ops) %in% user_options)] - - options(r_options) + if (!file.exists(settings_file)) { + return(FALSE) + } + + setting <- function(x, ...) { + switch(EXPR = x, ..., x) + } + + mapping <- quote(list( + vsc.use_webserver = session$useWebServer, + vsc.use_httpgd = plot$useHttpgd, + vsc.show_object_size = workspaceViewer$showObjectSize, + vsc.rstudioapi = session$emulateRStudioAPI, + vsc.str.max.level = setting(session$levelOfObjectDetail, Minimal = 0, Normal = 1, Detailed = 2), + vsc.object_length_limit = session$objectLengthLimit, + vsc.object_timeout = session$objectTimeout, + vsc.globalenv = session$watchGlobalEnvironment, + vsc.plot = setting(session$viewers$viewColumn$plot, Disable = FALSE), + vsc.dev.args = plot$devArgs, + vsc.browser = setting(session$viewers$viewColumn$browser, Disable = FALSE), + vsc.viewer = setting(session$viewers$viewColumn$viewer, Disable = FALSE), + vsc.page_viewer = setting(session$viewers$viewColumn$pageViewer, Disable = FALSE), + vsc.row_limit = session$data$rowLimit, + vsc.view = setting(session$viewers$viewColumn$view, Disable = FALSE), + vsc.helpPanel = setting(session$viewers$viewColumn$helpPanel, Disable = FALSE) + )) + + vsc_settings <- tryCatch(jsonlite::read_json(settings_file), error = function(e) { + message("Error occurs when reading VS Code settings: ", conditionMessage(e)) + }) + + if (is.null(vsc_settings)) { + return(FALSE) + } + + ops <- eval(mapping, vsc_settings) + + # exclude options set by user on startup + r_options <- ops[!(names(ops) %in% user_options)] + + options(r_options) } load_settings() if (is.null(getOption("help_type"))) { - options(help_type = "html") + options(help_type = "html") } use_webserver <- isTRUE(getOption("vsc.use_webserver", FALSE)) if (use_webserver) { - if (requireNamespace("httpuv", quietly = TRUE)) { - request_handlers <- list( - hover = function(expr, ...) { - tryCatch({ - expr <- parse(text = expr, keep.source = FALSE)[[1]] - obj <- eval(expr, .GlobalEnv) - list(str = capture_str(obj)) - }, error = function(e) NULL) - }, - - complete = function(expr, trigger, ...) { - obj <- tryCatch({ - expr <- parse(text = expr, keep.source = FALSE)[[1]] - eval(expr, .GlobalEnv) - }, error = function(e) NULL) - - if (is.null(obj)) { - return(NULL) - } - - if (trigger == "$") { - names <- if (is.object(obj)) { - .DollarNames(obj, pattern = "") - } else if (is.recursive(obj)) { - names(obj) - } else { - NULL - } - - result <- lapply(names, function(name) { - item <- obj[[name]] - list( - name = name, - type = typeof(item), - str = try_capture_str(item) - ) - }) - return(result) - } + if (requireNamespace("httpuv", quietly = TRUE)) { + request_handlers <- list( + hover = function(expr, ...) { + tryCatch({ + expr <- parse(text = expr, keep.source = FALSE)[[1]] + obj <- eval(expr, .GlobalEnv) + list(str = capture_str(obj)) + }, error = function(e) NULL) + }, + + complete = function(expr, trigger, ...) { + obj <- tryCatch({ + expr <- parse(text = expr, keep.source = FALSE)[[1]] + eval(expr, .GlobalEnv) + }, error = function(e) NULL) + + if (is.null(obj)) { + return(NULL) + } + + if (trigger == "$") { + names <- if (is.object(obj)) { + .DollarNames(obj, pattern = "") + } else if (is.recursive(obj)) { + names(obj) + } else { + NULL + } + + result <- lapply(names, function(name) { + item <- obj[[name]] + list( + name = name, + type = typeof(item), + str = try_capture_str(item) + ) + }) + return(result) + } + + if (trigger == "@" && isS4(obj)) { + names <- slotNames(obj) + result <- lapply(names, function(name) { + item <- slot(obj, name) + list( + name = name, + type = typeof(item), + str = try_capture_str(item) + ) + }) + return(result) + } + } + ) - if (trigger == "@" && isS4(obj)) { - names <- slotNames(obj) - result <- lapply(names, function(name) { - item <- slot(obj, name) - list( - name = name, - type = typeof(item), - str = try_capture_str(item) + server <- getOption("vsc.server") + if (!is.null(server) && server$isRunning()) { + host <- server$getHost() + port <- server$getPort() + token <- attr(server, "token") + } else { + host <- "127.0.0.1" + port <- httpuv::randomPort() + token <- sprintf("%d:%d:%.6f", pid, port, Sys.time()) + server <- httpuv::startServer(host, port, + list( + onHeaders = function(req) { + logger("http request ", + req[["REMOTE_ADDR"]], ":", + req[["REMOTE_PORT"]], " ", + req[["REQUEST_METHOD"]], " ", + req[["HTTP_USER_AGENT"]] + ) + + if (!nzchar(req[["REMOTE_ADDR"]]) || identical(req[["REMOTE_PORT"]], "0")) { + return(NULL) + } + + if (!identical(req[["HTTP_AUTHORIZATION"]], token)) { + return(list( + status = 401L, + headers = list( + "Content-Type" = "text/plain" + ), + body = "Unauthorized" + )) + } + + if (!identical(req[["HTTP_CONTENT_TYPE"]], "application/json")) { + return(list( + status = 400L, + headers = list( + "Content-Type" = "text/plain" + ), + body = "Bad request" + )) + } + }, + call = function(req) { + content <- req$rook.input$read_lines() + request <- jsonlite::fromJSON(content, simplifyVector = FALSE) + handler <- request_handlers[[request$type]] + response <- if (is.function(handler)) do.call(handler, request) + + list( + status = 200L, + headers = list( + "Content-Type" = "application/json" + ), + body = jsonlite::toJSON(response, auto_unbox = TRUE, force = TRUE) + ) + } + ) ) - }) - return(result) + attr(server, "token") <- token + options(vsc.server = server) } - } - ) - - server <- getOption("vsc.server") - if (!is.null(server) && server$isRunning()) { - host <- server$getHost() - port <- server$getPort() - token <- attr(server, "token") } else { - host <- "127.0.0.1" - port <- httpuv::randomPort() - token <- sprintf("%d:%d:%.6f", pid, port, Sys.time()) - server <- httpuv::startServer(host, port, - list( - onHeaders = function(req) { - logger("http request ", - req[["REMOTE_ADDR"]], ":", - req[["REMOTE_PORT"]], " ", - req[["REQUEST_METHOD"]], " ", - req[["HTTP_USER_AGENT"]] - ) - - if (!nzchar(req[["REMOTE_ADDR"]]) || identical(req[["REMOTE_PORT"]], "0")) { - return(NULL) - } - - if (!identical(req[["HTTP_AUTHORIZATION"]], token)) { - return(list( - status = 401L, - headers = list( - "Content-Type" = "text/plain" - ), - body = "Unauthorized" - )) - } - - if (!identical(req[["HTTP_CONTENT_TYPE"]], "application/json")) { - return(list( - status = 400L, - headers = list( - "Content-Type" = "text/plain" - ), - body = "Bad request" - )) - } - }, - call = function(req) { - content <- req$rook.input$read_lines() - request <- jsonlite::fromJSON(content, simplifyVector = FALSE) - handler <- request_handlers[[request$type]] - response <- if (is.function(handler)) do.call(handler, request) - - list( - status = 200L, - headers = list( - "Content-Type" = "application/json" - ), - body = jsonlite::toJSON(response, auto_unbox = TRUE, force = TRUE) - ) - } - ) - ) - attr(server, "token") <- token - options(vsc.server = server) + message("{httpuv} is required to use WebServer from the session watcher.") + use_webserver <- FALSE } - } else { - message("{httpuv} is required to use WebServer from the session watcher.") - use_webserver <- FALSE - } } get_timestamp <- function() { - sprintf("%.6f", Sys.time()) + sprintf("%.6f", Sys.time()) } scalar <- function(x) { - class(x) <- c("scalar", class(x)) - x + class(x) <- c("scalar", class(x)) + x } request <- function(command, ...) { - obj <- list( - time = Sys.time(), - pid = pid, - wd = wd, - command = command, - ... - ) - jsonlite::write_json(obj, request_file, - auto_unbox = TRUE, null = "null", force = TRUE) - cat(get_timestamp(), file = request_lock_file) + obj <- list( + time = Sys.time(), + pid = pid, + wd = wd, + command = command, + ... + ) + jsonlite::write_json(obj, request_file, + auto_unbox = TRUE, null = "null", force = TRUE + ) + cat(get_timestamp(), file = request_lock_file) } try_catch_timeout <- function(expr, timeout = Inf, ...) { - expr <- substitute(expr) - envir <- parent.frame() - setTimeLimit(timeout, transient = TRUE) - on.exit(setTimeLimit()) - tryCatch(eval(expr, envir), ...) + expr <- substitute(expr) + envir <- parent.frame() + setTimeLimit(timeout, transient = TRUE) + on.exit(setTimeLimit()) + tryCatch(eval(expr, envir), ...) } capture_str <- function(object, max.level = getOption("vsc.str.max.level", 0)) { - paste0(utils::capture.output( - utils::str(object, - max.level = max.level, - give.attr = FALSE, - vec.len = 1 - ) - ), collapse = "\n") + paste0(utils::capture.output( + utils::str(object, + max.level = max.level, + give.attr = FALSE, + vec.len = 1 + ) + ), collapse = "\n") } try_capture_str <- function(object, max.level = getOption("vsc.str.max.level", 0)) { - tryCatch( - capture_str(object, max.level = max.level), - error = function(e) { - paste0(class(object), collapse = ", ") - } - ) + tryCatch( + capture_str(object, max.level = max.level), + error = function(e) { + paste0(class(object), collapse = ", ") + } + ) } rebind <- function(sym, value, ns) { - if (is.character(ns)) { - Recall(sym, value, getNamespace(ns)) - pkg <- paste0("package:", ns) - if (pkg %in% search()) { - Recall(sym, value, as.environment(pkg)) - } - } else if (is.environment(ns)) { - if (bindingIsLocked(sym, ns)) { - unlockBinding(sym, ns) - on.exit(lockBinding(sym, ns)) + if (is.character(ns)) { + Recall(sym, value, getNamespace(ns)) + pkg <- paste0("package:", ns) + if (pkg %in% search()) { + Recall(sym, value, as.environment(pkg)) + } + } else if (is.environment(ns)) { + if (bindingIsLocked(sym, ns)) { + unlockBinding(sym, ns) + on.exit(lockBinding(sym, ns)) + } + assign(sym, value, ns) + } else { + stop("ns must be a string or environment") } - assign(sym, value, ns) - } else { - stop("ns must be a string or environment") - } } address <- function(x) { - info <- utils::capture.output(.Internal(inspect(x, 0L, 0L))) - sub("@([a-z0-9]+)\\s+.+", "\\1", info[[1]]) + info <- utils::capture.output(.Internal(inspect(x, 0L, 0L))) + sub("@([a-z0-9]+)\\s+.+", "\\1", info[[1]]) } globalenv_cache <- new.env(parent = emptyenv()) inspect_env <- function(env, cache) { - all_names <- ls(env) - rm(list = setdiff(names(globalenv_cache), all_names), envir = cache) - is_active <- vapply(all_names, bindingIsActive, logical(1), USE.NAMES = TRUE, env) - is_promise <- rlang::env_binding_are_lazy(env, all_names[!is_active]) - show_object_size <- getOption("vsc.show_object_size", FALSE) - object_length_limit <- getOption("vsc.object_length_limit", 2000) - object_timeout <- getOption("vsc.object_timeout", 50) / 1000 - str_max_level <- getOption("vsc.str.max.level", 0) - objs <- lapply(all_names, function(name) { - if (isTRUE(is_promise[name])) { - info <- list( - class = "promise", - type = scalar("promise"), - length = scalar(0L), - str = scalar("(promise)") - ) - } else if (isTRUE(is_active[name])) { - info <- list( - class = "active_binding", - type = scalar("active_binding"), - length = scalar(0L), - str = scalar("(active-binding)") - ) - } else { - obj <- env[[name]] - - info <- list( - class = class(obj), - type = scalar(typeof(obj)), - length = scalar(length(obj)) - ) - - if (show_object_size) { - addr <- address(obj) - cobj <- cache[[name]] - if (is.null(cobj) || cobj$address != addr || cobj$length != info$length) { - cache[[name]] <- cobj <- list( - address = addr, - length = length(obj), - size = unclass(object.size(obj)) - ) - } - info$size <- scalar(cobj$size) - } - - if (length(obj) > object_length_limit) { - info$str <- scalar(trimws(try_capture_str(obj, 0))) - } else { - info_str <- NULL - if (str_max_level > 0) { - info_str <- try_catch_timeout( - capture_str(obj, str_max_level), - timeout = object_timeout, - error = function(e) NULL - ) - } - if (is.null(info_str)) { - info_str <- try_capture_str(obj, 0) - } - info$str <- scalar(trimws(info_str)) - obj_names <- if (is.object(obj)) { - .DollarNames(obj, pattern = "") - } else if (is.recursive(obj)) { - names(obj) + all_names <- ls(env) + rm(list = setdiff(names(globalenv_cache), all_names), envir = cache) + is_active <- vapply(all_names, bindingIsActive, logical(1), USE.NAMES = TRUE, env) + is_promise <- rlang::env_binding_are_lazy(env, all_names[!is_active]) + show_object_size <- getOption("vsc.show_object_size", FALSE) + object_length_limit <- getOption("vsc.object_length_limit", 2000) + object_timeout <- getOption("vsc.object_timeout", 50) / 1000 + str_max_level <- getOption("vsc.str.max.level", 0) + objs <- lapply(all_names, function(name) { + if (isTRUE(is_promise[name])) { + info <- list( + class = "promise", + type = scalar("promise"), + length = scalar(0L), + str = scalar("(promise)") + ) + } else if (isTRUE(is_active[name])) { + info <- list( + class = "active_binding", + type = scalar("active_binding"), + length = scalar(0L), + str = scalar("(active-binding)") + ) } else { - NULL - } + obj <- env[[name]] - if (length(obj_names)) { - info$names <- obj_names - } - } + info <- list( + class = class(obj), + type = scalar(typeof(obj)), + length = scalar(length(obj)) + ) - if (isS4(obj)) { - info$slots <- slotNames(obj) - } + if (show_object_size) { + addr <- address(obj) + cobj <- cache[[name]] + if (is.null(cobj) || cobj$address != addr || cobj$length != info$length) { + cache[[name]] <- cobj <- list( + address = addr, + length = length(obj), + size = unclass(object.size(obj)) + ) + } + info$size <- scalar(cobj$size) + } - if (!is.null(dim(obj))) { - info$dim <- dim(obj) - } - } - info - }) - names(objs) <- all_names - objs + if (length(obj) > object_length_limit) { + info$str <- scalar(trimws(try_capture_str(obj, 0))) + } else { + info_str <- NULL + if (str_max_level > 0) { + info_str <- try_catch_timeout( + capture_str(obj, str_max_level), + timeout = object_timeout, + error = function(e) NULL + ) + } + if (is.null(info_str)) { + info_str <- try_capture_str(obj, 0) + } + info$str <- scalar(trimws(info_str)) + obj_names <- if (is.object(obj)) { + .DollarNames(obj, pattern = "") + } else if (is.recursive(obj)) { + names(obj) + } else { + NULL + } + + if (length(obj_names)) { + info$names <- obj_names + } + } + + if (isS4(obj)) { + info$slots <- slotNames(obj) + } + + if (!is.null(dim(obj))) { + info$dim <- dim(obj) + } + } + info + }) + names(objs) <- all_names + objs } dir_session <- file.path(tempdir, "vscode-R") @@ -363,16 +364,16 @@ workspace_lock_file <- file.path(dir_session, "workspace.lock") file.create(workspace_lock_file, showWarnings = FALSE) update_workspace <- function(...) { - tryCatch({ - data <- list( - search = search()[-1], - loaded_namespaces = loadedNamespaces(), - globalenv = if (show_globalenv) inspect_env(.GlobalEnv, globalenv_cache) else NULL - ) - jsonlite::write_json(data, workspace_file, force = TRUE, pretty = FALSE) - cat(get_timestamp(), file = workspace_lock_file) - }, error = message) - TRUE + tryCatch({ + data <- list( + search = search()[-1], + loaded_namespaces = loadedNamespaces(), + globalenv = if (show_globalenv) inspect_env(.GlobalEnv, globalenv_cache) else NULL + ) + jsonlite::write_json(data, workspace_file, force = TRUE, pretty = FALSE) + cat(get_timestamp(), file = workspace_lock_file) + }, error = message) + TRUE } update_workspace() addTaskCallback(update_workspace, name = "vsc.workspace") @@ -381,552 +382,560 @@ removeTaskCallback("vsc.plot") use_httpgd <- identical(getOption("vsc.use_httpgd", FALSE), TRUE) show_plot <- !identical(getOption("vsc.plot", "Two"), FALSE) if (use_httpgd && "httpgd" %in% .packages(all.available = TRUE)) { - options(device = function(...) { - httpgd::hgd( - silent = TRUE - ) - .vsc$request("httpgd", url = httpgd::hgd_url()) - }) + options(device = function(...) { + httpgd::hgd( + silent = TRUE + ) + .vsc$request("httpgd", url = httpgd::hgd_url()) + }) } else if (use_httpgd) { - message("Install package `httpgd` to use vscode-R with httpgd!") + message("Install package `httpgd` to use vscode-R with httpgd!") } else if (show_plot) { - plot_file <- file.path(dir_session, "plot.png") - plot_lock_file <- file.path(dir_session, "plot.lock") - file.create(plot_file, plot_lock_file, showWarnings = FALSE) - - plot_updated <- FALSE - null_dev_id <- c(pdf = 2L) - null_dev_size <- c(7 + pi, 7 + pi) - - check_null_dev <- function() { - identical(dev.cur(), null_dev_id) && - identical(dev.size(), null_dev_size) - } - - new_plot <- function() { - if (check_null_dev()) { - plot_updated <<- TRUE - } - } - - options( - device = function(...) { - pdf(NULL, - width = null_dev_size[[1L]], - height = null_dev_size[[2L]], - bg = "white") - dev.control(displaylist = "enable") + plot_file <- file.path(dir_session, "plot.png") + plot_lock_file <- file.path(dir_session, "plot.lock") + file.create(plot_file, plot_lock_file, showWarnings = FALSE) + + plot_updated <- FALSE + null_dev_id <- c(pdf = 2L) + null_dev_size <- c(7 + pi, 7 + pi) + + check_null_dev <- function() { + identical(dev.cur(), null_dev_id) && + identical(dev.size(), null_dev_size) } - ) - update_plot <- function(...) { - tryCatch({ - if (plot_updated && check_null_dev()) { - plot_updated <<- FALSE - record <- recordPlot() - if (length(record[[1L]])) { - dev_args <- getOption("vsc.dev.args") - do.call(png, c(list(filename = plot_file), dev_args)) - on.exit({ - dev.off() - cat(get_timestamp(), file = plot_lock_file) - }) - replayPlot(record) + new_plot <- function() { + if (check_null_dev()) { + plot_updated <<- TRUE } - } - }, error = message) - TRUE - } + } - setHook("plot.new", new_plot, "replace") - setHook("grid.newpage", new_plot, "replace") + options( + device = function(...) { + pdf(NULL, + width = null_dev_size[[1L]], + height = null_dev_size[[2L]], + bg = "white") + dev.control(displaylist = "enable") + } + ) - rebind(".External.graphics", function(...) { - out <- .Primitive(".External.graphics")(...) - if (check_null_dev()) { - plot_updated <<- TRUE + update_plot <- function(...) { + tryCatch({ + if (plot_updated && check_null_dev()) { + plot_updated <<- FALSE + record <- recordPlot() + if (length(record[[1L]])) { + dev_args <- getOption("vsc.dev.args") + do.call(png, c(list(filename = plot_file), dev_args)) + on.exit({ + dev.off() + cat(get_timestamp(), file = plot_lock_file) + }) + replayPlot(record) + } + } + }, error = message) + TRUE } - out - }, "base") - update_plot() - addTaskCallback(update_plot, name = "vsc.plot") + setHook("plot.new", new_plot, "replace") + setHook("grid.newpage", new_plot, "replace") + + rebind(".External.graphics", function(...) { + out <- .Primitive(".External.graphics")(...) + if (check_null_dev()) { + plot_updated <<- TRUE + } + out + }, "base") + + update_plot() + addTaskCallback(update_plot, name = "vsc.plot") } show_view <- !identical(getOption("vsc.view", "Two"), FALSE) if (show_view) { - get_column_def <- function(name, field, value) { - filter <- TRUE - tooltip <- sprintf( - "%s, class: [%s], type: %s", - name, - toString(class(value)), - typeof(value) - ) - if (is.numeric(value)) { - type <- "numericColumn" - if (is.null(attr(value, "class"))) { - filter <- "agNumberColumnFilter" - } - } else if (inherits(value, "Date")) { - type <- "dateColumn" - filter <- "agDateColumnFilter" - } else { - type <- "textColumn" - filter <- "agTextColumnFilter" + get_column_def <- function(name, field, value) { + filter <- TRUE + tooltip <- sprintf( + "%s, class: [%s], type: %s", + name, + toString(class(value)), + typeof(value) + ) + if (is.numeric(value)) { + type <- "numericColumn" + if (is.null(attr(value, "class"))) { + filter <- "agNumberColumnFilter" + } + } else if (inherits(value, "Date")) { + type <- "dateColumn" + filter <- "agDateColumnFilter" + } else { + type <- "textColumn" + filter <- "agTextColumnFilter" + } + list( + headerName = name, + headerTooltip = tooltip, + field = field, + type = type, + filter = filter + ) } - list( - headerName = name, - headerTooltip = tooltip, - field = field, - type = type, - filter = filter - ) - } - dataview_table <- function(data) { - if (is.matrix(data)) { - data <- as.data.frame.matrix(data) - } + dataview_table <- function(data) { + if (is.matrix(data)) { + data <- as.data.frame.matrix(data) + } - if (is.data.frame(data)) { - .nrow <- nrow(data) - .colnames <- colnames(data) - if (is.null(.colnames)) { - .colnames <- sprintf("V%d", seq_len(ncol(data))) - } else { - .colnames <- trimws(.colnames) - } - if (.row_names_info(data) > 0L) { - rownames <- rownames(data) - rownames(data) <- NULL - } else { - rownames <- seq_len(.nrow) - } - .colnames <- c("(row)", .colnames) - fields <- sprintf("x%d", seq_along(.colnames)) - data <- c(list(" " = rownames), .subset(data)) - names(data) <- fields - class(data) <- "data.frame" - attr(data, "row.names") <- .set_row_names(.nrow) - columns <- .mapply(get_column_def, - list(.colnames, fields, data), - NULL - ) - list( - columns = columns, - data = data - ) - } else { - stop("data must be a data.frame or a matrix") - } - } - - show_dataview <- function(x, title, uuid = NULL, - viewer = getOption("vsc.view", "Two"), - row_limit = abs(getOption("vsc.row_limit", 0))) { - as_truncated_data <- function(.data) { - .nrow <- nrow(.data) - if (row_limit != 0 && row_limit < .nrow) { - title <<- sprintf("%s (limited to %d/%d)", title, row_limit, .nrow) - .data <- utils::head(.data, n = row_limit) - } - return(.data) + if (is.data.frame(data)) { + .nrow <- nrow(data) + .colnames <- colnames(data) + if (is.null(.colnames)) { + .colnames <- sprintf("V%d", seq_len(ncol(data))) + } else { + .colnames <- trimws(.colnames) + } + if (.row_names_info(data) > 0L) { + rownames <- rownames(data) + rownames(data) <- NULL + } else { + rownames <- seq_len(.nrow) + } + .colnames <- c("(row)", .colnames) + fields <- sprintf("x%d", seq_along(.colnames)) + data <- c(list(" " = rownames), .subset(data)) + names(data) <- fields + class(data) <- "data.frame" + attr(data, "row.names") <- .set_row_names(.nrow) + columns <- .mapply(get_column_def, + list(.colnames, fields, data), + NULL + ) + list( + columns = columns, + data = data + ) + } else { + stop("data must be a data.frame or a matrix") + } } - if (missing(title)) { - sub <- substitute(x) - title <- deparse(sub, nlines = 1) - } - if (inherits(x, "ArrowTabular")) { - x <- as_truncated_data(x) - x <- as.data.frame(x) - } - if (is.environment(x)) { - all_names <- ls(x) - is_active <- vapply(all_names, bindingIsActive, logical(1), USE.NAMES = TRUE, x) - is_promise <- rlang::env_binding_are_lazy(x, all_names[!is_active]) - x <- lapply(all_names, function(name) { - if (isTRUE(is_promise[name])) { - data.frame( - class = "promise", - type = "promise", - length = 0L, - size = 0L, - value = "(promise)", - stringsAsFactors = FALSE, - check.names = FALSE - ) - } else if (isTRUE(is_active[name])) { - data.frame( - class = "active_binding", - type = "active_binding", - length = 0L, - size = 0L, - value = "(active-binding)", - stringsAsFactors = FALSE, - check.names = FALSE - ) + show_dataview <- function(x, title, uuid = NULL, + viewer = getOption("vsc.view", "Two"), + row_limit = abs(getOption("vsc.row_limit", 0))) { + as_truncated_data <- function(.data) { + .nrow <- nrow(.data) + if (row_limit != 0 && row_limit < .nrow) { + title <<- sprintf("%s (limited to %d/%d)", title, row_limit, .nrow) + .data <- utils::head(.data, n = row_limit) + } + return(.data) + } + + if (missing(title)) { + sub <- substitute(x) + title <- deparse(sub, nlines = 1) + } + if (inherits(x, "ArrowTabular")) { + x <- as_truncated_data(x) + x <- as.data.frame(x) + } + if (is.environment(x)) { + all_names <- ls(x) + is_active <- vapply(all_names, bindingIsActive, logical(1), USE.NAMES = TRUE, x) + is_promise <- rlang::env_binding_are_lazy(x, all_names[!is_active]) + x <- lapply(all_names, function(name) { + if (isTRUE(is_promise[name])) { + data.frame( + class = "promise", + type = "promise", + length = 0L, + size = 0L, + value = "(promise)", + stringsAsFactors = FALSE, + check.names = FALSE + ) + } else if (isTRUE(is_active[name])) { + data.frame( + class = "active_binding", + type = "active_binding", + length = 0L, + size = 0L, + value = "(active-binding)", + stringsAsFactors = FALSE, + check.names = FALSE + ) + } else { + obj <- x[[name]] + data.frame( + class = paste0(class(obj), collapse = ", "), + type = typeof(obj), + length = length(obj), + size = as.integer(object.size(obj)), + value = trimws(try_capture_str(obj, 0)), + stringsAsFactors = FALSE, + check.names = FALSE + ) + } + }) + names(x) <- all_names + if (length(x)) { + x <- do.call(rbind, x) + } else { + x <- data.frame( + class = character(), + type = character(), + length = integer(), + size = integer(), + value = character(), + stringsAsFactors = FALSE, + check.names = FALSE + ) + } + } + if (is.data.frame(x) || is.matrix(x)) { + x <- as_truncated_data(x) + data <- dataview_table(x) + file <- tempfile(tmpdir = tempdir, fileext = ".json") + jsonlite::write_json(data, file, na = "string", null = "null", auto_unbox = TRUE, force = TRUE) + request("dataview", source = "table", type = "json", + title = title, file = file, viewer = viewer, uuid = uuid + ) + } else if (is.list(x)) { + tryCatch({ + file <- tempfile(tmpdir = tempdir, fileext = ".json") + jsonlite::write_json(x, file, na = "string", null = "null", auto_unbox = TRUE, force = TRUE) + request("dataview", source = "list", type = "json", + title = title, file = file, viewer = viewer, uuid = uuid + ) + }, error = function(e) { + file <- file.path(tempdir, paste0(make.names(title), ".txt")) + text <- utils::capture.output(print(x)) + writeLines(text, file) + request("dataview", source = "object", type = "txt", + title = title, file = file, viewer = viewer, uuid = uuid + ) + }) } else { - obj <- x[[name]] - data.frame( - class = paste0(class(obj), collapse = ", "), - type = typeof(obj), - length = length(obj), - size = as.integer(object.size(obj)), - value = trimws(try_capture_str(obj, 0)), - stringsAsFactors = FALSE, - check.names = FALSE - ) + file <- file.path(tempdir, paste0(make.names(title), ".R")) + if (is.primitive(x)) { + code <- utils::capture.output(print(x)) + } else { + code <- deparse(x) + } + writeLines(code, file) + request("dataview", source = "object", type = "R", + title = title, file = file, viewer = viewer, uuid = uuid + ) } - }) - names(x) <- all_names - if (length(x)) { - x <- do.call(rbind, x) - } else { - x <- data.frame( - class = character(), - type = character(), - length = integer(), - size = integer(), - value = character(), - stringsAsFactors = FALSE, - check.names = FALSE - ) - } - } - if (is.data.frame(x) || is.matrix(x)) { - x <- as_truncated_data(x) - data <- dataview_table(x) - file <- tempfile(tmpdir = tempdir, fileext = ".json") - jsonlite::write_json(data, file, na = "string", null = "null", auto_unbox = TRUE, force = TRUE) - request("dataview", source = "table", type = "json", - title = title, file = file, viewer = viewer, uuid = uuid) - } else if (is.list(x)) { - tryCatch({ - file <- tempfile(tmpdir = tempdir, fileext = ".json") - jsonlite::write_json(x, file, na = "string", null = "null", auto_unbox = TRUE, force = TRUE) - request("dataview", source = "list", type = "json", - title = title, file = file, viewer = viewer, uuid = uuid) - }, error = function(e) { - file <- file.path(tempdir, paste0(make.names(title), ".txt")) - text <- utils::capture.output(print(x)) - writeLines(text, file) - request("dataview", source = "object", type = "txt", - title = title, file = file, viewer = viewer, uuid = uuid) - }) - } else { - file <- file.path(tempdir, paste0(make.names(title), ".R")) - if (is.primitive(x)) { - code <- utils::capture.output(print(x)) - } else { - code <- deparse(x) - } - writeLines(code, file) - request("dataview", source = "object", type = "R", - title = title, file = file, viewer = viewer, uuid = uuid) } - } - rebind("View", show_dataview, "utils") + rebind("View", show_dataview, "utils") } attach <- function() { - load_settings() - if (rstudioapi_enabled()) { - rstudioapi_util_env$update_addin_registry(addin_registry) - } - request("attach", - version = sprintf("%s.%s", R.version$major, R.version$minor), - tempdir = tempdir, - info = list( - command = commandArgs()[[1L]], - version = R.version.string, - start_time = format(file.info(tempdir)$ctime) - ), - plot_url = if (identical(names(dev.cur()), "httpgd")) httpgd::hgd_url(), - server = if (use_webserver) list( - host = host, - port = port, - token = token - ) else NULL - ) + load_settings() + if (rstudioapi_enabled()) { + rstudioapi_util_env$update_addin_registry(addin_registry) + } + request("attach", + version = sprintf("%s.%s", R.version$major, R.version$minor), + tempdir = tempdir, + info = list( + command = commandArgs()[[1L]], + version = R.version.string, + start_time = format(file.info(tempdir)$ctime) + ), + plot_url = if (identical(names(dev.cur()), "httpgd")) httpgd::hgd_url(), + server = if (use_webserver) list( + host = host, + port = port, + token = token + ) else NULL + ) } path_to_uri <- function(path) { - if (length(path) == 0) { - return(character()) - } - path <- path.expand(path) - if (.Platform$OS.type == "windows") { - prefix <- "file:///" - path <- gsub("\\", "/", path, fixed = TRUE) - } else { - prefix <- "file://" - } - paste0(prefix, utils::URLencode(path)) + if (length(path) == 0) { + return(character()) + } + path <- path.expand(path) + if (.Platform$OS.type == "windows") { + prefix <- "file:///" + path <- gsub("\\", "/", path, fixed = TRUE) + } else { + prefix <- "file://" + } + paste0(prefix, utils::URLencode(path)) } request_browser <- function(url, title, ..., viewer) { - # Printing URL with specific port triggers - # auto port-forwarding under remote development - message("Browsing ", url) - request("browser", url = url, title = title, ..., viewer = viewer) + # Printing URL with specific port triggers + # auto port-forwarding under remote development + message("Browsing ", url) + request("browser", url = url, title = title, ..., viewer = viewer) } show_browser <- function(url, title = url, ..., viewer = getOption("vsc.browser", "Active")) { - proxy_uri <- Sys.getenv("VSCODE_PROXY_URI") - if (nzchar(proxy_uri)) { - is_base_path <- grepl("\\:\\d+$", url) - url <- sub("^https?\\://(127\\.0\\.0\\.1|localhost)(\\:)?", - sub("\\{\\{?port\\}\\}?/?", "", proxy_uri), url) - if (is_base_path) { - url <- paste0(url, "/") + proxy_uri <- Sys.getenv("VSCODE_PROXY_URI") + if (nzchar(proxy_uri)) { + is_base_path <- grepl("\\:\\d+$", url) + url <- sub("^https?\\://(127\\.0\\.0\\.1|localhost)(\\:)?", + sub("\\{\\{?port\\}\\}?/?", "", proxy_uri), url + ) + if (is_base_path) { + url <- paste0(url, "/") + } } - } - if (grepl("^https?\\://(127\\.0\\.0\\.1|localhost)(\\:\\d+)?", url)) { - request_browser(url = url, title = title, ..., viewer = viewer) - } else if (grepl("^https?\\://", url)) { - message( - if (nzchar(proxy_uri)) { - "VSCode is not running on localhost but on a remote server.\n" - } else { - "VSCode WebView only supports showing local http content.\n" - }, - "Opening in external browser..." - ) - request_browser(url = url, title = title, ..., viewer = FALSE) - } else { - path <- sub("^file\\://", "", url) - if (file.exists(path)) { - path <- normalizePath(path, "/", mustWork = TRUE) - if (grepl("\\.html?$", path, ignore.case = TRUE)) { + if (grepl("^https?\\://(127\\.0\\.0\\.1|localhost)(\\:\\d+)?", url)) { + request_browser(url = url, title = title, ..., viewer = viewer) + } else if (grepl("^https?\\://", url)) { message( - "VSCode WebView has restricted access to local file.\n", - "Opening in external browser..." + if (nzchar(proxy_uri)) { + "VSCode is not running on localhost but on a remote server.\n" + } else { + "VSCode WebView only supports showing local http content.\n" + }, + "Opening in external browser..." ) - request_browser(url = path_to_uri(path), - title = title, ..., viewer = FALSE) - } else { - request("dataview", source = "object", type = "txt", - title = title, file = path, viewer = viewer) - } + request_browser(url = url, title = title, ..., viewer = FALSE) } else { - stop("File not exists") + path <- sub("^file\\://", "", url) + if (file.exists(path)) { + path <- normalizePath(path, "/", mustWork = TRUE) + if (grepl("\\.html?$", path, ignore.case = TRUE)) { + message( + "VSCode WebView has restricted access to local file.\n", + "Opening in external browser..." + ) + request_browser(url = path_to_uri(path), + title = title, ..., viewer = FALSE + ) + } else { + request("dataview", source = "object", type = "txt", + title = title, file = path, viewer = viewer + ) + } + } else { + stop("File not exists") + } } - } } show_webview <- function(url, title, ..., viewer) { - if (!is.character(url)) { - real_url <- NULL - temp_viewer <- function(url, ...) { - real_url <<- url + if (!is.character(url)) { + real_url <- NULL + temp_viewer <- function(url, ...) { + real_url <<- url + } + op <- options(viewer = temp_viewer, page_viewer = temp_viewer) + on.exit(options(op)) + print(url) + if (is.character(real_url)) { + url <- real_url + } else { + stop("Invalid object") + } } - op <- options(viewer = temp_viewer, page_viewer = temp_viewer) - on.exit(options(op)) - print(url) - if (is.character(real_url)) { - url <- real_url - } else { - stop("Invalid object") + proxy_uri <- Sys.getenv("VSCODE_PROXY_URI") + if (nzchar(proxy_uri)) { + is_base_path <- grepl("\\:\\d+$", url) + url <- sub("^https?\\://(127\\.0\\.0\\.1|localhost)(\\:)?", + sub("\\{\\{?port\\}\\}?/?", "", proxy_uri), url + ) + if (is_base_path) { + url <- paste0(url, "/") + } } - } - proxy_uri <- Sys.getenv("VSCODE_PROXY_URI") - if (nzchar(proxy_uri)) { - is_base_path <- grepl("\\:\\d+$", url) - url <- sub("^https?\\://(127\\.0\\.0\\.1|localhost)(\\:)?", - sub("\\{\\{?port\\}\\}?/?", "", proxy_uri), url) - if (is_base_path) { - url <- paste0(url, "/") + if (grepl("^https?\\://(127\\.0\\.0\\.1|localhost)(\\:\\d+)?", url)) { + request_browser(url = url, title = title, ..., viewer = viewer) + } else if (grepl("^https?\\://", url)) { + message( + if (nzchar(proxy_uri)) { + "VSCode is not running on localhost but on a remote server.\n" + } else { + "VSCode WebView only supports showing local http content.\n" + }, + "Opening in external browser..." + ) + request_browser(url = url, title = title, ..., viewer = FALSE) + } else if (file.exists(url)) { + file <- normalizePath(url, "/", mustWork = TRUE) + request("webview", file = file, title = title, viewer = viewer, ...) + } else { + stop("File not exists") } - } - if (grepl("^https?\\://(127\\.0\\.0\\.1|localhost)(\\:\\d+)?", url)) { - request_browser(url = url, title = title, ..., viewer = viewer) - } else if (grepl("^https?\\://", url)) { - message( - if (nzchar(proxy_uri)) { - "VSCode is not running on localhost but on a remote server.\n" - } else { - "VSCode WebView only supports showing local http content.\n" - }, - "Opening in external browser..." - ) - request_browser(url = url, title = title, ..., viewer = FALSE) - } else if (file.exists(url)) { - file <- normalizePath(url, "/", mustWork = TRUE) - request("webview", file = file, title = title, viewer = viewer, ...) - } else { - stop("File not exists") - } } show_viewer <- function(url, title = NULL, ..., viewer = getOption("vsc.viewer", "Two")) { - if (is.null(title)) { - expr <- substitute(url) - if (is.character(url)) { - title <- "Viewer" - } else { - title <- deparse(expr, nlines = 1) + if (is.null(title)) { + expr <- substitute(url) + if (is.character(url)) { + title <- "Viewer" + } else { + title <- deparse(expr, nlines = 1) + } } - } - show_webview(url = url, title = title, ..., viewer = viewer) + show_webview(url = url, title = title, ..., viewer = viewer) } show_page_viewer <- function(url, title = NULL, ..., viewer = getOption("vsc.page_viewer", "Active")) { - if (is.null(title)) { - expr <- substitute(url) - if (is.character(url)) { - title <- "Page Viewer" - } else { - title <- deparse(expr, nlines = 1) + if (is.null(title)) { + expr <- substitute(url) + if (is.character(url)) { + title <- "Page Viewer" + } else { + title <- deparse(expr, nlines = 1) + } } - } - show_webview(url = url, title = title, ..., viewer = viewer) + show_webview(url = url, title = title, ..., viewer = viewer) } options( - browser = show_browser, - viewer = show_viewer, - page_viewer = show_page_viewer + browser = show_browser, + viewer = show_viewer, + page_viewer = show_page_viewer ) # rstudioapi rstudioapi_enabled <- function() { - isTRUE(getOption("vsc.rstudioapi", TRUE)) + isTRUE(getOption("vsc.rstudioapi", TRUE)) } if (rstudioapi_enabled()) { - response_timeout <- 5 - response_lock_file <- file.path(dir_session, "response.lock") - response_file <- file.path(dir_session, "response.log") - file.create(response_lock_file, showWarnings = FALSE) - file.create(response_file, showWarnings = FALSE) - addin_registry <- file.path(dir_session, "addins.json") - # This is created in attach() - - get_response_timestamp <- function() { - readLines(response_lock_file) - } - # initialise the reponse timestamp to empty string - response_time_stamp <- "" - - get_response_lock <- function() { - lock_time_stamp <- get_response_timestamp() - if (isTRUE(lock_time_stamp != response_time_stamp)) { - response_time_stamp <<- lock_time_stamp - TRUE - } else { - FALSE + response_timeout <- 5 + response_lock_file <- file.path(dir_session, "response.lock") + response_file <- file.path(dir_session, "response.log") + file.create(response_lock_file, showWarnings = FALSE) + file.create(response_file, showWarnings = FALSE) + addin_registry <- file.path(dir_session, "addins.json") + # This is created in attach() + + get_response_timestamp <- function() { + readLines(response_lock_file) } - } - - request_response <- function(command, ...) { - request(command, ..., sd = dir_session) - wait_start <- Sys.time() - while (!get_response_lock()) { - if ((Sys.time() - wait_start) > response_timeout) { - stop( - "Did not receive a response from VSCode-R API within ", - response_timeout, " seconds." - ) - } - Sys.sleep(0.1) + # initialise the reponse timestamp to empty string + response_time_stamp <- "" + + get_response_lock <- function() { + lock_time_stamp <- get_response_timestamp() + if (isTRUE(lock_time_stamp != response_time_stamp)) { + response_time_stamp <<- lock_time_stamp + TRUE + } else { + FALSE + } } - jsonlite::read_json(response_file) - } - - rstudioapi_util_env <- new.env() - rstudioapi_env <- new.env(parent = rstudioapi_util_env) - source(file.path(dir_init, "rstudioapi_util.R"), local = rstudioapi_util_env) - source(file.path(dir_init, "rstudioapi.R"), local = rstudioapi_env) - setHook( - packageEvent("rstudioapi", "onLoad"), - function(...) { - rstudioapi_util_env$rstudioapi_patch_hook(rstudioapi_env) + + request_response <- function(command, ...) { + request(command, ..., sd = dir_session) + wait_start <- Sys.time() + while (!get_response_lock()) { + if ((Sys.time() - wait_start) > response_timeout) { + stop( + "Did not receive a response from VSCode-R API within ", + response_timeout, " seconds." + ) + } + Sys.sleep(0.1) + } + jsonlite::read_json(response_file) + } + + rstudioapi_util_env <- new.env() + rstudioapi_env <- new.env(parent = rstudioapi_util_env) + source(file.path(dir_init, "rstudioapi_util.R"), local = rstudioapi_util_env) + source(file.path(dir_init, "rstudioapi.R"), local = rstudioapi_env) + setHook( + packageEvent("rstudioapi", "onLoad"), + function(...) { + rstudioapi_util_env$rstudioapi_patch_hook(rstudioapi_env) + } + ) + if ("rstudioapi" %in% loadedNamespaces()) { + # if the rstudioapi is already loaded, for example via a call to + # library(tidyverse) in the user's profile, we need to shim it now. + # There's no harm in having also registered the hook in this case. It can + # work in the event that the namespace is unloaded and reloaded. + rstudioapi_util_env$rstudioapi_patch_hook(rstudioapi_env) } - ) - if ("rstudioapi" %in% loadedNamespaces()) { - # if the rstudioapi is already loaded, for example via a call to - # library(tidyverse) in the user's profile, we need to shim it now. - # There's no harm in having also registered the hook in this case. It can - # work in the event that the namespace is unloaded and reloaded. - rstudioapi_util_env$rstudioapi_patch_hook(rstudioapi_env) - } } print.help_files_with_topic <- function(h, ...) { - viewer <- getOption("vsc.helpPanel", "Two") - if (!identical(FALSE, viewer) && length(h) >= 1 && is.character(h)) { - file <- h[1] - path <- dirname(file) - dirpath <- dirname(path) - pkgname <- basename(dirpath) - requestPath <- paste0( - "/library/", - pkgname, - "/html/", - basename(file), - ".html" - ) - request(command = "help", requestPath = requestPath, viewer = viewer) - } else { - utils:::print.help_files_with_topic(h, ...) - } - invisible(h) + viewer <- getOption("vsc.helpPanel", "Two") + if (!identical(FALSE, viewer) && length(h) >= 1 && is.character(h)) { + file <- h[1] + path <- dirname(file) + dirpath <- dirname(path) + pkgname <- basename(dirpath) + requestPath <- paste0( + "/library/", + pkgname, + "/html/", + basename(file), + ".html" + ) + request(command = "help", requestPath = requestPath, viewer = viewer) + } else { + utils:::print.help_files_with_topic(h, ...) + } + invisible(h) } print.hsearch <- function(x, ...) { - viewer <- getOption("vsc.helpPanel", "Two") - if (!identical(FALSE, viewer) && length(x) >= 1) { - requestPath <- paste0( - "/doc/html/Search?pattern=", - tools:::escapeAmpersand(x$pattern), - paste0("&fields.", x$fields, "=1", - collapse = "" - ), - if (!is.null(x$agrep)) paste0("&agrep=", x$agrep), - if (!x$ignore.case) "&ignore.case=0", - if (!identical( - x$types, - getOption("help.search.types") - )) { - paste0("&types.", x$types, "=1", - collapse = "" - ) - }, - if (!is.null(x$package)) { - paste0( - "&package=", - paste(x$package, collapse = ";") - ) - }, - if (!identical(x$lib.loc, .libPaths())) { - paste0( - "&lib.loc=", - paste(x$lib.loc, collapse = ";") + viewer <- getOption("vsc.helpPanel", "Two") + if (!identical(FALSE, viewer) && length(x) >= 1) { + requestPath <- paste0( + "/doc/html/Search?pattern=", + tools:::escapeAmpersand(x$pattern), + paste0("&fields.", x$fields, "=1", + collapse = "" + ), + if (!is.null(x$agrep)) paste0("&agrep=", x$agrep), + if (!x$ignore.case) "&ignore.case=0", + if (!identical( + x$types, + getOption("help.search.types") + )) { + paste0("&types.", x$types, "=1", + collapse = "" + ) + }, + if (!is.null(x$package)) { + paste0( + "&package=", + paste(x$package, collapse = ";") + ) + }, + if (!identical(x$lib.loc, .libPaths())) { + paste0( + "&lib.loc=", + paste(x$lib.loc, collapse = ";") + ) + } ) - } - ) - request(command = "help", requestPath = requestPath, viewer = viewer) - } else { - utils:::print.hsearch(x, ...) - } - invisible(x) + request(command = "help", requestPath = requestPath, viewer = viewer) + } else { + utils:::print.hsearch(x, ...) + } + invisible(x) } # a copy of .S3method(), since this function is new in R 4.0 .S3method <- function(generic, class, method) { - if (missing(method)) { - method <- paste(generic, class, sep = ".") - } - method <- match.fun(method) - registerS3method(generic, class, method, envir = parent.frame()) - invisible(NULL) + if (missing(method)) { + method <- paste(generic, class, sep = ".") + } + method <- match.fun(method) + registerS3method(generic, class, method, envir = parent.frame()) + invisible(NULL) } reg.finalizer(.GlobalEnv, function(e) .vsc$request("detach"), onexit = TRUE)