From 68a5cc6d837f4bdc8b55470b95a921884e970771 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?G=C3=A1bor=20Cs=C3=A1rdi?= Date: Mon, 4 Nov 2024 09:46:40 +0100 Subject: [PATCH] Improve deps scanning - filter out calls from the wrong package - add support for modules --- R/scan-deps-queries.R | 23 +++++++++++-- R/scan-deps.R | 78 ++++++++++++++++++++++++++++++++----------- R/utils.R | 2 ++ 3 files changed, 81 insertions(+), 22 deletions(-) diff --git a/R/scan-deps-queries.R b/R/scan-deps-queries.R index fb4a87ab..3d1377e8 100644 --- a/R/scan-deps-queries.R +++ b/R/scan-deps-queries.R @@ -7,21 +7,38 @@ q_library_0 <- function() { (#any-of? @fn-name "library" "require" "loadNamespace" "requireNamespace" "pkg_attach" "pkg_attach2" - "p_load"))', + "p_load" + "module"))', '((call function: (namespace_operator lhs: (identifier) @ns-name rhs: (identifier) @fn-name ) ) @dep-code - (#any-of? @ns-name "base" "xfun" "pacman") + (#any-of? @ns-name "base" "xfun" "pacman" "modules") (#any-of? @fn-name "library" "require" "loadNamespace" "requireNamespace" "pkg_attach" "pkg_attach2" - "p_load"))' + "p_load" + "module" "import"))' ), names = rep("q_library_0", 2)) } +q_import <- function() { + c( + '((call function: (identifier) @fn-name) @dep-code + (#any-of? @fn-name "import"))', + '((call function: + (namespace_operator + lhs: (identifier) @ns-name + rhs: (identifier) @fn-name + ) + ) @dep-code + (#any-of? @ns-name "modules") + (#any-of? @fn-name "import"))' + ) +} + # pkg::fun, pkg:::fun q_colon <- function() { '((namespace_operator lhs: (identifier) @pkg-name) @dep-code diff --git a/R/scan-deps.R b/R/scan-deps.R index 383444a0..01f32a31 100644 --- a/R/scan-deps.R +++ b/R/scan-deps.R @@ -38,7 +38,8 @@ re_r_dep <- paste0(collapse = "|", c( "::", "setClass", "setGeneric", "pkg_attach", - "p_load" + "p_load", + "module" )) scan_path_deps <- function(path) { @@ -147,8 +148,16 @@ scan_path_deps_do_fn_hits <- function(hits, path) { scan_path_deps_do_gen_hits <- function(hits, path) { code <- hits$code[hits$name == "dep-code"] fn <- hits$code[hits$name == "fn-name"] + match_count <- max(c(hits$match, 0)) + ns <- vcapply( + seq_len(match_count), + function(m) { + hits[hits$match == m & hits$name == "ns-name", ]$code %|0|% + NA_character_ + } + ) pkgs <- lapply(seq_along(code), function(i) { - safe_parse_pkg_from_call(fn[i], code[i]) + safe_parse_pkg_from_call(ns[i], fn[i], code[i]) }) pkgs_count <- lengths(pkgs) data_frame( @@ -162,42 +171,51 @@ scan_path_deps_do_gen_hits <- function(hits, path) { ) } -fake_xfun_pkg_attach <- function(..., install, message) { } -fake_xfun_pkg_attach2 <- function(...) { } -fake_pacman_p_load <- function(..., char, install, update, character.only) { } +prot_xfun_pkg_attach <- function(..., install, message) { } +prot_xfun_pkg_attach2 <- function(...) { } +prot_pacman_p_load <- function(..., char, install, update, character.only) { } +prot_modules_import <- function(from, ..., attach = TRUE, where = parent.frame()) { } +prot_modules_module <- function(expr = {}, topEncl = NULL, envir = parent.frame()) { } -safe_parse_pkg_from_call <- function(fn, code) { +safe_parse_pkg_from_call <- function(ns, fn, code) { tryCatch( - parse_pkg_from_call(fn, code), + parse_pkg_from_call(ns, fn, code), error = function(...) NULL ) } -parse_pkg_from_call <- function(fn, code) { +parse_pkg_from_call <- function(ns, fn, code) { expr <- parse(text = code, keep.source = FALSE) fun <- switch(fn, "library" = base::library, "require" = base::require, "loadNamespace" = base::loadNamespace, "requireNamespace" = base::requireNamespace, - "pkg_attach" = fake_xfun_pkg_attach, - "pkg_attach2" = fake_xfun_pkg_attach2, - "p_load" = fake_pacman_p_load, + "pkg_attach" = prot_xfun_pkg_attach, + "pkg_attach2" = prot_xfun_pkg_attach2, + "p_load" = prot_pacman_p_load, + "import" = prot_modules_import, + "module" = prot_modules_module ) matched <- match.call(fun, expr, expand.dots = FALSE) switch(fn, "library" = , "require" = - parse_pkg_from_call_library(matched), + parse_pkg_from_call_library(ns, fs, matched), "loadNamespace" = , "requireNamespace" = - parse_pkg_from_call_loadNamespace(matched), + parse_pkg_from_call_loadNamespace(ns, fn, matched), "pkg_attache" = , "pkg_attach2" = - parse_pkg_from_call_xfun(matched), + parse_pkg_from_call_xfun(ns, fn, matched), "p_load" = - parse_pkg_from_call_pacman(matched) + parse_pkg_from_call_pacman(ns, fn, matched), + "import" = + parse_pkg_from_call_modules_import(ns, fn, matched), + "module" = + parse_pkg_from_call_modules_module(ns, fn, matched) ) } -parse_pkg_from_call_library <- function(matched) { +parse_pkg_from_call_library <- function(ns, fn, matched) { + if (!is.na(ns) && ns != "base") return(NULL) pkg <- matched[["package"]] if (is.character(pkg) && length(pkg) == 1) { return(pkg) @@ -209,7 +227,8 @@ parse_pkg_from_call_library <- function(matched) { NULL } -parse_pkg_from_call_loadNamespace <- function(matched) { +parse_pkg_from_call_loadNamespace <- function(ns, fn, matched) { + if (!is.na(ns) && ns != "base") return(NULL) pkg <- matched[["package"]] if (is.character(pkg) && length(pkg) == 1) { return(pkg) @@ -217,7 +236,8 @@ parse_pkg_from_call_loadNamespace <- function(matched) { NULL } -parse_pkg_from_call_xfun <- function(matched) { +parse_pkg_from_call_xfun <- function(ns, fn, matched) { + if (!is.na(ns) && ns != "xfun") return(NULL) pkgs <- unlist(lapply( matched[["..."]], function(x) if (is.character(x)) x @@ -226,7 +246,8 @@ parse_pkg_from_call_xfun <- function(matched) { NULL } -parse_pkg_from_call_pacman <- function(matched) { +parse_pkg_from_call_pacman <- function(ns, fn, matched) { + if (!is.na(ns) && ns != "pacman") return(NULL) # list of characters and symbols pkgs <- as.list(matched[["..."]]) @@ -247,6 +268,25 @@ parse_pkg_from_call_pacman <- function(matched) { NULL } +parse_pkg_from_call_modules_import <- function(ns, fn, matched) { + if (!is.na(ns) && ns != "modules") return(NULL) + pkgs <- as.character(matched[["from"]]) + if (length(pkgs) > 0) return(pkgs) + NULL +} + +parse_pkg_from_call_modules_module <- function(ns, fn, matched) { + if (!is.na(ns) && ns != "modules") return(NULL) + expr <- as.character(matched[["expr"]]) + hits <- code_query(expr, q_import())[["matched_captures"]] + code <- hits$code[hits$name == "dep-code"] + pkgs <- lapply(seq_along(code), function(i) { + safe_parse_pkg_from_call(ns, "import", code[i]) + }) + if (length(pkgs) > 0) return(unlist(pkgs)) + NULL +} + # ------------------------------------------------------------------------- scan_path_deps_do_rmd <- function(code, path) { diff --git a/R/utils.R b/R/utils.R index 2a294f79..c6a05665 100644 --- a/R/utils.R +++ b/R/utils.R @@ -7,6 +7,8 @@ pkgd_data <- new.env(parent = emptyenv()) `%||%` <- function(l, r) if (is.null(l)) r else l +`%|0|%` <- function(l, r) if (length(l) == 0) r else l + `%|z|%` <- function(l, r) if (is.null(l) || identical(l, "")) r else l `%&z&%` <- function(l, r) if (length(l) > 0 && l != "") r else ""