Merge branch 'dll-load'

R/load-dll.r

@@ -6,17 +6,139 @@
 #' @export
 load_dll <- function(pkg = ".") {
   pkg <- as.package(pkg)
+  env <- ns_env(pkg)
+  nsInfo <- parse_ns_file(pkg)
+
+  # The code below taken directly from base::loadNamespace, except for
+  # library.dynam2, which is a special version of library.dynam
+
+  ## load any dynamic libraries
+  dlls <- list()
+  dynLibs <- nsInfo$dynlibs
+  for (i in seq_along(dynLibs)) {
+    lib <- dynLibs[i]
+    # NOTE: replaced library.dynam with devtools replacement, library.dynam2
+    dlls[[lib]]  <- library.dynam2(pkg, lib)
+    assignNativeRoutines(dlls[[lib]], lib, env,
+                         nsInfo$nativeRoutines[[lib]])
+
+    ## If the DLL has a name as in useDynLib(alias = foo),
+    ## then assign DLL reference to alias.  Check if
+    ## names() is NULL to handle case that the nsInfo.rds
+    ## file was created before the names were added to the
+    ## dynlibs vector.
+    if(!is.null(names(nsInfo$dynlibs))
+       && names(nsInfo$dynlibs)[i] != "")
+      assign(names(nsInfo$dynlibs)[i], dlls[[lib]], envir = env)
+    setNamespaceInfo(env, "DLLs", dlls)
+  }
+  addNamespaceDynLibs(env, nsInfo$dynlibs)
+
+  invisible(dlls)
+}
+
+
+# Return a list of currently loaded DLLs from the package
+loaded_dlls <- function(pkg = ".") {
+  pkg <- as.package(pkg)
+  libs <- .dynLibs()
+  matchidx <- vapply(libs, "[[", character(1), "name") == pkg$package
+  libs[matchidx]
+}
+
+# This is a replacement for base::library.dynam, with a slightly different
+# call interface. The original requires that the name of the package is the
+# same as the directory name, which isn't always the case when loading with
+# devtools. This version allows them to be different, and also searches in
+# the src/ directory for the DLLs, instead of the libs/$R_ARCH/ directory.
+library.dynam2 <- function(pkg = ".", lib = "") {
+  pkg <- as.package(pkg)
+
+  dllname <- paste(lib, .Platform$dynlib.ext, sep = "")
+  dllfile <- file.path(pkg$path, "src", dllname)
 
-  dllfile <- dll_name(pkg)
   if (!file.exists(dllfile))
     return(invisible())
 
-  # The loading and registering of the dll is similar to how it's done
-  # in library.dynam.
+  # # The loading and registering of the dll is similar to how it's done
+  # # in library.dynam.
   dllinfo <- dyn.load(dllfile)
 
   # Register dll info so it can be unloaded with library.dynam.unload
   .dynLibs(c(.dynLibs(), list(dllinfo)))
 
-  invisible(dllfile)
+  return(dllinfo)
+}
+
+
+# This is taken directly from base::loadNamespace() in R 2.15.1
+addNamespaceDynLibs <- function(ns, newlibs) {
+  dynlibs <- getNamespaceInfo(ns, "dynlibs")
+  setNamespaceInfo(ns, "dynlibs", c(dynlibs, newlibs))
+}
+
+
+# This is taken directly from base::loadNamespace in R 2.15.1
+# The only change is the line used get the package name
+assignNativeRoutines <- function(dll, lib, env, nativeRoutines) {
+  package <- getPackageName(env)
+
+  if(length(nativeRoutines) == 0L)
+    return(NULL)
+
+  if(nativeRoutines$useRegistration) {
+    ## Use the registration information to register ALL the symbols
+    fixes <- nativeRoutines$registrationFixes
+    routines <- getDLLRegisteredRoutines.DLLInfo(dll, addNames = FALSE)
+    lapply(routines,
+      function(type) {
+        lapply(type,
+               function(sym) {
+                   varName <- paste0(fixes[1L], sym$name, fixes[2L])
+                   if(exists(varName, envir = env))
+                     warning("failed to assign RegisteredNativeSymbol for ",
+                             sym$name,
+                             paste(" to", varName),
+                             " since ", varName,
+                             " is already defined in the ", package,
+                             " namespace")
+                   else
+                     assign(varName, sym, envir = env)
+               })
+      })
+
+   }
+
+  symNames <- nativeRoutines$symbolNames
+  if(length(symNames) == 0L)
+    return(NULL)
+
+  symbols <- getNativeSymbolInfo(symNames, dll, unlist = FALSE,
+                                     withRegistrationInfo = TRUE)
+  lapply(seq_along(symNames),
+    function(i) {
+      ## could vectorize this outside of the loop
+      ## and assign to different variable to
+      ## maintain the original names.
+      varName <- names(symNames)[i]
+      origVarName <- symNames[i]
+      # DEVTOOLS: Following block commented out because it raises unneeded
+      #           warnings with load_all(reset=FALSE).
+      # if(exists(varName, envir = env))
+      #    warning("failed to assign NativeSymbolInfo for ",
+      #            origVarName,
+      #            ifelse(origVarName != varName,
+      #                       paste(" to", varName), ""),
+      #            " since ", varName,
+      #            " is already defined in the ", package,
+      #            " namespace")
+      # else
+        assign(varName, symbols[[origVarName]],
+               envir = env)
+
+    })
+
+
+
+  symbols
 }

R/reload.r

