R CMD check optionally reports on non-use of registration of native s…

…ymbols git-svn-id: https://svn.r-project.org/R/trunk@71981 00db46b3-68df-0310-9c12-caf00c1e9a41
wch · Jan 16, 2017 · 2f9cf02 · 2f9cf02
1 parent 7785d1a
commit 2f9cf02
Show file tree

Hide file tree

Showing 4 changed files with 75 additions and 9 deletions.
diff --git a/doc/manual/R-ints.texi b/doc/manual/R-ints.texi
@@ -4100,6 +4100,11 @@ Default: false (but true for CRAN submission checks).
 Number of trailing lines of test output to reproduce in the log.  If
 @code{0} all lines except the @R{} preamble are reproduced.
 Default: 13.
+
+@item _R_CHECK_SYMBOL_REGISTRATION_
+If set to a true value, report if the entry points to register symbols
+and suppress dynamic search are not found in a DLL.
+Default: false (but true for CRAN submission checks).
 @end vtable
 
 CRAN's submission checks use something like

diff --git a/src/library/tools/NAMESPACE b/src/library/tools/NAMESPACE
@@ -42,7 +42,7 @@ export("check_packages_in_dir",
 export("CRAN_package_db",
        "CRAN_check_results",
        "CRAN_check_details",
-       "CRAN_memtest_notes", 
+       "CRAN_memtest_notes",
        "summarize_CRAN_check_status")
 
 export(".print.via.format")
@@ -79,6 +79,7 @@ S3method("format", "check_package_license")
 S3method("format", "check_packages_used")
 S3method("format", "check_so_symbols")
 S3method("format", "check_nonAPI_calls")
+S3method("format", "check_RegSym_calls")
 S3method("format", "check_url_db")
 S3method("format", "checkDocFiles")
 S3method("format", "checkDocStyle")
@@ -169,6 +170,7 @@ S3method("print", "check_packages_used", .print.via.format)
 S3method("print", "check_po_files")
 S3method("print", "check_so_symbols", .print.via.format)
 S3method("print", "check_nonAPI_calls", .print.via.format)
+S3method("print", "check_RegSym_calls", .print.via.format)
 S3method("print", "check_url_db")
 S3method("print", "check_vignette_index")
 

diff --git a/src/library/tools/R/check.R b/src/library/tools/R/check.R
@@ -2452,6 +2452,7 @@ setRlibs <-
             else noteLog(Log)
             printLog0(Log, paste(c(out, ""), collapse = "\n"))
             nAPIs <- length(grep("Found non-API", out))
+            nRS <- length(grep("Found no call", out))
             nBad <- length(grep(", possibly from ", out))
             msg <- if (nBad) {
                 if(haveObjs)
@@ -2469,6 +2470,9 @@ setRlibs <-
             if(nAPIs)
                 msg <- c(msg,
                          "Compiled code should not call non-API entry points in R.\n")
+            if(nRS)
+                msg <- c(msg,
+                         "It is good practice to use registered native symbols and to disable symbol search.\n")
             wrapLog("\n", paste(msg, collapse = " "), "\n",
                     "See 'Writing portable packages'",
                     "in the 'Writing R Extensions' manual.\n")
@@ -4725,6 +4729,7 @@ setRlibs <-
         Sys.setenv("_R_CHECK_S3_METHODS_NOT_REGISTERED_" = "TRUE")
         Sys.setenv("_R_CHECK_PACKAGE_DATASETS_SUPPRESS_NOTES_" = "TRUE")
         Sys.setenv("_R_CHECK_PACKAGES_USED_IGNORE_UNUSED_IMPORTS_" = "TRUE")
+        Sys.setenv("_R_CHECK_SYMBOL_REGISTRATION_" = "TRUE")
         R_check_vc_dirs <- TRUE
         R_check_executables_exclusions <- FALSE
         R_check_doc_sizes2 <- TRUE

diff --git a/src/library/tools/R/sotools.R b/src/library/tools/R/sotools.R
@@ -1,7 +1,7 @@
 #  File src/library/tools/R/sotools.R
 #  Part of the R package, https://www.R-project.org
 #
-#  Copyright (C) 2011-2015 The R Core Team
+#  Copyright (C) 2011-2017 The R Core Team
 #
 #  This program is free software; you can redistribute it and/or modify
 #  it under the terms of the GNU General Public License as published by
@@ -390,6 +390,9 @@ check_so_symbols <- if(.Platform$OS.type == "windows") {
             tab2 <- setdiff(tab2, c("R_InputHandlers", "addInputHandler",
                                     "removeInputHandler"))
         if(length(tab2)) attr(tab, "nonAPI") <- tab2
+        tab2b <- setdiff(c("R_registerRoutines", "R_useDynamicSymbols"),
+                         sub("^_", "", nms))
+        if(length(tab2b)) attr(tab, "RegSym") <- tab2b
         class(tab) <- "check_so_symbols"
         tab
     }
@@ -407,11 +410,16 @@ check_so_symbols <- if(.Platform$OS.type == "windows") {
         tab <- so_symbol_names_table[ind, , drop = FALSE]
         attr(tab, "file") <- so
         tab2 <- sub("^_", "", tab2)
-        tab2 <- intersect(tab2, nonAPI)
-        if ("removeInputHandler" %in% tab2)
-            tab2 <- setdiff(tab2, c("R_InputHandlers", "addInputHandler",
+
+        tab2a <- intersect(tab2, nonAPI)
+        if ("removeInputHandler" %in% tab2a)
+            tab2a <- setdiff(tab2a, c("R_InputHandlers", "addInputHandler",
                                     "removeInputHandler"))
-        if(length(tab2)) attr(tab, "nonAPI") <- tab2
+        if(length(tab2a)) attr(tab, "nonAPI") <- tab2a
+
+        tab2b <- setdiff(c("R_registerRoutines", "R_useDynamicSymbols"), tab2)
+        if(length(tab2b)) attr(tab, "RegSym") <- tab2b
+
         class(tab) <- "check_so_symbols"
         tab
     }
@@ -456,6 +464,7 @@ if(.Platform$OS.type == "windows") {
 
         r_arch <- .Platform$r_arch
         useST <- config_val_to_logical(Sys.getenv("_R_SHLIB_BUILD_OBJECTS_SYMBOL_TABLES_", "FALSE"))
+        useSR <- config_val_to_logical(Sys.getenv("_R_CHECK_SYMBOL_REGISTRATION_", "FALSE"))
 
         compare <- function(x, strip_ = FALSE) {
             ## Compare symbols in the DLL and in objects:
@@ -505,9 +514,19 @@ if(.Platform$OS.type == "windows") {
                                   .file_path_relative_to_dir(attr(x, "file"),
                                                              dir, TRUE),
                                   class = "check_nonAPI_calls"))
-
         bad <- c(bad, Filter(length, nAPIs))
 
+        if (useSR) {
+            nRS <- lapply(lapply(so_files, check_so_symbols, rarch = "i386"),
+                          function(x) if(length(z <- attr(x, "RegSym")))
+                          structure(z,
+                                    file =
+                                    .file_path_relative_to_dir(attr(x, "file"),
+                                                               dir, TRUE),
+                                    class = "check_RegSym_calls"))
+            bad <- c(bad, Filter(length, nRS))
+        }
+
         so_files <-
             Sys.glob(file.path(dir, "libs/x64",
                                sprintf("*%s", .Platform$dynlib.ext)))
@@ -531,9 +550,19 @@ if(.Platform$OS.type == "windows") {
                                   .file_path_relative_to_dir(attr(x, "file"),
                                                              dir, TRUE),
                                   class = "check_nonAPI_calls"))
-
         bad2 <- c(bad2, Filter(length, nAPIs))
 
+        if (useSR) {
+            nRS <- lapply(lapply(so_files, check_so_symbols, rarch = "x64"),
+                          function(x) if(length(z <- attr(x, "RegSym")))
+                          structure(z,
+                                    file =
+                                    .file_path_relative_to_dir(attr(x, "file"),
+                                                               dir, TRUE),
+                                    class = "check_RegSym_calls"))
+            bad <- c(bad, Filter(length, nRS))
+        }
+
         if(!length(bad) && !length(bad2)) return(invisible(NULL))
 
         bad <- if(length(bad) && length(bad2)) rbind(bad, bad2)
@@ -548,6 +577,7 @@ if(.Platform$OS.type == "windows") {
 
         r_arch <- .Platform$r_arch
         useST <- config_val_to_logical(Sys.getenv("_R_SHLIB_BUILD_OBJECTS_SYMBOL_TABLES_", "FALSE"))
+        useSR <- config_val_to_logical(Sys.getenv("_R_CHECK_SYMBOL_REGISTRATION_", "FALSE"))
 
         compare <- function(x) {
             ## Compare symbols in the so and in objects:
@@ -596,8 +626,18 @@ if(.Platform$OS.type == "windows") {
                                   .file_path_relative_to_dir(attr(x, "file"),
                                                              dir, TRUE),
                                   class = "check_nonAPI_calls"))
-
         bad <- c(bad, Filter(length, nAPIs))
+
+        if (useSR) {
+            nRS <- lapply(lapply(so_files, check_so_symbols),
+                          function(x) if(length(z <- attr(x, "RegSym")))
+                          structure(z,
+                                    file =
+                                    .file_path_relative_to_dir(attr(x, "file"),
+                                                               dir, TRUE),
+                                    class = "check_RegSym_calls"))
+            bad <- c(bad, Filter(length, nRS))
+        }
         class(bad) <- "check_compiled_code"
         bad
     }
@@ -626,6 +666,20 @@ function(x, ...)
     else character()
 }
 
+format.check_RegSym_calls <-
+function(x, ...)
+{
+    if(length(x))
+        c(gettextf("File %s:", sQuote(attr(x, "file"))),
+          if (length(x) > 1L) {
+              strwrap(paste("Found no calls to:",
+                            paste(sQuote(x), collapse = ", ")),
+                      indent = 2L, exdent = 4L)
+          } else paste("  Found no call to:", sQuote(x))
+          )
+    else character()
+}
+
 .shlib_objects_symbol_tables <-
 function(file = "symbols.rds")
 {