Commit made by the Bioconductor Git-SVN bridge.

Consists of 1 commit(s).

Commit information:

    Commit id: 4edbf04790edc99ab6a05e6aa8d34be3664e73a7
    Commit message:
    Only check for native routine registration if .C (or similar) is called

    This should filter out cases where packages use Rcpp as their interface
    to native code.
    Committed by Dan Tenenbaum <dtenenba at fhcrc.org>
    Commit date: 2014-03-12T12:17:23-07:00

From: Bioconductor Git-SVN Bridge <bioc-sync@bioconductor.org>

git-svn-id: https://hedgehog.fhcrc.org/bioconductor/trunk/madman/Rpacks/BiocCheck@87371 bc3139a8-67e5-0310-9ffc-ced21a209358

.gitignore

@@ -6,4 +6,5 @@ BiocCheck.Rproj
 vignettes/*.md
 vignettes/*.html
 vignettes/sync.sh
-*.so
+*.so
+*.o

R/BiocCheck.R

@@ -100,8 +100,10 @@ BiocCheck <- function(package, ...)
     checkBBScompatibility(package_dir)
     handleMessage("Checking unit tests...")
     checkUnitTests(package_dir)
+    parsedCode <- parseFiles(package_dir)
+
     handleMessage("Checking native routine registration...")
-    checkRegistrationOfEntryPoints(package_name)
+    checkRegistrationOfEntryPoints(package_name, parsedCode)
     if (suppressMessages(suppressWarnings(require(codetoolsBioC))))
     {
         handleMessage("Checking for namespace import suggestions...")
@@ -113,7 +115,6 @@ BiocCheck <- function(package, ...)
 
     handleMessage("Parsing R code in R directory, examples, vignettes...")
 
-    parsedCode <- parseFiles(package_dir)
 
     handleMessage("Checking for T...")
     res <- findSymbolInParsedCode(parsedCode, package_name, "T",

R/checks.R

@@ -255,17 +255,26 @@ checkUnitTests <- function(pkgdir)
     }
 }
 
-checkRegistrationOfEntryPoints <- function(pkgname)
+checkRegistrationOfEntryPoints <- function(pkgname, parsedCode)
 {
-    d <- getLoadedDLLs()
-    if (pkgname %in% names(d))
+    symbols <-  c(".C", ".Call", ".Fortran", ".External")
+    res <- lapply(symbols, function(x) {
+        findSymbolInParsedCode(parsedCode, pkgname, x, "SYMBOL_FUNCTION_CALL",
+            TRUE)
+    })
+
+    if (any(res > 0)) 
     {
-        r <- getDLLRegisteredRoutines(pkgname)
-        if (sum(sapply(r, length)) == 0)
+        d <- getLoadedDLLs()
+        if (pkgname %in% names(d))
         {
-            handleRecommended(
-                paste0("Register native routines!",
-                    " see http://cran.r-project.org/doc/manuals/R-exts.html#Registering-native-routines"))
+            r <- getDLLRegisteredRoutines(pkgname)
+            if (sum(sapply(r, length)) == 0)
+            {
+                handleRecommended(
+                    paste0("Register native routines!",
+                        " see http://cran.r-project.org/doc/manuals/R-exts.html#Registering-native-routines"))
+            }
         }
     }
 }

R/util.R

@@ -136,7 +136,7 @@ parseFiles <- function(pkgdir)
 }
 
 findSymbolInParsedCode <- function(parsedCode, pkgname, symbolName,
-    token)
+    token, silent=FALSE)
 {
     matches <- list()
     for (filename in names(parsedCode))
@@ -159,15 +159,17 @@ findSymbolInParsedCode <- function(parsedCode, pkgname, symbolName,
         x <- matches[[name]]
         for (i in nrow(x))
         {
-            if (grepl("\\.R$", name, ignore.case=TRUE))
-                message(sprintf("      Found %s%s in %s (line %s, column %s)",
-                    symbolName, parens,
-                    mungeName(name, pkgname), x[i,1], x[i,2]))
-            else
-                message(sprintf("      Found %s%s in %s",
-                    symbolName, parens,
-                    mungeName(name, pkgname))) # FIXME test this
-
+            if (!silent)
+            {
+                if (grepl("\\.R$", name, ignore.case=TRUE))
+                    message(sprintf("      Found %s%s in %s (line %s, column %s)",
+                        symbolName, parens,
+                        mungeName(name, pkgname), x[i,1], x[i,2]))
+                else
+                    message(sprintf("      Found %s%s in %s",
+                        symbolName, parens,
+                        mungeName(name, pkgname))) # FIXME test this
+            }
         }
     }
     length(matches) # for tests

inst/testpackages/testpkg1/DESCRIPTION

@@ -0,0 +1,10 @@
+Package: testpkg1
+Title: bla
+Description: blsa
+Version: 0.1
+Author: Joe Blow
+Maintainer: Joe Blow <joe@blow.com>
+Depends: R (>= 3.1.0), RJSONIO
+License: GPL-2
+LazyData: true
+VignetteBuilder: knitr

inst/testpackages/testpkg1/NAMESPACE

@@ -0,0 +1 @@
+#

inst/testpackages/testpkg1/R/zzz.R

@@ -0,0 +1,5 @@
+.onLoad <- function(libname, pkgname)
+{
+    library.dynam(pkgname, pkgname, NULL)
+    if (FALSE) .C()
+}

inst/testpackages/testpkg1/src/testpkg1.c

@@ -0,0 +1,6 @@
+#include <R.h>
+#include <Rdefines.h>
+
+SEXP nsreg() {
+  return R_NamespaceRegistry;
+}

inst/unitTests/test_BiocCheck.R

@@ -269,15 +269,14 @@ test_installAndLoad <- function()
 
 test_checkRegistrationOfEntryPoints <- function()
 {
-    if(!require(Biobase)) suppressPackageStartupMessages(require("Biobase"))
-    zeroCounters()
-    BiocCheck:::checkRegistrationOfEntryPoints("Biobase")
-    checkTrue(stillZero())
-    zeroCounters()
-    # This test could fail if devtools registers routines:
-    if(!require(devtools)) suppressPackageStartupMessages(require("devtools"))
-    BiocCheck:::checkRegistrationOfEntryPoints("devtools")
-    checkTrue(.recommendations$getNum() == 1)
+    parsedCode1 <- BiocCheck:::parseFiles(system.file("testpackages",
+        "testpkg1", package="BiocCheck"))
+    BiocCheck:::installAndLoad(system.file("testpackages", "testpkg1",
+        package="BiocCheck"))
+
+    BiocCheck:::checkRegistrationOfEntryPoints("testpkg1", parsedCode1)
+    checkTrue(.recommendations$getNum() == 1, 
+        "unregistered code not flagged!")
 }
 
 test_checkDeprecatedPackages <- function()