Support native routine registration for C

pkgbuild now supports generation of the native routine registration for
C code. The way this works is it uses
tools::package_native_routines_registration_skeleton() to generate the
registrations, than inserts them in `src/init.c` between pkgdown
specific comments.

The rest of the file is passed through unchanged, so if you need to have
custom init code or additional includes you can do so just by adding it
to the same file, only the code
within the comments will be altered when the registration is updated.

Fixes #50

NAMESPACE

@@ -15,7 +15,9 @@ export(has_devel)
 export(has_latex)
 export(has_rtools)
 export(local_build_tools)
+export(needs_compile)
 export(pkg_has_src)
+export(pkg_links_to_rcpp)
 export(pkgbuild_process)
 export(rcmd_build_tools)
 export(rtools_path)

NEWS.md

@@ -1,5 +1,9 @@
 # Development
 
+* `build()` and `compile_dll()` gain a `register_routines` argument, to
+  automatically register C routines with
+  `tools::package_native_routines_registration_skeleton()` (#50)
+
 * `build()` will now warn if trying to build packages on R versions <= 3.4.2 on
   Windows with a space in the R installation directory (#49)
 

R/build-bg.R

@@ -50,9 +50,11 @@ pkgbuild_process <- R6Class(
 
     initialize = function(path = ".", dest_path = NULL, binary = FALSE,
                           vignettes = TRUE, manual = FALSE, args = NULL,
-                          needs_compilation = NA, compile_attributes = TRUE)
+                          needs_compilation = pkg_has_src(path),
+                          compile_attributes = FALSE,
+                          register_routines = FALSE)
       rcb_init(self, private, super, path, dest_path, binary, vignettes,
-               manual, args, needs_compilation, compile_attributes),
+               manual, args, needs_compilation, compile_attributes, register_routines),
 
     finalize = function() {
       super$kill()
@@ -97,10 +99,10 @@ pkgbuild_process <- R6Class(
 
 rcb_init <- function(self, private, super, path, dest_path, binary,
                      vignettes, manual, args, needs_compilation,
-                     compile_attributes) {
+                     compile_attributes, register_routines) {
 
   options <- build_setup(path, dest_path, binary, vignettes, manual, args,
-                         needs_compilation, compile_attributes)
+                         needs_compilation, compile_attributes, register_routines)
 
   private$path <- options$path
   private$dest_path <- options$dest_path

R/build.R

@@ -25,15 +25,20 @@
 #' @param compile_attributes if `TRUE` and the package uses Rcpp, call
 #'   [Rcpp::compileAttributes()] before building the package. It is ignored
 #'   if package does not need compilation.
+#' @param register_routines if `TRUE` and the package does not use Rcpp, call
+#'   register routines with
+#'   `tools::package_native_routine_registration_skeleton()` before building
+#'   the package. It is ignored if package does not need compilation.
 #' @export
 #' @return a string giving the location (including file name) of the built
 #'  package
 build <- function(path = ".", dest_path = NULL, binary = FALSE, vignettes = TRUE,
                   manual = FALSE, args = NULL, quiet = FALSE,
-                  needs_compilation = NA, compile_attributes = TRUE) {
+                  needs_compilation = pkg_has_src(path), compile_attributes = FALSE,
+                  register_routines = FALSE) {
 
   options <- build_setup(path, dest_path, binary, vignettes, manual, args,
-                         needs_compilation, compile_attributes)
+                         needs_compilation, compile_attributes, register_routines)
   on.exit(unlink(options$out_dir, recursive = TRUE), add = TRUE)
 
   withr::with_temp_libpaths(
@@ -55,19 +60,19 @@ build <- function(path = ".", dest_path = NULL, binary = FALSE, vignettes = TRUE
 }
 
 build_setup <- function(path, dest_path, binary, vignettes, manual, args,
-                        needs_compilation, compile_attributes) {
+                        needs_compilation, compile_attributes, register_routines) {
 
   if (!file.exists(path)) {
     stop("`path` must exist", call. = FALSE)
   }
   if (!is_dir(path)) {
     if (!binary) stop("`binary` must be TRUE for package files", call. = FALSE)
-    if (is.na(needs_compilation)) {
-      stop("`needs_compilation` cannot be NA for package files", call. = FALSE)
-    }
     if (compile_attributes) {
       stop("`compile_attributes` must be FALSE for package files", call. = FALSE)
     }
+    if (register_routines) {
+      stop("`register_routines` must be FALSE for package files", call. = FALSE)
+    }
   } else {
     path <- pkg_path(path)
   }
@@ -76,12 +81,8 @@ build_setup <- function(path, dest_path, binary, vignettes, manual, args,
     dest_path <- dirname(path)
   }
 
-  if (is.na(needs_compilation)) {
-    needs_compilation <- pkg_has_src(path)
-  }
-
-  if (needs_compilation && compile_attributes) {
-    compile_rcpp_attributes(path)
+  if (needs_compilation) {
+    update_registration(path, compile_attributes, register_routines)
   }
 
   if (binary) {

R/c-registration.R

@@ -0,0 +1,119 @@
+update_registration <- function(path, compile_attributes, register_routines) {
+  if (compile_attributes) {
+    compile_rcpp_attributes(path)
+  } else if (register_routines) {
+    update_c_registration(path)
+    check_namespace_registration(path)
+  }
+
+}
+
+update_c_registration <- function(path) {
+
+  path <- pkg_path(path)
+
+  pkgbuild_init_file <- file.path(path, "src", "init.c")
+
+  should_update <- !file.exists(pkgbuild_init_file) || any(grepl("generated by pkgbuild", readLines(pkgbuild_init_file)))
+
+  if (!should_update) {
+    return(invisible(character()))
+  }
+
+  # package_native_routine_registration_skeleton is not available before R 3.4
+  if (getRversion() < "3.4.0") {
+    return(invisible(character()))
+  }
+
+  con <- textConnection(NULL, "w")
+  tools::package_native_routine_registration_skeleton(path, con = con, character_only = FALSE)
+  lines <- textConnectionValue(con)
+  close(con)
+
+  if (length(lines) == 0) {
+    return(invisible(lines))
+  }
+
+  if (!file.exists(pkgbuild_init_file)) {
+
+    lines <- remove_fixme(lines)
+
+  } else {
+    current_lines <- readLines(pkgbuild_init_file)
+
+    current_range <- pkgbuild_generated_section(current_lines)
+
+    new_range <- tools_generated_section(lines)
+
+    lines <- c(
+      current_lines[seq(1, min(current_range) - 1)],
+      lines[new_range],
+      current_lines[seq(max(current_range) + 1, length(current_lines))]
+    )
+  }
+
+  lines <- add_generation_message(lines)
+  writeLines(lines, pkgbuild_init_file)
+
+  invisible(lines)
+}
+
+remove_fixme <- function(lines) {
+  fixme_loc <- grep("/* FIXME: ", lines, fixed = TRUE)
+  lines <- lines[-seq(fixme_loc, fixme_loc + 2)]
+
+  lines
+}
+
+tools_generated_section <- function(lines) {
+  start_loc <- grep("/* .Call calls */", lines, fixed = TRUE)
+  end_loc <- grep("};", lines, fixed = TRUE)
+
+  seq(start_loc, end_loc)
+}
+
+pkgbuild_generated_section <- function(lines) {
+  start_loc <- grep("/* Section generated by pkgbuild, do not edit */", lines, fixed = TRUE)
+  end_loc <- grep("/* End section generated by pkgbuild */", lines, fixed = TRUE)
+
+  seq(start_loc, end_loc)
+}
+
+add_generation_message <- function(lines) {
+  start_loc <- grep("/* .Call calls */", lines, fixed = TRUE)
+  end_loc <- grep("};", lines, fixed = TRUE)
+
+  if (end_loc <= start_loc) {
+    stop("Malformed init.c format")
+  }
+
+  lines <- append(lines, "/* Section generated by pkgbuild, do not edit */", after = start_loc - 1)
+
+  lines <- append(lines, "/* End section generated by pkgbuild */", after = end_loc + 1)
+
+  lines
+}
+
+check_namespace_registration <- function(path) {
+  path <- pkg_path(path)
+
+  namespace_file <- file.path(path, "NAMESPACE")
+
+  if (!file.exists(namespace_file)) {
+    warning("NAMESPACE file missing", immediate. = TRUE)
+  }
+
+  pkg_namespace <- readLines(namespace_file, warn = FALSE)
+  has_registration <- any(grepl("^[[:space:]]*useDynLib.*[.]registration[[:space:]]*=[[:space:]]*TRUE", pkg_namespace))
+
+  if (!has_registration) {
+    warning(immediate. = TRUE, call. = FALSE,
+      sprintf(
+"NAMESPACE missing native routine registration:
+  * Add `#' @useDynLib %s, .registration = TRUE` to R files.
+  * Run `devtools::document()`",
+        pkg_name(path)
+      )
+    )
+  }
+}

R/compile-dll.R

@@ -13,16 +13,23 @@
 #'   `PKG_CPPFLAGS=`$(R_HOME)/bin/Rscript -e 'Rcpp:::CxxFlags()'``
 #'
 #' @inheritParams build
+#' @param force If `TRUE`, for compilation even if [needs_compile()] is
+#'   `FALSE`.
 #' @seealso [clean_dll()] to delete the compiled files.
 #' @export
-compile_dll <- function(path = ".", quiet = FALSE) {
+compile_dll <- function(path = ".",
+                        force = FALSE,
+                        compile_attributes = pkg_links_to_rcpp(path),
+                        register_routines = !compile_attributes,
+                        quiet = FALSE) {
   path <- pkg_path(path)
 
-  if (!needs_compile(path))
+  if (!needs_compile(path) && !isTRUE(force)) {
     return(invisible())
+  }
 
   check_build_tools()
-  compile_rcpp_attributes(path)
+  update_registration(path, compile_attributes, register_routines)
 
   # Mock install the package to generate the DLL
   if (!quiet)
@@ -115,8 +122,12 @@ headers <- function(path = ".") {
   )
 }
 
-# Does the package need recompiling?
-# (i.e. is there a source or header file newer than the dll)
+
+#' Does the package need recompiling?
+#' (i.e. is there a source or header file newer than the dll)
+#' @inheritParams build
+#' @keywords internal
+#' @export
 needs_compile <- function(path = ".") {
   source <- mtime(c(sources(path), headers(path)))
   # no source files, so doesn't need compile

R/rcpp-attributes.R

@@ -3,11 +3,20 @@
 compile_rcpp_attributes <- function(path = ".") {
   path <- pkg_path(path)
 
-  deps <- desc::desc_get_deps(file.path(path, "DESCRIPTION"))
-  links_to_rcpp <- any(deps$type == "LinkingTo" & deps$package == "Rcpp")
-
-  if (links_to_rcpp) {
+  if (pkg_links_to_rcpp(path)) {
     unlink(file.path(path, c("R/RcppExports.R", "src/RcppExports.cpp")))
     Rcpp::compileAttributes(path)
   }
 }
+
+#' Test if a package path is linking to Rcpp
+#' @inheritParams build
+#' @export
+#' @keywords internal
+pkg_links_to_rcpp <- function(path) {
+  path <- pkg_path(path)
+
+  deps <- desc::desc_get_deps(file.path(path, "DESCRIPTION"))
+
+  any(deps$type == "LinkingTo" & deps$package == "Rcpp")
+}

tests/testthat/test-build-process.r

@@ -59,7 +59,7 @@ test_that("source builds return correct filenames", {
   dir.create(tmp <- tempfile())
   on.exit(unlink(tmp, recursive = TRUE), add = TRUE)
 
-  pr <- pkgbuild_process$new("testWithSrc", dest_path = tmp)
+  pr <- pkgbuild_process$new("testWithSrc", dest_path = tmp, register_routines = FALSE)
   pr$wait(60000)
   if (pr$is_alive()) {
     pr$kill()
@@ -74,7 +74,7 @@ test_that("source builds return correct filenames", {
 test_that("build package with src requires compiler", {
   without_compiler({
     expect_error({
-      pr <- pkgbuild_process$new("testWithSrc", dest_path = tempdir())
+      pr <- pkgbuild_process$new("testWithSrc", dest_path = tempdir(), register_routines = FALSE)
       pr$kill()
     }, "Could not find tools")
   })