protection against zero-length argument for nthread

Author: markvanderloo

pkg/DESCRIPTION

@@ -23,7 +23,7 @@ Description: Implements an approximate string matching version of R's native
  vectors representing generic sequences. This package is built for speed and
  runs in parallel by using 'openMP'. An API for C or C++ is exposed as well.
  Reference: MPJ van der Loo (2014) <doi:10.32614/RJ-2014-011>.
-Version: 0.9.13
+Version: 0.9.15
 Depends:
  R (>= 2.15.3)
 URL: https://github.com/markvanderloo/stringdist

pkg/NEWS

@@ -1,4 +1,9 @@
-version 0.9.13
+version 0.9.15
+- Fixe issue with zero-length 'nthreads' argument in all exported functions
+ with this parameter. (Thanks to Brian Ripley for the notification and pointer
+ to the problem)
+
+version 0.9.14
 - Fixed issue with zero-length strings in 'qgrams' (Thanks to Brian Ripley
  for the notification and pointer to the origin of the problem)
 

pkg/R/afind.R

@@ -87,6 +87,8 @@ afind <- function(x, pattern, window=NULL
  , is.logical(value) && !is.na(value)
  , ifelse(method %in% c('osa','dl'), length(weight) >= 4, TRUE)
  , ifelse(method %in% c('lv','jw') , length(weight) >= 3, TRUE)
+ , length(nthread) == 1
+ , is.numeric(nthread)
  , nthread > 0
  )
 

pkg/R/amatch.R

@@ -104,6 +104,8 @@ amatch <- function(x, table, nomatch=NA_integer_, matchNA=TRUE
  , is.logical(useBytes)
  , ifelse(method %in% c('osa','dl'), length(weight) >= 4, TRUE)
  , ifelse(method %in% c('lv','jw') , length(weight) >= 3, TRUE)
+ , length(nthread) == 1
+ , is.numeric(nthread)
  , nthread > 0
  )
  if (method == 'jw') weight <- weight[c(2,1,3)]
@@ -212,6 +214,8 @@ seq_amatch <- function(x, table, nomatch=NA_integer_, matchNA=TRUE
  , matchNA %in% c(TRUE,FALSE)
  , ifelse(method %in% c('osa','dl'), length(weight) >= 4, TRUE)
  , ifelse(method %in% c('lv','jw') , length(weight) >= 3, TRUE)
+ , length(nthread) == 1
+ , is.numeric(nthread)
  , nthread > 0
  )
  if (method == 'jw') weight <- weight[c(2,1,3)]

pkg/R/seqdist.R

@@ -69,6 +69,8 @@ seq_dist <- function(a, b
  , p >= 0
  , ifelse(method %in% c('osa','dl'), length(weight) >= 4, TRUE)
  , ifelse(method %in% c('lv','jw') , length(weight) >= 3, TRUE)
+ , length(nthread) == 1
+ , is.numeric(nthread)
  , nthread > 0
  )
 

pkg/R/stringdist.R

@@ -63,14 +63,14 @@
 #' }
 #' Or use \code{citation('stringdist')} to get a bibtex item.
 #'
-#' @aliases stringdist-package
+#' @name stringdist-package
 #' @docType package
 #' @useDynLib stringdist, .registration=TRUE
 #' @importFrom parallel detectCores 
 #'
 #'
 #' 
