Optionally check for if(class() == string).

git-svn-id: https://svn.r-project.org/R/trunk@81792 00db46b3-68df-0310-9c12-caf00c1e9a41

src/library/tools/R/QC.R

@@ -32,6 +32,7 @@
 ## .check_package_code_assign_to_globalenv
 ## .check_package_code_attach
 ## .check_package_code_data_into_globalenv
+## .check_package_code_class_is_string
 ## .check_code_usage_in_package
 ## .check_bogus_return
 ## .check_dotInternal
@@ -5584,6 +5585,41 @@ function(x, ...)
       unlist(Map(.format_calls_in_file, x, names(x))))
 }
 
+### * .check_package_code_class_is_string
+
+## Could easily make this return something classed with suitable
+## format() and print() methods ...
+
+.check_package_code_class_is_string <-
+function(dir) {
+    predicate <- function(e) {
+        is.call(e) &&
+            (length(e) >= 2L) &&
+            (as.character(e[[1L]]) == "if") &&
+            is.call(e <- e[[2L]]) &&
+            (as.character(e[[1L]]) %in% c("==", "!-")) &&
+            is.call(e2 <- e[[2L]]) &&
+            (as.character(e2[[1L]]) == "class") &&
+            is.character(e[[3L]]) &&
+            (length(e[[3L]] == 1L))
+    }
+    x <- Filter(length,
+                .find_calls_in_package_code(dir, predicate,
+                                            recursive = TRUE))
+    if(length(x)) {
+        s <- sprintf("File %s: %s",
+                     sQuote(rep.int(names(x), lengths(x))),
+                     vapply(unlist(x),
+                            function(e)
+                                sprintf("if (%s) ...", deparse1(e[[2L]])),
+                            ""))
+        writeLines(c("Found if() conditions comparing class() to string:",
+                     s,
+                     "Use inherits() (or maybe is()) instead."))
+    }
+    invisible(x)
+}
+
 ### * .check_packages_used
 
 .check_packages_used <-

src/library/tools/R/check.R

@@ -2066,7 +2066,7 @@ add_dummies <- function(dir, Log)
         out1 <- if (length(out1) && length(out1a)) c(out1, "", out1a)
                 else c(out1, out1a)
 
-        out2 <- out3 <- out4 <- out5 <- out6 <- out7 <- out8 <- out9 <- NULL
+        out2 <- out3 <- out4 <- out5 <- out6 <- out7 <- out8 <- out9 <- out10 <- NULL
 
         if (!is_base_pkg && R_check_unsafe_calls) {
             Rcmd <- paste(opWarn_string, "\n",
@@ -2158,12 +2158,20 @@ add_dummies <- function(dir, Log)
             out9 <- R_runR2(Rcmd, "R_DEFAULT_PACKAGES=")
         }
 
+        if(R_check_code_class_is_string) {
+            Rcmd <- paste(opWarn_string, "\n",
+                          sprintf("tools:::.check_package_code_class_is_string(dir = \"%s\")\n",
+                                  pkgdir))
+            out10 <- R_runR0(Rcmd, R_opts2, "R_DEFAULT_PACKAGES=NULL")
+        }
+
         t2 <- proc.time()
         print_time(t1, t2, Log)
 
         if (length(out1) || length(out2) || length(out3) ||
             length(out4) || length(out5) || length(out6) ||
-            length(out7) || length(out8) || length(out9)) {
+            length(out7) || length(out8) || length(out9) ||
+            length(out10)) {
             ini <- character()
             if(length(out4) ||
                (length(out8) &&
@@ -2227,6 +2235,10 @@ add_dummies <- function(dir, Log)
                 printLog0(Log, paste(c(ini, out9, ""), collapse = "\n"))
                 ini <- ""
             }
+            if(length(out10)) {
+                printLog0(Log, paste(c(ini, out10, ""), collapse = "\n"))
+                ini <- ""
+            }
         } else resultLog(Log, "OK")
     }
 
@@ -6336,6 +6348,9 @@ add_dummies <- function(dir, Log)
     R_check_vignette_titles <-
         config_val_to_logical(Sys.getenv("_R_CHECK_VIGNETTE_TITLES_",
                                          "FALSE"))
+    R_check_code_class_is_string <-
+        config_val_to_logical(Sys.getenv("_R_CHECK_CODE_CLASS_IS_STRING_",
+                                         "FALSE"))
 
     if (!nzchar(check_subdirs)) check_subdirs <- R_check_subdirs_strict
 
@@ -6408,6 +6423,7 @@ add_dummies <- function(dir, Log)
         R_check_things_in_temp_dir <- TRUE
         R_check_vignette_titles <- TRUE
         R_check_bogus_return <- TRUE
+        R_check_code_class_is_string <- TRUE
     } else {
         ## do it this way so that INSTALL produces symbols.rds
         ## when called from check but not in general.