From b4fb23783bdbea917b2a44ea2f244d9556fd82f6 Mon Sep 17 00:00:00 2001 From: eitsupi Date: Sat, 14 Nov 2026 07:02:23 +0000 Subject: [PATCH 1/4] chore: add Arity to format and lint R code Add arity-cli as a pinned dev dependency with format:r, format:r:check and lint:r scripts. Layout is now owned by the formatter, so drop the line length and indentation linters from the lintr configuration. --- R/.lintr | 4 +-- arity.toml | 27 ++++++++++++++ package.json | 4 +++ pnpm-lock.yaml | 95 ++++++++++++++++++++++++++++++++++++++++++++++++++ sess/.lintr | 3 +- 5 files changed, 130 insertions(+), 3 deletions(-) create mode 100644 arity.toml diff --git a/R/.lintr b/R/.lintr index c86c3fa1d..642615877 100644 --- a/R/.lintr +++ b/R/.lintr @@ -1,6 +1,6 @@ linters: linters_with_defaults( - line_length_linter(120), - indentation_linter(4), + line_length_linter = NULL, + indentation_linter = NULL, return_linter = NULL, object_name_linter = NULL, object_usage_linter = NULL) diff --git a/arity.toml b/arity.toml new file mode 100644 index 000000000..2eb2d1a92 --- /dev/null +++ b/arity.toml @@ -0,0 +1,27 @@ +# Arity formats and lints the R sources (R/, sess/, and R scripts elsewhere). +# See https://arity.cc/reference/configuration.html + +[format] +# Same width as the TypeScript sources (see .oxfmtrc.jsonc). +line-width = 100 +# Build scripts rewrite sess/DESCRIPTION, so keep its layout as is. +description = false + +[lint] +ignore = [ + # Test files rely on names attached by tinytest, and helper scripts are + # combined with source(), so cross-file names cannot be resolved statically. + # lintr's object_usage_linter is disabled for the same reason. + "undefined-symbol", + "unused-binding", + # `%||%` is only in base R since 4.4; the scripts run on the user's R. + "coalesce", + # Calls to unexported functions with `:::` are deliberate here. + "internal-function", + # Existing findings that are not addressed yet. + "roxygen-param", + "roxygen-return", + "shadowed-builtin", + "string-boundary", + "unnecessary-nesting", +] diff --git a/package.json b/package.json index ce682997c..ee442d263 100644 --- a/package.json +++ b/package.json @@ -2606,6 +2606,9 @@ "lint": "oxlint src", "format": "oxfmt .", "format:check": "oxfmt --check .", + "format:r": "arity format .", + "format:r:check": "arity format --check .", + "lint:r": "arity lint .", "typecheck": "tsc --noEmit -p ./", "test:sess-identity": "Rscript --vanilla R/tests/sess_source.R", "test:sess-attach": "Rscript --vanilla R/tests/attach_sess.R", @@ -2627,6 +2630,7 @@ "@vscode/test-cli": "^0.0.15", "@vscode/test-electron": "^3.1.0", "@vscode/vsce": "^4.1.0", + "arity-cli": "0.29.0", "esbuild": "^0.28.1", "git-cliff": "^2.14.2", "mocha": "^12.0.3", diff --git a/pnpm-lock.yaml b/pnpm-lock.yaml index 73ba892ef..533d58000 100644 --- a/pnpm-lock.yaml +++ b/pnpm-lock.yaml @@ -63,6 +63,9 @@ importers: '@vscode/vsce': specifier: ^4.1.0 version: 4.1.0(supports-color@8.1.1) + arity-cli: + specifier: 0.29.0 + version: 0.29.0 esbuild: specifier: ^0.28.1 version: 0.28.2 @@ -93,6 +96,58 @@ importers: packages: + '@arity-cli/darwin-arm64@0.29.0': + resolution: {integrity: sha512-0OV9CpFsrrcWmBZjPi3qAUy03lFhEpN73e9/eqqDzq3+qFrMqV3HtGJdiMkZpKToN59RHIMtHQLf3QidHUjRrg==} + engines: {node: '>=20'} + cpu: [arm64] + os: [darwin] + + '@arity-cli/darwin-x64@0.29.0': + resolution: {integrity: sha512-sFcALesMOnCSTVCzIvoYUkAolXlXZ7S5fJk+vLEmmayfUqtE6kcpm42L7dkAedRygdS3b4Pf8xPBRFc2Hs1ucw==} + engines: {node: '>=20'} + cpu: [x64] + os: [darwin] + + '@arity-cli/linux-arm64-gnu@0.29.0': + resolution: {integrity: sha512-UFFXYocWS52d5lFbd3ZmmnkawJbzyB64M4oSQjbmQVsZGcYuWTzgUTZ5KhkCLrGRMv9gAiNDnQJOfmK7UZXzmQ==} + engines: {node: '>=20'} + cpu: [arm64] + os: [linux] + libc: [glibc] + + '@arity-cli/linux-arm64-musl@0.29.0': + resolution: {integrity: sha512-dP1ZDobRuywgVyId2C/xZgcqfdBSNa+AwXtnrSmo+jkx1TmrFvGWCloCMYDSkM+uA0FUc0v37jbj+qZ5V6pN7Q==} + engines: {node: '>=20'} + cpu: [arm64] + os: [linux] + libc: [musl] + + '@arity-cli/linux-x64-gnu@0.29.0': + resolution: {integrity: sha512-KaotYKGfl0tM/Ko7HifoAcYK8H9dB56EQw6i6yLwLTjFx9IMNeAb/hCIIV8k3TTZryGa8Tkb/3Fkd71SJdbz2w==} + engines: {node: '>=20'} + cpu: [x64] + os: [linux] + libc: [glibc] + + '@arity-cli/linux-x64-musl@0.29.0': + resolution: {integrity: sha512-FyggDNp4BLLzW2O7F3QPnhaNACuO6uZTLqkOo5lRvHAKaf8K55whMw9M0v6DjUZVA5g0VVWudIDEFZD++xKCjA==} + engines: {node: '>=20'} + cpu: [x64] + os: [linux] + libc: [musl] + + '@arity-cli/win32-arm64@0.29.0': + resolution: {integrity: sha512-B98IszHLUzozi7HHORnsXI3Q89FQPXk2ug4A/Th/1irjPFJs1Oo2rv46/JteTNczAg9n5/uEQW929QgClhzi6g==} + engines: {node: '>=20'} + cpu: [arm64] + os: [win32] + + '@arity-cli/win32-x64@0.29.0': + resolution: {integrity: sha512-KYwTtDi9aQO0g29ODE3JCb3EF52eVS6woVvNxVbXUQBoHlDdlqwxbAOIrkNW6pFylYltxZYNiAaGypXEIFxP1w==} + engines: {node: '>=20'} + cpu: [x64] + os: [win32] + '@azure/abort-controller@2.2.0': resolution: {integrity: sha512-fNAjWnA/nZ2jz31kxR/AqRaUT8ewHBw/WuBIosK0moMy1C9e5ValbDfFdIxJzVOOYaYkV/b2F1S4H/aHiqfVQg==} engines: {node: '>=22.0.0'} @@ -1186,6 +1241,11 @@ packages: argparse@3.0.3: resolution: {integrity: sha512-Sn98ftV3KfsO8xfLPHG6oT8y+b0yvbrLgZjgPDXsharNY15tTAjqIsIju4S32nl6/iEUNNE4v+yL2Zhm8ooP3w==} + arity-cli@0.29.0: + resolution: {integrity: sha512-mjoNW1FRi0lyGq2fmvgXxma6qsl+dYjPY82EXW/RDxAEPNIUFOgozjp8NZDj0uLDkXs0GKU+fymD2cTQKH5PWQ==} + engines: {node: '>=20'} + hasBin: true + azure-devops-node-api@12.5.0: resolution: {integrity: sha512-R5eFskGvOm3U/GzeAuxRkUsAl0hrAwGgWn6zAd2KrZmrEhWZVqLew4OOupbQlXUuojUzpGtq62SmdhJ06N88og==} @@ -2346,6 +2406,30 @@ packages: snapshots: + '@arity-cli/darwin-arm64@0.29.0': + optional: true + + '@arity-cli/darwin-x64@0.29.0': + optional: true + + '@arity-cli/linux-arm64-gnu@0.29.0': + optional: true + + '@arity-cli/linux-arm64-musl@0.29.0': + optional: true + + '@arity-cli/linux-x64-gnu@0.29.0': + optional: true + + '@arity-cli/linux-x64-musl@0.29.0': + optional: true + + '@arity-cli/win32-arm64@0.29.0': + optional: true + + '@arity-cli/win32-x64@0.29.0': + optional: true + '@azure/abort-controller@2.2.0': dependencies: tslib: 2.8.1 @@ -3147,6 +3231,17 @@ snapshots: argparse@3.0.3: {} + arity-cli@0.29.0: + optionalDependencies: + '@arity-cli/darwin-arm64': 0.29.0 + '@arity-cli/darwin-x64': 0.29.0 + '@arity-cli/linux-arm64-gnu': 0.29.0 + '@arity-cli/linux-arm64-musl': 0.29.0 + '@arity-cli/linux-x64-gnu': 0.29.0 + '@arity-cli/linux-x64-musl': 0.29.0 + '@arity-cli/win32-arm64': 0.29.0 + '@arity-cli/win32-x64': 0.29.0 + azure-devops-node-api@12.5.0: dependencies: tunnel: 0.0.6 diff --git a/sess/.lintr b/sess/.lintr index a52d190b8..c52e14cc5 100644 --- a/sess/.lintr +++ b/sess/.lintr @@ -1,5 +1,6 @@ linters: linters_with_defaults( - line_length_linter = line_length_linter(100), + line_length_linter = NULL, + indentation_linter = NULL, object_usage_linter = NULL, object_length_linter = NULL, object_name_linter = NULL, From 55985fb6db919ebc672097efeac2d70965014b41 Mon Sep 17 00:00:00 2001 From: eitsupi Date: Sat, 14 Nov 2026 07:02:32 +0000 Subject: [PATCH 2/4] style: format R code with Arity Mechanical change from `pnpm run format:r`. The parsed code is unchanged apart from braces around single-expression bodies. --- R/attach_sess.R | 688 +++++---- R/cppProperties/extractLinkingTo.R | 17 +- R/help/getAliases.R | 48 +- R/help/helpServer.R | 43 +- R/help/rdToHtml.R | 20 +- R/install_sess.R | 127 +- R/interactive-metrics.R | 67 +- R/interactive-worker.R | 64 +- R/languageServer.R | 30 +- R/prepare-tools.R | 254 ++-- R/profile.R | 193 +-- R/rmarkdown/knit.R | 29 +- R/rmarkdown/preview.R | 75 +- R/rmarkdown/templates.R | 24 +- R/sess-package-install.R | 127 +- R/sess_source.R | 151 +- R/terminal-startup.R | 247 ++-- R/tests/attach_sess.R | 1030 +++++++------ R/tests/prepare-jgd.R | 1284 ++++++++++------- R/tests/prepare-rstudioapi.R | 687 +++++---- R/tests/sess_source.R | 316 ++-- R/tests/tool-consent.R | 292 ++-- R/tests/tool-library.R | 463 +++--- R/tool-consent.R | 304 ++-- R/tool-library.R | 604 +++++--- scripts/benchmark-workspace-refresh.R | 40 +- sess/R/dispatch.R | 29 +- sess/R/handlers.R | 734 ++++++---- sess/R/hooks.R | 304 ++-- sess/R/interactive.R | 375 +++-- sess/R/rstudioapi.R | 104 +- sess/R/runtime.R | 118 +- sess/R/server.R | 378 +++-- sess/R/zzz.R | 7 +- sess/bootstrap.R | 16 +- sess/inst/tinytest/test-attachment-metadata.R | 68 +- sess/inst/tinytest/test-connect-failure.R | 39 +- sess/inst/tinytest/test-connection-message.R | 53 +- .../tinytest/test-dataview-reproducibility.R | 23 +- sess/inst/tinytest/test-dataview.R | 233 ++- sess/inst/tinytest/test-httpgd-devices.R | 208 +-- sess/inst/tinytest/test-httpgd-version.R | 8 +- .../tinytest/test-interactive-large-table.R | 34 +- sess/inst/tinytest/test-interactive-output.R | 6 +- sess/inst/tinytest/test-ipc.R | 420 ++++-- sess/inst/tinytest/test-listview-format.R | 166 ++- sess/inst/tinytest/test-listview.R | 229 +-- sess/inst/tinytest/test-native-plot.R | 74 +- sess/inst/tinytest/test-plot-notification.R | 25 +- sess/inst/tinytest/test-plot-rendering.R | 50 +- sess/inst/tinytest/test-reconnect.R | 53 +- sess/inst/tinytest/test-rstudioapi-optional.R | 112 +- sess/inst/tinytest/test-runtime-devices.R | 105 +- sess/inst/tinytest/test-session-contract.R | 58 +- sess/inst/tinytest/test-workspace-refresh.R | 79 +- src/test/examples/large-table.R | 50 +- src/test/examples/sess-installer.R | 253 ++-- 57 files changed, 6850 insertions(+), 4785 deletions(-) diff --git a/R/attach_sess.R b/R/attach_sess.R index 54d107483..8fb3c8ee5 100644 --- a/R/attach_sess.R +++ b/R/attach_sess.R @@ -4,352 +4,408 @@ # Source the tool preparation helper into a fresh environment. Returns NULL # after reporting the failure when it cannot be loaded. vscode_r_load_prepare_helper <- function(helper, package) { - setup <- new.env(parent = environment(vscode_r_load_prepare_helper)) - loaded <- nzchar(helper) && file.exists(helper) && - isTRUE(tryCatch({ - sys.source(helper, envir = setup) - TRUE - }, error = function(error) { - message("vscode-R could not load managed ", package, " setup resources: ", - conditionMessage(error)) - FALSE - })) - if (loaded) setup else NULL + setup <- new.env(parent = environment(vscode_r_load_prepare_helper)) + loaded <- nzchar(helper) && + file.exists(helper) && + isTRUE(tryCatch( + { + sys.source(helper, envir = setup) + TRUE + }, + error = function(error) { + message( + "vscode-R could not load managed ", + package, + " setup resources: ", + conditionMessage(error) + ) + FALSE + } + )) + if (loaded) setup else NULL } vscode_r_with_jgd <- function( - plot_backend, - connect, - tool_prepare_helper = Sys.getenv("VSCODE_R_TOOL_PREPARE_HELPER", unset = ""), - tool_root = Sys.getenv("VSCODE_R_TOOL_ROOT", unset = ""), - tool_consent_directory = Sys.getenv("VSCODE_R_TOOL_CONSENT_DIRECTORY", unset = ""), - tool_library_helper = Sys.getenv("VSCODE_R_TOOL_LIBRARY_HELPER", unset = ""), - tool_consent_helper = Sys.getenv("VSCODE_R_TOOL_CONSENT_HELPER", unset = ""), - can_prompt = identical(Sys.getenv("VSCODE_R_JGD_CAN_PROMPT", unset = "TRUE"), "TRUE"), - minimum_version = Sys.getenv("VSCODE_R_JGD_MINIMUM_VERSION", unset = "") + plot_backend, + connect, + tool_prepare_helper = Sys.getenv("VSCODE_R_TOOL_PREPARE_HELPER", unset = ""), + tool_root = Sys.getenv("VSCODE_R_TOOL_ROOT", unset = ""), + tool_consent_directory = Sys.getenv("VSCODE_R_TOOL_CONSENT_DIRECTORY", unset = ""), + tool_library_helper = Sys.getenv("VSCODE_R_TOOL_LIBRARY_HELPER", unset = ""), + tool_consent_helper = Sys.getenv("VSCODE_R_TOOL_CONSENT_HELPER", unset = ""), + can_prompt = identical(Sys.getenv("VSCODE_R_JGD_CAN_PROMPT", unset = "TRUE"), "TRUE"), + minimum_version = Sys.getenv("VSCODE_R_JGD_MINIMUM_VERSION", unset = "") ) { - if (!is.function(connect)) stop("connect must be a function.", call. = FALSE) - if (!plot_backend %in% c("jgd", "auto")) { - return(connect(allow_jgd = TRUE)) - } - jgd_setup <- vscode_r_load_prepare_helper(tool_prepare_helper, "jgd") - if (!is.null(jgd_setup) && is.function(jgd_setup$vscode_r_connect_with_jgd)) { - return(jgd_setup$vscode_r_connect_with_jgd( - plot_backend, connect, tool_root, tool_consent_directory, - tool_library_helper, tool_consent_helper, can_prompt, minimum_version - )) - } - message("vscode-R could not load managed jgd setup resources; using the available plot fallback.") - connect(allow_jgd = FALSE) + if (!is.function(connect)) { + stop("connect must be a function.", call. = FALSE) + } + if (!plot_backend %in% c("jgd", "auto")) { + return(connect(allow_jgd = TRUE)) + } + jgd_setup <- vscode_r_load_prepare_helper(tool_prepare_helper, "jgd") + if (!is.null(jgd_setup) && is.function(jgd_setup$vscode_r_connect_with_jgd)) { + return(jgd_setup$vscode_r_connect_with_jgd( + plot_backend, + connect, + tool_root, + tool_consent_directory, + tool_library_helper, + tool_consent_helper, + can_prompt, + minimum_version + )) + } + message("vscode-R could not load managed jgd setup resources; using the available plot fallback.") + connect(allow_jgd = FALSE) } # Prepare rstudioapi before sess starts its emulation. Declining or failing only # prints a message; sess emulation stays enabled and patches rstudioapi # whenever it is loaded. Does nothing when emulation is disabled. vscode_r_with_rstudioapi <- function( - use_rstudioapi, - tool_prepare_helper = Sys.getenv("VSCODE_R_TOOL_PREPARE_HELPER", unset = ""), - tool_root = Sys.getenv("VSCODE_R_TOOL_ROOT", unset = ""), - tool_consent_directory = Sys.getenv("VSCODE_R_TOOL_CONSENT_DIRECTORY", unset = ""), - tool_library_helper = Sys.getenv("VSCODE_R_TOOL_LIBRARY_HELPER", unset = ""), - tool_consent_helper = Sys.getenv("VSCODE_R_TOOL_CONSENT_HELPER", unset = ""), - can_prompt = identical(Sys.getenv("VSCODE_R_RSTUDIOAPI_CAN_PROMPT", unset = "TRUE"), "TRUE"), - minimum_version = Sys.getenv("VSCODE_R_RSTUDIOAPI_MINIMUM_VERSION", unset = "") + use_rstudioapi, + tool_prepare_helper = Sys.getenv("VSCODE_R_TOOL_PREPARE_HELPER", unset = ""), + tool_root = Sys.getenv("VSCODE_R_TOOL_ROOT", unset = ""), + tool_consent_directory = Sys.getenv("VSCODE_R_TOOL_CONSENT_DIRECTORY", unset = ""), + tool_library_helper = Sys.getenv("VSCODE_R_TOOL_LIBRARY_HELPER", unset = ""), + tool_consent_helper = Sys.getenv("VSCODE_R_TOOL_CONSENT_HELPER", unset = ""), + can_prompt = identical(Sys.getenv("VSCODE_R_RSTUDIOAPI_CAN_PROMPT", unset = "TRUE"), "TRUE"), + minimum_version = Sys.getenv("VSCODE_R_RSTUDIOAPI_MINIMUM_VERSION", unset = "") ) { - if (identical(use_rstudioapi, FALSE)) { - return(invisible(FALSE)) - } - setup <- vscode_r_load_prepare_helper(tool_prepare_helper, "rstudioapi") - if (!is.null(setup) && is.function(setup$vscode_r_prepare_rstudioapi)) { - return(invisible(isTRUE(setup$vscode_r_prepare_rstudioapi( - use_rstudioapi, tool_root, tool_consent_directory, - tool_library_helper, tool_consent_helper, can_prompt, minimum_version - )))) - } - message("vscode-R could not load managed rstudioapi setup resources; continuing without it.") - invisible(FALSE) + if (identical(use_rstudioapi, FALSE)) { + return(invisible(FALSE)) + } + setup <- vscode_r_load_prepare_helper(tool_prepare_helper, "rstudioapi") + if (!is.null(setup) && is.function(setup$vscode_r_prepare_rstudioapi)) { + return(invisible(isTRUE(setup$vscode_r_prepare_rstudioapi( + use_rstudioapi, + tool_root, + tool_consent_directory, + tool_library_helper, + tool_consent_helper, + can_prompt, + minimum_version + )))) + } + message("vscode-R could not load managed rstudioapi setup resources; continuing without it.") + invisible(FALSE) } -vscode_r_prepare_sess <- function(pkg_path, managed_root, consent_dir, - source_helper, installer_helper, - timeout_seconds = 180, - setup_timeout_seconds = 300) { - source(source_helper, local = TRUE) - expected <- sess_source_revision(file.path(pkg_path, "DESCRIPTION")) - if (is.null(expected)) { - stop("Bundled sess has no valid source revision.") - } - runtime <- sess_runtime_identity() - managed_library <- sess_managed_library(managed_root, expected) +vscode_r_prepare_sess <- function( + pkg_path, + managed_root, + consent_dir, + source_helper, + installer_helper, + timeout_seconds = 180, + setup_timeout_seconds = 300 +) { + source(source_helper, local = TRUE) + expected <- sess_source_revision(file.path(pkg_path, "DESCRIPTION")) + if (is.null(expected)) { + stop("Bundled sess has no valid source revision.") + } + runtime <- sess_runtime_identity() + managed_library <- sess_managed_library(managed_root, expected) - loaded <- "sess" %in% loadedNamespaces() - if (loaded) { - loaded_revision <- sess_loaded_source_revision() - if (!identical(loaded_revision, expected)) { - stop(paste( - "A different sess namespace is already loaded.", - "Close this R session and start a new one before attaching the session watcher.", - "Reloading VS Code does not restart a persistent R session." - )) - } - ns <- asNamespace("sess") + loaded <- "sess" %in% loadedNamespaces() + if (loaded) { + loaded_revision <- sess_loaded_source_revision() + if (!identical(loaded_revision, expected)) { + stop(paste( + "A different sess namespace is already loaded.", + "Close this R session and start a new one before attaching the session watcher.", + "Reloading VS Code does not restart a persistent R session." + )) + } + ns <- asNamespace("sess") + } else { + library <- sess_find_source_library(expected, .libPaths()) + if (!is.null(library)) { + ns <- sess_load_namespace(library, expected) } else { - library <- sess_find_source_library(expected, .libPaths()) - if (!is.null(library)) { - ns <- sess_load_namespace(library, expected) + lock_parent <- dirname(managed_library) + dir.create(lock_parent, recursive = TRUE, showWarnings = FALSE) + if (!dir.exists(lock_parent) || file.access(lock_parent, 2L) != 0L) { + stop("The vscode-R managed sess setup directory is not writable.") + } + lock_path <- file.path(lock_parent, ".setup-lock") + # Keep lock ownership rules in sync with src/interactive/backends/sessPreparation.ts: + # mkdir claims atomically; only the owner releases via on.exit; timeout never clears a stale lock. + # This revision lock covers consent, install, and load; a follower without a ready copy does not prompt. + # Publish .ready with the source revision only after the exact namespace has loaded successfully. + lock_deadline <- Sys.time() + setup_timeout_seconds + lock_timeout_message <- paste( + "Timed out waiting for another sess setup. Its owner may have crashed;", + "retrying alone will not clear the stale lock. Remove", + shQuote(lock_path), + "only if its owner has exited, then retry." + ) + followed_setup <- FALSE + repeat { + acquired <- dir.create(lock_path, showWarnings = FALSE, mode = "0700") + if (isTRUE(acquired)) { + on.exit(unlink(lock_path, recursive = TRUE, force = TRUE), add = TRUE) + break + } + followed_setup <- TRUE + if (!file.exists(lock_path)) { + if (file.access(lock_parent, 2L) != 0L) { + stop("The vscode-R managed sess setup directory is not writable.") + } + if (Sys.time() >= lock_deadline) { + stop(lock_timeout_message) + } + Sys.sleep(0.1) + next + } + if (!dir.exists(lock_path)) { + stop("A file is blocking the vscode-R managed sess setup lock.") + } + if (Sys.time() >= lock_deadline) { + stop(lock_timeout_message) + } + Sys.sleep(0.1) + } + + ready_path <- file.path(lock_parent, ".ready") + ready_revision <- tryCatch( + readLines(ready_path, warn = FALSE, n = 2L), + warning = function(e) character(), + error = function(e) character() + ) + installed <- sess_find_source_library(expected, managed_library) + if ( + length(ready_revision) == 1L && identical(ready_revision, expected) && !is.null(installed) + ) { + ns <- sess_load_namespace(installed, expected) + } else if (followed_setup) { + return(NULL) + } else { + existing <- any(vapply( + .libPaths(), + function(library) file.exists(file.path(library, "sess", "DESCRIPTION")), + FALSE + )) + reason <- if (existing) { + "mismatch" } else { - lock_parent <- dirname(managed_library) - dir.create(lock_parent, recursive = TRUE, showWarnings = FALSE) - if (!dir.exists(lock_parent) || file.access(lock_parent, 2L) != 0L) { - stop("The vscode-R managed sess setup directory is not writable.") - } - lock_path <- file.path(lock_parent, ".setup-lock") - # Keep lock ownership rules in sync with src/interactive/backends/sessPreparation.ts: - # mkdir claims atomically; only the owner releases via on.exit; timeout never clears a stale lock. - # This revision lock covers consent, install, and load; a follower without a ready copy does not prompt. - # Publish .ready with the source revision only after the exact namespace has loaded successfully. - lock_deadline <- Sys.time() + setup_timeout_seconds - lock_timeout_message <- paste( - "Timed out waiting for another sess setup. Its owner may have crashed;", - "retrying alone will not clear the stale lock. Remove", - shQuote(lock_path), "only if its owner has exited, then retry." - ) - followed_setup <- FALSE - repeat { - acquired <- dir.create(lock_path, showWarnings = FALSE, mode = "0700") - if (isTRUE(acquired)) { - on.exit(unlink(lock_path, recursive = TRUE, force = TRUE), add = TRUE) - break - } - followed_setup <- TRUE - if (!file.exists(lock_path)) { - if (file.access(lock_parent, 2L) != 0L) { - stop("The vscode-R managed sess setup directory is not writable.") - } - if (Sys.time() >= lock_deadline) { - stop(lock_timeout_message) - } - Sys.sleep(0.1) - next - } - if (!dir.exists(lock_path)) { - stop("A file is blocking the vscode-R managed sess setup lock.") - } - if (Sys.time() >= lock_deadline) { - stop(lock_timeout_message) - } - Sys.sleep(0.1) - } + "missing" + } + if (!dir.exists(consent_dir)) { + stop( + "The extension's sess consent service is unavailable. Restart VS Code and try again." + ) + } + new_id_part <- function() { + temporary <- basename(tempfile(pattern = "request-", tmpdir = consent_dir)) + gsub("[^A-Za-z0-9_-]", "", sub("^request-", "", temporary)) + } + id <- paste0(new_id_part(), new_id_part()) + if (!grepl("^[A-Za-z0-9_-]{16,64}$", id)) { + stop("Could not create a unique sess installation request.") + } + request <- paste("vscode-r-sess-consent-v1", id, expected, runtime, reason, sep = "\n") + request_path <- file.path(consent_dir, paste0(id, ".request")) + response_path <- file.path(consent_dir, paste0(id, ".response")) + temporary_path <- tempfile(pattern = paste0(id, "-"), tmpdir = consent_dir) + on.exit(unlink(c(temporary_path, request_path, response_path)), add = TRUE) + writeLines(request, temporary_path, useBytes = TRUE) + if (.Platform$OS.type == "unix") { + Sys.chmod(temporary_path, "0600") + } + if (!file.rename(temporary_path, request_path)) { + stop("Could not request permission to install bundled sess.") + } - ready_path <- file.path(lock_parent, ".ready") - ready_revision <- tryCatch( - readLines(ready_path, warn = FALSE, n = 2L), - warning = function(e) character(), - error = function(e) character() + deadline <- Sys.time() + timeout_seconds + response <- "" + while (Sys.time() < deadline && dir.exists(consent_dir) && !nzchar(response)) { + if (file.exists(response_path)) { + lines <- tryCatch( + readLines(response_path, warn = FALSE, n = 2L), + error = function(e) character() ) - installed <- sess_find_source_library(expected, managed_library) - if (length(ready_revision) == 1L && identical(ready_revision, expected) && - !is.null(installed)) { - ns <- sess_load_namespace(installed, expected) - } else if (followed_setup) { - return(NULL) + if (length(lines) == 1L && lines %in% c("approve", "decline")) { + response <- lines } else { - existing <- any(vapply(.libPaths(), function(library) { - file.exists(file.path(library, "sess", "DESCRIPTION")) - }, FALSE)) - reason <- if (existing) { - "mismatch" - } else { - "missing" - } - if (!dir.exists(consent_dir)) { - stop("The extension's sess consent service is unavailable. Restart VS Code and try again.") - } - new_id_part <- function() { - temporary <- basename(tempfile(pattern = "request-", tmpdir = consent_dir)) - gsub("[^A-Za-z0-9_-]", "", sub("^request-", "", temporary)) - } - id <- paste0(new_id_part(), new_id_part()) - if (!grepl("^[A-Za-z0-9_-]{16,64}$", id)) { - stop("Could not create a unique sess installation request.") - } - request <- paste( - "vscode-r-sess-consent-v1", id, expected, runtime, reason, sep = "\n") - request_path <- file.path(consent_dir, paste0(id, ".request")) - response_path <- file.path(consent_dir, paste0(id, ".response")) - temporary_path <- tempfile(pattern = paste0(id, "-"), tmpdir = consent_dir) - on.exit(unlink(c(temporary_path, request_path, response_path)), add = TRUE) - writeLines(request, temporary_path, useBytes = TRUE) - if (.Platform$OS.type == "unix") { - Sys.chmod(temporary_path, "0600") - } - if (!file.rename(temporary_path, request_path)) { - stop("Could not request permission to install bundled sess.") - } - - deadline <- Sys.time() + timeout_seconds - response <- "" - while (Sys.time() < deadline && dir.exists(consent_dir) && !nzchar(response)) { - if (file.exists(response_path)) { - lines <- tryCatch( - readLines(response_path, warn = FALSE, n = 2L), - error = function(e) character()) - if (length(lines) == 1L && lines %in% c("approve", "decline")) { - response <- lines - } else { - stop("Invalid response to the sess installation request.") - } - } else { - Sys.sleep(0.2) - } - } - if (!identical(response, "approve")) { - message("Bundled sess was not installed. The session watcher was not attached.") - return(NULL) - } - - unlink(ready_path, force = TRUE) - ready_link <- Sys.readlink(ready_path) - if (file.exists(ready_path) || dir.exists(ready_path) || - (length(ready_link) && !is.na(ready_link) && nzchar(ready_link))) { - stop("Could not clear the previous vscode-R managed sess completion marker.") - } - configured <- getOption("repos") - repo <- if ("CRAN" %in% names(configured)) { - configured[["CRAN"]] - } else if (length(configured)) { - configured[[1L]] - } else { - "https://cloud.r-project.org" - } - if (!length(repo) || is.na(repo) || !nzchar(repo) || identical(repo, "@CRAN@")) { - repo <- "https://cloud.r-project.org" - } - dir.create(managed_library, recursive = TRUE, showWarnings = FALSE) - if (file.access(managed_library, 2L) != 0L) { - stop("The vscode-R managed sess library is not writable.") - } - installer <- new.env(parent = baseenv()) - sys.source(installer_helper, envir = installer) - installer$sess_install(pkg_path, managed_library, repo) - ns <- sess_load_namespace(managed_library, expected) - ready_temporary <- tempfile(pattern = ".ready-", tmpdir = lock_parent) - on.exit(unlink(ready_temporary), add = TRUE) - writeLines(expected, ready_temporary, useBytes = TRUE) - if (.Platform$OS.type == "unix") { - Sys.chmod(ready_temporary, "0600") - } - if (!file.rename(ready_temporary, ready_path)) { - stop("Could not publish the vscode-R managed sess completion marker.") - } + stop("Invalid response to the sess installation request.") } + } else { + Sys.sleep(0.2) + } + } + if (!identical(response, "approve")) { + message("Bundled sess was not installed. The session watcher was not attached.") + return(NULL) + } + + unlink(ready_path, force = TRUE) + ready_link <- Sys.readlink(ready_path) + if ( + file.exists(ready_path) || + dir.exists(ready_path) || + (length(ready_link) && !is.na(ready_link) && nzchar(ready_link)) + ) { + stop("Could not clear the previous vscode-R managed sess completion marker.") + } + configured <- getOption("repos") + repo <- if ("CRAN" %in% names(configured)) { + configured[["CRAN"]] + } else if (length(configured)) { + configured[[1L]] + } else { + "https://cloud.r-project.org" + } + if (!length(repo) || is.na(repo) || !nzchar(repo) || identical(repo, "@CRAN@")) { + repo <- "https://cloud.r-project.org" + } + dir.create(managed_library, recursive = TRUE, showWarnings = FALSE) + if (file.access(managed_library, 2L) != 0L) { + stop("The vscode-R managed sess library is not writable.") } + installer <- new.env(parent = baseenv()) + sys.source(installer_helper, envir = installer) + installer$sess_install(pkg_path, managed_library, repo) + ns <- sess_load_namespace(managed_library, expected) + ready_temporary <- tempfile(pattern = ".ready-", tmpdir = lock_parent) + on.exit(unlink(ready_temporary), add = TRUE) + writeLines(expected, ready_temporary, useBytes = TRUE) + if (.Platform$OS.type == "unix") { + Sys.chmod(ready_temporary, "0600") + } + if (!file.rename(ready_temporary, ready_path)) { + stop("Could not publish the vscode-R managed sess completion marker.") + } + } } + } - ns + ns } -vscode_r_attach_sess <- function(endpoint, pkg_path, managed_root, consent_dir, - source_helper, installer_helper, plot_backend, - timeout_seconds = 180, - setup_timeout_seconds = 300, - use_rstudioapi = TRUE, - attachment_id = NULL, - auto_activate = TRUE, - tool_root = Sys.getenv("VSCODE_R_TOOL_ROOT", unset = ""), - tool_consent_directory = Sys.getenv( - "VSCODE_R_TOOL_CONSENT_DIRECTORY", unset = "" - ), - tool_library_helper = Sys.getenv( - "VSCODE_R_TOOL_LIBRARY_HELPER", unset = "" - ), - tool_consent_helper = Sys.getenv( - "VSCODE_R_TOOL_CONSENT_HELPER", unset = "" - ), - tool_prepare_helper = Sys.getenv( - "VSCODE_R_TOOL_PREPARE_HELPER", unset = "" - ), - jgd_can_prompt = TRUE, - jgd_minimum_version = Sys.getenv( - "VSCODE_R_JGD_MINIMUM_VERSION", unset = "" - ), - rstudioapi_can_prompt = TRUE, - rstudioapi_minimum_version = Sys.getenv( - "VSCODE_R_RSTUDIOAPI_MINIMUM_VERSION", unset = "" - )) { - if (!is.null(attachment_id) && - !(is.character(attachment_id) && length(attachment_id) == 1L && - !is.na(attachment_id) && - grepl("^[A-Za-z0-9_-]{1,128}$", attachment_id, useBytes = TRUE))) { - stop("attachment_id must be NULL or a 1-128 character ASCII identifier.", call. = FALSE) +vscode_r_attach_sess <- function( + endpoint, + pkg_path, + managed_root, + consent_dir, + source_helper, + installer_helper, + plot_backend, + timeout_seconds = 180, + setup_timeout_seconds = 300, + use_rstudioapi = TRUE, + attachment_id = NULL, + auto_activate = TRUE, + tool_root = Sys.getenv("VSCODE_R_TOOL_ROOT", unset = ""), + tool_consent_directory = Sys.getenv("VSCODE_R_TOOL_CONSENT_DIRECTORY", unset = ""), + tool_library_helper = Sys.getenv("VSCODE_R_TOOL_LIBRARY_HELPER", unset = ""), + tool_consent_helper = Sys.getenv("VSCODE_R_TOOL_CONSENT_HELPER", unset = ""), + tool_prepare_helper = Sys.getenv("VSCODE_R_TOOL_PREPARE_HELPER", unset = ""), + jgd_can_prompt = TRUE, + jgd_minimum_version = Sys.getenv("VSCODE_R_JGD_MINIMUM_VERSION", unset = ""), + rstudioapi_can_prompt = TRUE, + rstudioapi_minimum_version = Sys.getenv("VSCODE_R_RSTUDIOAPI_MINIMUM_VERSION", unset = "") +) { + if ( + !is.null(attachment_id) && + !(is.character(attachment_id) && + length(attachment_id) == 1L && + !is.na(attachment_id) && + grepl("^[A-Za-z0-9_-]{1,128}$", attachment_id, useBytes = TRUE)) + ) { + stop("attachment_id must be NULL or a 1-128 character ASCII identifier.", call. = FALSE) + } + if (!(is.logical(auto_activate) && length(auto_activate) == 1L && !is.na(auto_activate))) { + stop("auto_activate must be a single non-NA logical value.", call. = FALSE) + } + if (!auto_activate && is.null(attachment_id)) { + stop("auto_activate = FALSE requires attachment_id.", call. = FALSE) + } + + registered <- getOption("vscodeR.terminalStartup") + profile_process <- is.list(registered) && identical(registered$pid, Sys.getpid()) + startup_context <- NULL + if (profile_process) { + notifier_available <- exists("vscode_r_startup_existing", mode = "function") && + exists("vscode_r_startup_run", mode = "function") + if (!notifier_available) { + startup_helper <- Sys.getenv("VSCODE_R_SESS_STARTUP_HELPER", unset = "") + if (nzchar(startup_helper) && file.exists(startup_helper)) { + tryCatch( + source(startup_helper, local = TRUE), + error = function(error) { + message("vscode-R could not load terminal startup notifier: ", conditionMessage(error)) + } + ) + } + notifier_available <- exists("vscode_r_startup_existing", mode = "function") && + exists("vscode_r_startup_run", mode = "function") } - if (!(is.logical(auto_activate) && length(auto_activate) == 1L && !is.na(auto_activate))) { - stop("auto_activate must be a single non-NA logical value.", call. = FALSE) + if (!notifier_available) { + message( + "vscode-R terminal startup notifier is unavailable; the session watcher was not attached." + ) + return(invisible(FALSE)) } - if (!auto_activate && is.null(attachment_id)) { - stop("auto_activate = FALSE requires attachment_id.", call. = FALSE) + startup_context <- vscode_r_startup_existing(endpoint) + if (is.null(startup_context)) { + message( + "vscode-R could not validate terminal startup status; the session watcher was not attached." + ) + return(invisible(FALSE)) } + } - registered <- getOption("vscodeR.terminalStartup") - profile_process <- is.list(registered) && identical(registered$pid, Sys.getpid()) - startup_context <- NULL - if (profile_process) { - notifier_available <- exists("vscode_r_startup_existing", mode = "function") && - exists("vscode_r_startup_run", mode = "function") - if (!notifier_available) { - startup_helper <- Sys.getenv("VSCODE_R_SESS_STARTUP_HELPER", unset = "") - if (nzchar(startup_helper) && file.exists(startup_helper)) { - tryCatch(source(startup_helper, local = TRUE), error = function(error) { - message("vscode-R could not load terminal startup notifier: ", conditionMessage(error)) - }) - } - notifier_available <- exists("vscode_r_startup_existing", mode = "function") && - exists("vscode_r_startup_run", mode = "function") - } - if (!notifier_available) { - message("vscode-R terminal startup notifier is unavailable; the session watcher was not attached.") - return(invisible(FALSE)) - } - startup_context <- vscode_r_startup_existing(endpoint) - if (is.null(startup_context)) { - message("vscode-R could not validate terminal startup status; the session watcher was not attached.") - return(invisible(FALSE)) - } + attach <- function() { + ns <- vscode_r_prepare_sess( + pkg_path, + managed_root, + consent_dir, + source_helper, + installer_helper, + timeout_seconds, + setup_timeout_seconds + ) + if (is.null(ns)) { + return(invisible(FALSE)) } - - attach <- function() { - ns <- vscode_r_prepare_sess(pkg_path, managed_root, consent_dir, source_helper, installer_helper, - timeout_seconds, setup_timeout_seconds) - if (is.null(ns)) { - return(invisible(FALSE)) - } - connect <- get("connect", envir = ns, inherits = FALSE) - args <- list(endpoint = endpoint, plot_backend = plot_backend, - use_rstudioapi = use_rstudioapi) - # Preserve compatibility with older sess namespaces and helper stubs - # when the caller uses the legacy, untagged attach path. - if (!is.null(attachment_id)) { - args$attachment_id <- attachment_id - args$auto_activate <- auto_activate - } - vscode_r_with_rstudioapi( - use_rstudioapi, tool_prepare_helper, tool_root, tool_consent_directory, - tool_library_helper, tool_consent_helper, rstudioapi_can_prompt, - rstudioapi_minimum_version - ) - vscode_r_with_jgd( - plot_backend, - function(allow_jgd = TRUE) { - args$allow_jgd <- allow_jgd - do.call(connect, args) - }, - tool_prepare_helper, tool_root, tool_consent_directory, - tool_library_helper, tool_consent_helper, jgd_can_prompt, jgd_minimum_version - ) + connect <- get("connect", envir = ns, inherits = FALSE) + args <- list(endpoint = endpoint, plot_backend = plot_backend, use_rstudioapi = use_rstudioapi) + # Preserve compatibility with older sess namespaces and helper stubs + # when the caller uses the legacy, untagged attach path. + if (!is.null(attachment_id)) { + args$attachment_id <- attachment_id + args$auto_activate <- auto_activate } + vscode_r_with_rstudioapi( + use_rstudioapi, + tool_prepare_helper, + tool_root, + tool_consent_directory, + tool_library_helper, + tool_consent_helper, + rstudioapi_can_prompt, + rstudioapi_minimum_version + ) + vscode_r_with_jgd( + plot_backend, + function(allow_jgd = TRUE) { + args$allow_jgd <- allow_jgd + do.call(connect, args) + }, + tool_prepare_helper, + tool_root, + tool_consent_directory, + tool_library_helper, + tool_consent_helper, + jgd_can_prompt, + jgd_minimum_version + ) + } - if (profile_process) { - return(vscode_r_startup_run(startup_context, attach)) - } - attach() + if (profile_process) { + return(vscode_r_startup_run(startup_context, attach)) + } + attach() } diff --git a/R/cppProperties/extractLinkingTo.R b/R/cppProperties/extractLinkingTo.R index ddffc65c3..f0c34aa3b 100644 --- a/R/cppProperties/extractLinkingTo.R +++ b/R/cppProperties/extractLinkingTo.R @@ -1,13 +1,12 @@ deps <- read.dcf("DESCRIPTION", "LinkingTo") -if (length(deps) == 0) { # Empty file - deps <- "" +if (length(deps) == 0) { + # Empty file + deps <- "" } else { - deps <- unname(deps[1, ]) # Read 'LinkingTo' field from description - deps <- gsub("\\s|\\n|(\\([^\\)]*\\))", "", deps) # Remove all whitespace, line breaks and version constraints - deps <- strsplit(deps, ",")[[1]] # Split package names - deps <- vapply(deps, function(pkg) { - system.file("include", package = pkg) - }, character(1)) # Lookup include dir - deps <- utils::URLencode(deps) + deps <- unname(deps[1, ]) # Read 'LinkingTo' field from description + deps <- gsub("\\s|\\n|(\\([^\\)]*\\))", "", deps) # Remove all whitespace, line breaks and version constraints + deps <- strsplit(deps, ",")[[1]] # Split package names + deps <- vapply(deps, function(pkg) system.file("include", package = pkg), character(1)) # Lookup include dir + deps <- utils::URLencode(deps) } writeLines(deps) diff --git a/R/help/getAliases.R b/R/help/getAliases.R index 5f7a3bbcb..6eac7b5b2 100644 --- a/R/help/getAliases.R +++ b/R/help/getAliases.R @@ -2,19 +2,19 @@ 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) - .libPaths(.paths) + add_lib_paths <- strsplit(add_lib_paths, "\n", fixed = TRUE)[[1L]] + .paths <- c(.paths, add_lib_paths) + .libPaths(.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) @@ -28,27 +28,19 @@ 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 - ) - if (is.list(res)) { - info$aliases <- res - } else { - info$error <- res - } + 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) + 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 2ee9a570b..61dfe0c88 100644 --- a/R/help/helpServer.R +++ b/R/help/helpServer.R @@ -2,19 +2,19 @@ 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) - .libPaths(.paths) + add_lib_paths <- strsplit(add_lib_paths, "\n", fixed = TRUE)[[1L]] + .paths <- c(.paths, add_lib_paths) + .libPaths(.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) @@ -24,27 +24,22 @@ lim <- Sys.getenv("VSCR_LIM") NEW_PACKAGE_STRING <- "NEW_PACKAGES" -cat( - lim, - tools::startDynamicHelp(), - lim, - sep = "" -) +cat(lim, tools::startDynamicHelp(), lim, sep = "") lib_dirs <- .libPaths() last_mtimes <- file.info(lib_dirs)$mtime currentPackages <- installed.packages(fields = "Packaged")[, c("Version", "Packaged")] while (TRUE) { - Sys.sleep(5) - current_mtimes <- file.info(lib_dirs)$mtime - if (!identical(last_mtimes, current_mtimes)) { - newPackages <- installed.packages(fields = "Packaged")[, c("Version", "Packaged")] - if (!identical(currentPackages, newPackages)) { - cat(NEW_PACKAGE_STRING, "\n") - currentPackages <- newPackages - } - last_mtimes <- current_mtimes - gc() + Sys.sleep(5) + current_mtimes <- file.info(lib_dirs)$mtime + if (!identical(last_mtimes, current_mtimes)) { + newPackages <- installed.packages(fields = "Packaged")[, c("Version", "Packaged")] + if (!identical(currentPackages, newPackages)) { + cat(NEW_PACKAGE_STRING, "\n") + currentPackages <- newPackages } + last_mtimes <- current_mtimes + gc() + } } diff --git a/R/help/rdToHtml.R b/R/help/rdToHtml.R index e2523efad..6a667bb3b 100644 --- a/R/help/rdToHtml.R +++ b/R/help/rdToHtml.R @@ -1,10 +1,10 @@ #' Converts an .Rd file to HTML (output is printed to stdout) #' #' Execute this with the following trailing commandline args: -#' 1. path of an .Rd file -#' 2. name of the package -#' 3. version string of the package -#' 4. root dir of the package +#' 1. path of an .Rd file +#' 2. name of the package +#' 3. version string of the package +#' 4. root dir of the package args <- base::commandArgs(TRUE) @@ -12,10 +12,10 @@ e <- tools::loadPkgRdMacros(args[4]) e <- tools::loadRdMacros(file.path(R.home("share"), "Rd", "macros", "system.Rd"), macros = e) tools::Rd2HTML( - args[1], - package = args[2:3], - dynamic = TRUE, - encoding = "utf-8", - macros = e, - stages = c("build", "install", "render") + args[1], + package = args[2:3], + dynamic = TRUE, + encoding = "utf-8", + macros = e, + stages = c("build", "install", "render") ) diff --git a/R/install_sess.R b/R/install_sess.R index b61d4bd2d..f674a4246 100644 --- a/R/install_sess.R +++ b/R/install_sess.R @@ -1,65 +1,80 @@ local({ - args <- commandArgs(trailingOnly = TRUE) - pkg_path <- if (length(args) >= 1L && nzchar(args[1L])) args[1L] else - Sys.getenv("VSCODE_R_SESS_PKG_PATH", unset = "") + args <- commandArgs(trailingOnly = TRUE) + pkg_path <- if (length(args) >= 1L && nzchar(args[1L])) { + args[1L] + } else { + Sys.getenv("VSCODE_R_SESS_PKG_PATH", unset = "") + } - if (!nzchar(pkg_path)) { - stop("Missing pkg_path (set VSCODE_R_SESS_PKG_PATH or pass as first command arg)") - } + if (!nzchar(pkg_path)) { + stop("Missing pkg_path (set VSCODE_R_SESS_PKG_PATH or pass as first command arg)") + } - repo <- if (length(args) >= 2L && nzchar(args[2L])) args[2L] else - Sys.getenv("VSCODE_R_SESS_REPO", unset = "") - if (!nzchar(repo)) { - configured <- getOption("repos") - repo <- if ("CRAN" %in% names(configured)) { - configured[["CRAN"]] - } else if (length(configured)) { - configured[[1L]] - } else { - "" - } - } - library_arg <- if (length(args) >= 3L) args[3L] else "" - if (!length(repo) || is.na(repo) || !nzchar(repo) || identical(repo, "@CRAN@")) { - repo <- "https://cloud.r-project.org" + repo <- if (length(args) >= 2L && nzchar(args[2L])) { + args[2L] + } else { + Sys.getenv("VSCODE_R_SESS_REPO", unset = "") + } + if (!nzchar(repo)) { + configured <- getOption("repos") + repo <- if ("CRAN" %in% names(configured)) { + configured[["CRAN"]] + } else if (length(configured)) { + configured[[1L]] + } else { + "" } + } + library_arg <- if (length(args) >= 3L) args[3L] else "" + if (!length(repo) || is.na(repo) || !nzchar(repo) || identical(repo, "@CRAN@")) { + repo <- "https://cloud.r-project.org" + } - if (!file.exists(file.path(pkg_path, "DESCRIPTION"))) { - stop(paste("DESCRIPTION file not found in", pkg_path)) - } + if (!file.exists(file.path(pkg_path, "DESCRIPTION"))) { + stop(paste("DESCRIPTION file not found in", pkg_path)) + } - # Resolve the helper beside this script, independently of the package's - # staging path. source() records ofile; an R task supplies --file instead. - script_files <- unlist(lapply(sys.frames(), function(frame) frame$ofile)) - if (!length(script_files)) { - script_files <- sub("^--file=", "", grep("^--file=", commandArgs(), value = TRUE)) - # The Unix R launcher encodes spaces in --file values before invoking R. - if (.Platform$OS.type == "unix") { - script_files <- gsub("~+~", " ", script_files, fixed = TRUE) - } - } - if (!length(script_files)) { - stop("Cannot locate install_sess.R") - } - script_directory <- dirname(tail(script_files, 1)) - source(file.path(script_directory, "sess_source.R"), local = TRUE) - expected_revision <- sess_source_revision(file.path(pkg_path, "DESCRIPTION")) - if (is.null(expected_revision)) { - stop("Bundled sess has no valid source revision. Rebuild or reinstall the vscode-R extension.") + # Resolve the helper beside this script, independently of the package's + # staging path. source() records ofile; an R task supplies --file instead. + script_files <- unlist(lapply(sys.frames(), function(frame) frame$ofile)) + if (!length(script_files)) { + script_files <- sub("^--file=", "", grep("^--file=", commandArgs(), value = TRUE)) + # The Unix R launcher encodes spaces in --file values before invoking R. + if (.Platform$OS.type == "unix") { + script_files <- gsub("~+~", " ", script_files, fixed = TRUE) } + } + if (!length(script_files)) { + stop("Cannot locate install_sess.R") + } + script_directory <- dirname(tail(script_files, 1)) + source(file.path(script_directory, "sess_source.R"), local = TRUE) + expected_revision <- sess_source_revision(file.path(pkg_path, "DESCRIPTION")) + if (is.null(expected_revision)) { + stop("Bundled sess has no valid source revision. Rebuild or reinstall the vscode-R extension.") + } - library <- if (nzchar(library_arg)) library_arg else - Sys.getenv("VSCODE_R_SESS_LIBRARY", unset = "") - if (!nzchar(library)) { - stop("Missing VSCODE_R_SESS_LIBRARY. Refusing to install sess into a default R library.") - } - dir.create(library, recursive = TRUE, showWarnings = FALSE) - if (file.access(library, 2L) != 0L) stop(paste("R library is not writable:", library)) - installer <- new.env(parent = baseenv()) - sys.source(file.path(script_directory, "sess-package-install.R"), envir = installer) - installer$sess_install(pkg_path, library, repo, - interactive = identical(Sys.getenv("VSCODE_R_SESS_INTERACTIVE"), "1")) - if ("sess" %in% loadedNamespaces()) { - message("sess was already loaded. Restart R to use the newly installed source.") - } + library <- if (nzchar(library_arg)) { + library_arg + } else { + Sys.getenv("VSCODE_R_SESS_LIBRARY", unset = "") + } + if (!nzchar(library)) { + stop("Missing VSCODE_R_SESS_LIBRARY. Refusing to install sess into a default R library.") + } + dir.create(library, recursive = TRUE, showWarnings = FALSE) + if (file.access(library, 2L) != 0L) { + stop(paste("R library is not writable:", library)) + } + installer <- new.env(parent = baseenv()) + sys.source(file.path(script_directory, "sess-package-install.R"), envir = installer) + installer$sess_install( + pkg_path, + library, + repo, + interactive = identical(Sys.getenv("VSCODE_R_SESS_INTERACTIVE"), "1") + ) + if ("sess" %in% loadedNamespaces()) { + message("sess was already loaded. Restart R to use the newly installed source.") + } }) diff --git a/R/interactive-metrics.R b/R/interactive-metrics.R index 573c9ae14..5ca83898b 100644 --- a/R/interactive-metrics.R +++ b/R/interactive-metrics.R @@ -1,27 +1,48 @@ # This independent process supplies metrics even while the analysis R is busy. -if (!requireNamespace("systemfonts", quietly = TRUE)) stop("systemfonts is required for JGD metrics") +if (!requireNamespace("systemfonts", quietly = TRUE)) { + stop("systemfonts is required for JGD metrics") +} input <- file("stdin", "r") repeat { - line <- readLines(input, n = 1L, warn = FALSE) - if (!length(line)) break - request <- jsonlite::fromJSON(line, simplifyVector = FALSE) - result <- tryCatch({ - font <- request$gc$font - family <- if (is.null(font$family) || !nzchar(font$family)) "sans" else font$family - size <- if (is.null(font$size)) 12 else font$size - dpi <- if (is.null(request$dpi)) 96 else request$dpi - face <- if (is.null(font$face)) 1 else font$face - text <- if (identical(request$kind, "strWidth")) request$str else intToUtf8(request$c) - weight <- if (face %in% c(2, 4)) "bold" else "normal" - width <- systemfonts::string_width(text, family = family, italic = face %in% c(3, 4), - weight = weight, size = size, res = dpi) - info <- systemfonts::font_info(family = family, italic = face %in% c(3, 4), - weight = weight, size = size, res = dpi) - list(type = "metrics_response", id = request$id, width = width[[1L]], - ascent = info$max_ascend[[1L]], descent = abs(info$max_descend[[1L]])) - }, error = function(e) { - list(type = "metrics_error", id = request$id, message = conditionMessage(e)) - }) - cat(as.character(jsonlite::toJSON(result, auto_unbox = TRUE)), "\n", sep = "") - flush(stdout()) + line <- readLines(input, n = 1L, warn = FALSE) + if (!length(line)) { + break + } + request <- jsonlite::fromJSON(line, simplifyVector = FALSE) + result <- tryCatch( + { + font <- request$gc$font + family <- if (is.null(font$family) || !nzchar(font$family)) "sans" else font$family + size <- if (is.null(font$size)) 12 else font$size + dpi <- if (is.null(request$dpi)) 96 else request$dpi + face <- if (is.null(font$face)) 1 else font$face + text <- if (identical(request$kind, "strWidth")) request$str else intToUtf8(request$c) + weight <- if (face %in% c(2, 4)) "bold" else "normal" + width <- systemfonts::string_width( + text, + family = family, + italic = face %in% c(3, 4), + weight = weight, + size = size, + res = dpi + ) + info <- systemfonts::font_info( + family = family, + italic = face %in% c(3, 4), + weight = weight, + size = size, + res = dpi + ) + list( + type = "metrics_response", + id = request$id, + width = width[[1L]], + ascent = info$max_ascend[[1L]], + descent = abs(info$max_descend[[1L]]) + ) + }, + error = function(e) list(type = "metrics_error", id = request$id, message = conditionMessage(e)) + ) + cat(as.character(jsonlite::toJSON(result, auto_unbox = TRUE)), "\n", sep = "") + flush(stdout()) } diff --git a/R/interactive-worker.R b/R/interactive-worker.R index e34bfd4d4..511315e3b 100644 --- a/R/interactive-worker.R +++ b/R/interactive-worker.R @@ -1,34 +1,38 @@ function(library, config, support_libraries = character(), managed = TRUE) { - # Load the bridge explicitly without making its private directory a default - # install target or changing the library order established by R/renv startup. - if ("sess" %in% loadedNamespaces() && - normalizePath(getNamespaceInfo("sess", "path")) != normalizePath(file.path(library, "sess"))) { - ns <- asNamespace("sess") - if (exists("interactive_stop", ns, inherits = FALSE)) { - get("interactive_stop", ns)() - } else if (exists(".transport_disconnect", ns, inherits = FALSE)) { - get(".transport_disconnect", ns)(silent = TRUE) - } - if ("package:sess" %in% search()) detach("package:sess", unload = FALSE) - unloadNamespace("sess") + # Load the bridge explicitly without making its private directory a default + # install target or changing the library order established by R/renv startup. + if ( + "sess" %in% loadedNamespaces() && + normalizePath(getNamespaceInfo("sess", "path")) != normalizePath(file.path(library, "sess")) + ) { + ns <- asNamespace("sess") + if (exists("interactive_stop", ns, inherits = FALSE)) { + get("interactive_stop", ns)() + } else if (exists(".transport_disconnect", ns, inherits = FALSE)) { + get(".transport_disconnect", ns)(silent = TRUE) } - # First-time setup may install missing Imports beside the private bridge. - # Use them as a final loading fallback without changing .libPaths(). - support_paths <- unique(c(.libPaths(), support_libraries, library)) - # sess uses qualified calls rather than namespace imports for these packages. - # processx also calls ps lazily from .onLoad on Linux, before it can finish - # loading in an isolated renv project. - for (package in c("jsonlite", "later", "ps", "processx", "rstudioapi")) { - loadNamespace(package, lib.loc = support_paths) + if ("package:sess" %in% search()) { + detach("package:sess", unload = FALSE) } - loadNamespace("sess", lib.loc = c(library, support_paths)) - cfg <- jsonlite::fromJSON(config) - # Prefer project versions of support packages. Libraries outside an isolated - # project are available only for loading the IDE bridge and its plot device. - device <- if (isTRUE(cfg$useJgd)) "jgd" else "svglite" - tryCatch(loadNamespace(device, lib.loc = support_paths), - error = function(e) { - if (isTRUE(cfg$useJgd)) stop(e) - }) - sess:::interactive_start(config, managed = managed) + unloadNamespace("sess") + } + # First-time setup may install missing Imports beside the private bridge. + # Use them as a final loading fallback without changing .libPaths(). + support_paths <- unique(c(.libPaths(), support_libraries, library)) + # sess uses qualified calls rather than namespace imports for these packages. + # processx also calls ps lazily from .onLoad on Linux, before it can finish + # loading in an isolated renv project. + for (package in c("jsonlite", "later", "ps", "processx", "rstudioapi")) { + loadNamespace(package, lib.loc = support_paths) + } + loadNamespace("sess", lib.loc = c(library, support_paths)) + cfg <- jsonlite::fromJSON(config) + # Prefer project versions of support packages. Libraries outside an isolated + # project are available only for loading the IDE bridge and its plot device. + device <- if (isTRUE(cfg$useJgd)) "jgd" else "svglite" + tryCatch( + loadNamespace(device, lib.loc = support_paths), + error = function(e) if (isTRUE(cfg$useJgd)) stop(e) + ) + sess:::interactive_start(config, managed = managed) } diff --git a/R/languageServer.R b/R/languageServer.R index b24c1eab5..013bb7319 100644 --- a/R/languageServer.R +++ b/R/languageServer.R @@ -2,26 +2,26 @@ 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) - .libPaths(.paths) + add_lib_paths <- strsplit(add_lib_paths, "\n", fixed = TRUE)[[1L]] + .paths <- c(.paths, add_lib_paths) + .libPaths(.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") @@ -31,15 +31,15 @@ debug <- if (nzchar(debug)) as.logical(debug) else FALSE port <- if (nzchar(port)) as.integer(port) else NULL if (identical(Sys.getenv("VSCR_LSP_VIRTUAL_DOCUMENTS"), "TRUE")) { - # lintr's disk cache reads the source filename, but virtual cells have no - # corresponding R file. Keep diagnostics enabled and lint their live text. - options(languageserver.lint_cache = FALSE) + # lintr's disk cache reads the source filename, but virtual cells have no + # corresponding R file. Keep diagnostics enabled and lint their live text. + options(languageserver.lint_cache = FALSE) } if (identical(Sys.getenv("VSCR_LSP_SYNTHETIC_WORKSPACE"), "TRUE")) { - # A session directory supplies context for virtual documents, but is not an - # opened project. Avoid recursively indexing it (it may be the home folder). - options(languageserver.index_mode = "off") + # A session directory supplies context for virtual documents, but is not an + # opened project. Avoid recursively indexing it (it may be the home folder). + options(languageserver.index_mode = "off") } languageserver::run(port = port, debug = debug) diff --git a/R/prepare-tools.R b/R/prepare-tools.R index dc1e3aeae..bf9c19d25 100644 --- a/R/prepare-tools.R +++ b/R/prepare-tools.R @@ -1,23 +1,30 @@ # Keep optional jgd preparation and its result shared by terminal connections. vscode_r_connect_with_jgd <- function( - plot_backend, - connect, - tool_root = Sys.getenv("VSCODE_R_TOOL_ROOT", unset = ""), - consent_directory = Sys.getenv("VSCODE_R_TOOL_CONSENT_DIRECTORY", unset = ""), - library_helper = Sys.getenv("VSCODE_R_TOOL_LIBRARY_HELPER", unset = ""), - consent_helper = Sys.getenv("VSCODE_R_TOOL_CONSENT_HELPER", unset = ""), - can_prompt = identical(Sys.getenv("VSCODE_R_JGD_CAN_PROMPT", unset = "TRUE"), "TRUE"), - minimum_version = Sys.getenv("VSCODE_R_JGD_MINIMUM_VERSION", unset = "") + plot_backend, + connect, + tool_root = Sys.getenv("VSCODE_R_TOOL_ROOT", unset = ""), + consent_directory = Sys.getenv("VSCODE_R_TOOL_CONSENT_DIRECTORY", unset = ""), + library_helper = Sys.getenv("VSCODE_R_TOOL_LIBRARY_HELPER", unset = ""), + consent_helper = Sys.getenv("VSCODE_R_TOOL_CONSENT_HELPER", unset = ""), + can_prompt = identical(Sys.getenv("VSCODE_R_JGD_CAN_PROMPT", unset = "TRUE"), "TRUE"), + minimum_version = Sys.getenv("VSCODE_R_JGD_MINIMUM_VERSION", unset = "") ) { - if (!is.function(connect)) stop("connect must be a function.", call. = FALSE) - if (!plot_backend %in% c("jgd", "auto")) { - return(connect(allow_jgd = TRUE)) - } - ready <- isTRUE(vscode_r_prepare_jgd( - plot_backend, tool_root, consent_directory, - library_helper, consent_helper, can_prompt, minimum_version - )) - connect(allow_jgd = ready) + if (!is.function(connect)) { + stop("connect must be a function.", call. = FALSE) + } + if (!plot_backend %in% c("jgd", "auto")) { + return(connect(allow_jgd = TRUE)) + } + ready <- isTRUE(vscode_r_prepare_jgd( + plot_backend, + tool_root, + consent_directory, + library_helper, + consent_helper, + can_prompt, + minimum_version + )) + connect(allow_jgd = ready) } # Select, install if approved, and eagerly load one tool package. Returns TRUE @@ -26,95 +33,103 @@ vscode_r_connect_with_jgd <- function( # consent policy sent to the extension ("always" or "once"); `fallback` and # `support` only word the messages. An already loaded namespace is never replaced. vscode_r_prepare_tool_package <- function( - package, - policy, - tool_root, - consent_directory, - library_helper, - consent_helper, - can_prompt, - minimum_version, - support, - fallback, - report_load_failure = TRUE + package, + policy, + tool_root, + consent_directory, + library_helper, + consent_helper, + can_prompt, + minimum_version, + support, + fallback, + report_load_failure = TRUE ) { - if (!(is.logical(can_prompt) && length(can_prompt) == 1L && !is.na(can_prompt))) { - stop("can_prompt must be a single non-NA logical value.", call. = FALSE) - } - helpers <- c(library_helper, consent_helper) - if (any(!nzchar(helpers)) || any(!file.exists(helpers)) || !nzchar(tool_root)) { - message("vscode-R could not locate managed ", package, " setup resources; ", fallback, ".") - return(FALSE) - } + if (!(is.logical(can_prompt) && length(can_prompt) == 1L && !is.na(can_prompt))) { + stop("can_prompt must be a single non-NA logical value.", call. = FALSE) + } + helpers <- c(library_helper, consent_helper) + if (any(!nzchar(helpers)) || any(!file.exists(helpers)) || !nzchar(tool_root)) { + message("vscode-R could not locate managed ", package, " setup resources; ", fallback, ".") + return(FALSE) + } - tryCatch({ - tool_environment <- new.env(parent = environment(vscode_r_prepare_tool_package)) - for (helper in helpers) { - sys.source(helper, envir = tool_environment) - } - if (!can_prompt) { - # A compatible ordinary or managed copy remains usable without resolving a new plan. - return(!is.null(tool_environment$tool_library_load( - package, minimum_version, tool_root - ))) - } - prepared <- tool_environment$tool_library_prepare( - package, - minimum_version, - tool_root, - consent_directory, - policy, - consent_timeout_seconds = 180, - install_timeout_seconds = 300, - resolution_timeout_seconds = 30 - ) - if (is.null(prepared)) { - message("vscode-R optional ", package, " installation was not approved; ", fallback, ".") - return(FALSE) - } - namespace <- tool_environment$tool_library_load( - package, minimum_version, tool_root - ) - if (is.null(namespace)) { - if (report_load_failure) { - message("vscode-R could not load a compatible ", package, " package; ", fallback, ".") - } - return(FALSE) + tryCatch( + { + tool_environment <- new.env(parent = environment(vscode_r_prepare_tool_package)) + for (helper in helpers) { + sys.source(helper, envir = tool_environment) + } + if (!can_prompt) { + # A compatible ordinary or managed copy remains usable without resolving a new plan. + return(!is.null(tool_environment$tool_library_load(package, minimum_version, tool_root))) + } + prepared <- tool_environment$tool_library_prepare( + package, + minimum_version, + tool_root, + consent_directory, + policy, + consent_timeout_seconds = 180, + install_timeout_seconds = 300, + resolution_timeout_seconds = 30 + ) + if (is.null(prepared)) { + message("vscode-R optional ", package, " installation was not approved; ", fallback, ".") + return(FALSE) + } + namespace <- tool_environment$tool_library_load(package, minimum_version, tool_root) + if (is.null(namespace)) { + if (report_load_failure) { + message("vscode-R could not load a compatible ", package, " package; ", fallback, ".") } - TRUE - }, error = function(error) { - message("vscode-R could not prepare optional ", support, ": ", conditionMessage(error)) - FALSE - }, interrupt = function(error) { - message("vscode-R ", package, " preparation was interrupted; ", fallback, ".") - FALSE - }) + return(FALSE) + } + TRUE + }, + error = function(error) { + message("vscode-R could not prepare optional ", support, ": ", conditionMessage(error)) + FALSE + }, + interrupt = function(error) { + message("vscode-R ", package, " preparation was interrupted; ", fallback, ".") + FALSE + } + ) } # Prepare optional plot support without making sess startup depend on CRAN access # or user consent. The managed library is loaded before sess checks the package. vscode_r_prepare_jgd <- function( - plot_backend, - tool_root = Sys.getenv("VSCODE_R_TOOL_ROOT", unset = ""), - consent_directory = Sys.getenv("VSCODE_R_TOOL_CONSENT_DIRECTORY", unset = ""), - library_helper = Sys.getenv("VSCODE_R_TOOL_LIBRARY_HELPER", unset = ""), - consent_helper = Sys.getenv("VSCODE_R_TOOL_CONSENT_HELPER", unset = ""), - can_prompt = identical(Sys.getenv("VSCODE_R_JGD_CAN_PROMPT", unset = "TRUE"), "TRUE"), - minimum_version = Sys.getenv("VSCODE_R_JGD_MINIMUM_VERSION", unset = "") + plot_backend, + tool_root = Sys.getenv("VSCODE_R_TOOL_ROOT", unset = ""), + consent_directory = Sys.getenv("VSCODE_R_TOOL_CONSENT_DIRECTORY", unset = ""), + library_helper = Sys.getenv("VSCODE_R_TOOL_LIBRARY_HELPER", unset = ""), + consent_helper = Sys.getenv("VSCODE_R_TOOL_CONSENT_HELPER", unset = ""), + can_prompt = identical(Sys.getenv("VSCODE_R_JGD_CAN_PROMPT", unset = "TRUE"), "TRUE"), + minimum_version = Sys.getenv("VSCODE_R_JGD_MINIMUM_VERSION", unset = "") ) { - if (!is.character(plot_backend) || length(plot_backend) != 1L || - is.na(plot_backend) || !plot_backend %in% c("jgd", "auto")) { - return(FALSE) - } - # An explicit jgd backend is offered installation on every request; auto only once. - vscode_r_prepare_tool_package( - "jgd", - if (identical(plot_backend, "jgd")) "always" else "once", - tool_root, consent_directory, library_helper, consent_helper, - can_prompt, minimum_version, - support = "jgd plot support", - fallback = "using the available plot fallback" - ) + if ( + !is.character(plot_backend) || + length(plot_backend) != 1L || + is.na(plot_backend) || + !plot_backend %in% c("jgd", "auto") + ) { + return(FALSE) + } + # An explicit jgd backend is offered installation on every request; auto only once. + vscode_r_prepare_tool_package( + "jgd", + if (identical(plot_backend, "jgd")) "always" else "once", + tool_root, + consent_directory, + library_helper, + consent_helper, + can_prompt, + minimum_version, + support = "jgd plot support", + fallback = "using the available plot fallback" + ) } # Make rstudioapi available before sess starts its emulation, so that @@ -122,25 +137,30 @@ vscode_r_prepare_jgd <- function( # Emulation stays enabled whatever the outcome: sess patches rstudioapi when it # is loaded now or later. Does nothing when emulation is disabled. vscode_r_prepare_rstudioapi <- function( - use_rstudioapi, - tool_root = Sys.getenv("VSCODE_R_TOOL_ROOT", unset = ""), - consent_directory = Sys.getenv("VSCODE_R_TOOL_CONSENT_DIRECTORY", unset = ""), - library_helper = Sys.getenv("VSCODE_R_TOOL_LIBRARY_HELPER", unset = ""), - consent_helper = Sys.getenv("VSCODE_R_TOOL_CONSENT_HELPER", unset = ""), - can_prompt = identical(Sys.getenv("VSCODE_R_RSTUDIOAPI_CAN_PROMPT", unset = "TRUE"), "TRUE"), - minimum_version = Sys.getenv("VSCODE_R_RSTUDIOAPI_MINIMUM_VERSION", unset = "") + use_rstudioapi, + tool_root = Sys.getenv("VSCODE_R_TOOL_ROOT", unset = ""), + consent_directory = Sys.getenv("VSCODE_R_TOOL_CONSENT_DIRECTORY", unset = ""), + library_helper = Sys.getenv("VSCODE_R_TOOL_LIBRARY_HELPER", unset = ""), + consent_helper = Sys.getenv("VSCODE_R_TOOL_CONSENT_HELPER", unset = ""), + can_prompt = identical(Sys.getenv("VSCODE_R_RSTUDIOAPI_CAN_PROMPT", unset = "TRUE"), "TRUE"), + minimum_version = Sys.getenv("VSCODE_R_RSTUDIOAPI_MINIMUM_VERSION", unset = "") ) { - # sess treats an unset (NA) value as enabled. - if (identical(use_rstudioapi, FALSE)) { - return(FALSE) - } - vscode_r_prepare_tool_package( - "rstudioapi", "once", - tool_root, consent_directory, library_helper, consent_helper, - can_prompt, minimum_version, - support = "rstudioapi support", - fallback = "continuing without it", - # An incompatible loaded namespace is already reported by the loader. - report_load_failure = FALSE - ) + # sess treats an unset (NA) value as enabled. + if (identical(use_rstudioapi, FALSE)) { + return(FALSE) + } + vscode_r_prepare_tool_package( + "rstudioapi", + "once", + tool_root, + consent_directory, + library_helper, + consent_helper, + can_prompt, + minimum_version, + support = "rstudioapi support", + fallback = "continuing without it", + # An incompatible loaded namespace is already reported by the loader. + report_load_failure = FALSE + ) } diff --git a/R/profile.R b/R/profile.R index b8b4a6d9e..9c28cbeb3 100644 --- a/R/profile.R +++ b/R/profile.R @@ -1,102 +1,123 @@ # 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() }) invisible(local({ - initialize_sess <- function() { - bundled_path <- Sys.getenv("VSCODE_R_SESS_PKG_PATH", unset = "") - if (!nzchar(bundled_path)) { - return(invisible(FALSE)) - } - - helper <- Sys.getenv("VSCODE_R_SESS_SOURCE_HELPER", unset = "") - attach_helper <- Sys.getenv("VSCODE_R_SESS_ATTACH_HELPER", unset = "") - installer_helper <- Sys.getenv("VSCODE_R_SESS_INSTALLER_HELPER", unset = "") - managed_root <- Sys.getenv("VSCODE_R_SESS_ROOT", unset = "") - consent_directory <- Sys.getenv("VSCODE_R_SESS_CONSENT_DIRECTORY", unset = "") - resources <- c(helper, attach_helper, installer_helper) - resources_ok <- all(nzchar(c(resources, managed_root))) && - all(file.exists(resources)) - if (!resources_ok) { - message("vscode-R could not locate its sess setup resources; the session watcher was not started.") - return(invisible(FALSE)) - } - source(attach_helper, local = TRUE) - ns <- vscode_r_prepare_sess(bundled_path, managed_root, consent_directory, helper, installer_helper) - if (is.null(ns)) { - return(invisible(FALSE)) - } + initialize_sess <- function() { + bundled_path <- Sys.getenv("VSCODE_R_SESS_PKG_PATH", unset = "") + if (!nzchar(bundled_path)) { + return(invisible(FALSE)) + } - plot_backend <- Sys.getenv("SESS_PLOT_BACKEND", "auto") - connect <- get("connect", envir = ns, inherits = FALSE) - use_rstudioapi <- as.logical(Sys.getenv("SESS_RSTUDIOAPI", "TRUE")) - vscode_r_with_rstudioapi(use_rstudioapi) - result <- vscode_r_with_jgd(plot_backend, function(allow_jgd = TRUE) { - connect(use_rstudioapi = use_rstudioapi, plot_backend = plot_backend, - allow_jgd = allow_jgd) - }) - isTRUE(result) + helper <- Sys.getenv("VSCODE_R_SESS_SOURCE_HELPER", unset = "") + attach_helper <- Sys.getenv("VSCODE_R_SESS_ATTACH_HELPER", unset = "") + installer_helper <- Sys.getenv("VSCODE_R_SESS_INSTALLER_HELPER", unset = "") + managed_root <- Sys.getenv("VSCODE_R_SESS_ROOT", unset = "") + consent_directory <- Sys.getenv("VSCODE_R_SESS_CONSENT_DIRECTORY", unset = "") + resources <- c(helper, attach_helper, installer_helper) + resources_ok <- all(nzchar(c(resources, managed_root))) && all(file.exists(resources)) + if (!resources_ok) { + message( + "vscode-R could not locate its sess setup resources; the session watcher was not started." + ) + return(invisible(FALSE)) + } + source(attach_helper, local = TRUE) + ns <- vscode_r_prepare_sess( + bundled_path, + managed_root, + consent_directory, + helper, + installer_helper + ) + if (is.null(ns)) { + return(invisible(FALSE)) } - startup_file <- Sys.getenv("VSCODE_R_SESS_STARTUP_FILE", unset = "") - startup_context <- NULL - startup_allowed <- TRUE - if (nzchar(startup_file)) { - startup_helper <- Sys.getenv("VSCODE_R_SESS_STARTUP_HELPER", unset = "") - startup_token <- Sys.getenv("VSCODE_R_SESS_STARTUP_TOKEN", unset = "") - startup_endpoint <- Sys.getenv("VSCODE_R_SESS_STARTUP_ENDPOINT", unset = "") - if (!nzchar(startup_helper) || !file.exists(startup_helper)) { - message("vscode-R could not locate its terminal startup notifier; the session watcher was not started.") - startup_allowed <- FALSE - } else { - tryCatch({ - sys.source(startup_helper, envir = environment()) - startup_context <- vscode_r_startup_register(startup_file, startup_token, startup_endpoint) - }, error = function(error) { - message("vscode-R could not register terminal startup status: ", conditionMessage(error)) - }) - if (is.null(startup_context)) { - message("vscode-R could not register terminal startup status; the session watcher was not started.") - startup_allowed <- FALSE - } + plot_backend <- Sys.getenv("SESS_PLOT_BACKEND", "auto") + connect <- get("connect", envir = ns, inherits = FALSE) + use_rstudioapi <- as.logical(Sys.getenv("SESS_RSTUDIOAPI", "TRUE")) + vscode_r_with_rstudioapi(use_rstudioapi) + result <- vscode_r_with_jgd( + plot_backend, + function(allow_jgd = TRUE) { + connect(use_rstudioapi = use_rstudioapi, plot_backend = plot_backend, allow_jgd = allow_jgd) + } + ) + isTRUE(result) + } + + startup_file <- Sys.getenv("VSCODE_R_SESS_STARTUP_FILE", unset = "") + startup_context <- NULL + startup_allowed <- TRUE + if (nzchar(startup_file)) { + startup_helper <- Sys.getenv("VSCODE_R_SESS_STARTUP_HELPER", unset = "") + startup_token <- Sys.getenv("VSCODE_R_SESS_STARTUP_TOKEN", unset = "") + startup_endpoint <- Sys.getenv("VSCODE_R_SESS_STARTUP_ENDPOINT", unset = "") + if (!nzchar(startup_helper) || !file.exists(startup_helper)) { + message( + "vscode-R could not locate its terminal startup notifier; the session watcher was not started." + ) + startup_allowed <- FALSE + } else { + tryCatch( + { + sys.source(startup_helper, envir = environment()) + startup_context <- vscode_r_startup_register( + startup_file, + startup_token, + startup_endpoint + ) + }, + error = function(error) { + message("vscode-R could not register terminal startup status: ", conditionMessage(error)) } + ) + if (is.null(startup_context)) { + message( + "vscode-R could not register terminal startup status; the session watcher was not started." + ) + startup_allowed <- FALSE + } } + } - if (startup_allowed) { - tryCatch({ - if (nzchar(startup_file)) { - vscode_r_startup_run(startup_context, initialize_sess) - } else { - initialize_sess() - } - }, error = function(error) { - message("vscode-R could not start the session watcher: ", conditionMessage(error)) - invisible(FALSE) - }, interrupt = function(error) { - message("vscode-R session watcher startup was interrupted: ", conditionMessage(error)) - invisible(FALSE) - }) - } + if (startup_allowed) { + tryCatch( + { + if (nzchar(startup_file)) { + vscode_r_startup_run(startup_context, initialize_sess) + } else { + initialize_sess() + } + }, + error = function(error) { + message("vscode-R could not start the session watcher: ", conditionMessage(error)) + invisible(FALSE) + }, + interrupt = function(error) { + message("vscode-R session watcher startup was interrupted: ", conditionMessage(error)) + invisible(FALSE) + } + ) + } })) diff --git a/R/rmarkdown/knit.R b/R/rmarkdown/knit.R index fc205141e..1c4c0e5df 100644 --- a/R/rmarkdown/knit.R +++ b/R/rmarkdown/knit.R @@ -1,34 +1,27 @@ # requires rmarkdown package to run (and knitr) if (!requireNamespace("rmarkdown", quietly = TRUE)) { - stop("Knitting requires the {rmarkdown} package.") + stop("Knitting requires the {rmarkdown} package.") } # get values from extension-set env values # Hiding values is necessary to prevent their accidental removal # See: https://github.com/REditorSupport/vscode-R/issues/860 attach( - local({ - .vsc.knit_dir <- Sys.getenv("VSCR_KNIT_DIR") - .vsc.knit_lim <- Sys.getenv("VSCR_LIM") - .vsc.knit_command <- Sys.getenv("VSCR_KNIT_COMMAND") - environment() - }), - name = "tools:vscode", - warn.conflicts = FALSE + local({ + .vsc.knit_dir <- Sys.getenv("VSCR_KNIT_DIR") + .vsc.knit_lim <- Sys.getenv("VSCR_LIM") + .vsc.knit_command <- Sys.getenv("VSCR_KNIT_COMMAND") + environment() + }), + name = "tools:vscode", + warn.conflicts = FALSE ) - # set the knitr chunk eval directory # mainly affects source calls if (nzchar(.vsc.knit_dir)) { - knitr::opts_knit[["set"]](root.dir = .vsc.knit_dir) + knitr::opts_knit[["set"]](root.dir = .vsc.knit_dir) } # render and get file output location for use in extension -cat( - .vsc.knit_lim, - eval(parse(text = .vsc.knit_command)), - .vsc.knit_lim, - sep = "", - file = stdout() -) +cat(.vsc.knit_lim, eval(parse(text = .vsc.knit_command)), .vsc.knit_lim, sep = "", file = stdout()) diff --git a/R/rmarkdown/preview.R b/R/rmarkdown/preview.R index b6bdd3f48..737122f2c 100644 --- a/R/rmarkdown/preview.R +++ b/R/rmarkdown/preview.R @@ -1,57 +1,56 @@ # requires rmarkdown package to run (and knitr) if (!requireNamespace("rmarkdown", quietly = TRUE)) { - stop("Previewing documents requires the {rmarkdown} package.") + stop("Previewing documents requires the {rmarkdown} package.") } # get values from extension-set env values # Hiding values is necessary to prevent their accidental removal # See: https://github.com/REditorSupport/vscode-R/issues/860 attach( - local({ - .vsc.knit_dir <- Sys.getenv("VSCR_KNIT_DIR") - .vsc.knit_lim <- Sys.getenv("VSCR_LIM") - .vsc.file_path <- Sys.getenv("VSCR_FILE_PATH") - .vsc.output_file_loc <- Sys.getenv("VSCR_OUTPUT_FILE") - .vsc.tmp_dir <- Sys.getenv("VSCR_TMP_DIR") + local({ + .vsc.knit_dir <- Sys.getenv("VSCR_KNIT_DIR") + .vsc.knit_lim <- Sys.getenv("VSCR_LIM") + .vsc.file_path <- Sys.getenv("VSCR_FILE_PATH") + .vsc.output_file_loc <- Sys.getenv("VSCR_OUTPUT_FILE") + .vsc.tmp_dir <- Sys.getenv("VSCR_TMP_DIR") - # if an output format ends up as html, we should not overwrite - # the format with rmarkdown::html_document() - .vsc.set_html <- tryCatch( - expr = { - lines <- suppressWarnings(readLines(.vsc.file_path, encoding = "UTF-8")) - out <- rmarkdown:::output_format_from_yaml_front_matter(lines) - output_format <- rmarkdown:::create_output_format(out$name, out$options) - if (!output_format$pandoc$to == "html") { - rmarkdown::html_document() - } else { - NULL - } - }, error = function(e) { - rmarkdown::html_document() - } - ) - environment() - }), - name = "tools:vscode", - warn.conflicts = FALSE + # if an output format ends up as html, we should not overwrite + # the format with rmarkdown::html_document() + .vsc.set_html <- tryCatch( + expr = { + lines <- suppressWarnings(readLines(.vsc.file_path, encoding = "UTF-8")) + out <- rmarkdown:::output_format_from_yaml_front_matter(lines) + output_format <- rmarkdown:::create_output_format(out$name, out$options) + if (!output_format$pandoc$to == "html") { + rmarkdown::html_document() + } else { + NULL + } + }, + error = function(e) rmarkdown::html_document() + ) + environment() + }), + name = "tools:vscode", + warn.conflicts = FALSE ) # set the knitr chunk eval directory # mainly affects source calls if (nzchar(.vsc.knit_dir)) { - knitr::opts_knit[["set"]](root.dir = .vsc.knit_dir) + knitr::opts_knit[["set"]](root.dir = .vsc.knit_dir) } # render and get file output location for use in extension cat( - .vsc.knit_lim, - rmarkdown::render( - .vsc.file_path, - output_format = .vsc.set_html, - output_file = .vsc.output_file_loc, - intermediates_dir = .vsc.tmp_dir - ), - .vsc.knit_lim, - sep = "", - file = stdout() + .vsc.knit_lim, + rmarkdown::render( + .vsc.file_path, + output_format = .vsc.set_html, + output_file = .vsc.output_file_loc, + intermediates_dir = .vsc.tmp_dir + ), + .vsc.knit_lim, + sep = "", + file = stdout() ) diff --git a/R/rmarkdown/templates.R b/R/rmarkdown/templates.R index f226a6975..93a7a0a81 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/sess-package-install.R b/R/sess-package-install.R index 6dedb45f4..0f4c616d7 100644 --- a/R/sess-package-install.R +++ b/R/sess-package-install.R @@ -1,66 +1,91 @@ # Shared by ordinary sess installation and the private Interactive runtime. sess_install_command <- function(package, library) { - status <- system2(file.path(R.home("bin"), "R"), - c("CMD", "INSTALL", "--clean", shQuote(paste0("--library=", library)), shQuote(package))) - identical(as.integer(status), 0L) + status <- system2( + file.path(R.home("bin"), "R"), + c("CMD", "INSTALL", "--clean", shQuote(paste0("--library=", library)), shQuote(package)) + ) + identical(as.integer(status), 0L) } sess_install_dependencies <- function(packages, library, repos) { - utils::install.packages(packages, lib = library, repos = repos) + utils::install.packages(packages, lib = library, repos = repos) } sess_verify_package <- function(library, required, expected_revision, interactive) { - # Verification must not accidentally use an older namespace already loaded - # in the terminal from which Attach was invoked. - code <- paste( - "a <- commandArgs(TRUE); ns <- loadNamespace('sess', lib.loc=a[1]);", - "stopifnot(normalizePath(getNamespaceInfo(ns,'path')) == normalizePath(file.path(a[1],'sess')));", - "stopifnot(utils::compareVersion(as.character(utils::packageVersion('sess',lib.loc=a[1])),a[2]) >= 0);", - "stopifnot(identical(", - "utils::packageDescription('sess',lib.loc=a[1],fields='Config/vscode-R/source-revision'),", - "a[3]));", - "stopifnot(all(c('connect','notify_client','request_client') %in% getNamespaceExports(ns)));", - "if (a[4] == 'TRUE') {", - "stopifnot(all(c('interactive_stop','display') %in% getNamespaceExports(ns)));", - "stopifnot(all(vapply(c('interactive_start','interactive_execute'),", - "function(n) exists(n, ns, mode='function', inherits=FALSE), FALSE)));", - "stopifnot(utils::packageDescription('sess',lib.loc=a[1],fields='Config/vscode-R/Interactive') == '1');", - "stopifnot(utils::packageDescription('sess',lib.loc=a[1],fields='NeedsCompilation') == 'no'); }" + # Verification must not accidentally use an older namespace already loaded + # in the terminal from which Attach was invoked. + code <- paste( + "a <- commandArgs(TRUE); ns <- loadNamespace('sess', lib.loc=a[1]);", + "stopifnot(normalizePath(getNamespaceInfo(ns,'path')) == normalizePath(file.path(a[1],'sess')));", + "stopifnot(utils::compareVersion(as.character(utils::packageVersion('sess',lib.loc=a[1])),a[2]) >= 0);", + "stopifnot(identical(", + "utils::packageDescription('sess',lib.loc=a[1],fields='Config/vscode-R/source-revision'),", + "a[3]));", + "stopifnot(all(c('connect','notify_client','request_client') %in% getNamespaceExports(ns)));", + "if (a[4] == 'TRUE') {", + "stopifnot(all(c('interactive_stop','display') %in% getNamespaceExports(ns)));", + "stopifnot(all(vapply(c('interactive_start','interactive_execute'),", + "function(n) exists(n, ns, mode='function', inherits=FALSE), FALSE)));", + "stopifnot(utils::packageDescription('sess',lib.loc=a[1],fields='Config/vscode-R/Interactive') == '1');", + "stopifnot(utils::packageDescription('sess',lib.loc=a[1],fields='NeedsCompilation') == 'no'); }" + ) + status <- system2( + file.path(R.home("bin"), "R"), + c( + "--vanilla", + "--slave", + "-e", + shQuote(code), + "--args", + shQuote(library), + shQuote(required), + shQuote(expected_revision), + as.character(interactive) ) - status <- system2(file.path(R.home("bin"), "R"), - c("--vanilla", "--slave", "-e", shQuote(code), "--args", - shQuote(library), shQuote(required), shQuote(expected_revision), as.character(interactive))) - if (!identical(as.integer(status), 0L)) stop("The installed sess package failed its compatibility/load check.") + ) + if (!identical(as.integer(status), 0L)) { + stop("The installed sess package failed its compatibility/load check.") + } } sess_install <- function(pkg_path, library, repos, interactive = FALSE) { - description <- read.dcf(file.path(pkg_path, "DESCRIPTION")) - required <- description[1L, "Version"] - expected_revision <- description[1L, "Config/vscode-R/source-revision"] + description <- read.dcf(file.path(pkg_path, "DESCRIPTION")) + required <- description[1L, "Version"] + expected_revision <- description[1L, "Config/vscode-R/source-revision"] - # Pass the caller's library search path to installation/verification children, - # including project libraries, without sourcing the caller's startup profile. - keys <- c("R_LIBS", "R_PROFILE_USER", "R_ENVIRON_USER") - previous <- Sys.getenv(keys, unset = NA_character_, names = TRUE) - on.exit({ - Sys.unsetenv(keys[is.na(previous)]) - if (any(!is.na(previous))) do.call(Sys.setenv, as.list(previous[!is.na(previous)])) - }, add = TRUE) - Sys.setenv(R_LIBS = paste(unique(c(library, .libPaths())), collapse = .Platform$path.sep), - R_PROFILE_USER = "", R_ENVIRON_USER = "") + # Pass the caller's library search path to installation/verification children, + # including project libraries, without sourcing the caller's startup profile. + keys <- c("R_LIBS", "R_PROFILE_USER", "R_ENVIRON_USER") + previous <- Sys.getenv(keys, unset = NA_character_, names = TRUE) + on.exit( + { + Sys.unsetenv(keys[is.na(previous)]) + if (any(!is.na(previous))) do.call(Sys.setenv, as.list(previous[!is.na(previous)])) + }, + add = TRUE + ) + Sys.setenv( + R_LIBS = paste(unique(c(library, .libPaths())), collapse = .Platform$path.sep), + R_PROFILE_USER = "", + R_ENVIRON_USER = "" + ) - deps <- if ("Imports" %in% colnames(description)) description[1L, "Imports"] else "" - deps <- trimws(gsub("\\s*\\(.*\\)", "", unlist(strsplit(deps, ",")))) - # The private Interactive runtime loads rstudioapi itself. Ordinary terminals - # obtain it on demand from the extension's tool library instead. - if (interactive) deps <- c(deps, "rstudioapi") - installed <- utils::installed.packages(lib.loc = unique(c(library, .libPaths()))) - missing <- setdiff(deps[nzchar(deps)], rownames(installed)) - if (length(missing)) { - sess_install_dependencies(missing, library, repos) - } - message("Installing bundled sess from: ", pkg_path) - if (!sess_install_command(pkg_path, library)) stop("Could not install bundled sess.") - sess_verify_package(library, required, expected_revision, interactive) - invisible(TRUE) + deps <- if ("Imports" %in% colnames(description)) description[1L, "Imports"] else "" + deps <- trimws(gsub("\\s*\\(.*\\)", "", unlist(strsplit(deps, ",")))) + # The private Interactive runtime loads rstudioapi itself. Ordinary terminals + # obtain it on demand from the extension's tool library instead. + if (interactive) { + deps <- c(deps, "rstudioapi") + } + installed <- utils::installed.packages(lib.loc = unique(c(library, .libPaths()))) + missing <- setdiff(deps[nzchar(deps)], rownames(installed)) + if (length(missing)) { + sess_install_dependencies(missing, library, repos) + } + message("Installing bundled sess from: ", pkg_path) + if (!sess_install_command(pkg_path, library)) { + stop("Could not install bundled sess.") + } + sess_verify_package(library, required, expected_revision, interactive) + invisible(TRUE) } diff --git a/R/sess_source.R b/R/sess_source.R index 0d3f7e50d..a20589f7a 100644 --- a/R/sess_source.R +++ b/R/sess_source.R @@ -1,101 +1,108 @@ # Deployment identity only. Runtime compatibility is checked by protocol_version. sess_source_revision <- function(description_path) { - tryCatch({ - desc <- read.dcf(description_path, fields = "Config/vscode-R/source-revision") - revision <- unname(desc[1, 1]) - if (is.na(revision) || !grepl("^git-tree:([a-f0-9]{40}|[a-f0-9]{64})$", revision)) { - return(NULL) - } - revision - }, error = function(e) NULL) + tryCatch( + { + desc <- read.dcf(description_path, fields = "Config/vscode-R/source-revision") + revision <- unname(desc[1, 1]) + if (is.na(revision) || !grepl("^git-tree:([a-f0-9]{40}|[a-f0-9]{64})$", revision)) { + return(NULL) + } + revision + }, + error = function(e) NULL + ) } sess_runtime_identity <- function() { - minor <- strsplit(R.version$minor, ".", fixed = TRUE)[[1L]][1L] - version <- paste(R.version$major, minor, sep = ".") - if (!grepl("^[A-Za-z0-9_.-]+$", R.version$platform) || !grepl("^[0-9]+\\.[0-9]+$", version)) { - stop("Unsupported R platform or version for managed sess library.") - } - paste(R.version$platform, version, sep = "|") + minor <- strsplit(R.version$minor, ".", fixed = TRUE)[[1L]][1L] + version <- paste(R.version$major, minor, sep = ".") + if (!grepl("^[A-Za-z0-9_.-]+$", R.version$platform) || !grepl("^[0-9]+\\.[0-9]+$", version)) { + stop("Unsupported R platform or version for managed sess library.") + } + paste(R.version$platform, version, sep = "|") } sess_managed_library <- function(root, revision) { - identity <- strsplit(sess_runtime_identity(), "|", fixed = TRUE)[[1L]] - if (length(identity) != 2L || !grepl("^git-tree:([a-f0-9]{40}|[a-f0-9]{64})$", revision)) { - stop("Cannot determine the managed sess library identity.") - } - file.path(root, identity[[1L]], identity[[2L]], sub("^git-tree:", "", revision), "library") + identity <- strsplit(sess_runtime_identity(), "|", fixed = TRUE)[[1L]] + if (length(identity) != 2L || !grepl("^git-tree:([a-f0-9]{40}|[a-f0-9]{64})$", revision)) { + stop("Cannot determine the managed sess library identity.") + } + file.path(root, identity[[1L]], identity[[2L]], sub("^git-tree:", "", revision), "library") } sess_installed_source_revision <- function(lib.loc = .libPaths()) { - # Explicit lib.loc reads the copy selected by .libPaths(), even if a different - # copy is already loaded. Do not load sess just to inspect its DESCRIPTION. - for (library in lib.loc) { - pkg <- file.path(library, "sess") - if (file.exists(file.path(pkg, "DESCRIPTION"))) { - revision <- sess_source_revision(file.path(pkg, "DESCRIPTION")) - if (!is.null(revision)) { - return(revision) - } - } + # Explicit lib.loc reads the copy selected by .libPaths(), even if a different + # copy is already loaded. Do not load sess just to inspect its DESCRIPTION. + for (library in lib.loc) { + pkg <- file.path(library, "sess") + if (file.exists(file.path(pkg, "DESCRIPTION"))) { + revision <- sess_source_revision(file.path(pkg, "DESCRIPTION")) + if (!is.null(revision)) { + return(revision) + } } - NULL + } + NULL } sess_has_source_revision <- function(revision, lib.loc = .libPaths()) { - !is.null(sess_find_source_library(revision, lib.loc)) + !is.null(sess_find_source_library(revision, lib.loc)) } sess_find_source_library <- function(revision, lib.loc = .libPaths()) { - for (library in lib.loc) { - pkg <- file.path(library, "sess") - if (file.exists(file.path(pkg, "DESCRIPTION")) && - identical(sess_source_revision(file.path(pkg, "DESCRIPTION")), revision)) { - return(library) - } + for (library in lib.loc) { + pkg <- file.path(library, "sess") + if ( + file.exists(file.path(pkg, "DESCRIPTION")) && + identical(sess_source_revision(file.path(pkg, "DESCRIPTION")), revision) + ) { + return(library) } - NULL + } + NULL } sess_loaded_source_revision <- function() { - if (!("sess" %in% loadedNamespaces())) { - return(NULL) - } - path <- getNamespaceInfo(asNamespace("sess"), "path") - sess_source_revision(file.path(path, "DESCRIPTION")) + if (!("sess" %in% loadedNamespaces())) { + return(NULL) + } + path <- getNamespaceInfo(asNamespace("sess"), "path") + sess_source_revision(file.path(path, "DESCRIPTION")) } sess_load_namespace <- function(library, revision, normal_libraries = .libPaths()) { - paths <- unique(c(library, normal_libraries)) - support_paths <- unique(c(normal_libraries, library)) - description <- read.dcf(file.path(library, "sess", "DESCRIPTION")) - imports <- if ("Imports" %in% colnames(description)) { - trimws(gsub("\\s*\\(.*\\)", "", unlist(strsplit(description[1L, "Imports"], ",")))) - } else { - character() - } - # processx may load ps during .onLoad. Load it first so dependencies found - # only in the managed library remain visible without changing .libPaths(). - if ("processx" %in% imports) { - loadNamespace("ps", lib.loc = support_paths) - } - for (package in intersect(c("jsonlite", "later", "processx"), imports)) { - loadNamespace(package, lib.loc = support_paths) - } - ns <- loadNamespace("sess", lib.loc = paths) - actual_path <- normalizePath(getNamespaceInfo(ns, "path"), winslash = "/", mustWork = TRUE) - intended_path <- normalizePath(file.path(library, "sess"), winslash = "/", mustWork = TRUE) - actual_revision <- sess_source_revision(file.path(actual_path, "DESCRIPTION")) - if (!identical(actual_path, intended_path) || !identical(actual_revision, revision)) { - stop("Loaded sess does not match the selected vscode-R source. Restart R before attaching the session watcher.") - } - ns + paths <- unique(c(library, normal_libraries)) + support_paths <- unique(c(normal_libraries, library)) + description <- read.dcf(file.path(library, "sess", "DESCRIPTION")) + imports <- if ("Imports" %in% colnames(description)) { + trimws(gsub("\\s*\\(.*\\)", "", unlist(strsplit(description[1L, "Imports"], ",")))) + } else { + character() + } + # processx may load ps during .onLoad. Load it first so dependencies found + # only in the managed library remain visible without changing .libPaths(). + if ("processx" %in% imports) { + loadNamespace("ps", lib.loc = support_paths) + } + for (package in intersect(c("jsonlite", "later", "processx"), imports)) { + loadNamespace(package, lib.loc = support_paths) + } + ns <- loadNamespace("sess", lib.loc = paths) + actual_path <- normalizePath(getNamespaceInfo(ns, "path"), winslash = "/", mustWork = TRUE) + intended_path <- normalizePath(file.path(library, "sess"), winslash = "/", mustWork = TRUE) + actual_revision <- sess_source_revision(file.path(actual_path, "DESCRIPTION")) + if (!identical(actual_path, intended_path) || !identical(actual_revision, revision)) { + stop( + "Loaded sess does not match the selected vscode-R source. Restart R before attaching the session watcher." + ) + } + ns } sess_install_required <- function(pkg_path) { - bundled <- sess_source_revision(file.path(pkg_path, "DESCRIPTION")) - if (is.null(bundled)) { - stop("Bundled sess has no valid source revision. Rebuild or reinstall the vscode-R extension.") - } - !sess_has_source_revision(bundled) + bundled <- sess_source_revision(file.path(pkg_path, "DESCRIPTION")) + if (is.null(bundled)) { + stop("Bundled sess has no valid source revision. Rebuild or reinstall the vscode-R extension.") + } + !sess_has_source_revision(bundled) } diff --git a/R/terminal-startup.R b/R/terminal-startup.R index d9dc035ac..f1024e158 100644 --- a/R/terminal-startup.R +++ b/R/terminal-startup.R @@ -5,152 +5,171 @@ .vscode_startup_protocol <- "vscode-r-terminal-startup-v1" .vscode_startup_valid <- function(file, token) { - length(file) == 1L && !is.na(file) && nzchar(file) && - length(token) == 1L && !is.na(token) && grepl("^[[:xdigit:]]{32}$", token) + length(file) == 1L && + !is.na(file) && + nzchar(file) && + length(token) == 1L && + !is.na(token) && + grepl("^[[:xdigit:]]{32}$", token) } .vscode_startup_valid_endpoint <- function(endpoint) { - length(endpoint) == 1L && !is.na(endpoint) && nzchar(endpoint) && - !grepl("[\r\n]", endpoint) + length(endpoint) == 1L && !is.na(endpoint) && nzchar(endpoint) && !grepl("[\r\n]", endpoint) } .vscode_startup_registered <- function(context) { - registered <- getOption(.vscode_startup_option) - is.list(registered) && is.list(context) && - identical(registered$file, context$file) && - identical(registered$token, context$token) && - identical(registered$pid, Sys.getpid()) && - identical(context$pid, Sys.getpid()) && - is.function(registered$run) && identical(registered$run, context$run) && - .vscode_startup_valid_endpoint(context$endpoint) + registered <- getOption(.vscode_startup_option) + is.list(registered) && + is.list(context) && + identical(registered$file, context$file) && + identical(registered$token, context$token) && + identical(registered$pid, Sys.getpid()) && + identical(context$pid, Sys.getpid()) && + is.function(registered$run) && + identical(registered$run, context$run) && + .vscode_startup_valid_endpoint(context$endpoint) } .vscode_startup_write <- function(context, attempt, state) { - lines <- c(.vscode_startup_protocol, context$token, attempt, - as.character(context$pid), context$endpoint, state) - temporary <- "" - on.exit(if (nzchar(temporary)) unlink(temporary), add = TRUE) - tryCatch(suppressWarnings({ - directory <- dirname(context$file) - if (!dir.exists(directory)) { - return(FALSE) - } - temporary <- tempfile(pattern = ".startup-", tmpdir = directory) - writeLines(lines, temporary, useBytes = TRUE) - if (.Platform$OS.type == "unix") { - Sys.chmod(temporary, "0600") - } - isTRUE(file.rename(temporary, context$file)) - }), error = function(error) FALSE) + lines <- c( + .vscode_startup_protocol, + context$token, + attempt, + as.character(context$pid), + context$endpoint, + state + ) + temporary <- "" + on.exit(if (nzchar(temporary)) unlink(temporary), add = TRUE) + tryCatch( + suppressWarnings({ + directory <- dirname(context$file) + if (!dir.exists(directory)) { + return(FALSE) + } + temporary <- tempfile(pattern = ".startup-", tmpdir = directory) + writeLines(lines, temporary, useBytes = TRUE) + if (.Platform$OS.type == "unix") { + Sys.chmod(temporary, "0600") + } + isTRUE(file.rename(temporary, context$file)) + }), + error = function(error) FALSE + ) } # Called only by the managed terminal profile. The option is process-local so # inherited environment variables cannot authorize a child R to update a parent. vscode_r_startup_register <- function(file, token, endpoint) { - if (!.vscode_startup_valid(file, token) || !.vscode_startup_valid_endpoint(endpoint)) { - return(NULL) - } - context <- list( - file = file, - token = tolower(token), - endpoint = endpoint, - pid = Sys.getpid(), - attempt = NULL - ) - context$run <- function(endpoint, setup) { - current <- vscode_r_startup_existing(endpoint) - if (is.null(current)) { - return(invisible(FALSE)) - } - vscode_r_startup_run(current, setup) - } - options(structure(list(context), names = .vscode_startup_option)) - context + if (!.vscode_startup_valid(file, token) || !.vscode_startup_valid_endpoint(endpoint)) { + return(NULL) + } + context <- list( + file = file, + token = tolower(token), + endpoint = endpoint, + pid = Sys.getpid(), + attempt = NULL + ) + context$run <- function(endpoint, setup) { + current <- vscode_r_startup_existing(endpoint) + if (is.null(current)) { + return(invisible(FALSE)) + } + vscode_r_startup_run(current, setup) + } + options(structure(list(context), names = .vscode_startup_option)) + context } # Manual attach reuses the immutable profile identity while recording its current # endpoint for this attempt. The endpoint may differ after a reconnect. vscode_r_startup_existing <- function(endpoint) { - if (!.vscode_startup_valid_endpoint(endpoint)) { - return(NULL) - } - registered <- getOption(.vscode_startup_option) - if (!is.list(registered)) { - return(NULL) - } - if (!.vscode_startup_valid(registered$file, registered$token)) { - return(NULL) - } - if (!identical(registered$pid, Sys.getpid())) { - return(NULL) - } - if (!is.function(registered$run)) { - return(NULL) - } - registered$endpoint <- endpoint - registered + if (!.vscode_startup_valid_endpoint(endpoint)) { + return(NULL) + } + registered <- getOption(.vscode_startup_option) + if (!is.list(registered)) { + return(NULL) + } + if (!.vscode_startup_valid(registered$file, registered$token)) { + return(NULL) + } + if (!identical(registered$pid, Sys.getpid())) { + return(NULL) + } + if (!is.function(registered$run)) { + return(NULL) + } + registered$endpoint <- endpoint + registered } # Publish pending before doing any package preparation or IPC work. A failed # publish returns NULL, leaving callers free to keep ordinary R usable. vscode_r_startup_begin <- function(context) { - if (!.vscode_startup_registered(context)) { - return(NULL) - } - candidate <- gsub("[^A-Za-z0-9_-]", "", basename(tempfile(pattern = "attempt-"))) - candidate <- paste0(candidate, substr(context$token, 1L, 16L)) - attempt <- substr(candidate, 1L, 64L) - if (!grepl("^[A-Za-z0-9_-]{16,64}$", attempt)) { - message("vscode-R could not create a terminal startup attempt ID.") - return(NULL) - } - if (!.vscode_startup_write(context, attempt, "pending")) { - message("vscode-R could not publish terminal startup status; the session watcher was not started.") - return(NULL) - } - context$attempt <- attempt - options(structure(list(context), names = .vscode_startup_option)) - attempt + if (!.vscode_startup_registered(context)) { + return(NULL) + } + candidate <- gsub("[^A-Za-z0-9_-]", "", basename(tempfile(pattern = "attempt-"))) + candidate <- paste0(candidate, substr(context$token, 1L, 16L)) + attempt <- substr(candidate, 1L, 64L) + if (!grepl("^[A-Za-z0-9_-]{16,64}$", attempt)) { + message("vscode-R could not create a terminal startup attempt ID.") + return(NULL) + } + if (!.vscode_startup_write(context, attempt, "pending")) { + message( + "vscode-R could not publish terminal startup status; the session watcher was not started." + ) + return(NULL) + } + context$attempt <- attempt + options(structure(list(context), names = .vscode_startup_option)) + attempt } # A completion can update only the attempt currently registered in this process. # If atomic publication fails, the last successfully published pending status remains. vscode_r_startup_finish <- function(context, attempt, state) { - if (!state %in% c("ready", "failed")) { - return(invisible(FALSE)) - } - if (!.vscode_startup_registered(context)) { - return(invisible(FALSE)) - } - registered <- getOption(.vscode_startup_option) - if (!identical(registered$attempt, attempt)) { - return(invisible(FALSE)) - } - if (!identical(registered$endpoint, context$endpoint)) { - return(invisible(FALSE)) - } - if (!.vscode_startup_write(context, attempt, state)) { - message("vscode-R could not publish terminal startup completion; status remains pending.") - return(invisible(FALSE)) - } - invisible(TRUE) + if (!state %in% c("ready", "failed")) { + return(invisible(FALSE)) + } + if (!.vscode_startup_registered(context)) { + return(invisible(FALSE)) + } + registered <- getOption(.vscode_startup_option) + if (!identical(registered$attempt, attempt)) { + return(invisible(FALSE)) + } + if (!identical(registered$endpoint, context$endpoint)) { + return(invisible(FALSE)) + } + if (!.vscode_startup_write(context, attempt, state)) { + message("vscode-R could not publish terminal startup completion; status remains pending.") + return(invisible(FALSE)) + } + invisible(TRUE) } # Wrap one setup attempt for both the profile and generated manual attach. # Without a matching profile registration, setup keeps its historical behavior. vscode_r_startup_run <- function(context, setup) { - if (is.null(context)) { - return(setup()) - } - attempt <- vscode_r_startup_begin(context) - if (is.null(attempt)) { - return(invisible(FALSE)) - } - completed <- FALSE - on.exit({ - vscode_r_startup_finish(context, attempt, if (completed) "ready" else "failed") - }, add = TRUE) - result <- setup() - completed <- isTRUE(result) - result + if (is.null(context)) { + return(setup()) + } + attempt <- vscode_r_startup_begin(context) + if (is.null(attempt)) { + return(invisible(FALSE)) + } + completed <- FALSE + on.exit( + { + vscode_r_startup_finish(context, attempt, if (completed) "ready" else "failed") + }, + add = TRUE + ) + result <- setup() + completed <- isTRUE(result) + result } diff --git a/R/tests/attach_sess.R b/R/tests/attach_sess.R index 726ce6b42..31da5680e 100644 --- a/R/tests/attach_sess.R +++ b/R/tests/attach_sess.R @@ -9,18 +9,27 @@ revision <- paste0("git-tree:", strrep("a", 40)) mismatch <- paste0("git-tree:", strrep("b", 40)) pkg <- file.path(root, "bundled", "sess") dir.create(file.path(pkg, "R"), recursive = TRUE) -writeLines(c( - "Package: sess", "Version: 1.0.0", "Title: Manual Attach Consent Fixture", - "Description: A local fixture for manual attach consent.", "License: MIT", - "Author: Test Author", "Maintainer: Test Author ", +writeLines( + c( + "Package: sess", + "Version: 1.0.0", + "Title: Manual Attach Consent Fixture", + "Description: A local fixture for manual attach consent.", + "License: MIT", + "Author: Test Author", + "Maintainer: Test Author ", paste0("Config/vscode-R/source-revision: ", revision) -), file.path(pkg, "DESCRIPTION")) -writeLines(c( + ), + file.path(pkg, "DESCRIPTION") +) +writeLines( + c( "connect <- function(endpoint=NULL, plot_backend=NULL, use_rstudioapi=TRUE, ...) {", " options(vscodeR.test.use_rstudioapi=use_rstudioapi,", " vscodeR.test.connect.args=list(...)); TRUE", "}", - "notify_client <- function(...) NULL", "request_client <- function(...) NULL", + "notify_client <- function(...) NULL", + "request_client <- function(...) NULL", ".onLoad <- function(libname, pkgname) {", " complete <- Sys.getenv('VSCODE_R_TEST_INSTALL_COMPLETE', '')", " if (nzchar(complete) && !file.exists(complete)) stop('loaded before install completed')", @@ -33,12 +42,17 @@ writeLines(c( " log <- Sys.getenv('VSCODE_R_TEST_LOAD_LOG', '')", " if (nzchar(log)) cat(role, '\\n', sep='', file=log, append=TRUE)", "}" -), file.path(pkg, "R", "api.R")) -writeLines(c("export(connect)", "export(notify_client)", "export(request_client)"), - file.path(pkg, "NAMESPACE")) + ), + file.path(pkg, "R", "api.R") +) +writeLines( + c("export(connect)", "export(notify_client)", "export(request_client)"), + file.path(pkg, "NAMESPACE") +) runner <- file.path(root, "run-case.R") -writeLines(c( +writeLines( + c( "args <- commandArgs(TRUE)", "mode <- args[[1L]]; root <- args[[2L]]; pkg <- args[[3L]]", "revision <- args[[4L]]; mismatch <- args[[5L]]", @@ -397,10 +411,13 @@ writeLines(c( " tryCatch({ execute_case(); publish_result('ok') },", " error=function(e) publish_result(paste0('error: ', conditionMessage(e))))", "} else execute_case()" -), runner) + ), + runner +) agent <- file.path(root, "consent-agent.R") -writeLines(c( +writeLines( + c( "args <- commandArgs(TRUE)", "directory <- args[[1L]]; count <- as.integer(args[[2L]])", "answers <- strsplit(args[[3L]], ',', fixed=TRUE)[[1L]]", @@ -441,259 +458,346 @@ writeLines(c( "}, error=function(e) {", "writeLines(paste0('error: ', conditionMessage(e)), status_log)", "})" -), agent) + ), + agent +) r_binary <- file.path(R.home("bin"), if (.Platform$OS.type == "windows") "R.exe" else "R") r_literal <- function(value) encodeString(value, quote = "\"") read_child_logs <- function(paths) { - read_log <- function(path) { - tryCatch(readLines(path, warn = FALSE), error = function(e) paste("could not read", path)) - } - c(read_log(paths$stdout), read_log(paths$stderr)) + read_log <- function(path) { + tryCatch(readLines(path, warn = FALSE), error = function(e) paste("could not read", path)) + } + c(read_log(paths$stdout), read_log(paths$stderr)) } run_case <- function(mode) { - case_root <- file.path(root, mode) - dir.create(case_root) + case_root <- file.path(root, mode) + dir.create(case_root) + startup_status <- file.path(case_root, "profile.status") + consent <- file.path(case_root, "consent") + dir.create(consent) + profile_modes <- c("profile_exact", "profile_decline", "profile_approve") + startup <- mode %in% profile_modes + if (startup) { + normal <- file.path(case_root, "normal library") + project <- file.path(case_root, "project library") + managed_root <- file.path(case_root, "vscode-R") + dir.create(normal) + dir.create(project) + user_profile <- file.path(case_root, "user.Rprofile") + baseline <- file.path(case_root, "profile-libraries.rds") + marker <- file.path(case_root, "user-profile-ran") + writeLines( + c( + paste0(".libPaths(c(", r_literal(project), ", .libPaths()))"), + paste0("saveRDS(.libPaths(), ", r_literal(baseline), ")"), + paste0("file.create(", r_literal(marker), ")") + ), + user_profile + ) + startup_profile <- file.path(case_root, "startup.Rprofile") startup_status <- file.path(case_root, "profile.status") - consent <- file.path(case_root, "consent") - dir.create(consent) - profile_modes <- c("profile_exact", "profile_decline", "profile_approve") - startup <- mode %in% profile_modes - if (startup) { - normal <- file.path(case_root, "normal library") - project <- file.path(case_root, "project library") - managed_root <- file.path(case_root, "vscode-R") - dir.create(normal) - dir.create(project) - user_profile <- file.path(case_root, "user.Rprofile") - baseline <- file.path(case_root, "profile-libraries.rds") - marker <- file.path(case_root, "user-profile-ran") - writeLines(c( - paste0(".libPaths(c(", r_literal(project), ", .libPaths()))"), - paste0("saveRDS(.libPaths(), ", r_literal(baseline), ")"), - paste0("file.create(", r_literal(marker), ")") - ), user_profile) - startup_profile <- file.path(case_root, "startup.Rprofile") - startup_status <- file.path(case_root, "profile.status") - production_profile <- file.path(getwd(), "R", "profile.R") - writeLines(c( - "Sys.setenv(R_PROFILE_USER_OLD=Sys.getenv('VSCODE_R_TEST_USER_PROFILE'))", - paste0(".libPaths(c(Sys.getenv('VSCODE_R_TEST_NORMAL_LIBRARY'), .libPaths()))"), - "source(Sys.getenv('VSCODE_R_TEST_PROFILE'))" - ), startup_profile) - managed_library <- sess_managed_library(managed_root, revision) - install_library <- if (mode == "profile_exact") { - normal - } else { - file.path(managed_root, "fixture-other-platform", "99.99", - strrep("a", 40), "library") - } - dir.create(install_library, recursive = TRUE, showWarnings = FALSE) - if (mode %in% c("profile_decline", "profile_approve")) { - wrong_sess <- file.path(install_library, "sess") - dir.create(wrong_sess, recursive = TRUE) - writeLines(c("Package: sess", "Version: 1.0.0", - paste0("Config/vscode-R/source-revision: ", revision)), - file.path(wrong_sess, "DESCRIPTION")) - } else { - utils::install.packages(pkg, repos = NULL, type = "source", lib = install_library, - quiet = TRUE) - } - if (mode == "profile_exact") { - unlink(consent, recursive = TRUE) - } - profile_environment <- c( - R_PROFILE_USER = startup_profile, - VSCODE_R_TEST_USER_PROFILE = user_profile, - VSCODE_R_TEST_NORMAL_LIBRARY = normal, - VSCODE_R_TEST_PROFILE = production_profile, - VSCODE_R_SESS_PKG_PATH = pkg, - VSCODE_R_SESS_SOURCE_HELPER = file.path(getwd(), "R", "sess_source.R"), - VSCODE_R_SESS_ATTACH_HELPER = file.path(getwd(), "R", "attach_sess.R"), - VSCODE_R_SESS_INSTALLER_HELPER = file.path(getwd(), "R", "sess-package-install.R"), - VSCODE_R_SESS_ROOT = managed_root, - VSCODE_R_SESS_CONSENT_DIRECTORY = consent, - VSCODE_R_SESS_STARTUP_FILE = startup_status, - VSCODE_R_SESS_STARTUP_TOKEN = paste0(strrep("c", 32L)), - VSCODE_R_SESS_STARTUP_ENDPOINT = "endpoint", - VSCODE_R_SESS_STARTUP_HELPER = file.path(getwd(), "R", "terminal-startup.R")) - profile_keys <- names(profile_environment) - previous_environment <- Sys.getenv(profile_keys, unset = NA_character_) - on.exit({ - Sys.unsetenv(profile_keys) - if (any(!is.na(previous_environment))) { - do.call(Sys.setenv, as.list(previous_environment[!is.na(previous_environment)])) - } - }, add = TRUE) - do.call(Sys.setenv, as.list(profile_environment)) - } - consent_modes <- c("markers", "mismatch", "profile_decline", "profile_approve") - if (mode %in% consent_modes) { - log <- file.path(case_root, "consent-ids") - identity_log <- file.path(case_root, "runtime-identities") - status_log <- file.path(case_root, "consent-agent-status") - count <- if (mode %in% c("markers", "profile_decline")) 2L else 1L - answer <- switch(mode, profile_approve = "approve", profile_decline = "decline,approve", - "decline") - release_marker <- if (mode %in% c("profile_decline", "profile_approve")) { - file.path(case_root, "release-profile-consent") - } else { - "" - } - system2(r_binary, shQuote(c( - "--vanilla", "--slave", paste0("--file=", agent), "--args", - consent, as.character(count), answer, log, identity_log, status_log, release_marker - )), wait = FALSE, stdout = FALSE, stderr = FALSE) - } - flags <- if (startup) { - c("--no-site-file", "--no-environ", "--slave", "--no-save", "--no-restore") + production_profile <- file.path(getwd(), "R", "profile.R") + writeLines( + c( + "Sys.setenv(R_PROFILE_USER_OLD=Sys.getenv('VSCODE_R_TEST_USER_PROFILE'))", + paste0(".libPaths(c(Sys.getenv('VSCODE_R_TEST_NORMAL_LIBRARY'), .libPaths()))"), + "source(Sys.getenv('VSCODE_R_TEST_PROFILE'))" + ), + startup_profile + ) + managed_library <- sess_managed_library(managed_root, revision) + install_library <- if (mode == "profile_exact") { + normal } else { - c("--vanilla", "--slave", "--no-save", "--no-restore") + file.path(managed_root, "fixture-other-platform", "99.99", strrep("a", 40), "library") } + dir.create(install_library, recursive = TRUE, showWarnings = FALSE) if (mode %in% c("profile_decline", "profile_approve")) { - result_file <- file.path(case_root, "startup-runner-result") - stdout_path <- file.path(case_root, "startup-runner-stdout") - stderr_path <- file.path(case_root, "startup-runner-stderr") - system2( - r_binary, - shQuote(c( - flags, - paste0("--file=", runner), "--args", mode, case_root, pkg, revision, mismatch, - "", result_file - )), - wait = FALSE, - stdout = stdout_path, - stderr = stderr_path - ) - deadline <- Sys.time() + 10 - requests <- character() - while (!length(requests) && Sys.time() < deadline) { - requests <- list.files(consent, pattern = "\\.request$", full.names = TRUE) - if (!length(requests)) Sys.sleep(0.01) - } - if (!length(requests)) stop("profile startup did not publish a consent request") - startup_record <- readLines(startup_status, warn = FALSE) - stopifnot(length(startup_record) == 6L, - startup_record[[1L]] == "vscode-r-terminal-startup-v1", - startup_record[[2L]] == Sys.getenv("VSCODE_R_SESS_STARTUP_TOKEN"), - grepl("^[A-Za-z0-9_-]{16,64}$", startup_record[[3L]]), - grepl("^[1-9][0-9]*$", startup_record[[4L]]), - startup_record[[5L]] == "endpoint", - startup_record[[6L]] == "pending") - file.create(release_marker) - deadline <- Sys.time() + 30 - while (!file.exists(result_file) && Sys.time() < deadline) Sys.sleep(0.01) - if (!file.exists(result_file)) { - child_output <- read_child_logs(list(stdout = stdout_path, stderr = stderr_path)) - stop(paste(mode, "startup child timed out; output:", paste(child_output, collapse = "\n"))) - } - child_result <- readLines(result_file, warn = FALSE) - if (!identical(child_result, "ok")) { - child_output <- read_child_logs(list(stdout = stdout_path, stderr = stderr_path)) - stop(paste(mode, "startup child failed:", paste(child_result, collapse = " "), - "output:", paste(child_output, collapse = "\n"))) - } + wrong_sess <- file.path(install_library, "sess") + dir.create(wrong_sess, recursive = TRUE) + writeLines( + c("Package: sess", "Version: 1.0.0", paste0("Config/vscode-R/source-revision: ", revision)), + file.path(wrong_sess, "DESCRIPTION") + ) } else { - output <- suppressWarnings( - system2( - r_binary, - shQuote(c( - flags, - paste0("--file=", runner), "--args", mode, case_root, pkg, revision, mismatch, - "", "" - )), - stdout = TRUE, - stderr = TRUE - ) - ) - status <- attr(output, "status") - if (!is.null(status) && status != 0L) stop(paste(output, collapse = "\n")) + utils::install.packages( + pkg, + repos = NULL, + type = "source", + lib = install_library, + quiet = TRUE + ) + } + if (mode == "profile_exact") { + unlink(consent, recursive = TRUE) } - if (mode %in% consent_modes) { - status_path <- file.path(case_root, "consent-agent-status") - deadline <- Sys.time() + 5 - while (!file.exists(status_path) && Sys.time() < deadline) Sys.sleep(0.01) - if (!file.exists(status_path)) stop(paste("consent agent did not finish:", mode)) - agent_status <- readLines(status_path, warn = FALSE) - if (!identical(agent_status, "ok")) { - stop(paste("consent agent failed in", mode, ":", paste(agent_status, collapse = " "))) + profile_environment <- c( + R_PROFILE_USER = startup_profile, + VSCODE_R_TEST_USER_PROFILE = user_profile, + VSCODE_R_TEST_NORMAL_LIBRARY = normal, + VSCODE_R_TEST_PROFILE = production_profile, + VSCODE_R_SESS_PKG_PATH = pkg, + VSCODE_R_SESS_SOURCE_HELPER = file.path(getwd(), "R", "sess_source.R"), + VSCODE_R_SESS_ATTACH_HELPER = file.path(getwd(), "R", "attach_sess.R"), + VSCODE_R_SESS_INSTALLER_HELPER = file.path(getwd(), "R", "sess-package-install.R"), + VSCODE_R_SESS_ROOT = managed_root, + VSCODE_R_SESS_CONSENT_DIRECTORY = consent, + VSCODE_R_SESS_STARTUP_FILE = startup_status, + VSCODE_R_SESS_STARTUP_TOKEN = paste0(strrep("c", 32L)), + VSCODE_R_SESS_STARTUP_ENDPOINT = "endpoint", + VSCODE_R_SESS_STARTUP_HELPER = file.path(getwd(), "R", "terminal-startup.R") + ) + profile_keys <- names(profile_environment) + previous_environment <- Sys.getenv(profile_keys, unset = NA_character_) + on.exit( + { + Sys.unsetenv(profile_keys) + if (any(!is.na(previous_environment))) { + do.call(Sys.setenv, as.list(previous_environment[!is.na(previous_environment)])) } - log_path <- file.path(case_root, "consent-ids") - ids <- readLines(log_path, warn = FALSE) - expected_count <- if (mode %in% c("markers", "profile_decline")) 2L else 1L - stopifnot(length(ids) == expected_count, !anyDuplicated(ids)) - stopifnot(all(grepl("^[A-Za-z0-9_-]{16,64}$", ids))) - identity_log <- file.path(case_root, "runtime-identities") - runtime_identity <- readLines(identity_log, warn = FALSE) - minor <- strsplit(R.version$minor, ".", fixed = TRUE)[[1L]][1L] - expected_runtime <- paste(R.version$platform, - paste(R.version$major, minor, sep = "."), sep = "|") - stopifnot(length(runtime_identity) == expected_count) - stopifnot(all(runtime_identity == expected_runtime)) + }, + add = TRUE + ) + do.call(Sys.setenv, as.list(profile_environment)) + } + consent_modes <- c("markers", "mismatch", "profile_decline", "profile_approve") + if (mode %in% consent_modes) { + log <- file.path(case_root, "consent-ids") + identity_log <- file.path(case_root, "runtime-identities") + status_log <- file.path(case_root, "consent-agent-status") + count <- if (mode %in% c("markers", "profile_decline")) 2L else 1L + answer <- switch( + mode, + profile_approve = "approve", + profile_decline = "decline,approve", + "decline" + ) + release_marker <- if (mode %in% c("profile_decline", "profile_approve")) { + file.path(case_root, "release-profile-consent") + } else { + "" + } + system2( + r_binary, + shQuote(c( + "--vanilla", + "--slave", + paste0("--file=", agent), + "--args", + consent, + as.character(count), + answer, + log, + identity_log, + status_log, + release_marker + )), + wait = FALSE, + stdout = FALSE, + stderr = FALSE + ) + } + flags <- if (startup) { + c("--no-site-file", "--no-environ", "--slave", "--no-save", "--no-restore") + } else { + c("--vanilla", "--slave", "--no-save", "--no-restore") + } + if (mode %in% c("profile_decline", "profile_approve")) { + result_file <- file.path(case_root, "startup-runner-result") + stdout_path <- file.path(case_root, "startup-runner-stdout") + stderr_path <- file.path(case_root, "startup-runner-stderr") + system2( + r_binary, + shQuote(c( + flags, + paste0("--file=", runner), + "--args", + mode, + case_root, + pkg, + revision, + mismatch, + "", + result_file + )), + wait = FALSE, + stdout = stdout_path, + stderr = stderr_path + ) + deadline <- Sys.time() + 10 + requests <- character() + while (!length(requests) && Sys.time() < deadline) { + requests <- list.files(consent, pattern = "\\.request$", full.names = TRUE) + if (!length(requests)) Sys.sleep(0.01) + } + if (!length(requests)) { + stop("profile startup did not publish a consent request") + } + startup_record <- readLines(startup_status, warn = FALSE) + stopifnot( + length(startup_record) == 6L, + startup_record[[1L]] == "vscode-r-terminal-startup-v1", + startup_record[[2L]] == Sys.getenv("VSCODE_R_SESS_STARTUP_TOKEN"), + grepl("^[A-Za-z0-9_-]{16,64}$", startup_record[[3L]]), + grepl("^[1-9][0-9]*$", startup_record[[4L]]), + startup_record[[5L]] == "endpoint", + startup_record[[6L]] == "pending" + ) + file.create(release_marker) + deadline <- Sys.time() + 30 + while (!file.exists(result_file) && Sys.time() < deadline) { + Sys.sleep(0.01) + } + if (!file.exists(result_file)) { + child_output <- read_child_logs(list(stdout = stdout_path, stderr = stderr_path)) + stop(paste(mode, "startup child timed out; output:", paste(child_output, collapse = "\n"))) + } + child_result <- readLines(result_file, warn = FALSE) + if (!identical(child_result, "ok")) { + child_output <- read_child_logs(list(stdout = stdout_path, stderr = stderr_path)) + stop(paste( + mode, + "startup child failed:", + paste(child_result, collapse = " "), + "output:", + paste(child_output, collapse = "\n") + )) + } + } else { + output <- suppressWarnings(system2( + r_binary, + shQuote(c( + flags, + paste0("--file=", runner), + "--args", + mode, + case_root, + pkg, + revision, + mismatch, + "", + "" + )), + stdout = TRUE, + stderr = TRUE + )) + status <- attr(output, "status") + if (!is.null(status) && status != 0L) stop(paste(output, collapse = "\n")) + } + if (mode %in% consent_modes) { + status_path <- file.path(case_root, "consent-agent-status") + deadline <- Sys.time() + 5 + while (!file.exists(status_path) && Sys.time() < deadline) { + Sys.sleep(0.01) } + if (!file.exists(status_path)) { + stop(paste("consent agent did not finish:", mode)) + } + agent_status <- readLines(status_path, warn = FALSE) + if (!identical(agent_status, "ok")) { + stop(paste("consent agent failed in", mode, ":", paste(agent_status, collapse = " "))) + } + log_path <- file.path(case_root, "consent-ids") + ids <- readLines(log_path, warn = FALSE) + expected_count <- if (mode %in% c("markers", "profile_decline")) 2L else 1L + stopifnot(length(ids) == expected_count, !anyDuplicated(ids)) + stopifnot(all(grepl("^[A-Za-z0-9_-]{16,64}$", ids))) + identity_log <- file.path(case_root, "runtime-identities") + runtime_identity <- readLines(identity_log, warn = FALSE) + minor <- strsplit(R.version$minor, ".", fixed = TRUE)[[1L]][1L] + expected_runtime <- paste( + R.version$platform, + paste(R.version$major, minor, sep = "."), + sep = "|" + ) + stopifnot(length(runtime_identity) == expected_count) + stopifnot(all(runtime_identity == expected_runtime)) + } } for (mode in c( - "mismatch", "exact", "prepared", "markers", "profile_exact", "profile_decline", "profile_approve" -)) run_case(mode) + "mismatch", + "exact", + "prepared", + "markers", + "profile_exact", + "profile_decline", + "profile_approve" +)) { + run_case(mode) +} wait_for_file <- function(path, seconds, description) { - deadline <- Sys.time() + seconds - while (!file.exists(path) && Sys.time() < deadline) Sys.sleep(0.01) - if (!file.exists(path)) stop(paste("Timed out waiting for", description)) + deadline <- Sys.time() + seconds + while (!file.exists(path) && Sys.time() < deadline) { + Sys.sleep(0.01) + } + if (!file.exists(path)) stop(paste("Timed out waiting for", description)) } wait_for_request <- function(directory, seconds) { - deadline <- Sys.time() + seconds - requests <- character() - while (!length(requests) && Sys.time() < deadline) { - requests <- list.files(directory, pattern = "\\.request$", full.names = TRUE) - if (!length(requests)) Sys.sleep(0.01) - } - if (!length(requests)) stop("Timed out waiting for owner consent request") - requests[[1L]] + deadline <- Sys.time() + seconds + requests <- character() + while (!length(requests) && Sys.time() < deadline) { + requests <- list.files(directory, pattern = "\\.request$", full.names = TRUE) + if (!length(requests)) Sys.sleep(0.01) + } + if (!length(requests)) { + stop("Timed out waiting for owner consent request") + } + requests[[1L]] } -start_consent_agent <- function(case_root, answer, wait_marker = "", label = "consent", - count = 1L, script = agent) { - consent <- file.path(case_root, "consent") - log <- file.path(case_root, paste0(label, "-ids")) - identity_log <- file.path(case_root, paste0(label, "-identities")) - status <- file.path(case_root, paste0(label, "-status")) - stdout <- file.path(case_root, paste0(label, "-stdout")) - stderr <- file.path(case_root, paste0(label, "-stderr")) - system2( - r_binary, - shQuote(c( - "--vanilla", "--slave", paste0("--file=", script), "--args", - consent, as.character(count), answer, log, identity_log, status, wait_marker - )), - wait = FALSE, - stdout = stdout, - stderr = stderr - ) - list(log = log, identity_log = identity_log, status = status, - stdout = stdout, stderr = stderr) +start_consent_agent <- function( + case_root, + answer, + wait_marker = "", + label = "consent", + count = 1L, + script = agent +) { + consent <- file.path(case_root, "consent") + log <- file.path(case_root, paste0(label, "-ids")) + identity_log <- file.path(case_root, paste0(label, "-identities")) + status <- file.path(case_root, paste0(label, "-status")) + stdout <- file.path(case_root, paste0(label, "-stdout")) + stderr <- file.path(case_root, paste0(label, "-stderr")) + system2( + r_binary, + shQuote(c( + "--vanilla", + "--slave", + paste0("--file=", script), + "--args", + consent, + as.character(count), + answer, + log, + identity_log, + status, + wait_marker + )), + wait = FALSE, + stdout = stdout, + stderr = stderr + ) + list(log = log, identity_log = identity_log, status = status, stdout = stdout, stderr = stderr) } wait_for_agent <- function(paths, count = 1L) { - wait_for_file(paths$status, 10, "consent-agent completion") - result <- readLines(paths$status, warn = FALSE) - if (!identical(result, "ok")) { - stop(paste("Consent agent failed:", paste(result, collapse = " "))) - } - ids <- readLines(paths$log, warn = FALSE) - identities <- readLines(paths$identity_log, warn = FALSE) - stopifnot(length(ids) == count, !anyDuplicated(ids), - all(grepl("^[A-Za-z0-9_-]{16,64}$", ids))) - minor <- strsplit(R.version$minor, ".", fixed = TRUE)[[1L]][1L] - expected_runtime <- paste( - R.version$platform, - paste(R.version$major, minor, sep = "."), - sep = "|" - ) - stopifnot(identical(identities, rep(expected_runtime, count))) - ids + wait_for_file(paths$status, 10, "consent-agent completion") + result <- readLines(paths$status, warn = FALSE) + if (!identical(result, "ok")) { + stop(paste("Consent agent failed:", paste(result, collapse = " "))) + } + ids <- readLines(paths$log, warn = FALSE) + identities <- readLines(paths$identity_log, warn = FALSE) + stopifnot(length(ids) == count, !anyDuplicated(ids), all(grepl("^[A-Za-z0-9_-]{16,64}$", ids))) + minor <- strsplit(R.version$minor, ".", fixed = TRUE)[[1L]][1L] + expected_runtime <- paste(R.version$platform, paste(R.version$major, minor, sep = "."), sep = "|") + stopifnot(identical(identities, rep(expected_runtime, count))) + ids } # Force the list/read race instead of relying on platform scheduling: one request @@ -710,21 +814,25 @@ second_request <- file.path(scan_consent, paste0(second_id, ".request")) first_response <- file.path(scan_consent, paste0(first_id, ".response")) scan_reads <- file.path(scan_root, "first-request-reads") request_lines <- function(id) { - c("vscode-r-sess-consent-v1", id, revision, sess_runtime_identity(), "missing") + c("vscode-r-sess-consent-v1", id, revision, sess_runtime_identity(), "missing") } writeLines(request_lines(expired_id), expired_request) writeLines(request_lines(first_id), first_request) scan_agent <- file.path(scan_root, "raced-agent.R") -writeLines(c( +writeLines( + c( paste0("expired <- ", r_literal(expired_request)), paste0("first <- ", r_literal(first_request)), paste0("second <- ", r_literal(second_request)), paste0("response <- ", r_literal(first_response)), "reads <- 0L", "list.files <- function(...) {", - paste0(" if (file.exists(response) && !file.exists(second)) writeLines(", - "c(", paste(vapply(request_lines(second_id), r_literal, ""), collapse = ", "), - "), second)"), + paste0( + " if (file.exists(response) && !file.exists(second)) writeLines(", + "c(", + paste(vapply(request_lines(second_id), r_literal, ""), collapse = ", "), + "), second)" + ), " files <- base::list.files(...)", " if (expired %in% files) unlink(expired)", " files", @@ -738,216 +846,243 @@ writeLines(c( "}", paste0("source(", r_literal(agent), ")"), paste0("writeLines(as.character(reads), ", r_literal(scan_reads), ")") -), scan_agent) + ), + scan_agent +) scan_paths <- start_consent_agent(scan_root, "decline", count = 2L, script = scan_agent) scan_ids <- wait_for_agent(scan_paths, count = 2L) wait_for_file(scan_reads, 5, "consent scan fixture completion") -stopifnot(identical(scan_ids, c(first_id, second_id)), !file.exists(expired_request), - identical(readLines(scan_reads), "1")) +stopifnot( + identical(scan_ids, c(first_id, second_id)), + !file.exists(expired_request), + identical(readLines(scan_reads), "1") +) start_parallel_child <- function(case_root, mode, role, result_file, install_helper = "") { - environment_names <- c("VSCODE_R_TEST_INSTALL_HELPER", "VSCODE_R_TEST_REQUEST_LOG") - previous <- Sys.getenv(environment_names, unset = NA_character_) - do.call( - Sys.setenv, - as.list(c( - VSCODE_R_TEST_INSTALL_HELPER = install_helper, - VSCODE_R_TEST_REQUEST_LOG = file.path(case_root, "published-requests") - )) - ) - on.exit({ - Sys.unsetenv(environment_names) - if (any(!is.na(previous))) do.call(Sys.setenv, as.list(previous[!is.na(previous)])) - }) - stdout <- file.path(case_root, paste0(role, "-stdout")) - stderr <- file.path(case_root, paste0(role, "-stderr")) - system2( - r_binary, - shQuote(c( - "--vanilla", "--slave", paste0("--file=", runner), "--args", - mode, case_root, pkg, revision, mismatch, role, result_file - )), - wait = FALSE, - stdout = stdout, - stderr = stderr - ) - list(result = result_file, stdout = stdout, stderr = stderr) + environment_names <- c("VSCODE_R_TEST_INSTALL_HELPER", "VSCODE_R_TEST_REQUEST_LOG") + previous <- Sys.getenv(environment_names, unset = NA_character_) + do.call( + Sys.setenv, + as.list(c( + VSCODE_R_TEST_INSTALL_HELPER = install_helper, + VSCODE_R_TEST_REQUEST_LOG = file.path(case_root, "published-requests") + )) + ) + on.exit({ + Sys.unsetenv(environment_names) + if (any(!is.na(previous))) do.call(Sys.setenv, as.list(previous[!is.na(previous)])) + }) + stdout <- file.path(case_root, paste0(role, "-stdout")) + stderr <- file.path(case_root, paste0(role, "-stderr")) + system2( + r_binary, + shQuote(c( + "--vanilla", + "--slave", + paste0("--file=", runner), + "--args", + mode, + case_root, + pkg, + revision, + mismatch, + role, + result_file + )), + wait = FALSE, + stdout = stdout, + stderr = stderr + ) + list(result = result_file, stdout = stdout, stderr = stderr) } wait_for_child <- function(paths, description) { - # Must exceed the parallel follower's setup budget so its own diagnostic wins. - deadline <- Sys.time() + 90 - while (!file.exists(paths$result) && Sys.time() < deadline) Sys.sleep(0.01) - child_output <- read_child_logs(paths) - if (!file.exists(paths$result)) { - stop(paste(description, "timed out; child output:", paste(child_output, collapse = "\n"))) - } - result <- readLines(paths$result, warn = FALSE) - if (!identical(result, "ok")) { - stop(paste(description, "failed:", paste(result, collapse = " "), - "child output:", paste(child_output, collapse = "\n"))) - } - invisible(TRUE) + # Must exceed the parallel follower's setup budget so its own diagnostic wins. + deadline <- Sys.time() + 90 + while (!file.exists(paths$result) && Sys.time() < deadline) { + Sys.sleep(0.01) + } + child_output <- read_child_logs(paths) + if (!file.exists(paths$result)) { + stop(paste(description, "timed out; child output:", paste(child_output, collapse = "\n"))) + } + result <- readLines(paths$result, warn = FALSE) + if (!identical(result, "ok")) { + stop(paste( + description, + "failed:", + paste(result, collapse = " "), + "child output:", + paste(child_output, collapse = "\n") + )) + } + invisible(TRUE) } run_parallel_setup <- function(approve) { - mode <- if (approve) "parallel_approve" else "parallel_decline" - case_root <- file.path(root, mode) - dir.create(case_root) - consent <- file.path(case_root, "consent") - dir.create(consent) - managed_root <- file.path(case_root, "vscode-R") - managed_library <- sess_managed_library(managed_root, revision) - lock_path <- file.path(dirname(managed_library), ".setup-lock") - ready_path <- file.path(dirname(managed_library), ".ready") - owner_ready <- file.path(case_root, "owner-lock-ready") - follower_observed <- file.path(case_root, "follower-observed-lock") - install_complete <- file.path(case_root, "install-complete") - description_visible <- file.path(case_root, "install-description-visible") - install_release <- file.path(case_root, "allow-install-complete") - install_log <- file.path(case_root, "install-invocations") - load_log <- file.path(case_root, "load-log") - install_helper <- file.path(case_root, "blocking-installer.R") - writeLines(c( - "sess_install <- function(pkg_path, library, repo) {", - paste0(" cat('install\\n', file=", r_literal(install_log), ", append=TRUE)"), - " test_vars <- c('VSCODE_R_TEST_ROLE', 'VSCODE_R_TEST_LOCK_OWNER',", - " 'VSCODE_R_TEST_LOAD_LOG', 'VSCODE_R_TEST_INSTALL_COMPLETE')", - " previous <- Sys.getenv(test_vars, unset=NA_character_)", - " Sys.unsetenv(test_vars)", - " on.exit({", - " Sys.unsetenv(test_vars)", - " if (any(!is.na(previous))) do.call(Sys.setenv, as.list(previous[!is.na(previous)]))", - " }, add=TRUE)", - " utils::install.packages(pkg_path, repos=NULL, type='source', lib=library, quiet=TRUE)", - paste0(" if (!file.exists(file.path(library, 'sess', 'DESCRIPTION'))) stop('install failed')"), - paste0(" file.create(", r_literal(description_visible), ")"), - paste0(" deadline <- Sys.time() + 60; release <- ", r_literal(install_release)), - " while (!file.exists(release) && Sys.time() < deadline) Sys.sleep(0.01)", - " if (!file.exists(release)) stop('installer fixture release timed out')", - paste0(" file.create(", r_literal(install_complete), ")"), - "}" - ), install_helper) + mode <- if (approve) "parallel_approve" else "parallel_decline" + case_root <- file.path(root, mode) + dir.create(case_root) + consent <- file.path(case_root, "consent") + dir.create(consent) + managed_root <- file.path(case_root, "vscode-R") + managed_library <- sess_managed_library(managed_root, revision) + lock_path <- file.path(dirname(managed_library), ".setup-lock") + ready_path <- file.path(dirname(managed_library), ".ready") + owner_ready <- file.path(case_root, "owner-lock-ready") + follower_observed <- file.path(case_root, "follower-observed-lock") + install_complete <- file.path(case_root, "install-complete") + description_visible <- file.path(case_root, "install-description-visible") + install_release <- file.path(case_root, "allow-install-complete") + install_log <- file.path(case_root, "install-invocations") + load_log <- file.path(case_root, "load-log") + install_helper <- file.path(case_root, "blocking-installer.R") + writeLines( + c( + "sess_install <- function(pkg_path, library, repo) {", + paste0(" cat('install\\n', file=", r_literal(install_log), ", append=TRUE)"), + " test_vars <- c('VSCODE_R_TEST_ROLE', 'VSCODE_R_TEST_LOCK_OWNER',", + " 'VSCODE_R_TEST_LOAD_LOG', 'VSCODE_R_TEST_INSTALL_COMPLETE')", + " previous <- Sys.getenv(test_vars, unset=NA_character_)", + " Sys.unsetenv(test_vars)", + " on.exit({", + " Sys.unsetenv(test_vars)", + " if (any(!is.na(previous))) do.call(Sys.setenv, as.list(previous[!is.na(previous)]))", + " }, add=TRUE)", + " utils::install.packages(pkg_path, repos=NULL, type='source', lib=library, quiet=TRUE)", + paste0( + " if (!file.exists(file.path(library, 'sess', 'DESCRIPTION'))) stop('install failed')" + ), + paste0(" file.create(", r_literal(description_visible), ")"), + paste0(" deadline <- Sys.time() + 60; release <- ", r_literal(install_release)), + " while (!file.exists(release) && Sys.time() < deadline) Sys.sleep(0.01)", + " if (!file.exists(release)) stop('installer fixture release timed out')", + paste0(" file.create(", r_literal(install_complete), ")"), + "}" + ), + install_helper + ) - agent_paths <- start_consent_agent( - case_root, - if (approve) "approve" else "decline", - follower_observed - ) - owner_result <- file.path(case_root, "owner-result") - follower_result <- file.path(case_root, "follower-result") - owner <- start_parallel_child(case_root, mode, "owner", owner_result, install_helper) - wait_for_file(owner_ready, 10, "owner setup lock") - wait_for_request(consent, 10) - follower <- start_parallel_child(case_root, mode, "follower", follower_result) - wait_for_file(follower_observed, 10, "follower observation of the held setup lock") + agent_paths <- start_consent_agent( + case_root, + if (approve) "approve" else "decline", + follower_observed + ) + owner_result <- file.path(case_root, "owner-result") + follower_result <- file.path(case_root, "follower-result") + owner <- start_parallel_child(case_root, mode, "owner", owner_result, install_helper) + wait_for_file(owner_ready, 10, "owner setup lock") + wait_for_request(consent, 10) + follower <- start_parallel_child(case_root, mode, "follower", follower_result) + wait_for_file(follower_observed, 10, "follower observation of the held setup lock") - if (approve) { - wait_for_file(description_visible, 60, "installed package metadata while owner holds lock") - stopifnot(dir.exists(lock_path), file.exists(file.path(managed_library, "sess", "DESCRIPTION"))) - stopifnot(!file.exists(load_log), !file.exists(ready_path)) - file.create(install_release) - wait_for_file(install_complete, 60, "installer verification completion") + if (approve) { + wait_for_file(description_visible, 60, "installed package metadata while owner holds lock") + stopifnot(dir.exists(lock_path), file.exists(file.path(managed_library, "sess", "DESCRIPTION"))) + stopifnot(!file.exists(load_log), !file.exists(ready_path)) + file.create(install_release) + wait_for_file(install_complete, 60, "installer verification completion") + } + wait_for_child(owner, paste(mode, "role=owner")) + wait_for_child(follower, paste(mode, "role=follower")) + request_ids <- wait_for_agent(agent_paths) + published_requests <- readLines(file.path(case_root, "published-requests"), warn = FALSE) + stopifnot(length(published_requests) == 1L) + stopifnot(length(list.files(consent, pattern = "\\.(request|response)$")) == 0L) + stopifnot(!dir.exists(lock_path)) + if (approve) { + stopifnot(length(readLines(install_log, warn = FALSE)) == 1L) + stopifnot(file.exists(install_complete), file.exists(load_log)) + stopifnot(identical(readLines(ready_path, warn = FALSE), revision)) + loads <- readLines(load_log, warn = FALSE) + if (!identical(sort(loads), c("follower", "owner"))) { + stop(paste("unexpected package load sequence:", paste(loads, collapse = ", "))) } - wait_for_child(owner, paste(mode, "role=owner")) - wait_for_child(follower, paste(mode, "role=follower")) - request_ids <- wait_for_agent(agent_paths) + } else { + stopifnot(!file.exists(install_log), !dir.exists(managed_library)) + stopifnot(!file.exists(load_log), !file.exists(ready_path)) + + third_agent <- start_consent_agent(case_root, "decline", label = "third-consent") + third_result <- file.path(case_root, "third-result") + third <- start_parallel_child(case_root, "parallel_third", "third", third_result) + wait_for_child(third, "parallel_third role=third after decline") + third_id <- wait_for_agent(third_agent) + stopifnot(!identical(third_id, request_ids)) published_requests <- readLines(file.path(case_root, "published-requests"), warn = FALSE) - stopifnot(length(published_requests) == 1L) + stopifnot(length(published_requests) == 2L) stopifnot(length(list.files(consent, pattern = "\\.(request|response)$")) == 0L) - stopifnot(!dir.exists(lock_path)) - if (approve) { - stopifnot(length(readLines(install_log, warn = FALSE)) == 1L) - stopifnot(file.exists(install_complete), file.exists(load_log)) - stopifnot(identical(readLines(ready_path, warn = FALSE), revision)) - loads <- readLines(load_log, warn = FALSE) - if (!identical(sort(loads), c("follower", "owner"))) { - stop(paste("unexpected package load sequence:", paste(loads, collapse = ", "))) - } - } else { - stopifnot(!file.exists(install_log), !dir.exists(managed_library)) - stopifnot(!file.exists(load_log), !file.exists(ready_path)) - - third_agent <- start_consent_agent(case_root, "decline", label = "third-consent") - third_result <- file.path(case_root, "third-result") - third <- start_parallel_child(case_root, "parallel_third", "third", third_result) - wait_for_child(third, "parallel_third role=third after decline") - third_id <- wait_for_agent(third_agent) - stopifnot(!identical(third_id, request_ids)) - published_requests <- readLines(file.path(case_root, "published-requests"), warn = FALSE) - stopifnot(length(published_requests) == 2L) - stopifnot(length(list.files(consent, pattern = "\\.(request|response)$")) == 0L) - stopifnot(!dir.exists(lock_path), !dir.exists(managed_library)) - stopifnot(!file.exists(install_log), !file.exists(load_log), !file.exists(ready_path)) - } + stopifnot(!dir.exists(lock_path), !dir.exists(managed_library)) + stopifnot(!file.exists(install_log), !file.exists(load_log), !file.exists(ready_path)) + } } run_parallel_setup(TRUE) run_parallel_setup(FALSE) run_failed_install <- function() { - case_root <- file.path(root, "parallel-failed-install") - dir.create(case_root) - dir.create(file.path(case_root, "consent")) - managed_library <- sess_managed_library(file.path(case_root, "vscode-R"), revision) - lock_path <- file.path(dirname(managed_library), ".setup-lock") - ready_path <- file.path(dirname(managed_library), ".ready") - request_log <- file.path(case_root, "published-requests") - failure_helper <- file.path(case_root, "failing-installer.R") - dir.create(managed_library, recursive = TRUE) - utils::install.packages(pkg, repos = NULL, type = "source", lib = managed_library, quiet = TRUE) - existing_description <- file.path(managed_library, "sess", "DESCRIPTION") - description <- read.dcf(existing_description) - description[1L, "Config/vscode-R/source-revision"] <- mismatch - write.dcf(description, existing_description) - writeLines(revision, ready_path) - writeLines(c( - "sess_install <- function(pkg_path, library, repo) {", - " test_vars <- c('VSCODE_R_TEST_ROLE', 'VSCODE_R_TEST_LOCK_OWNER',", - " 'VSCODE_R_TEST_LOAD_LOG', 'VSCODE_R_TEST_INSTALL_COMPLETE')", - " previous <- Sys.getenv(test_vars, unset=NA_character_)", - " Sys.unsetenv(test_vars)", - " on.exit({", - " Sys.unsetenv(test_vars)", - " if (any(!is.na(previous))) do.call(Sys.setenv, as.list(previous[!is.na(previous)]))", - " }, add=TRUE)", - " utils::install.packages(pkg_path, repos=NULL, type='source', lib=library, quiet=TRUE)", - " if (!file.exists(file.path(library, 'sess', 'DESCRIPTION'))) stop('install failed')", - " stop('injected verification failure')", - "}" - ), failure_helper) + case_root <- file.path(root, "parallel-failed-install") + dir.create(case_root) + dir.create(file.path(case_root, "consent")) + managed_library <- sess_managed_library(file.path(case_root, "vscode-R"), revision) + lock_path <- file.path(dirname(managed_library), ".setup-lock") + ready_path <- file.path(dirname(managed_library), ".ready") + request_log <- file.path(case_root, "published-requests") + failure_helper <- file.path(case_root, "failing-installer.R") + dir.create(managed_library, recursive = TRUE) + utils::install.packages(pkg, repos = NULL, type = "source", lib = managed_library, quiet = TRUE) + existing_description <- file.path(managed_library, "sess", "DESCRIPTION") + description <- read.dcf(existing_description) + description[1L, "Config/vscode-R/source-revision"] <- mismatch + write.dcf(description, existing_description) + writeLines(revision, ready_path) + writeLines( + c( + "sess_install <- function(pkg_path, library, repo) {", + " test_vars <- c('VSCODE_R_TEST_ROLE', 'VSCODE_R_TEST_LOCK_OWNER',", + " 'VSCODE_R_TEST_LOAD_LOG', 'VSCODE_R_TEST_INSTALL_COMPLETE')", + " previous <- Sys.getenv(test_vars, unset=NA_character_)", + " Sys.unsetenv(test_vars)", + " on.exit({", + " Sys.unsetenv(test_vars)", + " if (any(!is.na(previous))) do.call(Sys.setenv, as.list(previous[!is.na(previous)]))", + " }, add=TRUE)", + " utils::install.packages(pkg_path, repos=NULL, type='source', lib=library, quiet=TRUE)", + " if (!file.exists(file.path(library, 'sess', 'DESCRIPTION'))) stop('install failed')", + " stop('injected verification failure')", + "}" + ), + failure_helper + ) - first_agent <- start_consent_agent(case_root, "approve", label = "failure-consent") - first_result <- file.path(case_root, "failure-result") - first <- start_parallel_child( - case_root, - "parallel_failure", - "failure-owner", - first_result, - failure_helper - ) - wait_for_child(first, "parallel_failure role=failure-owner") - first_id <- wait_for_agent(first_agent) - stopifnot(file.exists(file.path(managed_library, "sess", "DESCRIPTION"))) - stopifnot(identical(sess_source_revision(file.path(managed_library, "sess", "DESCRIPTION")), revision)) - stopifnot(!file.exists(ready_path), !dir.exists(lock_path)) - stopifnot(length(readLines(request_log, warn = FALSE)) == 1L) + first_agent <- start_consent_agent(case_root, "approve", label = "failure-consent") + first_result <- file.path(case_root, "failure-result") + first <- start_parallel_child( + case_root, + "parallel_failure", + "failure-owner", + first_result, + failure_helper + ) + wait_for_child(first, "parallel_failure role=failure-owner") + first_id <- wait_for_agent(first_agent) + stopifnot(file.exists(file.path(managed_library, "sess", "DESCRIPTION"))) + stopifnot(identical( + sess_source_revision(file.path(managed_library, "sess", "DESCRIPTION")), + revision + )) + stopifnot(!file.exists(ready_path), !dir.exists(lock_path)) + stopifnot(length(readLines(request_log, warn = FALSE)) == 1L) - retry_agent <- start_consent_agent(case_root, "decline", label = "retry-consent") - retry_result <- file.path(case_root, "retry-result") - retry <- start_parallel_child( - case_root, - "parallel_retry", - "retry", - retry_result - ) - wait_for_child(retry, "parallel_retry role=retry after failed setup") - retry_id <- wait_for_agent(retry_agent) - stopifnot(!identical(first_id, retry_id)) - stopifnot(length(readLines(request_log, warn = FALSE)) == 2L) - stopifnot(file.exists(file.path(managed_library, "sess", "DESCRIPTION"))) - stopifnot(!file.exists(ready_path), !dir.exists(lock_path)) - stopifnot(!file.exists(file.path(case_root, "load-log"))) + retry_agent <- start_consent_agent(case_root, "decline", label = "retry-consent") + retry_result <- file.path(case_root, "retry-result") + retry <- start_parallel_child(case_root, "parallel_retry", "retry", retry_result) + wait_for_child(retry, "parallel_retry role=retry after failed setup") + retry_id <- wait_for_agent(retry_agent) + stopifnot(!identical(first_id, retry_id)) + stopifnot(length(readLines(request_log, warn = FALSE)) == 2L) + stopifnot(file.exists(file.path(managed_library, "sess", "DESCRIPTION"))) + stopifnot(!file.exists(ready_path), !dir.exists(lock_path)) + stopifnot(!file.exists(file.path(case_root, "load-log"))) } run_failed_install() @@ -955,26 +1090,33 @@ run_failed_install() timeout_root <- file.path(root, "foreign-lock-timeout") dir.create(timeout_root) timeout_lock <- file.path( - dirname(sess_managed_library(file.path(timeout_root, "vscode-R"), revision)), - ".setup-lock" + dirname(sess_managed_library(file.path(timeout_root, "vscode-R"), revision)), + ".setup-lock" ) dir.create(timeout_lock, recursive = TRUE) foreign_marker <- file.path(timeout_lock, "foreign-owner") writeLines("preserve", foreign_marker) timeout_result <- file.path(timeout_root, "result") -timeout_output <- suppressWarnings( - system2( - r_binary, - shQuote(c( - "--vanilla", "--slave", paste0("--file=", runner), "--args", - "lock_timeout", timeout_root, pkg, revision, mismatch, "timeout", timeout_result - )), - stdout = TRUE, - stderr = TRUE - ) -) +timeout_output <- suppressWarnings(system2( + r_binary, + shQuote(c( + "--vanilla", + "--slave", + paste0("--file=", runner), + "--args", + "lock_timeout", + timeout_root, + pkg, + revision, + mismatch, + "timeout", + timeout_result + )), + stdout = TRUE, + stderr = TRUE +)) if (!is.null(attr(timeout_output, "status")) && attr(timeout_output, "status") != 0L) { - stop(paste(timeout_output, collapse = "\n")) + stop(paste(timeout_output, collapse = "\n")) } stopifnot(identical(readLines(timeout_result, warn = FALSE), "ok")) stopifnot(dir.exists(timeout_lock), identical(readLines(foreign_marker, warn = FALSE), "preserve")) diff --git a/R/tests/prepare-jgd.R b/R/tests/prepare-jgd.R index 5a8d3b46c..8b262cb15 100644 --- a/R/tests/prepare-jgd.R +++ b/R/tests/prepare-jgd.R @@ -1,558 +1,790 @@ # Base-R integration coverage for optional jgd preparation during attach. local({ - root <- tempfile("prepare-jgd-") - dir.create(root) - root <- normalizePath(root, winslash = "/", mustWork = TRUE) - r_literal <- function(value) paste0("\"", gsub("\\\"", "\\\\\\\"", value), "\"") - on.exit(unlink(root, recursive = TRUE), add = TRUE) - ambient_library <- file.path(root, "ambient-user-library") - isolated_child_env <- function(label, libraries = "") { - user_library <- file.path(root, "isolated-libraries", label, "user") - site_library <- file.path(root, "isolated-libraries", label, "site") - dir.create(user_library, recursive = TRUE, showWarnings = FALSE) - dir.create(site_library, recursive = TRUE, showWarnings = FALSE) - c(R_LIBS_USER = user_library, R_LIBS_SITE = site_library, - R_LIBS = libraries, VSCODE_R_TEST_AMBIENT_LIBRARY = ambient_library) - } - with_child_environment <- function(environment, expression) { - stopifnot(is.character(environment), !is.null(names(environment)), - !anyNA(environment), !anyDuplicated(names(environment))) - keys <- names(environment) - previous <- Sys.getenv(keys, unset = NA_character_) - on.exit({ - unset <- keys[is.na(previous)] - if (length(unset)) Sys.unsetenv(unset) - restore <- previous[!is.na(previous)] - if (length(restore)) do.call(Sys.setenv, as.list(restore)) - }, add = TRUE) - do.call(Sys.setenv, as.list(environment)) - force(expression) - } - system2_with_child_environment <- function(environment, command, args, ...) { - arguments <- c(list(command = command, args = args), list(...)) - with_child_environment(environment, do.call(system2, arguments)) - } + root <- tempfile("prepare-jgd-") + dir.create(root) + root <- normalizePath(root, winslash = "/", mustWork = TRUE) + r_literal <- function(value) paste0("\"", gsub("\\\"", "\\\\\\\"", value), "\"") + on.exit(unlink(root, recursive = TRUE), add = TRUE) + ambient_library <- file.path(root, "ambient-user-library") + isolated_child_env <- function(label, libraries = "") { + user_library <- file.path(root, "isolated-libraries", label, "user") + site_library <- file.path(root, "isolated-libraries", label, "site") + dir.create(user_library, recursive = TRUE, showWarnings = FALSE) + dir.create(site_library, recursive = TRUE, showWarnings = FALSE) + c( + R_LIBS_USER = user_library, + R_LIBS_SITE = site_library, + R_LIBS = libraries, + VSCODE_R_TEST_AMBIENT_LIBRARY = ambient_library + ) + } + with_child_environment <- function(environment, expression) { + stopifnot( + is.character(environment), + !is.null(names(environment)), + !anyNA(environment), + !anyDuplicated(names(environment)) + ) + keys <- names(environment) + previous <- Sys.getenv(keys, unset = NA_character_) + on.exit( + { + unset <- keys[is.na(previous)] + if (length(unset)) { + Sys.unsetenv(unset) + } + restore <- previous[!is.na(previous)] + if (length(restore)) do.call(Sys.setenv, as.list(restore)) + }, + add = TRUE + ) + do.call(Sys.setenv, as.list(environment)) + force(expression) + } + system2_with_child_environment <- function(environment, command, args, ...) { + arguments <- c(list(command = command, args = args), list(...)) + with_child_environment(environment, do.call(system2, arguments)) + } - source_package <- function(version) { - package <- file.path(root, paste0("jgd-", version)) - dir.create(file.path(package, "R"), recursive = TRUE) - writeLines(c( - "Package: jgd", paste0("Version: ", version), "Title: jgd fixture", - "Description: Local jgd fixture.", "License: MIT", "Author: Test Author", - "Maintainer: Test Author ", "Encoding: UTF-8" - ), file.path(package, "DESCRIPTION")) - writeLines(c( - "fixture_device <- function() 'jgd'", - "jgd <- function() {", - " path <- Sys.getenv('JGD_TEST_DEVICE_LOG', '')", - " if (nzchar(path)) cat('jgd\\n', file=path, append=TRUE)", - # sess now tracks the opened device and attaches its session identity. - # A null PDF supplies a real device without requiring a JGD renderer. - " grDevices::pdf(NULL)", - " invisible(NULL)", - "}", - "jgd_server_info <- function() list(server_info=c(deviceId=as.character(grDevices::dev.cur())))", - "jgd_frame_ext <- function(value) {", - " path <- Sys.getenv('JGD_TEST_DEVICE_LOG', '')", - " if (nzchar(path)) cat(value, '\\n', file=paste0(path, '-frames'), append=TRUE)", - " invisible(NULL)", - "}" - ), file.path(package, "R", "api.R")) - writeLines(c("export(fixture_device)", "export(jgd)", - "export(jgd_server_info)", "export(jgd_frame_ext)"), file.path(package, "NAMESPACE")) - previous <- setwd(root) - on.exit(setwd(previous), add = TRUE) - output <- system2_with_child_environment( - isolated_child_env(paste0("build-", version)), - file.path(R.home("bin"), "R"), - c("CMD", "build", "--no-build-vignettes", shQuote(basename(package))), - stdout = TRUE, stderr = TRUE - ) - status <- attr(output, "status") - if (!is.null(status) && status != 0L) stop(paste(output, collapse = "\n")) - archive <- file.path(root, paste0("jgd_", version, ".tar.gz")) - stopifnot(file.exists(archive)) - contrib <- file.path(root, "repo", "src", "contrib") - dir.create(contrib, recursive = TRUE, showWarnings = FALSE) - file.copy(archive, contrib) - tools::write_PACKAGES(contrib, type = "source") - package + source_package <- function(version) { + package <- file.path(root, paste0("jgd-", version)) + dir.create(file.path(package, "R"), recursive = TRUE) + writeLines( + c( + "Package: jgd", + paste0("Version: ", version), + "Title: jgd fixture", + "Description: Local jgd fixture.", + "License: MIT", + "Author: Test Author", + "Maintainer: Test Author ", + "Encoding: UTF-8" + ), + file.path(package, "DESCRIPTION") + ) + writeLines( + c( + "fixture_device <- function() 'jgd'", + "jgd <- function() {", + " path <- Sys.getenv('JGD_TEST_DEVICE_LOG', '')", + " if (nzchar(path)) cat('jgd\\n', file=path, append=TRUE)", + # sess now tracks the opened device and attaches its session identity. + # A null PDF supplies a real device without requiring a JGD renderer. + " grDevices::pdf(NULL)", + " invisible(NULL)", + "}", + "jgd_server_info <- function() list(server_info=c(deviceId=as.character(grDevices::dev.cur())))", + "jgd_frame_ext <- function(value) {", + " path <- Sys.getenv('JGD_TEST_DEVICE_LOG', '')", + " if (nzchar(path)) cat(value, '\\n', file=paste0(path, '-frames'), append=TRUE)", + " invisible(NULL)", + "}" + ), + file.path(package, "R", "api.R") + ) + writeLines( + c( + "export(fixture_device)", + "export(jgd)", + "export(jgd_server_info)", + "export(jgd_frame_ext)" + ), + file.path(package, "NAMESPACE") + ) + previous <- setwd(root) + on.exit(setwd(previous), add = TRUE) + output <- system2_with_child_environment( + isolated_child_env(paste0("build-", version)), + file.path(R.home("bin"), "R"), + c("CMD", "build", "--no-build-vignettes", shQuote(basename(package))), + stdout = TRUE, + stderr = TRUE + ) + status <- attr(output, "status") + if (!is.null(status) && status != 0L) { + stop(paste(output, collapse = "\n")) } + archive <- file.path(root, paste0("jgd_", version, ".tar.gz")) + stopifnot(file.exists(archive)) + contrib <- file.path(root, "repo", "src", "contrib") + dir.create(contrib, recursive = TRUE, showWarnings = FALSE) + file.copy(archive, contrib) + tools::write_PACKAGES(contrib, type = "source") + package + } - package <- source_package("0.1.0") - source_package("0.0.1") - unlink(file.path(root, "repo", "src", "contrib", "jgd_0.0.1.tar.gz")) - tools::write_PACKAGES(file.path(root, "repo", "src", "contrib"), type = "source") - repo <- paste0("file:///", sub("^/", "", normalizePath(file.path(root, "repo"), winslash = "/"))) - dir.create(ambient_library) - ambient_install <- system2_with_child_environment( - isolated_child_env("ambient-install"), - file.path(R.home("bin"), "R"), - c("CMD", "INSTALL", paste0("--library=", shQuote(ambient_library)), - shQuote(file.path(root, "jgd-0.1.0"))), - stdout = TRUE, stderr = TRUE + package <- source_package("0.1.0") + source_package("0.0.1") + unlink(file.path(root, "repo", "src", "contrib", "jgd_0.0.1.tar.gz")) + tools::write_PACKAGES(file.path(root, "repo", "src", "contrib"), type = "source") + repo <- paste0("file:///", sub("^/", "", normalizePath(file.path(root, "repo"), winslash = "/"))) + dir.create(ambient_library) + ambient_install <- system2_with_child_environment( + isolated_child_env("ambient-install"), + file.path(R.home("bin"), "R"), + c( + "CMD", + "INSTALL", + paste0("--library=", shQuote(ambient_library)), + shQuote(file.path(root, "jgd-0.1.0")) + ), + stdout = TRUE, + stderr = TRUE + ) + ambient_status <- attr(ambient_install, "status") + if (!is.null(ambient_status) && ambient_status != 0L) { + stop("Could not install ambient jgd fixture: ", paste(ambient_install, collapse = "\n")) + } + old_user_library <- Sys.getenv("R_LIBS_USER", unset = NA_character_) + old_site_library <- Sys.getenv("R_LIBS_SITE", unset = NA_character_) + Sys.setenv(R_LIBS_USER = ambient_library, R_LIBS_SITE = ambient_library) + on.exit( + { + if (is.na(old_user_library)) { + Sys.unsetenv("R_LIBS_USER") + } else { + Sys.setenv(R_LIBS_USER = old_user_library) + } + if (is.na(old_site_library)) { + Sys.unsetenv("R_LIBS_SITE") + } else { + Sys.setenv(R_LIBS_SITE = old_site_library) + } + }, + add = TRUE + ) + installed <- utils::installed.packages(lib.loc = .libPaths()) + runtime_dependencies <- unique(c( + "processx", + "later", + "jsonlite", + unlist( + tools::package_dependencies( + c("processx", "later", "jsonlite"), + db = installed, + which = c("Depends", "Imports"), + recursive = TRUE + ), + use.names = FALSE ) - ambient_status <- attr(ambient_install, "status") - if (!is.null(ambient_status) && ambient_status != 0L) { - stop("Could not install ambient jgd fixture: ", paste(ambient_install, collapse = "\n")) + )) + dependency_library <- file.path(root, "runtime-dependencies") + dir.create(dependency_library) + for (dependency in setdiff( + runtime_dependencies, + rownames(installed)[installed[, "LibPath"] == .Library] + )) { + rows <- which(rownames(installed) == dependency) + if (!length(rows)) { + stop("Missing installed runtime test dependency: ", dependency) } - old_user_library <- Sys.getenv("R_LIBS_USER", unset = NA_character_) - old_site_library <- Sys.getenv("R_LIBS_SITE", unset = NA_character_) - Sys.setenv(R_LIBS_USER = ambient_library, R_LIBS_SITE = ambient_library) - on.exit({ - if (is.na(old_user_library)) Sys.unsetenv("R_LIBS_USER") else - Sys.setenv(R_LIBS_USER = old_user_library) - if (is.na(old_site_library)) Sys.unsetenv("R_LIBS_SITE") else - Sys.setenv(R_LIBS_SITE = old_site_library) - }, add = TRUE) - installed <- utils::installed.packages(lib.loc = .libPaths()) - runtime_dependencies <- unique(c( - "processx", "later", "jsonlite", - unlist(tools::package_dependencies(c("processx", "later", "jsonlite"), - db = installed, which = c("Depends", "Imports"), - recursive = TRUE), use.names = FALSE) - )) - dependency_library <- file.path(root, "runtime-dependencies") - dir.create(dependency_library) - for (dependency in setdiff(runtime_dependencies, rownames(installed)[installed[, "LibPath"] == .Library])) { - rows <- which(rownames(installed) == dependency) - if (!length(rows)) stop("Missing installed runtime test dependency: ", dependency) - source_path <- file.path(installed[rows[[1L]], "LibPath"], dependency) - if (!file.copy(source_path, dependency_library, recursive = TRUE)) { - stop("Could not stage runtime test dependency: ", dependency) - } + source_path <- file.path(installed[rows[[1L]], "LibPath"], dependency) + if (!file.copy(source_path, dependency_library, recursive = TRUE)) { + stop("Could not stage runtime test dependency: ", dependency) } - sess_library <- file.path(root, "sess-library") - dir.create(sess_library) - sess_install <- system2_with_child_environment( - isolated_child_env("sess-install", dependency_library), - file.path(R.home("bin"), "R"), - c("CMD", "INSTALL", paste0("--library=", shQuote(sess_library)), - shQuote(file.path(getwd(), "sess"))), - stdout = TRUE, stderr = TRUE + } + sess_library <- file.path(root, "sess-library") + dir.create(sess_library) + sess_install <- system2_with_child_environment( + isolated_child_env("sess-install", dependency_library), + file.path(R.home("bin"), "R"), + c( + "CMD", + "INSTALL", + paste0("--library=", shQuote(sess_library)), + shQuote(file.path(getwd(), "sess")) + ), + stdout = TRUE, + stderr = TRUE + ) + sess_status <- attr(sess_install, "status") + if (!is.null(sess_status) && sess_status != 0L) { + stop("Could not install sess test fixture: ", paste(sess_install, collapse = "\n")) + } + runner <- file.path(root, "run.R") + writeLines( + c( + "args <- commandArgs(TRUE); mode <- args[[1L]]; root <- args[[2L]]; repo <- args[[3L]];", + "result <- args[[4L]];", + "ambient <- normalizePath(Sys.getenv('VSCODE_R_TEST_AMBIENT_LIBRARY'), winslash='/');", + "stopifnot(!ambient %in% normalizePath(.libPaths(), winslash='/'));", + "source(file.path(getwd(), 'R', 'tool-library.R'));", + "source(file.path(getwd(), 'R', 'tool-consent.R'));", + "source(file.path(getwd(), 'R', 'prepare-tools.R'));", + "source(file.path(getwd(), 'R', 'attach_sess.R'));", + "options(repos=c(CRAN=repo), pkgType='source');", + "consent <- file.path(root, 'consent'); dir.create(consent, showWarnings=FALSE);", + # Manual attach must use its supplied minimum rather than an inherited terminal value. + "Sys.setenv(JGD_SOCKET='fixture-socket', VSCODE_R_JGD_MINIMUM_VERSION='9.9.9');", + "connect_seen <- new.env();", + "device_log <- file.path(root, paste0(mode, '-device-log'));", + "Sys.setenv(JGD_TEST_DEVICE_LOG=device_log);", + "vscode_r_prepare_sess <- function(...) { ns <- new.env(); ns$connect <- function(allow_jgd=TRUE, ...) {", + " connect_seen$allow_jgd <- allow_jgd;", + " if (mode == 'socket-empty') Sys.setenv(JGD_SOCKET='fixture-socket');", + " connect_seen$socket <- Sys.getenv('JGD_SOCKET', unset='');", + " connect_seen$loaded <- requireNamespace('jgd', quietly=TRUE);", + " hooks <- new.env(parent=globalenv());", + " sys.source(file.path(getwd(), 'sess', 'R', 'hooks.R'), hooks);", + " has_jgd <- connect_seen$allow_jgd && nzchar(connect_seen$socket) && connect_seen$loaded;", + " connect_seen$device <- hooks$.select_plot_backend('jgd', FALSE, has_jgd);", + " if (connect_seen$device == 'jgd') jgd::jgd(); TRUE }; ns };", + "if (mode == 'old') {", + " old <- file.path(root, 'old-library'); dir.create(old);", + " utils::install.packages(file.path(root, 'jgd-0.0.1'), repos=NULL, type='source', lib=old, quiet=TRUE);", + " .libPaths(c(old, .Library)); loadNamespace('jgd', lib.loc=old);", + "}", + "if (mode == 'offline') options(repos=c(CRAN=file.path(root, 'missing-repo')));", + "if (mode == 'socket-empty') Sys.unsetenv('JGD_SOCKET');", + "tool_library_helper <- if (mode %in% c('parallel', 'no-prompt', 'no-prompt-compatible'))", + " file.path(root, 'instrumented-tool-library.R') else", + " file.path(getwd(), 'R', 'tool-library.R');", + "if (mode == 'library-helper-missing') tool_library_helper <- file.path(root, 'missing-tool-library.R');", + "if (mode == 'no-prompt-compatible') {", + " ordinary <- file.path(root, 'ordinary-library'); dir.create(ordinary);", + " utils::install.packages('jgd', repos=repo, type='source', lib=ordinary, quiet=TRUE);", + " .libPaths(c(ordinary, .libPaths()));", + "}", + "timeout_before <- getOption('timeout'); libraries_before <- .libPaths();", + "answer <- vscode_r_attach_sess('endpoint', 'unused', file.path(root, 'tools'), consent,", + " 'unused', 'unused', 'jgd', timeout_seconds=0, use_rstudioapi=FALSE,", + " tool_root=file.path(root, 'tools'),", + " tool_consent_directory=consent, tool_library_helper=tool_library_helper,", + " tool_consent_helper=file.path(getwd(), 'R', 'tool-consent.R'),", + " tool_prepare_helper=if (mode == 'helper-missing') file.path(root, 'missing-prepare-tools.R') else", + " file.path(getwd(), 'R', 'prepare-tools.R'),", + " jgd_can_prompt=!(mode %in% c('no-prompt', 'no-prompt-compatible', 'socket-empty')),", + " jgd_minimum_version='0.1.0');", + "stopifnot(isTRUE(answer), identical(Sys.getenv('JGD_SOCKET'), 'fixture-socket'));", + "stopifnot(identical(getOption('timeout'), timeout_before), identical(.libPaths(), libraries_before));", + "writeLines(c(connect_seen$socket, as.character(connect_seen$loaded), connect_seen$device,", + " as.character(connect_seen$allow_jgd)), result);" + ), + runner + ) + + r_binary <- file.path(R.home("bin"), "R") + run_child <- function(mode, result) { + child_args <- c( + "--vanilla", + "--slave", + paste0("--file=", runner), + "--args", + mode, + root, + repo, + result ) - sess_status <- attr(sess_install, "status") - if (!is.null(sess_status) && sess_status != 0L) { - stop("Could not install sess test fixture: ", paste(sess_install, collapse = "\n")) + output <- system2_with_child_environment( + isolated_child_env(mode), + r_binary, + shQuote(child_args), + stdout = TRUE, + stderr = TRUE + ) + status <- attr(output, "status") + if (!is.null(status) && status != 0L) { + stop(paste(output, collapse = "\n")) } - runner <- file.path(root, "run.R") - writeLines(c( - "args <- commandArgs(TRUE); mode <- args[[1L]]; root <- args[[2L]]; repo <- args[[3L]];", - "result <- args[[4L]];", - "ambient <- normalizePath(Sys.getenv('VSCODE_R_TEST_AMBIENT_LIBRARY'), winslash='/');", - "stopifnot(!ambient %in% normalizePath(.libPaths(), winslash='/'));", - "source(file.path(getwd(), 'R', 'tool-library.R'));", - "source(file.path(getwd(), 'R', 'tool-consent.R'));", - "source(file.path(getwd(), 'R', 'prepare-tools.R'));", - "source(file.path(getwd(), 'R', 'attach_sess.R'));", - "options(repos=c(CRAN=repo), pkgType='source');", - "consent <- file.path(root, 'consent'); dir.create(consent, showWarnings=FALSE);", - # Manual attach must use its supplied minimum rather than an inherited terminal value. - "Sys.setenv(JGD_SOCKET='fixture-socket', VSCODE_R_JGD_MINIMUM_VERSION='9.9.9');", - "connect_seen <- new.env();", - "device_log <- file.path(root, paste0(mode, '-device-log'));", - "Sys.setenv(JGD_TEST_DEVICE_LOG=device_log);", - "vscode_r_prepare_sess <- function(...) { ns <- new.env(); ns$connect <- function(allow_jgd=TRUE, ...) {", - " connect_seen$allow_jgd <- allow_jgd;", - " if (mode == 'socket-empty') Sys.setenv(JGD_SOCKET='fixture-socket');", - " connect_seen$socket <- Sys.getenv('JGD_SOCKET', unset='');", - " connect_seen$loaded <- requireNamespace('jgd', quietly=TRUE);", - " hooks <- new.env(parent=globalenv());", - " sys.source(file.path(getwd(), 'sess', 'R', 'hooks.R'), hooks);", - " has_jgd <- connect_seen$allow_jgd && nzchar(connect_seen$socket) && connect_seen$loaded;", - " connect_seen$device <- hooks$.select_plot_backend('jgd', FALSE, has_jgd);", - " if (connect_seen$device == 'jgd') jgd::jgd(); TRUE }; ns };", - "if (mode == 'old') {", - " old <- file.path(root, 'old-library'); dir.create(old);", - " utils::install.packages(file.path(root, 'jgd-0.0.1'), repos=NULL, type='source', lib=old, quiet=TRUE);", - " .libPaths(c(old, .Library)); loadNamespace('jgd', lib.loc=old);", - "}", - "if (mode == 'offline') options(repos=c(CRAN=file.path(root, 'missing-repo')));", - "if (mode == 'socket-empty') Sys.unsetenv('JGD_SOCKET');", - "tool_library_helper <- if (mode %in% c('parallel', 'no-prompt', 'no-prompt-compatible'))", - " file.path(root, 'instrumented-tool-library.R') else", - " file.path(getwd(), 'R', 'tool-library.R');", - "if (mode == 'library-helper-missing') tool_library_helper <- file.path(root, 'missing-tool-library.R');", - "if (mode == 'no-prompt-compatible') {", - " ordinary <- file.path(root, 'ordinary-library'); dir.create(ordinary);", - " utils::install.packages('jgd', repos=repo, type='source', lib=ordinary, quiet=TRUE);", - " .libPaths(c(ordinary, .libPaths()));", - "}", - "timeout_before <- getOption('timeout'); libraries_before <- .libPaths();", - "answer <- vscode_r_attach_sess('endpoint', 'unused', file.path(root, 'tools'), consent,", - " 'unused', 'unused', 'jgd', timeout_seconds=0, use_rstudioapi=FALSE,", - " tool_root=file.path(root, 'tools'),", - " tool_consent_directory=consent, tool_library_helper=tool_library_helper,", - " tool_consent_helper=file.path(getwd(), 'R', 'tool-consent.R'),", - " tool_prepare_helper=if (mode == 'helper-missing') file.path(root, 'missing-prepare-tools.R') else", - " file.path(getwd(), 'R', 'prepare-tools.R'),", - " jgd_can_prompt=!(mode %in% c('no-prompt', 'no-prompt-compatible', 'socket-empty')),", - " jgd_minimum_version='0.1.0');", - "stopifnot(isTRUE(answer), identical(Sys.getenv('JGD_SOCKET'), 'fixture-socket'));", - "stopifnot(identical(getOption('timeout'), timeout_before), identical(.libPaths(), libraries_before));", - "writeLines(c(connect_seen$socket, as.character(connect_seen$loaded), connect_seen$device,", - " as.character(connect_seen$allow_jgd)), result);" - ), runner) + readLines(result, warn = FALSE) + } - r_binary <- file.path(R.home("bin"), "R") - run_child <- function(mode, result) { - child_args <- c("--vanilla", "--slave", paste0("--file=", runner), "--args", - mode, root, repo, result) - output <- system2_with_child_environment(isolated_child_env(mode), r_binary, - shQuote(child_args), stdout = TRUE, stderr = TRUE) - status <- attr(output, "status") - if (!is.null(status) && status != 0L) stop(paste(output, collapse = "\n")) - readLines(result, warn = FALSE) + wait_requests <- function(directory, count) { + deadline <- Sys.time() + 15 + repeat { + paths <- list.files(directory, pattern = "\\.request$", full.names = TRUE) + if (length(paths) >= count) { + return(paths) + } + if (Sys.time() >= deadline) { + log_paths <- list.files(root, pattern = "(out|err)$", recursive = TRUE, full.names = TRUE) + logs <- unlist(lapply(log_paths, function(path) c(path, readLines(path, warn = FALSE)))) + stop( + "Timed out waiting for jgd consent request in ", + directory, + ": ", + paste(logs, collapse = "\n") + ) + } + Sys.sleep(0.01) } + } - wait_requests <- function(directory, count) { - deadline <- Sys.time() + 15 - repeat { - paths <- list.files(directory, pattern = "\\.request$", full.names = TRUE) - if (length(paths) >= count) return(paths) - if (Sys.time() >= deadline) { - log_paths <- list.files(root, pattern = "(out|err)$", recursive = TRUE, - full.names = TRUE) - logs <- unlist(lapply(log_paths, function(path) { - c(path, readLines(path, warn = FALSE)) - })) - stop("Timed out waiting for jgd consent request in ", directory, ": ", - paste(logs, collapse = "\n")) - } - Sys.sleep(0.01) - } + answer_requests <- function(paths, answer) { + for (path in paths) { + id <- sub("\\.request$", "", basename(path)) + temporary <- file.path(dirname(path), paste0(id, ".response.tmp")) + writeLines(answer, temporary, useBytes = TRUE) + stopifnot(file.rename(temporary, file.path(dirname(path), paste0(id, ".response")))) } + } - answer_requests <- function(paths, answer) { - for (path in paths) { - id <- sub("\\.request$", "", basename(path)) - temporary <- file.path(dirname(path), paste0(id, ".response.tmp")) - writeLines(answer, temporary, useBytes = TRUE) - stopifnot(file.rename(temporary, file.path(dirname(path), paste0(id, ".response")))) - } - } + dir.create(file.path(root, "consent"), showWarnings = FALSE) + real_runner <- file.path(root, "real-connect.R") + writeLines( + c( + "args <- commandArgs(TRUE); mode <- args[[1L]]; root <- args[[2L]]; repo <- args[[3L]];", + "result <- args[[4L]]; sess_library <- args[[5L]];", + "ambient <- normalizePath(Sys.getenv('VSCODE_R_TEST_AMBIENT_LIBRARY'), winslash='/');", + "stopifnot(!ambient %in% normalizePath(.libPaths(), winslash='/'));", + "source(file.path(getwd(), 'R', 'tool-library.R'));", + "source(file.path(getwd(), 'R', 'tool-consent.R'));", + "source(file.path(getwd(), 'R', 'prepare-tools.R'));", + "source(file.path(getwd(), 'R', 'attach_sess.R'));", + "options(repos=c(CRAN=repo), pkgType='source', sess.quiet=TRUE);", + "sess_ns <- loadNamespace('sess', lib.loc=sess_library);", + "endpoint <- if (.Platform$OS.type == 'windows')", + " paste0('\\\\\\\\?\\\\pipe\\\\', basename(tempfile('sess-jgd-'))) else tempfile(fileext='.sock');", + "server <- processx::conn_create_unix_socket(endpoint);", + "discovery <- file.path(root, paste0(mode, '-discovery.json'));", + "writeLines(jsonlite::toJSON(list(version=1L, endpoint=endpoint, jgdSocket='fixture-jgd-socket'),", + " auto_unbox=TRUE), discovery);", + "Sys.setenv(SESS_DISCOVERY_FILE=discovery, JGD_TEST_DEVICE_LOG=file.path(root, paste0(mode, '-real-device')));", + "Sys.unsetenv('JGD_SOCKET');", + "old_library <- file.path(root, paste0(mode, '-old-library')); dir.create(old_library);", + "if (mode %in% c('real-loaded-old', 'real-user-old'))", + " utils::install.packages(file.path(root, 'jgd-0.0.1'), repos=NULL,", + " type='source', lib=old_library, quiet=TRUE);", + "if (mode == 'real-loaded-old') loadNamespace('jgd', lib.loc=old_library);", + "if (mode == 'real-user-old') .libPaths(c(old_library, .libPaths()));", + "connect_env <- new.env(parent=sess_ns); connect_env$.sess_env <- sess_ns$.sess_env;", + "connect_env$connect <- getExportedValue('sess', 'connect');", + "environment(connect_env$connect) <- connect_env;", + "connect_env$.schedule_reconnect <- sess_ns$.schedule_reconnect;", + "environment(connect_env$.schedule_reconnect) <- connect_env;", + "connect_env$.reconnect_with_startup <- sess_ns$.reconnect_with_startup;", + "environment(connect_env$.reconnect_with_startup) <- connect_env;", + "connect_env$poll_connection <- function(...) {", + " processx::poll(list(server), 1000L); processx::conn_accept_unix_socket(server);", + " processx::poll(list(server), 1000L); message <- processx::conn_read_chars(server);", + " stopifnot(grepl('\\\"method\\\":\\\"attach\\\"', message)); invisible(NULL)", + "};", + "answer <- vscode_r_with_jgd('jgd', function(allow_jgd=TRUE)", + " connect_env$connect(endpoint=endpoint, use_rstudioapi=FALSE,", + " plot_backend='jgd', allow_jgd=allow_jgd),", + " tool_prepare_helper=file.path(getwd(), 'R', 'prepare-tools.R'),", + " tool_root=file.path(root, paste0(mode, '-tools')),", + " tool_consent_directory=file.path(root, 'consent'),", + " tool_library_helper=file.path(getwd(), 'R', 'tool-library.R'),", + " tool_consent_helper=file.path(getwd(), 'R', 'tool-consent.R'),", + " can_prompt=identical(mode, 'real-approved'), minimum_version='0.1.0');", + "allow <- sess_ns$.sess_env$reconnect$options$allow_jgd;", + "socket <- Sys.getenv('JGD_SOCKET', unset='');", + "loaded <- 'jgd' %in% loadedNamespaces();", + "getOption('device')();", + "settings <- sess_ns$.sess_env$reconnect;", + "sess_ns$.transport_disconnect(silent=TRUE); close(server);", + "next_endpoint <- if (.Platform$OS.type == 'windows')", + " paste0('\\\\\\\\?\\\\pipe\\\\', basename(tempfile('sess-jgd-next-'))) else tempfile(fileext='.sock');", + "server <- processx::conn_create_unix_socket(next_endpoint);", + "writeLines(jsonlite::toJSON(list(version=1L, endpoint=next_endpoint,", + " jgdSocket='fixture-jgd-socket-next'), auto_unbox=TRUE), discovery);", + "scheduled <- NULL;", + "connect_env$.schedule_reconnect(settings, schedule=function(callback, delay) { scheduled <<- callback });", + "stopifnot(is.function(scheduled)); scheduled();", + "next_allow <- sess_ns$.sess_env$reconnect$options$allow_jgd;", + "next_socket <- Sys.getenv('JGD_SOCKET', unset='');", + "next_loaded <- 'jgd' %in% loadedNamespaces();", + "getOption('device')();", + "writeLines(c(as.character(answer), as.character(allow), socket, as.character(loaded),", + " as.character(next_allow), next_socket, as.character(next_loaded)), result);", + "sess_ns$.transport_disconnect(silent=TRUE); close(server)" + ), + real_runner + ) - dir.create(file.path(root, "consent"), showWarnings = FALSE) - real_runner <- file.path(root, "real-connect.R") - writeLines(c( - "args <- commandArgs(TRUE); mode <- args[[1L]]; root <- args[[2L]]; repo <- args[[3L]];", - "result <- args[[4L]]; sess_library <- args[[5L]];", - "ambient <- normalizePath(Sys.getenv('VSCODE_R_TEST_AMBIENT_LIBRARY'), winslash='/');", - "stopifnot(!ambient %in% normalizePath(.libPaths(), winslash='/'));", - "source(file.path(getwd(), 'R', 'tool-library.R'));", - "source(file.path(getwd(), 'R', 'tool-consent.R'));", - "source(file.path(getwd(), 'R', 'prepare-tools.R'));", - "source(file.path(getwd(), 'R', 'attach_sess.R'));", - "options(repos=c(CRAN=repo), pkgType='source', sess.quiet=TRUE);", - "sess_ns <- loadNamespace('sess', lib.loc=sess_library);", - "endpoint <- if (.Platform$OS.type == 'windows')", - " paste0('\\\\\\\\?\\\\pipe\\\\', basename(tempfile('sess-jgd-'))) else tempfile(fileext='.sock');", - "server <- processx::conn_create_unix_socket(endpoint);", - "discovery <- file.path(root, paste0(mode, '-discovery.json'));", - "writeLines(jsonlite::toJSON(list(version=1L, endpoint=endpoint, jgdSocket='fixture-jgd-socket'),", - " auto_unbox=TRUE), discovery);", - "Sys.setenv(SESS_DISCOVERY_FILE=discovery, JGD_TEST_DEVICE_LOG=file.path(root, paste0(mode, '-real-device')));", - "Sys.unsetenv('JGD_SOCKET');", - "old_library <- file.path(root, paste0(mode, '-old-library')); dir.create(old_library);", - "if (mode %in% c('real-loaded-old', 'real-user-old'))", - " utils::install.packages(file.path(root, 'jgd-0.0.1'), repos=NULL,", - " type='source', lib=old_library, quiet=TRUE);", - "if (mode == 'real-loaded-old') loadNamespace('jgd', lib.loc=old_library);", - "if (mode == 'real-user-old') .libPaths(c(old_library, .libPaths()));", - "connect_env <- new.env(parent=sess_ns); connect_env$.sess_env <- sess_ns$.sess_env;", - "connect_env$connect <- getExportedValue('sess', 'connect');", - "environment(connect_env$connect) <- connect_env;", - "connect_env$.schedule_reconnect <- sess_ns$.schedule_reconnect;", - "environment(connect_env$.schedule_reconnect) <- connect_env;", - "connect_env$.reconnect_with_startup <- sess_ns$.reconnect_with_startup;", - "environment(connect_env$.reconnect_with_startup) <- connect_env;", - "connect_env$poll_connection <- function(...) {", - " processx::poll(list(server), 1000L); processx::conn_accept_unix_socket(server);", - " processx::poll(list(server), 1000L); message <- processx::conn_read_chars(server);", - " stopifnot(grepl('\\\"method\\\":\\\"attach\\\"', message)); invisible(NULL)", - "};", - "answer <- vscode_r_with_jgd('jgd', function(allow_jgd=TRUE)", - " connect_env$connect(endpoint=endpoint, use_rstudioapi=FALSE,", - " plot_backend='jgd', allow_jgd=allow_jgd),", - " tool_prepare_helper=file.path(getwd(), 'R', 'prepare-tools.R'),", - " tool_root=file.path(root, paste0(mode, '-tools')),", - " tool_consent_directory=file.path(root, 'consent'),", - " tool_library_helper=file.path(getwd(), 'R', 'tool-library.R'),", - " tool_consent_helper=file.path(getwd(), 'R', 'tool-consent.R'),", - " can_prompt=identical(mode, 'real-approved'), minimum_version='0.1.0');", - "allow <- sess_ns$.sess_env$reconnect$options$allow_jgd;", - "socket <- Sys.getenv('JGD_SOCKET', unset='');", - "loaded <- 'jgd' %in% loadedNamespaces();", - "getOption('device')();", - "settings <- sess_ns$.sess_env$reconnect;", - "sess_ns$.transport_disconnect(silent=TRUE); close(server);", - "next_endpoint <- if (.Platform$OS.type == 'windows')", - " paste0('\\\\\\\\?\\\\pipe\\\\', basename(tempfile('sess-jgd-next-'))) else tempfile(fileext='.sock');", - "server <- processx::conn_create_unix_socket(next_endpoint);", - "writeLines(jsonlite::toJSON(list(version=1L, endpoint=next_endpoint,", - " jgdSocket='fixture-jgd-socket-next'), auto_unbox=TRUE), discovery);", - "scheduled <- NULL;", - "connect_env$.schedule_reconnect(settings, schedule=function(callback, delay) { scheduled <<- callback });", - "stopifnot(is.function(scheduled)); scheduled();", - "next_allow <- sess_ns$.sess_env$reconnect$options$allow_jgd;", - "next_socket <- Sys.getenv('JGD_SOCKET', unset='');", - "next_loaded <- 'jgd' %in% loadedNamespaces();", - "getOption('device')();", - "writeLines(c(as.character(answer), as.character(allow), socket, as.character(loaded),", - " as.character(next_allow), next_socket, as.character(next_loaded)), result);", - "sess_ns$.transport_disconnect(silent=TRUE); close(server)" - ), real_runner) + run_real_child <- function(mode, result, wait = TRUE) { + args <- c( + "--vanilla", + "--slave", + paste0("--file=", real_runner), + "--args", + mode, + root, + repo, + result, + sess_library + ) + system2_with_child_environment( + isolated_child_env( + paste0("real-", mode), + paste(sess_library, dependency_library, sep = .Platform$path.sep) + ), + r_binary, + shQuote(args), + wait = wait, + stdout = if (wait) TRUE else file.path(root, paste0(mode, "-out")), + stderr = if (wait) TRUE else file.path(root, paste0(mode, "-err")) + ) + } - run_real_child <- function(mode, result, wait = TRUE) { - args <- c("--vanilla", "--slave", paste0("--file=", real_runner), "--args", - mode, root, repo, result, sess_library) - system2_with_child_environment( - isolated_child_env(paste0("real-", mode), - paste(sess_library, dependency_library, sep = .Platform$path.sep)), - r_binary, shQuote(args), wait = wait, - stdout = if (wait) TRUE else file.path(root, paste0(mode, "-out")), - stderr = if (wait) TRUE else file.path(root, paste0(mode, "-err")) - ) + for (mode in c("real-loaded-old", "real-user-old")) { + result <- file.path(root, paste0(mode, "-result")) + output <- run_real_child(mode, result) + status <- attr(output, "status") + if (!is.null(status) && status != 0L) { + stop(paste(output, collapse = "\n")) } + values <- readLines(result, warn = FALSE) + stopifnot(identical(values[c(1L, 2L, 3L)], c("TRUE", "FALSE", ""))) + stopifnot(identical(values[[4L]], as.character(identical(mode, "real-loaded-old")))) + stopifnot(identical(values[c(5L, 6L)], c("FALSE", ""))) + stopifnot(identical(values[[7L]], values[[4L]])) + stopifnot(!file.exists(file.path(root, paste0(mode, "-real-device")))) + } - for (mode in c("real-loaded-old", "real-user-old")) { - result <- file.path(root, paste0(mode, "-result")) - output <- run_real_child(mode, result) - status <- attr(output, "status") - if (!is.null(status) && status != 0L) stop(paste(output, collapse = "\n")) - values <- readLines(result, warn = FALSE) - stopifnot(identical(values[c(1L, 2L, 3L)], c("TRUE", "FALSE", ""))) - stopifnot(identical(values[[4L]], as.character(identical(mode, "real-loaded-old")))) - stopifnot(identical(values[c(5L, 6L)], c("FALSE", ""))) - stopifnot(identical(values[[7L]], values[[4L]])) - stopifnot(!file.exists(file.path(root, paste0(mode, "-real-device")))) - } + approved_real_result <- file.path(root, "real-approved-result") + real_process <- run_real_child("real-approved", approved_real_result, wait = FALSE) + real_request <- wait_requests(file.path(root, "consent"), 1L) + answer_requests(real_request, "approve") + deadline <- Sys.time() + 30 + while (!file.exists(approved_real_result) && Sys.time() < deadline) { + Sys.sleep(0.01) + } + if (!file.exists(approved_real_result)) { + logs <- unlist(lapply(c("real-approved-out", "real-approved-err"), function(name) { + path <- file.path(root, name) + if (file.exists(path)) readLines(path, warn = FALSE) else character() + })) + stop("Actual sess jgd connection did not finish: ", paste(logs, collapse = "\n")) + } + stopifnot(identical( + readLines(approved_real_result, warn = FALSE), + c("TRUE", "TRUE", "fixture-jgd-socket", "TRUE", "TRUE", "fixture-jgd-socket-next", "TRUE") + )) + stopifnot(identical( + readLines(file.path(root, "real-approved-real-device"), warn = FALSE), + c("jgd", "jgd") + )) + frames <- lapply( + readLines(file.path(root, "real-approved-real-device-frames"), warn = FALSE), + jsonlite::fromJSON + ) + stopifnot(length(frames) == 2L) + stopifnot(all(vapply( + frames, + function(frame) { + identity <- frame$vscodeR + nzchar(identity$sessionId) && + nzchar(identity$pid) && + nzchar(identity$deviceId) && + identical(identity$restoring, FALSE) + }, + logical(1) + ))) + stopifnot(identical(frames[[1L]]$vscodeR$sessionId, frames[[2L]]$vscodeR$sessionId)) + stopifnot(!identical(frames[[1L]]$vscodeR$deviceId, frames[[2L]]$vscodeR$deviceId)) + + approved_root <- file.path(root, "approved") + dir.create(approved_root) + approved_result <- file.path(root, "approved-result") + approved_args <- c( + "--vanilla", + "--slave", + paste0("--file=", runner), + "--args", + "approved", + approved_root, + repo, + approved_result + ) + approved_process <- system2_with_child_environment( + isolated_child_env("approved"), + r_binary, + shQuote(approved_args), + wait = FALSE, + stdout = file.path(root, "approved-out"), + stderr = file.path(root, "approved-err") + ) + request <- wait_requests(file.path(approved_root, "consent"), 1L) + answer_requests(request, "approve") + deadline <- Sys.time() + 30 + while (!file.exists(approved_result) && Sys.time() < deadline) { + Sys.sleep(0.01) + } + if (!file.exists(approved_result)) { + logs <- unlist(lapply(c("approved-out", "approved-err"), function(name) { + path <- file.path(root, name) + if (file.exists(path)) readLines(path, warn = FALSE) else character() + })) + stop("Approved jgd attach did not finish: ", paste(logs, collapse = "\n")) + } + stopifnot(identical(readLines(approved_result), c("fixture-socket", "TRUE", "jgd", "TRUE"))) + stopifnot(identical(readLines(file.path(approved_root, "approved-device-log")), "jgd")) + + declined_root <- file.path(root, "declined") + dir.create(declined_root) + declined_result <- file.path(root, "declined-result") + declined_args <- c( + "--vanilla", + "--slave", + paste0("--file=", runner), + "--args", + "declined", + declined_root, + repo, + declined_result + ) + declined_process <- system2_with_child_environment( + isolated_child_env("declined"), + r_binary, + shQuote(declined_args), + wait = FALSE, + stdout = file.path(root, "declined-out"), + stderr = file.path(root, "declined-err") + ) + request <- wait_requests(file.path(declined_root, "consent"), 1L) + answer_requests(request, "decline") + deadline <- Sys.time() + 30 + while (!file.exists(declined_result) && Sys.time() < deadline) { + Sys.sleep(0.01) + } + if (!file.exists(declined_result)) { + stop("Declined jgd attach did not finish.") + } + stopifnot(identical( + readLines(declined_result), + c("fixture-socket", "FALSE", "standard", "FALSE") + )) - approved_real_result <- file.path(root, "real-approved-result") - real_process <- run_real_child("real-approved", approved_real_result, wait = FALSE) - real_request <- wait_requests(file.path(root, "consent"), 1L) - answer_requests(real_request, "approve") - deadline <- Sys.time() + 30 - while (!file.exists(approved_real_result) && Sys.time() < deadline) Sys.sleep(0.01) - if (!file.exists(approved_real_result)) { - logs <- unlist(lapply(c("real-approved-out", "real-approved-err"), function(name) { - path <- file.path(root, name) - if (file.exists(path)) readLines(path, warn = FALSE) else character() - })) - stop("Actual sess jgd connection did not finish: ", paste(logs, collapse = "\n")) + for (mode in c("old", "offline", "helper-missing", "library-helper-missing", "socket-empty")) { + result <- file.path(root, paste0(mode, "-result")) + observed <- run_child(mode, result) + expected_socket <- "fixture-socket" + expected <- c(expected_socket, if (mode == "old") "TRUE" else "FALSE", "standard", "FALSE") + if (!identical(observed, expected)) { + stop( + mode, + " expected ", + paste(expected, collapse = " | "), + " observed ", + paste(observed, collapse = " | ") + ) } - stopifnot(identical(readLines(approved_real_result, warn = FALSE), - c("TRUE", "TRUE", "fixture-jgd-socket", "TRUE", "TRUE", - "fixture-jgd-socket-next", "TRUE"))) - stopifnot(identical(readLines(file.path(root, "real-approved-real-device"), warn = FALSE), - c("jgd", "jgd"))) - frames <- lapply(readLines(file.path(root, "real-approved-real-device-frames"), warn = FALSE), - jsonlite::fromJSON) - stopifnot(length(frames) == 2L) - stopifnot(all(vapply(frames, function(frame) { - identity <- frame$vscodeR - nzchar(identity$sessionId) && nzchar(identity$pid) && - nzchar(identity$deviceId) && identical(identity$restoring, FALSE) - }, logical(1)))) - stopifnot(identical(frames[[1L]]$vscodeR$sessionId, frames[[2L]]$vscodeR$sessionId)) - stopifnot(!identical(frames[[1L]]$vscodeR$deviceId, frames[[2L]]$vscodeR$deviceId)) + stopifnot(length(list.files(file.path(root, mode, "consent"), pattern = "\\.request$")) == 0L) + } - approved_root <- file.path(root, "approved") - dir.create(approved_root) - approved_result <- file.path(root, "approved-result") - approved_args <- c("--vanilla", "--slave", paste0("--file=", runner), "--args", - "approved", approved_root, repo, approved_result) - approved_process <- system2_with_child_environment( - isolated_child_env("approved"), r_binary, shQuote(approved_args), wait = FALSE, - stdout = file.path(root, "approved-out"), stderr = file.path(root, "approved-err") + for (mode in c("no-prompt", "no-prompt-compatible")) { + plan_marker <- file.path(root, paste0(mode, "-plan-called")) + helper_lines <- readLines(file.path(getwd(), "R", "tool-library.R"), warn = FALSE) + helper_lines <- c( + helper_lines, + paste0( + "tool_library_plan <- function(...) { file.create(", + r_literal(plan_marker), + "); stop('unexpected metadata resolution') }" + ) ) - request <- wait_requests(file.path(approved_root, "consent"), 1L) - answer_requests(request, "approve") - deadline <- Sys.time() + 30 - while (!file.exists(approved_result) && Sys.time() < deadline) Sys.sleep(0.01) - if (!file.exists(approved_result)) { - logs <- unlist(lapply(c("approved-out", "approved-err"), function(name) { - path <- file.path(root, name) - if (file.exists(path)) readLines(path, warn = FALSE) else character() - })) - stop("Approved jgd attach did not finish: ", paste(logs, collapse = "\n")) + writeLines(helper_lines, file.path(root, "instrumented-tool-library.R")) + result <- file.path(root, paste0(mode, "-result")) + observed <- run_child(mode, result) + if (mode == "no-prompt") { + stopifnot(identical(observed, c("fixture-socket", "FALSE", "standard", "FALSE"))) + } else { + stopifnot(identical(observed, c("fixture-socket", "TRUE", "jgd", "TRUE"))) + stopifnot(identical(readLines(file.path(root, paste0(mode, "-device-log"))), "jgd")) } - stopifnot(identical(readLines(approved_result), c("fixture-socket", "TRUE", "jgd", "TRUE"))) - stopifnot(identical(readLines(file.path(approved_root, "approved-device-log")), "jgd")) + stopifnot(length(list.files(file.path(root, "consent"), pattern = "\\.request$")) == 0L) + stopifnot(!file.exists(plan_marker)) + } - declined_root <- file.path(root, "declined") - dir.create(declined_root) - declined_result <- file.path(root, "declined-result") - declined_args <- c("--vanilla", "--slave", paste0("--file=", runner), "--args", - "declined", declined_root, repo, declined_result) - declined_process <- system2_with_child_environment( - isolated_child_env("declined"), r_binary, shQuote(declined_args), wait = FALSE, - stdout = file.path(root, "declined-out"), stderr = file.path(root, "declined-err") + parallel_root <- file.path(root, "parallel") + dir.create(parallel_root) + base_helper <- readLines(file.path(getwd(), "R", "tool-library.R"), warn = FALSE) + instrumented_helper <- file.path(parallel_root, "instrumented-tool-library.R") + writeLines( + c( + base_helper, + ".tool_verify_child_base <- .tool_verify_child", + paste0( + ".tool_verify_child <- function(...) { cat('verify\\n', file=", + r_literal(file.path(parallel_root, "verify-log")), + ", append=TRUE);", + " .tool_verify_child_base(...) }" + ) + ), + instrumented_helper + ) + parallel_consent <- file.path(parallel_root, "consent") + dir.create(parallel_consent) + parallel_result <- file.path(parallel_root, c("one", "two")) + parallel_children <- lapply(seq_along(parallel_result), function(index) { + child_args <- c( + "--vanilla", + "--slave", + paste0("--file=", runner), + "--args", + "parallel", + parallel_root, + repo, + parallel_result[[index]] ) - request <- wait_requests(file.path(declined_root, "consent"), 1L) - answer_requests(request, "decline") - deadline <- Sys.time() + 30 - while (!file.exists(declined_result) && Sys.time() < deadline) Sys.sleep(0.01) - if (!file.exists(declined_result)) stop("Declined jgd attach did not finish.") - stopifnot(identical(readLines(declined_result), c("fixture-socket", "FALSE", "standard", "FALSE"))) + system2_with_child_environment( + isolated_child_env(paste0("parallel-", index)), + r_binary, + shQuote(child_args), + wait = FALSE, + stdout = file.path(parallel_root, paste0(index, "-out")), + stderr = file.path(parallel_root, paste0(index, "-err")) + ) + }) + requests <- wait_requests(parallel_consent, 2L) + answer_requests(requests, "approve") + deadline <- Sys.time() + 30 + while (!all(file.exists(parallel_result)) && Sys.time() < deadline) { + Sys.sleep(0.01) + } + if (!all(file.exists(parallel_result))) { + stop("Concurrent jgd preparation did not finish.") + } + stopifnot(all(vapply( + parallel_result, + function(path) { + identical(readLines(path, warn = FALSE), c("fixture-socket", "TRUE", "jgd", "TRUE")) + }, + FALSE + ))) + stopifnot(length(readLines(file.path(parallel_root, "verify-log"), warn = FALSE)) == 1L) - for (mode in c("old", "offline", "helper-missing", "library-helper-missing", "socket-empty")) { - result <- file.path(root, paste0(mode, "-result")) - observed <- run_child(mode, result) - expected_socket <- "fixture-socket" - expected <- c(expected_socket, if (mode == "old") "TRUE" else "FALSE", - "standard", "FALSE") - if (!identical(observed, expected)) { - stop(mode, " expected ", paste(expected, collapse = " | "), " observed ", - paste(observed, collapse = " | ")) + # Exercise the startup profile consumer separately: a declined optional tool + # request must still let sess connect and publish a ready startup status. + profile_root <- file.path(root, "profile-declined") + dir.create(profile_root) + profile_consent <- file.path(profile_root, "consent") + dir.create(profile_consent) + profile_log <- file.path(profile_root, "connect-log") + stub_attach <- file.path(profile_root, "attach-helper.R") + source_helper <- file.path(profile_root, "source-helper.R") + installer_helper <- file.path(profile_root, "installer-helper.R") + empty_user_profile <- file.path(profile_root, "empty-user-profile.R") + file.create(source_helper, installer_helper, empty_user_profile) + writeLines( + c( + "source(file.path(getwd(), 'R', 'attach_sess.R'))", + "vscode_r_prepare_sess <- function(...) { ns <- new.env(); ns$connect <- function(allow_jgd=TRUE, ...) {", + paste0( + " writeLines(c(Sys.getenv('JGD_SOCKET', unset=''), ", + "as.character(requireNamespace('jgd', quietly=TRUE)), as.character(allow_jgd)), ", + "", + r_literal(profile_log), + ")" + ), + " TRUE", + "}; ns }" + ), + stub_attach + ) + startup_file <- file.path(profile_root, "startup.status") + startup_profile <- file.path(profile_root, "run-profile.R") + # Publish completion only after profile.R returns, so the status file is final. + # Polling the status while the child replaces it fails on Windows: an open + # reader blocks the rename and a reader racing the rename gets Permission denied. + profile_done <- file.path(profile_root, "profile-done") + profile_done_temporary <- paste0(profile_done, ".tmp") + writeLines( + c( + paste0("Sys.setenv(VSCODE_R_SESS_PKG_PATH=", r_literal(package), ","), + paste0(" VSCODE_R_SESS_SOURCE_HELPER=", r_literal(source_helper), ","), + paste0(" VSCODE_R_SESS_ATTACH_HELPER=", r_literal(stub_attach), ","), + paste0(" VSCODE_R_SESS_INSTALLER_HELPER=", r_literal(installer_helper), ","), + paste0(" VSCODE_R_SESS_ROOT=", r_literal(profile_root), ","), + paste0(" VSCODE_R_SESS_CONSENT_DIRECTORY=", r_literal(profile_consent), ","), + paste0(" VSCODE_R_SESS_STARTUP_FILE=", r_literal(startup_file), ","), + " VSCODE_R_SESS_STARTUP_TOKEN='0123456789abcdef0123456789abcdef',", + " VSCODE_R_SESS_STARTUP_ENDPOINT='fixture-endpoint',", + paste0( + " VSCODE_R_SESS_STARTUP_HELPER=", + r_literal(file.path(getwd(), "R", "terminal-startup.R")), + "," + ), + paste0( + " VSCODE_R_TOOL_PREPARE_HELPER=", + r_literal(file.path(getwd(), "R", "prepare-tools.R")), + "," + ), + paste0(" VSCODE_R_TOOL_ROOT=", r_literal(file.path(profile_root, "tools")), ","), + paste0(" VSCODE_R_TOOL_CONSENT_DIRECTORY=", r_literal(profile_consent), ","), + paste0( + " VSCODE_R_TOOL_LIBRARY_HELPER=", + r_literal(file.path(getwd(), "R", "tool-library.R")), + "," + ), + paste0( + " VSCODE_R_TOOL_CONSENT_HELPER=", + r_literal(file.path(getwd(), "R", "tool-consent.R")), + "," + ), + " VSCODE_R_JGD_CAN_PROMPT='TRUE',", + " VSCODE_R_JGD_MINIMUM_VERSION='0.1.0',", + paste0(" R_PROFILE_USER_OLD=", r_literal(empty_user_profile), ","), + " SESS_PLOT_BACKEND='jgd', SESS_RSTUDIOAPI='FALSE', JGD_SOCKET='fixture-socket')", + paste0("options(repos=c(CRAN=", r_literal(repo), "), pkgType='source')"), + paste0( + "tryCatch(source(file.path(getwd(), 'R', 'profile.R')), finally = {", + "writeLines('done', ", + r_literal(profile_done_temporary), + "); ", + "stopifnot(file.rename(", + r_literal(profile_done_temporary), + ", ", + r_literal(profile_done), + ")) })" + ) + ), + startup_profile + ) + profile_result <- file.path(profile_root, "result") + profile_process <- system2_with_child_environment( + isolated_child_env("profile"), + r_binary, + shQuote(c("--vanilla", "--slave", paste0("--file=", startup_profile))), + wait = FALSE, + stdout = file.path(profile_root, "stdout"), + stderr = file.path(profile_root, "stderr") + ) + request <- wait_requests(profile_consent, 1L) + answer_requests(request, "decline") + profile_logs <- function() { + # Redirected output can stay open briefly after the done marker on Windows. + unlist(lapply(c("stdout", "stderr"), function(name) { + path <- file.path(profile_root, name) + deadline <- Sys.time() + 10 + repeat { + lines <- suppressWarnings(tryCatch( + if (file.exists(path)) readLines(path, warn = FALSE) else character(), + error = function(error) NULL + )) + if (!is.null(lines)) { + return(lines) } - stopifnot(length(list.files(file.path(root, mode, "consent"), pattern = "\\.request$")) == 0L) - } - - for (mode in c("no-prompt", "no-prompt-compatible")) { - plan_marker <- file.path(root, paste0(mode, "-plan-called")) - helper_lines <- readLines(file.path(getwd(), "R", "tool-library.R"), warn = FALSE) - helper_lines <- c(helper_lines, - paste0("tool_library_plan <- function(...) { file.create(", - r_literal(plan_marker), "); stop('unexpected metadata resolution') }")) - writeLines(helper_lines, file.path(root, "instrumented-tool-library.R")) - result <- file.path(root, paste0(mode, "-result")) - observed <- run_child(mode, result) - if (mode == "no-prompt") { - stopifnot(identical(observed, c("fixture-socket", "FALSE", "standard", "FALSE"))) - } else { - stopifnot(identical(observed, c("fixture-socket", "TRUE", "jgd", "TRUE"))) - stopifnot(identical(readLines(file.path(root, paste0(mode, "-device-log"))), "jgd")) + if (Sys.time() >= deadline) { + return(paste("could not read", path)) } - stopifnot(length(list.files(file.path(root, "consent"), pattern = "\\.request$")) == 0L) - stopifnot(!file.exists(plan_marker)) - } - - parallel_root <- file.path(root, "parallel") - dir.create(parallel_root) - base_helper <- readLines(file.path(getwd(), "R", "tool-library.R"), warn = FALSE) - instrumented_helper <- file.path(parallel_root, "instrumented-tool-library.R") - writeLines(c(base_helper, - ".tool_verify_child_base <- .tool_verify_child", - paste0(".tool_verify_child <- function(...) { cat('verify\\n', file=", - r_literal(file.path(parallel_root, "verify-log")), ", append=TRUE);", - " .tool_verify_child_base(...) }")), instrumented_helper) - parallel_consent <- file.path(parallel_root, "consent") - dir.create(parallel_consent) - parallel_result <- file.path(parallel_root, c("one", "two")) - parallel_children <- lapply(seq_along(parallel_result), function(index) { - child_args <- c("--vanilla", "--slave", paste0("--file=", runner), "--args", - "parallel", parallel_root, repo, parallel_result[[index]]) - system2_with_child_environment( - isolated_child_env(paste0("parallel-", index)), r_binary, shQuote(child_args), wait = FALSE, - stdout = file.path(parallel_root, paste0(index, "-out")), - stderr = file.path(parallel_root, paste0(index, "-err")) - ) - }) - requests <- wait_requests(parallel_consent, 2L) - answer_requests(requests, "approve") - deadline <- Sys.time() + 30 - while (!all(file.exists(parallel_result)) && Sys.time() < deadline) Sys.sleep(0.01) - if (!all(file.exists(parallel_result))) stop("Concurrent jgd preparation did not finish.") - stopifnot(all(vapply(parallel_result, function(path) { - identical(readLines(path, warn = FALSE), c("fixture-socket", "TRUE", "jgd", "TRUE")) - }, FALSE))) - stopifnot(length(readLines(file.path(parallel_root, "verify-log"), warn = FALSE)) == 1L) - - # Exercise the startup profile consumer separately: a declined optional tool - # request must still let sess connect and publish a ready startup status. - profile_root <- file.path(root, "profile-declined") - dir.create(profile_root) - profile_consent <- file.path(profile_root, "consent") - dir.create(profile_consent) - profile_log <- file.path(profile_root, "connect-log") - stub_attach <- file.path(profile_root, "attach-helper.R") - source_helper <- file.path(profile_root, "source-helper.R") - installer_helper <- file.path(profile_root, "installer-helper.R") - empty_user_profile <- file.path(profile_root, "empty-user-profile.R") - file.create(source_helper, installer_helper, empty_user_profile) - writeLines(c( - "source(file.path(getwd(), 'R', 'attach_sess.R'))", - "vscode_r_prepare_sess <- function(...) { ns <- new.env(); ns$connect <- function(allow_jgd=TRUE, ...) {", - paste0(" writeLines(c(Sys.getenv('JGD_SOCKET', unset=''), ", - "as.character(requireNamespace('jgd', quietly=TRUE)), as.character(allow_jgd)), ", - "", r_literal(profile_log), ")"), - " TRUE", - "}; ns }" - ), stub_attach) - startup_file <- file.path(profile_root, "startup.status") - startup_profile <- file.path(profile_root, "run-profile.R") - # Publish completion only after profile.R returns, so the status file is final. - # Polling the status while the child replaces it fails on Windows: an open - # reader blocks the rename and a reader racing the rename gets Permission denied. - profile_done <- file.path(profile_root, "profile-done") - profile_done_temporary <- paste0(profile_done, ".tmp") - writeLines(c( - paste0("Sys.setenv(VSCODE_R_SESS_PKG_PATH=", r_literal(package), ","), - paste0(" VSCODE_R_SESS_SOURCE_HELPER=", r_literal(source_helper), ","), - paste0(" VSCODE_R_SESS_ATTACH_HELPER=", r_literal(stub_attach), ","), - paste0(" VSCODE_R_SESS_INSTALLER_HELPER=", r_literal(installer_helper), ","), - paste0(" VSCODE_R_SESS_ROOT=", r_literal(profile_root), ","), - paste0(" VSCODE_R_SESS_CONSENT_DIRECTORY=", r_literal(profile_consent), ","), - paste0(" VSCODE_R_SESS_STARTUP_FILE=", r_literal(startup_file), ","), - " VSCODE_R_SESS_STARTUP_TOKEN='0123456789abcdef0123456789abcdef',", - " VSCODE_R_SESS_STARTUP_ENDPOINT='fixture-endpoint',", - paste0(" VSCODE_R_SESS_STARTUP_HELPER=", r_literal(file.path(getwd(), "R", "terminal-startup.R")), ","), - paste0(" VSCODE_R_TOOL_PREPARE_HELPER=", r_literal(file.path(getwd(), "R", "prepare-tools.R")), ","), - paste0(" VSCODE_R_TOOL_ROOT=", r_literal(file.path(profile_root, "tools")), ","), - paste0(" VSCODE_R_TOOL_CONSENT_DIRECTORY=", r_literal(profile_consent), ","), - paste0(" VSCODE_R_TOOL_LIBRARY_HELPER=", r_literal(file.path(getwd(), "R", "tool-library.R")), ","), - paste0(" VSCODE_R_TOOL_CONSENT_HELPER=", r_literal(file.path(getwd(), "R", "tool-consent.R")), ","), - " VSCODE_R_JGD_CAN_PROMPT='TRUE',", - " VSCODE_R_JGD_MINIMUM_VERSION='0.1.0',", - paste0(" R_PROFILE_USER_OLD=", r_literal(empty_user_profile), ","), - " SESS_PLOT_BACKEND='jgd', SESS_RSTUDIOAPI='FALSE', JGD_SOCKET='fixture-socket')", - paste0("options(repos=c(CRAN=", r_literal(repo), "), pkgType='source')"), - paste0("tryCatch(source(file.path(getwd(), 'R', 'profile.R')), finally = {", - "writeLines('done', ", r_literal(profile_done_temporary), "); ", - "stopifnot(file.rename(", r_literal(profile_done_temporary), ", ", - r_literal(profile_done), ")) })") - ), startup_profile) - profile_result <- file.path(profile_root, "result") - profile_process <- system2_with_child_environment( - isolated_child_env("profile"), r_binary, - shQuote(c("--vanilla", "--slave", paste0("--file=", startup_profile))), - wait = FALSE, stdout = file.path(profile_root, "stdout"), - stderr = file.path(profile_root, "stderr") + Sys.sleep(0.1) + } + })) + } + deadline <- Sys.time() + 60 + while (!file.exists(profile_done) && Sys.time() < deadline) { + Sys.sleep(0.05) + } + if (!file.exists(profile_done)) { + stop("Declined startup profile did not finish: ", paste(profile_logs(), collapse = "\n")) + } + if (!file.exists(profile_log)) { + stop("Declined startup profile did not connect sess: ", paste(profile_logs(), collapse = "\n")) + } + stopifnot(identical(readLines(profile_log), c("fixture-socket", "FALSE", "FALSE"))) + startup_status <- readLines(startup_file, warn = FALSE) + if (length(startup_status) != 6L || startup_status[[6L]] != "ready") { + logs <- profile_logs() + stop( + "Unexpected profile startup status: ", + paste(startup_status, collapse = " | "), + " logs: ", + paste(logs, collapse = "\n") ) - request <- wait_requests(profile_consent, 1L) - answer_requests(request, "decline") - profile_logs <- function() { - # Redirected output can stay open briefly after the done marker on Windows. - unlist(lapply(c("stdout", "stderr"), function(name) { - path <- file.path(profile_root, name) - deadline <- Sys.time() + 10 - repeat { - lines <- suppressWarnings(tryCatch( - if (file.exists(path)) readLines(path, warn = FALSE) else character(), - error = function(error) NULL - )) - if (!is.null(lines)) return(lines) - if (Sys.time() >= deadline) return(paste("could not read", path)) - Sys.sleep(0.1) - } - })) - } - deadline <- Sys.time() + 60 - while (!file.exists(profile_done) && Sys.time() < deadline) Sys.sleep(0.05) - if (!file.exists(profile_done)) { - stop("Declined startup profile did not finish: ", paste(profile_logs(), collapse = "\n")) - } - if (!file.exists(profile_log)) { - stop("Declined startup profile did not connect sess: ", paste(profile_logs(), collapse = "\n")) - } - stopifnot(identical(readLines(profile_log), c("fixture-socket", "FALSE", "FALSE"))) - startup_status <- readLines(startup_file, warn = FALSE) - if (length(startup_status) != 6L || startup_status[[6L]] != "ready") { - logs <- profile_logs() - stop("Unexpected profile startup status: ", paste(startup_status, collapse = " | "), - " logs: ", paste(logs, collapse = "\n")) - } + } - cat("jgd preparation integration tests passed\n") + cat("jgd preparation integration tests passed\n") }) diff --git a/R/tests/prepare-rstudioapi.R b/R/tests/prepare-rstudioapi.R index 1bf403426..40bb84d02 100644 --- a/R/tests/prepare-rstudioapi.R +++ b/R/tests/prepare-rstudioapi.R @@ -1,312 +1,421 @@ # Base-R integration coverage for optional rstudioapi preparation during attach # and terminal startup. All packages are local fixtures served from a file repository. local({ - root <- tempfile("prepare-rstudioapi-") - dir.create(root) - root <- normalizePath(root, winslash = "/", mustWork = TRUE) - on.exit(unlink(root, recursive = TRUE), add = TRUE) - r_literal <- function(value) paste0("\"", gsub("\\\"", "\\\\\\\"", value), "\"") - r_binary <- file.path(R.home("bin"), "R") - minimum_version <- "0.4.0" - ambient_library <- file.path(root, "ambient-user-library") - dir.create(ambient_library) - isolated_child_env <- function(label) { - user_library <- file.path(root, "isolated-libraries", label, "user") - site_library <- file.path(root, "isolated-libraries", label, "site") - dir.create(user_library, recursive = TRUE, showWarnings = FALSE) - dir.create(site_library, recursive = TRUE, showWarnings = FALSE) - c(R_LIBS_USER = user_library, R_LIBS_SITE = site_library, R_LIBS = "") - } - system2_with_child_environment <- function(environment, command, args, ...) { - keys <- names(environment) - previous <- Sys.getenv(keys, unset = NA_character_) - on.exit({ - unset <- keys[is.na(previous)] - if (length(unset)) Sys.unsetenv(unset) - restore <- previous[!is.na(previous)] - if (length(restore)) do.call(Sys.setenv, as.list(restore)) - }, add = TRUE) - do.call(Sys.setenv, as.list(environment)) - system2(command, args, ...) - } - - # Fixtures: rstudioapi 0.4.0 is published, 0.3.1 exists only as a local source - # directory below the minimum. jgd 0.1.0 is published for the combined startup. - fixture_package <- function(package, version, publish) { - directory <- file.path(root, "fixtures", paste0(package, "-", version)) - dir.create(file.path(directory, "R"), recursive = TRUE) - writeLines(c( - paste0("Package: ", package), paste0("Version: ", version), - paste0("Title: ", package, " fixture"), - paste0("Description: Local ", package, " fixture."), "License: MIT", - "Author: Test Author", "Maintainer: Test Author ", - "Encoding: UTF-8" - ), file.path(directory, "DESCRIPTION")) - writeLines("fixture_value <- function() 'fixture'", file.path(directory, "R", "api.R")) - writeLines("export(fixture_value)", file.path(directory, "NAMESPACE")) - if (publish) { - previous <- setwd(dirname(directory)) - on.exit(setwd(previous), add = TRUE) - output <- system2_with_child_environment( - isolated_child_env(paste0("build-", package, "-", version)), r_binary, - c("CMD", "build", "--no-build-vignettes", shQuote(basename(directory))), - stdout = TRUE, stderr = TRUE - ) - status <- attr(output, "status") - if (!is.null(status) && status != 0L) stop(paste(output, collapse = "\n")) - contrib <- file.path(root, "repo", "src", "contrib") - dir.create(contrib, recursive = TRUE, showWarnings = FALSE) - archive <- file.path(dirname(directory), paste0(package, "_", version, ".tar.gz")) - stopifnot(file.copy(archive, contrib)) + root <- tempfile("prepare-rstudioapi-") + dir.create(root) + root <- normalizePath(root, winslash = "/", mustWork = TRUE) + on.exit(unlink(root, recursive = TRUE), add = TRUE) + r_literal <- function(value) paste0("\"", gsub("\\\"", "\\\\\\\"", value), "\"") + r_binary <- file.path(R.home("bin"), "R") + minimum_version <- "0.4.0" + ambient_library <- file.path(root, "ambient-user-library") + dir.create(ambient_library) + isolated_child_env <- function(label) { + user_library <- file.path(root, "isolated-libraries", label, "user") + site_library <- file.path(root, "isolated-libraries", label, "site") + dir.create(user_library, recursive = TRUE, showWarnings = FALSE) + dir.create(site_library, recursive = TRUE, showWarnings = FALSE) + c(R_LIBS_USER = user_library, R_LIBS_SITE = site_library, R_LIBS = "") + } + system2_with_child_environment <- function(environment, command, args, ...) { + keys <- names(environment) + previous <- Sys.getenv(keys, unset = NA_character_) + on.exit( + { + unset <- keys[is.na(previous)] + if (length(unset)) { + Sys.unsetenv(unset) } - directory + restore <- previous[!is.na(previous)] + if (length(restore)) do.call(Sys.setenv, as.list(restore)) + }, + add = TRUE + ) + do.call(Sys.setenv, as.list(environment)) + system2(command, args, ...) + } + + # Fixtures: rstudioapi 0.4.0 is published, 0.3.1 exists only as a local source + # directory below the minimum. jgd 0.1.0 is published for the combined startup. + fixture_package <- function(package, version, publish) { + directory <- file.path(root, "fixtures", paste0(package, "-", version)) + dir.create(file.path(directory, "R"), recursive = TRUE) + writeLines( + c( + paste0("Package: ", package), + paste0("Version: ", version), + paste0("Title: ", package, " fixture"), + paste0("Description: Local ", package, " fixture."), + "License: MIT", + "Author: Test Author", + "Maintainer: Test Author ", + "Encoding: UTF-8" + ), + file.path(directory, "DESCRIPTION") + ) + writeLines("fixture_value <- function() 'fixture'", file.path(directory, "R", "api.R")) + writeLines("export(fixture_value)", file.path(directory, "NAMESPACE")) + if (publish) { + previous <- setwd(dirname(directory)) + on.exit(setwd(previous), add = TRUE) + output <- system2_with_child_environment( + isolated_child_env(paste0("build-", package, "-", version)), + r_binary, + c("CMD", "build", "--no-build-vignettes", shQuote(basename(directory))), + stdout = TRUE, + stderr = TRUE + ) + status <- attr(output, "status") + if (!is.null(status) && status != 0L) { + stop(paste(output, collapse = "\n")) + } + contrib <- file.path(root, "repo", "src", "contrib") + dir.create(contrib, recursive = TRUE, showWarnings = FALSE) + archive <- file.path(dirname(directory), paste0(package, "_", version, ".tar.gz")) + stopifnot(file.copy(archive, contrib)) } - fixture_package("rstudioapi", minimum_version, publish = TRUE) - fixture_package("rstudioapi", "0.3.1", publish = FALSE) - fixture_package("jgd", "0.1.0", publish = TRUE) - tools::write_PACKAGES(file.path(root, "repo", "src", "contrib"), type = "source") - repo <- paste0("file:///", sub("^/", "", normalizePath(file.path(root, "repo"), winslash = "/"))) - fixtures <- file.path(root, "fixtures") + directory + } + fixture_package("rstudioapi", minimum_version, publish = TRUE) + fixture_package("rstudioapi", "0.3.1", publish = FALSE) + fixture_package("jgd", "0.1.0", publish = TRUE) + tools::write_PACKAGES(file.path(root, "repo", "src", "contrib"), type = "source") + repo <- paste0("file:///", sub("^/", "", normalizePath(file.path(root, "repo"), winslash = "/"))) + fixtures <- file.path(root, "fixtures") - # The child records what sess would observe when connect() runs. - runner <- file.path(root, "run-attach.R") - writeLines(c( - "args <- commandArgs(TRUE); mode <- args[[1L]]; root <- args[[2L]]; repo <- args[[3L]];", - "result <- args[[4L]]; fixtures <- args[[5L]];", - "source(file.path(getwd(), 'R', 'tool-library.R'));", - "source(file.path(getwd(), 'R', 'tool-consent.R'));", - "source(file.path(getwd(), 'R', 'attach_sess.R'));", - "options(repos=c(CRAN=repo), pkgType='source');", - "if (mode == 'offline') options(repos=c(CRAN=file.path(root, 'missing-repo')));", - "work <- file.path(root, mode);", - "consent <- file.path(work, 'consent'); dir.create(consent);", - "install_fixture <- function(name, label) {", - " library <- file.path(work, label); dir.create(library);", - " utils::install.packages(file.path(fixtures, name), repos=NULL, type='source',", - " lib=library, quiet=TRUE);", - " .libPaths(c(library, .libPaths())); library", - "};", - "if (mode %in% c('no-prompt-compatible', 'loaded-compatible'))", - " loaded_from <- install_fixture('rstudioapi-0.4.0', 'ordinary-library');", - "if (mode == 'loaded-compatible') loadNamespace('rstudioapi', lib.loc=loaded_from);", - "if (mode == 'loaded-incompatible') {", - " loaded_from <- install_fixture('rstudioapi-0.3.1', 'old-library');", - " loadNamespace('rstudioapi', lib.loc=loaded_from);", - "}", - # Record metadata resolution without changing what the helper does. - "marker <- file.path(work, 'plan-called');", - "instrumented <- file.path(work, 'tool-library.R');", - "writeLines(c(readLines(file.path(getwd(), 'R', 'tool-library.R'), warn=FALSE),", - " 'tool_library_plan_original <- tool_library_plan',", - " paste0('tool_library_plan <- function(...) { file.create(',", - " deparse(marker), '); tool_library_plan_original(...) }')), instrumented);", - "seen <- new.env();", - "vscode_r_prepare_sess <- function(...) { ns <- new.env();", - " ns$connect <- function(allow_jgd=TRUE, ...) {", - " seen$called <- TRUE; seen$allow_jgd <- allow_jgd;", - " seen$rstudioapi <- 'rstudioapi' %in% loadedNamespaces();", - " seen$jgd <- 'jgd' %in% loadedNamespaces();", - " seen$path <- if (seen$rstudioapi)", - " normalizePath(getNamespaceInfo('rstudioapi', 'path'), winslash='/') else '';", - " seen$version <- if (seen$rstudioapi)", - " as.character(getNamespaceVersion(asNamespace('rstudioapi'))) else '';", - " seen$require <- requireNamespace('rstudioapi', quietly=TRUE);", - " TRUE", - " }; ns };", - "libraries_before <- .libPaths();", - "can_prompt <- !(mode %in% c('no-prompt', 'no-prompt-compatible'));", - "plot_backend <- switch(mode, both='auto', 'both-explicit'='jgd', 'standard');", - "answer <- vscode_r_attach_sess('endpoint', 'unused', file.path(work, 'managed'), consent,", - " 'unused', 'unused', plot_backend, timeout_seconds=0,", - " use_rstudioapi=mode != 'disabled',", - " tool_root=file.path(work, 'tools'), tool_consent_directory=consent,", - " tool_library_helper=instrumented,", - " tool_consent_helper=file.path(getwd(), 'R', 'tool-consent.R'),", - " tool_prepare_helper=file.path(getwd(), 'R', 'prepare-tools.R'),", - " jgd_can_prompt=can_prompt, jgd_minimum_version='0.1.0',", - " rstudioapi_can_prompt=can_prompt, rstudioapi_minimum_version='0.4.0');", - "stopifnot(isTRUE(answer), isTRUE(seen$called), identical(.libPaths(), libraries_before));", - "tool_path <- tool_library_path(file.path(work, 'tools'));", - "writeLines(c(as.character(seen$rstudioapi), seen$path, seen$version,", - " as.character(seen$require), as.character(seen$jgd), as.character(seen$allow_jgd),", - " as.character(file.exists(marker)), tool_path), result)" - ), runner) + # The child records what sess would observe when connect() runs. + runner <- file.path(root, "run-attach.R") + writeLines( + c( + "args <- commandArgs(TRUE); mode <- args[[1L]]; root <- args[[2L]]; repo <- args[[3L]];", + "result <- args[[4L]]; fixtures <- args[[5L]];", + "source(file.path(getwd(), 'R', 'tool-library.R'));", + "source(file.path(getwd(), 'R', 'tool-consent.R'));", + "source(file.path(getwd(), 'R', 'attach_sess.R'));", + "options(repos=c(CRAN=repo), pkgType='source');", + "if (mode == 'offline') options(repos=c(CRAN=file.path(root, 'missing-repo')));", + "work <- file.path(root, mode);", + "consent <- file.path(work, 'consent'); dir.create(consent);", + "install_fixture <- function(name, label) {", + " library <- file.path(work, label); dir.create(library);", + " utils::install.packages(file.path(fixtures, name), repos=NULL, type='source',", + " lib=library, quiet=TRUE);", + " .libPaths(c(library, .libPaths())); library", + "};", + "if (mode %in% c('no-prompt-compatible', 'loaded-compatible'))", + " loaded_from <- install_fixture('rstudioapi-0.4.0', 'ordinary-library');", + "if (mode == 'loaded-compatible') loadNamespace('rstudioapi', lib.loc=loaded_from);", + "if (mode == 'loaded-incompatible') {", + " loaded_from <- install_fixture('rstudioapi-0.3.1', 'old-library');", + " loadNamespace('rstudioapi', lib.loc=loaded_from);", + "}", + # Record metadata resolution without changing what the helper does. + "marker <- file.path(work, 'plan-called');", + "instrumented <- file.path(work, 'tool-library.R');", + "writeLines(c(readLines(file.path(getwd(), 'R', 'tool-library.R'), warn=FALSE),", + " 'tool_library_plan_original <- tool_library_plan',", + " paste0('tool_library_plan <- function(...) { file.create(',", + " deparse(marker), '); tool_library_plan_original(...) }')), instrumented);", + "seen <- new.env();", + "vscode_r_prepare_sess <- function(...) { ns <- new.env();", + " ns$connect <- function(allow_jgd=TRUE, ...) {", + " seen$called <- TRUE; seen$allow_jgd <- allow_jgd;", + " seen$rstudioapi <- 'rstudioapi' %in% loadedNamespaces();", + " seen$jgd <- 'jgd' %in% loadedNamespaces();", + " seen$path <- if (seen$rstudioapi)", + " normalizePath(getNamespaceInfo('rstudioapi', 'path'), winslash='/') else '';", + " seen$version <- if (seen$rstudioapi)", + " as.character(getNamespaceVersion(asNamespace('rstudioapi'))) else '';", + " seen$require <- requireNamespace('rstudioapi', quietly=TRUE);", + " TRUE", + " }; ns };", + "libraries_before <- .libPaths();", + "can_prompt <- !(mode %in% c('no-prompt', 'no-prompt-compatible'));", + "plot_backend <- switch(mode, both='auto', 'both-explicit'='jgd', 'standard');", + "answer <- vscode_r_attach_sess('endpoint', 'unused', file.path(work, 'managed'), consent,", + " 'unused', 'unused', plot_backend, timeout_seconds=0,", + " use_rstudioapi=mode != 'disabled',", + " tool_root=file.path(work, 'tools'), tool_consent_directory=consent,", + " tool_library_helper=instrumented,", + " tool_consent_helper=file.path(getwd(), 'R', 'tool-consent.R'),", + " tool_prepare_helper=file.path(getwd(), 'R', 'prepare-tools.R'),", + " jgd_can_prompt=can_prompt, jgd_minimum_version='0.1.0',", + " rstudioapi_can_prompt=can_prompt, rstudioapi_minimum_version='0.4.0');", + "stopifnot(isTRUE(answer), isTRUE(seen$called), identical(.libPaths(), libraries_before));", + "tool_path <- tool_library_path(file.path(work, 'tools'));", + "writeLines(c(as.character(seen$rstudioapi), seen$path, seen$version,", + " as.character(seen$require), as.character(seen$jgd), as.character(seen$allow_jgd),", + " as.character(file.exists(marker)), tool_path), result)" + ), + runner + ) - read_child_logs <- function(logs, timeout_seconds = 10) { - deadline <- Sys.time() + timeout_seconds - repeat { - output <- lapply(logs, function(path) { - suppressWarnings(tryCatch(readLines(path, warn = FALSE), - error = function(error) error)) - }) - failed <- vapply(output, inherits, FALSE, "error") - if (!any(failed)) return(unlist(output)) - if (Sys.time() >= deadline) { - stop(output[[which(failed)[[1L]]]]) - } - # Publishing a result does not close redirected stdout/stderr. Windows - # can deny read access until the asynchronous child releases them. - Sys.sleep(0.02) + read_child_logs <- function(logs, timeout_seconds = 10) { + deadline <- Sys.time() + timeout_seconds + repeat { + output <- lapply( + logs, + function(path) { + suppressWarnings(tryCatch(readLines(path, warn = FALSE), error = function(error) error)) } + ) + failed <- vapply(output, inherits, FALSE, "error") + if (!any(failed)) { + return(unlist(output)) + } + if (Sys.time() >= deadline) { + stop(output[[which(failed)[[1L]]]]) + } + # Publishing a result does not close redirected stdout/stderr. Windows + # can deny read access until the asynchronous child releases them. + Sys.sleep(0.02) } + } - # Answer consent requests by package until the child publishes its result. - serve <- function(consent, result, answers, logs) { - seen <- list() - handled <- character() - deadline <- Sys.time() + 90 - repeat { - for (path in list.files(consent, pattern = "\\.request$", full.names = TRUE)) { - id <- sub("\\.request$", "", basename(path)) - if (id %in% handled) next - handled <- c(handled, id) - lines <- readLines(path, warn = FALSE) - seen[[length(seen) + 1L]] <- lines - answer <- answers[[lines[[6L]]]] - if (is.null(answer)) answer <- "decline" - temporary <- file.path(consent, paste0(id, ".response.tmp")) - writeLines(answer, temporary, useBytes = TRUE) - stopifnot(file.rename(temporary, file.path(consent, paste0(id, ".response")))) - } - if (file.exists(result)) return(seen) - if (Sys.time() >= deadline) { - output <- tryCatch(read_child_logs(logs, timeout_seconds = 0), - error = conditionMessage) - stop("Timed out waiting for the attach child: ", paste(output, collapse = "\n")) - } - Sys.sleep(0.02) + # Answer consent requests by package until the child publishes its result. + serve <- function(consent, result, answers, logs) { + seen <- list() + handled <- character() + deadline <- Sys.time() + 90 + repeat { + for (path in list.files(consent, pattern = "\\.request$", full.names = TRUE)) { + id <- sub("\\.request$", "", basename(path)) + if (id %in% handled) { + next } + handled <- c(handled, id) + lines <- readLines(path, warn = FALSE) + seen[[length(seen) + 1L]] <- lines + answer <- answers[[lines[[6L]]]] + if (is.null(answer)) { + answer <- "decline" + } + temporary <- file.path(consent, paste0(id, ".response.tmp")) + writeLines(answer, temporary, useBytes = TRUE) + stopifnot(file.rename(temporary, file.path(consent, paste0(id, ".response")))) + } + if (file.exists(result)) { + return(seen) + } + if (Sys.time() >= deadline) { + output <- tryCatch(read_child_logs(logs, timeout_seconds = 0), error = conditionMessage) + stop("Timed out waiting for the attach child: ", paste(output, collapse = "\n")) + } + Sys.sleep(0.02) } + } - run_mode <- function(mode, answers = list()) { - result <- file.path(root, paste0(mode, "-result")) - logs <- file.path(root, paste0(mode, c("-out", "-err"))) - dir.create(file.path(root, mode), showWarnings = FALSE) - args <- c("--vanilla", "--slave", paste0("--file=", runner), "--args", - mode, root, repo, result, fixtures) - system2_with_child_environment(isolated_child_env(mode), r_binary, shQuote(args), - wait = FALSE, stdout = logs[[1L]], stderr = logs[[2L]]) - requests <- serve(file.path(root, mode, "consent"), result, answers, logs) - output <- read_child_logs(logs) - list(values = readLines(result, warn = FALSE), requests = requests, - messages = grep("^vscode-R|incompatible", output, value = TRUE)) - } - request_summary <- function(request) request[c(4L, 6L, 7L)] + run_mode <- function(mode, answers = list()) { + result <- file.path(root, paste0(mode, "-result")) + logs <- file.path(root, paste0(mode, c("-out", "-err"))) + dir.create(file.path(root, mode), showWarnings = FALSE) + args <- c( + "--vanilla", + "--slave", + paste0("--file=", runner), + "--args", + mode, + root, + repo, + result, + fixtures + ) + system2_with_child_environment( + isolated_child_env(mode), + r_binary, + shQuote(args), + wait = FALSE, + stdout = logs[[1L]], + stderr = logs[[2L]] + ) + requests <- serve(file.path(root, mode, "consent"), result, answers, logs) + output <- read_child_logs(logs) + list( + values = readLines(result, warn = FALSE), + requests = requests, + messages = grep("^vscode-R|incompatible", output, value = TRUE) + ) + } + request_summary <- function(request) request[c(4L, 6L, 7L)] - approved <- run_mode("approved", list(rstudioapi = "approve")) - tool_package <- file.path(approved$values[[8L]], "rstudioapi") - stopifnot(length(approved$requests) == 1L, - identical(request_summary(approved$requests[[1L]]), - c("once", "rstudioapi", minimum_version)), - identical(approved$values[1:7], - c("TRUE", normalizePath(tool_package, winslash = "/"), minimum_version, - "TRUE", "FALSE", "TRUE", "TRUE")), - length(approved$messages) == 0L) + approved <- run_mode("approved", list(rstudioapi = "approve")) + tool_package <- file.path(approved$values[[8L]], "rstudioapi") + stopifnot( + length(approved$requests) == 1L, + identical(request_summary(approved$requests[[1L]]), c("once", "rstudioapi", minimum_version)), + identical( + approved$values[1:7], + c( + "TRUE", + normalizePath(tool_package, winslash = "/"), + minimum_version, + "TRUE", + "FALSE", + "TRUE", + "TRUE" + ) + ), + length(approved$messages) == 0L + ) - declined <- run_mode("declined") - stopifnot(length(declined$requests) == 1L, - identical(declined$values[c(1L, 4L, 7L)], c("FALSE", "FALSE", "TRUE")), - length(declined$messages) == 1L, - grepl("rstudioapi installation was not approved", declined$messages)) - stopifnot(!dir.exists(file.path(declined$values[[8L]], "rstudioapi"))) + declined <- run_mode("declined") + stopifnot( + length(declined$requests) == 1L, + identical(declined$values[c(1L, 4L, 7L)], c("FALSE", "FALSE", "TRUE")), + length(declined$messages) == 1L, + grepl("rstudioapi installation was not approved", declined$messages) + ) + stopifnot(!dir.exists(file.path(declined$values[[8L]], "rstudioapi"))) - offline <- run_mode("offline") - stopifnot(length(offline$requests) == 0L, - identical(offline$values[c(1L, 4L)], c("FALSE", "FALSE")), - length(offline$messages) == 1L, - grepl("could not prepare optional rstudioapi support", offline$messages)) + offline <- run_mode("offline") + stopifnot( + length(offline$requests) == 0L, + identical(offline$values[c(1L, 4L)], c("FALSE", "FALSE")), + length(offline$messages) == 1L, + grepl("could not prepare optional rstudioapi support", offline$messages) + ) - # Emulation disabled: no request, no repository query, no message. - disabled <- run_mode("disabled", list(rstudioapi = "approve")) - stopifnot(length(disabled$requests) == 0L, - identical(disabled$values[c(1L, 4L, 7L)], c("FALSE", "FALSE", "FALSE")), - length(disabled$messages) == 0L) + # Emulation disabled: no request, no repository query, no message. + disabled <- run_mode("disabled", list(rstudioapi = "approve")) + stopifnot( + length(disabled$requests) == 0L, + identical(disabled$values[c(1L, 4L, 7L)], c("FALSE", "FALSE", "FALSE")), + length(disabled$messages) == 0L + ) - # Without a prompt only an existing compatible copy is used, silently and - # without contacting repositories. - no_prompt <- run_mode("no-prompt") - stopifnot(length(no_prompt$requests) == 0L, - identical(no_prompt$values[c(1L, 4L, 7L)], c("FALSE", "FALSE", "FALSE")), - length(no_prompt$messages) == 0L) - compatible <- run_mode("no-prompt-compatible") - stopifnot(length(compatible$requests) == 0L, - identical(compatible$values[c(1L, 3L, 4L, 7L)], c("TRUE", minimum_version, "TRUE", "FALSE")), - grepl("/ordinary-library/rstudioapi$", compatible$values[[2L]])) + # Without a prompt only an existing compatible copy is used, silently and + # without contacting repositories. + no_prompt <- run_mode("no-prompt") + stopifnot( + length(no_prompt$requests) == 0L, + identical(no_prompt$values[c(1L, 4L, 7L)], c("FALSE", "FALSE", "FALSE")), + length(no_prompt$messages) == 0L + ) + compatible <- run_mode("no-prompt-compatible") + stopifnot( + length(compatible$requests) == 0L, + identical(compatible$values[c(1L, 3L, 4L, 7L)], c("TRUE", minimum_version, "TRUE", "FALSE")), + grepl("/ordinary-library/rstudioapi$", compatible$values[[2L]]) + ) - # A loaded namespace is never replaced, whatever its version. - loaded <- run_mode("loaded-compatible") - stopifnot(length(loaded$requests) == 0L, - identical(loaded$values[c(1L, 3L, 7L)], c("TRUE", minimum_version, "FALSE")), - grepl("/ordinary-library/rstudioapi$", loaded$values[[2L]])) - old <- run_mode("loaded-incompatible", list(rstudioapi = "approve")) - stopifnot(length(old$requests) == 0L, - identical(old$values[c(1L, 3L, 7L)], c("TRUE", "0.3.1", "FALSE")), - grepl("/old-library/rstudioapi$", old$values[[2L]]), - length(old$messages) == 1L) + # A loaded namespace is never replaced, whatever its version. + loaded <- run_mode("loaded-compatible") + stopifnot( + length(loaded$requests) == 0L, + identical(loaded$values[c(1L, 3L, 7L)], c("TRUE", minimum_version, "FALSE")), + grepl("/ordinary-library/rstudioapi$", loaded$values[[2L]]) + ) + old <- run_mode("loaded-incompatible", list(rstudioapi = "approve")) + stopifnot( + length(old$requests) == 0L, + identical(old$values[c(1L, 3L, 7L)], c("TRUE", "0.3.1", "FALSE")), + grepl("/old-library/rstudioapi$", old$values[[2L]]), + length(old$messages) == 1L + ) - # jgd and rstudioapi in the same startup: two separate requests, each - # with its own policy, and the decision for one does not affect the other. - both <- run_mode("both", list(rstudioapi = "approve", jgd = "decline")) - summaries <- vapply(both$requests, function(request) paste(request_summary(request), collapse = " "), "") - stopifnot(identical(sort(summaries), sort(c("once rstudioapi 0.4.0", "once jgd 0.1.0"))), - identical(both$values[c(1L, 4L, 5L, 6L)], c("TRUE", "TRUE", "FALSE", "FALSE"))) - explicit <- run_mode("both-explicit", list(rstudioapi = "approve", jgd = "approve")) - summaries <- vapply(explicit$requests, function(request) paste(request_summary(request), collapse = " "), "") - stopifnot(identical(sort(summaries), sort(c("once rstudioapi 0.4.0", "always jgd 0.1.0"))), - identical(explicit$values[c(1L, 4L, 5L, 6L)], c("TRUE", "TRUE", "TRUE", "TRUE"))) + # jgd and rstudioapi in the same startup: two separate requests, each + # with its own policy, and the decision for one does not affect the other. + both <- run_mode("both", list(rstudioapi = "approve", jgd = "decline")) + summaries <- vapply( + both$requests, + function(request) paste(request_summary(request), collapse = " "), + "" + ) + stopifnot( + identical(sort(summaries), sort(c("once rstudioapi 0.4.0", "once jgd 0.1.0"))), + identical(both$values[c(1L, 4L, 5L, 6L)], c("TRUE", "TRUE", "FALSE", "FALSE")) + ) + explicit <- run_mode("both-explicit", list(rstudioapi = "approve", jgd = "approve")) + summaries <- vapply( + explicit$requests, + function(request) paste(request_summary(request), collapse = " "), + "" + ) + stopifnot( + identical(sort(summaries), sort(c("once rstudioapi 0.4.0", "always jgd 0.1.0"))), + identical(explicit$values[c(1L, 4L, 5L, 6L)], c("TRUE", "TRUE", "TRUE", "TRUE")) + ) - # Terminal startup profile: emulation setting drives preparation. - profile_run <- function(label, emulation, answer) { - profile_root <- file.path(root, label) - dir.create(profile_root) - consent <- file.path(profile_root, "consent") - dir.create(consent) - connect_log <- file.path(profile_root, "connect-log") - stub_attach <- file.path(profile_root, "attach-helper.R") - placeholder <- file.path(profile_root, "placeholder.R") - file.create(placeholder) - writeLines(c( - "source(file.path(getwd(), 'R', 'attach_sess.R'))", - "vscode_r_prepare_sess <- function(...) {", - " ns <- new.env(); ns$connect <- function(use_rstudioapi=TRUE, ...) {", - paste0(" writeLines(c(as.character(use_rstudioapi), as.character('rstudioapi' %in% loadedNamespaces())), ", - r_literal(connect_log), ")"), - " TRUE", - "}; ns }" - ), stub_attach) - startup <- file.path(profile_root, "run-profile.R") - writeLines(c( - paste0("Sys.setenv(VSCODE_R_SESS_PKG_PATH=", r_literal(profile_root), ","), - paste0(" VSCODE_R_SESS_SOURCE_HELPER=", r_literal(placeholder), ","), - paste0(" VSCODE_R_SESS_ATTACH_HELPER=", r_literal(stub_attach), ","), - paste0(" VSCODE_R_SESS_INSTALLER_HELPER=", r_literal(placeholder), ","), - paste0(" VSCODE_R_SESS_ROOT=", r_literal(profile_root), ","), - paste0(" VSCODE_R_SESS_CONSENT_DIRECTORY=", r_literal(consent), ","), - paste0(" VSCODE_R_TOOL_PREPARE_HELPER=", r_literal(file.path(getwd(), "R", "prepare-tools.R")), ","), - paste0(" VSCODE_R_TOOL_ROOT=", r_literal(file.path(profile_root, "tools")), ","), - paste0(" VSCODE_R_TOOL_CONSENT_DIRECTORY=", r_literal(consent), ","), - paste0(" VSCODE_R_TOOL_LIBRARY_HELPER=", r_literal(file.path(getwd(), "R", "tool-library.R")), ","), - paste0(" VSCODE_R_TOOL_CONSENT_HELPER=", r_literal(file.path(getwd(), "R", "tool-consent.R")), ","), - paste0(" VSCODE_R_RSTUDIOAPI_MINIMUM_VERSION=", r_literal(minimum_version), ","), - " VSCODE_R_RSTUDIOAPI_CAN_PROMPT='TRUE',", - paste0(" R_PROFILE_USER_OLD=", r_literal(placeholder), ","), - paste0(" SESS_PLOT_BACKEND='standard', SESS_RSTUDIOAPI='", emulation, "')"), - paste0("options(repos=c(CRAN=", r_literal(repo), "), pkgType='source')"), - "source(file.path(getwd(), 'R', 'profile.R'))" - ), startup) - logs <- file.path(profile_root, c("stdout", "stderr")) - system2_with_child_environment(isolated_child_env(label), r_binary, - shQuote(c("--vanilla", "--slave", paste0("--file=", startup))), - wait = FALSE, stdout = logs[[1L]], stderr = logs[[2L]]) - requests <- serve(consent, connect_log, list(rstudioapi = answer), logs) - list(values = readLines(connect_log, warn = FALSE), requests = requests) - } - enabled <- profile_run("profile-enabled", "TRUE", "approve") - stopifnot(length(enabled$requests) == 1L, - identical(request_summary(enabled$requests[[1L]]), c("once", "rstudioapi", minimum_version)), - identical(enabled$values, c("TRUE", "TRUE"))) - suppressed <- profile_run("profile-disabled", "FALSE", "approve") - stopifnot(length(suppressed$requests) == 0L, identical(suppressed$values, c("FALSE", "FALSE"))) + # Terminal startup profile: emulation setting drives preparation. + profile_run <- function(label, emulation, answer) { + profile_root <- file.path(root, label) + dir.create(profile_root) + consent <- file.path(profile_root, "consent") + dir.create(consent) + connect_log <- file.path(profile_root, "connect-log") + stub_attach <- file.path(profile_root, "attach-helper.R") + placeholder <- file.path(profile_root, "placeholder.R") + file.create(placeholder) + writeLines( + c( + "source(file.path(getwd(), 'R', 'attach_sess.R'))", + "vscode_r_prepare_sess <- function(...) {", + " ns <- new.env(); ns$connect <- function(use_rstudioapi=TRUE, ...) {", + paste0( + " writeLines(c(as.character(use_rstudioapi), as.character('rstudioapi' %in% loadedNamespaces())), ", + r_literal(connect_log), + ")" + ), + " TRUE", + "}; ns }" + ), + stub_attach + ) + startup <- file.path(profile_root, "run-profile.R") + writeLines( + c( + paste0("Sys.setenv(VSCODE_R_SESS_PKG_PATH=", r_literal(profile_root), ","), + paste0(" VSCODE_R_SESS_SOURCE_HELPER=", r_literal(placeholder), ","), + paste0(" VSCODE_R_SESS_ATTACH_HELPER=", r_literal(stub_attach), ","), + paste0(" VSCODE_R_SESS_INSTALLER_HELPER=", r_literal(placeholder), ","), + paste0(" VSCODE_R_SESS_ROOT=", r_literal(profile_root), ","), + paste0(" VSCODE_R_SESS_CONSENT_DIRECTORY=", r_literal(consent), ","), + paste0( + " VSCODE_R_TOOL_PREPARE_HELPER=", + r_literal(file.path(getwd(), "R", "prepare-tools.R")), + "," + ), + paste0(" VSCODE_R_TOOL_ROOT=", r_literal(file.path(profile_root, "tools")), ","), + paste0(" VSCODE_R_TOOL_CONSENT_DIRECTORY=", r_literal(consent), ","), + paste0( + " VSCODE_R_TOOL_LIBRARY_HELPER=", + r_literal(file.path(getwd(), "R", "tool-library.R")), + "," + ), + paste0( + " VSCODE_R_TOOL_CONSENT_HELPER=", + r_literal(file.path(getwd(), "R", "tool-consent.R")), + "," + ), + paste0(" VSCODE_R_RSTUDIOAPI_MINIMUM_VERSION=", r_literal(minimum_version), ","), + " VSCODE_R_RSTUDIOAPI_CAN_PROMPT='TRUE',", + paste0(" R_PROFILE_USER_OLD=", r_literal(placeholder), ","), + paste0(" SESS_PLOT_BACKEND='standard', SESS_RSTUDIOAPI='", emulation, "')"), + paste0("options(repos=c(CRAN=", r_literal(repo), "), pkgType='source')"), + "source(file.path(getwd(), 'R', 'profile.R'))" + ), + startup + ) + logs <- file.path(profile_root, c("stdout", "stderr")) + system2_with_child_environment( + isolated_child_env(label), + r_binary, + shQuote(c("--vanilla", "--slave", paste0("--file=", startup))), + wait = FALSE, + stdout = logs[[1L]], + stderr = logs[[2L]] + ) + requests <- serve(consent, connect_log, list(rstudioapi = answer), logs) + list(values = readLines(connect_log, warn = FALSE), requests = requests) + } + enabled <- profile_run("profile-enabled", "TRUE", "approve") + stopifnot( + length(enabled$requests) == 1L, + identical(request_summary(enabled$requests[[1L]]), c("once", "rstudioapi", minimum_version)), + identical(enabled$values, c("TRUE", "TRUE")) + ) + suppressed <- profile_run("profile-disabled", "FALSE", "approve") + stopifnot(length(suppressed$requests) == 0L, identical(suppressed$values, c("FALSE", "FALSE"))) - cat("rstudioapi preparation integration tests passed\n") + cat("rstudioapi preparation integration tests passed\n") }) diff --git a/R/tests/sess_source.R b/R/tests/sess_source.R index 54be57c24..de3000647 100644 --- a/R/tests/sess_source.R +++ b/R/tests/sess_source.R @@ -10,11 +10,15 @@ dir.create(root) on.exit(unlink(root, recursive = TRUE), add = TRUE) write_description <- function(pkg, version, revision = NULL, imports = NULL) { - dir.create(pkg, recursive = TRUE, showWarnings = FALSE) - lines <- c("Package: sess", paste0("Version: ", version)) - if (!is.null(revision)) lines <- c(lines, paste0(field, ": ", revision)) - if (!is.null(imports)) lines <- c(lines, paste0("Imports: ", imports)) - writeLines(lines, file.path(pkg, "DESCRIPTION")) + dir.create(pkg, recursive = TRUE, showWarnings = FALSE) + lines <- c("Package: sess", paste0("Version: ", version)) + if (!is.null(revision)) { + lines <- c(lines, paste0(field, ": ", revision)) + } + if (!is.null(imports)) { + lines <- c(lines, paste0("Imports: ", imports)) + } + writeLines(lines, file.path(pkg, "DESCRIPTION")) } # Installed metadata is read from library directories without loading sess. @@ -32,10 +36,14 @@ original_libs <- .libPaths() on.exit(.libPaths(original_libs), add = TRUE) .libPaths(c(project_library, user_library, original_libs)) stopifnot(!sess_install_required(bundled)) # Exact revision in any normal library wins. -stopifnot(identical(normalized_paths(sess_find_source_library(stable)), - normalized_paths(user_library))) -stopifnot(identical(normalized_paths(.libPaths()[1:2]), - normalized_paths(c(project_library, user_library)))) +stopifnot(identical( + normalized_paths(sess_find_source_library(stable)), + normalized_paths(user_library) +)) +stopifnot(identical( + normalized_paths(.libPaths()[1:2]), + normalized_paths(c(project_library, user_library)) +)) write_description(file.path(user_library, "sess"), "99.0.0", pre_release) stopifnot(sess_install_required(bundled)) # Mismatch does not count as bundled source. @@ -50,8 +58,8 @@ stopifnot(sess_install_required(bundled)) # Stable/pre-release revisions differ write_description(file.path(user_library, "sess"), "99.0.0", pre_release) stopifnot(!sess_install_required(bundled)) # Version is independent of source identity. for (invalid in c("", "unknown", "git-tree:123")) { - write_description(file.path(user_library, "sess"), "99.0.0", invalid) - stopifnot(sess_install_required(bundled)) + write_description(file.path(user_library, "sess"), "99.0.0", invalid) + stopifnot(sess_install_required(bundled)) } write_description(bundled, "3.0.2") stopifnot(inherits(tryCatch(sess_install_required(bundled), error = identity), "error")) @@ -65,8 +73,10 @@ runtime_version <- paste(R.version$major, minor, sep = ".") expected_identity <- paste(R.version$platform, runtime_version, sep = "|") stopifnot(identical(identity, expected_identity)) managed_library <- sess_managed_library(managed_root, stable) -stopifnot(identical(managed_library, file.path(managed_root, R.version$platform, - runtime_version, strrep("a", 40), "library"))) +stopifnot(identical( + managed_library, + file.path(managed_root, R.version$platform, runtime_version, strrep("a", 40), "library") +)) stopifnot(!identical(managed_library, sess_managed_library(managed_root, pre_release))) # Install a dependency-free fixture into the managed library, then verify that @@ -76,7 +86,8 @@ pkg <- file.path(extension, "dist", "resources", "sess") dir.create(file.path(pkg, "R"), recursive = TRUE) dependency <- file.path(root, "sessfixturedep") dir.create(file.path(dependency, "R"), recursive = TRUE) -writeLines(c( +writeLines( + c( "Package: sessfixturedep", "Version: 1.0.0", "Title: Source Identity Dependency Test", @@ -84,32 +95,49 @@ writeLines(c( "License: MIT", "Author: Test Author", "Maintainer: Test Author " -), file.path(dependency, "DESCRIPTION")) -writeLines("fixture_value <- function() 'normal-library-dependency'", file.path(dependency, "R", "api.R")) + ), + file.path(dependency, "DESCRIPTION") +) +writeLines( + "fixture_value <- function() 'normal-library-dependency'", + file.path(dependency, "R", "api.R") +) writeLines("export(fixture_value)", file.path(dependency, "NAMESPACE")) -utils::install.packages(dependency, repos = NULL, type = "source", lib = user_library, - quiet = TRUE) +utils::install.packages(dependency, repos = NULL, type = "source", lib = user_library, quiet = TRUE) write_description(pkg, "3.0.1", stable, imports = "sessfixturedep") -cat(paste0( +cat( + paste0( "Title: Source Identity Test\n", "Description: A dependency-free installation fixture.\n", "License: MIT\n", "Author: Test Author\n", "Maintainer: Test Author \n" -), file = file.path(pkg, "DESCRIPTION"), append = TRUE) -writeLines(c( + ), + file = file.path(pkg, "DESCRIPTION"), + append = TRUE +) +writeLines( + c( "connect <- function(...) sessfixturedep::fixture_value()", "notify_client <- function(...) NULL", "request_client <- function(...) NULL" -), file.path(pkg, "R", "api.R")) -writeLines(c("export(connect)", "export(notify_client)", "export(request_client)", - "importFrom(sessfixturedep,fixture_value)"), - file.path(pkg, "NAMESPACE")) + ), + file.path(pkg, "R", "api.R") +) +writeLines( + c( + "export(connect)", + "export(notify_client)", + "export(request_client)", + "importFrom(sessfixturedep,fixture_value)" + ), + file.path(pkg, "NAMESPACE") +) install_sess_script <- file.path(extension, "R", "install_sess.R") dir.create(dirname(install_sess_script), recursive = TRUE) for (script in c("install_sess.R", "sess_source.R", "sess-package-install.R")) { - stopifnot(file.copy(file.path("R", script), file.path(dirname(install_sess_script), script))) + stopifnot(file.copy(file.path("R", script), file.path(dirname(install_sess_script), script))) } ordinary_before <- .libPaths() @@ -120,25 +148,51 @@ r_binary <- file.path(R.home("bin"), if (.Platform$OS.type == "windows") "R.exe" stopifnot(sess_install_required(bundled)) existing_user_sess <- readLines(file.path(user_library, "sess", "DESCRIPTION")) Sys.unsetenv("VSCODE_R_SESS_LIBRARY") -refusal <- suppressWarnings(system2(r_binary, shQuote(c( - "--vanilla", "--silent", "--no-echo", "--no-save", "--no-restore", - paste0("--file=", install_sess_script), "--args", pkg, "https://example.com" -)), stdout = TRUE, stderr = TRUE)) +refusal <- suppressWarnings(system2( + r_binary, + shQuote(c( + "--vanilla", + "--silent", + "--no-echo", + "--no-save", + "--no-restore", + paste0("--file=", install_sess_script), + "--args", + pkg, + "https://example.com" + )), + stdout = TRUE, + stderr = TRUE +)) stopifnot(!is.null(attr(refusal, "status")), attr(refusal, "status") != 0L) stopifnot(identical(readLines(file.path(user_library, "sess", "DESCRIPTION")), existing_user_sess)) stopifnot(!dir.exists(inherited_library)) -Sys.setenv(VSCODE_R_SESS_PKG_PATH = pkg, - VSCODE_R_SESS_REPO = "https://example.com", - VSCODE_R_SESS_LIBRARY = inherited_library, - VSCODE_R_SESS_INTERACTIVE = "0") -output <- suppressWarnings(system2(r_binary, shQuote(c( - "--vanilla", "--silent", "--no-echo", "--no-save", "--no-restore", - paste0("--file=", install_sess_script), "--args", pkg, - "https://example.com", managed_library -)), stdout = TRUE, stderr = TRUE)) +Sys.setenv( + VSCODE_R_SESS_PKG_PATH = pkg, + VSCODE_R_SESS_REPO = "https://example.com", + VSCODE_R_SESS_LIBRARY = inherited_library, + VSCODE_R_SESS_INTERACTIVE = "0" +) +output <- suppressWarnings(system2( + r_binary, + shQuote(c( + "--vanilla", + "--silent", + "--no-echo", + "--no-save", + "--no-restore", + paste0("--file=", install_sess_script), + "--args", + pkg, + "https://example.com", + managed_library + )), + stdout = TRUE, + stderr = TRUE +)) if (!is.null(attr(output, "status")) && attr(output, "status") != 0L) { - stop(paste(output, collapse = "\n")) + stop(paste(output, collapse = "\n")) } stopifnot(file.exists(file.path(managed_library, "sess", "DESCRIPTION"))) stopifnot(!dir.exists(file.path(managed_library, "sessfixturedep"))) @@ -154,7 +208,8 @@ write_description(pkg, "3.0.1", stable, imports = "sessfixturedep") child <- file.path(root, "check-loaded-mismatch.R") profile_consent <- file.path(root, "profile consent") dir.create(profile_consent) -writeLines(c( +writeLines( + c( "args <- commandArgs(TRUE)", "source(args[1])", "normal <- strsplit(args[5], .Platform$path.sep, fixed=TRUE)[[1]]", @@ -163,28 +218,52 @@ writeLines(c( "expected <- args[3]; mismatch <- args[4]", "err <- tryCatch(sess_load_namespace(args[2], expected, normal), error=identity)", "stopifnot(inherits(err, 'error'), identical(sess_loaded_source_revision(), mismatch))", - paste0("Sys.setenv(VSCODE_R_SESS_PKG_PATH=args[6], ", - "VSCODE_R_SESS_SOURCE_HELPER=args[1], ", - "VSCODE_R_SESS_ATTACH_HELPER=file.path(dirname(args[1]), 'attach_sess.R'), ", - "VSCODE_R_SESS_INSTALLER_HELPER=file.path(dirname(args[1]), 'sess-package-install.R'), ", - "VSCODE_R_SESS_ROOT=args[7], VSCODE_R_SESS_CONSENT_DIRECTORY=args[9])"), + paste0( + "Sys.setenv(VSCODE_R_SESS_PKG_PATH=args[6], ", + "VSCODE_R_SESS_SOURCE_HELPER=args[1], ", + "VSCODE_R_SESS_ATTACH_HELPER=file.path(dirname(args[1]), 'attach_sess.R'), ", + "VSCODE_R_SESS_INSTALLER_HELPER=file.path(dirname(args[1]), 'sess-package-install.R'), ", + "VSCODE_R_SESS_ROOT=args[7], VSCODE_R_SESS_CONSENT_DIRECTORY=args[9])" + ), "messages <- character()", - paste0("withCallingHandlers(source(args[8]), message=function(m) { ", - "messages <<- c(messages, conditionMessage(m)); invokeRestart('muffleMessage') })"), - paste0("stopifnot(any(grepl('different sess namespace is already loaded', messages)), ", - "identical(sess_loaded_source_revision(), mismatch))"), + paste0( + "withCallingHandlers(source(args[8]), message=function(m) { ", + "messages <<- c(messages, conditionMessage(m)); invokeRestart('muffleMessage') })" + ), + paste0( + "stopifnot(any(grepl('different sess namespace is already loaded', messages)), ", + "identical(sess_loaded_source_revision(), mismatch))" + ), "stopifnot(identical(normalizePath(.libPaths(), winslash='/'), normalizePath(normal, winslash='/')))" -), child) + ), + child +) profile <- file.path("R", "profile.R") -child_output <- suppressWarnings(system2(r_binary, shQuote(c( - "--vanilla", "--silent", "--no-echo", "--no-save", "--no-restore", - paste0("--file=", child), "--args", - file.path(getwd(), "R", "sess_source.R"), managed_library, stable, pre_release, - paste(ordinary_before, collapse = .Platform$path.sep), pkg, managed_root, - file.path(getwd(), profile), profile_consent -)), stdout = TRUE, stderr = TRUE)) +child_output <- suppressWarnings(system2( + r_binary, + shQuote(c( + "--vanilla", + "--silent", + "--no-echo", + "--no-save", + "--no-restore", + paste0("--file=", child), + "--args", + file.path(getwd(), "R", "sess_source.R"), + managed_library, + stable, + pre_release, + paste(ordinary_before, collapse = .Platform$path.sep), + pkg, + managed_root, + file.path(getwd(), profile), + profile_consent + )), + stdout = TRUE, + stderr = TRUE +)) if (!is.null(attr(child_output, "status")) && attr(child_output, "status") != 0L) { - stop(paste(child_output, collapse = "\n")) + stop(paste(child_output, collapse = "\n")) } # Metadata queries and explicit load target the intended copy. The package is @@ -202,49 +281,84 @@ stopifnot(identical(normalized_paths(.libPaths()), normalized_paths(ordinary_bef # The private Interactive runtime installs rstudioapi beside sess, which only # suggests it. Ordinary installations must not request it. local({ - package <- file.path(root, "installer-dependencies", "sess") - dir.create(package, recursive = TRUE) - writeLines(c("Package: sess", "Version: 1.0.0", "Imports: sessfixturedep", - "Config/vscode-R/source-revision: fixture"), - file.path(package, "DESCRIPTION")) - target <- file.path(root, "installer-dependencies", "library") - isolated <- file.path(root, "installer-dependencies", "empty") - for (directory in c(target, isolated)) dir.create(directory) - child <- file.path(root, "installer-dependencies.R") - writeLines(c( - "args <- commandArgs(TRUE)", - "installer <- new.env(parent = baseenv())", - "sys.source(args[[1L]], installer)", - "installer$sess_install_dependencies <- function(packages, ...) requested <<- packages", - "installer$sess_install_command <- function(...) TRUE", - "installer$sess_verify_package <- function(...) invisible(TRUE)", - "for (interactive in c(TRUE, FALSE)) {", - " requested <- character()", - " installer$sess_install(args[[2L]], args[[3L]], 'https://example.com',", - " interactive = interactive)", - " cat('requested', interactive, paste(requested, collapse = ','), '\\n', sep = ';')", - "}" - ), child) - keys <- c("R_LIBS", "R_LIBS_USER", "R_LIBS_SITE") - previous <- Sys.getenv(keys, unset = NA_character_) - on.exit({ - Sys.unsetenv(keys[is.na(previous)]) - if (any(!is.na(previous))) do.call(Sys.setenv, as.list(previous[!is.na(previous)])) - }, add = TRUE) - Sys.setenv(R_LIBS = "", R_LIBS_USER = isolated, R_LIBS_SITE = isolated) - output <- system2(r_binary, shQuote(c( - "--vanilla", "--silent", "--no-echo", "--no-save", "--no-restore", - paste0("--file=", child), "--args", - file.path(getwd(), "R", "sess-package-install.R"), package, target - )), stdout = TRUE, stderr = TRUE) - stopifnot(is.null(attr(output, "status"))) - stopifnot(identical(grep("^requested;", output, value = TRUE), - c("requested;TRUE;sessfixturedep,rstudioapi;", - "requested;FALSE;sessfixturedep;"))) + package <- file.path(root, "installer-dependencies", "sess") + dir.create(package, recursive = TRUE) + writeLines( + c( + "Package: sess", + "Version: 1.0.0", + "Imports: sessfixturedep", + "Config/vscode-R/source-revision: fixture" + ), + file.path(package, "DESCRIPTION") + ) + target <- file.path(root, "installer-dependencies", "library") + isolated <- file.path(root, "installer-dependencies", "empty") + for (directory in c(target, isolated)) { + dir.create(directory) + } + child <- file.path(root, "installer-dependencies.R") + writeLines( + c( + "args <- commandArgs(TRUE)", + "installer <- new.env(parent = baseenv())", + "sys.source(args[[1L]], installer)", + "installer$sess_install_dependencies <- function(packages, ...) requested <<- packages", + "installer$sess_install_command <- function(...) TRUE", + "installer$sess_verify_package <- function(...) invisible(TRUE)", + "for (interactive in c(TRUE, FALSE)) {", + " requested <- character()", + " installer$sess_install(args[[2L]], args[[3L]], 'https://example.com',", + " interactive = interactive)", + " cat('requested', interactive, paste(requested, collapse = ','), '\\n', sep = ';')", + "}" + ), + child + ) + keys <- c("R_LIBS", "R_LIBS_USER", "R_LIBS_SITE") + previous <- Sys.getenv(keys, unset = NA_character_) + on.exit( + { + Sys.unsetenv(keys[is.na(previous)]) + if (any(!is.na(previous))) do.call(Sys.setenv, as.list(previous[!is.na(previous)])) + }, + add = TRUE + ) + Sys.setenv(R_LIBS = "", R_LIBS_USER = isolated, R_LIBS_SITE = isolated) + output <- system2( + r_binary, + shQuote(c( + "--vanilla", + "--silent", + "--no-echo", + "--no-save", + "--no-restore", + paste0("--file=", child), + "--args", + file.path(getwd(), "R", "sess-package-install.R"), + package, + target + )), + stdout = TRUE, + stderr = TRUE + ) + stopifnot(is.null(attr(output, "status"))) + stopifnot(identical( + grep("^requested;", output, value = TRUE), + c("requested;TRUE;sessfixturedep,rstudioapi;", "requested;FALSE;sessfixturedep;") + )) }) -Sys.unsetenv(c("VSCODE_R_SESS_PKG_PATH", "VSCODE_R_SESS_REPO", - "VSCODE_R_SESS_LIBRARY", "VSCODE_R_SESS_INTERACTIVE")) -if (is.na(previous_r_libs)) Sys.unsetenv("R_LIBS") else Sys.setenv(R_LIBS = previous_r_libs) +Sys.unsetenv(c( + "VSCODE_R_SESS_PKG_PATH", + "VSCODE_R_SESS_REPO", + "VSCODE_R_SESS_LIBRARY", + "VSCODE_R_SESS_INTERACTIVE" +)) +if (is.na(previous_r_libs)) { + Sys.unsetenv("R_LIBS") +} else { + Sys.setenv(R_LIBS = previous_r_libs) +} unlink(root, recursive = TRUE) cat("sess source identity and managed installer tests passed\n") diff --git a/R/tests/tool-consent.R b/R/tests/tool-consent.R index 364ff439b..4c46261c8 100644 --- a/R/tests/tool-consent.R +++ b/R/tests/tool-consent.R @@ -3,140 +3,178 @@ source("R/tool-library.R") source("R/tool-consent.R") local({ - root <- tempfile("tool-consent-") - dir.create(root) - root <- normalizePath(root, winslash = "/", mustWork = TRUE) - on.exit(unlink(root, recursive = TRUE), add = TRUE) - library <- tool_library_path(root) - repository <- "https://example.invalid/src/contrib" - available <- matrix( - c("jgd", "0.1.0", "", "yes", repository), - nrow = 1L, - dimnames = list("jgd", c("Package", "Version", "Imports", "NeedsCompilation", "Repository")) - ) - plan <- structure( - list( - package = "jgd", - minimum_version = "0.1.0", - version = "0.1.0", - repository = repository, - package_type = "source", - source_build = TRUE, - repositories = "https://example.invalid", - available = available, - root = root, - library = library - ), - class = "vscode_r_tool_install_plan" - ) + root <- tempfile("tool-consent-") + dir.create(root) + root <- normalizePath(root, winslash = "/", mustWork = TRUE) + on.exit(unlink(root, recursive = TRUE), add = TRUE) + library <- tool_library_path(root) + repository <- "https://example.invalid/src/contrib" + available <- matrix( + c("jgd", "0.1.0", "", "yes", repository), + nrow = 1L, + dimnames = list("jgd", c("Package", "Version", "Imports", "NeedsCompilation", "Repository")) + ) + plan <- structure( + list( + package = "jgd", + minimum_version = "0.1.0", + version = "0.1.0", + repository = repository, + package_type = "source", + source_build = TRUE, + repositories = "https://example.invalid", + available = available, + root = root, + library = library + ), + class = "vscode_r_tool_install_plan" + ) - lines <- .tool_consent_lines(plan, strrep("a", 32L), "always") - stopifnot(length(lines) == 11L) - stopifnot(identical(lines[c(1L, 2L, 4L, 5L)], - c("vscode-r-package-consent-v1", strrep("a", 32L), "always", "1"))) - stopifnot(identical(lines[6:11], - c("jgd", "0.1.0", "0.1.0", repository, "source", "yes"))) - invalid <- plan - invalid$repository <- paste0(repository, "\nother.example") - stopifnot(inherits(tryCatch(.tool_consent_lines(invalid, strrep("b", 32L), "once"), - error = identity), "error")) + lines <- .tool_consent_lines(plan, strrep("a", 32L), "always") + stopifnot(length(lines) == 11L) + stopifnot(identical( + lines[c(1L, 2L, 4L, 5L)], + c("vscode-r-package-consent-v1", strrep("a", 32L), "always", "1") + )) + stopifnot(identical(lines[6:11], c("jgd", "0.1.0", "0.1.0", repository, "source", "yes"))) + invalid <- plan + invalid$repository <- paste0(repository, "\nother.example") + stopifnot(inherits( + tryCatch(.tool_consent_lines(invalid, strrep("b", 32L), "once"), error = identity), + "error" + )) - directory <- file.path(root, "consent") - dir.create(directory) - approval <- .tool_publish_consent_request(plan, strrep("c", 32L), "once", directory) - stopifnot(identical(readLines(approval$request_path), - .tool_consent_lines(plan, strrep("c", 32L), "once"))) - stopifnot(inherits(tryCatch(.tool_publish_consent_request(plan, strrep("c", 32L), - "once", directory), - error = identity), "error")) - writeLines("approve", approval$response_path) - stopifnot(isTRUE(.tool_wait_for_consent(approval, timeout_seconds = 0))) - stopifnot(!file.exists(approval$request_path), !file.exists(approval$response_path)) + directory <- file.path(root, "consent") + dir.create(directory) + approval <- .tool_publish_consent_request(plan, strrep("c", 32L), "once", directory) + stopifnot(identical( + readLines(approval$request_path), + .tool_consent_lines(plan, strrep("c", 32L), "once") + )) + stopifnot(inherits( + tryCatch( + .tool_publish_consent_request(plan, strrep("c", 32L), "once", directory), + error = identity + ), + "error" + )) + writeLines("approve", approval$response_path) + stopifnot(isTRUE(.tool_wait_for_consent(approval, timeout_seconds = 0))) + stopifnot(!file.exists(approval$request_path), !file.exists(approval$response_path)) - changed <- .tool_publish_consent_request(plan, strrep("d", 32L), "once", directory) - changed_lines <- changed$lines - changed_lines[8L] <- "0.2.0" - writeLines(changed_lines, changed$request_path) - writeLines("approve", changed$response_path) - stopifnot(!.tool_wait_for_consent(changed, timeout_seconds = 0)) - stopifnot(!file.exists(changed$request_path), !file.exists(changed$response_path)) + changed <- .tool_publish_consent_request(plan, strrep("d", 32L), "once", directory) + changed_lines <- changed$lines + changed_lines[8L] <- "0.2.0" + writeLines(changed_lines, changed$request_path) + writeLines("approve", changed$response_path) + stopifnot(!.tool_wait_for_consent(changed, timeout_seconds = 0)) + stopifnot(!file.exists(changed$request_path), !file.exists(changed$response_path)) - declined <- .tool_publish_consent_request(plan, strrep("e", 32L), "always", directory) - writeLines("decline", declined$response_path) - stopifnot(!.tool_wait_for_consent(declined, timeout_seconds = 0)) - stopifnot(!file.exists(declined$request_path), !file.exists(declined$response_path)) + declined <- .tool_publish_consent_request(plan, strrep("e", 32L), "always", directory) + writeLines("decline", declined$response_path) + stopifnot(!.tool_wait_for_consent(declined, timeout_seconds = 0)) + stopifnot(!file.exists(declined$request_path), !file.exists(declined$response_path)) - stopifnot(!.tool_request_consent(plan, "once", directory, timeout_seconds = 0)) - stopifnot(length(list.files(directory)) == 0L) + stopifnot(!.tool_request_consent(plan, "once", directory, timeout_seconds = 0)) + stopifnot(length(list.files(directory)) == 0L) - unavailable <- .tool_publish_consent_request(plan, strrep("f", 32L), "once", directory) - stopifnot(!.tool_wait_for_consent(unavailable, timeout_seconds = 0)) - stopifnot(!file.exists(unavailable$request_path), !file.exists(unavailable$response_path)) - invalid_timeout <- .tool_publish_consent_request(plan, strrep("0", 32L), "once", directory) - stopifnot(inherits(tryCatch(.tool_wait_for_consent(invalid_timeout, timeout_seconds = -1), - error = identity), "error")) - stopifnot(!file.exists(invalid_timeout$request_path), !file.exists(invalid_timeout$response_path)) + unavailable <- .tool_publish_consent_request(plan, strrep("f", 32L), "once", directory) + stopifnot(!.tool_wait_for_consent(unavailable, timeout_seconds = 0)) + stopifnot(!file.exists(unavailable$request_path), !file.exists(unavailable$response_path)) + invalid_timeout <- .tool_publish_consent_request(plan, strrep("0", 32L), "once", directory) + stopifnot(inherits( + tryCatch(.tool_wait_for_consent(invalid_timeout, timeout_seconds = -1), error = identity), + "error" + )) + stopifnot(!file.exists(invalid_timeout$request_path), !file.exists(invalid_timeout$response_path)) - prompt_calls <- 0L - install_calls <- 0L - permission <- FALSE - ready <- FALSE - prepare_environment <- new.env(parent = environment(tool_library_prepare)) - prepare_environment$tool_library_check <- function(...) { - list(package = "jgd", version = if (ready) "1.0.0" else NULL, - source = if (ready) "managed" else "install", - install_required = !ready, library = library) - } - prepare_environment$tool_library_plan <- function(...) if (ready) NULL else plan - prepare_environment$.tool_request_consent <- function(received, policy, directory, - timeout_seconds) { - prompt_calls <<- prompt_calls + 1L - stopifnot(identical(received, plan), policy %in% c("always", "once"), - identical(directory, "consent")) - permission - } - prepare_environment$tool_library_install <- function(package, minimum_version, root, - repos, timeout_seconds, plan) { - install_calls <<- install_calls + 1L - stopifnot(identical(plan, received_plan), identical(repos, plan$repositories)) - list(package = package, version = plan$version, source = "managed", - install_required = FALSE, library = plan$library) - } - received_plan <- plan - prepare <- tool_library_prepare - environment(prepare) <- prepare_environment - stopifnot(is.null(prepare("jgd", "0.1.0", root, "consent", "once", repos = character()))) - stopifnot(prompt_calls == 1L, install_calls == 0L) - permission <- FALSE - stopifnot(is.null(prepare("jgd", "0.1.0", root, "consent", "always", repos = character()))) - stopifnot(prompt_calls == 2L, install_calls == 0L) - permission <- TRUE - prepare("jgd", "0.1.0", root, "consent", "once", repos = character()) - stopifnot(prompt_calls == 3L, install_calls == 1L) - ready <- TRUE - prepare("jgd", "0.1.0", root, "consent", "once", repos = character()) - stopifnot(prompt_calls == 3L, install_calls == 1L) + prompt_calls <- 0L + install_calls <- 0L + permission <- FALSE + ready <- FALSE + prepare_environment <- new.env(parent = environment(tool_library_prepare)) + prepare_environment$tool_library_check <- function(...) { + list( + package = "jgd", + version = if (ready) "1.0.0" else NULL, + source = if (ready) "managed" else "install", + install_required = !ready, + library = library + ) + } + prepare_environment$tool_library_plan <- function(...) if (ready) NULL else plan + prepare_environment$.tool_request_consent <- function( + received, + policy, + directory, + timeout_seconds + ) { + prompt_calls <<- prompt_calls + 1L + stopifnot( + identical(received, plan), + policy %in% c("always", "once"), + identical(directory, "consent") + ) + permission + } + prepare_environment$tool_library_install <- function( + package, + minimum_version, + root, + repos, + timeout_seconds, + plan + ) { + install_calls <<- install_calls + 1L + stopifnot(identical(plan, received_plan), identical(repos, plan$repositories)) + list( + package = package, + version = plan$version, + source = "managed", + install_required = FALSE, + library = plan$library + ) + } + received_plan <- plan + prepare <- tool_library_prepare + environment(prepare) <- prepare_environment + stopifnot(is.null(prepare("jgd", "0.1.0", root, "consent", "once", repos = character()))) + stopifnot(prompt_calls == 1L, install_calls == 0L) + permission <- FALSE + stopifnot(is.null(prepare("jgd", "0.1.0", root, "consent", "always", repos = character()))) + stopifnot(prompt_calls == 2L, install_calls == 0L) + permission <- TRUE + prepare("jgd", "0.1.0", root, "consent", "once", repos = character()) + stopifnot(prompt_calls == 3L, install_calls == 1L) + ready <- TRUE + prepare("jgd", "0.1.0", root, "consent", "once", repos = character()) + stopifnot(prompt_calls == 3L, install_calls == 1L) - # Exercise prepare through its real file request and response path. - ready <- FALSE - consent_directory <- file.path(root, "prepare consent") - dir.create(consent_directory) - original_wait <- .tool_wait_for_consent - prepare_environment$.tool_request_consent <- function(received, policy, - directory, timeout_seconds) { - request <- .tool_publish_consent_request(received, strrep("1", 32L), - policy, directory) - prepare_environment$.tool_wait_for_consent(request, timeout_seconds) - } - prepare_environment$.tool_wait_for_consent <- function(request, timeout_seconds) { - writeLines("approve", request$response_path) - original_wait(request, timeout_seconds = 0) - } - prepared <- prepare("jgd", "0.1.0", root, consent_directory, "always", - repos = character()) - stopifnot(identical(prepared$version, plan$version), - prompt_calls == 3L, install_calls == 2L, - length(list.files(consent_directory)) == 0L) + # Exercise prepare through its real file request and response path. + ready <- FALSE + consent_directory <- file.path(root, "prepare consent") + dir.create(consent_directory) + original_wait <- .tool_wait_for_consent + prepare_environment$.tool_request_consent <- function( + received, + policy, + directory, + timeout_seconds + ) { + request <- .tool_publish_consent_request(received, strrep("1", 32L), policy, directory) + prepare_environment$.tool_wait_for_consent(request, timeout_seconds) + } + prepare_environment$.tool_wait_for_consent <- function(request, timeout_seconds) { + writeLines("approve", request$response_path) + original_wait(request, timeout_seconds = 0) + } + prepared <- prepare("jgd", "0.1.0", root, consent_directory, "always", repos = character()) + stopifnot( + identical(prepared$version, plan$version), + prompt_calls == 3L, + install_calls == 2L, + length(list.files(consent_directory)) == 0L + ) - cat("managed tool consent tests passed\n") + cat("managed tool consent tests passed\n") }) diff --git a/R/tests/tool-library.R b/R/tests/tool-library.R index 3b9345c17..34c61bebe 100644 --- a/R/tests/tool-library.R +++ b/R/tests/tool-library.R @@ -3,203 +3,288 @@ source("R/tool-library.R") source("R/tool-consent.R") local({ - root <- tempfile("tool-library-") - dir.create(root) - root <- normalizePath(root, winslash = "/", mustWork = TRUE) - on.exit(unlink(root, recursive = TRUE), add = TRUE) - original_paths <- .libPaths() - on.exit(.libPaths(original_paths), add = TRUE) + root <- tempfile("tool-library-") + dir.create(root) + root <- normalizePath(root, winslash = "/", mustWork = TRUE) + on.exit(unlink(root, recursive = TRUE), add = TRUE) + original_paths <- .libPaths() + on.exit(.libPaths(original_paths), add = TRUE) - write_package <- function(package, version, imports = NULL) { - directory <- file.path(root, "source", package) - dir.create(file.path(directory, "R"), recursive = TRUE, showWarnings = FALSE) - fields <- c(paste0("Package: ", package), paste0("Version: ", version), - paste0("Title: ", package, " fixture"), - paste0("Description: Local test package for ", package, "."), - "License: MIT", "Author: Test Author", - "Maintainer: Test Author ", "Encoding: UTF-8") - if (!is.null(imports)) fields <- c(fields, paste0("Imports: ", imports)) - writeLines(fields, file.path(directory, "DESCRIPTION")) - writeLines("fixture_value <- function() 'managed'", file.path(directory, "R", "api.R")) - writeLines("export(fixture_value)", file.path(directory, "NAMESPACE")) - archive <- file.path(root, "repo", "src", "contrib") - dir.create(archive, recursive = TRUE, showWarnings = FALSE) - unlink(list.files(archive, pattern = paste0("^", package, "_.*\\.tar\\.gz$"), full.names = TRUE)) - previous <- setwd(dirname(directory)) - on.exit(setwd(previous), add = TRUE) - result <- system2(file.path(R.home("bin"), "R"), - c("CMD", "build", "--no-build-vignettes", shQuote(basename(directory))), - stdout = TRUE, stderr = TRUE) - status <- attr(result, "status") - if (!is.null(status) && status != 0L) stop(paste(result, collapse = "\n")) - built <- list.files(".", pattern = "\\.tar\\.gz$", full.names = TRUE) - stopifnot(length(built) == 1L) - stopifnot(file.copy(built, archive)) - unlink(built) - setwd(previous) - invisible(directory) + write_package <- function(package, version, imports = NULL) { + directory <- file.path(root, "source", package) + dir.create(file.path(directory, "R"), recursive = TRUE, showWarnings = FALSE) + fields <- c( + paste0("Package: ", package), + paste0("Version: ", version), + paste0("Title: ", package, " fixture"), + paste0("Description: Local test package for ", package, "."), + "License: MIT", + "Author: Test Author", + "Maintainer: Test Author ", + "Encoding: UTF-8" + ) + if (!is.null(imports)) { + fields <- c(fields, paste0("Imports: ", imports)) } + writeLines(fields, file.path(directory, "DESCRIPTION")) + writeLines("fixture_value <- function() 'managed'", file.path(directory, "R", "api.R")) + writeLines("export(fixture_value)", file.path(directory, "NAMESPACE")) + archive <- file.path(root, "repo", "src", "contrib") + dir.create(archive, recursive = TRUE, showWarnings = FALSE) + unlink(list.files( + archive, + pattern = paste0("^", package, "_.*\\.tar\\.gz$"), + full.names = TRUE + )) + previous <- setwd(dirname(directory)) + on.exit(setwd(previous), add = TRUE) + result <- system2( + file.path(R.home("bin"), "R"), + c("CMD", "build", "--no-build-vignettes", shQuote(basename(directory))), + stdout = TRUE, + stderr = TRUE + ) + status <- attr(result, "status") + if (!is.null(status) && status != 0L) { + stop(paste(result, collapse = "\n")) + } + built <- list.files(".", pattern = "\\.tar\\.gz$", full.names = TRUE) + stopifnot(length(built) == 1L) + stopifnot(file.copy(built, archive)) + unlink(built) + setwd(previous) + invisible(directory) + } - # Build a package with an external dependency and verify that it is rejected. - write_package("jgddep", "1.0.0") - write_package("jgd", "1.3.0", imports = "jgddep") - tools::write_PACKAGES(file.path(root, "repo", "src", "contrib"), type = "source") - repo <- paste0("file:///", sub("^/", "", normalizePath(file.path(root, "repo"), winslash = "/"))) - previous_pkg_type <- getOption("pkgType") - options(pkgType = "source") - on.exit(options(pkgType = previous_pkg_type), add = TRUE) - root_path <- file.path(root, "vscode-R") - managed <- tool_library_path(root_path) - stopifnot(identical(managed, - file.path(root_path, "packages", R.version$platform, - paste(R.version$major, - strsplit(R.version$minor, ".", fixed = TRUE)[[1L]][1L], - sep = "."), "library"))) + # Build a package with an external dependency and verify that it is rejected. + write_package("jgddep", "1.0.0") + write_package("jgd", "1.3.0", imports = "jgddep") + tools::write_PACKAGES(file.path(root, "repo", "src", "contrib"), type = "source") + repo <- paste0("file:///", sub("^/", "", normalizePath(file.path(root, "repo"), winslash = "/"))) + previous_pkg_type <- getOption("pkgType") + options(pkgType = "source") + on.exit(options(pkgType = previous_pkg_type), add = TRUE) + root_path <- file.path(root, "vscode-R") + managed <- tool_library_path(root_path) + stopifnot(identical( + managed, + file.path( + root_path, + "packages", + R.version$platform, + paste(R.version$major, strsplit(R.version$minor, ".", fixed = TRUE)[[1L]][1L], sep = "."), + "library" + ) + )) - # DESCRIPTION can look compatible even when the installed package cannot load. - broken_root <- file.path(root, "broken") - broken_library <- tool_library_path(broken_root) - broken_package <- file.path(broken_library, "jgd") - dir.create(broken_package, recursive = TRUE) - writeLines(c("Package: jgd", "Version: 1.0.0"), file.path(broken_package, "DESCRIPTION")) - original_failure <- tryCatch(loadNamespace("jgd", lib.loc = broken_library), error = identity) - failure <- tryCatch(tool_library_load("jgd", "1.0.0", broken_root), error = identity) - stopifnot(inherits(original_failure, "error"), inherits(failure, "error"), - grepl(broken_package, conditionMessage(failure), fixed = TRUE), - grepl("Remove ", conditionMessage(failure), fixed = TRUE), - grepl("installation on the next startup", conditionMessage(failure), fixed = TRUE), - grepl(conditionMessage(original_failure), conditionMessage(failure), fixed = TRUE), - file.exists(file.path(broken_package, "DESCRIPTION"))) - .libPaths(c(broken_library, original_paths)) - user_failure <- tryCatch(tool_library_load("jgd", "1.0.0", broken_root), error = identity) - stopifnot(identical(conditionMessage(user_failure), conditionMessage(original_failure))) - .libPaths(original_paths) + # DESCRIPTION can look compatible even when the installed package cannot load. + broken_root <- file.path(root, "broken") + broken_library <- tool_library_path(broken_root) + broken_package <- file.path(broken_library, "jgd") + dir.create(broken_package, recursive = TRUE) + writeLines(c("Package: jgd", "Version: 1.0.0"), file.path(broken_package, "DESCRIPTION")) + original_failure <- tryCatch(loadNamespace("jgd", lib.loc = broken_library), error = identity) + failure <- tryCatch(tool_library_load("jgd", "1.0.0", broken_root), error = identity) + stopifnot( + inherits(original_failure, "error"), + inherits(failure, "error"), + grepl(broken_package, conditionMessage(failure), fixed = TRUE), + grepl("Remove ", conditionMessage(failure), fixed = TRUE), + grepl("installation on the next startup", conditionMessage(failure), fixed = TRUE), + grepl(conditionMessage(original_failure), conditionMessage(failure), fixed = TRUE), + file.exists(file.path(broken_package, "DESCRIPTION")) + ) + .libPaths(c(broken_library, original_paths)) + user_failure <- tryCatch(tool_library_load("jgd", "1.0.0", broken_root), error = identity) + stopifnot(identical(conditionMessage(user_failure), conditionMessage(original_failure))) + .libPaths(original_paths) - project_library <- file.path(root, "project library") - package_manager_library <- file.path(root, "package manager library") - user_library <- file.path(root, "user library") - dir.create(project_library) - dir.create(package_manager_library) - dir.create(user_library) - .libPaths(c(project_library, package_manager_library, user_library, original_paths)) - before <- .libPaths() - snapshot <- function(path) { - files <- sort(list.files(path, recursive = TRUE, all.files = TRUE, no.. = TRUE)) - list(files = files, contents = unname(tools::md5sum(file.path(path, files)))) - } - ordinary_libraries <- c(project_library, package_manager_library, user_library) - for (library in ordinary_libraries) writeLines("Keep this file.", file.path(library, "sentinel")) - ordinary_before <- lapply(ordinary_libraries, snapshot) - stopifnot(tool_library_check("jgd", "1.0.0", root_path)$install_required) - stopifnot(inherits(tryCatch(tool_library_check("arbitrary", "1.0.0", root_path), - error = identity), "error")) - stopifnot(identical(unname(.vscode_r_tool_packages), c("jgd", "rstudioapi"))) - stopifnot(isTRUE(.tool_validate_request("rstudioapi", "0.4.0"))) - for (invalid in c("", "1.foo", "https://example.com/pkg")) { - stopifnot(inherits(tryCatch(tool_library_check("jgd", invalid, root_path), - error = identity), "error")) - } - for (field in c("Depends", "LinkingTo")) { - description <- matrix("jgddep", nrow = 1L, dimnames = list(NULL, field)) - stopifnot(!.tool_dependencies_allowed(description)) - } - stopifnot(.tool_dependencies_allowed(matrix("R (>= 4.0), stats", nrow = 1L, - dimnames = list(NULL, "Depends")))) - rejection <- tryCatch(tool_library_install("jgd", "1.3.0", root_path, - repos = c(CRAN = repo)), error = identity) - stopifnot(inherits(rejection, "error"), grepl("non-base package dependencies", conditionMessage(rejection))) - stopifnot(!dir.exists(file.path(managed, "jgd"))) + project_library <- file.path(root, "project library") + package_manager_library <- file.path(root, "package manager library") + user_library <- file.path(root, "user library") + dir.create(project_library) + dir.create(package_manager_library) + dir.create(user_library) + .libPaths(c(project_library, package_manager_library, user_library, original_paths)) + before <- .libPaths() + snapshot <- function(path) { + files <- sort(list.files(path, recursive = TRUE, all.files = TRUE, no.. = TRUE)) + list(files = files, contents = unname(tools::md5sum(file.path(path, files)))) + } + ordinary_libraries <- c(project_library, package_manager_library, user_library) + for (library in ordinary_libraries) { + writeLines("Keep this file.", file.path(library, "sentinel")) + } + ordinary_before <- lapply(ordinary_libraries, snapshot) + stopifnot(tool_library_check("jgd", "1.0.0", root_path)$install_required) + stopifnot(inherits( + tryCatch(tool_library_check("arbitrary", "1.0.0", root_path), error = identity), + "error" + )) + stopifnot(identical(unname(.vscode_r_tool_packages), c("jgd", "rstudioapi"))) + stopifnot(isTRUE(.tool_validate_request("rstudioapi", "0.4.0"))) + for (invalid in c("", "1.foo", "https://example.com/pkg")) { + stopifnot(inherits( + tryCatch(tool_library_check("jgd", invalid, root_path), error = identity), + "error" + )) + } + for (field in c("Depends", "LinkingTo")) { + description <- matrix("jgddep", nrow = 1L, dimnames = list(NULL, field)) + stopifnot(!.tool_dependencies_allowed(description)) + } + stopifnot(.tool_dependencies_allowed(matrix( + "R (>= 4.0), stats", + nrow = 1L, + dimnames = list(NULL, "Depends") + ))) + rejection <- tryCatch( + tool_library_install("jgd", "1.3.0", root_path, repos = c(CRAN = repo)), + error = identity + ) + stopifnot( + inherits(rejection, "error"), + grepl("non-base package dependencies", conditionMessage(rejection)) + ) + stopifnot(!dir.exists(file.path(managed, "jgd"))) - # Replace it with a dependency-free package, then install without network access. - write_package("jgd", "1.2.0") - tools::write_PACKAGES(file.path(root, "repo", "src", "contrib"), type = "source") - # The same verification failure must distinguish first installation from an update. - failing_install <- tool_library_install - environment(failing_install) <- list2env(list( - .tool_verify_child = function(...) stop("fixture verification failure") - ), parent = environment(tool_library_install)) - for (updating in c(FALSE, TRUE)) { - failure_root <- file.path(root, if (updating) "failed update" else "failed installation") - if (updating) { - existing <- file.path(tool_library_path(failure_root), "jgd") - dir.create(existing, recursive = TRUE) - writeLines(c("Package: jgd", "Version: 0.1.0"), file.path(existing, "DESCRIPTION")) - } - failure <- tryCatch(failing_install("jgd", "1.0.0", failure_root, repos = c(CRAN = repo)), - error = identity) - expected <- paste0("Could not ", if (updating) "update" else "install", " the managed jgd package. ", - if (updating) "Close other R sessions using it and try again. " else "", - "fixture verification failure") - stopifnot(inherits(failure, "error"), identical(conditionMessage(failure), expected)) + # Replace it with a dependency-free package, then install without network access. + write_package("jgd", "1.2.0") + tools::write_PACKAGES(file.path(root, "repo", "src", "contrib"), type = "source") + # The same verification failure must distinguish first installation from an update. + failing_install <- tool_library_install + environment(failing_install) <- list2env( + list(.tool_verify_child = function(...) stop("fixture verification failure")), + parent = environment(tool_library_install) + ) + for (updating in c(FALSE, TRUE)) { + failure_root <- file.path(root, if (updating) "failed update" else "failed installation") + if (updating) { + existing <- file.path(tool_library_path(failure_root), "jgd") + dir.create(existing, recursive = TRUE) + writeLines(c("Package: jgd", "Version: 0.1.0"), file.path(existing, "DESCRIPTION")) } - too_old <- tryCatch(tool_library_install("jgd", "1.3.0", root_path, repos = c(CRAN = repo)), - error = identity) - stopifnot(inherits(too_old, "error"), !dir.exists(file.path(managed, "jgd"))) - frozen_plan <- tool_library_plan("jgd", "1.0.0", root_path, repos = c(CRAN = repo)) - stopifnot(identical(frozen_plan$version, "1.2.0")) - consent_lines <- .tool_consent_lines(frozen_plan, strrep("a", 32L), "once") - stopifnot(identical(consent_lines[1:5], - c("vscode-r-package-consent-v1", strrep("a", 32L), - paste(R.version$platform, - paste(R.version$major, - strsplit(R.version$minor, ".", fixed = TRUE)[[1L]][1L], - sep = "."), sep = "|"), - "once", "1"))) - stopifnot(identical(consent_lines[6:11], - c("jgd", "1.0.0", "1.2.0", frozen_plan$repository, - frozen_plan$package_type, if (frozen_plan$source_build) "yes" else "no"))) - frozen_install <- tool_library_install("jgd", "1.0.0", root_path, - repos = character(), plan = frozen_plan) - stopifnot(identical(frozen_install$version, "1.2.0")) - stopifnot(inherits(tryCatch(.tool_validate_install_plan(frozen_plan, "jgd", "2.0.0", - root_path), error = identity), - "error")) - result <- tool_library_install("jgd", "1.0.0", root_path, repos = c(CRAN = repo)) - stopifnot(identical(result$source, "managed"), identical(result$version, "1.2.0")) - stopifnot(identical(.libPaths(), before)) - stopifnot(identical(tool_library_check("jgd", "1.0.0", root_path)$source, "managed")) - stopifnot(identical(lapply(ordinary_libraries, snapshot), ordinary_before)) - no_update <- tool_library_install("jgd", "1.0.0", root_path, repos = character()) - stopifnot(identical(no_update$version, "1.2.0")) - write_package("jgd", "1.4.0") - tools::write_PACKAGES(file.path(root, "repo", "src", "contrib"), type = "source") - upgrade <- tool_library_install("jgd", "1.3.0", root_path, repos = c(CRAN = repo)) - stopifnot(identical(upgrade$version, "1.4.0")) - stopifnot(identical(lapply(ordinary_libraries, snapshot), ordinary_before), identical(.libPaths(), before)) + failure <- tryCatch( + failing_install("jgd", "1.0.0", failure_root, repos = c(CRAN = repo)), + error = identity + ) + expected <- paste0( + "Could not ", + if (updating) "update" else "install", + " the managed jgd package. ", + if (updating) "Close other R sessions using it and try again. " else "", + "fixture verification failure" + ) + stopifnot(inherits(failure, "error"), identical(conditionMessage(failure), expected)) + } + too_old <- tryCatch( + tool_library_install("jgd", "1.3.0", root_path, repos = c(CRAN = repo)), + error = identity + ) + stopifnot(inherits(too_old, "error"), !dir.exists(file.path(managed, "jgd"))) + frozen_plan <- tool_library_plan("jgd", "1.0.0", root_path, repos = c(CRAN = repo)) + stopifnot(identical(frozen_plan$version, "1.2.0")) + consent_lines <- .tool_consent_lines(frozen_plan, strrep("a", 32L), "once") + stopifnot(identical( + consent_lines[1:5], + c( + "vscode-r-package-consent-v1", + strrep("a", 32L), + paste( + R.version$platform, + paste(R.version$major, strsplit(R.version$minor, ".", fixed = TRUE)[[1L]][1L], sep = "."), + sep = "|" + ), + "once", + "1" + ) + )) + stopifnot(identical( + consent_lines[6:11], + c( + "jgd", + "1.0.0", + "1.2.0", + frozen_plan$repository, + frozen_plan$package_type, + if (frozen_plan$source_build) "yes" else "no" + ) + )) + frozen_install <- tool_library_install( + "jgd", + "1.0.0", + root_path, + repos = character(), + plan = frozen_plan + ) + stopifnot(identical(frozen_install$version, "1.2.0")) + stopifnot(inherits( + tryCatch(.tool_validate_install_plan(frozen_plan, "jgd", "2.0.0", root_path), error = identity), + "error" + )) + result <- tool_library_install("jgd", "1.0.0", root_path, repos = c(CRAN = repo)) + stopifnot(identical(result$source, "managed"), identical(result$version, "1.2.0")) + stopifnot(identical(.libPaths(), before)) + stopifnot(identical(tool_library_check("jgd", "1.0.0", root_path)$source, "managed")) + stopifnot(identical(lapply(ordinary_libraries, snapshot), ordinary_before)) + no_update <- tool_library_install("jgd", "1.0.0", root_path, repos = character()) + stopifnot(identical(no_update$version, "1.2.0")) + write_package("jgd", "1.4.0") + tools::write_PACKAGES(file.path(root, "repo", "src", "contrib"), type = "source") + upgrade <- tool_library_install("jgd", "1.3.0", root_path, repos = c(CRAN = repo)) + stopifnot(identical(upgrade$version, "1.4.0")) + stopifnot( + identical(lapply(ordinary_libraries, snapshot), ordinary_before), + identical(.libPaths(), before) + ) - lock_path <- file.path(dirname(managed), ".setup-lock") - stopifnot(isTRUE(.tool_with_library_lock(managed, dir.exists(lock_path)))) - stopifnot(!dir.exists(lock_path)) - owner_error <- tryCatch(.tool_with_library_lock(managed, stop("fixture failure")), error = identity) - stopifnot(inherits(owner_error, "error"), !dir.exists(lock_path)) - dir.create(lock_path) - lock_timeout <- tryCatch(.tool_with_library_lock(managed, TRUE, timeout_seconds = 0), - error = identity) - stopifnot(inherits(lock_timeout, "error"), dir.exists(lock_path)) - unlink(lock_path, recursive = TRUE) + lock_path <- file.path(dirname(managed), ".setup-lock") + stopifnot(isTRUE(.tool_with_library_lock(managed, dir.exists(lock_path)))) + stopifnot(!dir.exists(lock_path)) + owner_error <- tryCatch( + .tool_with_library_lock(managed, stop("fixture failure")), + error = identity + ) + stopifnot(inherits(owner_error, "error"), !dir.exists(lock_path)) + dir.create(lock_path) + lock_timeout <- tryCatch( + .tool_with_library_lock(managed, TRUE, timeout_seconds = 0), + error = identity + ) + stopifnot(inherits(lock_timeout, "error"), dir.exists(lock_path)) + unlink(lock_path, recursive = TRUE) - # A compatible ordinary library copy wins over the managed one. - utils::install.packages(file.path(root, "source", "jgd"), repos = NULL, - type = "source", lib = user_library, quiet = TRUE) - .libPaths(c(user_library, .Library)) - user_paths <- .libPaths() - user_choice <- tool_library_check("jgd", "1.0.0", root_path) - stopifnot(identical(user_choice$source, "user")) - user_namespace <- tool_library_load("jgd", "1.0.0", root_path) - stopifnot(identical(normalizePath(getNamespaceInfo(user_namespace, "path"), winslash = "/"), - normalizePath(file.path(user_library, "jgd"), winslash = "/"))) - stopifnot(identical(.libPaths(), user_paths)) - unloadNamespace("jgd") - .libPaths(setdiff(before, user_library)) - managed_paths <- .libPaths() - namespace <- tool_library_load("jgd", "1.0.0", root_path) - stopifnot(identical(getExportedValue("jgd", "fixture_value")(), "managed")) - stopifnot(identical(normalizePath(getNamespaceInfo(namespace, "path"), winslash = "/"), - normalizePath(file.path(managed, "jgd"), winslash = "/"))) - stopifnot(is.null(tool_library_load("jgd", "2.0.0", root_path))) - child_rejection <- tryCatch(.tool_verify_child("jgd", "2.0.0", managed), error = identity) - stopifnot(inherits(child_rejection, "error")) - stopifnot(identical(.libPaths(), managed_paths)) + # A compatible ordinary library copy wins over the managed one. + utils::install.packages( + file.path(root, "source", "jgd"), + repos = NULL, + type = "source", + lib = user_library, + quiet = TRUE + ) + .libPaths(c(user_library, .Library)) + user_paths <- .libPaths() + user_choice <- tool_library_check("jgd", "1.0.0", root_path) + stopifnot(identical(user_choice$source, "user")) + user_namespace <- tool_library_load("jgd", "1.0.0", root_path) + stopifnot(identical( + normalizePath(getNamespaceInfo(user_namespace, "path"), winslash = "/"), + normalizePath(file.path(user_library, "jgd"), winslash = "/") + )) + stopifnot(identical(.libPaths(), user_paths)) + unloadNamespace("jgd") + .libPaths(setdiff(before, user_library)) + managed_paths <- .libPaths() + namespace <- tool_library_load("jgd", "1.0.0", root_path) + stopifnot(identical(getExportedValue("jgd", "fixture_value")(), "managed")) + stopifnot(identical( + normalizePath(getNamespaceInfo(namespace, "path"), winslash = "/"), + normalizePath(file.path(managed, "jgd"), winslash = "/") + )) + stopifnot(is.null(tool_library_load("jgd", "2.0.0", root_path))) + child_rejection <- tryCatch(.tool_verify_child("jgd", "2.0.0", managed), error = identity) + stopifnot(inherits(child_rejection, "error")) + stopifnot(identical(.libPaths(), managed_paths)) - cat("managed tool library tests passed\n") + cat("managed tool library tests passed\n") }) diff --git a/R/tool-consent.R b/R/tool-consent.R index 48ffe32d3..da33b6ffc 100644 --- a/R/tool-consent.R +++ b/R/tool-consent.R @@ -3,138 +3,208 @@ .tool_consent_request_version <- "vscode-r-package-consent-v1" .tool_consent_lines <- function(plan, id, policy) { - if (!inherits(plan, "vscode_r_tool_install_plan") || - !(is.character(id) && length(id) == 1L && - grepl("^[A-Za-z0-9_-]{1,64}$", id)) || - !(is.character(policy) && length(policy) == 1L && policy %in% c("always", "once"))) { - stop("Invalid managed tool consent request.", call. = FALSE) - } - runtime_minor <- strsplit(R.version$minor, ".", fixed = TRUE)[[1L]][1L] - runtime <- paste(R.version$platform, - paste(R.version$major, runtime_minor, sep = "."), sep = "|") - package_fields <- c(plan$package, plan$minimum_version, plan$version, - plan$repository, plan$package_type, - if (isTRUE(plan$source_build)) "yes" else "no") - if (anyNA(package_fields) || any(!nzchar(package_fields)) || - any(grepl("[\r\n]", package_fields))) { - stop("The managed tool installation plan cannot be represented in a consent request.", - call. = FALSE) - } - lines <- c(.tool_consent_request_version, id, runtime, policy, "1", package_fields) - request <- paste0(paste(lines, collapse = "\n"), "\n") - if (nchar(request, type = "bytes") > .tool_consent_max_bytes) { - stop("The managed tool consent request is too large.", call. = FALSE) - } - lines + if ( + !inherits(plan, "vscode_r_tool_install_plan") || + !(is.character(id) && length(id) == 1L && grepl("^[A-Za-z0-9_-]{1,64}$", id)) || + !(is.character(policy) && length(policy) == 1L && policy %in% c("always", "once")) + ) { + stop("Invalid managed tool consent request.", call. = FALSE) + } + runtime_minor <- strsplit(R.version$minor, ".", fixed = TRUE)[[1L]][1L] + runtime <- paste(R.version$platform, paste(R.version$major, runtime_minor, sep = "."), sep = "|") + package_fields <- c( + plan$package, + plan$minimum_version, + plan$version, + plan$repository, + plan$package_type, + if (isTRUE(plan$source_build)) "yes" else "no" + ) + if ( + anyNA(package_fields) || any(!nzchar(package_fields)) || any(grepl("[\r\n]", package_fields)) + ) { + stop( + "The managed tool installation plan cannot be represented in a consent request.", + call. = FALSE + ) + } + lines <- c(.tool_consent_request_version, id, runtime, policy, "1", package_fields) + request <- paste0(paste(lines, collapse = "\n"), "\n") + if (nchar(request, type = "bytes") > .tool_consent_max_bytes) { + stop("The managed tool consent request is too large.", call. = FALSE) + } + lines } .tool_publish_consent_request <- function(plan, id, policy, directory) { - if (!(is.character(directory) && length(directory) == 1L && - !is.na(directory) && nzchar(directory))) { - stop("The managed tool consent directory is unavailable.", call. = FALSE) - } - dir.create(directory, recursive = TRUE, showWarnings = FALSE, mode = "0700") - if (!dir.exists(directory) || file.access(directory, 2L) != 0L) { - stop("The managed tool consent directory is unavailable.", call. = FALSE) - } - if (.Platform$OS.type == "unix") Sys.chmod(directory, "0700") - lines <- .tool_consent_lines(plan, id, policy) - request_path <- file.path(directory, paste0(id, ".request")) - response_path <- file.path(directory, paste0(id, ".response")) - if (file.exists(request_path) || file.exists(response_path)) { - stop("The managed tool consent request ID has already been used.", call. = FALSE) - } - temporary_path <- tempfile(pattern = paste0(id, "-"), tmpdir = directory) - on.exit(unlink(temporary_path), add = TRUE) - writeLines(lines, temporary_path, useBytes = TRUE) - if (.Platform$OS.type == "unix") Sys.chmod(temporary_path, "0600") - if (!file.rename(temporary_path, request_path)) { - stop("Could not publish the managed tool consent request.", call. = FALSE) - } - if (.Platform$OS.type == "unix") Sys.chmod(request_path, "0600") - list(id = id, lines = lines, request_path = request_path, - response_path = response_path) + if ( + !(is.character(directory) && length(directory) == 1L && !is.na(directory) && nzchar(directory)) + ) { + stop("The managed tool consent directory is unavailable.", call. = FALSE) + } + dir.create(directory, recursive = TRUE, showWarnings = FALSE, mode = "0700") + if (!dir.exists(directory) || file.access(directory, 2L) != 0L) { + stop("The managed tool consent directory is unavailable.", call. = FALSE) + } + if (.Platform$OS.type == "unix") { + Sys.chmod(directory, "0700") + } + lines <- .tool_consent_lines(plan, id, policy) + request_path <- file.path(directory, paste0(id, ".request")) + response_path <- file.path(directory, paste0(id, ".response")) + if (file.exists(request_path) || file.exists(response_path)) { + stop("The managed tool consent request ID has already been used.", call. = FALSE) + } + temporary_path <- tempfile(pattern = paste0(id, "-"), tmpdir = directory) + on.exit(unlink(temporary_path), add = TRUE) + writeLines(lines, temporary_path, useBytes = TRUE) + if (.Platform$OS.type == "unix") { + Sys.chmod(temporary_path, "0600") + } + if (!file.rename(temporary_path, request_path)) { + stop("Could not publish the managed tool consent request.", call. = FALSE) + } + if (.Platform$OS.type == "unix") { + Sys.chmod(request_path, "0600") + } + list(id = id, lines = lines, request_path = request_path, response_path = response_path) } .tool_wait_for_consent <- function(request, timeout_seconds = 180) { - directory <- dirname(request$request_path) - on.exit(unlink(c(request$request_path, request$response_path)), add = TRUE) - if (!(is.numeric(timeout_seconds) && length(timeout_seconds) == 1L && - !is.na(timeout_seconds) && is.finite(timeout_seconds) && timeout_seconds >= 0)) { - stop("timeout_seconds must be a finite non-negative number.", call. = FALSE) + directory <- dirname(request$request_path) + on.exit(unlink(c(request$request_path, request$response_path)), add = TRUE) + if ( + !(is.numeric(timeout_seconds) && + length(timeout_seconds) == 1L && + !is.na(timeout_seconds) && + is.finite(timeout_seconds) && + timeout_seconds >= 0) + ) { + stop("timeout_seconds must be a finite non-negative number.", call. = FALSE) + } + deadline <- Sys.time() + timeout_seconds + repeat { + if (!dir.exists(directory) || !file.exists(request$request_path)) { + return(FALSE) + } + request_size <- file.info(request$request_path)$size + if (is.na(request_size) || request_size > .tool_consent_max_bytes) { + return(FALSE) + } + request_lines <- tryCatch( + readLines(request$request_path, warn = FALSE), + error = function(error) character() + ) + # A grant applies to the exact version and source the user saw. + if (!identical(request_lines, request$lines)) { + return(FALSE) + } + if (file.exists(request$response_path)) { + response_size <- file.info(request$response_path)$size + if (is.na(response_size) || response_size > 32L) { + stop("Invalid response to the managed tool consent request.", call. = FALSE) + } + response <- tryCatch( + readLines(request$response_path, warn = FALSE), + error = function(error) character() + ) + if (identical(response, "approve")) { + return(TRUE) + } + if (identical(response, "decline")) { + return(FALSE) + } + stop("Invalid response to the managed tool consent request.", call. = FALSE) } - deadline <- Sys.time() + timeout_seconds - repeat { - if (!dir.exists(directory) || !file.exists(request$request_path)) return(FALSE) - request_size <- file.info(request$request_path)$size - if (is.na(request_size) || request_size > .tool_consent_max_bytes) return(FALSE) - request_lines <- tryCatch(readLines(request$request_path, warn = FALSE), - error = function(error) character()) - # A grant applies to the exact version and source the user saw. - if (!identical(request_lines, request$lines)) return(FALSE) - if (file.exists(request$response_path)) { - response_size <- file.info(request$response_path)$size - if (is.na(response_size) || response_size > 32L) { - stop("Invalid response to the managed tool consent request.", call. = FALSE) - } - response <- tryCatch(readLines(request$response_path, warn = FALSE), - error = function(error) character()) - if (identical(response, "approve")) return(TRUE) - if (identical(response, "decline")) return(FALSE) - stop("Invalid response to the managed tool consent request.", call. = FALSE) - } - if (Sys.time() >= deadline) return(FALSE) - Sys.sleep(0.1) + if (Sys.time() >= deadline) { + return(FALSE) } + Sys.sleep(0.1) + } } .tool_request_consent <- function(plan, policy, directory, timeout_seconds = 180) { - if (!(is.character(directory) && length(directory) == 1L && - !is.na(directory) && nzchar(directory) && dir.exists(directory))) { - stop("The extension's tool consent service is unavailable. Restart VS Code and try again.", - call. = FALSE) + if ( + !(is.character(directory) && + length(directory) == 1L && + !is.na(directory) && + nzchar(directory) && + dir.exists(directory)) + ) { + stop( + "The extension's tool consent service is unavailable. Restart VS Code and try again.", + call. = FALSE + ) + } + repeat { + temporary <- paste0( + basename(tempfile(pattern = "request-", tmpdir = directory)), + basename(tempfile(pattern = "request-", tmpdir = directory)) + ) + id <- gsub("[^A-Za-z0-9_-]", "", sub("^request-", "", sub("^request-", "", temporary))) + if (!grepl("^[A-Za-z0-9_-]{16,64}$", id)) { + next } - repeat { - temporary <- paste0( - basename(tempfile(pattern = "request-", tmpdir = directory)), - basename(tempfile(pattern = "request-", tmpdir = directory)) - ) - id <- gsub("[^A-Za-z0-9_-]", "", - sub("^request-", "", sub("^request-", "", temporary))) - if (!grepl("^[A-Za-z0-9_-]{16,64}$", id)) next - request_path <- file.path(directory, paste0(id, ".request")) - response_path <- file.path(directory, paste0(id, ".response")) - if (!file.exists(request_path) && !file.exists(response_path)) break - } - request <- .tool_publish_consent_request(plan, id, policy, directory) - .tool_wait_for_consent(request, timeout_seconds) + request_path <- file.path(directory, paste0(id, ".request")) + response_path <- file.path(directory, paste0(id, ".response")) + if (!file.exists(request_path) && !file.exists(response_path)) break + } + request <- .tool_publish_consent_request(plan, id, policy, directory) + .tool_wait_for_consent(request, timeout_seconds) } # Request consent only when no compatible namespace is already available. # On approval the frozen repository result is passed directly to installation. # `policy` is "always" or "once"; the extension applies it to its prompt. -tool_library_prepare <- function(package, minimum_version, root, consent_directory, - policy, repos = getOption("repos"), - consent_timeout_seconds = 180, - install_timeout_seconds = 300, - resolution_timeout_seconds = 30) { - available <- tool_library_check(package, minimum_version, root) - if (!available$install_required) return(invisible(available)) - plan <- local({ - previous_timeout <- getOption("timeout") - on.exit(options(timeout = previous_timeout), add = TRUE) - bounded_timeout <- resolution_timeout_seconds - if (is.numeric(previous_timeout) && length(previous_timeout) == 1L && - !is.na(previous_timeout) && is.finite(previous_timeout) && previous_timeout > 0) { - bounded_timeout <- min(previous_timeout, resolution_timeout_seconds) - } - options(timeout = bounded_timeout) - tool_library_plan(package, minimum_version, root, repos) - }) - if (is.null(plan)) return(invisible(tool_library_check(package, minimum_version, root))) - approved <- .tool_request_consent(plan, policy, consent_directory, - timeout_seconds = consent_timeout_seconds) - if (!isTRUE(approved)) return(invisible(NULL)) - tool_library_install(package, minimum_version, root, repos = plan$repositories, - timeout_seconds = install_timeout_seconds, plan = plan) +tool_library_prepare <- function( + package, + minimum_version, + root, + consent_directory, + policy, + repos = getOption("repos"), + consent_timeout_seconds = 180, + install_timeout_seconds = 300, + resolution_timeout_seconds = 30 +) { + available <- tool_library_check(package, minimum_version, root) + if (!available$install_required) { + return(invisible(available)) + } + plan <- local({ + previous_timeout <- getOption("timeout") + on.exit(options(timeout = previous_timeout), add = TRUE) + bounded_timeout <- resolution_timeout_seconds + if ( + is.numeric(previous_timeout) && + length(previous_timeout) == 1L && + !is.na(previous_timeout) && + is.finite(previous_timeout) && + previous_timeout > 0 + ) { + bounded_timeout <- min(previous_timeout, resolution_timeout_seconds) + } + options(timeout = bounded_timeout) + tool_library_plan(package, minimum_version, root, repos) + }) + if (is.null(plan)) { + return(invisible(tool_library_check(package, minimum_version, root))) + } + approved <- .tool_request_consent( + plan, + policy, + consent_directory, + timeout_seconds = consent_timeout_seconds + ) + if (!isTRUE(approved)) { + return(invisible(NULL)) + } + tool_library_install( + package, + minimum_version, + root, + repos = plan$repositories, + timeout_seconds = install_timeout_seconds, + plan = plan + ) } diff --git a/R/tool-library.R b/R/tool-library.R index e4b043827..214e0a709 100644 --- a/R/tool-library.R +++ b/R/tool-library.R @@ -4,229 +4,307 @@ .vscode_r_tool_packages <- c(jgd = "jgd", rstudioapi = "rstudioapi") tool_library_path <- function(root) { - .tool_validate_root(root) - minor <- strsplit(R.version$minor, ".", fixed = TRUE)[[1L]][1L] - version <- paste(R.version$major, minor, sep = ".") - if (!grepl("^[A-Za-z0-9_.-]+$", R.version$platform) || - !grepl("^[0-9]+\\.[0-9]+$", version)) { - stop("Unsupported R platform or version for the managed tool library.") - } - file.path(root, "packages", R.version$platform, version, "library") + .tool_validate_root(root) + minor <- strsplit(R.version$minor, ".", fixed = TRUE)[[1L]][1L] + version <- paste(R.version$major, minor, sep = ".") + if (!grepl("^[A-Za-z0-9_.-]+$", R.version$platform) || !grepl("^[0-9]+\\.[0-9]+$", version)) { + stop("Unsupported R platform or version for the managed tool library.") + } + file.path(root, "packages", R.version$platform, version, "library") } .tool_validate_root <- function(root) { - if (!(is.character(root) && length(root) == 1L && !is.na(root) && nzchar(root))) { - stop("A non-empty tool library root path is required.", call. = FALSE) - } - invisible(TRUE) + if (!(is.character(root) && length(root) == 1L && !is.na(root) && nzchar(root))) { + stop("A non-empty tool library root path is required.", call. = FALSE) + } + invisible(TRUE) } .tool_validate_request <- function(package, minimum_version) { - if (!(is.character(package) && length(package) == 1L && !is.na(package) && - package %in% .vscode_r_tool_packages)) { - stop("Package is not allowed in the vscode-R tool library.", call. = FALSE) - } - if (!(is.character(minimum_version) && length(minimum_version) == 1L && - !is.na(minimum_version) && - !inherits(tryCatch(package_version(minimum_version), - error = identity), "error"))) { - stop("A valid minimum package version is required.", call. = FALSE) - } - invisible(TRUE) + if ( + !(is.character(package) && + length(package) == 1L && + !is.na(package) && + package %in% .vscode_r_tool_packages) + ) { + stop("Package is not allowed in the vscode-R tool library.", call. = FALSE) + } + if ( + !(is.character(minimum_version) && + length(minimum_version) == 1L && + !is.na(minimum_version) && + !inherits(tryCatch(package_version(minimum_version), error = identity), "error")) + ) { + stop("A valid minimum package version is required.", call. = FALSE) + } + invisible(TRUE) } .tool_description <- function(path) { - if (!file.exists(file.path(path, "DESCRIPTION"))) return(NULL) - tryCatch(read.dcf(file.path(path, "DESCRIPTION")), error = function(e) NULL) + if (!file.exists(file.path(path, "DESCRIPTION"))) { + return(NULL) + } + tryCatch(read.dcf(file.path(path, "DESCRIPTION")), error = function(e) NULL) } .tool_version_at <- function(package, library) { - description <- .tool_description(file.path(library, package)) - if (is.null(description) || !"Version" %in% colnames(description)) return(NULL) - unname(description[1L, "Version"]) + description <- .tool_description(file.path(library, package)) + if (is.null(description) || !"Version" %in% colnames(description)) { + return(NULL) + } + unname(description[1L, "Version"]) } .tool_version_ok <- function(version, minimum_version) { - if (is.null(version) || length(version) != 1L || is.na(version)) return(FALSE) - isTRUE(tryCatch(package_version(version) >= package_version(minimum_version), - error = function(e) FALSE)) + if (is.null(version) || length(version) != 1L || is.na(version)) { + return(FALSE) + } + isTRUE(tryCatch( + package_version(version) >= package_version(minimum_version), + error = function(e) FALSE + )) } .tool_namespace_path <- function(package) { - if (!package %in% loadedNamespaces()) return(NULL) - getNamespaceInfo(asNamespace(package), "path") + if (!package %in% loadedNamespaces()) { + return(NULL) + } + getNamespaceInfo(asNamespace(package), "path") } # Report what would satisfy a request without installing or loading anything. # Returns package, version, source, install_required, and library fields. `source` # is loaded, user, managed, install, or loaded-incompatible. tool_library_check <- function(package, minimum_version, root) { - .tool_validate_request(package, minimum_version) - .tool_validate_root(root) - loaded_path <- .tool_namespace_path(package) - if (!is.null(loaded_path)) { - version <- as.character(getNamespaceVersion(asNamespace(package))) - compatible <- .tool_version_ok(version, minimum_version) - return(list(package = package, version = version, - source = if (compatible) "loaded" else "loaded-incompatible", - install_required = FALSE, library = dirname(loaded_path))) - } - for (library in .libPaths()) { - version <- .tool_version_at(package, library) - if (.tool_version_ok(version, minimum_version)) { - return(list(package = package, version = version, source = "user", - install_required = FALSE, library = library)) - } - } - library <- tool_library_path(root) + .tool_validate_request(package, minimum_version) + .tool_validate_root(root) + loaded_path <- .tool_namespace_path(package) + if (!is.null(loaded_path)) { + version <- as.character(getNamespaceVersion(asNamespace(package))) + compatible <- .tool_version_ok(version, minimum_version) + return(list( + package = package, + version = version, + source = if (compatible) "loaded" else "loaded-incompatible", + install_required = FALSE, + library = dirname(loaded_path) + )) + } + for (library in .libPaths()) { version <- .tool_version_at(package, library) if (.tool_version_ok(version, minimum_version)) { - return(list(package = package, version = version, source = "managed", - install_required = FALSE, library = library)) + return(list( + package = package, + version = version, + source = "user", + install_required = FALSE, + library = library + )) } - list(package = package, version = version, source = "install", - install_required = TRUE, library = library) + } + library <- tool_library_path(root) + version <- .tool_version_at(package, library) + if (.tool_version_ok(version, minimum_version)) { + return(list( + package = package, + version = version, + source = "managed", + install_required = FALSE, + library = library + )) + } + list( + package = package, + version = version, + source = "install", + install_required = TRUE, + library = library + ) } .tool_dependencies_allowed <- function(description) { - installed <- utils::installed.packages(fields = "Priority") - allowed <- rownames(installed)[!is.na(installed[, "Priority"]) & - installed[, "Priority"] %in% c("base", "recommended")] - for (field in c("Depends", "Imports", "LinkingTo")) { - if (!field %in% colnames(description) || is.na(description[1L, field])) next - entries <- trimws(strsplit(description[1L, field], ",", fixed = TRUE)[[1L]]) - names <- sub("\\s*\\(.*$", "", entries) - names <- setdiff(names[nzchar(names)], "R") - if (length(setdiff(names, allowed))) return(FALSE) + installed <- utils::installed.packages(fields = "Priority") + allowed <- rownames(installed)[ + !is.na(installed[, "Priority"]) & installed[, "Priority"] %in% c("base", "recommended") + ] + for (field in c("Depends", "Imports", "LinkingTo")) { + if (!field %in% colnames(description) || is.na(description[1L, field])) { + next } - TRUE + entries <- trimws(strsplit(description[1L, field], ",", fixed = TRUE)[[1L]]) + names <- sub("\\s*\\(.*$", "", entries) + names <- setdiff(names[nzchar(names)], "R") + if (length(setdiff(names, allowed))) return(FALSE) + } + TRUE } .tool_with_library_lock <- function(library, code, timeout_seconds = 300) { - if (!(is.numeric(timeout_seconds) && length(timeout_seconds) == 1L && - !is.na(timeout_seconds) && is.finite(timeout_seconds) && timeout_seconds >= 0)) { - stop("timeout_seconds must be a finite non-negative number.") + if ( + !(is.numeric(timeout_seconds) && + length(timeout_seconds) == 1L && + !is.na(timeout_seconds) && + is.finite(timeout_seconds) && + timeout_seconds >= 0) + ) { + stop("timeout_seconds must be a finite non-negative number.") + } + parent <- dirname(library) + dir.create(parent, recursive = TRUE, showWarnings = FALSE) + if (!dir.exists(parent) || file.access(parent, 2L) != 0L) { + stop("The vscode-R managed tool library is not writable.") + } + lock <- file.path(parent, ".setup-lock") + deadline <- Sys.time() + timeout_seconds + repeat { + if (isTRUE(dir.create(lock, showWarnings = FALSE, mode = "0700"))) { + on.exit(unlink(lock, recursive = TRUE, force = TRUE), add = TRUE) + return(force(code)) } - parent <- dirname(library) - dir.create(parent, recursive = TRUE, showWarnings = FALSE) - if (!dir.exists(parent) || file.access(parent, 2L) != 0L) { - stop("The vscode-R managed tool library is not writable.") + if (!dir.exists(lock)) { + if (Sys.time() >= deadline) { + stop("Timed out waiting for the managed tool library lock.") + } + Sys.sleep(0.1) + next } - lock <- file.path(parent, ".setup-lock") - deadline <- Sys.time() + timeout_seconds - repeat { - if (isTRUE(dir.create(lock, showWarnings = FALSE, mode = "0700"))) { - on.exit(unlink(lock, recursive = TRUE, force = TRUE), add = TRUE) - return(force(code)) - } - if (!dir.exists(lock)) { - if (Sys.time() >= deadline) stop("Timed out waiting for the managed tool library lock.") - Sys.sleep(0.1) - next - } - if (Sys.time() >= deadline) { - stop("Timed out waiting for another tool library setup. Its owner may have crashed; remove ", - shQuote(lock), " only after confirming its owner has exited.") - } - Sys.sleep(0.1) + if (Sys.time() >= deadline) { + stop( + "Timed out waiting for another tool library setup. Its owner may have crashed; remove ", + shQuote(lock), + " only after confirming its owner has exited." + ) } + Sys.sleep(0.1) + } } .tool_verify_child <- function(package, minimum_version, library) { - code <- paste( - "a <- commandArgs(TRUE); p <- a[1]; minimum <- a[2]; lib <- a[3];", - "ns <- loadNamespace(p, lib.loc=lib);", - "stopifnot(normalizePath(getNamespaceInfo(ns,'path')) == normalizePath(file.path(lib,p)));", - "stopifnot(utils::compareVersion(as.character(utils::packageVersion(p,lib.loc=lib)),minimum) >= 0)" + code <- paste( + "a <- commandArgs(TRUE); p <- a[1]; minimum <- a[2]; lib <- a[3];", + "ns <- loadNamespace(p, lib.loc=lib);", + "stopifnot(normalizePath(getNamespaceInfo(ns,'path')) == normalizePath(file.path(lib,p)));", + "stopifnot(utils::compareVersion(as.character(utils::packageVersion(p,lib.loc=lib)),minimum) >= 0)" + ) + status <- system2( + file.path(R.home("bin"), "R"), + c( + "--vanilla", + "--slave", + "-e", + shQuote(code), + "--args", + shQuote(package), + shQuote(minimum_version), + shQuote(library) ) - status <- system2(file.path(R.home("bin"), "R"), - c("--vanilla", "--slave", "-e", shQuote(code), "--args", - shQuote(package), shQuote(minimum_version), shQuote(library))) - if (!identical(as.integer(status), 0L)) { - stop("The installed ", package, " package failed its compatibility/load check.") - } - invisible(TRUE) + ) + if (!identical(as.integer(status), 0L)) { + stop("The installed ", package, " package failed its compatibility/load check.") + } + invisible(TRUE) } # Resolve and validate a single allowed package against the configured R repositories. # The returned plan captures the repository result and package type for consent. tool_library_plan <- function(package, minimum_version, root, repos = getOption("repos")) { - .tool_validate_request(package, minimum_version) - .tool_validate_root(root) - initial <- tool_library_check(package, minimum_version, root) - if (!initial$install_required) return(NULL) - if (!is.character(repos)) { - stop("No R package repository is configured for the managed tool library.") - } - repositories <- repos[!is.na(repos) & nzchar(repos) & repos != "@CRAN@"] - if (length(repositories) == 0L) stop("No usable R package repository is configured.") - package_type <- getOption("pkgType") - if (identical(package_type, "binary")) package_type <- .Platform$pkgType - package_types <- if (identical(package_type, "both")) { - binary_type <- if (.Platform$OS.type == "windows") "win.binary" else .Platform$pkgType - c(binary_type, "source") - } else { - package_type - } - candidates <- lapply(package_types, function(type) { - available <- tryCatch(utils::available.packages(repos = repositories, type = type, - fields = "NeedsCompilation"), - error = function(e) matrix(character(), nrow = 0L)) - list(type = type, available = available) - }) - selected <- NULL - for (candidate in candidates) { - available <- candidate$available - if (!package %in% rownames(available)) next - candidate_version <- available[package, "Version"] - if (.tool_version_ok(candidate_version, minimum_version)) { - selected <- candidate - break - } - } - if (is.null(selected)) { - stop("No configured repository version satisfies the requested minimum version.") - } - package_type <- selected$type - available <- selected$available - row <- available[package, , drop = TRUE] - description <- as.data.frame(as.list(row), stringsAsFactors = FALSE) - if (!.tool_dependencies_allowed(description)) { - stop("Refusing to install ", package, - " because it has non-base package dependencies.") + .tool_validate_request(package, minimum_version) + .tool_validate_root(root) + initial <- tool_library_check(package, minimum_version, root) + if (!initial$install_required) { + return(NULL) + } + if (!is.character(repos)) { + stop("No R package repository is configured for the managed tool library.") + } + repositories <- repos[!is.na(repos) & nzchar(repos) & repos != "@CRAN@"] + if (length(repositories) == 0L) { + stop("No usable R package repository is configured.") + } + package_type <- getOption("pkgType") + if (identical(package_type, "binary")) { + package_type <- .Platform$pkgType + } + package_types <- if (identical(package_type, "both")) { + binary_type <- if (.Platform$OS.type == "windows") "win.binary" else .Platform$pkgType + c(binary_type, "source") + } else { + package_type + } + candidates <- lapply(package_types, function(type) { + available <- tryCatch( + utils::available.packages(repos = repositories, type = type, fields = "NeedsCompilation"), + error = function(e) matrix(character(), nrow = 0L) + ) + list(type = type, available = available) + }) + selected <- NULL + for (candidate in candidates) { + available <- candidate$available + if (!package %in% rownames(available)) { + next } - selected_repositories <- repositories - repository <- if ("Repository" %in% names(row) && !is.na(row[["Repository"]])) { - unname(row[["Repository"]]) - } else { - unname(repositories[[1L]]) + candidate_version <- available[package, "Version"] + if (.tool_version_ok(candidate_version, minimum_version)) { + selected <- candidate + break } - needs_compilation <- if ("NeedsCompilation" %in% names(row)) row[["NeedsCompilation"]] else NA_character_ - source_build <- identical(package_type, "source") && - (is.na(needs_compilation) || !nzchar(needs_compilation) || - identical(tolower(needs_compilation), "yes")) - structure(list( - package = package, - minimum_version = minimum_version, - version = unname(row[["Version"]]), - repository = repository, - package_type = package_type, - source_build = source_build, - repositories = selected_repositories, - available = available, - root = root, - library = initial$library - ), class = "vscode_r_tool_install_plan") + } + if (is.null(selected)) { + stop("No configured repository version satisfies the requested minimum version.") + } + package_type <- selected$type + available <- selected$available + row <- available[package, , drop = TRUE] + description <- as.data.frame(as.list(row), stringsAsFactors = FALSE) + if (!.tool_dependencies_allowed(description)) { + stop("Refusing to install ", package, " because it has non-base package dependencies.") + } + selected_repositories <- repositories + repository <- if ("Repository" %in% names(row) && !is.na(row[["Repository"]])) { + unname(row[["Repository"]]) + } else { + unname(repositories[[1L]]) + } + needs_compilation <- if ("NeedsCompilation" %in% names(row)) { + row[["NeedsCompilation"]] + } else { + NA_character_ + } + source_build <- identical(package_type, "source") && + (is.na(needs_compilation) || + !nzchar(needs_compilation) || + identical(tolower(needs_compilation), "yes")) + structure( + list( + package = package, + minimum_version = minimum_version, + version = unname(row[["Version"]]), + repository = repository, + package_type = package_type, + source_build = source_build, + repositories = selected_repositories, + available = available, + root = root, + library = initial$library + ), + class = "vscode_r_tool_install_plan" + ) } .tool_validate_install_plan <- function(plan, package, minimum_version, root) { - if (!inherits(plan, "vscode_r_tool_install_plan") || - !identical(plan$package, package) || - !identical(plan$minimum_version, minimum_version) || - !identical(plan$root, root)) { - stop("The approved tool installation plan is invalid or does not match the request.", call. = FALSE) - } - invisible(TRUE) + if ( + !inherits(plan, "vscode_r_tool_install_plan") || + !identical(plan$package, package) || + !identical(plan$minimum_version, minimum_version) || + !identical(plan$root, root) + ) { + stop( + "The approved tool installation plan is invalid or does not match the request.", + call. = FALSE + ) + } + invisible(TRUE) } # Updating a shared library while another R process has loaded its package can @@ -234,70 +312,134 @@ tool_library_plan <- function(package, minimum_version, root, repos = getOption( # callers should close other R sessions using the package and retry on failure. # Install only after the caller has obtained consent. A supplied plan uses the # exact repository metadata and package type shown in the one-time request. -tool_library_install <- function(package, minimum_version, root, - repos = getOption("repos"), timeout_seconds = 300, plan = NULL) { - .tool_validate_request(package, minimum_version) - .tool_validate_root(root) - initial <- tool_library_check(package, minimum_version, root) - if (!initial$install_required) return(invisible(initial)) - if (is.null(plan)) plan <- tool_library_plan(package, minimum_version, root, repos) - if (is.null(plan)) return(invisible(tool_library_check(package, minimum_version, root))) - .tool_validate_install_plan(plan, package, minimum_version, root) - package_type <- plan$package_type - available <- plan$available - library <- plan$library - selected_repositories <- plan$repositories - .tool_with_library_lock(library, { - current <- tool_library_check(package, minimum_version, root) - if (!current$install_required) return(invisible(current)) - updating <- !is.null(current$version) - dir.create(library, recursive = TRUE, showWarnings = FALSE) - if (file.access(library, 2L) != 0L) stop("The vscode-R managed tool library is not writable.") - tryCatch({ - utils::install.packages(package, lib = library, repos = selected_repositories, - available = available, dependencies = FALSE, - type = package_type, quiet = TRUE) - version <- .tool_version_at(package, library) - if (!identical(version, plan$version) || - !.tool_version_ok(version, minimum_version)) { - stop("The installed version does not match the approved repository version.") - } - .tool_verify_child(package, minimum_version, library) - invisible(list(package = package, version = version, source = "managed", - install_required = FALSE, library = library)) - }, error = function(error) { - action <- if (updating) "update" else "install" - advice <- if (updating) "Close other R sessions using it and try again. " else "" - stop("Could not ", action, " the managed ", package, " package. ", advice, - conditionMessage(error), call. = FALSE) - }) - }, timeout_seconds = timeout_seconds) +tool_library_install <- function( + package, + minimum_version, + root, + repos = getOption("repos"), + timeout_seconds = 300, + plan = NULL +) { + .tool_validate_request(package, minimum_version) + .tool_validate_root(root) + initial <- tool_library_check(package, minimum_version, root) + if (!initial$install_required) { + return(invisible(initial)) + } + if (is.null(plan)) { + plan <- tool_library_plan(package, minimum_version, root, repos) + } + if (is.null(plan)) { + return(invisible(tool_library_check(package, minimum_version, root))) + } + .tool_validate_install_plan(plan, package, minimum_version, root) + package_type <- plan$package_type + available <- plan$available + library <- plan$library + selected_repositories <- plan$repositories + .tool_with_library_lock( + library, + { + current <- tool_library_check(package, minimum_version, root) + if (!current$install_required) { + return(invisible(current)) + } + updating <- !is.null(current$version) + dir.create(library, recursive = TRUE, showWarnings = FALSE) + if (file.access(library, 2L) != 0L) { + stop("The vscode-R managed tool library is not writable.") + } + tryCatch( + { + utils::install.packages( + package, + lib = library, + repos = selected_repositories, + available = available, + dependencies = FALSE, + type = package_type, + quiet = TRUE + ) + version <- .tool_version_at(package, library) + if (!identical(version, plan$version) || !.tool_version_ok(version, minimum_version)) { + stop("The installed version does not match the approved repository version.") + } + .tool_verify_child(package, minimum_version, library) + invisible(list( + package = package, + version = version, + source = "managed", + install_required = FALSE, + library = library + )) + }, + error = function(error) { + action <- if (updating) "update" else "install" + advice <- if (updating) "Close other R sessions using it and try again. " else "" + stop( + "Could not ", + action, + " the managed ", + package, + " package. ", + advice, + conditionMessage(error), + call. = FALSE + ) + } + ) + }, + timeout_seconds = timeout_seconds + ) } # Load a compatible namespace according to the agreed precedence. Returns the # loaded namespace, or NULL when installation is needed or an incompatible # namespace is already loaded. The latter is left untouched for safe fallback. tool_library_load <- function(package, minimum_version, root) { - selected <- tool_library_check(package, minimum_version, root) - if (selected$source == "loaded-incompatible") { - message("An incompatible ", package, - " namespace is already loaded. Restart R before using the managed version.") - return(NULL) - } - if (selected$source == "loaded") return(asNamespace(package)) - if (selected$install_required) return(NULL) - namespace <- tryCatch(loadNamespace(package, lib.loc = selected$library), error = function(error) { - if (selected$source != "managed") stop(error) - stop("Could not load the managed ", package, " package. Remove ", - shQuote(file.path(selected$library, package)), - " to allow vscode-R to offer installation on the next startup. ", - conditionMessage(error), call. = FALSE) - }) - actual_path <- normalizePath(getNamespaceInfo(namespace, "path"), winslash = "/", mustWork = TRUE) - intended_path <- normalizePath(file.path(selected$library, package), winslash = "/", mustWork = TRUE) - actual_version <- as.character(getNamespaceVersion(namespace)) - if (!identical(actual_path, intended_path) || !.tool_version_ok(actual_version, minimum_version)) { - stop("Loaded ", package, " does not match the selected compatible library.") + selected <- tool_library_check(package, minimum_version, root) + if (selected$source == "loaded-incompatible") { + message( + "An incompatible ", + package, + " namespace is already loaded. Restart R before using the managed version." + ) + return(NULL) + } + if (selected$source == "loaded") { + return(asNamespace(package)) + } + if (selected$install_required) { + return(NULL) + } + namespace <- tryCatch( + loadNamespace(package, lib.loc = selected$library), + error = function(error) { + if (selected$source != "managed") { + stop(error) + } + stop( + "Could not load the managed ", + package, + " package. Remove ", + shQuote(file.path(selected$library, package)), + " to allow vscode-R to offer installation on the next startup. ", + conditionMessage(error), + call. = FALSE + ) } - namespace + ) + actual_path <- normalizePath(getNamespaceInfo(namespace, "path"), winslash = "/", mustWork = TRUE) + intended_path <- normalizePath( + file.path(selected$library, package), + winslash = "/", + mustWork = TRUE + ) + actual_version <- as.character(getNamespaceVersion(namespace)) + if ( + !identical(actual_path, intended_path) || !.tool_version_ok(actual_version, minimum_version) + ) { + stop("Loaded ", package, " does not match the selected compatible library.") + } + namespace } diff --git a/scripts/benchmark-workspace-refresh.R b/scripts/benchmark-workspace-refresh.R index 394a1e2c8..a6d459c5d 100644 --- a/scripts/benchmark-workspace-refresh.R +++ b/scripts/benchmark-workspace-refresh.R @@ -5,8 +5,13 @@ local({ source("sess/R/zzz.R", local = helpers) source("sess/R/handlers.R", local = helpers) encode <- function(snapshot) { - jsonlite::toJSON(list(jsonrpc = "2.0", id = 1L, result = snapshot), - auto_unbox = TRUE, null = "null", force = TRUE, digits = NA) + jsonlite::toJSON( + list(jsonrpc = "2.0", id = 1L, result = snapshot), + auto_unbox = TRUE, + null = "null", + force = TRUE, + digits = NA + ) } for (n in c(1000L, 10000L)) { symbols <- sprintf("workspace_benchmark_%05d", seq_len(n)) @@ -15,16 +20,27 @@ local({ invisible(encode(snapshot)) snapshot <- helpers$get_workspace_data() full <- replicate(5L, unname(system.time(encode(helpers$get_workspace_data()))[["elapsed"]])) - unchanged <- replicate(5L, unname(system.time( - encode(helpers$get_workspace_data(snapshot$revision)) - )[["elapsed"]])) - cat(jsonlite::toJSON(list( - objects = n, - full_median_ms = median(full) * 1000, - unchanged_median_ms = median(unchanged) * 1000, - full_bytes = nchar(encode(snapshot), type = "bytes"), - unchanged_bytes = nchar(encode(helpers$get_workspace_data(snapshot$revision)), type = "bytes") - ), auto_unbox = TRUE), "\n", sep = "") + unchanged <- replicate( + 5L, + unname(system.time(encode(helpers$get_workspace_data(snapshot$revision)))[["elapsed"]]) + ) + cat( + jsonlite::toJSON( + list( + objects = n, + full_median_ms = median(full) * 1000, + unchanged_median_ms = median(unchanged) * 1000, + full_bytes = nchar(encode(snapshot), type = "bytes"), + unchanged_bytes = nchar( + encode(helpers$get_workspace_data(snapshot$revision)), + type = "bytes" + ) + ), + auto_unbox = TRUE + ), + "\n", + sep = "" + ) rm(list = symbols, envir = .GlobalEnv) } }) diff --git a/sess/R/dispatch.R b/sess/R/dispatch.R index 910fa08cc..ac14cac18 100644 --- a/sess/R/dispatch.R +++ b/sess/R/dispatch.R @@ -2,10 +2,15 @@ #' @keywords internal ipc_write <- function(data) { # Forked workers must never interleave frames on the parent Interactive socket. - if (isTRUE(.sess_env$interactive_connected) && - !identical(.sess_env$interactive_pid, Sys.getpid())) return(invisible(FALSE)) + if ( + isTRUE(.sess_env$interactive_connected) && !identical(.sess_env$interactive_pid, Sys.getpid()) + ) { + return(invisible(FALSE)) + } con <- .sess_env$con - if (is.null(con)) return(invisible(FALSE)) + if (is.null(con)) { + return(invisible(FALSE)) + } json <- jsonlite::toJSON(data, auto_unbox = TRUE, null = "null", force = TRUE, digits = NA) line <- c(charToRaw(enc2utf8(json)), as.raw(0x0a)) @@ -41,11 +46,7 @@ rpc_send <- function(method, params = list(), request = FALSE) { return(invisible(FALSE)) } - msg <- list( - jsonrpc = "2.0", - method = method, - params = params - ) + msg <- list(jsonrpc = "2.0", method = method, params = params) req_id <- NULL if (request) { @@ -54,7 +55,9 @@ rpc_send <- function(method, params = list(), request = FALSE) { } sent <- ipc_write(msg) - if (!isTRUE(sent)) return(invisible(FALSE)) + if (!isTRUE(sent)) { + return(invisible(FALSE)) + } if (!request) { invisible(TRUE) @@ -66,7 +69,9 @@ rpc_send <- function(method, params = list(), request = FALSE) { Sys.sleep(0.01) } - if (is.null(.sess_env$con)) return(invisible(FALSE)) + if (is.null(.sess_env$con)) { + return(invisible(FALSE)) + } response <- .sess_env$pending_responses[[req_id]] .sess_env$pending_responses[[req_id]] <- NULL @@ -96,6 +101,4 @@ notify_client <- function(method, params = list()) { #' @param action String of the action name #' @param args List of arguments #' @export -request_client <- function(action, args = list()) { - rpc_send(action, args, request = TRUE) -} +request_client <- function(action, args = list()) rpc_send(action, args, request = TRUE) diff --git a/sess/R/handlers.R b/sess/R/handlers.R index 4f3f615f0..2ae69706c 100644 --- a/sess/R/handlers.R +++ b/sess/R/handlers.R @@ -1,13 +1,15 @@ # Handlers for the client Pull Requests (HTTP GET/POST) capture_str <- function(object, max_level = 0L) { - paste0(utils::capture.output( - utils::str(object, + paste0( + utils::capture.output(utils::str( + object, max.level = max_level, give.attr = FALSE, vec.len = 1L - ) - ), collapse = "\n") + )), + collapse = "\n" + ) } try_capture_str <- function(object, max_level = 0L) { @@ -17,9 +19,7 @@ try_capture_str <- function(object, max_level = 0L) { ) } -workspace_env_names <- function(env) { - ls(env, sorted = FALSE) -} +workspace_env_names <- function(env) ls(env, sorted = FALSE) workspace_child_count <- function(object) { # POSIXlt is list-backed, but [[ returns another date-time, not a child list. @@ -39,25 +39,45 @@ workspace_child_count <- function(object) { # Read structural metadata without invoking arbitrary S3 inspection methods. # Expensive/custom completion still runs through handle_complete() on demand. workspace_length <- function(object) { - if (is.environment(object)) return(length(workspace_env_names(object))) - if (isS4(object)) return(NULL) - if (inherits(object, "POSIXlt")) return(length(.subset2(object, 1L))) - if (is.data.frame(object)) return(length(attr(object, "names", exact = TRUE))) - if (!is.object(object)) return(length(object)) + if (is.environment(object)) { + return(length(workspace_env_names(object))) + } + if (isS4(object)) { + return(NULL) + } + if (inherits(object, "POSIXlt")) { + return(length(.subset2(object, 1L))) + } + if (is.data.frame(object)) { + return(length(attr(object, "names", exact = TRUE))) + } + if (!is.object(object)) { + return(length(object)) + } dimensions <- attr(object, "dim", exact = TRUE) - if (!is.null(dimensions)) return(prod(dimensions)) + if (!is.null(dimensions)) { + return(prod(dimensions)) + } object_names <- attr(object, "names", exact = TRUE) - if (!is.null(object_names)) return(length(object_names)) - if (typeof(object) %in% c("closure", "builtin")) return(1L) + if (!is.null(object_names)) { + return(length(object_names)) + } + if (typeof(object) %in% c("closure", "builtin")) { + return(1L) + } # unclass() can copy an entire classed vector. Check dispatch before using the # primitive length instead; unknown custom lengths belong to explicit queries. registry <- get(".__S3MethodsTable__.", envir = .BaseNamespaceEnv, inherits = FALSE) - has_method <- any(vapply(paste0("length.", c(class(object), "default")), function(method) { - # exists(mode = "any") does not force active bindings or promises. Treat an - # ambiguous binding as a method; getS3method's function lookup would force it. - exists(method, envir = .GlobalEnv, mode = "any", inherits = TRUE) || - exists(method, envir = registry, mode = "any", inherits = FALSE) - }, logical(1))) + has_method <- any(vapply( + paste0("length.", c(class(object), "default")), + function(method) { + # exists(mode = "any") does not force active bindings or promises. Treat an + # ambiguous binding as a method; getS3method's function lookup would force it. + exists(method, envir = .GlobalEnv, mode = "any", inherits = TRUE) || + exists(method, envir = registry, mode = "any", inherits = FALSE) + }, + logical(1) + )) if (has_method) NULL else length(object) } @@ -106,11 +126,14 @@ get_workspace_data <- function(revision = NULL) { } else if (isS4(obj)) { length(methods::slotNames(obj)) > 0L } else { - !inherits(obj, "POSIXlt") && obj_type %in% c("list", "pairlist") && + !inherits(obj, "POSIXlt") && + obj_type %in% c("list", "pairlist") && (is.null(obj_length) || obj_length > 0L) } ) - if (is.null(obj_length)) info$length <- NULL + if (is.null(obj_length)) { + info$length <- NULL + } obj_names <- if (obj_type %in% c("list", "pairlist")) { attr(obj, "names", exact = TRUE) @@ -132,11 +155,7 @@ get_workspace_data <- function(revision = NULL) { }) names(objs) <- all_names - snapshot <- list( - globalenv = objs, - search = search()[-1], - loaded_namespaces = loadedNamespaces() - ) + snapshot <- list(globalenv = objs, search = search()[-1], loaded_namespaces = loadedNamespaces()) # Compare metadata after inspecting every binding: reference objects can mutate # in place, and R task callbacks do not cover every embedding's evaluation. if (!identical(snapshot, .sess_env$workspace_snapshot)) { @@ -144,8 +163,12 @@ get_workspace_data <- function(revision = NULL) { .sess_env$workspace_revision <- (.sess_env$workspace_revision %||% 0) + 1 } current_revision <- .sess_env$workspace_revision - if (length(revision) == 1L && is.numeric(revision) && - is.finite(revision) && identical(as.numeric(revision), current_revision)) { + if ( + length(revision) == 1L && + is.numeric(revision) && + is.finite(revision) && + identical(as.numeric(revision), current_revision) + ) { return(list(revision = current_revision, unchanged = TRUE)) } c(snapshot, list(revision = current_revision)) @@ -154,7 +177,8 @@ get_workspace_data <- function(revision = NULL) { workspace_object <- function(name, path = list()) { object <- get(name, envir = .GlobalEnv, inherits = FALSE) for (selector in path) { - object <- switch(selector$kind, + object <- switch( + selector$kind, index = object[[as.integer(selector$value)]], name = get(selector$value, envir = object, inherits = FALSE), slot = methods::slot(object, selector$value), @@ -189,10 +213,13 @@ workspace_child_label <- function(name, index) { workspace_show_view <- function(object, title, owner, context = NULL) { previous <- .sess_env$view_owner previous_context <- .sess_env$listview_context - on.exit({ - .sess_env$view_owner <- previous - .sess_env$listview_context <- previous_context - }, add = TRUE) + on.exit( + { + .sess_env$view_owner <- previous + .sess_env$listview_context <- previous_context + }, + add = TRUE + ) .sess_env$view_owner <- owner .sess_env$listview_context <- context utils::View(object, title = title) @@ -208,8 +235,11 @@ handle_workspace_view <- function(name, path = list()) { # Lists and vectors share one viewer; only their row presentation differs. listview_supported <- function(object) { !dataview_is_table(object) && - (is.list(object) || is.pairlist(object) || is.environment(object) || isS4(object) || - listview_is_vector(object)) + (is.list(object) || + is.pairlist(object) || + is.environment(object) || + isS4(object) || + listview_is_vector(object)) } listview_is_vector <- function(object) { @@ -217,10 +247,21 @@ listview_is_vector <- function(object) { } listview_state <- function(object, title, owner) { - kind <- if (is.environment(object)) "name" else if (isS4(object)) "slot" else "index" + kind <- if (is.environment(object)) { + "name" + } else if (isS4(object)) { + "slot" + } else { + "index" + } list( - type = "list", data = object, title = title, owner = owner, kind = kind, - names = switch(kind, + type = "list", + data = object, + title = title, + owner = owner, + kind = kind, + names = switch( + kind, name = workspace_env_names(object), slot = methods::slotNames(object), index = names(object) @@ -232,7 +273,10 @@ listview_state <- function(object, title, owner) { # Resolve workspace selectors once; navigation paths are relative to the retained root. listview_context <- function(root, selectors, expression_env = NULL) { location <- listview_location( - root, selectors, resolve_selectors = TRUE, expression_env = expression_env + root, + selectors, + resolve_selectors = TRUE, + expression_env = expression_env ) list(root = root, data = location$data, navigation = listview_navigation(location)) } @@ -242,87 +286,121 @@ listview_binding <- function(name, envir) { while (!identical(envir, emptyenv()) && !exists(name, envir = envir, inherits = FALSE)) { envir <- parent.env(envir) } - if (identical(envir, emptyenv()) || bindingIsActive(name, envir)) return(NULL) + if (identical(envir, emptyenv()) || bindingIsActive(name, envir)) { + return(NULL) + } get(name, envir = envir, inherits = FALSE) } # Only known structural extraction can be represented by an index breadcrumb. listview_structural_extraction <- function(object, operator, envir) { - if (operator == "@") return(isS4(object)) - if (!is.object(object)) return(TRUE) - if (isS4(object) || !identical(class(object), "data.frame")) return(FALSE) - if (operator == "$" && - !is.null(utils::getS3method("$", "data.frame", optional = TRUE, envir = envir))) { + if (operator == "@") { + return(isS4(object)) + } + if (!is.object(object)) { + return(TRUE) + } + if (isS4(object) || !identical(class(object), "data.frame")) { + return(FALSE) + } + if ( + operator == "$" && + !is.null(utils::getS3method("$", "data.frame", optional = TRUE, envir = envir)) + ) { return(FALSE) } # Check both the caller's extraction and the viewer's later indexed traversal. - all(vapply(list(envir, environment(listview_location)), function(method_env) { - identical(utils::getS3method("[[", "data.frame", optional = TRUE, envir = method_env), - base::`[[.data.frame`) - }, logical(1))) + all(vapply( + list(envir, environment(listview_location)), + function(method_env) { + identical( + utils::getS3method("[[", "data.frame", optional = TRUE, envir = method_env), + base::`[[.data.frame` + ) + }, + logical(1) + )) } # Direct View(x$a) calls can also start with a complete breadcrumb path. listview_expression_context <- function(expression, envir, owner, value) { - tryCatch({ - selectors <- list() - while (is.call(expression) && length(expression) == 3L && - is.symbol(expression[[1L]])) { - operator <- as.character(expression[[1L]]) - if (!operator %in% c("$", "[[", "@")) return(NULL) - if (!identical(listview_binding(operator, envir), get(operator, envir = baseenv()))) { + tryCatch( + { + selectors <- list() + while (is.call(expression) && length(expression) == 3L && is.symbol(expression[[1L]])) { + operator <- as.character(expression[[1L]]) + if (!operator %in% c("$", "[[", "@")) { + return(NULL) + } + if (!identical(listview_binding(operator, envir), get(operator, envir = baseenv()))) { + return(NULL) + } + selector <- expression[[3L]] + if (operator %in% c("$", "@") && is.symbol(selector)) { + selector <- as.character(selector) + } + if (length(selector) != 1L || !(is.character(selector) || is.numeric(selector))) { + return(NULL) + } + selectors <- c(list(list(kind = operator, value = selector)), selectors) + expression <- expression[[2L]] + } + if (!length(selectors) || !is.symbol(expression)) { return(NULL) } - selector <- expression[[3L]] - if (operator %in% c("$", "@") && is.symbol(selector)) selector <- as.character(selector) - if (length(selector) != 1L || !(is.character(selector) || is.numeric(selector))) return(NULL) - selectors <- c(list(list(kind = operator, value = selector)), selectors) - expression <- expression[[2L]] - } - if (!length(selectors) || !is.symbol(expression)) return(NULL) - name <- as.character(expression) - object <- listview_binding(name, envir) - if (is.null(object) || !listview_structural_extraction(object, selectors[[1L]]$kind, envir)) { - return(NULL) - } - root <- listview_state(object, name, owner) - context <- listview_context(root, selectors, expression_env = envir) - # Even a safe path is optional: the already-evaluated argument is authoritative. - if (!identical(context$data, value)) return(NULL) - context - }, error = function(e) NULL) + name <- as.character(expression) + object <- listview_binding(name, envir) + if (is.null(object) || !listview_structural_extraction(object, selectors[[1L]]$kind, envir)) { + return(NULL) + } + root <- listview_state(object, name, owner) + context <- listview_context(root, selectors, expression_env = envir) + # Even a safe path is optional: the already-evaluated argument is authoritative. + if (!identical(context$data, value)) return(NULL) + context + }, + error = function(e) NULL + ) } listview_navigation <- function(location) { list( - title = location$title, path = I(location$path), breadcrumbs = I(location$breadcrumbs), + title = location$title, + path = I(location$path), + breadcrumbs = I(location$breadcrumbs), vector = listview_is_vector(location$data) ) } handle_listview_navigate <- function(view_id, path = list()) { state <- dataview_get_state(view_id) - if (!identical(state$type, "list")) stop("Not a list view") + if (!identical(state$type, "list")) { + stop("Not a list view") + } location <- listview_location(state, path) if (dataview_is_table(location$data)) { - return(workspace_show_view( - location$data, - location$title, - state$owner %||% state$title - )) + return(workspace_show_view(location$data, location$title, state$owner %||% state$title)) + } + if (!listview_supported(location$data)) { + stop("Not a list view") } - if (!listview_supported(location$data)) stop("Not a list view") listview_navigation(location) } -listview_location <- function(state, path = list(), resolve_selectors = FALSE, - expression_env = NULL) { +listview_location <- function( + state, + path = list(), + resolve_selectors = FALSE, + expression_env = NULL +) { visited <- integer() state$breadcrumbs <- list(list(label = state$title, path = I(list()))) for (index in path) { if (resolve_selectors) { - if (!is.null(expression_env) && - !listview_structural_extraction(state$data, index$kind, expression_env)) { + if ( + !is.null(expression_env) && + !listview_structural_extraction(state$data, index$kind, expression_env) + ) { stop("Cannot reconstruct custom extraction as an index path") } index <- if (index$kind %in% c("index", "[[") && is.numeric(index$value)) { @@ -334,17 +412,26 @@ listview_location <- function(state, path = list(), resolve_selectors = FALSE, } } child_count <- if (state$kind == "index") length(state$data) else length(state$names) - if (length(index) != 1L || !is.numeric(index) || is.na(index) || - index != as.integer(index) || index < 1L || index > child_count) { + if ( + length(index) != 1L || + !is.numeric(index) || + is.na(index) || + index != as.integer(index) || + index < 1L || + index > child_count + ) { stop("Invalid list item index") } child_name <- if (is.null(state$names)) NULL else state$names[[index]] - if (state$kind == "name" && - (!exists(child_name, envir = state$data, inherits = FALSE) || - bindingIsActive(child_name, state$data))) { + if ( + state$kind == "name" && + (!exists(child_name, envir = state$data, inherits = FALSE) || + bindingIsActive(child_name, state$data)) + ) { stop("List item is unavailable") } - child <- switch(state$kind, + child <- switch( + state$kind, name = get(child_name, envir = state$data, inherits = FALSE), slot = methods::slot(state$data, child_name), index = state$data[[index]] @@ -357,14 +444,23 @@ listview_location <- function(state, path = list(), resolve_selectors = FALSE, paste0(state$title, "[[", index, "]]") } state$data <- child - state$kind <- if (is.environment(child)) "name" else if (isS4(child)) "slot" else "index" + state$kind <- if (is.environment(child)) { + "name" + } else if (isS4(child)) { + "slot" + } else { + "index" + } visited <- c(visited, index) - state$names <- switch(state$kind, + state$names <- switch( + state$kind, name = { # Reuse the binding snapshot without enumerating the environment again. key <- paste(visited, collapse = "/") - if (is.environment(state$child_names) && - exists(key, envir = state$child_names, inherits = FALSE)) { + if ( + is.environment(state$child_names) && + exists(key, envir = state$child_names, inherits = FALSE) + ) { get(key, envir = state$child_names, inherits = FALSE) } else { child_names <- workspace_env_names(child) @@ -394,13 +490,17 @@ listview_format_values <- function(values) { } if (is.numeric(formatted) && !is.object(formatted)) { # Match the numeric precision sent to the data viewer over IPC. - formatted <- vapply(formatted, function(value) { - if (is.finite(value)) { - as.character(jsonlite::toJSON(value, auto_unbox = TRUE, digits = NA)) - } else { - as.character(value) - } - }, character(1)) + formatted <- vapply( + formatted, + function(value) { + if (is.finite(value)) { + as.character(jsonlite::toJSON(value, auto_unbox = TRUE, digits = NA)) + } else { + as.character(value) + } + }, + character(1) + ) } else if (!is.character(formatted)) { formatted <- format(formatted, trim = TRUE, justify = "none") } @@ -414,10 +514,19 @@ listview_summary <- function(object) { type <- if (is.object(object)) { paste(class(object), collapse = "/") } else { - switch(typeof(object), integer = "int", double = "num", complex = "cplx", - logical = "logi", character = "chr", raw = "raw") + switch( + typeof(object), + integer = "int", + double = "num", + complex = "cplx", + logical = "logi", + character = "chr", + raw = "raw" + ) + } + if (!size) { + return(paste0(type, "(0)")) } - if (!size) return(paste0(type, "(0)")) shape <- if (!is.null(dim(object))) { paste0(" [", paste0("1:", dim(object), collapse = ", "), "]") } else if (size > 1L) { @@ -432,108 +541,131 @@ listview_summary <- function(object) { } else { listview_format_values(values) } - paste0(type, shape, " ", paste(formatted, collapse = " "), - if (size > preview_size) " ...") + paste0(type, shape, " ", paste(formatted, collapse = " "), if (size > preview_size) " ...") } else { trimws(try_capture_str(object)) } } get_workspace_children <- function(name = NULL, path = list(), start = 1L, view_id = NULL) { - tryCatch({ - vector_rows <- FALSE - if (is.null(view_id)) { - object <- workspace_object(name, path) - kind <- if (is.environment(object)) "name" else if (isS4(object)) "slot" else "index" - child_names <- switch(kind, - name = workspace_env_names(object), - slot = methods::slotNames(object), - index = names(object) - ) - } else { - state <- dataview_get_state(view_id) - if (!identical(state$type, "list")) stop("Not a list view") - state <- listview_location(state, path) - object <- state$data - vector_rows <- listview_is_vector(object) - kind <- if (vector_rows) "index" else state$kind - child_names <- if (vector_rows) names(object) else state$names - } - child_count <- if (kind == "index") { - if (vector_rows) { - length(object) + tryCatch( + { + vector_rows <- FALSE + if (is.null(view_id)) { + object <- workspace_object(name, path) + kind <- if (is.environment(object)) { + "name" + } else if (isS4(object)) { + "slot" + } else { + "index" + } + child_names <- switch( + kind, + name = workspace_env_names(object), + slot = methods::slotNames(object), + index = names(object) + ) } else { - workspace_child_count(object) + state <- dataview_get_state(view_id) + if (!identical(state$type, "list")) { + stop("Not a list view") + } + state <- listview_location(state, path) + object <- state$data + vector_rows <- listview_is_vector(object) + kind <- if (vector_rows) "index" else state$kind + child_names <- if (vector_rows) names(object) else state$names } - } else { - length(child_names) - } - start <- max(1L, as.integer(start)) - end <- min(child_count, start + workspace_child_page_size - 1L) - if (start > end) { - return(list(children = I(list()), next_start = NULL)) - } - formatted_values <- if (vector_rows) listview_format_values(object[seq.int(start, end)]) - - children <- lapply(seq.int(start, end), function(index) { - child_name <- if (is.null(child_names)) NULL else child_names[[index]] - label <- if (vector_rows) { - if (!is.null(child_name) && !is.na(child_name) && nzchar(child_name)) { - child_name + child_count <- if (kind == "index") { + if (vector_rows) { + length(object) } else { - paste0("[", index, "]") + workspace_child_count(object) } - } else if (kind == "slot") { - paste0("@ ", child_name) } else { - workspace_child_label(child_name, index) + length(child_names) } - unavailable <- if (kind == "name" && !exists(child_name, envir = object, inherits = FALSE)) { - "removed" - } else if (kind == "name" && bindingIsActive(child_name, object)) { - "active_binding" - } else { - NULL + start <- max(1L, as.integer(start)) + end <- min(child_count, start + workspace_child_page_size - 1L) + if (start > end) { + return(list(children = I(list()), next_start = NULL)) } - if (!is.null(unavailable)) { - summary <- if (unavailable == "removed") "(removed)" else "(active-binding)" - if (!is.null(view_id)) { - return(list(label = label, str = summary, viewable = FALSE, index = index)) + formatted_values <- if (vector_rows) listview_format_values(object[seq.int(start, end)]) + + children <- lapply(seq.int(start, end), function(index) { + child_name <- if (is.null(child_names)) NULL else child_names[[index]] + label <- if (vector_rows) { + if (!is.null(child_name) && !is.na(child_name) && nzchar(child_name)) { + child_name + } else { + paste0("[", index, "]") + } + } else if (kind == "slot") { + paste0("@ ", child_name) + } else { + workspace_child_label(child_name, index) } - return(list( - str = paste0(label, ": ", summary), class = unavailable, - type = unavailable, has_children = FALSE - )) - } - child <- if (!vector_rows) switch(kind, - name = get(child_name, envir = object, inherits = FALSE), - slot = methods::slot(object, child_name), - index = object[[index]] - ) - summary <- if (vector_rows) { - formatted_values[[index - start + 1L]] - } else { - listview_summary(child) - } - if (!is.null(view_id)) { - list( - label = label, str = summary, viewable = !vector_rows, index = index, - has_children = !vector_rows && workspace_child_count(child) > 0L - ) - } else { - selector <- if (kind == "index") { - list(kind = kind, value = index, name = child_name) + unavailable <- if ( + kind == "name" && !exists(child_name, envir = object, inherits = FALSE) + ) { + "removed" + } else if (kind == "name" && bindingIsActive(child_name, object)) { + "active_binding" + } else { + NULL + } + if (!is.null(unavailable)) { + summary <- if (unavailable == "removed") "(removed)" else "(active-binding)" + if (!is.null(view_id)) { + return(list(label = label, str = summary, viewable = FALSE, index = index)) + } + return(list( + str = paste0(label, ": ", summary), + class = unavailable, + type = unavailable, + has_children = FALSE + )) + } + child <- if (!vector_rows) { + switch( + kind, + name = get(child_name, envir = object, inherits = FALSE), + slot = methods::slot(object, child_name), + index = object[[index]] + ) + } + summary <- if (vector_rows) { + formatted_values[[index - start + 1L]] + } else { + listview_summary(child) + } + if (!is.null(view_id)) { + list( + label = label, + str = summary, + viewable = !vector_rows, + index = index, + has_children = !vector_rows && workspace_child_count(child) > 0L + ) } else { - list(kind = kind, value = child_name) + selector <- if (kind == "index") { + list(kind = kind, value = index, name = child_name) + } else { + list(kind = kind, value = child_name) + } + workspace_child_item(child, paste0(label, ": ", summary), selector) } - workspace_child_item(child, paste0(label, ": ", summary), selector) + }) + list(children = I(children), next_start = if (end < child_count) end + 1L else NULL) + }, + error = function(e) { + if (!is.null(view_id)) { + stop(e) } - }) - list(children = I(children), next_start = if (end < child_count) end + 1L else NULL) - }, error = function(e) { - if (!is.null(view_id)) stop(e) - list(children = I(list()), next_start = NULL) - }) + list(children = I(list()), next_start = NULL) + } + ) } handle_listview_view <- function(view_id, index, path = list()) { @@ -543,7 +675,9 @@ handle_listview_view <- function(view_id, index, path = list()) { } path <- c(path, list(index)) location <- tryCatch(listview_location(state, path), error = function(e) NULL) - if (is.null(location)) return(FALSE) + if (is.null(location)) { + return(FALSE) + } if (listview_supported(location$data)) { return(listview_navigation(location)) } @@ -589,11 +723,7 @@ handle_complete <- function(expr_str, trigger = NULL) { return(lapply(nms, function(n) { item <- obj[[n]] - list( - name = n, - type = typeof(item), - str = paste0(class(item), collapse = ", ") - ) + list(name = n, type = typeof(item), str = paste0(class(item), collapse = ", ")) })) } @@ -601,11 +731,7 @@ handle_complete <- function(expr_str, trigger = NULL) { nms <- methods::slotNames(obj) return(lapply(nms, function(n) { item <- methods::slot(obj, n) - list( - name = n, - type = typeof(item), - str = paste0(class(item), collapse = ", ") - ) + list(name = n, type = typeof(item), str = paste0(class(item), collapse = ", ")) })) } @@ -637,19 +763,22 @@ handle_plot_latest <- function(params) { if (format == "svglite") { if (requireNamespace("svglite", quietly = TRUE)) { - do.call(svglite::svglite, c(list( - filename = plot_file, width = width / 72, height = height / 72 - ), dev_args)) + do.call( + svglite::svglite, + c(list(filename = plot_file, width = width / 72, height = height / 72), dev_args) + ) } else { # Fallback to png - do.call(grDevices::png, c(list( - filename = plot_file, width = width, height = height, res = 72 - ), dev_args)) + do.call( + grDevices::png, + c(list(filename = plot_file, width = width, height = height, res = 72), dev_args) + ) } } else { - do.call(grDevices::png, c(list( - filename = plot_file, width = width, height = height, res = 72 - ), dev_args)) + do.call( + grDevices::png, + c(list(filename = plot_file, width = width, height = height, res = 72), dev_args) + ) } on.exit({ @@ -675,12 +804,7 @@ handle_plot_latest <- function(params) { } get_column_def <- function(name, field, value) { - tooltip <- sprintf( - "%s, class: [%s], type: %s", - name, - toString(class(value)), - typeof(value) - ) + tooltip <- sprintf("%s, class: [%s], type: %s", name, toString(class(value)), typeof(value)) units <- attr(value, "units", exact = TRUE) if (!is.null(units)) { tooltip <- sprintf("%s, units: %s", tooltip, toString(units)) @@ -702,8 +826,7 @@ get_column_def <- function(name, field, value) { } else if (inherits(value, "Date")) { type <- "dateColumn" filter <- "agDateColumnFilter" - } else if (inherits(value, "POSIXct") || - inherits(value, "POSIXlt")) { + } else if (inherits(value, "POSIXct") || inherits(value, "POSIXlt")) { type <- "datetimeColumn" filter <- "agDateColumnFilter" } else if (is.logical(value) && !is.object(value)) { @@ -713,7 +836,8 @@ get_column_def <- function(name, field, value) { type <- "textColumn" filter <- "agTextColumnFilter" } - sortable <- is.null(dim(value)) && !is.complex(value) && + sortable <- is.null(dim(value)) && + !is.complex(value) && !(is.list(value) && !inherits(value, "POSIXlt")) && !is.raw(value) if (identical(field, "0")) { @@ -775,9 +899,7 @@ dataview_slice <- function(data, row_idx) { return(as.data.frame(data[row_idx, ])) } if (is.matrix(data) && is.object(data)) { - page <- lapply(seq_len(ncol(data)), function(position) { - data[row_idx, position] - }) + page <- lapply(seq_len(ncol(data)), function(position) data[row_idx, position]) names(page) <- colnames(data) return(as.data.frame(page, optional = TRUE)) } @@ -803,8 +925,7 @@ dataview_to_state <- function(data) { } n <- nrow(data) - colnames <- if (inherits(data, "ArrowTabular") || - inherits(data, "polars_data_frame")) { + colnames <- if (inherits(data, "ArrowTabular") || inherits(data, "polars_data_frame")) { names(data) } else { colnames(data) @@ -828,28 +949,20 @@ dataview_to_state <- function(data) { schema <- dataview_schema(data) cols <- c( list(if (is.null(row_index)) integer() else character()), - lapply(seq_len(ncol(schema)), function(position) { - dataview_column(schema, position) - }) + lapply(seq_len(ncol(schema)), function(position) dataview_column(schema, position)) ) list( data = data, row_index = row_index, - columns = .mapply( - get_column_def, - list(headers, fields, cols), - NULL - ), + columns = .mapply(get_column_def, list(headers, fields, cols), NULL), total_rows = n, query_key = NULL, query_indices = NULL ) } -dataview_columns <- function(state) { - state$columns -} +dataview_columns <- function(state) state$columns dataview_new_id <- function() { repeat { @@ -899,8 +1012,11 @@ dataview_get_state <- function(view_id, refresh = FALSE) { stop("Table columns changed. Reopen Data viewer from the cell to refresh the full table.") } revision <- .sess_env$dataview_revision %||% 0 - if (refresh || !identical(state$revision, revision) || - !identical(state$total_rows, current$total_rows)) { + if ( + refresh || + !identical(state$revision, revision) || + !identical(state$total_rows, current$total_rows) + ) { current$live <- TRUE current$revision <- revision current$state_generation <- state$state_generation @@ -937,12 +1053,18 @@ dataview_preview_text <- function(value) { } dataview_cell_preview <- function(value, depth = 0L, budget = new.env(parent = emptyenv())) { - if (is.null(budget$remaining)) budget$remaining <- 100L + if (is.null(budget$remaining)) { + budget$remaining <- 100L + } size <- if (is.null(dim(value))) length(value) else prod(dim(value)) - if (size > budget$remaining || depth >= 3L || - is.environment(value) || isS4(value) || is.function(value) || - (is.list(value) && is.object(value) && !is.data.frame(value) && - !inherits(value, "POSIXlt"))) { + if ( + size > budget$remaining || + depth >= 3L || + is.environment(value) || + isS4(value) || + is.function(value) || + (is.list(value) && is.object(value) && !is.data.frame(value) && !inherits(value, "POSIXlt")) + ) { shape <- if (is.null(dim(value))) length(value) else dim(value) return(sprintf("<%s [%s]>", class(value)[[1L]], paste(shape, collapse = " x "))) } @@ -973,7 +1095,9 @@ dataview_cell_preview <- function(value, depth = 0L, budget = new.env(parent = e } dataview_format_column <- function(values, truncate = TRUE) { - if (is.character(values)) return(if (truncate) dataview_preview_text(values) else values) + if (is.character(values)) { + return(if (truncate) dataview_preview_text(values) else values) + } # jsonlite's complex formatter rejects the IPC precision setting, digits = NA. if (is.complex(values)) { formatted <- format(values, trim = TRUE, justify = "none") @@ -988,22 +1112,20 @@ dataview_format_column <- function(values, truncate = TRUE) { } # Let the class supply its display, without changing the stored values used for sorting. - formatted <- tryCatch( - format(values, trim = TRUE, justify = "none"), - error = function(e) NULL - ) - if (!is.character(formatted) || !is.null(dim(formatted)) || - length(formatted) != length(values)) { + formatted <- tryCatch(format(values, trim = TRUE, justify = "none"), error = function(e) NULL) + if (!is.character(formatted) || !is.null(dim(formatted)) || length(formatted) != length(values)) { formatted <- tryCatch(as.character(values), error = function(e) NULL) } - if (!is.character(formatted) || !is.null(dim(formatted)) || - length(formatted) != length(values)) { + if (!is.character(formatted) || !is.null(dim(formatted)) || length(formatted) != length(values)) { return(values) } - tryCatch({ - formatted[is.na(values)] <- NA_character_ - formatted - }, error = function(e) values) + tryCatch( + { + formatted[is.na(values)] <- NA_character_ + formatted + }, + error = function(e) values + ) } dataview_match_condition <- function(values, cond) { @@ -1023,9 +1145,9 @@ dataview_match_condition <- function(values, cond) { result <- !is.na(values) & values } else if (is.logical(values) && cond_type == "false") { result <- !is.na(values) & !values - } else if (inherits(values, "Date") || - inherits(values, "POSIXct") || - inherits(values, "POSIXlt")) { + } else if ( + inherits(values, "Date") || inherits(values, "POSIXct") || inherits(values, "POSIXlt") + ) { if (inherits(values, "Date")) { ds <- as.Date(values) d1 <- as.Date(if (is.null(cond$dateFrom)) cond$filter else cond$dateFrom) @@ -1033,16 +1155,11 @@ dataview_match_condition <- function(values, cond) { } else { ds <- as.POSIXct(values) tz <- attr(ds, "tzone", exact = TRUE) %||% "" - d1 <- as.POSIXct( - if (is.null(cond$dateFrom)) cond$filter else cond$dateFrom, - tz = tz - ) - d2 <- as.POSIXct( - if (is.null(cond$dateTo)) cond$filterTo else cond$dateTo, - tz = tz - ) + d1 <- as.POSIXct(if (is.null(cond$dateFrom)) cond$filter else cond$dateFrom, tz = tz) + d2 <- as.POSIXct(if (is.null(cond$dateTo)) cond$filterTo else cond$dateTo, tz = tz) } - result <- switch(cond_type, + result <- switch( + cond_type, equals = ds == d1, notEqual = ds != d1, greaterThan = ds > d1, @@ -1062,7 +1179,8 @@ dataview_match_condition <- function(values, cond) { f1 <- suppressWarnings(as.numeric(cond$filter)) f2 <- suppressWarnings(as.numeric(cond$filterTo)) } - result <- switch(cond_type, + result <- switch( + cond_type, equals = nums == f1, notEqual = nums != f1, greaterThan = nums > f1, @@ -1075,7 +1193,8 @@ dataview_match_condition <- function(values, cond) { } else { text <- tolower(as.character(values)) filter_value <- tolower(as.character(cond$filter %||% "")) - result <- switch(cond_type, + result <- switch( + cond_type, equals = text == filter_value, notEqual = text != filter_value, contains = grepl(filter_value, text, fixed = TRUE), @@ -1099,9 +1218,7 @@ dataview_filter_values <- function(values, model) { return(dataview_match_condition(values, model)) } - matches <- lapply(conditions, function(cond) { - dataview_match_condition(values, cond) - }) + matches <- lapply(conditions, function(cond) dataview_match_condition(values, cond)) if (identical(toupper(model$operator), "OR")) { Reduce(`|`, matches) } else { @@ -1109,9 +1226,7 @@ dataview_filter_values <- function(values, model) { } } -`%||%` <- function(x, y) { - if (is.null(x)) y else x -} +`%||%` <- function(x, y) if (is.null(x)) y else x dataview_field_position <- function(field, column_count) { position <- suppressWarnings(as.integer(field)) + 1L @@ -1147,7 +1262,13 @@ dataview_apply_filter_model <- function(state, filter_model, row_idx) { matched <- if (is.null(matched)) column_match else matched & column_match } - if (is.null(matched)) row_idx else if (is.null(row_idx)) which(matched) else row_idx[matched] + if (is.null(matched)) { + row_idx + } else if (is.null(row_idx)) { + which(matched) + } else { + row_idx[matched] + } } dataview_apply_sort_model <- function(state, sort_model, row_idx) { @@ -1175,10 +1296,7 @@ dataview_apply_sort_model <- function(state, sort_model, row_idx) { raw_values } - sort_specs[[length(sort_specs) + 1L]] <- list( - values = sort_vec, - decreasing = is_desc - ) + sort_specs[[length(sort_specs) + 1L]] <- list(values = sort_vec, decreasing = is_desc) } if (!length(sort_specs)) { @@ -1190,18 +1308,9 @@ dataview_apply_sort_model <- function(state, sort_model, row_idx) { spec <- sort_specs[[i]] values <- if (is.null(row_order)) spec$values else spec$values[row_order] order_index <- if (inherits(values, "integer64")) { - bit64::order( - values, - na.last = TRUE, - decreasing = spec$decreasing - ) + bit64::order(values, na.last = TRUE, decreasing = spec$decreasing) } else { - order( - values, - na.last = TRUE, - decreasing = spec$decreasing, - method = "radix" - ) + order(values, na.last = TRUE, decreasing = spec$decreasing, method = "radix") } row_order <- if (is.null(row_order)) order_index else row_order[order_index] } @@ -1222,8 +1331,9 @@ dataview_query_key <- function(sort_model, filter_model) { } dataview_query_indices <- function(state, sort_model, filter_model) { - if ((is.null(sort_model) || !length(sort_model)) && - (is.null(filter_model) || !length(filter_model))) { + if ( + (is.null(sort_model) || !length(sort_model)) && (is.null(filter_model) || !length(filter_model)) + ) { return(NULL) } @@ -1240,8 +1350,7 @@ dataview_rows <- function(state, row_idx) { } if (is.data.frame(page)) { for (position in seq_len(ncol(page))) { - if (inherits(page[[position]], "POSIXct") || - inherits(page[[position]], "POSIXlt")) { + if (inherits(page[[position]], "POSIXct") || inherits(page[[position]], "POSIXlt")) { page[[position]] <- format(page[[position]], "%Y-%m-%dT%H:%M:%S") } else if (inherits(page[[position]], "integer64")) { page[[position]] <- as.character(page[[position]]) @@ -1250,13 +1359,7 @@ dataview_rows <- function(state, row_idx) { } } } - rows <- cbind( - data.frame( - dataview_column_values(state, 1L, row_idx), - check.names = FALSE - ), - page - ) + rows <- cbind(data.frame(dataview_column_values(state, 1L, row_idx), check.names = FALSE), page) names(rows) <- as.character(seq_len(ncol(rows)) - 1L) rownames(rows) <- NULL rows @@ -1265,11 +1368,7 @@ dataview_rows <- function(state, row_idx) { handle_dataview_init <- function(params) { view_id <- as.character(params$view_id %||% "") state <- dataview_get_state(view_id, refresh = TRUE) - list( - columns = dataview_columns(state), - totalRows = state$total_rows, - live = isTRUE(state$live) - ) + list(columns = dataview_columns(state), totalRows = state$total_rows, live = isTRUE(state$live)) } handle_dataview_page <- function(params) { @@ -1321,12 +1420,15 @@ handle_dataview_page <- function(params) { if (isTRUE(params$formatNumbers)) { # Format only the requested page, using the session's digits, scipen and OutDec. # Keep raw rows unchanged for sorting, filtering and full-precision inspection. - numeric_fields <- vapply(state$columns, function(column) { - column$type == "numericColumn" && column$field != "0" - }, logical(1)) - result$formattedColumns <- lapply(result$rows[numeric_fields], function(values) { - I(format(values, trim = TRUE, justify = "none")) - }) + numeric_fields <- vapply( + state$columns, + function(column) column$type == "numericColumn" && column$field != "0", + logical(1) + ) + result$formattedColumns <- lapply( + result$rows[numeric_fields], + function(values) I(format(values, trim = TRUE, justify = "none")) + ) } result } diff --git a/sess/R/hooks.R b/sess/R/hooks.R index 4c02940cc..99c70d0b2 100644 --- a/sess/R/hooks.R +++ b/sess/R/hooks.R @@ -1,11 +1,17 @@ .resolve_plot_backend <- function(plot_backend) { - if (is.null(plot_backend)) return("auto") + if (is.null(plot_backend)) { + return("auto") + } match.arg(plot_backend, c("auto", "jgd", "httpgd", "standard", "native")) } .select_plot_backend <- function(plot_backend, has_httpgd, has_jgd) { - if (plot_backend == "native") return("native") - if (plot_backend %in% c("auto", "jgd") && has_jgd) return("jgd") + if (plot_backend == "native") { + return("native") + } + if (plot_backend %in% c("auto", "jgd") && has_jgd) { + return("jgd") + } if (plot_backend %in% c("auto", "httpgd") && has_httpgd) return("httpgd") "standard" } @@ -34,16 +40,22 @@ # Send runtime notifications after task callbacks return, so transport failure # cannot remove the currently executing task callback during runtime cleanup. .defer_runtime_notification <- function(method, schedule = later::later) { - if (!isTRUE(.runtime_state()$active)) return(FALSE) + if (!isTRUE(.runtime_state()$active)) { + return(FALSE) + } force(method) generation <- .sess_env$transport_generation - schedule(function() { - if (!isTRUE(.runtime_state()$active) || - !identical(generation, .sess_env$transport_generation)) { - return(invisible(NULL)) - } - notify_client(method) - }, 0) + schedule( + function() { + if ( + !isTRUE(.runtime_state()$active) || !identical(generation, .sess_env$transport_generation) + ) { + return(invisible(NULL)) + } + notify_client(method) + }, + 0 + ) TRUE } @@ -58,9 +70,11 @@ #' @param allow_jgd Logical. Whether the jgd renderer may be selected. #' #' @keywords internal -runtime_start <- function(use_rstudioapi = TRUE, - plot_backend = c("auto", "jgd", "httpgd", "standard", "native"), - allow_jgd = TRUE) { +runtime_start <- function( + use_rstudioapi = TRUE, + plot_backend = c("auto", "jgd", "httpgd", "standard", "native"), + allow_jgd = TRUE +) { plot_backend <- match.arg(plot_backend) if (!(is.logical(allow_jgd) && length(allow_jgd) == 1L && !is.na(allow_jgd))) { stop("allow_jgd must be a single non-NA logical value.", call. = FALSE) @@ -79,13 +93,16 @@ runtime_start <- function(use_rstudioapi = TRUE, state$plot_backend <- plot_backend state$active <- TRUE completed <- FALSE - on.exit({ - if (!completed) { - try(runtime_stop(), silent = TRUE) - } else { - .sess_env$runtime_start_phase <- NULL - } - }, add = TRUE) + on.exit( + { + if (!completed) { + try(runtime_stop(), silent = TRUE) + } else { + .sess_env$runtime_start_phase <- NULL + } + }, + add = TRUE + ) # 1. Override View() to serve table data via paged RPC. .sess_env$runtime_start_phase <- "view" @@ -97,8 +114,11 @@ runtime_start <- function(use_rstudioapi = TRUE, # Capture the root before forcing x so View(x$a) shares the viewer for x. original_expression <- substitute(x) expression <- original_expression - while (is.call(expression) && is.symbol(expression[[1L]]) && - as.character(expression[[1L]]) %in% c("$", "[[", "@")) { + while ( + is.call(expression) && + is.symbol(expression[[1L]]) && + as.character(expression[[1L]]) %in% c("$", "[[", "@") + ) { expression <- expression[[2L]] } owner <- .sess_env$view_owner @@ -107,8 +127,11 @@ runtime_start <- function(use_rstudioapi = TRUE, } force(title) - if (is.null(.sess_env$view_owner) && isTRUE(.sess_env$interactive_connected) && - .interactive_rich_value(x)) { + if ( + is.null(.sess_env$view_owner) && + isTRUE(.sess_env$interactive_connected) && + .interactive_rich_value(x) + ) { return(invisible(NULL)) } @@ -123,8 +146,9 @@ runtime_start <- function(use_rstudioapi = TRUE, owner <- owner %||% title_key registry_key <- paste0(view_type, ":", owner) dataview_registry <- .sess_env$dataview_registry - view_id <- if (nzchar(title_key) && - exists(registry_key, envir = dataview_registry, inherits = FALSE)) { + view_id <- if ( + nzchar(title_key) && exists(registry_key, envir = dataview_registry, inherits = FALSE) + ) { get(registry_key, envir = dataview_registry, inherits = FALSE) } else { id <- dataview_new_id() @@ -137,13 +161,16 @@ runtime_start <- function(use_rstudioapi = TRUE, if (view_type == "table") { registration <- dataview_register(x, view_id = view_id) - notify_client("dataview", list( - title = title, - source = "table", - type = "json", - view_id = registration$view_id, - state_generation = registration$state_generation - )) + notify_client( + "dataview", + list( + title = title, + source = "table", + type = "json", + view_id = registration$view_id, + state_generation = registration$state_generation + ) + ) } else if (view_type == "list") { context <- .sess_env$listview_context if (is.null(context) && missing(title)) { @@ -156,26 +183,27 @@ runtime_start <- function(use_rstudioapi = TRUE, context$navigation } root <- dataview_set_state(view_id, root) - notify_client("dataview", list( - title = title, - source = view_type, - type = "json", - view_id = view_id, - state_generation = root$state_generation, - navigation = navigation - )) + notify_client( + "dataview", + list( + title = title, + source = view_type, + type = "json", + view_id = view_id, + state_generation = root$state_generation, + navigation = navigation + ) + ) } else { code <- if (is.primitive(x)) utils::capture.output(print(x)) else deparse(x) file_path <- .sess_env$dataviews[[view_id]]$file %||% tempfile(tmpdir = .sess_env$tempdir, fileext = ".R") writeLines(code, file_path) .sess_env$dataviews[[view_id]] <- list(type = "object", file = file_path) - notify_client("dataview", list( - title = title, - file = file_path, - source = "object", - type = "R" - )) + notify_client( + "dataview", + list(title = title, file = file_path, source = "object", type = "R") + ) } } .runtime_rebind("View", show_dataview, ns = "utils") @@ -186,9 +214,7 @@ runtime_start <- function(use_rstudioapi = TRUE, function(url, ...) { if (!is.character(url)) { real_url <- NULL - temp_viewer <- function(url, ...) { - real_url <<- url - } + temp_viewer <- function(url, ...) real_url <<- url op <- options(viewer = temp_viewer, page_viewer = temp_viewer, browser = temp_viewer) on.exit(options(op)) print(url) @@ -219,25 +245,23 @@ runtime_start <- function(use_rstudioapi = TRUE, file <- x[1] pkgname <- basename(dirname(dirname(file))) requestPath <- paste0("/library/", pkgname, "/html/", basename(file), ".html") - notify_client("help", list( - requestPath = requestPath - )) + notify_client("help", list(requestPath = requestPath)) } else { utils:::print.help_files_with_topic(x, ...) } invisible(x) } .runtime_register_s3( - "print", "help_files_with_topic", sess_print.help_files_with_topic, + "print", + "help_files_with_topic", + sess_print.help_files_with_topic, envir = asNamespace("utils") ) sess_print.hsearch <- function(x, ...) { if (length(x) >= 1) { requestPath <- paste0("/doc/html/Search?pattern=", tools:::escapeAmpersand(x$pattern)) - notify_client("help", list( - requestPath = requestPath - )) + notify_client("help", list(requestPath = requestPath)) } else { utils:::print.hsearch(x, ...) } @@ -245,8 +269,10 @@ runtime_start <- function(use_rstudioapi = TRUE, } # 4. Plot device: JGD > httpgd > Standard, or no plot integration for native .sess_env$runtime_start_phase <- "plot" - has_jgd <- allow_jgd && plot_backend %in% c("auto", "jgd") && - nzchar(Sys.getenv("JGD_SOCKET")) && requireNamespace("jgd", quietly = TRUE) + has_jgd <- allow_jgd && + plot_backend %in% c("auto", "jgd") && + nzchar(Sys.getenv("JGD_SOCKET")) && + requireNamespace("jgd", quietly = TRUE) # The built-in client requires the 2.x renderer schema, including descr. has_httpgd <- plot_backend %in% c("auto", "httpgd") && requireNamespace("httpgd", quietly = TRUE) && @@ -254,13 +280,17 @@ runtime_start <- function(use_rstudioapi = TRUE, selected_backend <- .select_plot_backend(plot_backend, has_httpgd, has_jgd) if (selected_backend == "jgd") { open_device <- jgd::jgd - .runtime_rebind("jgd", function(...) { - result <- open_device(...) - # Windows defers the renderer welcome until server_info is requested. - # Cache it while connected so explicit devices can be identified on reload. - tryCatch(jgd::jgd_server_info(), error = function(e) NULL) - invisible(result) - }, "jgd") + .runtime_rebind( + "jgd", + function(...) { + result <- open_device(...) + # Windows defers the renderer welcome until server_info is requested. + # Cache it while connected so explicit devices can be identified on reload. + tryCatch(jgd::jgd_server_info(), error = function(e) NULL) + invisible(result) + }, + "jgd" + ) open_jgd_device <- function(key = NULL, recorded = NULL, previous_device_id = NULL, ...) { jgd::jgd(...) .runtime_track_device() @@ -270,20 +300,28 @@ runtime_start <- function(use_rstudioapi = TRUE, } devices <- .runtime_state()$devices devices[[length(devices)]]$key <- key - devices[[length(devices)]]$renderer_device_id <- unname( - jgd::jgd_server_info()$server_info["deviceId"] - ) + devices[[length(devices)]]$renderer_device_id <- unname(jgd::jgd_server_info()$server_info[ + "deviceId" + ]) state$devices <- devices # Carry the logical device identity across a new renderer socket. Device # numbers and JGD's native counter can change when the device is reopened. set_identity <- function(restoring = FALSE) { - jgd::jgd_frame_ext(jsonlite::toJSON(list(vscodeR = list( - sessionId = .session_id(), host = unname(Sys.info()[["nodename"]]), - pid = as.character(Sys.getpid()), - rVer = sprintf("%s.%s", R.version$major, R.version$minor), - processExited = FALSE, deviceId = key, restoring = restoring, - previousDeviceId = previous_device_id - )), auto_unbox = TRUE)) + jgd::jgd_frame_ext(jsonlite::toJSON( + list( + vscodeR = list( + sessionId = .session_id(), + host = unname(Sys.info()[["nodename"]]), + pid = as.character(Sys.getpid()), + rVer = sprintf("%s.%s", R.version$major, R.version$minor), + processExited = FALSE, + deviceId = key, + restoring = restoring, + previousDeviceId = previous_device_id + ) + ), + auto_unbox = TRUE + )) } set_identity(!is.null(recorded)) if (!is.null(recorded)) { @@ -298,8 +336,10 @@ runtime_start <- function(use_rstudioapi = TRUE, previous <- grDevices::dev.cur() # Freeze eligibility before reopening can reuse a closed registration's number. device_entries <- get(".Devices", envir = baseenv()) - retained <- Filter(function(entry) .runtime_device_is_live(entry, device_entries), - .runtime_state()$devices) + retained <- Filter( + function(entry) .runtime_device_is_live(entry, device_entries), + .runtime_state()$devices + ) # Explicit jgd::jgd() calls bypass our device factory. Recover live devices # belonging to VS Code too, leaving other renderers' devices untouched. devs <- grDevices::dev.list() @@ -307,23 +347,33 @@ runtime_start <- function(use_rstudioapi = TRUE, grDevices::dev.set(id) info <- tryCatch(jgd::jgd_server_info(), error = function(e) NULL) previous_device_id <- unname(info$server_info["deviceId"]) - if (length(previous_device_id) != 1L || is.na(previous_device_id) || - !nzchar(previous_device_id)) { + if ( + length(previous_device_id) != 1L || is.na(previous_device_id) || !nzchar(previous_device_id) + ) { previous_device_id <- NULL } # An explicit jgd() can reuse a managed device's number without calling # our factory. Only the renderer's per-connection ID proves continuity. - same_device <- vapply(retained, function(entry) { - entry$id == id && !is.null(previous_device_id) && - identical(entry$renderer_device_id, previous_device_id) - }, logical(1)) - if (any(same_device)) next + same_device <- vapply( + retained, + function(entry) { + entry$id == id && + !is.null(previous_device_id) && + identical(entry$renderer_device_id, previous_device_id) + }, + logical(1) + ) + if (any(same_device)) { + next + } retained <- Filter(function(entry) entry$id != id, retained) if (identical(info$server_name, "jgd-vscode")) { # JGD retains the renderer welcome even after its socket disconnects. # Carry its original identity so reconnect preserves the saved history. retained[[length(retained) + 1L]] <- list( - id = unname(id), name = "jgd", previous_device_id = previous_device_id + id = unname(id), + name = "jgd", + previous_device_id = previous_device_id ) } } @@ -331,7 +381,9 @@ runtime_start <- function(use_rstudioapi = TRUE, for (entry in retained) { devs <- grDevices::dev.list() index <- match(entry$id, devs) - if (is.na(index) || !identical(names(devs)[[index]], entry$name)) next + if (is.na(index) || !identical(names(devs)[[index]], entry$name)) { + next + } if (!identical(entry$name, "jgd")) { .runtime_track_device(entry$id) next @@ -343,8 +395,14 @@ runtime_start <- function(use_rstudioapi = TRUE, dpi <- grDevices::dev.size("px")[[1L]] / size[[1L]] recorded <- tryCatch(grDevices::recordPlot(), error = function(e) NULL) tryCatch(grDevices::dev.off(entry$id), error = function(e) NULL) - open_jgd_device(entry$key, recorded, entry$previous_device_id, - width = size[[1L]], height = size[[2L]], dpi = dpi) + open_jgd_device( + entry$key, + recorded, + entry$previous_device_id, + width = size[[1L]], + height = size[[2L]], + dpi = dpi + ) if (identical(unname(previous), entry$id)) previous <- grDevices::dev.cur() } if (previous %in% grDevices::dev.list()) grDevices::dev.set(previous) @@ -357,22 +415,33 @@ runtime_start <- function(use_rstudioapi = TRUE, # Auto is meant to degrade quietly. if (plot_backend %in% c("jgd", "httpgd")) { if (plot_backend == "jgd" && !allow_jgd) { - warning("[sess] Plot backend \"jgd\" was requested but jgd setup was not available. ", - "Falling back to the standard plot viewer. Check the jgd setup message, ", - "or change the r.plot.backend setting.", call. = FALSE) + warning( + "[sess] Plot backend \"jgd\" was requested but jgd setup was not available. ", + "Falling back to the standard plot viewer. Check the jgd setup message, ", + "or change the r.plot.backend setting.", + call. = FALSE + ) } else if (plot_backend == "jgd" && !requireNamespace("jgd", quietly = TRUE)) { - warning("[sess] Plot backend \"jgd\" was requested but the jgd package ", - "is not installed. Falling back to the standard plot viewer. ", - "Install jgd, or change the r.plot.backend setting.", call. = FALSE) + warning( + "[sess] Plot backend \"jgd\" was requested but the jgd package ", + "is not installed. Falling back to the standard plot viewer. ", + "Install jgd, or change the r.plot.backend setting.", + call. = FALSE + ) } else if (plot_backend == "jgd") { - warning("[sess] Plot backend \"jgd\" was requested but no renderer ", - "connection is available. Falling back to the standard plot ", - "viewer.", call. = FALSE) + warning( + "[sess] Plot backend \"jgd\" was requested but no renderer ", + "connection is available. Falling back to the standard plot ", + "viewer.", + call. = FALSE + ) } else if (plot_backend == "httpgd") { - warning("[sess] Plot backend \"httpgd\" requires httpgd >= 2.0.1. ", - "Falling back to the standard plot viewer. ", - "Install or update httpgd, or change the r.plot.backend setting.", - call. = FALSE) + warning( + "[sess] Plot backend \"httpgd\" requires httpgd >= 2.0.1. ", + "Falling back to the standard plot viewer. ", + "Install or update httpgd, or change the r.plot.backend setting.", + call. = FALSE + ) } } @@ -386,9 +455,13 @@ runtime_start <- function(use_rstudioapi = TRUE, check_null_dev <- function() { cur <- grDevices::dev.cur() id <- getOption("sess.null_dev") - !is.null(id) && cur == id && any(vapply(state$devices, function(entry) { - entry$id == id && .runtime_device_is_live(entry) - }, logical(1))) + !is.null(id) && + cur == id && + any(vapply( + state$devices, + function(entry) entry$id == id && .runtime_device_is_live(entry), + logical(1) + )) } new_plot <- function() { @@ -422,9 +495,7 @@ runtime_start <- function(use_rstudioapi = TRUE, } } }, - error = function(e) { - warning("Error in sess update_plot: ", e$message) - } + error = function(e) warning("Error in sess update_plot: ", e$message) ) TRUE } @@ -434,19 +505,14 @@ runtime_start <- function(use_rstudioapi = TRUE, # Reattach refreshes the record without reopening a viewer the user closed. update_plot(notify = FALSE) - .runtime_add_task_callback(function(...) { - update_plot(...) - }, name = "sess.plot") + .runtime_add_task_callback(function(...) update_plot(...), name = "sess.plot") } # 5. rstudioapi hooks .sess_env$runtime_start_phase <- "rstudioapi" if (use_rstudioapi) { - rstudioapi_hook <- function(...) { - patch_rstudioapi() - } - .runtime_set_hook(packageEvent("rstudioapi", "onLoad"), - rstudioapi_hook, action = "append") + rstudioapi_hook <- function(...) patch_rstudioapi() + .runtime_set_hook(packageEvent("rstudioapi", "onLoad"), rstudioapi_hook, action = "append") if ("rstudioapi" %in% loadedNamespaces()) { patch_rstudioapi() @@ -470,7 +536,9 @@ runtime_start <- function(use_rstudioapi = TRUE, devs <- grDevices::dev.list() for (id in devs[names(devs) %in% c("httpgd", "unigd")]) { url <- tryCatch(httpgd::hgd_url(which = id), error = function(e) NULL) - if (!is.null(url)) notify_client("httpgd", list(url = url, restoring = TRUE)) + if (!is.null(url)) { + notify_client("httpgd", list(url = url, restoring = TRUE)) + } if (!isTRUE(state$active)) break } } diff --git a/sess/R/interactive.R b/sess/R/interactive.R index 03e935025..78beb36c9 100644 --- a/sess/R/interactive.R +++ b/sess/R/interactive.R @@ -1,32 +1,49 @@ # Rich events use pure R IPC; small stdout markers preserve console ordering. .interactive_event <- function(type, data = list()) { - if (!identical(.sess_env$interactive_pid, Sys.getpid())) return(invisible(NULL)) + if (!identical(.sess_env$interactive_pid, Sys.getpid())) { + return(invisible(NULL)) + } id <- .sess_env$interactive_id event <- c(list(type = type, executionId = if (is.null(id)) "" else id), data) json <- as.character(jsonlite::toJSON( - event, auto_unbox = TRUE, null = "null", na = "null", digits = NA + event, + auto_unbox = TRUE, + null = "null", + na = "null", + digits = NA )) # Bound encoded events before writing to the agent transport. # Agent-side display limits run only after parsing and cannot protect it from # oversized HTML, wide tables, or strings enlarged by JSON escaping. if (nchar(json, type = "bytes") > 2 * 1024 * 1024) { - json <- as.character(jsonlite::toJSON(list( - type = "truncated", executionId = if (is.null(id)) "" else id, - message = "Rich output exceeds 2 MiB; display a smaller preview or save it to a file." - ), auto_unbox = TRUE)) + json <- as.character(jsonlite::toJSON( + list( + type = "truncated", + executionId = if (is.null(id)) "" else id, + message = "Rich output exceeds 2 MiB; display a smaller preview or save it to a file." + ), + auto_unbox = TRUE + )) } if (isTRUE(.sess_env$interactive_managed)) { .sess_env$interactive_event_counter <- .sess_env$interactive_event_counter + 1L event_id <- .sess_env$interactive_event_counter - rpc_send("interactive_event", list(eventId = event_id, - event = jsonlite::fromJSON(json, simplifyVector = FALSE))) + rpc_send( + "interactive_event", + list(eventId = event_id, event = jsonlite::fromJSON(json, simplifyVector = FALSE)) + ) reference <- jsonlite::toJSON(list(type = "event", eventId = event_id), auto_unbox = TRUE) encoded <- jsonlite::base64_enc(charToRaw(reference)) marker <- paste0("\036", .sess_env$interactive_token, ":", encoded, "\037") # A stderr fence ensures the agent drains both pipes before finishing a cell. if (type == "finished") { - fence <- paste0("\036", .sess_env$interactive_token, ":", - jsonlite::base64_enc(charToRaw('{"type":"flush"}')), "\037") + fence <- paste0( + "\036", + .sess_env$interactive_token, + ":", + jsonlite::base64_enc(charToRaw('{"type":"flush"}')), + "\037" + ) .interactive_write(.sess_env$interactive_stderr, fence) } .interactive_write(.sess_env$interactive_stdout, marker) @@ -45,15 +62,19 @@ } .interactive_plot_context <- function(open_group = TRUE) { - if (requireNamespace("jgd", quietly = TRUE) && - "jgd" %in% names(grDevices::dev.list())) { + if (requireNamespace("jgd", quietly = TRUE) && "jgd" %in% names(grDevices::dev.list())) { id <- .sess_env$interactive_id context <- as.character(jsonlite::toJSON( - list(executionId = if (is.null(id)) "" else id, - vscodeRExecutionId = if (is.null(id)) "" else id), auto_unbox = TRUE + list( + executionId = if (is.null(id)) "" else id, + vscodeRExecutionId = if (is.null(id)) "" else id + ), + auto_unbox = TRUE )) if (!is.null(id)) { - if (!identical(names(grDevices::dev.cur()), "jgd")) return(invisible(NULL)) + if (!identical(names(grDevices::dev.cur()), "jgd")) { + return(invisible(NULL)) + } try(jgd::jgd_frame_ext(context), silent = TRUE) device <- as.integer(grDevices::dev.cur()) if (open_group && !device %in% .sess_env$interactive_plot_groups) { @@ -62,15 +83,21 @@ } } else { selected <- grDevices::dev.cur() - if (identical(names(selected), "jgd")) try(jgd::jgd_frame_ext(context), silent = TRUE) + if (identical(names(selected), "jgd")) { + try(jgd::jgd_frame_ext(context), silent = TRUE) + } devices <- grDevices::dev.list() - for (device in intersect(.sess_env$interactive_plot_groups, - devices[names(devices) == "jgd"])) { + for (device in intersect( + .sess_env$interactive_plot_groups, + devices[names(devices) == "jgd"] + )) { grDevices::dev.set(device) try(jgd::jgd_end_group(), silent = TRUE) try(jgd::jgd_frame_ext(context), silent = TRUE) } - if (selected %in% grDevices::dev.list()) grDevices::dev.set(selected) + if (selected %in% grDevices::dev.list()) { + grDevices::dev.set(selected) + } .sess_env$interactive_plot_groups <- integer() } } @@ -78,8 +105,9 @@ .interactive_plot_new_page <- function() { device <- as.integer(grDevices::dev.cur()) - if (identical(names(grDevices::dev.cur()), "jgd") && - device %in% .sess_env$interactive_plot_groups) { + if ( + identical(names(grDevices::dev.cur()), "jgd") && device %in% .sess_env$interactive_plot_groups + ) { # Close our execution marker before JGD resets its groups at a page boundary. try(jgd::jgd_end_group(), silent = TRUE) .sess_env$interactive_plot_groups <- setdiff(.sess_env$interactive_plot_groups, device) @@ -96,12 +124,16 @@ interactive_start <- function(config, managed = FALSE) { stop("This R process already belongs to an Interactive agent") } cfg <- jsonlite::read_json(config, simplifyVector = TRUE) - if (!interactive()) stop("The Interactive worker requires an interactive R frontend") + if (!interactive()) { + stop("The Interactive worker requires an interactive R frontend") + } options(sess.quiet = TRUE) .sess_env$interactive_token <- cfg$token Sys.setenv(JGD_SOCKET = cfg$jgd, SESS_ENDPOINT = cfg$sess) connect(endpoint = cfg$sess, plot_backend = if (isTRUE(cfg$useJgd)) "jgd" else "standard") - if (is.null(.sess_env$con)) stop("Could not connect to the session agent") + if (is.null(.sess_env$con)) { + stop("Could not connect to the session agent") + } .sess_env$interactive_pid <- Sys.getpid() .sess_env$interactive_managed <- managed .sess_env$interactive_event_counter <- 0L @@ -123,11 +155,17 @@ interactive_start <- function(config, managed = FALSE) { .sess_env$interactive_last_plot_data <- NULL if (isTRUE(cfg$useJgd)) { select_device <- grDevices::dev.set - .runtime_rebind("dev.set", function(which = grDevices::dev.next()) { - result <- select_device(which) - if (!is.null(.sess_env$interactive_id)) .interactive_plot_context() - invisible(result) - }, ns = "grDevices") + .runtime_rebind( + "dev.set", + function(which = grDevices::dev.next()) { + result <- select_device(which) + if (!is.null(.sess_env$interactive_id)) { + .interactive_plot_context() + } + invisible(result) + }, + ns = "grDevices" + ) } # Hooks also run through references already imported by stats/lattice. # Rebinding plot.new/grid.newpage misses those references and loses pages. @@ -139,7 +177,8 @@ interactive_start <- function(config, managed = FALSE) { current <- grDevices::dev.cur() owned <- current == 1L || current == getOption("sess.null_dev", -1L) # plot.new is also called for each panel of mfrow/mfcol/layout. - new_page <- !isTRUE(.sess_env$interactive_capturing) && owned && + new_page <- !isTRUE(.sess_env$interactive_capturing) && + owned && (grid_page || current == 1L || isTRUE(graphics::par("page"))) if (new_page) { .interactive_capture_plot() @@ -158,13 +197,15 @@ interactive_start <- function(config, managed = FALSE) { } device <- getOption("device") if (is.function(device)) { - options(device = local({ - original <- device - function(...) { - original(...) - .interactive_plot_context(open_group = FALSE) - } - })) + options( + device = local({ + original <- device + function(...) { + original(...) + .interactive_plot_context(open_group = FALSE) + } + }) + ) } if (!managed) { .sess_env$interactive_skip_task <- TRUE @@ -174,16 +215,25 @@ interactive_start <- function(config, managed = FALSE) { return(TRUE) } if (is.null(.sess_env$interactive_id)) { - .interactive_event("external", list(code = paste(deparse(expr), collapse = "\n"), - success = ok)) + .interactive_event( + "external", + list(code = paste(deparse(expr), collapse = "\n"), success = ok) + ) } TRUE }) } - .interactive_event("ready", list(pid = Sys.getpid(), version = R.version.string, - rPath = file.path(R.home("bin"), "R"), - libraryPaths = as.list(.libPaths()), - sessionId = .session_id(), nativeConsole = FALSE)) + .interactive_event( + "ready", + list( + pid = Sys.getpid(), + version = R.version.string, + rPath = file.path(R.home("bin"), "R"), + libraryPaths = as.list(.libPaths()), + sessionId = .session_id(), + nativeConsole = FALSE + ) + ) invisible(NULL) } @@ -195,8 +245,12 @@ interactive_start <- function(config, managed = FALSE) { #' @keywords internal interactive_execute <- function(id, code, source = NULL) { .sess_env$interactive_skip_task <- TRUE - if (!isTRUE(.sess_env$interactive_connected)) stop("No Interactive agent connected") - if (!is.null(.sess_env$interactive_id)) stop("R is already executing an Interactive request") + if (!isTRUE(.sess_env$interactive_connected)) { + stop("No Interactive agent connected") + } + if (!is.null(.sess_env$interactive_id)) { + stop("R is already executing an Interactive request") + } if (!is.character(id) || length(id) != 1L || !grepl("^[a-zA-Z0-9_-]{1,100}$", id)) { stop("Invalid execution identifier") } @@ -206,13 +260,16 @@ interactive_execute <- function(id, code, source = NULL) { assign(id, TRUE, envir = .sess_env$interactive_seen) .sess_env$interactive_id <- id .sess_env$interactive_plot_groups <- integer() - on.exit({ - # Live full-table viewers must discard cached filter/sort indices after code - # may have edited their data by reference (including failed executions). - .sess_env$dataview_revision <- (.sess_env$dataview_revision %||% 0) + 1 - .sess_env$interactive_id <- NULL - .interactive_plot_context() - }, add = TRUE) + on.exit( + { + # Live full-table viewers must discard cached filter/sort indices after code + # may have edited their data by reference (including failed executions). + .sess_env$dataview_revision <- (.sess_env$dataview_revision %||% 0) + 1 + .sess_env$interactive_id <- NULL + .interactive_plot_context() + }, + add = TRUE + ) state <- "success" trace_state <- new.env(parent = emptyenv()) trace_state$depth <- 0L @@ -228,21 +285,43 @@ interactive_execute <- function(id, code, source = NULL) { if (length(frames) >= 3L && identical(calls[[frames[[1L]]]], wrapper)) { frames <- frames[-seq_len(3L)] } - handlers <- list(on_error, on_warning, on_message, diagnostic, - base::.handleSimpleError, base::.signalSimpleWarning, - base::signalCondition) - internal <- vapply(frames, function(frame) { - any(vapply(handlers, function(fun) identical(sys.function(frame), fun), FALSE)) - }, FALSE) - if (any(internal)) frames <- frames[seq_len(which(internal)[[1L]] - 1L)] + handlers <- list( + on_error, + on_warning, + on_message, + diagnostic, + base::.handleSimpleError, + base::.signalSimpleWarning, + base::signalCondition + ) + internal <- vapply( + frames, + function(frame) { + any(vapply(handlers, function(fun) identical(sys.function(frame), fun), FALSE)) + }, + FALSE + ) + if (any(internal)) { + frames <- frames[seq_len(which(internal)[[1L]] - 1L)] + } trace <- as.list(vapply(calls[frames], function(x) paste(deparse(x), collapse = " "), "")) - .interactive_event("condition", list(kind = kind, message = conditionMessage(cnd), - call = paste(deparse(conditionCall(cnd)), collapse = "\n"), - trace = trace)) + .interactive_event( + "condition", + list( + kind = kind, + message = conditionMessage(cnd), + call = paste(deparse(conditionCall(cnd)), collapse = "\n"), + trace = trace + ) + ) } on_warning <- function(cnd) { - if (getOption("warn") >= 2) return() - if (getOption("warn") >= 0) diagnostic(cnd, "warning") + if (getOption("warn") >= 2) { + return() + } + if (getOption("warn") >= 0) { + diagnostic(cnd, "warning") + } invokeRestart("muffleWarning") } on_message <- function(cnd) { @@ -273,14 +352,9 @@ interactive_execute <- function(id, code, source = NULL) { } } tryCatch( - withCallingHandlers(evaluate(), - warning = on_warning, message = on_message, error = on_error), - error = function(cnd) { - state <<- "error" - }, - interrupt = function(cnd) { - state <<- "interrupted" - } + withCallingHandlers(evaluate(), warning = on_warning, message = on_message, error = on_error), + error = function(cnd) state <<- "error", + interrupt = function(cnd) state <<- "interrupted" ) .interactive_capture_plot() .interactive_event("finished", list(state = state)) @@ -288,61 +362,87 @@ interactive_execute <- function(id, code, source = NULL) { } .interactive_capture_plot <- function() { - if (!isTRUE(.sess_env$interactive_static) || - isTRUE(.sess_env$interactive_capturing) || - grDevices::dev.cur() != getOption("sess.null_dev", -1L)) return() + if ( + !isTRUE(.sess_env$interactive_static) || + isTRUE(.sess_env$interactive_capturing) || + grDevices::dev.cur() != getOption("sess.null_dev", -1L) + ) { + return() + } .sess_env$interactive_capturing <- TRUE - on.exit({ - .sess_env$interactive_capturing <- FALSE - }, add = TRUE) + on.exit( + { + .sess_env$interactive_capturing <- FALSE + }, + add = TRUE + ) record <- tryCatch(grDevices::recordPlot(), error = function(e) NULL) - if (is.null(record)) return() + if (is.null(record)) { + return() + } commands <- as.list(record[[1L]]) # Trailing par()/layout() calls configure future drawing; they do not paint this page. # Comparing the whole record also compares graphics state changed by par(). while (length(commands)) { routine <- commands[[length(commands)]][[2L]][[1L]] - if (!is.list(routine) || !routine$name %in% c("C_par", "C_layout")) break + if (!is.list(routine) || !routine$name %in% c("C_par", "C_layout")) { + break + } commands <- head(commands, -1L) } - if (!length(commands) || identical(commands, .sess_env$interactive_last_plot)) return() + if (!length(commands) || identical(commands, .sess_env$interactive_last_plot)) { + return() + } .sess_env$interactive_last_plot <- commands .sess_env$latest_plot_record <- record plot <- handle_plot_latest(list(width = 800L, height = 600L, format = "svglite")) if (!is.null(plot$data)) { page <- .sess_env$interactive_plot_page # par() can change the display list without changing the rendered picture. - if (identical(page, .sess_env$interactive_last_plot_page) && - identical(plot$data, .sess_env$interactive_last_plot_data)) return() + if ( + identical(page, .sess_env$interactive_last_plot_page) && + identical(plot$data, .sess_env$interactive_last_plot_data) + ) { + return() + } .sess_env$interactive_last_plot_page <- page .sess_env$interactive_last_plot_data <- plot$data mime <- if (identical(plot$format, "png")) "image/png" else "image/svg+xml" - .interactive_event("display", list(kind = "image", data = plot$data, - mime = mime, - displayId = paste("static", .sess_env$interactive_id, - page, sep = "-"))) + .interactive_event( + "display", + list( + kind = "image", + data = plot$data, + mime = mime, + displayId = paste("static", .sess_env$interactive_id, page, sep = "-") + ) + ) } } .interactive_table_text <- function(value) { file <- tempfile("table-print-") on.exit(unlink(file)) - tryCatch({ - # Use the class printer and current R options. A file bounds the amount we - # retain in memory even when a custom printer produces a very large table. - # Binary output keeps notebook newlines portable on Windows too. - connection <- file(file, open = "wb") - tryCatch(utils::capture.output(print(value), file = connection), - finally = close(connection)) - limit <- 256L * 1024L - text <- readChar(file, nchars = limit, useBytes = TRUE) - if (!length(text)) text <- "" - text <- iconv(text, to = "UTF-8", sub = "") - if (file.info(file)$size > limit) { - text <- paste0(text, "\n[Printed preview truncated at 256 KiB]\n") - } - list(printedText = text) - }, error = function(e) list(printError = conditionMessage(e))) + tryCatch( + { + # Use the class printer and current R options. A file bounds the amount we + # retain in memory even when a custom printer produces a very large table. + # Binary output keeps notebook newlines portable on Windows too. + connection <- file(file, open = "wb") + tryCatch(utils::capture.output(print(value), file = connection), finally = close(connection)) + limit <- 256L * 1024L + text <- readChar(file, nchars = limit, useBytes = TRUE) + if (!length(text)) { + text <- "" + } + text <- iconv(text, to = "UTF-8", sub = "") + if (file.info(file)$size > limit) { + text <- paste0(text, "\n[Printed preview truncated at 256 KiB]\n") + } + list(printedText = text) + }, + error = function(e) list(printError = conditionMessage(e)) + ) } .interactive_table_snapshot <- function(value) { @@ -374,10 +474,14 @@ interactive_execute <- function(id, code, source = NULL) { snapshot <- .interactive_table_snapshot(value) registration <- dataview_register(snapshot$value) metadata <- handle_dataview_init(list(view_id = registration$view_id)) - preview <- handle_dataview_page(list(view_id = registration$view_id, - startRow = 0L, endRow = 20L, - formatNumbers = TRUE, - sortModel = list(), filterModel = list())) + preview <- handle_dataview_page(list( + view_id = registration$view_id, + startRow = 0L, + endRow = 20L, + formatNumbers = TRUE, + sortModel = list(), + filterModel = list() + )) printed <- .interactive_table_text(snapshot$value) full_view <- NULL if (snapshot$truncated) { @@ -385,20 +489,30 @@ interactive_execute <- function(id, code, source = NULL) { # the expanded viewer can reflect later reference edits to this object. full_view <- dataview_register(value, live = TRUE)$view_id if (!is.null(printed$printedText)) { - note <- - sprintf("\n[Snapshot: first %s of %s rows. Open Data viewer for the full table.]\n", - format(metadata$totalRows, big.mark = ",", scientific = FALSE, trim = TRUE), - format(snapshot$source_rows, big.mark = ",", scientific = FALSE, trim = TRUE)) + note <- sprintf( + "\n[Snapshot: first %s of %s rows. Open Data viewer for the full table.]\n", + format(metadata$totalRows, big.mark = ",", scientific = FALSE, trim = TRUE), + format(snapshot$source_rows, big.mark = ",", scientific = FALSE, trim = TRUE) + ) printed$printedText <- paste0(printed$printedText, note) } } - .interactive_event("display", c(list(kind = "table", viewId = registration$view_id, - fullViewId = full_view, - sourceRows = snapshot$source_rows, - columns = metadata$columns, rows = preview$rows, - formattedColumns = preview$formattedColumns, - totalRows = metadata$totalRows), - printed)) + .interactive_event( + "display", + c( + list( + kind = "table", + viewId = registration$view_id, + fullViewId = full_view, + sourceRows = snapshot$source_rows, + columns = metadata$columns, + rows = preview$rows, + formattedColumns = preview$formattedColumns, + totalRows = metadata$totalRows + ), + printed + ) + ) return(TRUE) } if (is.list(value) && !is.object(value)) { @@ -407,9 +521,18 @@ interactive_execute <- function(id, code, source = NULL) { root <- listview_state(value, "List", paste0("interactive:", view_id)) dataview_set_state(view_id, root) preview <- get_workspace_children(view_id = view_id) - .interactive_event("display", c(list(kind = "list", viewId = view_id, - navigation = listview_navigation(listview_location(root))), - preview, .interactive_table_text(value))) + .interactive_event( + "display", + c( + list( + kind = "list", + viewId = view_id, + navigation = listview_navigation(listview_location(root)) + ), + preview, + .interactive_table_text(value) + ) + ) return(TRUE) } if (inherits(value, "htmlwidget") && requireNamespace("htmlwidgets", quietly = TRUE)) { @@ -420,8 +543,10 @@ interactive_execute <- function(id, code, source = NULL) { .interactive_event("display", list(kind = "html", file = file)) return(TRUE) } - if (inherits(value, c("shiny.tag", "shiny.tag.list", "html")) && - requireNamespace("htmltools", quietly = TRUE)) { + if ( + inherits(value, c("shiny.tag", "shiny.tag.list", "html")) && + requireNamespace("htmltools", quietly = TRUE) + ) { directory <- tempfile("html-") dir.create(directory) file <- file.path(directory, "index.html") @@ -441,8 +566,10 @@ display <- function(x, mime = NULL) { if (!isTRUE(.sess_env$interactive_connected)) { print(x) } else if (!is.null(mime)) { - .interactive_event("display", list(kind = "mime", mime = mime, - text = paste(as.character(x), collapse = "\n"))) + .interactive_event( + "display", + list(kind = "mime", mime = mime, text = paste(as.character(x), collapse = "\n")) + ) } else if (!.interactive_rich_value(x)) { print(x) } diff --git a/sess/R/rstudioapi.R b/sess/R/rstudioapi.R index 89f025639..bfaf8cdb5 100644 --- a/sess/R/rstudioapi.R +++ b/sess/R/rstudioapi.R @@ -12,9 +12,7 @@ verifyAvailable <- function(version_needed = NULL) { getVersion() >= numeric_version(version_needed) } -isAvailable <- function(version_needed = NULL, child_ok = FALSE) { - verifyAvailable(version_needed) -} +isAvailable <- function(version_needed = NULL, child_ok = FALSE) verifyAvailable(version_needed) insertText <- function(location, text, id = NULL) { if (missing(text) && is.character(location) && length(location) == 1) { @@ -34,13 +32,18 @@ insertText <- function(location, text, id = NULL) { normalised_location <- normalise_pos_or_range_arg(location) normalised_text <- normalise_text_arg(text, length(normalised_location)) - query <- mapply(function(location, text) { - list( - operation = if (rstudioapi::is.document_range(location)) "modifyRange" else "insertText", - location = serialize_location(location), - text = text - ) - }, normalised_location, normalised_text, SIMPLIFY = FALSE) + query <- mapply( + function(location, text) { + list( + operation = if (rstudioapi::is.document_range(location)) "modifyRange" else "insertText", + location = serialize_location(location), + text = text + ) + }, + normalised_location, + normalised_text, + SIMPLIFY = FALSE + ) invisible(request_client("rstudioapi/insert_or_modify_text", args = list(query = query, id = id))) } @@ -81,11 +84,10 @@ showDialog <- function(title, message, url = "") { } navigateToFile <- function(file, line = 1L, column = 1L) { - invisible(request_client("rstudioapi/navigate_to_file", args = list( - file = normalizePath(file), - line = line, - column = column - ))) + invisible(request_client( + "rstudioapi/navigate_to_file", + args = list(file = normalizePath(file), line = line, column = column) + )) } setSelectionRanges <- function(ranges, id = NULL) { @@ -127,20 +129,22 @@ documentSaveAll <- function() { invisible(request_client("rstudioapi/document_save_all", args = list())) } -documentNew <- function(text = "", type = c("r", "rmarkdown", "sql"), - position = rstudioapi::document_position(1, 1), - execute = FALSE) { +documentNew <- function( + text = "", + type = c("r", "rmarkdown", "sql"), + position = rstudioapi::document_position(1, 1), + execute = FALSE +) { if (!rstudioapi::is.document_position((position))) { stop("DocumentNew requires a document_position object") } if (length(text) != 1 || !is.character(text)) { stop("text for DocumentNew must be a length one character vector.") } - invisible(request_client("rstudioapi/document_new", args = list( - text = text, - type = match.arg(type), - position = serialize_pos(position) - ))) + invisible(request_client( + "rstudioapi/document_new", + args = list(text = text, type = match.arg(type), position = serialize_pos(position)) + )) } setDocumentContents <- function(text, id = NULL) { @@ -155,9 +159,7 @@ restartSession <- function(command = "", clean = FALSE) { invisible(notify_client("restart_r", params = list(command = command, clean = clean))) } -viewer <- function(url, height = NULL) { - notify_client("webview", list(url = url, title = "Viewer")) -} +viewer <- function(url, height = NULL) notify_client("webview", list(url = url, title = "Viewer")) page_viewer <- function(url, title = NULL) { notify_client( @@ -170,7 +172,9 @@ getVersion <- function() numeric_version("0") versionInfo <- function() { list( - citation = "", mode = "generic-ipc", version = numeric_version("0"), + citation = "", + mode = "generic-ipc", + version = numeric_version("0"), release_name = "generic-ipc" ) } @@ -180,9 +184,10 @@ sendToConsole <- function(code, echo = TRUE, execute = TRUE, focus = TRUE, anima warning("rstudioapi::sendToConsole echo = FALSE is not supported in the generic IPC client.") } code_to_run <- paste0(code, collapse = "\n") - invisible(notify_client("rstudioapi/send_to_console", params = list( - code = code_to_run, execute = execute, focus = focus, animate = animate - ))) + invisible(notify_client( + "rstudioapi/send_to_console", + params = list(code = code_to_run, execute = execute, focus = focus, animate = animate) + )) } documentClose <- function(id = NULL, save = TRUE) { @@ -214,9 +219,10 @@ make_rs_range <- function(sess_selection) { extract_document_ranges <- function(sess_selections) { if (is.data.frame(sess_selections)) { - lapply(seq_len(nrow(sess_selections)), function(i) { - make_rs_range(as.list(sess_selections[i, , drop = FALSE])) - }) + lapply( + seq_len(nrow(sess_selections)), + function(i) make_rs_range(as.list(sess_selections[i, , drop = FALSE])) + ) } else { lapply(sess_selections, make_rs_range) } @@ -253,7 +259,9 @@ extract_range_text <- function(range, content_lines) { # Adjust end if (end_row <= length(content_lines)) { content_rows[length(content_rows)] <- substring( - content_rows[length(content_rows)], 1, range$end["column"] - 1 + content_rows[length(content_rows)], + 1, + range$end["column"] - 1 ) } @@ -264,16 +272,15 @@ extract_range_text <- function(range, content_lines) { } range_has_text <- function(range) { - (range$end["row"] - range$start["row"]) + - (range$end["column"] - range$start["column"]) > 0 + (range$end["row"] - range$start["row"]) + (range$end["column"] - range$start["column"]) > 0 } make_rs_document_selection <- function(ranges, range_texts) { structure( mapply( - function(range, text) { - list(range = range, text = text) - }, ranges, range_texts, + function(range, text) list(range = range, text = text), + ranges, + range_texts, SIMPLIFY = FALSE ), class = "document_selection" @@ -285,12 +292,15 @@ make_rs_document_context <- function(editor_context) { content_lines <- to_content_lines(editor_context$contents, document_ranges) document_range_texts <- lapply(document_ranges, extract_range_text, content_lines) document_selection <- make_rs_document_selection(document_ranges, document_range_texts) - structure(list( - id = editor_context$id$external, - path = editor_context$path, - contents = content_lines, - selection = document_selection - ), class = "document_context") + structure( + list( + id = editor_context$id$external, + path = editor_context$path, + contents = content_lines, + selection = document_selection + ), + class = "document_context" + ) } is_positionable <- function(p) is.numeric(p) && length(p) == 2 @@ -334,9 +344,7 @@ normalise_text_arg <- function(text, location_length) { } } -serialize_pos <- function(pos) { - as.numeric(c(pos[["row"]], pos[["column"]])) -} +serialize_pos <- function(pos) as.numeric(c(pos[["row"]], pos[["column"]])) serialize_range <- function(range) { list(start = serialize_pos(range$start), end = serialize_pos(range$end)) diff --git a/sess/R/runtime.R b/sess/R/runtime.R index 01f2da639..d7984dfc7 100644 --- a/sess/R/runtime.R +++ b/sess/R/runtime.R @@ -64,13 +64,17 @@ .runtime_assign_binding <- function(sym, value, env) { locked <- bindingIsLocked(sym, env) - if (locked) unlockBinding(sym, env) - on.exit({ - if (locked && exists(sym, envir = env, inherits = FALSE) && - !bindingIsLocked(sym, env)) { - lockBinding(sym, env) - } - }, add = TRUE) + if (locked) { + unlockBinding(sym, env) + } + on.exit( + { + if (locked && exists(sym, envir = env, inherits = FALSE) && !bindingIsLocked(sym, env)) { + lockBinding(sym, env) + } + }, + add = TRUE + ) assign(sym, value, envir = env) invisible(value) } @@ -92,10 +96,14 @@ state <- .runtime_state() for (env in envs) { - if (!exists(sym, envir = env, inherits = FALSE)) next - index <- which(vapply(state$bindings, function(entry) { - identical(entry$env, env) && identical(entry$name, sym) - }, logical(1))) + if (!exists(sym, envir = env, inherits = FALSE)) { + next + } + index <- which(vapply( + state$bindings, + function(entry) identical(entry$env, env) && identical(entry$name, sym), + logical(1) + )) if (!length(index)) { state$bindings[[length(state$bindings) + 1L]] <- list( env = env, @@ -140,8 +148,7 @@ state <- .runtime_state() registration_envir <- new.env(parent = envir) dispatch_envir <- .runtime_s3_dispatch_env(generic, envir) - original <- utils::getS3method(generic, class, envir = dispatch_envir, - optional = TRUE) + original <- utils::getS3method(generic, class, envir = dispatch_envir, optional = TRUE) original_namespace_methods <- if (isNamespace(envir)) { getNamespaceInfo(envir, "S3methods") } else { @@ -176,7 +183,9 @@ .runtime_track_device <- function(id = grDevices::dev.cur()) { state <- .runtime_state() devices <- grDevices::dev.list() - if (is.null(devices)) return(invisible(NULL)) + if (is.null(devices)) { + return(invisible(NULL)) + } name <- names(devices)[match(id, devices)] if (length(name) && !is.na(name)) { # A newly opened device can reuse a number from dev.off(). Retire that @@ -190,17 +199,14 @@ device_entries <- get(".Devices", envir = baseenv()) attr(device_entries[[id]], "vscodeR.device") <- token assign(".Devices", device_entries, envir = baseenv()) - state$devices[[length(state$devices) + 1L]] <- list( - id = unname(id), - name = name, - token = token - ) + state$devices[[length(state$devices) + 1L]] <- list(id = unname(id), name = name, token = token) } invisible(id) } .runtime_device_is_live <- function(entry, devices = get(".Devices", envir = baseenv())) { - !is.null(entry$token) && entry$id <= length(devices) && + !is.null(entry$token) && + entry$id <= length(devices) && identical(attr(devices[[entry$id]], "vscodeR.device", exact = TRUE), entry$token) } @@ -221,28 +227,33 @@ optional = TRUE ) restore_namespace_methods <- isNamespace(entry$namespace_envir) && - identical(getNamespaceInfo(entry$namespace_envir, "S3methods"), - entry$installed_namespace_methods) + identical( + getNamespaceInfo(entry$namespace_envir, "S3methods"), + entry$installed_namespace_methods + ) if (identical(current, entry$installed)) { if (!is.null(entry$original)) { - try(registerS3method(entry$generic, entry$class, entry$original, - envir = entry$envir), silent = TRUE) + try( + registerS3method(entry$generic, entry$class, entry$original, envir = entry$envir), + silent = TRUE + ) } else { dispatch_env <- entry$dispatch_envir table <- get0(".__S3MethodsTable__.", envir = dispatch_env, inherits = FALSE) method_name <- paste(entry$generic, entry$class, sep = ".") - if (is.environment(table) && - exists(method_name, envir = table, inherits = FALSE) && - identical(get(method_name, envir = table, inherits = FALSE), entry$installed)) { + if ( + is.environment(table) && + exists(method_name, envir = table, inherits = FALSE) && + identical(get(method_name, envir = table, inherits = FALSE), entry$installed) + ) { rm(list = method_name, envir = table) } } } if (restore_namespace_methods) { try( - setNamespaceInfo(entry$namespace_envir, "S3methods", - entry$original_namespace_methods), + setNamespaceInfo(entry$namespace_envir, "S3methods", entry$original_namespace_methods), silent = TRUE ) } @@ -264,8 +275,10 @@ for (entry in rev(state$bindings)) { env <- entry$env name <- entry$name - if (exists(name, envir = env, inherits = FALSE) && - identical(get(name, envir = env, inherits = FALSE), entry$installed)) { + if ( + exists(name, envir = env, inherits = FALSE) && + identical(get(name, envir = env, inherits = FALSE), entry$installed) + ) { try(.runtime_assign_binding(name, entry$original, env), silent = TRUE) } } @@ -276,19 +289,28 @@ for (entry in if (preserve_plots) list() else rev(state$devices)) { devices <- grDevices::dev.list() index <- if (is.null(devices)) NA_integer_ else match(entry$id, devices) - if (!is.na(index) && identical(names(devices)[[index]], entry$name) && - .runtime_device_is_live(entry)) { + if ( + !is.na(index) && + identical(names(devices)[[index]], entry$name) && + .runtime_device_is_live(entry) + ) { try(grDevices::dev.off(which = entry$id), silent = TRUE) } } - if (!preserve_plots) state$devices <- list() + if (!preserve_plots) { + state$devices <- list() + } for (entry in rev(state$fields)) { - if (preserve_plots && identical(entry$name, "latest_plot_record")) next + if (preserve_plots && identical(entry$name, "latest_plot_record")) { + next + } exists_current <- exists(entry$name, envir = .sess_env, inherits = FALSE) current <- if (exists_current) get(entry$name, envir = .sess_env, inherits = FALSE) else NULL - if (identical(exists_current, entry$installed_exists) && - (!exists_current || identical(current, entry$installed))) { + if ( + identical(exists_current, entry$installed_exists) && + (!exists_current || identical(current, entry$installed)) + ) { if (entry$original_exists) { assign(entry$name, entry$original, envir = .sess_env) } else if (exists_current) { @@ -303,7 +325,9 @@ } for (name in names(state$options)) { - if (preserve_plots && identical(name, "sess.null_dev")) next + if (preserve_plots && identical(name, "sess.null_dev")) { + next + } entry <- state$options[[name]] if (identical(getOption(name), entry$installed)) { try(do.call(options, .runtime_named_value(name, entry$original)), silent = TRUE) @@ -323,15 +347,21 @@ #' Stop the VS Code runtime integration (internal) #' #' Removes runtime callbacks and restores R state installed by runtime_start(). -#' @param preserve_plots Keep live graphics devices and the latest plot while -#' reconnecting the same R process after an editor reload. +#' @param preserve_plots Keep live graphics devices and the latest plot while reconnecting the same +#' R process after an editor reload. #' @keywords internal runtime_stop <- function(preserve_plots = FALSE) { state <- .runtime_state() - if (!isTRUE(state$active) && !length(state$options) && - !length(state$bindings) && !length(state$hooks) && - !length(state$s3_methods) && !length(state$task_callbacks) && - !length(state$devices) && !length(state$fields)) { + if ( + !isTRUE(state$active) && + !length(state$options) && + !length(state$bindings) && + !length(state$hooks) && + !length(state$s3_methods) && + !length(state$task_callbacks) && + !length(state$devices) && + !length(state$fields) + ) { .runtime_clear_viewer_state() return(invisible(NULL)) } diff --git a/sess/R/server.R b/sess/R/server.R index 4d2a5d3cc..082923a6d 100644 --- a/sess/R/server.R +++ b/sess/R/server.R @@ -1,35 +1,42 @@ #' Connect to the VS Code IPC server #' -#' @param endpoint Character. Local named pipe / Unix domain socket endpoint. -#' If NULL, uses SESS_ENDPOINT, then SESS_DISCOVERY_FILE. +#' @param endpoint Character. Local named pipe / Unix domain socket endpoint. If NULL, uses +#' SESS_ENDPOINT, then SESS_DISCOVERY_FILE. #' @param use_rstudioapi Logical. Enable rstudioapi emulation. Defaults to TRUE. -#' @param plot_backend Plot backend: `auto`, `jgd`, `httpgd`, `standard`, or -#' `native`. NULL also selects `auto`. -#' @param allow_jgd Logical. Whether the jgd renderer may be selected. Set to -#' `FALSE` when optional jgd preparation was unavailable. -#' @param attachment_id Optional opaque identifier supplied by an external -#' terminal integration to correlate this attachment with its preparation. -#' It must be 1-128 ASCII characters from `A-Z`, `a-z`, `0-9`, `_`, and `-`. -#' It is not an authentication token or an exclusive ownership claim. -#' @param auto_activate Logical. Whether vscode-R should select this attachment -#' automatically. `FALSE` requires `attachment_id`. -#' @return Invisibly returns `TRUE` when the IPC connection and runtime startup -#' succeed, or `FALSE` when the IPC endpoint is unavailable. -#' @details When SESS_DISCOVERY_FILE describes the connected endpoint, an -#' unexpected disconnect waits for a replacement endpoint in that file and -#' reconnects with the same runtime options and session identity. The optional -#' discovery jgdSocket string updates JGD_SOCKET when the resolved backend -#' includes jgd and `allow_jgd` is `TRUE`; an empty string clears it, and an -#' omitted field leaves it unchanged. Set -#' `options(sess.quiet = TRUE)` to suppress the successful connection message. +#' @param plot_backend Plot backend: `auto`, `jgd`, `httpgd`, `standard`, or `native`. NULL also +#' selects `auto`. +#' @param allow_jgd Logical. Whether the jgd renderer may be selected. Set to `FALSE` when optional +#' jgd preparation was unavailable. +#' @param attachment_id Optional opaque identifier supplied by an external terminal integration to +#' correlate this attachment with its preparation. It must be 1-128 ASCII characters from `A-Z`, +#' `a-z`, `0-9`, `_`, and `-`. It is not an authentication token or an exclusive ownership claim. +#' @param auto_activate Logical. Whether vscode-R should select this attachment automatically. +#' `FALSE` requires `attachment_id`. +#' @return +#' Invisibly returns `TRUE` when the IPC connection and runtime startup succeed, or `FALSE` when the +#' IPC endpoint is unavailable. +#' @details +#' When SESS_DISCOVERY_FILE describes the connected endpoint, an unexpected disconnect waits for a +#' replacement endpoint in that file and reconnects with the same runtime options and session +#' identity. The optional discovery jgdSocket string updates JGD_SOCKET when the resolved backend +#' includes jgd and `allow_jgd` is `TRUE`; an empty string clears it, and an omitted field leaves it +#' unchanged. Set `options(sess.quiet = TRUE)` to suppress the successful connection message. #' @export -connect <- function(endpoint = NULL, use_rstudioapi = TRUE, - plot_backend = c("auto", "jgd", "httpgd", "standard", "native"), - attachment_id = NULL, auto_activate = TRUE, allow_jgd = TRUE) { - if (!is.null(attachment_id) && - !(is.character(attachment_id) && length(attachment_id) == 1L && - !is.na(attachment_id) && - grepl("^[A-Za-z0-9_-]{1,128}$", attachment_id, useBytes = TRUE))) { +connect <- function( + endpoint = NULL, + use_rstudioapi = TRUE, + plot_backend = c("auto", "jgd", "httpgd", "standard", "native"), + attachment_id = NULL, + auto_activate = TRUE, + allow_jgd = TRUE +) { + if ( + !is.null(attachment_id) && + !(is.character(attachment_id) && + length(attachment_id) == 1L && + !is.na(attachment_id) && + grepl("^[A-Za-z0-9_-]{1,128}$", attachment_id, useBytes = TRUE)) + ) { stop("attachment_id must be NULL or a 1-128 character ASCII identifier.", call. = FALSE) } if (!(is.logical(auto_activate) && length(auto_activate) == 1L && !is.na(auto_activate))) { @@ -75,10 +82,15 @@ connect <- function(endpoint = NULL, use_rstudioapi = TRUE, if (!is.null(discovery) && identical(discovery$endpoint, endpoint)) { .configure_discovery_jgd(discovery, allow_jgd && plot_backend %in% c("auto", "jgd")) .sess_env$reconnect <- list( - path = discovery_file, endpoint = endpoint, - options = list(use_rstudioapi = use_rstudioapi, plot_backend = plot_backend, - attachment_id = attachment_id, auto_activate = auto_activate, - allow_jgd = allow_jgd) + path = discovery_file, + endpoint = endpoint, + options = list( + use_rstudioapi = use_rstudioapi, + plot_backend = plot_backend, + attachment_id = attachment_id, + auto_activate = auto_activate, + allow_jgd = allow_jgd + ) ) } @@ -107,14 +119,18 @@ connect <- function(endpoint = NULL, use_rstudioapi = TRUE, NULL } ) - if (is.null(con)) return(FALSE) + if (is.null(con)) { + return(FALSE) + } .sess_env$con <- con # session_id is stable across reconnects during this R process lifetime. notify_client("attach", .session_attach_metadata()) - if (is.null(.sess_env$con)) return(FALSE) + if (is.null(.sess_env$con)) { + return(FALSE) + } if (!isTRUE(getOption("sess.quiet"))) { print_async_msg("[sess] Connected to VS Code") @@ -127,11 +143,16 @@ connect <- function(endpoint = NULL, use_rstudioapi = TRUE, connected <- do_connect() - if (is.na(use_rstudioapi)) use_rstudioapi <- TRUE + if (is.na(use_rstudioapi)) { + use_rstudioapi <- TRUE + } if (isTRUE(connected) && !is.null(.sess_env$con)) { tryCatch( - runtime_start(use_rstudioapi = use_rstudioapi, plot_backend = plot_backend, - allow_jgd = allow_jgd), + runtime_start( + use_rstudioapi = use_rstudioapi, + plot_backend = plot_backend, + allow_jgd = allow_jgd + ), error = function(e) { phase <- .sess_env$runtime_start_phase error_call <- conditionCall(e) @@ -146,8 +167,11 @@ connect <- function(endpoint = NULL, use_rstudioapi = TRUE, "" } message( - "[sess] Runtime startup failed during ", phase, ": ", - conditionMessage(e), call_suffix + "[sess] Runtime startup failed during ", + phase, + ": ", + conditionMessage(e), + call_suffix ) .transport_disconnect(silent = TRUE) stop(e) @@ -162,9 +186,11 @@ connect <- function(endpoint = NULL, use_rstudioapi = TRUE, } # Resolve the direct argument, environment variables, then discovery data. -.resolve_endpoint <- function(endpoint = NULL, - env_endpoint = Sys.getenv("SESS_ENDPOINT"), - env_discovery_file = Sys.getenv("SESS_DISCOVERY_FILE")) { +.resolve_endpoint <- function( + endpoint = NULL, + env_endpoint = Sys.getenv("SESS_ENDPOINT"), + env_discovery_file = Sys.getenv("SESS_DISCOVERY_FILE") +) { if (!is.null(endpoint) && length(endpoint) == 1L && !is.na(endpoint) && nzchar(endpoint)) { return(endpoint) } @@ -174,8 +200,9 @@ connect <- function(endpoint = NULL, use_rstudioapi = TRUE, # An explicit discovery path is authoritative. If it is missing or # incompatible, do not connect using a stale endpoint. - if (length(env_discovery_file) == 1L && !is.na(env_discovery_file) && - nzchar(env_discovery_file)) { + if ( + length(env_discovery_file) == 1L && !is.na(env_discovery_file) && nzchar(env_discovery_file) + ) { return(.read_discovery_endpoint(env_discovery_file, warn = TRUE)) } "" @@ -183,7 +210,9 @@ connect <- function(endpoint = NULL, use_rstudioapi = TRUE, .read_discovery_endpoint <- function(path, warn = FALSE) { discovery <- .read_discovery(path, warn) - if (is.null(discovery)) return(if (warn) "" else NULL) + if (is.null(discovery)) { + return(if (warn) "" else NULL) + } discovery$endpoint } @@ -208,63 +237,71 @@ connect <- function(endpoint = NULL, use_rstudioapi = TRUE, return(NULL) } - tryCatch({ - cfg <- jsonlite::fromJSON(readLines(path, warn = FALSE), simplifyVector = FALSE) - if (!is.list(cfg)) { - return(warn_problem(sprintf( - "Invalid session discovery data in '%s'; expected a JSON object.", - path - ))) - } + tryCatch( + { + cfg <- jsonlite::fromJSON(readLines(path, warn = FALSE), simplifyVector = FALSE) + if (!is.list(cfg)) { + return(warn_problem(sprintf( + "Invalid session discovery data in '%s'; expected a JSON object.", + path + ))) + } - if (is.null(cfg$version)) { - return(warn_problem(sprintf( - paste0( - "Session discovery file '%s' has no supported schema version; ", - "expected version 1 with an endpoint field." - ), - path - ))) - } + if (is.null(cfg$version)) { + return(warn_problem(sprintf( + paste0( + "Session discovery file '%s' has no supported schema version; ", + "expected version 1 with an endpoint field." + ), + path + ))) + } - version <- cfg$version - if (!identical(version, 1L)) { - return(warn_problem(sprintf( - paste0( - "Unsupported session discovery version '%s' in '%s'; ", - "update vscode-R or use a version 1 discovery file." - ), - paste(cfg$version, collapse = ", "), path - ))) - } + version <- cfg$version + if (!identical(version, 1L)) { + return(warn_problem(sprintf( + paste0( + "Unsupported session discovery version '%s' in '%s'; ", + "update vscode-R or use a version 1 discovery file." + ), + paste(cfg$version, collapse = ", "), + path + ))) + } - value <- cfg$endpoint - if (!is_endpoint(value)) { - return(warn_problem(sprintf( - "Session discovery file '%s' has no endpoint; check the vscode-R session setup.", - path - ))) - } - if ("jgdSocket" %in% names(cfg) && - !(is.character(cfg$jgdSocket) && length(cfg$jgdSocket) == 1L && - !is.na(cfg$jgdSocket))) { - return(warn_problem(sprintf( - "Invalid jgdSocket in session discovery file '%s'; expected a string.", path - ))) + value <- cfg$endpoint + if (!is_endpoint(value)) { + return(warn_problem(sprintf( + "Session discovery file '%s' has no endpoint; check the vscode-R session setup.", + path + ))) + } + if ( + "jgdSocket" %in% names(cfg) && + !(is.character(cfg$jgdSocket) && length(cfg$jgdSocket) == 1L && !is.na(cfg$jgdSocket)) + ) { + return(warn_problem(sprintf( + "Invalid jgdSocket in session discovery file '%s'; expected a string.", + path + ))) + } + cfg + }, + error = function(e) { + warn_problem(sprintf( + "Could not read session discovery file '%s': %s", + path, + conditionMessage(e) + )) } - cfg - }, error = function(e) { - warn_problem(sprintf( - "Could not read session discovery file '%s': %s", - path, - conditionMessage(e) - )) - }) + ) } # Discovery configures only the optional JGD renderer, never arbitrary R state. .configure_discovery_jgd <- function(discovery, jgd_enabled) { - if (!isTRUE(jgd_enabled) || is.null(discovery$jgdSocket)) return(invisible(NULL)) + if (!isTRUE(jgd_enabled) || is.null(discovery$jgdSocket)) { + return(invisible(NULL)) + } if (nzchar(discovery$jgdSocket)) { Sys.setenv(JGD_SOCKET = discovery$jgdSocket) } else { @@ -275,7 +312,9 @@ connect <- function(endpoint = NULL, use_rstudioapi = TRUE, .session_attach_metadata <- function() { host <- Sys.info()[["nodename"]] - if (is.null(host) || is.na(host)) host <- "" + if (is.null(host) || is.na(host)) { + host <- "" + } metadata <- list( protocol_version = 2L, interactive_token = .sess_env$interactive_token, @@ -301,48 +340,67 @@ connect <- function(endpoint = NULL, use_rstudioapi = TRUE, # Wait for a replacement endpoint, keeping the last connected endpoint until # a retry succeeds. A published endpoint may not yet be accepting connections. -.schedule_reconnect <- function(settings, generation = .sess_env$transport_generation, - schedule = later::later) { - if (is.null(settings)) return(invisible(NULL)) +.schedule_reconnect <- function( + settings, + generation = .sess_env$transport_generation, + schedule = later::later +) { + if (is.null(settings)) { + return(invisible(NULL)) + } force(generation) pid <- Sys.getpid() - schedule(function() { - if (!identical(pid, Sys.getpid()) || + schedule( + function() { + if ( + !identical(pid, Sys.getpid()) || !identical(generation, .sess_env$transport_generation) || - !is.null(.sess_env$con)) return(invisible(NULL)) - discovery <- .read_discovery(settings$path) - endpoint <- discovery$endpoint - if (is.character(endpoint) && length(endpoint) == 1L && nzchar(endpoint) && - !identical(endpoint, settings$endpoint)) { - # Read endpoint and renderer from one snapshot, even if the file is - # replaced again while connect() runs. - allow_jgd <- settings$options$allow_jgd - if (is.null(allow_jgd)) allow_jgd <- TRUE - .configure_discovery_jgd( - discovery, - isTRUE(allow_jgd) && settings$options$plot_backend %in% c("auto", "jgd") - ) - .sess_env$reconnecting <- TRUE - tryCatch( - .reconnect_with_startup(endpoint, function() { - do.call(connect, c(list(endpoint = endpoint), settings$options)) - }), - error = function(e) message("[sess] Reconnection failed: ", conditionMessage(e)), - finally = { - .sess_env$reconnecting <- NULL - } - ) - if (!is.null(.sess_env$con)) { - settings$endpoint <- endpoint - .sess_env$reconnect <- settings + !is.null(.sess_env$con) + ) { return(invisible(NULL)) } - # An attach write/poll failure may itself have queued a retry. Cancel it - # before scheduling our retry so there is only one pending chain. - .transport_disconnect(silent = TRUE, preserve_plots = TRUE) - } - .schedule_reconnect(settings, .sess_env$transport_generation, schedule) - }, 1) + discovery <- .read_discovery(settings$path) + endpoint <- discovery$endpoint + if ( + is.character(endpoint) && + length(endpoint) == 1L && + nzchar(endpoint) && + !identical(endpoint, settings$endpoint) + ) { + # Read endpoint and renderer from one snapshot, even if the file is + # replaced again while connect() runs. + allow_jgd <- settings$options$allow_jgd + if (is.null(allow_jgd)) { + allow_jgd <- TRUE + } + .configure_discovery_jgd( + discovery, + isTRUE(allow_jgd) && settings$options$plot_backend %in% c("auto", "jgd") + ) + .sess_env$reconnecting <- TRUE + tryCatch( + .reconnect_with_startup( + endpoint, + function() do.call(connect, c(list(endpoint = endpoint), settings$options)) + ), + error = function(e) message("[sess] Reconnection failed: ", conditionMessage(e)), + finally = { + .sess_env$reconnecting <- NULL + } + ) + if (!is.null(.sess_env$con)) { + settings$endpoint <- endpoint + .sess_env$reconnect <- settings + return(invisible(NULL)) + } + # An attach write/poll failure may itself have queued a retry. Cancel it + # before scheduling our retry so there is only one pending chain. + .transport_disconnect(silent = TRUE, preserve_plots = TRUE) + } + .schedule_reconnect(settings, .sess_env$transport_generation, schedule) + }, + 1 + ) invisible(NULL) } @@ -371,10 +429,16 @@ connect <- function(endpoint = NULL, use_rstudioapi = TRUE, .sess_env$read_buffer <- "" .sess_env$pending_responses <- list() - if (!is.null(con)) try(close(con), silent = TRUE) + if (!is.null(con)) { + try(close(con), silent = TRUE) + } runtime_stop(preserve_plots = reconnect || preserve_plots) - if (reconnect && !is.null(con)) .schedule_reconnect(settings) - if (!silent && !is.null(con)) message("[sess] Disconnected from VS Code") + if (reconnect && !is.null(con)) { + .schedule_reconnect(settings) + } + if (!silent && !is.null(con)) { + message("[sess] Disconnected from VS Code") + } invisible(NULL) } @@ -382,10 +446,7 @@ connect <- function(endpoint = NULL, use_rstudioapi = TRUE, # A ready poll can race with a read that finds no bytes. Treat only a # connection known to have reached EOF as disconnected; processx documents # conn_is_incomplete() as FALSE once no more data can arrive. - incomplete <- tryCatch( - processx::conn_is_incomplete(con), - error = function(e) TRUE - ) + incomplete <- tryCatch(processx::conn_is_incomplete(con), error = function(e) TRUE) identical(incomplete, FALSE) } @@ -394,10 +455,15 @@ connect <- function(endpoint = NULL, use_rstudioapi = TRUE, #' Runs as a recurring later callback; dispatches NDJSON messages from vscode. #' @keywords internal poll_connection <- function(generation = .sess_env$transport_generation) { - if (isTRUE(.sess_env$interactive_connected) && - !identical(.sess_env$interactive_pid, Sys.getpid())) return() + if ( + isTRUE(.sess_env$interactive_connected) && !identical(.sess_env$interactive_pid, Sys.getpid()) + ) { + return() + } con <- .sess_env$con - if (is.null(con) || !identical(generation, .sess_env$transport_generation)) return() + if (is.null(con) || !identical(generation, .sess_env$transport_generation)) { + return() + } # Non-blocking poll: 0 ms timeout ready <- tryCatch( @@ -408,8 +474,7 @@ poll_connection <- function(generation = .sess_env$transport_generation) { } ) - if (is.null(.sess_env$con) || - !identical(generation, .sess_env$transport_generation)) { + if (is.null(.sess_env$con) || !identical(generation, .sess_env$transport_generation)) { return() } @@ -423,7 +488,9 @@ poll_connection <- function(generation = .sess_env$transport_generation) { } ) - if (is.null(.sess_env$con)) return() + if (is.null(.sess_env$con)) { + return() + } has_data <- !is.null(chunk) && length(chunk) > 0L && any(nzchar(chunk)) if (!has_data) { if (.transport_empty_read_is_eof(con)) { @@ -445,12 +512,12 @@ poll_connection <- function(generation = .sess_env$transport_generation) { for (line in parts) { line <- trimws(line) - if (!nzchar(line)) next + if (!nzchar(line)) { + next + } tryCatch( dispatch_message(line), - error = function(e) { - warning("[sess] Error dispatching message: ", e$message) - } + error = function(e) warning("[sess] Error dispatching message: ", e$message) ) } } @@ -468,7 +535,9 @@ poll_connection <- function(generation = .sess_env$transport_generation) { #' @keywords internal dispatch_message <- function(line) { payload <- tryCatch(jsonlite::fromJSON(line, simplifyVector = FALSE), error = function(e) NULL) - if (is.null(payload)) return(invisible(NULL)) + if (is.null(payload)) { + return(invisible(NULL)) + } has_id <- !is.null(payload$id) has_method <- !is.null(payload$method) @@ -479,8 +548,7 @@ dispatch_message <- function(line) { if (!is.null(payload$result)) { .sess_env$pending_responses[[key]] <- payload$result } else if (!is.null(payload$error)) { - .sess_env$pending_responses[[key]] <- - structure(payload$error, class = "json_rpc_error") + .sess_env$pending_responses[[key]] <- structure(payload$error, class = "json_rpc_error") } } else if (has_method && has_id) { # Request from vscode → R must reply @@ -530,6 +598,10 @@ dispatch_message <- function(line) { #' @keywords internal rpc_reply <- function(id, result = NULL, error = NULL) { msg <- list(jsonrpc = "2.0", id = id) - if (!is.null(error)) msg$error <- error else msg$result <- result + if (!is.null(error)) { + msg$error <- error + } else { + msg$result <- result + } ipc_write(msg) } diff --git a/sess/R/zzz.R b/sess/R/zzz.R index 1a6a8fb16..e0ccab91a 100644 --- a/sess/R/zzz.R +++ b/sess/R/zzz.R @@ -7,14 +7,11 @@ # process reaches the attach handshake with its parent's cached state. .session_id <- function() { pid <- Sys.getpid() - if (is.null(.sess_env$session_id) || - !identical(.sess_env$session_pid, pid)) { + if (is.null(.sess_env$session_id) || !identical(.sess_env$session_pid, pid)) { .sess_env$session_pid <- pid .sess_env$session_id <- basename(tempfile("sess-session-")) } .sess_env$session_id } -.onUnload <- function(libpath) { - .transport_disconnect(silent = TRUE) -} +.onUnload <- function(libpath) .transport_disconnect(silent = TRUE) diff --git a/sess/bootstrap.R b/sess/bootstrap.R index f33ff10eb..fdcb33937 100644 --- a/sess/bootstrap.R +++ b/sess/bootstrap.R @@ -28,15 +28,19 @@ local({ prefix <- git(c("rev-parse", "--show-prefix")) # Bootstrap identifies committed sources. Refuse local source edits; # extension development builds identify their working tree separately. - status <- system2("git", c("diff", "--quiet", "HEAD", "--", ".", - shQuote(":(exclude)DESCRIPTION"))) - untracked <- system2("git", c("ls-files", "--others", "--exclude-standard", "."), - stdout = TRUE) + status <- system2( + "git", + c("diff", "--quiet", "HEAD", "--", ".", shQuote(":(exclude)DESCRIPTION")) + ) + untracked <- system2("git", c("ls-files", "--others", "--exclude-standard", "."), stdout = TRUE) if (status != 0L || length(untracked)) { stop("bootstrap.R requires committed sess sources") } - original <- system2("git", c("show", shQuote(paste0("HEAD:", prefix, "DESCRIPTION"))), - stdout = TRUE) + original <- system2( + "git", + c("show", shQuote(paste0("HEAD:", prefix, "DESCRIPTION"))), + stdout = TRUE + ) original_con <- textConnection(original) on.exit(close(original_con)) original_desc <- read.dcf(original_con) diff --git a/sess/inst/tinytest/test-attachment-metadata.R b/sess/inst/tinytest/test-attachment-metadata.R index f9924dab6..c2dc98fb0 100644 --- a/sess/inst/tinytest/test-attachment-metadata.R +++ b/sess/inst/tinytest/test-attachment-metadata.R @@ -5,30 +5,51 @@ local({ namespace <- asNamespace("sess") state <- get(".sess_env", namespace) fields <- c( - "con", "reconnect", "attachment_id", "auto_activate", "tempdir", - "latest_plot_path", "pending_responses", "read_buffer", "dataviews", + "con", + "reconnect", + "attachment_id", + "auto_activate", + "tempdir", + "latest_plot_path", + "pending_responses", + "read_buffer", + "dataviews", "dataview_registry" ) - saved <- lapply(fields, function(name) { - list(exists = exists(name, envir = state, inherits = FALSE), - value = if (exists(name, envir = state, inherits = FALSE)) get(name, state) else NULL) - }) + saved <- lapply( + fields, + function(name) { + list( + exists = exists(name, envir = state, inherits = FALSE), + value = if (exists(name, envir = state, inherits = FALSE)) get(name, state) else NULL + ) + } + ) names(saved) <- fields original_discovery <- Sys.getenv("SESS_DISCOVERY_FILE", unset = NA_character_) original_endpoint <- Sys.getenv("SESS_ENDPOINT", unset = NA_character_) - on.exit({ - for (name in fields) { - if (saved[[name]]$exists) { - assign(name, saved[[name]]$value, envir = state) - } else if (exists(name, envir = state, inherits = FALSE)) { - rm(list = name, envir = state) + on.exit( + { + for (name in fields) { + if (saved[[name]]$exists) { + assign(name, saved[[name]]$value, envir = state) + } else if (exists(name, envir = state, inherits = FALSE)) { + rm(list = name, envir = state) + } } - } - if (is.na(original_discovery)) Sys.unsetenv("SESS_DISCOVERY_FILE") else - Sys.setenv(SESS_DISCOVERY_FILE = original_discovery) - if (is.na(original_endpoint)) Sys.unsetenv("SESS_ENDPOINT") else - Sys.setenv(SESS_ENDPOINT = original_endpoint) - }, add = TRUE) + if (is.na(original_discovery)) { + Sys.unsetenv("SESS_DISCOVERY_FILE") + } else { + Sys.setenv(SESS_DISCOVERY_FILE = original_discovery) + } + if (is.na(original_endpoint)) { + Sys.unsetenv("SESS_ENDPOINT") + } else { + Sys.setenv(SESS_ENDPOINT = original_endpoint) + } + }, + add = TRUE + ) env <- new.env(parent = namespace) env$.sess_env <- state @@ -41,9 +62,7 @@ local({ state$reconnect <- NULL } env$.resolve_plot_backend <- function(plot_backend) "standard" - env$.resolve_endpoint <- function(endpoint = NULL, ...) { - if (is.null(endpoint)) "" else endpoint - } + env$.resolve_endpoint <- function(endpoint = NULL, ...) if (is.null(endpoint)) "" else endpoint # Invalid new options must be rejected before the old transport is touched. sentinel <- new.env(parent = emptyenv()) @@ -68,9 +87,10 @@ local({ # The returned attach metadata reflects an external connection, then resets # to the historical native shape on the next untagged connect call. - expect_warning(result <- env$connect( - endpoint = "", attachment_id = "console_7", auto_activate = FALSE - ), "Connection info not available") + expect_warning( + result <- env$connect(endpoint = "", attachment_id = "console_7", auto_activate = FALSE), + "Connection info not available" + ) expect_false(result) metadata <- sess:::.session_attach_metadata() expect_equal(metadata$attachment_id, "console_7") diff --git a/sess/inst/tinytest/test-connect-failure.R b/sess/inst/tinytest/test-connect-failure.R index 68fa0772e..b2e58a7e5 100644 --- a/sess/inst/tinytest/test-connect-failure.R +++ b/sess/inst/tinytest/test-connect-failure.R @@ -17,8 +17,10 @@ local({ tempfile(fileext = ".sock") } discovery <- tempfile(fileext = ".json") - writeLines(jsonlite::toJSON(list(version = 1L, endpoint = endpoint), - auto_unbox = TRUE), discovery) + writeLines( + jsonlite::toJSON(list(version = 1L, endpoint = endpoint), auto_unbox = TRUE), + discovery + ) original_discovery <- Sys.getenv("SESS_DISCOVERY_FILE", unset = NA_character_) Sys.setenv(SESS_DISCOVERY_FILE = discovery) original_view <- utils::View @@ -26,17 +28,23 @@ local({ original_callbacks <- getTaskCallbackNames() original_plot_hook <- getHook("plot.new") server <- NULL - on.exit({ - sess:::.transport_disconnect(silent = TRUE) - if (!is.null(server)) try(close(server), silent = TRUE) - unlink(c(discovery, if (.Platform$OS.type != "windows") endpoint)) - if (is.na(original_discovery)) Sys.unsetenv("SESS_DISCOVERY_FILE") else - Sys.setenv(SESS_DISCOVERY_FILE = original_discovery) - }, add = TRUE) + on.exit( + { + sess:::.transport_disconnect(silent = TRUE) + if (!is.null(server)) { + try(close(server), silent = TRUE) + } + unlink(c(discovery, if (.Platform$OS.type != "windows") endpoint)) + if (is.na(original_discovery)) { + Sys.unsetenv("SESS_DISCOVERY_FILE") + } else { + Sys.setenv(SESS_DISCOVERY_FILE = original_discovery) + } + }, + add = TRUE + ) - listen <- function() { - server <<- processx::conn_create_unix_socket(endpoint, encoding = "") - } + listen <- function() server <<- processx::conn_create_unix_socket(endpoint, encoding = "") # Accept while the client is open, including on Windows named pipes. Drive # subsequent retries explicitly instead of starting background poll timers. env$poll_connection <- function(...) { @@ -65,15 +73,12 @@ local({ } opts <- list(use_rstudioapi = FALSE, plot_backend = "standard") listen() - expect_error(do.call(env$connect, c(list(endpoint = endpoint), opts)), - "injected runtime failure") + expect_error(do.call(env$connect, c(list(endpoint = endpoint), opts)), "injected runtime failure") close_peer() # Transport connected and sent attach before runtime failed. expect_clean() callbacks <- list() - schedule <- function(callback, delay) { - callbacks[[length(callbacks) + 1L]] <<- callback - } + schedule <- function(callback, delay) callbacks[[length(callbacks) + 1L]] <<- callback tick <- function() { callback <- callbacks[[1L]] callbacks <<- callbacks[-1L] diff --git a/sess/inst/tinytest/test-connection-message.R b/sess/inst/tinytest/test-connection-message.R index 64ea48db8..a51d0467b 100644 --- a/sess/inst/tinytest/test-connection-message.R +++ b/sess/inst/tinytest/test-connection-message.R @@ -5,10 +5,13 @@ local({ } old_options <- options()[c("sess.quiet", "prompt")] - on.exit({ - options(old_options) - sess:::.transport_disconnect(silent = TRUE) - }, add = TRUE) + on.exit( + { + options(old_options) + sess:::.transport_disconnect(silent = TRUE) + }, + add = TRUE + ) # Tests run non-interactively, so present an interactive console to connect(). # .schedule_reconnect() is rebound too so that its retries call this copy. @@ -24,11 +27,14 @@ local({ connect_once <- function(quiet) { path <- tempfile(fileext = ".sock") server <- processx::conn_create_unix_socket(path, encoding = "") - on.exit({ - sess:::.transport_disconnect(silent = TRUE) - try(close(server), silent = TRUE) - unlink(path) - }, add = TRUE) + on.exit( + { + sess:::.transport_disconnect(silent = TRUE) + try(close(server), silent = TRUE) + unlink(path) + }, + add = TRUE + ) options(sess.quiet = quiet) capture.output(do.call(env$connect, c(list(endpoint = path), opts))) @@ -49,9 +55,7 @@ local({ # Automatic reconnects print at an idle prompt, so each message redraws it. callbacks <- list() - schedule <- function(callback, delay) { - callbacks[[length(callbacks) + 1L]] <<- callback - } + schedule <- function(callback, delay) callbacks[[length(callbacks) + 1L]] <<- callback tick <- function() { callback <- callbacks[[1L]] callbacks <<- callbacks[-1L] @@ -59,17 +63,26 @@ local({ } replacement <- tempfile(fileext = ".sock") discovery <- tempfile(fileext = ".json") - writeLines(jsonlite::toJSON(list(version = 1L, endpoint = replacement), - auto_unbox = TRUE), discovery) + writeLines( + jsonlite::toJSON(list(version = 1L, endpoint = replacement), auto_unbox = TRUE), + discovery + ) server <- NULL - on.exit({ - if (!is.null(server)) try(close(server), silent = TRUE) - unlink(c(replacement, discovery)) - }, add = TRUE) + on.exit( + { + if (!is.null(server)) { + try(close(server), silent = TRUE) + } + unlink(c(replacement, discovery)) + }, + add = TRUE + ) options(sess.quiet = FALSE) - env$.schedule_reconnect(list(path = discovery, endpoint = "old", options = opts), - schedule = schedule) + env$.schedule_reconnect( + list(path = discovery, endpoint = "old", options = opts), + schedule = schedule + ) not_listening <- tick() expect_true(any(grepl("\\[sess\\] Failed to connect", not_listening))) expect_equal(tail(not_listening, 1L), "custom prompt> ") diff --git a/sess/inst/tinytest/test-dataview-reproducibility.R b/sess/inst/tinytest/test-dataview-reproducibility.R index 38481842a..c084c8ca5 100644 --- a/sess/inst/tinytest/test-dataview-reproducibility.R +++ b/sess/inst/tinytest/test-dataview-reproducibility.R @@ -4,16 +4,21 @@ local({ views <- env$dataviews had_seed <- exists(".Random.seed", .GlobalEnv, inherits = FALSE) seed <- if (had_seed) get(".Random.seed", .GlobalEnv) else NULL - on.exit({ - env$dataviews <- views - if (had_seed) { - assign(".Random.seed", seed, .GlobalEnv) - } else if (exists(".Random.seed", .GlobalEnv, inherits = FALSE)) { - rm(".Random.seed", envir = .GlobalEnv) - } - }, add = TRUE) + on.exit( + { + env$dataviews <- views + if (had_seed) { + assign(".Random.seed", seed, .GlobalEnv) + } else if (exists(".Random.seed", .GlobalEnv, inherits = FALSE)) { + rm(".Random.seed", envir = .GlobalEnv) + } + }, + add = TRUE + ) - if (had_seed) rm(".Random.seed", envir = .GlobalEnv) + if (had_seed) { + rm(".Random.seed", envir = .GlobalEnv) + } ids <- replicate(100L, sess:::dataview_register(iris)$view_id) expect_equal(length(unique(ids)), 100L) expect_false(exists(".Random.seed", .GlobalEnv, inherits = FALSE)) diff --git a/sess/inst/tinytest/test-dataview.R b/sess/inst/tinytest/test-dataview.R index 512998d20..219f1169f 100644 --- a/sess/inst/tinytest/test-dataview.R +++ b/sess/inst/tinytest/test-dataview.R @@ -4,11 +4,14 @@ local({ orig_dataviews <- .sess_env$dataviews orig_con <- .sess_env$con pipe <- processx::conn_create_pipepair() - on.exit({ - .sess_env$dataviews <- orig_dataviews - .sess_env$con <- orig_con - lapply(pipe, close) - }, add = TRUE) + on.exit( + { + .sess_env$dataviews <- orig_dataviews + .sess_env$con <- orig_con + lapply(pipe, close) + }, + add = TRUE + ) .sess_env$con <- pipe[[2L]] request <- function(method, params) { @@ -39,9 +42,22 @@ local({ df$list <- list(list(number = 1L, value = 3 - 4i), NULL) df$complex_matrix <- I(matrix(c(1 + 2i, NA_complex_), ncol = 1)) expected <- list( - 42L, 1.54e-100, 1.23456789012345e14, TRUE, '中文 😀 "quoted" ', - "apple", "low", "2000-01-01", "2020-01-01T00:00:00", "60 secs", - "1+2i", "0", "001", FALSE, list(number = 1L, value = "3-4i"), list("1+2i") + 42L, + 1.54e-100, + 1.23456789012345e14, + TRUE, + '中文 😀 "quoted" ', + "apple", + "low", + "2000-01-01", + "2020-01-01T00:00:00", + "60 secs", + "1+2i", + "0", + "001", + FALSE, + list(number = 1L, value = "3-4i"), + list("1+2i") ) if (requireNamespace("bit64", quietly = TRUE)) { df$integer64 <- bit64::as.integer64(c("9007199254740993", NA)) @@ -69,8 +85,18 @@ local({ missing <- request("dataview_page", list(view_id = view_id, startRow = 1L, endRow = 2L)) expect_null(missing$error) expect_length(missing$result$rows, 1L) - for (name in c("integer", "double", "logical", "character", "factor", "ordered", - "date", "datetime", "difftime", "complex")) { + for (name in c( + "integer", + "double", + "logical", + "character", + "factor", + "ordered", + "date", + "datetime", + "difftime", + "complex" + )) { expect_null(missing$result$rows[[1L]][[as.character(match(name, names(df)))]], info = name) } @@ -79,8 +105,14 @@ local({ expect_length(empty$result$rows, 0L) expect_identical(serialize(df, NULL), original) - for (values in list(c(1L, NA_integer_), c(1.54e-100, NA_real_), c(TRUE, NA), - c("中文", NA_character_), c(1 + 2i, NA_complex_), as.raw(c(0, 255)))) { + for (values in list( + c(1L, NA_integer_), + c(1.54e-100, NA_real_), + c(TRUE, NA), + c("中文", NA_character_), + c(1 + 2i, NA_complex_), + as.raw(c(0, 255)) + )) { matrix <- matrix(values, ncol = 1L) view_id <- sess:::dataview_register(matrix)$view_id page <- request("dataview_page", list(view_id = view_id, startRow = 0L, endRow = 2L)) @@ -99,8 +131,11 @@ local({ expect_equal(page$result$rows[[1L]][["2"]], "2020-01-01T00:00:00") expect_null(page$result$rows[[2L]][["2"]]) - df <- data.frame(value = c(-Inf, Inf, NaN, NA_real_, 0, 1), - all_na_numeric = NA_real_, all_na_character = NA_character_) + df <- data.frame( + value = c(-Inf, Inf, NaN, NA_real_, 0, 1), + all_na_numeric = NA_real_, + all_na_character = NA_character_ + ) view_id <- sess:::dataview_register(df)$view_id page <- request("dataview_page", list(view_id = view_id)) expect_null(page$error) @@ -112,8 +147,11 @@ local({ expect_null(row[["3"]]) } - nested <- list(date = as.Date("2000-01-01"), - table = data.frame(value = 1:2), value = list(1 + 2i)) + nested <- list( + date = as.Date("2000-01-01"), + table = data.frame(value = 1:2), + value = list(1 + 2i) + ) formatted <- sess:::dataview_format_column(list(nested))[[1L]] expect_identical(formatted$date, nested$date) expect_identical(formatted$table, nested$table) @@ -126,11 +164,14 @@ local({ orig_dataviews <- .sess_env$dataviews orig_con <- .sess_env$con pipe <- processx::conn_create_pipepair() - on.exit({ - .sess_env$dataviews <- orig_dataviews - .sess_env$con <- orig_con - lapply(pipe, close) - }, add = TRUE) + on.exit( + { + .sess_env$dataviews <- orig_dataviews + .sess_env$con <- orig_con + lapply(pipe, close) + }, + add = TRUE + ) .sess_env$con <- pipe[[2L]] values <- c(1.54e-05, 3.54e-05, -6.65e-13, 1.54e-100, 0, 1.23456789) @@ -158,29 +199,39 @@ local({ orig_con <- .sess_env$con orig_options <- options(digits = 7, scipen = 0, OutDec = ".") pipe <- processx::conn_create_pipepair() - on.exit({ - .sess_env$dataviews <- orig_dataviews - .sess_env$con <- orig_con - options(orig_options) - lapply(pipe, close) - }, add = TRUE) + on.exit( + { + .sess_env$dataviews <- orig_dataviews + .sess_env$con <- orig_con + options(orig_options) + lapply(pipe, close) + }, + add = TRUE + ) .sess_env$con <- pipe[[2L]] request <- function(view_id, ...) { sess:::dispatch_message(as.character(jsonlite::toJSON( - list(jsonrpc = "2.0", id = "formatted", method = "dataview_page", - params = c(list(view_id = view_id, formatNumbers = TRUE), list(...))), - auto_unbox = TRUE, digits = NA + list( + jsonrpc = "2.0", + id = "formatted", + method = "dataview_page", + params = c(list(view_id = view_id, formatNumbers = TRUE), list(...)) + ), + auto_unbox = TRUE, + digits = NA ))) - response <- jsonlite::fromJSON(processx::conn_read_chars(pipe[[1L]]), - simplifyVector = FALSE) + response <- jsonlite::fromJSON(processx::conn_read_chars(pipe[[1L]]), simplifyVector = FALSE) expect_null(response$error) response$result } values <- c(326 / 0.23, 326 / 0.21, 1400) - df <- data.frame(value = values, tiny = c(1.54e-100, 2.54e-100, 0), - text = c("001.234567890123", "