R/c-registration.R

In pkgbuild: Find Tools Needed to Build R Packages

update_registration <- function(path, compile_attributes, register_routines, quiet) {
  if (compile_attributes) {
    if (pkg_links_to_cpp11(path)) {
      cpp11::cpp_register(path, quiet = quiet)
    } else if (pkg_links_to_rcpp(path)) {
      unlink(file.path(path, c("R/RcppExports.R", "src/RcppExports.cpp")))
      Rcpp::compileAttributes(path, verbose = !quiet)
    }
  } 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)
      )
    )
  }
}

#' Test if a package path is linking to Rcpp or cpp11
#'
#' @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")
}

#' @rdname pkg_links_to_rcpp
#' @keywords internal
#' @export
pkg_links_to_cpp11 <- function(path) {
  path <- pkg_path(path)

  desc <- desc::desc(file = file.path(path, "DESCRIPTION"))
  deps <- desc$get_deps()

  desc$get_field("Package") == "cpp11" || any(deps$type == "LinkingTo" & deps$package == "cpp11")
}