# Copyright (C) 2012 - 2022 JJ Allaire, Dirk Eddelbuettel and Romain Francois
# Copyright (C) 2023 - 2024 JJ Allaire, Dirk Eddelbuettel, Romain Francois and Iñaki Ucar
#
# This file is part of Rcpp.
#
# Rcpp is free software: you can redistribute it and/or modify it
# under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 2 of the License, or
# (at your option) any later version.
#
# Rcpp is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with Rcpp. If not, see <http://www.gnu.org/licenses/>.
# Source C++ code from a file
sourceCpp <- function(file = "",
code = NULL,
env = globalenv(),
embeddedR = TRUE,
rebuild = FALSE,
cacheDir = getOption("rcpp.cache.dir", tempdir()),
cleanupCacheDir = FALSE,
showOutput = verbose,
verbose = getOption("verbose"),
dryRun = FALSE,
windowsDebugDLL = FALSE,
echo = TRUE) {
# use an architecture/version specific subdirectory of the cacheDir
# (since cached dynlibs can now perist across sessions we need to be
# sure to invalidate them when R or Rcpp versions change)
cacheDir <- path.expand(cacheDir)
cacheDir <- .sourceCppPlatformCacheDir(cacheDir)
cacheDir <- normalizePath(cacheDir)
# resolve code into a file if necessary. also track the working
# directory to source the R embedded code chunk within
if (!missing(code)) {
rWorkingDir <- getwd()
file <- tempfile(fileext = ".cpp", tmpdir = cacheDir)
con <- file(file, open = "w")
writeLines(code, con)
close(con)
} else {
rWorkingDir <- normalizePath(dirname(file))
}
# resolve the file path
file <- normalizePath(file, winslash = "/")
# error if the file extension isn't one supported by R CMD SHLIB
if (! tools::file_ext(file) %in% c("cc", "cpp")) { # #nocov start
stop("The filename '", basename(file), "' does not have an ",
"extension of .cc or .cpp so cannot be compiled.")
} # #nocov end
# validate that there are no spaces in the path on windows
if (.Platform$OS.type == "windows") { # #nocov start
if (grepl(' ', basename(file), fixed=TRUE)) {
stop("The filename '", basename(file), "' contains spaces. This ",
"is not permitted.")
}
} else {
if (windowsDebugDLL) {
if (verbose) {
message("The 'windowsDebugDLL' toggle is ignored on ",
"non-Windows platforms.")
}
windowsDebugDLL <- FALSE # now we do not need to deal with OS choice below
} # #nocov end
}
# get the context (does code generation as necessary)
context <- .Call("sourceCppContext", PACKAGE="Rcpp",
file, code, rebuild, cacheDir, .Platform)
# perform a build if necessary
if (context$buildRequired || rebuild) {
# print output for verbose mode
if (verbose)
.printVerboseOutput(context) # #nocov
# variables used to hold completed state (passed to completed hook)
succeeded <- FALSE
output <- NULL
# build dependency list
depends <- .getSourceCppDependencies(context$depends, file)
# validate packages (error if package not found)
.validatePackages(depends, context$cppSourceFilename)
# temporarily modify environment for the build
envRestore <- .setupBuildEnvironment(depends, context$plugins, file)
# temporarily setwd to build directory
cwd <- getwd()
setwd(context$buildDirectory)
# call the onBuild hook. note that this hook should always be called
# after .setupBuildEnvironment so subscribers are able to examine
# the build environment
fromCode <- !missing(code)
if (!.callBuildHook(context$cppSourcePath, fromCode, showOutput)) {
.restoreEnvironment(envRestore) # #nocov start
setwd(cwd)
return (invisible(NULL))
} # #nocov end
# on.exit handler calls hook and restores environment and working dir
on.exit({
if (!succeeded)
.showBuildFailureDiagnostics() # #nocov
.callBuildCompleteHook(succeeded, output)
setwd(cwd)
.restoreEnvironment(envRestore)
})
# unload and delete existing dylib if necessary
if (file.exists(context$previousDynlibPath)) { # #nocov start
try(silent=TRUE, dyn.unload(context$previousDynlibPath))
file.remove(context$previousDynlibPath)
} # #nocov end
# grab components we need to build command
r <- file.path(R.home("bin"), "R")
lib <- context$dynlibFilename
deps <- context$cppDependencySourcePaths
src <- context$cppSourceFilename
# prepare the command (output if we are in showOutput mode)
args <- c(
"CMD", "SHLIB",
if (windowsDebugDLL) "-d",
if (rebuild) "--preclean",
if (dryRun) "--dry-run",
"-o", shQuote(lib),
if (length(deps))
paste(shQuote(deps), collapse = " "),
shQuote(src)
)
if (showOutput)
cat(paste(c(r, args), collapse = " "), "\n") # #nocov
# execute the build -- suppressWarnings b/c when showOutput = FALSE
# we are going to explicitly check for an error and print the output
so <- if (showOutput) "" else TRUE
result <- suppressWarnings(system2(r, args, stdout = so, stderr = so))
# check build results
if(!showOutput) {
# capture output
output <- result
attributes(output) <- NULL
# examine status
status <- attr(result, "status")
if (!is.null(status)) {
cat(result, sep = "\n") # #nocov start
succeeded <- FALSE
stop("Error ", status, " occurred building shared library.")
} else if (!file.exists(context$dynlibFilename)) {
cat(result, sep = "\n")
succeeded <- FALSE
stop("Error occurred building shared library.") # #nocov end
} else {
succeeded <- TRUE
}
}
else if (!identical(as.character(result), "0")) { # #nocov start
succeeded <- FALSE
stop("Error ", result, " occurred building shared library.")
} else {
succeeded <- TRUE # #nocov end
}
}
else {
cwd <- getwd()
on.exit({
setwd(cwd)
})
if (verbose) # #nocov start
cat("\nNo rebuild required (use rebuild = TRUE to ",
"force a rebuild)\n\n", sep="")
}
# return immediately if this was a dry run
if (dryRun)
return(invisible(NULL)) # #nocov end
# load the module if we have exported symbols
if (length(context$exportedFunctions) > 0 || length(context$modules) > 0) {
# remove existing objects of the same name from the environment
exports <- c(context$exportedFunctions, context$modules)
removeObjs <- exports[exports %in% ls(envir = env, all.names = T)]
remove(list = removeObjs, envir = env)
# source the R script
scriptPath <- file.path(context$buildDirectory, context$rSourceFilename)
source(scriptPath, local = env)
} else if (getOption("rcpp.warnNoExports", default=TRUE)) { # #nocov start
warning("No Rcpp::export attributes or RCPP_MODULE declarations ",
"found in source") # #nocov end
}
# source the embeddedR
if (embeddedR && (length(context$embeddedR) > 0)) {
srcConn <- textConnection(context$embeddedR)
setwd(rWorkingDir) # will be reset by previous on.exit handler
source(file = srcConn, local = env, echo = echo)
}
# cleanup the cache dir if requested
if (cleanupCacheDir)
cleanupSourceCppCache(cacheDir, context$cppSourcePath, context$buildDirectory) # #nocov
# return (invisibly) a list containing exported functions and modules
invisible(list(functions = context$exportedFunctions,
modules = context$modules,
cppSourcePath = context$cppSourcePath,
buildDirectory = context$buildDirectory))
}
# Cleanup a directory used as the cache for a sourceCpp compilation. This will
# remove all files from the cache directory that aren't a result of the
# compilation that yielded the passed buildDirectory.
cleanupSourceCppCache <- function(cacheDir, cppSourcePath, buildDirectory) {
# normalize cpp source path and build directory # #nocov start
cppSourcePath <- normalizePath(cppSourcePath)
buildDirectory <- normalizePath(buildDirectory)
# determine the parent dir that was used for the compilation then collect all the
# *.cpp files and subdirectories therein
cacheFiles <- list.files(cacheDir, pattern = glob2rx("*.cpp"), recursive = FALSE, full.names = TRUE)
cacheFiles <- c(cacheFiles, list.dirs(cacheDir, recursive = FALSE, full.names = TRUE))
cacheFiles <- normalizePath(cacheFiles)
# determine the list of tiles that were not yielded by the passed sourceCpp
# result and remove them
oldCacheFiles <- cacheFiles[!cacheFiles %in% c(cppSourcePath, buildDirectory)]
unlink(oldCacheFiles, recursive = TRUE) # #nocov end
}
# Define a single C++ function
cppFunction <- function(code,
depends = character(),
plugins = character(),
includes = character(),
env = parent.frame(),
rebuild = FALSE,
cacheDir = getOption("rcpp.cache.dir", tempdir()),
showOutput = verbose,
verbose = getOption("verbose"),
echo = TRUE) {
# process depends
if (!is.null(depends) && length(depends) > 0) { # #nocov start
depends <- paste(depends, collapse=", ")
scaffolding <- paste("// [[Rcpp::depends(", depends, ")]]", sep="")
scaffolding <- c(scaffolding, "", .linkingToIncludes(depends, FALSE),
recursive=TRUE) # #nocov end
}
else {
scaffolding <- "#include <Rcpp.h>"
}
# process plugins
if (!is.null(plugins) && length(plugins) > 0) {
plugins <- paste(plugins, sep=", ") # #nocov start
pluginsAttrib <- paste("// [[Rcpp::plugins(", plugins, ")]]", sep="")
scaffolding <- c(scaffolding, pluginsAttrib)
# append plugin includes
for (pluginName in plugins) {
plugin <- .findPlugin(pluginName)
settings <- plugin()
scaffolding <- c(scaffolding, settings$includes, recursive=TRUE)
} # #nocov end
}
# remainder of scaffolding
scaffolding <- c(scaffolding,
"",
"using namespace Rcpp;",
"",
includes,
"// [[Rcpp::export]]",
recursive = T)
# prepend scaffolding to code
code <- paste(c(scaffolding, code, recursive = T), collapse="\n")
# print the generated code if we are in verbose mode
if (verbose) { # #nocov start
cat("\nGenerated code for function definition:",
"\n--------------------------------------------------------\n\n")
cat(code)
cat("\n")
}
# source cpp into specified environment. if env is set to NULL
# then create a new one (the caller can get a hold of the function
# via the return value)
if (is.null(env))
env <- new.env() # #nocov end
exported <- sourceCpp(code = code,
env = env,
rebuild = rebuild,
cacheDir = cacheDir,
showOutput = showOutput,
verbose = verbose,
echo = echo)
# verify that a single function was exported and return it
if (length(exported$functions) == 0)
stop("No function definition found") # #nocov
else if (length(exported$functions) > 1)
stop("More than one function definition") # #nocov
else {
functionName <- exported$functions[[1]]
invisible(get(functionName, env))
}
}
.type_manipulate <- function( what = "DEMANGLE", class = NULL ) {
function( type = "int", ... ){ # #nocov start
code <- sprintf( '
SEXP manipulate_this_type(){
typedef %s type ;
return wrap( %s(type) ) ;
}', type, what )
dots <- list( code, ... )
dots[["env"]] <- environment()
manipulate_this_type <- do.call( cppFunction, dots )
res <- manipulate_this_type()
if( ! is.null(class) ){
class(res) <- class
}
res
} # #nocov end
}
demangle <- .type_manipulate( "DEMANGLE" )
sizeof <- .type_manipulate( "sizeof", "bytes" )
print.bytes <- function( x, ...){ # #nocov start
writeLines( sprintf( "%d bytes (%d bits)", x, 8 * x ) )
invisible( x )
} # #nocov end
# Evaluate a simple c++ expression
evalCpp <- function(code,
depends = character(),
plugins = character(),
includes = character(),
rebuild = FALSE,
cacheDir = getOption("rcpp.cache.dir", tempdir()),
showOutput = verbose,
verbose = getOption( "verbose" ) ){
# #nocov start
code <- sprintf( "SEXP get_value(){ return wrap( %s ) ; }", code )
env <- new.env()
cppFunction(code, depends = depends, plugins = plugins,
includes = includes, env = env,
rebuild = rebuild, cacheDir = cacheDir, showOutput = showOutput, verbose = verbose )
fun <- env[["get_value"]]
fun() # #nocov end
}
areMacrosDefined <- function(names,
depends = character(),
includes = character(),
rebuild = FALSE,
showOutput = verbose,
verbose = getOption( "verbose" ) ){
code <- sprintf( '
LogicalVector get_value(){
return LogicalVector::create(
%s
) ;
}',
paste( sprintf( ' _["%s"] =
#if defined(%s)
true
#else
false
#endif
', names, names ), collapse = ",\n" )
)
env <- new.env()
cppFunction(code, depends = depends, includes = includes, env = env,
rebuild = rebuild, showOutput = showOutput, verbose = verbose )
fun <- env[["get_value"]]
fun()
}
# Scan the source files within a package for attributes and generate code
# based on the attributes.
compileAttributes <- function(pkgdir = ".", verbose = getOption("verbose")) {
# verify this is a package and read the DESCRIPTION to get it's name
pkgdir <- normalizePath(pkgdir, winslash = "/")
descFile <- file.path(pkgdir,"DESCRIPTION")
if (!file.exists(descFile))
stop("pkgdir must refer to the directory containing an R package") # #nocov
pkgDesc <- read.dcf(descFile)[1,]
pkgname = .readPkgDescField(pkgDesc, "Package")
depends <- c(.readPkgDescField(pkgDesc, "Depends", character()),
.readPkgDescField(pkgDesc, "Imports", character()),
.readPkgDescField(pkgDesc, "LinkingTo", character()))
depends <- unique(.splitDepends(depends))
depends <- depends[depends != "R"]
# check the NAMESPACE file to see if dynamic registration is enabled
namespaceFile <- file.path(pkgdir, "NAMESPACE")
if (!file.exists(namespaceFile))
stop("pkgdir must refer to the directory containing an R package") # #nocov
pkgNamespace <- readLines(namespaceFile, warn = FALSE)
registration <- any(grepl("^\\s*useDynLib.*\\.registration\\s*=\\s*TRUE.*$", pkgNamespace))
# determine source directory
srcDir <- file.path(pkgdir, "src")
if (!file.exists(srcDir))
return (FALSE) # #nocov
# create R directory if it doesn't already exist
rDir <- file.path(pkgdir, "R")
if (!file.exists(rDir))
dir.create(rDir) # #nocov
# remove the old RcppExports.R file
unlink(file.path(rDir, "RcppExports.R"))
# get a list of all source files
cppFiles <- list.files(srcDir, pattern = "\\.((c(c|pp)?)|(h(pp)?))$", ignore.case = TRUE)
# don't include RcppExports.cpp
cppFiles <- setdiff(cppFiles, "RcppExports.cpp")
# locale independent sort for stable output
locale <- Sys.getlocale(category = "LC_COLLATE")
Sys.setlocale(category = "LC_COLLATE", locale = "C")
cppFiles <- sort(cppFiles)
Sys.setlocale(category = "LC_COLLATE", locale = locale)
# derive base names (will be used for modules)
cppFileBasenames <- tools::file_path_sans_ext(cppFiles)
# expend them to their full paths
cppFiles <- file.path(srcDir, cppFiles)
cppFiles <- normalizePath(cppFiles, winslash = "/")
# generate the includes list based on LinkingTo. Specify plugins-only
# because we only need as/wrap declarations
linkingTo <- .readPkgDescField(pkgDesc, "LinkingTo")
includes <- .linkingToIncludes(linkingTo, TRUE)
# if a master include file or types file is in inst/include then use it
typesHeader <- c(paste0(pkgname, "_types.h"), paste0(pkgname, "_types.hpp"))
pkgHeader <- c(paste0(pkgname, ".h"), typesHeader)
pkgHeaderPath <- file.path(pkgdir, "inst", "include", pkgHeader)
pkgHeader <- pkgHeader[file.exists(pkgHeaderPath)]
if (length(pkgHeader) > 0) { # #nocov start
pkgInclude <- paste("#include \"../inst/include/",
pkgHeader, "\"", sep="")
includes <- c(pkgInclude, includes)
} # #nocov end
# if a _types file is in src then include it
pkgHeader <- typesHeader
pkgHeaderPath <- file.path(pkgdir, "src", pkgHeader)
pkgHeader <- pkgHeader[file.exists(pkgHeaderPath)]
if (length(pkgHeader) > 0)
includes <- c(paste0("#include \"", pkgHeader ,"\""), includes) # #nocov
# generate exports
invisible(.Call("compileAttributes", PACKAGE="Rcpp",
pkgdir, pkgname, depends, registration, cppFiles, cppFileBasenames,
includes, verbose, .Platform))
}
# setup plugins environment
.plugins <- new.env()
# built-in C++98 plugin
.plugins[["cpp98"]] <- function() {
if (getRversion() >= "3.4") # with recent R versions, R can decide
list(env = list(USE_CXX98 = "yes"))
else
list(env = list(PKG_CXXFLAGS ="-std=c++98"))
}
# built-in C++11 plugin
.plugins[["cpp11"]] <- function() {
if (getRversion() >= "3.4") # with recent R versions, R can decide
list(env = list(USE_CXX11 = "yes"))
else if (getRversion() >= "3.1") # with recent R versions, R can decide
list(env = list(USE_CXX1X = "yes"))
else if (.Platform$OS.type == "windows")
list(env = list(PKG_CXXFLAGS = "-std=c++0x"))
else # g++-4.8.1 or later
list(env = list(PKG_CXXFLAGS ="-std=c++11"))
}
# built-in C++11 plugin for older g++ compiler
.plugins[["cpp0x"]] <- function() {
list(env = list(PKG_CXXFLAGS ="-std=c++0x"))
}
## built-in C++14 plugin for C++14 standard
## this is the default in g++-6.1 and later
## per https://gcc.gnu.org/projects/cxx-status.html#cxx14
.plugins[["cpp14"]] <- function() {
if (getRversion() >= "3.4") # with recent R versions, R can decide
list(env = list(USE_CXX14 = "yes"))
else
list(env = list(PKG_CXXFLAGS ="-std=c++14"))
}
# built-in C++1y plugin for C++14 and C++17 standard under development
.plugins[["cpp1y"]] <- function() {
list(env = list(PKG_CXXFLAGS ="-std=c++1y"))
}
# built-in C++17 plugin for C++17 standard (g++-6 or later)
.plugins[["cpp17"]] <- function() {
if (getRversion() >= "3.4") # with recent R versions, R can decide
list(env = list(USE_CXX17 = "yes"))
else
list(env = list(PKG_CXXFLAGS ="-std=c++17"))
}
# built-in C++20 plugin for C++20
.plugins[["cpp20"]] <- function() {
if (getRversion() >= "4.2") # with recent R versions, R can decide
list(env = list(USE_CXX20 = "yes"))
else
list(env = list(PKG_CXXFLAGS ="-std=c++20"))
}
# built-in C++23 plugin for C++23
.plugins[["cpp23"]] <- function() {
if (getRversion() >= "4.3") # with recent R versions, R can decide
list(env = list(USE_CXX23 = "yes"))
else
list(env = list(PKG_CXXFLAGS ="-std=c++23"))
}
## built-in C++1z plugin for C++17 standard under development
## note that as of Feb 2017 this is taken to be a moving target
## see https://gcc.gnu.org/projects/cxx-status.html
.plugins[["cpp1z"]] <- function() {
list(env = list(PKG_CXXFLAGS ="-std=c++1z"))
}
## built-in C++2a plugin for g++ 8 and later
## cf https://gcc.gnu.org/projects/cxx-status.html as of Dec 2018
.plugins[["cpp2a"]] <- function() {
list(env = list(PKG_CXXFLAGS ="-std=c++2a"))
}
## built-in C++2b plugin for compilers without C++23 support
.plugins[["cpp2b"]] <- function() {
list(env = list(PKG_CXXFLAGS ="-std=c++2b"))
}
## built-in OpenMP plugin
.plugins[["openmp"]] <- function() {
list(env = list(PKG_CXXFLAGS="-fopenmp",
PKG_LIBS="-fopenmp"))
}
.plugins[["unwindProtect"]] <- function() { # nocov start
warning("unwindProtect is enabled by default and this plugin is deprecated.",
" It will be removed in a future version of Rcpp.")
list()
} # nocov end
# register a plugin
registerPlugin <- function(name, plugin) {
.plugins[[name]] <- plugin # #nocov
}
# Take an empty function body and connect it to the specified external symbol
sourceCppFunction <- function(func, isVoid, dll, symbol) {
args <- names(formals(func))
body <- quote( CALL_PLACEHOLDER ( EXTERNALNAME, ARG ) )[ c(1:2, rep(3, length(args))) ]
for (i in seq(along.with = args))
body[[i+2]] <- as.symbol(args[i])
body[[1L]] <- quote(.Call)
body[[2L]] <- getNativeSymbolInfo(symbol, dll)$address
if (isVoid)
body <- call("invisible", body)
body(func) <- body
func
}
# Print verbose output
.printVerboseOutput <- function(context) { # #nocov start
cat("\nGenerated extern \"C\" functions",
"\n--------------------------------------------------------\n")
cat(context$generatedCpp, sep="")
cat("\nGenerated R functions",
"\n-------------------------------------------------------\n\n")
cat(readLines(file.path(context$buildDirectory,
context$rSourceFilename)),
sep="\n")
cat("\nBuilding shared library",
"\n--------------------------------------------------------\n",
"\nDIR: ", context$buildDirectory, "\n\n", sep="")
} # #nocov end
# Add LinkingTo dependencies if the sourceFile is in a package
.getSourceCppDependencies <- function(depends, sourceFile) {
# If the source file is in a package then simulate it being built
# within the package by including it's LinkingTo dependencies,
# the src directory (.), and the inst/include directory
if (.isPackageSourceFile(sourceFile)) { # #nocov start
descFile <- file.path(dirname(sourceFile), "..", "DESCRIPTION")
DESCRIPTION <- read.dcf(descFile, all = TRUE)
linkingTo <- .parseLinkingTo(DESCRIPTION$LinkingTo)
unique(c(depends, linkingTo)) # #nocov end
} else {
depends
}
}
# Check whether a source file is in a package
.isPackageSourceFile <- function(sourceFile) {
file.exists(file.path(dirname(sourceFile), "..", "DESCRIPTION"))
}
# Error if a package is not currently available
.validatePackages <- function(depends, sourceFilename) {
unavailable <- depends[!depends %in% .packages(all.available=TRUE)]
if (length(unavailable) > 0) { # #nocov start
stop(paste("Package '", unavailable[[1]], "' referenced from ",
"Rcpp::depends in source file ",
sourceFilename, " is not available.",
sep=""),
call. = FALSE) # #nocov end
}
}
# Split the depends field of a package description
.splitDepends <- function(x) {
if (!length(x))
return(character()) # #nocov
x <- unlist(strsplit(x, ","))
x <- sub("[[:space:]]+$", "", x)
x <- unique(sub("^[[:space:]]*(.*)", "\\1", x))
sub("^([[:alnum:].]+).*$", "\\1", x)
}
# read a field from a named package description character vector
.readPkgDescField <- function(pkgDesc, name, default = NULL) {
if (name %in% names(pkgDesc))
pkgDesc[[name]]
else
default
}
# Get the inline plugin for the specified package (return NULL if none found)
.getInlinePlugin <- function(package) { # #nocov start
tryCatch(get("inlineCxxPlugin", asNamespace(package), inherits = FALSE),
error = function(e) NULL)
} # #nocov end
# Lookup a plugin
.findPlugin <- function(pluginName) {
plugin <- .plugins[[pluginName]]
if (is.null(plugin))
stop("Inline plugin '", pluginName, "' could not be found ", # #nocov start
"within the Rcpp package. You should be ",
"sure to call registerPlugin before using a plugin.") # #nocov end
return(plugin)
}
# Setup the build environment based on the specified dependencies. Returns an
# opaque object that can be passed to .restoreEnvironment to reverse whatever
# changes that were made
.setupBuildEnvironment <- function(depends, plugins, sourceFile) {
# setup
buildEnv <- list()
linkingToPackages <- c("Rcpp")
# merge values into the buildEnv
mergeIntoBuildEnv <- function(name, value) {
# protect against null or empty string
if (is.null(value) || !nzchar(value))
return(invisible(NULL))
# if it doesn't exist already just set it
if (is.null(buildEnv[[name]])) {
buildEnv[[name]] <<- value
}
# if it's not identical then append
else if (!identical(buildEnv[[name]], value)) { # #nocov
buildEnv[[name]] <<- paste(buildEnv[[name]], value) # #nocov
}
else {
# it already exists and it's the same value, this
# likely means it's a flag-type variable so we
# do nothing rather than appending it
}
}
# update dependencies from a plugin
setDependenciesFromPlugin <- function(plugin) {
# get the plugin settings
settings <- plugin()
# merge environment variables
pluginEnv <- settings$env
for (name in names(pluginEnv)) {
mergeIntoBuildEnv(name, pluginEnv[[name]])
}
# capture any LinkingTo elements defined by the plugin
linkingToPackages <<- unique(c(linkingToPackages,
settings$LinkingTo))
}
# add packages to linkingTo and introspect for plugins
for (package in depends) {
# #nocov start
# add a LinkingTo for this package
linkingToPackages <- unique(c(linkingToPackages, package))
# see if the package exports a plugin
plugin <- .getInlinePlugin(package)
if (!is.null(plugin))
setDependenciesFromPlugin(plugin) # #nocov end
}
# process plugins
for (pluginName in plugins) {
plugin <- .findPlugin(pluginName)
setDependenciesFromPlugin(plugin)
}
# if there is no buildEnv from a plugin then use the Rcpp plugin
if (length(buildEnv) == 0) {
buildEnv <- inlineCxxPlugin()$env
}
# set CLINK_CPPFLAGS based on the LinkingTo dependencies
buildEnv$CLINK_CPPFLAGS <- .buildClinkCppFlags(linkingToPackages)
# add the source file's directory to the compilation
srcDir <- dirname(sourceFile)
srcDir <- asBuildPath(srcDir)
buildDirs <- srcDir
# if the source file is in a package then add inst/include
if (.isPackageSourceFile(sourceFile)) { # #nocov start
incDir <- file.path(dirname(sourceFile), "..", "inst", "include")
incDir <- asBuildPath(incDir)
buildDirs <- c(buildDirs, incDir) # #nocov end
}
# set CLINK_CPPFLAGS with directory flags
dirFlags <- paste0('-I"', buildDirs, '"', collapse=" ")
buildEnv$CLINK_CPPFLAGS <- paste(buildEnv$CLINK_CPPFLAGS,
dirFlags,
collapse=" ")
# merge existing environment variables
for (name in names(buildEnv))
mergeIntoBuildEnv(name, Sys.getenv(name))
# add cygwin message muffler
buildEnv$CYGWIN = "nodosfilewarning"
# on windows see if we need to add Rtools to the path
# (don't do this for RStudio since it has it's own handling)
if (identical(Sys.info()[['sysname']], "Windows") &&
!nzchar(Sys.getenv("RSTUDIO"))) { # #nocov start
env <- .environmentWithRtools()
for (var in names(env))
buildEnv[[var]] <- env[[var]] # #nocov end
}
# create restore list
restore <- list()
for (name in names(buildEnv))
restore[[name]] <- Sys.getenv(name, unset = NA)
# set environment variables
do.call(Sys.setenv, buildEnv)
# return restore list
return (restore)
}
# If we don't have the GNU toolchain already on the path then see if
# we can find Rtools and add it to the path
.environmentWithRtools <- function() {
# #nocov start
# Only proceed if we don't have the required tools on the path
hasRtools <- nzchar(Sys.which("ls.exe")) && nzchar(Sys.which("gcc.exe"))
if (!hasRtools) {
# Read the Rtools registry key
key <- NULL
try(key <- utils::readRegistry("SOFTWARE\\R-core\\Rtools",
hive = "HLM", view = "32-bit"),
silent = TRUE)
# If we found the key examine it
if (!is.null(key)) {
# Check version
ver <- key$`Current Version`
if (ver %in% (c("2.15", "2.16", "3.0", "3.1", "3.2", "3.3", "3.4"))) {
# See if the InstallPath leads to the expected directories
# R version 3.3.0 alpha (2016-03-25 r70378)
isGcc49 <- ver %in% c("3.3", "3.4") && as.numeric(R.Version()$`svn rev`) >= 70378
rToolsPath <- key$`InstallPath`
if (!is.null(rToolsPath)) {
# add appropriate path entries
path <- file.path(rToolsPath, "bin", fsep="\\")
if (!isGcc49)
path <- c(path, file.path(rToolsPath, "gcc-4.6.3", "bin", fsep="\\"))
# if they all exist then return a list with modified
# environment variables for the compilation
if (all(file.exists(path))) {
env <- list()
path <- paste(path, collapse = .Platform$path.sep)
env$PATH <- paste(path, Sys.getenv("PATH"), sep=.Platform$path.sep)
if (isGcc49) {
env$RTOOLS <- .rtoolsPath(rToolsPath)
env$BINPREF <- file.path(env$RTOOLS, "mingw_$(WIN)/bin//", fsep = "/")
}
return(env)
}
}
}
}
}
return(NULL) # #nocov end
}
# Ensure that the path is suitable for passing as an RTOOLS
# environment variable
.rtoolsPath <- function(path) {
path <- gsub("\\\\", "/", path) # #nocov start
## R 3.2.0 or later only: path <- trimws(path)
.localsub <- function(re, x) sub(re, "", x, perl = TRUE)
path <- .localsub("[ \t\r\n]+$", .localsub("^[ \t\r\n]+", path))
if (substring(path, nchar(path)) != "/")
path <- paste(path, "/", sep="")
path # #nocov end
}
# Build CLINK_CPPFLAGS from include directories of LinkingTo packages
.buildClinkCppFlags <- function(linkingToPackages) {
pkgCxxFlags <- NULL
for (package in linkingToPackages) {
packagePath <- find.package(package, NULL, quiet=TRUE)
packagePath <- asBuildPath(packagePath)
pkgCxxFlags <- paste(pkgCxxFlags,
paste0('-I"', packagePath, '/include"'),
collapse=" ")
}
return (pkgCxxFlags)
}
.restoreEnvironment <- function(restore) {
# variables to reset
setVars <- restore[!is.na(restore)]
if (length(setVars))
do.call(Sys.setenv, setVars) # #nocov
# variables to remove
removeVars <- names(restore[is.na(restore)])
if (length(removeVars))
Sys.unsetenv(removeVars)
}
# Call the onBuild hook. This hook is provided so that external tools
# can perform processing (e.g. lint checking or other diagnostics) prior
# to the execution of a build). The showOutput flag is there to inform the
# subscriber whether they'll be getting output in the onBuildComplete hook
# or whether it will need to be scraped from the console (for verbose=TRUE)
# The onBuild hook is always called from within the temporary build directory
.callBuildHook <- function(file, fromCode, showOutput) {
for (fun in .getHooksList("sourceCpp.onBuild")) {
if (is.character(fun)) # #nocov start
fun <- get(fun)
# allow the hook to cancel the build (errors in the hook explicitly
# do not cancel the build since they are unexpected bugs)
continue <- tryCatch(fun(file, fromCode, showOutput),
error = function(e) TRUE)
if (!continue)
return (FALSE) # #nocov end
}
return (TRUE)
}
# Call the onBuildComplete hook. This hook is provided so that external tools
# can do analysis of build errors and (for example) present them in a
# navigable list. Note that the output parameter will be NULL when showOutput
# is TRUE. Tools can try to scrape the output from the console (in an
# implemenentation-dependent fashion) or can simply not rely on output
# processing in that case (since the user explicitly asked for output to be
# printed to the console). The onBuildCompleted hook is always called within
# the temporary build directory.
.callBuildCompleteHook <- function(succeeded, output) {
# Call the hooks in reverse order to align sequencing with onBuild
for (fun in .getHooksList("sourceCpp.onBuildComplete")) {
if (is.character(fun)) # #nocov start
fun <- get(fun)
try(fun(succeeded, output)) # #nocov end
}
}
# The value for getHooks can be a single function or a list of functions,
# This function ensures that the result can always be processed as a list
.getHooksList <- function(name) {
hooks <- getHook(name)
if (!is.list(hooks))
hooks <- list(hooks) # #nocov
hooks
}
# Generate list of includes based on LinkingTo. The pluginsOnly parameter
# to distinguish the case of capturing all includes needed for a compiliation
# (e.g. cppFunction) verses only needing to capture as/wrap converters which
# is the case for generation of shims (RcppExports.cpp) and Rcpp::interfaces
# package header files.
.linkingToIncludes <- function(linkingTo, pluginsOnly) {
# This field can be NULL or empty -- in that case just return Rcpp.h
if (is.null(linkingTo) || !nzchar(linkingTo))
return (c("#include <Rcpp.h>")) # #nocov
# Look for Rcpp inline plugins within the list or LinkedTo packages
include.before <- character()
include.after <- character()
linkingToPackages <- .parseLinkingTo(linkingTo)
for (package in linkingToPackages) {
# We already handle Rcpp internally
if (identical(package, "Rcpp"))
next
# see if there is a plugin that we can extract includes from
plugin <- .getInlinePlugin(package) # #nocov start
if (!is.null(plugin)) {
includes <- .pluginIncludes(plugin)
if (!is.null(includes)) {
include.before <- c(include.before, includes$before)
include.after <- c(include.after, includes$after)
}
}
# otherwise check for standard Rcpp::interfaces generated include
else if (!pluginsOnly) {
pkgPath <- find.package(package, NULL, quiet=TRUE)
if (length(pkgPath) == 0) {
stop(paste("Package '", package, "' referenced from ",
"LinkingTo directive is not available.", sep=""),
call. = FALSE)
}
pkgHeader <- paste(package, ".h", sep="")
pkgHeaderPath <- file.path(pkgPath, "include", pkgHeader)
if (file.exists(pkgHeaderPath)) {
pkgInclude <- paste("#include <", pkgHeader, ">", sep="")
include.after <- c(include.after, pkgInclude)
}
} # #nocov end
}
# return the includes
c(include.before, "#include <Rcpp.h>", include.after)
}
# Analyze the plugin's includes field to determine include.before and
# include.after. We are ONLY interested in plugins that work with Rcpp since
# the only types we need from includes are as/wrap marshallers. Therefore,
# we verify that the plugin was created using Rcpp.plugin.maker and then
# use that assumption to correctly extract include.before and include.after
.pluginIncludes <- function(plugin) {
# #nocov start
# First determine the standard suffix of an Rcpp plugin by calling
# Rcpp.plugin.maker. If the plugin$includes has this suffix we know
# it's an Rcpp plugin
token <- "include_after_token"
stockRcppPlugin <- Rcpp.plugin.maker(include.after=token)
includes <- stockRcppPlugin()$includes
suffix <- strsplit(includes, token)[[1]][[2]]
# now ask the plugin for it's includes, ensure that the plugin includes
# are not null, and verify they have the Rcpp suffix before proceeding
pluginIncludes <- plugin()$includes
if (is.null(pluginIncludes))
return (NULL)
if (!grepl(suffix, pluginIncludes))
return (NULL)
# strip the suffix then split on stock Rcpp include to get before and after
pluginIncludes <- strsplit(pluginIncludes, suffix)[[1]][[1]]
pluginIncludes <- strsplit(pluginIncludes, c("#include <Rcpp.h>"))[[1]]
# extract before and after and nix empty lines
before <- pluginIncludes[[1]]
before <- strsplit(before, "\n")[[1]]
before <- before[nzchar(before)]
after <- pluginIncludes[[2]]
after <- strsplit(after, "\n")[[1]]
after <- after[nzchar(after)]
# return before and after
list(before = before, after = after) # #nocov end
}
# Parse a LinkingTo field into a character vector
.parseLinkingTo <- function(linkingTo) {
if (is.null(linkingTo))
return (character()) # #nocov
linkingTo <- strsplit(linkingTo, "\\s*\\,")[[1]]
result <- gsub("\\s", "", linkingTo)
gsub("\\(.*", "", result)
}
# show diagnostics for failed builds
.showBuildFailureDiagnostics <- function() {
# #nocov start
# RStudio does it's own diagnostics so only do this for other environments
if (nzchar(Sys.getenv("RSTUDIO")))
return();
# if we can't call R CMD SHLIB then notify the user they should
# install the appropriate development tools
if (!.checkDevelTools()) {
msg <- paste("\nWARNING: The tools required to build C++ code for R ",
"were not found.\n\n", sep="")
sysName <- Sys.info()[['sysname']]
if (identical(sysName, "Windows")) {
msg <- paste(msg, "Please download and install the appropriate ",
"version of Rtools:\n\n",
"http://cran.r-project.org/bin/windows/Rtools/\n",
sep="");
} else if (identical(sysName, "Darwin")) {
msg <- paste(msg, "Please install Command Line Tools for XCode ",
"(or equivalent).\n", sep="")
} else {
msg <- paste(msg, "Please install GNU development tools ",
"including a C++ compiler.\n", sep="")
}
message(msg)
} # #nocov end
}
# check if R development tools are installed (cache successful result)
.hasDevelTools <- FALSE
.checkDevelTools <- function() {
if (!.hasDevelTools) { # #nocov start
# create temp source file
tempFile <- file.path(tempdir(), "foo.c")
cat("void foo() {}\n", file = tempFile)
on.exit(unlink(tempFile))
# set working directory to tempdir (revert on exit)
oldDir <- setwd(tempdir())
on.exit(setwd(oldDir), add = TRUE)
# attempt the compilation and note whether we succeed
cmd <- paste(R.home(component="bin"), .Platform$file.sep, "R ",
"CMD SHLIB foo.c", sep = "")
result <- suppressWarnings(system(cmd,
ignore.stderr = TRUE,
intern = TRUE))
utils::assignInMyNamespace(".hasDevelTools", is.null(attr(result, "status")))
# if we build successfully then remove the shared library
if (.hasDevelTools) {
lib <- file.path(tempdir(),
paste("foo", .Platform$dynlib.ext, sep=''))
unlink(lib)
}
}
.hasDevelTools # #nocov end
}
# insert a dynlib entry into the cache
.sourceCppDynlibInsert <- function(cacheDir, file, code, dynlib) {
cache <- .sourceCppDynlibReadCache(cacheDir)
index <- .sourceCppFindCacheEntryIndex(cache, file, code)
if (is.null(index))
index <- length(cache) + 1
cache[[index]] <- list(file = file, code = code, dynlib = dynlib)
.sourceCppDynlibWriteCache(cacheDir, cache)
}
# attempt to lookup a dynlib entry from the cache
.sourceCppDynlibLookup <- function(cacheDir, file, code) {
cache <- .sourceCppDynlibReadCache(cacheDir)
index <- .sourceCppFindCacheEntryIndex(cache, file, code)
if (!is.null(index))
cache[[index]]$dynlib
else
list()
}
# write the cache to disk
.sourceCppDynlibWriteCache <- function(cacheDir, cache) {
index_file <- file.path(cacheDir, "cache.rds")
save(cache, file = index_file, compress = FALSE)
}
# read the cache from disk
.sourceCppDynlibReadCache <- function(cacheDir) {
index_file <- file.path(cacheDir, "cache.rds")
if (file.exists(index_file)) {
load(file = index_file)
get("cache")
} else {
list()
}
}
# search the cache for an entry that matches the file or code argument
.sourceCppFindCacheEntryIndex <- function(cache, file, code) {
if (length(cache) > 0) {
for (i in 1:length(cache)) {
entry <- cache[[i]]
if ((nzchar(file) && identical(file, entry$file)) ||
(nzchar(code) && identical(code, entry$code))) {
if (file.exists(entry$dynlib$cppSourcePath))
return(i)
}
}
}
# none found
NULL
}
# generate an R version / Rcpp version specific cache dir for dynlibs
.sourceCppPlatformCacheDir <- function(cacheDir) {
dir <- file.path(cacheDir,
paste("sourceCpp",
R.version$platform,
utils::packageVersion("Rcpp"),
sep = "-"))
if (!utils::file_test("-d", dir))
dir.create(dir, recursive = TRUE)
dir
}
# generate a unique token for a cacheDir
.sourceCppDynlibUniqueToken <- function(cacheDir) {
# read existing token (or create a new one)
token_file <- file.path(cacheDir, "token.rds")
if (file.exists(token_file))
load(file = token_file)
else
token <- 0
# increment
token <- token + 1
# write it
save(token, file = token_file)
# return it as a string
as.character(token)
}
.extraRoutineRegistrations <- function(targetFile, routines) {
declarations = character()
call_entries = character()
# if we are running R 3.4 or higher we can use an internal utility function
# to automatically discover additional native routines that require registration
if (getRversion() >= "3.4") {
# determine the package directory
pkgdir <- dirname(dirname(targetFile))
# get the generated code from R
con <- textConnection(object = NULL, open = "w")
on.exit(close(con), add = TRUE)
tools::package_native_routine_registration_skeleton(
dir = pkgdir,
con = con,
character_only = FALSE
)
code <- textConnectionValue(con)
# look for lines containing call entries
matches <- regexec('^\\s+\\{"([^"]+)",.*$', code)
matches <- regmatches(code, matches)
matches <- Filter(x = matches, function(x) {
length(x) > 0 # #nocov start
})
for (match in matches) {
routine <- match[[2]]
if (!routine %in% routines) {
declaration <- grep(sprintf("^extern .* %s\\(.*$", routine), code,
value = TRUE)
# FIXME: maybe we should extend this to *any* routine?
# or is there any case in which `void *` is not SEXP for a .Call?
if (routine == "run_testthat_tests")
declaration <- gsub("void *", "SEXP", declaration, fixed=TRUE)
declarations <- c(declarations, sub("^extern", "RcppExport", declaration))
call_entries <- c(call_entries, match[[1]]) # #nocov end
}
}
}
# return extra declaratiosn and call entries
list(declarations = declarations,
call_entries = call_entries)
}
