vendor path

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: cpp11
 Title: A C++11 Interface for R's C Interface
-Version: 0.5.2.9000
+Version: 0.6.0.9000
 Authors@R:
     c(
       person("Davis", "Vaughan", email = "davis@posit.co", role = c("aut", "cre"), comment = c(ORCID = "0000-0003-4777-038X")),
@@ -31,7 +31,6 @@ Suggests:
     glue,
     knitr,
     lobstr,
-    mockery,
     progress,
     rmarkdown,
     scales,

NAMESPACE

@@ -4,4 +4,5 @@ export(cpp_eval)
 export(cpp_function)
 export(cpp_register)
 export(cpp_source)
+export(cpp_unvendor)
 export(cpp_vendor)

NEWS.md

@@ -4,6 +4,12 @@
 
 * Fixed an issue related to `-Wdeprecated-literal-operator` (#447, @andrjohns).
 
+# cpp11 0.5.1.9000
+
+* Uses testthat 3e style tests (#402).
+* Removes the mockery dependence.
+* The vendoring function accepts a custom path (i.e., to use the GitHub version of the package)
+
 # cpp11 0.5.1
 
 * cpp11 now requires R >=4.0.0, in line with the

R/register.R

@@ -77,17 +77,16 @@ cpp_register <- function(path = ".", quiet = !is_interactive(), extension = c(".
     cli::cli_alert_success("generated file {.file {basename(r_path)}}")
   }
 
-
   call_entries <- get_call_entries(path, funs$name, package)
 
   cpp_function_registration <- glue::glue_data(funs, '    {{
     "_cpp11_{name}", (DL_FUNC) &_{package}_{name}, {n_args}}}, ',
     n_args = viapply(funs$args, nrow)
   )
 
-  cpp_function_registration <- glue::glue_collapse(cpp_function_registration, sep  = "\n")
+  cpp_function_registration <- glue::glue_collapse(cpp_function_registration, sep = "\n")
 
-  extra_includes <-  character()
+  extra_includes <- character()
   if (pkg_links_to_rcpp(path)) {
     extra_includes <- c(extra_includes, "#include <cpp11/R.hpp>", "#include <Rcpp.h>", "using namespace Rcpp;")
   }
@@ -215,35 +214,75 @@ generate_init_functions <- function(funs) {
 }
 
 generate_r_functions <- function(funs, package = "cpp11", use_package = FALSE) {
-  funs <- funs[c("name", "return_type", "args")]
+  funs <- funs[c("name", "return_type", "args", "file", "line", "decoration")]
 
   if (use_package) {
     package_call <- glue::glue(', PACKAGE = "{package}"')
     package_names <- glue::glue_data(funs, '"_{package}_{name}"')
   } else {
-    package_names <- glue::glue_data(funs, '`_{package}_{name}`')
+    package_names <- glue::glue_data(funs, "`_{package}_{name}`")
     package_call <- ""
   }
 
-  funs$package <- package
   funs$package_call <- package_call
   funs$list_params <- vcapply(funs$args, glue_collapse_data, "{name}")
   funs$params <- vcapply(funs$list_params, function(x) if (nzchar(x)) paste0(", ", x) else x)
   is_void <- funs$return_type == "void"
   funs$calls <- ifelse(is_void,
-    glue::glue_data(funs, 'invisible(.Call({package_names}{params}{package_call}))'),
-    glue::glue_data(funs, '.Call({package_names}{params}{package_call})')
+    glue::glue_data(funs, "invisible(.Call({package_names}{params}{package_call}))"),
+    glue::glue_data(funs, ".Call({package_names}{params}{package_call})")
   )
 
-  out <- glue::glue_data(funs, '
-    {name} <- function({list_params}) {{
-      {calls}
-    }}
-    ')
+  # Parse and associate Roxygen comments
+  funs$roxygen_comment <- mapply(function(file, line) {
+    if (file.exists(file)) {
+      comments <- extract_roxygen_comments(file)
+      matched_comment <- ""
+      for (comment in comments) {
+        # Check if the comment directly precedes the function without gaps
+        if (line == comment$line + 1) {
+          matched_comment <- comment$text
+          break
+        }
+      }
+      matched_comment
+    } else {
+      ""
+    }
+  }, funs$file, funs$line, SIMPLIFY = TRUE)
+
+  # Generate R functions with or without Roxygen comments
+  out <- mapply(function(name, list_params, calls, roxygen_comment) {
+    if (nzchar(roxygen_comment)) {
+      glue::glue("{roxygen_comment}\n{name} <- function({list_params}) {{\n\t{calls}\n}}")
+    } else {
+      glue::glue("{name} <- function({list_params}) {{\n  {calls}\n}}")
+    }
+  }, funs$name, funs$list_params, funs$calls, funs$roxygen_comment, SIMPLIFY = TRUE)
+
+  out <- glue::trim(out)
   out <- glue::glue_collapse(out, sep = "\n\n")
   unclass(out)
 }
 
+extract_roxygen_comments <- function(file) {
+  lines <- readLines(file)
+  roxygen_start <- grep("^/\\* roxygen start", lines)
+  roxygen_end <- grep("roxygen end \\*/$", lines)
+
+  if (length(roxygen_start) == 0 || length(roxygen_end) == 0) {
+    return(list())
+  }
+
+  roxygen_comments <- mapply(function(start, end) {
+    roxygen_lines <- lines[(start + 1):(end - 1)]
+    roxygen_lines <- sub("^", "#' ", roxygen_lines)
+    list(line = end, text = paste(roxygen_lines, collapse = "\n"))
+  }, roxygen_start, roxygen_end, SIMPLIFY = FALSE)
+
+  roxygen_comments
+}
+
 wrap_call <- function(name, return_type, args) {
   call <- glue::glue('{name}({list_params})', list_params = glue_collapse_data(args, "cpp11::as_cpp<cpp11::decay_t<{type}>>({name})"))
   if (return_type == "void") {

R/source.R

@@ -18,6 +18,13 @@
 #'   uses 'CXX11' if unset.
 #' @param dir The directory to store the generated source files. `tempfile()` is
 #'   used by default. The directory will be removed if `clean` is `TRUE`.
+#' @param local Passed to [dyn.load()]. If `TRUE` (the default) the shared
+#'   library is loaded with local symbols; if `FALSE` symbols are made global
+#'   (equivalent to `dyn.load(..., local = FALSE)`), which can be required when
+#'   other shared objects need to see RTTI/vtable symbols from this library.
+#' @note See the unit test that demonstrates this usage at
+#' \code{tests/testthat/test-source-local.R} (shows how `local = FALSE` exports
+#' the necessary symbols so separate shared objects can link against them).
 #' @return For [cpp_source()] and `[cpp_function()]` the results of
 #'   [dyn.load()] (invisibly). For `[cpp_eval()]` the results of the evaluated
 #'   expression.
@@ -65,7 +72,7 @@
 #' }
 #'
 #' @export
-cpp_source <- function(file, code = NULL, env = parent.frame(), clean = TRUE, quiet = TRUE, cxx_std = Sys.getenv("CXX_STD", "CXX11"), dir = tempfile()) {
+cpp_source <- function(file, code = NULL, env = parent.frame(), clean = TRUE, quiet = TRUE, cxx_std = Sys.getenv("CXX_STD", "CXX11"), dir = tempfile(), local = TRUE) {
   stop_unless_installed(c("brio", "callr", "cli", "decor", "desc", "glue", "tibble", "vctrs"))
   if (!missing(file) && !file.exists(file)) {
     stop("Can't find `file` at this path:\n", file, "\n", call. = FALSE)
@@ -145,7 +152,7 @@ cpp_source <- function(file, code = NULL, env = parent.frame(), clean = TRUE, qu
   brio::write_lines(r_functions, r_path)
   source(r_path, local = env)
 
-  dyn.load(shared_lib, local = TRUE, now = TRUE)
+  dyn.load(shared_lib, local = local, now = TRUE)
 }
 
 the <- new.env(parent = emptyenv())
@@ -163,12 +170,15 @@ generate_cpp_name <- function(name, loaded_dlls = c("cpp11", names(getLoadedDLLs
   sprintf("%s.%s", new_name, ext)
 }
 
-
-
-generate_include_paths <- function(packages) {
+generate_include_paths <- function(packages, custom_path = NULL) {
   out <- character(length(packages))
   for (i in seq_along(packages)) {
-    path <- system.file(package = packages[[i]], "include")
+    if (!is.null(custom_path)) {
+      path <- custom_path
+    } else {
+      path <- system.file(package = packages[[i]], "include")
+    }
+
     if (is_windows()) {
       path <- utils::shortPathName(path)
     }
@@ -183,7 +193,7 @@ generate_makevars <- function(includes, cxx_std) {
 
 #' @rdname cpp_source
 #' @export
-cpp_function <- function(code, env = parent.frame(), clean = TRUE, quiet = TRUE, cxx_std = Sys.getenv("CXX_STD", "CXX11")) {
+cpp_function <- function(code, env = parent.frame(), clean = TRUE, quiet = TRUE, cxx_std = Sys.getenv("CXX_STD", "CXX11"), local = TRUE) {
   cpp_source(code = paste(c('#include "cpp11.hpp"',
         "using namespace ::cpp11;",
         "namespace writable = ::cpp11::writable;",
@@ -193,15 +203,16 @@ cpp_function <- function(code, env = parent.frame(), clean = TRUE, quiet = TRUE,
     env = env,
     clean = clean,
     quiet = quiet,
-    cxx_std = cxx_std
+    cxx_std = cxx_std,
+    local = local
   )
 }
 
 utils::globalVariables("f")
 
 #' @rdname cpp_source
 #' @export
-cpp_eval <- function(code, env = parent.frame(), clean = TRUE, quiet = TRUE, cxx_std = Sys.getenv("CXX_STD", "CXX11")) {
+cpp_eval <- function(code, env = parent.frame(), clean = TRUE, quiet = TRUE, cxx_std = Sys.getenv("CXX_STD", "CXX11"), local = TRUE) {
   cpp_source(code = paste(c('#include "cpp11.hpp"',
         "using namespace ::cpp11;",
         "namespace writable = ::cpp11::writable;",
@@ -214,7 +225,8 @@ cpp_eval <- function(code, env = parent.frame(), clean = TRUE, quiet = TRUE, cxx
     env = env,
     clean = clean,
     quiet = quiet,
-    cxx_std = cxx_std
+    cxx_std = cxx_std,
+    local = local
   )
   f()
 }

R/unvendor.R

@@ -0,0 +1,39 @@
+#' Unvendor the cpp11 dependency
+#'
+#' This function removes the vendored cpp11 headers from your package and
+#' restores the `LinkingTo: cpp11` field in the DESCRIPTION file if it was removed.
+#'
+#' @inheritParams cpp_register
+#' @return The file path to the unvendored code (invisibly).
+#' @export
+#' @examples
+#' # create a new directory
+#' dir <- tempfile()
+#' dir.create(dir)
+#'
+#' # vendor the cpp11 headers into the directory
+#' cpp_vendor(dir)
+#'
+#' # unvendor the cpp11 headers from the directory
+#' cpp_unvendor(dir)
+#'
+#' list.files(file.path(dir, "inst", "include", "cpp11"))
+#'
+#' # cleanup
+#' unlink(dir, recursive = TRUE)
+cpp_unvendor <- function(path = ".") {
+  new <- file.path(path, "inst", "include", "cpp11")
+
+  if (!dir.exists(new)) {
+    stop("'", new, "' does not exist", call. = FALSE)
+  }
+
+  unlink(new, recursive = TRUE)
+
+  cpp11_hpp <- file.path(dirname(new), "cpp11.hpp")
+  if (file.exists(cpp11_hpp)) {
+    unlink(cpp11_hpp)
+  }
+
+  invisible(new)
+}

R/vendor.R

@@ -8,14 +8,17 @@
 #' 'cpp11 version: XYZ' to the top of the files, where XYZ is the version of
 #' cpp11 currently installed on your machine.
 #'
-#' If you choose to vendor the headers you should _remove_ `LinkingTo:
-#' cpp11` from your DESCRIPTION.
-#'
 #' **Note**: vendoring places the responsibility of updating the code on
 #' **you**. Bugfixes and new features in cpp11 will not be available for your
 #' code until you run `cpp_vendor()` again.
 #'
 #' @inheritParams cpp_register
+#' @param dir The directoyy to vendor the code into.
+#' @param subdir The subdirectory to vendor the code into.
+#' @param headers The path to the cpp11 headers to vendor. By default this is
+#'  the path where R installed the cpp11 package. You can change this to
+#'  use a different version of cpp11, such as as the development version
+#'  from GitHub. 
 #' @return The file path to the vendored code (invisibly).
 #' @export
 #' @examples
@@ -30,34 +33,85 @@
 #'
 #' # cleanup
 #' unlink(dir, recursive = TRUE)
-cpp_vendor <- function(path = ".") {
-  new <- file.path(path, "inst", "include", "cpp11")
+cpp_vendor <- function(dir = NULL, subdir = "/inst/include") {
+  if (is.null(dir)) {
+    stop("You must provide a path to vendor the code into", call. = FALSE)
+  }
+
+  path <- paste0(dir, subdir)
 
-  if (dir.exists(new)) {
-    stop("'", new, "' already exists\n * run unlink('", new, "', recursive = TRUE)", call. = FALSE)
+  path2 <- file.path(path, "cpp11")
+  if (dir.exists(path2)) {
+    stop("'", path2, "' already exists\n * run unlink('", path2, "', recursive = TRUE)", call. = FALSE)
   }
 
-  dir.create(new , recursive = TRUE, showWarnings = FALSE)
+  # Vendor cpp11 ----
+
+  dir.create(
+    path2,
+    recursive = TRUE,
+    showWarnings = FALSE
+  )
+
+  current_cpp11 <- system.file(
+    "include",
+    "cpp11",
+    package = "cpp11"
+  )
 
-  current <- system.file("include", "cpp11", package = "cpp11")
-  if (!nzchar(current)) {
+  if (!nzchar(current_cpp11)) {
     stop("cpp11 is not installed", call. = FALSE)
   }
 
   cpp11_version <- utils::packageVersion("cpp11")
 
-  cpp11_header <- sprintf("// cpp11 version: %s\n// vendored on: %s", cpp11_version, Sys.Date())
+  cpp11_header <- sprintf(
+    "// cpp11 version: %s\n// vendored on: %s",
+    cpp11_version,
+    Sys.Date()
+  )
 
-  files <- list.files(current, full.names = TRUE)
+  write_header(
+    path, "cpp11.hpp", "cpp11",
+    cpp11_header
+  )
 
+  copy_files(
+    list.files(current_cpp11, full.names = TRUE),
+    path, "cpp11", cpp11_header
+  )
+
+  # Additional steps to make vendoring work ----
+
+  message(paste(
+    "Makevars and/or Makevars.win should have a line such as",
+    "'PKG_CPPFLAGS = -I../inst/include'"
+  ))
+
+  message("DESCRIPTION should not have lines such as 'LinkingTo: cpp11'")
+
+  files <- list.files(headers, full.names = TRUE)
+
+  invisible(path)
+}
+
+write_header <- function(path, header, pkg, cpp11armadillo_header) {
   writeLines(
-    c(cpp11_header, readLines(system.file("include", "cpp11.hpp", package = "cpp11"))),
-    file.path(dirname(new), "cpp11.hpp")
+    c(
+      cpp11armadillo_header,
+      readLines(
+        system.file("include", header, package = pkg)
+      )
+    ),
+    file.path(path, header)
   )
+}
 
+copy_files <- function(files, path, out, cpp11armadillo_header) {
   for (f in files) {
-    writeLines(c(cpp11_header, readLines(f)), file.path(new, basename(f)))
+    writeLines(
+      c(cpp11armadillo_header, readLines(f)),
+      file.path(path, out, basename(f))
+    )
   }
-
-  invisible(new)
 }