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