diff --git a/NAMESPACE b/NAMESPACE index ef10680d5..2d14d4137 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -47,6 +47,7 @@ export(upgrade) export(use) export(use_python) importFrom(tools,file_ext) +importFrom(tools,md5sum) importFrom(tools,pskill) importFrom(tools,psnice) importFrom(tools,write_PACKAGES) diff --git a/R/aaa.R b/R/aaa.R index d2eb09848..d77d23c1e 100644 --- a/R/aaa.R +++ b/R/aaa.R @@ -1,6 +1,7 @@ # global variables the <- new.env(parent = emptyenv()) +the$ffi <- new.env(parent = emptyenv()) the$paths <- new.env(parent = emptyenv()) # detect if we're running on CI diff --git a/R/dependencies.R b/R/dependencies.R index b86665a85..3415dbc6c 100644 --- a/R/dependencies.R +++ b/R/dependencies.R @@ -1082,11 +1082,7 @@ renv_dependencies_discover_r <- function(path = NULL, for (method in methods) method(node, envir) - # update node in parent environment -- this is a hack - # that allows our recurse implementation to remain - # performant without needing to care about the return - # values of these functions in general - assign("object", node, envir = parent.frame()) + # return (potentially transformed) node invisible(node) }) @@ -1889,21 +1885,21 @@ renv_dependencies_eval <- function(expr) { } -renv_dependencies_recurse <- function(object, callback, ...) { +renv_dependencies_recurse <- function(object, callback) { if (is.call(object)) - callback(object, ...) + callback(object) if (is.recursive(object)) for (i in seq_along(object)) if (is.call(object[[i]])) - renv_dependencies_recurse_impl(object[[i]], callback, ...) + renv_dependencies_recurse_impl(object[[i]], callback) } -renv_dependencies_recurse_impl <- function(object, callback, ...) { - callback(object, ...) +renv_dependencies_recurse_impl <- function(object, callback) { + callback(object) for (i in seq_along(object)) if (is.call(object[[i]])) - renv_dependencies_recurse_impl(object[[i]], callback, ...) + renv_dependencies_recurse_impl(object[[i]], callback) } diff --git a/R/ext.R b/R/ext.R new file mode 100644 index 000000000..b219d6bc5 --- /dev/null +++ b/R/ext.R @@ -0,0 +1,106 @@ + +renv_ext_init <- function() { + tryCatch( + renv_ext_init_impl(), + error = function(cnd) print(cnd) + ) +} + +renv_ext_init_impl <- function() { + + if (renv_metadata_embedded()) + return() + + name <- Sys.getenv("R_PACKAGE_NAME", unset = NA) + if (!is.na(name)) + return() + + shlib <- renv_ext_compile() + if (file.exists(shlib)) + renv_ext_load(shlib) + +} + +renv_ext_compile <- function(force = FALSE) { + + # get paths + pkgdir <- renv_paths_ext("renv") + libsdir <- file.path(pkgdir, "libs") + libname <- if (renv_platform_windows()) "renv.dll" else "renv.so" + sopath <- file.path(libsdir, libname) + srcfile <- system.file("ext/renv.c", package = "renv") + tgtfile <- file.path(libsdir, "renv.c") + hashpath <- file.path(libsdir, "md5sum") + + # initialize extension directory + ensure_directory(libsdir) + renv_scope_wd(libsdir) + + recompile <- force || + !file.exists(sopath) || + !file.exists(hashpath) || + readLines(hashpath) != md5sum(srcfile) + + if (!recompile) + return(sopath) + + # copy our DESCRIPTION file over, so we can convince R to load + # this DLL as though it were part of our package + renv_file_copy( + source = system.file("DESCRIPTION", package = "renv"), + target = file.path(pkgdir, "DESCRIPTION"), + overwrite = TRUE + ) + + # copy the '.c' file over for compilation + renv_file_copy( + source = srcfile, + target = tgtfile, + overwrite = TRUE + ) + + # compile it + renv_system_exec( + command = R(), + args = c("CMD", "SHLIB", "renv.c", "-o", libname) + ) + + # update the md5sum + writeLines( + md5sum(srcfile), + con = hashpath + ) + + # return path to + sopath + +} + +renv_ext_load <- function(shlib) { + + # load the shared library + the$dll_info <- library.dynam( + chname = "renv", + package = "renv", + lib.loc = renv_paths_ext() + ) + + # install the ffi equivalents + envir <- renv_envir_self() + enumerate(the$ffi, function(symbol, replacement) { + renv_binding_replace( + envir = envir, + symbol = symbol, + replacement = replacement + ) + }) + +} + +renv_ext_unload <- function() { + if (!is.null(the$dll_info)) { + path <- the$dll_info[["path"]] + the$dll_info <- NULL + library.dynam.unload("renv", libpath = dirname(dirname(path))) + } +} diff --git a/R/ffi.R b/R/ffi.R new file mode 100644 index 000000000..b71fed31a --- /dev/null +++ b/R/ffi.R @@ -0,0 +1,27 @@ + +the$ffi$renv_dependencies_recurse <- function(object, callback) { + + symbol <- as.symbol(names(formals(args(callback)))[[1L]]) + envir <- new.env(parent = environment(callback)) + expr <- body(callback) + + .Call( + "renv_ffi_recurse", + object, + symbol, + expr, + envir, + PACKAGE = .packageName + ) + +} + +the$ffi$renv_call_expect <- function(node, package, methods) { + .Call( + "renv_ffi_call_expect", + node, + as.character(package), + as.character(methods), + PACKAGE = .packageName + ) +} diff --git a/R/hash.R b/R/hash.R index 9b3a10469..a20f6a31f 100644 --- a/R/hash.R +++ b/R/hash.R @@ -62,7 +62,7 @@ renv_hash_description_impl <- function(path) { close(con) # ready for hasing - hash <- unname(tools::md5sum(tempfile)) + hash <- unname(md5sum(tempfile)) # remove the old file unlink(tempfile) diff --git a/R/imports.R b/R/imports.R index e7566e70f..fff7d99d8 100644 --- a/R/imports.R +++ b/R/imports.R @@ -1,6 +1,6 @@ #' @importFrom tools -#' file_ext pskill psnice write_PACKAGES +#' file_ext md5sum pskill psnice write_PACKAGES #' #' @importFrom utils #' adist available.packages browseURL citation contrib.url download.file diff --git a/R/paths.R b/R/paths.R index ee836e348..d9bd64e8b 100644 --- a/R/paths.R +++ b/R/paths.R @@ -126,6 +126,13 @@ renv_paths_cache <- function(..., version = NULL) { renv_paths_common("cache", c(version, platform), ...) } +renv_paths_ext <- function(...) { + platform <- renv_platform_prefix() + version <- renv_metadata_version() + renv_paths_common("ext", c(version, platform), ...) +} + + renv_paths_rtools <- function() { root <- renv_paths_override("rtools") diff --git a/R/remotes.R b/R/remotes.R index 0abb2620e..b517c76b0 100644 --- a/R/remotes.R +++ b/R/remotes.R @@ -914,7 +914,7 @@ renv_remotes_resolve_url <- function(url, quiet = FALSE) { tempfile <- renv_scope_tempfile("renv-url-") writeLines(url, con = tempfile) - hash <- tools::md5sum(tempfile) + hash <- md5sum(tempfile) ext <- fileext(url, default = ".tar.gz") name <- paste(hash, ext, sep = "") diff --git a/R/renv-package.R b/R/renv-package.R index c65d845e7..ff0a6f6b9 100644 --- a/R/renv-package.R +++ b/R/renv-package.R @@ -7,5 +7,5 @@ #' Each project using renv will share package installations from a global #' cache of packages, helping to avoid wasting disk space on multiple #' installations of a package that might otherwise be shared across projects. -#' +#' "_PACKAGE" diff --git a/R/zzz.R b/R/zzz.R index e0dbd0993..4a9a50cb4 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -11,6 +11,12 @@ # set root directory root <- Sys.getenv("RENV_PATHS_ROOT", unset = tempfile("renv-root-")) Sys.setenv(RENV_PATHS_ROOT = root) + + # unset on exit + reg.finalizer(renv_envir_self(), function(envir) { + if (identical(root, Sys.getenv("RENV_PATHS_ROOT", unset = NA))) + Sys.unsetenv("RENV_PATHS_ROOT") + }, onexit = TRUE) # set up sandbox -- only done on non-Windows due to strange intermittent # test failures that seemed to occur there? @@ -26,6 +32,7 @@ renv_defer_init() renv_metadata_init() + renv_ext_init() renv_ansify_init() renv_platform_init() renv_virtualization_init() @@ -72,6 +79,7 @@ renv_lock_unload() renv_task_unload() renv_watchdog_unload() + renv_ext_unload() # do some extra cleanup when running R CMD check if (renv_platform_unix() && checking() && !ci()) diff --git a/inst/ext/renv.c b/inst/ext/renv.c new file mode 100644 index 000000000..bd68f3d44 --- /dev/null +++ b/inst/ext/renv.c @@ -0,0 +1,124 @@ + +#include // for NULL + +#include +#include +#include + +// Helpers ---- + +// check for a call of the form 'package::foo(a, b, c)'; +// if we match, then create a new call of the form 'foo(a, b, c)' +static SEXP renv_call_expect_package(SEXP node, SEXP package) { + + if (TYPEOF(node) != LANGSXP) + return node; + + SEXP call = CAR(node); + if (TYPEOF(call) != LANGSXP) + return node; + + SEXP symbol = CAR(call); + if (TYPEOF(symbol) != SYMSXP) + return node; + + const char* value = CHAR(PRINTNAME(symbol)); + if (strcmp(value, "::") != 0 && strcmp(value, ":::") != 0) + return node; + + SEXP name = CADR(call); + if (TYPEOF(name) != SYMSXP) + return node; + + int matches = strcmp(CHAR(PRINTNAME(name)), CHAR(STRING_ELT(package, 0))) == 0; + if (!matches) + return node; + + node = Rf_duplicate(node); + SETCAR(node, CADDR(call)); + return node; + +} + + +// Methods ---- + +SEXP renv_ffi_recurse(SEXP object, + SEXP symbol, + SEXP expr, + SEXP envir) +{ + switch (TYPEOF(object)) { + + case LISTSXP: + case LANGSXP: + + Rf_defineVar(symbol, object, envir); + SEXP result = Rf_eval(expr, envir); + if (TYPEOF(result) == LANGSXP) { + object = result; + } + + PROTECT(object); + while (object != R_NilValue) { + renv_ffi_recurse(CAR(object), symbol, expr, envir); + object = CDR(object); + } + UNPROTECT(1); + + break; + + case VECSXP: + case EXPRSXP: + + for (int i = 0, n = Rf_xlength(object); i < n; i++) { + renv_ffi_recurse(VECTOR_ELT(object, i), symbol, expr, envir); + } + + break; + + } + + return object; + +} + +SEXP renv_ffi_call_expect(SEXP node, SEXP package, SEXP methods) { + + node = renv_call_expect_package(node, package); + PROTECT(node); + + SEXP symbol = CAR(node); + if (TYPEOF(symbol) != SYMSXP) { + UNPROTECT(1); + return R_NilValue; + } + + const char* symname = CHAR(PRINTNAME(symbol)); + for (int i = 0, n = Rf_xlength(methods); i < n; i++) { + const char* method = CHAR(STRING_ELT(methods, i)); + if (strcmp(method, symname) == 0) { + UNPROTECT(1); + return node; + } + } + + UNPROTECT(1); + return R_NilValue; + +} + + +// Init ---- + +static const R_CallMethodDef callEntries[] = { + { "renv_ffi_recurse", (DL_FUNC) &renv_ffi_recurse, 4 }, + { "renv_ffi_call_expect", (DL_FUNC) &renv_ffi_call_expect, 3}, + { NULL, NULL, 0 } +}; + +void R_init_renv(DllInfo* dllInfo) +{ + R_registerRoutines(dllInfo, NULL, callEntries, NULL, NULL); + R_useDynamicSymbols(dllInfo, FALSE); +} diff --git a/tests/testthat/test-call.R b/tests/testthat/test-call.R index 7a4807066..79a3bcabe 100644 --- a/tests/testthat/test-call.R +++ b/tests/testthat/test-call.R @@ -10,3 +10,9 @@ test_that("renv_call_matches() works as expected", { expect_true(renv_call_matches(call, names = c("foo", "bar"), nargs = 2L)) }) + +test_that("renv_call_expect() works as expected", { + node <- quote(R6::R6Class("Class", inherit = "ParentClass")) + class <- renv_call_expect(node, "R6", "R6Class") + expect_identical(class, quote(R6Class("Class", inherit = "ParentClass"))) +}) diff --git a/tests/testthat/test-ffi.R b/tests/testthat/test-ffi.R new file mode 100644 index 000000000..3a300cd77 --- /dev/null +++ b/tests/testthat/test-ffi.R @@ -0,0 +1,12 @@ + +test_that("all ffi methods have matching formal definitions", { + + enumerate(the$ffi, function(name, value) { + expect_identical( + object = formals(value), + expected = formals(get(name, envir = renv_envir_self())), + info = name + ) + }) + +})