@@ -94,18 +94,16 @@ unload <- function(pkg = ".") {
 # This unloads dlls loaded by either library() or load_all()
 unload_dll <- function(pkg = ".") {
   pkg <- as.package(pkg)
-  libs <- .dynLibs()
 
-  # Get all dlls whose name matches this package
-  # (can be more than one)
-  matchidx <- vapply(libs, "[[", character(1), "name") == pkg$package
+  pkglibs <- loaded_dlls(pkg)
 
-  for (matchlib in libs[matchidx]) {
-    dyn.unload(matchlib[["path"]])
+  for (lib in pkglibs) {
+    dyn.unload(lib[["path"]])
   }
 
   # Remove the unloaded dlls from .dynLibs()
-  .dynLibs(libs[!matchidx])
+  libs <- .dynLibs()
+  .dynLibs(libs[!(libs %in% pkglibs)])
 
   invisible()
 }

inst/tests/dll-unload/DESCRIPTION → inst/tests/dll-load/DESCRIPTION

@@ -1,5 +1,5 @@
-Package: dllunload
-Title: Tools to make developing R code easier
+Package: dllload
+Title: Test package for loading and unloading DLLs
 License: GPL-2
 Description:
 Author: Hadley <h.wickham@gmail.com>

inst/tests/dll-load/NAMESPACE

@@ -0,0 +1,4 @@
+useDynLib(dllload)
+useDynLib(dllload,null_test2)
+export(nulltest)
+export(nulltest2)

inst/tests/dll-load/R/a.r

@@ -0,0 +1,9 @@
+a <- 1
+
+nulltest <- function() {
+  .Call("null_test", PACKAGE = "dllload")
+}
+
+nulltest2 <- function() {
+  .Call(null_test2)
+}

inst/tests/dll-unload/src/null-test.c → inst/tests/dll-load/src/null-test.c

@@ -4,3 +4,8 @@
 SEXP null_test() {
     return R_NilValue;
 }
+
+SEXP null_test2() {
+    return R_NilValue;
+}
+

inst/tests/test-dll.r

@@ -8,68 +8,90 @@ test_that("unload() unloads DLLs from packages loaded with library()", {
   if (!dir.exists(tmp_libpath)) dir.create(tmp_libpath)
   .libPaths(c(tmp_libpath, .libPaths()))
 
-  install("dll-unload")
-  expect_true(require(dllunload))
+  install("dll-load")
+  expect_true(require(dllload))
 
   # Check that it's loaded properly, by running a function from the package.
   # nulltest() calls a C function which returns null.
   expect_true(is.null(nulltest()))
 
   # DLL should be listed in .dynLibs()
   dynlibs <- vapply(.dynLibs(), `[[`, "name", FUN.VALUE = character(1))
-  expect_true(any(grepl("dllunload", dynlibs)))
+  expect_true(any(grepl("dllload", dynlibs)))
 
-  unload("dll-unload")
+  unload("dll-load")
 
   # DLL should not be listed in .dynLibs()
   dynlibs <- vapply(.dynLibs(), `[[`, "name", FUN.VALUE = character(1))
-  expect_false(any(grepl("dllunload", dynlibs)))
+  expect_false(any(grepl("dllload", dynlibs)))
 
   # Reset the libpath
   .libPaths(old_libpaths)
 
   # Clean out compiled objects
-  clean_dll("dll-unload")
+  clean_dll("dll-load")
 })
 
 
 test_that("load_all() compiles and loads DLLs", {
 
-  clean_dll("dll-unload")
+  clean_dll("dll-load")
 
-  load_all("dll-unload", reset = TRUE)
+  load_all("dll-load", reset = TRUE)
 
   # Check that it's loaded properly, by running a function from the package.
   # nulltest() calls a C function which returns null.
   expect_true(is.null(nulltest()))
 
   # DLL should be listed in .dynLibs()
   dynlibs <- vapply(.dynLibs(), `[[`, "name", FUN.VALUE = character(1))
-  expect_true(any(grepl("dllunload", dynlibs)))
+  expect_true(any(grepl("dllload", dynlibs)))
 
-  unload("dll-unload")
+  unload("dll-load")
 
   # DLL should not be listed in .dynLibs()
   dynlibs <- vapply(.dynLibs(), `[[`, "name", FUN.VALUE = character(1))
-  expect_false(any(grepl("dllunload", dynlibs)))
+  expect_false(any(grepl("dllload", dynlibs)))
 
 
   # Loading again, and reloading
   # Should not re-compile (don't have a proper test for this)
-  load_all("dll-unload")
+  load_all("dll-load")
   expect_true(is.null(nulltest()))
 
   # load_all when already loaded
   # Should not re-compile (don't have a proper test for this)
-  load_all("dll-unload")
+  load_all("dll-load")
   expect_true(is.null(nulltest()))
 
   # Should re-compile (don't have a proper test for this)
-  load_all("dll-unload", recompile = TRUE)
+  load_all("dll-load", recompile = TRUE)
   expect_true(is.null(nulltest()))
-  unload("dll-unload")
+  unload("dll-load")
 
   # Clean out compiled objects
-  clean_dll("dll-unload")
+  clean_dll("dll-load")
 })
 
+
+test_that("Specific functions from DLLs listed in NAMESPACE can be called", {
+  load_all("dll-load")
+
+  # nulltest() uses the calling convention:
+  # .Call("null_test", PACKAGE = "dllload")
+  expect_true(is.null(nulltest()))
+
+  # nulltest2() uses a specific C function listed in NAMESPACE, null_test2
+  # null_test2 is an object in the packg_env
+  # It uses this calling convention:
+  # .Call(null_test2)
+  expect_true(is.null(nulltest2()))
+  nt2 <- ns_env("dll-load")$null_test2
+  expect_equal(class(nt2), "NativeSymbolInfo")
+  expect_equal(nt2$name, "null_test2")
+
+  unload("dll-load")
+
+  # Clean out compiled objects
+  clean_dll("dll-load")
+})