Add gctorture arg to Rcpp:::test, so we can run tests wrapped in gctorture(TRUE)

Author: kevinushey

ChangeLog

@@ -2,6 +2,8 @@
 
         * inst/include/Rcpp/proxy/FieldProxy.h: bandaid for protection issue
         in operator= of FieldProxy
+        * R/unit.tests.R: modify Rcpp:::test so we can run tests with
+        gctorture(TRUE)
 
 2014-03-03  Kevin Ushey <[email protected]>
 

R/unit.tests.R

@@ -1,4 +1,4 @@
-# Copyright (C) 2010 - 2014  Dirk Eddelbuettel and Romain Francois
+# Copyright (C) 2010 - 2014  Dirk Eddelbuettel, Romain Francois and Kevin Ushey
 #
 # This file is part of Rcpp.
 #
@@ -14,11 +14,61 @@
 #
 # You should have received a copy of the GNU General Public License
 # along with Rcpp.  If not, see <http://www.gnu.org/licenses/>.
-
-test <- function(output=if(file.exists("/tmp")) "/tmp" else getwd()) {
+test <- function(
+    output=if(file.exists("/tmp")) "/tmp" else getwd(),
+    gctorture=FALSE,
+    gctorture.exclude="runit.Module.client.package.R") {
     if (require(RUnit)) {
+        
+        if (gctorture) {
+            
+            message("Running tests with gctorture(TRUE)")
+            if (length(gctorture.exclude)) {
+                message("The following tests will be excluded:\n",
+                    paste(">>", gctorture.exclude, collapse="\n")
+                )
+            }
+            
+            unitTestsDir <- system.file("unitTests", package="Rcpp")
+            files <- list.files(
+                unitTestsDir,
+                recursive=TRUE
+            )
+            files <- setdiff(files, gctorture.exclude)
+            dirs <- list.dirs(unitTestsDir, full.names=FALSE)
+            testDir <- file.path( tempdir(), "RcppTests" )
+            for (dir in file.path(testDir, dirs)) dir.create(dir)
+            
+            copySuccess <- sapply(files, function(file) {
+                file.copy(
+                    file.path(unitTestsDir, file), 
+                    file.path(testDir, file)
+                )
+            })
+            
+            if (!all(copySuccess)) {
+                stop("Could not copy test files to temporary directory")
+            }
+            
+            ## Modify all the test files that were copied
+            testFiles <- list.files(testDir, pattern="^runit", full.names=TRUE)
+            for (file in testFiles) gctortureRUnitTest(file)
+            
+            ## Ensure we can read and parse each file
+            for (file in testFiles) {
+                tryCatch( parse(text=readLines(file)),
+                    error=function(e) {
+                        "could not parse test file"
+                    }
+                )
+            }
+            
+        } else {
+            testDir <- system.file("unitTests", package = "Rcpp")
+        }
+        
         testSuite <- defineTestSuite(name="Rcpp Unit Tests",
-                                     dirs=system.file("unitTests", package = "Rcpp"),
+                                     dirs=testDir,
                                      testFuncRegexp = "^[Tt]est.+")
 
         ## if someoone calls Rcpp::test(), he/she wants all tests
@@ -48,3 +98,42 @@ unitTestSetup <- function(file, packages=NULL,
     }
 }
 
+gctortureRUnitTest <- function(file) {
+    
+    test <- readLines(file)
+    
+    ## TODO: handle '{', '}' within quotes
+    findMatchingBrace <- function(test, start, balance=1) {
+        line <- test[start]
+        if (start > length(test)) {
+            stop("error")
+        }
+        if (balance > 0) {
+            balance <- balance + 
+                sum(gregexpr("{", line, fixed=TRUE)[[1]] > 0) -
+                sum(gregexpr("}", line, fixed=TRUE)[[1]] > 0)
+            return( findMatchingBrace(test, start+1, balance) )
+        }
+        return(start - 1)
+    }
+    
+    ## Find the lines defining unit tests
+    testStarts <- grep("^[[:space:]]*[Tt]est\\.+", test)
+    
+    ## Get the line with the closing brace
+    testEnds <- sapply(testStarts, function(ind) {
+        findMatchingBrace(test, ind + 1)
+    })
+    stopifnot( length(testStarts) == length(testEnds) )
+    
+    ## Modify the function definition by wrapping it in gctorture
+    for (i in seq_along(testStarts)) {
+        start <- testStarts[i]
+        end <- testEnds[i]
+        test[start] <- paste( test[start], "gctorture(TRUE);" )
+        test[end] <- paste("gctorture(FALSE); }")
+    }
+    
+    cat(test, file=file, sep="\n")
+    
+}