-{}
+"_PACKAGE"
 
 listwarning <- function(x,y){
 sprintf("
@@ -156,6 +156,8 @@ stringdist <- function(a, b
  , is.logical(useBytes)
  , ifelse(method %in% c('osa','dl'), length(weight) >= 4, TRUE)
  , ifelse(method %in% c('lv','jw') , length(weight) >= 3, TRUE)
+ , length(nthread) == 1
+ , is.numeric(nthread)
  , nthread > 0
  )
 
@@ -224,6 +226,8 @@ stringdistmatrix <- function(a, b
  , is.logical(useBytes)
  , ifelse(method %in% c('osa','dl'), length(weight) >= 4, TRUE)
  , ifelse(method %in% c('lv','jw') , length(weight) >= 3, TRUE)
+ , length(nthread) == 1
+ , is.numeric(nthread)
  , nthread > 0
  )
 
@@ -342,7 +346,7 @@ lower_tri <- function(a
  if (is.na(method)){
  stop(sprintf("method '%s' is not defined",method))
  }
- 
+
  x <- .Call("R_lower_tri", a, methnr
  , as.double(weight), as.double(p), as.double(bt)
  , as.integer(q), as.integer(useBytes), as.integer(nthread)

pkg/inst/tinytest/test_afind.R

@@ -1,5 +1,16 @@
 options(sd_num_thread=1L)
 
+# tests against cases that used to segfault when we did not check
+# NULL cases.
+expect_error(afind("a","b",nthread=1:4))
+expect_error(afind("a","b",nthread="foo"))
+expect_error(afind("a","b",nthread=integer(0)))
+expect_error(afind("a","b",nthread=NULL))
+
+
+
+
+
 texts = c("When I grow up, I want to be"
  , "one of the harversters of the sea"
  , "I think before my days are gone"

pkg/inst/tinytest/test_amatch.R

@@ -1,5 +1,12 @@
 options(sd_num_thread=2)
 ## amatch: Optimal String Alignment
+# tests against cases that used to segfault when we did not check
+# NULL cases.
+expect_error(amatch("a","b",nthread=1:4))
+expect_error(amatch("a","b",nthread="foo"))
+expect_error(amatch("a","b",nthread=integer(0)))
+expect_error(amatch("a","b",nthread=NULL))
+
 
 ## simple test and multiple edge cases
  expect_equal(amatch("aa",c("ba","bb"), method="osa",maxDist=1L), 1L)
@@ -187,5 +194,9 @@ options(sd_num_thread=2)
  expect_false(seq_ain(x,table))
 
 
+expect_error(seq_amatch(x,table,nthread=1:4))
+expect_error(seq_amatch(x,table,nthread="foo"))
+expect_error(seq_amatch(x,table,nthread=integer(0)))
+expect_error(seq_amatch(x,table,nthread=NULL))
 
 

pkg/inst/tinytest/test_seq_dist.R

@@ -1,5 +1,11 @@
 options(sd_num_thread=2)
 ## seq_dist
+# tests against cases that used to segfault when we did not check
+# NULL cases.
+expect_error(seq_dist(a=list(c(1L,2L,3L)), b=list(c(2L,1L,3L)),nthread=1:4))
+expect_error(seq_dist(a=list(c(1L,2L,3L)), b=list(c(2L,1L,3L)),nthread="foo"))
+expect_error(seq_dist(a=list(c(1L,2L,3L)), b=list(c(2L,1L,3L)),nthread=integer(0)))
+expect_error(seq_dist(a=list(c(1L,2L,3L)), b=list(c(2L,1L,3L)),nthread=NULL))
 
 # A simple test to see that everything is passed on to the correct
 # algorithm

pkg/inst/tinytest/test_stringdist.R

@@ -8,11 +8,19 @@ options(sd_num_thread=2)
  expect_error(stringdist("a","b",weight=c(-1,1,1,1)))
  expect_error(stringdist("a","b",weight=c(1,0,1,1)))
  expect_error(stringdist("a","b",weight=c(1,1,1,4)))
+ expect_error(stringdist("a","b",nthread=1:4))
+ expect_error(stringdist("a","b",nthread="foo"))
+ expect_error(stringdist("a","b",nthread=integer(0)))
+ expect_error(stringdist("a","b",nthread=NULL))
  expect_warning(stringdist(letters[1:3],letters[1:2]))
  expect_warning(stringdist(list('a'),'a'))
  expect_warning(stringdist('a',list('a')))
  expect_warning(stringdistmatrix(list('a')))
  expect_warning(stringdistmatrix(list('a'),list('b')))
+ expect_error(stringdistmatrix("a","b",nthread=1:4))
+ expect_error(stringdistmatrit("a","b",nthread="foo"))
+ expect_error(stringdistmatrit("a","b",nthread=integer(0)))
+ expect_error(stringdistmatrit("a","b",nthread=NULL))