Logic to make linters robust to adversarial comments (#2901)

* logic to make linters robust to adversarial comments

* remove those under #2827

* more in sync with #2827 in/out rule

* need known_safe

* delint

* add a comment

* spurious ws

* review feedback

* update / improve comment about needs_braces=TRUE

* bad merge: needs to be following-sibling

Author: MichaelChirico

R/brace_linter.R

@@ -134,7 +134,7 @@ brace_linter <- function(allow_single_line = FALSE,
     { xp_cond_closed }
     and (
       (@line1 = preceding-sibling::*[1][not(self::OP-LEFT-BRACE)]/@line2)
-      or (@line1 = parent::expr/following-sibling::*[1][not(self::ELSE)]/@line1)
+      or (@line1 = parent::expr/following-sibling::*[not(self::COMMENT)][1][not(self::ELSE)]/@line1)
     )
   ]")
 

R/coalesce_linter.R

@@ -46,34 +46,34 @@
 coalesce_linter <- function() {
   braced_expr_cond <- "expr[1][OP-LEFT-BRACE and count(*) = 3]/expr"
   xpath <- glue("
-  parent::expr[
+  expr[expr[
     preceding-sibling::IF
     and (
       expr[2] = following-sibling::ELSE/following-sibling::expr
       or expr[2] = following-sibling::ELSE/following-sibling::{braced_expr_cond}
       or expr[2][LEFT_ASSIGN]/expr[1] = following-sibling::ELSE/following-sibling::expr
       or expr[2][LEFT_ASSIGN]/expr[1] = following-sibling::ELSE/following-sibling::{braced_expr_cond}
     )
-  ]
-    /parent::expr
+  ]]
   |
-  parent::expr[
-    preceding-sibling::OP-EXCLAMATION
-    and parent::expr/preceding-sibling::IF
-    and parent::expr/following-sibling::ELSE
+  self::*[expr[
+    preceding-sibling::IF
+    and following-sibling::ELSE
+    and OP-EXCLAMATION
     and (
-      expr[2] = parent::expr/following-sibling::expr[1]
-      or expr[2] = parent::expr/following-sibling::{braced_expr_cond}
-      or expr[2][LEFT_ASSIGN]/expr[1] = parent::expr/following-sibling::expr[1]
-      or expr[2][LEFT_ASSIGN]/expr[1] = parent::expr/following-sibling::{braced_expr_cond}
+      expr/expr[2] = following-sibling::expr[1]
+      or expr/expr[2] = following-sibling::{braced_expr_cond}
+      or expr/expr[2][LEFT_ASSIGN]/expr[1] = following-sibling::expr[1]
+      or expr/expr[2][LEFT_ASSIGN]/expr[1] = following-sibling::{braced_expr_cond}
     )
-  ]
-    /parent::expr
-    /parent::expr
+  ]]
   ")
 
   Linter(linter_level = "expression", function(source_expression) {
-    null_calls <- source_expression$xml_find_function_calls("is.null")
+    null_calls <- xml_parent(xml_parent(xml_parent(
+      source_expression$xml_find_function_calls("is.null")
+    )))
+    null_calls <- strip_comments_from_subtree(null_calls)
     bad_expr <- xml_find_all(null_calls, xpath)
     is_negation <- !is.na(xml_find_first(bad_expr, "expr/OP-EXCLAMATION"))
     observed <- ifelse(is_negation, "if (!is.null(x)) x else y", "if (is.null(x)) y else x")

R/empty_assignment_linter.R

@@ -33,7 +33,7 @@
 empty_assignment_linter <- make_linter_from_xpath(
   # for some reason, the parent in the `=` case is <equal_assign>, not <expr>, hence parent::expr
   xpath = "
-  //OP-LEFT-BRACE[following-sibling::*[1][self::OP-RIGHT-BRACE]]
+  //OP-LEFT-BRACE[following-sibling::*[not(self::COMMENT)][1][self::OP-RIGHT-BRACE]]
     /parent::expr[
       preceding-sibling::LEFT_ASSIGN
       or preceding-sibling::EQ_ASSIGN

R/expect_comparison_linter.R

@@ -65,7 +65,7 @@ expect_comparison_linter <- function() {
     xml_calls <- source_expression$xml_find_function_calls("expect_true")
     bad_expr <- xml_find_all(xml_calls, xpath)
 
-    comparator <- xml_find_chr(bad_expr, "string(expr[2]/*[2])")
+    comparator <- xml_find_chr(bad_expr, "string(expr[2]/*[not(self::COMMENT)][2])")
     expectation <- comparator_expectation_map[comparator]
     lint_message <- sprintf("%s(x, y) is better than expect_true(x %s y).", expectation, comparator)
     xml_nodes_to_lints(bad_expr, source_expression, lint_message = lint_message, type = "warning")

R/if_switch_linter.R

@@ -191,8 +191,6 @@ if_switch_linter <- function(max_branch_lines = 0L, max_branch_expressions = 0L)
   # NB: IF AND {...} AND ELSE/... implies >= 3 equality conditions are present
   # .//expr/IF/...: the expr in `==` that's _not_ the STR_CONST
   # not(preceding::IF): prevent nested matches which might be incorrect globally
-  # not(. != .): don't match if there are _any_ expr which _don't_ match the top
-  #   expr
   if_xpath <- glue("
   //IF
     /parent::expr[
@@ -203,21 +201,27 @@ if_switch_linter <- function(max_branch_lines = 0L, max_branch_expressions = 0L)
         and {equal_str_cond}
         and ELSE/following-sibling::expr[IF and {equal_str_cond}]
       ]
-      and not(
-        .//expr/IF/following-sibling::{equal_str_cond}/expr[not(STR_CONST)]
-          != expr[1][EQ]/expr[not(STR_CONST)]
-      )
       and not({ max_lines_cond })
     ]
   ")
 
+  # not(. != .): don't match if there are _any_ expr which _don't_ match the top expr
+  equality_test_cond <- glue("self::*[
+    .//expr/IF/following-sibling::{equal_str_cond}/expr[not(STR_CONST)]
+      != expr[1][EQ]/expr[not(STR_CONST)]
+  ]")
+
   Linter(linter_level = "expression", function(source_expression) {
     xml <- source_expression$xml_parsed_content
 
     bad_expr <- xml_find_all(xml, if_xpath)
+    expr_all_equal <- is.na(xml_find_first(
+      strip_comments_from_subtree(bad_expr),
+      equality_test_cond
+    ))
 
     lints <- xml_nodes_to_lints(
-      bad_expr,
+      bad_expr[expr_all_equal],
       source_expression = source_expression,
       lint_message = paste(
         "Prefer switch() statements over repeated if/else equality tests,",

R/implicit_assignment_linter.R

@@ -96,7 +96,7 @@ implicit_assignment_linter <- function(except = c("bquote", "expression", "expr"
   xpath <- glue("
     ({assignments})
       /parent::expr[
-        preceding-sibling::*[2][self::IF or self::WHILE]
+        preceding-sibling::*[not(self::COMMENT)][2][self::IF or self::WHILE]
         or parent::forcond
         or preceding-sibling::expr/{xpath_exceptions}
         or parent::expr/*[1][self::OP-LEFT-PAREN]
@@ -108,7 +108,7 @@ implicit_assignment_linter <- function(except = c("bquote", "expression", "expr"
   }
   if (allow_scoped) {
     # force 2nd preceding to ensure we're in the loop condition, not the loop expression
-    in_branch_cond <- "ancestor-or-self::expr[preceding-sibling::*[2][self::IF or self::WHILE]]"
+    in_branch_cond <- "ancestor-or-self::expr[preceding-sibling::*[not(self::COMMENT)][2][self::IF or self::WHILE]]"
     xpath <- paste0(
       xpath,
       # _if_ we're in an IF/WHILE branch, lint if the assigned SYMBOL appears anywhere later on.

R/length_test_linter.R

@@ -51,9 +51,14 @@ length_test_linter <- function() {
   Linter(linter_level = "expression", function(source_expression) {
     xml_calls <- source_expression$xml_find_function_calls(c("length", "nrow", "ncol", "NROW", "NCOL"))
     bad_expr <- xml_find_all(xml_calls, xpath)
+    bad_expr <- strip_comments_from_subtree(bad_expr)
 
     matched_function <- xp_call_name(bad_expr)
-    expr_parts <- vapply(lapply(bad_expr, xml_find_all, "expr[2]/*"), xml_text, character(3L))
+    expr_parts <- vapply(
+      lapply(bad_expr, xml_find_all, "expr[2]/*[not(self::COMMENT)]"),
+      xml_text,
+      character(3L)
+    )
     lint_message <- sprintf(
       "Checking the %s of a logical vector is likely a mistake. Did you mean `%s(%s) %s %s`?",
       matched_function, matched_function, expr_parts[1L, ], expr_parts[2L, ], expr_parts[3L, ]

R/object_usage_linter.R

@@ -61,13 +61,24 @@ object_usage_linter <- function(interpret_glue = NULL, interpret_extensions = c(
   # NB: the repeated expr[2][FUNCTION] XPath has no performance impact, so the different direct assignment XPaths are
   #   split for better readability, see PR#1197
   # TODO(#1106): use //[...] to capture assignments in more scopes
-  xpath_function_assignment <- "
-    expr[LEFT_ASSIGN or EQ_ASSIGN]/expr[2][FUNCTION or OP-LAMBDA]
-    | expr_or_assign_or_help[EQ_ASSIGN]/expr[2][FUNCTION or OP-LAMBDA]
-    | equal_assign[EQ_ASSIGN]/expr[2][FUNCTION or OP-LAMBDA]
-    | //SYMBOL_FUNCTION_CALL[text() = 'assign']/parent::expr/following-sibling::expr[2][FUNCTION or OP-LAMBDA]
-    | //SYMBOL_FUNCTION_CALL[text() = 'setMethod']/parent::expr/following-sibling::expr[3][FUNCTION or OP-LAMBDA]
-  "
+  fun_node <- "FUNCTION or OP-LAMBDA"
+  xpath_function_assignment <- glue("
+    expr[LEFT_ASSIGN or EQ_ASSIGN]/expr[2][{fun_node}]
+    | expr_or_assign_or_help[EQ_ASSIGN]/expr[2][{fun_node}]
+    | equal_assign[EQ_ASSIGN]/expr[2][{fun_node}]
+    | //SYMBOL_FUNCTION_CALL[text() = 'assign']/parent::expr/following-sibling::expr[2][{fun_node}]
+    | //SYMBOL_FUNCTION_CALL[text() = 'setMethod']/parent::expr/following-sibling::expr[3][{fun_node}]
+  ")
+
+  # code like:
+  #   foo <- \ #comment
+  #     (x) x
+  # is technically valid, but won't parse unless the lambda is in a bigger expression (here '<-').
+  #   the same doesn't apply to 'function', which is acknowledged as "not worth a breaking change to fix":
+  #   https://bugs.r-project.org/show_bug.cgi?id=18924. If we find such code (which has only ever
+  #   arisen in content fuzzing where we inject comments at random to the AST), we have to avoid parsing
+  #   it as a standalone expression.
+  xpath_unsafe_lambda <- "OP-LAMBDA[@line1 = following-sibling::*[1][self::COMMENT]/@line1]"
 
   # not all instances of linted symbols are potential sources for the observed violations -- see #1914
   symbol_exclude_cond <- "preceding-sibling::OP-DOLLAR or preceding-sibling::OP-AT or ancestor::expr[OP-TILDE]"
@@ -100,7 +111,9 @@ object_usage_linter <- function(interpret_glue = NULL, interpret_extensions = c(
     fun_assignments <- xml_find_all(xml, xpath_function_assignment)
 
     lapply(fun_assignments, function(fun_assignment) {
-      code <- get_content(lines = source_expression$content, fun_assignment)
+      # this will mess with the source line numbers. but I don't think anybody cares.
+      needs_braces <- !is.na(xml_find_first(fun_assignment, xpath_unsafe_lambda))
+      code <- get_content(lines = source_expression$content, fun_assignment, needs_braces = needs_braces)
       fun <- try_silently(eval(
         envir = env,
         parse(
@@ -190,8 +203,8 @@ get_assignment_symbols <- function(xml) {
       expr[RIGHT_ASSIGN]/expr[2]/SYMBOL[1] |
       equal_assign/expr[1]/SYMBOL[1] |
       expr_or_assign_or_help/expr[1]/SYMBOL[1] |
-      expr[expr[1][SYMBOL_FUNCTION_CALL/text()='assign']]/expr[2]/* |
-      expr[expr[1][SYMBOL_FUNCTION_CALL/text()='setMethod']]/expr[2]/*
+      expr[expr[1][SYMBOL_FUNCTION_CALL/text() = 'assign']]/expr[2]/* |
+      expr[expr[1][SYMBOL_FUNCTION_CALL/text() = 'setMethod']]/expr[2]/*
     "
   ))
 }

R/redundant_equals_linter.R

@@ -58,7 +58,7 @@ redundant_equals_linter <- function() {
     xml <- source_expression$xml_parsed_content
 
     bad_expr <- xml_find_all(xml, xpath)
-    op <- xml_text(xml_find_first(bad_expr, "*[2]"))
+    op <- xml_text(xml_find_first(bad_expr, "*[not(self::COMMENT)][2]"))
 
     xml_nodes_to_lints(
       bad_expr,

R/regex_subset_linter.R

@@ -47,25 +47,23 @@
 #' @seealso [linters] for a complete list of linters available in lintr.
 #' @export
 regex_subset_linter <- function() {
-  # parent::expr for LEFT_ASSIGN and RIGHT_ASSIGN, but, strangely,
-  #   parent::equal_assign for EQ_ASSIGN. So just use * as a catchall.
-  # See https://www.w3.org/TR/1999/REC-xpath-19991116/#booleans;
-  #   equality of nodes is based on the string value of the nodes, which
-  #   is basically what we need, i.e., whatever expression comes in
-  #   <expr>[grepl(pattern, <expr>)] matches exactly, e.g. names(x)[grepl(ptn, names(x))].
   xpath_fmt <- "
-  parent::expr[
-    parent::expr[
+  self::*[
+    not(LEFT_ASSIGN or EQ_ASSIGN or RIGHT_ASSIGN)
+  ]
+    /expr[
       OP-LEFT-BRACKET
-      and not(parent::*[LEFT_ASSIGN or EQ_ASSIGN or RIGHT_ASSIGN])
+      and expr[1] = expr/expr[position() = {arg_pos} ]
     ]
-    and expr[position() = {arg_pos} ] = parent::expr/expr[1]
-  ]"
+  "
   grep_xpath <- glue(xpath_fmt, arg_pos = 3L)
   stringr_xpath <- glue(xpath_fmt, arg_pos = 2L)
 
   Linter(linter_level = "expression", function(source_expression) {
-    grep_calls <- source_expression$xml_find_function_calls(c("grepl", "grep"))
+    grep_calls <- xml_parent(xml_parent(xml_parent(
+      source_expression$xml_find_function_calls(c("grepl", "grep"))
+    )))
+    grep_calls <- strip_comments_from_subtree(grep_calls)
     grep_expr <- xml_find_all(grep_calls, grep_xpath)
 
     grep_lints <- xml_nodes_to_lints(
@@ -78,7 +76,10 @@ regex_subset_linter <- function() {
       type = "warning"
     )
 
-    stringr_calls <- source_expression$xml_find_function_calls(c("str_detect", "str_which"))
+    stringr_calls <- xml_parent(xml_parent(xml_parent(
+      source_expression$xml_find_function_calls(c("str_detect", "str_which"))
+    )))
+    stringr_calls <- strip_comments_from_subtree(stringr_calls)
     stringr_expr <- xml_find_all(stringr_calls, stringr_xpath)
 
     stringr_lints <- xml_nodes_to_lints(