1#' @describeIn linters checks that closures have the proper usage using
2#' \code{\link[codetools]{checkUsage}}.  Note this runs
3#' \code{\link[base]{eval}} on the code, so do not use with untrusted code.
4#' @export
5object_usage_linter <-  function(source_file) {
6  # we only want to run on the full file
7  if (is.null(source_file$file_lines)) {
8    return()
9  }
10
11  # If there is no xml data just return
12  if (is.null(source_file$xml_parsed_content)) {
13    return()
14  }
15
16  source_file$parsed_content <- source_file$full_parsed_content
17
18  pkg_name <- pkg_name(find_package(dirname(source_file$filename)))
19  if (!is.null(pkg_name)) {
20    parent_env <- try_silently(getNamespace(pkg_name))
21  }
22  if (is.null(pkg_name) || inherits(parent_env, "try-error")) {
23    parent_env <- globalenv()
24  }
25  env <- new.env(parent = parent_env)
26
27  declared_globals <- try_silently(utils::globalVariables(package = pkg_name %||% globalenv()))
28
29  symbols <- get_assignment_symbols(source_file$xml_parsed_content)
30
31  # Just assign them an empty function
32  for(symbol in symbols) {
33    assign(symbol, function(...) invisible(), envir = env)
34  }
35
36  all_globals <- unique(recursive_ls(env))
37
38  fun_info <- get_function_assignments(source_file$xml_parsed_content)
39
40  lapply(seq_len(NROW(fun_info)), function(i) {
41    info <- fun_info[i, ]
42
43    code <- get_content(lines = source_file$content[seq(info$line1, info$line2)], info)
44    fun <- try_silently(eval(envir = env,
45      parse(
46        text = code,
47        keep.source = TRUE
48      )
49    ))
50
51    if (inherits(fun, "try-error")) {
52      return()
53    }
54    res <- parse_check_usage(fun)
55
56    lapply(which(!is.na(res$message)),
57      function(row_num) {
58        row <- res[row_num, ]
59
60        if (row$name %in% declared_globals) {
61          return()
62        }
63
64        org_line_num <- as.integer(row$line_number) + info$line1 - 1L
65
66        line <- source_file$content[as.integer(org_line_num)]
67
68        row$name <- re_substitutes(row$name, rex("<-"), "")
69
70        location <- re_matches(line,
71          rex(row$name),
72          locations = TRUE)
73
74        Lint(
75          filename = source_file$filename,
76          line_number = org_line_num,
77          column_number = location$start,
78          type = "warning",
79          message = row$message,
80          line = line,
81          ranges = list(c(location$start, location$end)),
82          linter = "object_usage_linter"
83        )
84      })
85  })
86}
87
88get_assignment_symbols <- function(xml) {
89  left_assignment_symbols <- xml2::xml_text(xml2::xml_find_all(xml, "expr[LEFT_ASSIGN]/expr[1]/*"))
90
91  equal_assignment_symbols <- xml2::xml_text(xml2::xml_find_all(xml, "equal_assign/expr[1]/*"))
92
93  assign_fun_symbols <- xml2::xml_text(xml2::xml_find_all(xml, "expr[expr[SYMBOL_FUNCTION_CALL/text()='assign']]/expr[2]/*"))
94
95  set_method_fun_symbols <- xml2::xml_text(xml2::xml_find_all(xml, "expr[expr[SYMBOL_FUNCTION_CALL/text()='setMethod']]/expr[2]/*"))
96
97  symbols <- c(left_assignment_symbols, equal_assignment_symbols, assign_fun_symbols, set_method_fun_symbols)
98
99  # remove quotes or backticks from the beginning or the end
100  symbols <- gsub("^[`'\"]|['\"`]$", "", symbols)
101
102  symbols
103}
104
105get_function_assignments <- function(xml) {
106  left_assignment_functions <- xml2::xml_find_all(xml, "expr[LEFT_ASSIGN][expr[2][FUNCTION]]/expr[2]")
107
108  equal_assignment_functions <- xml2::xml_find_all(xml, "equal_assign[expr[2]][expr[FUNCTION]]/expr[2]")
109
110  assign_fun_assignment_functions <- xml2::xml_find_all(xml, "expr[expr[SYMBOL_FUNCTION_CALL/text()='assign']]/expr[3]")
111
112  set_method_fun_assignment_functions <- xml2::xml_find_all(xml, "expr[expr[SYMBOL_FUNCTION_CALL/text()='setMethod']]/expr[3]")
113
114  funs <- c(left_assignment_functions, equal_assignment_functions, assign_fun_assignment_functions, set_method_fun_assignment_functions)
115
116  get_attr <- function(x, attr) as.integer(xml2::xml_attr(x, attr))
117
118  data.frame(
119    line1 = viapply(funs, get_attr, "line1"),
120    line2 = viapply(funs, get_attr, "line2"),
121    col1 = viapply(funs, get_attr, "col1"),
122    col2 = viapply(funs, get_attr, "col2"),
123    stringsAsFactors = FALSE
124  )
125}
126
127parse_check_usage <- function(expression) {
128
129  vals <- list()
130
131  report <- function (x) {
132    vals[[length(vals) + 1L]] <<- x
133  }
134
135  try(codetools::checkUsage(expression, report = report))
136
137  function_name <- rex(anything, ": ")
138  line_info <- rex(" ", "(", capture(name = "path", non_spaces), ":", capture(name = "line_number", digits), ")")
139
140  res <- re_matches(vals,
141    rex(function_name,
142      capture(name = "message", anything,
143        one_of(quote, "\u2018"), capture(name = "name", anything), one_of(quote, "\u2019"),
144        anything),
145      line_info))
146
147  missing <- is.na(res$message)
148  if (any(missing)) {
149    res[missing, ] <- re_matches(vals[missing],
150      rex(function_name,
151        capture(name = "message",
152          "possible error in ", capture(name = "name", anything), ": ", anything
153          ),
154          line_info))
155  }
156
157  res
158}
159