Test for r-lib#1480

olivroy · Jul 3, 2023 · c6290a2 · c6290a2
1 parent a34bdf7
commit c6290a2
Show file tree

Hide file tree

Showing 3 changed files with 92 additions and 4 deletions.
diff --git a/R/rd-find-link-files.R b/R/rd-find-link-files.R
@@ -48,7 +48,8 @@ find_topic_in_package <- function(pkg, topic) {
   on.exit(close(con), add = TRUE)
   con <- textConnection(topic)
   raw_topic <- str_trim(tools::parse_Rd(con)[[1]][1])
-  basename(utils::help((raw_topic), (pkg))[1])
+  name <- utils::help((raw_topic), (pkg))[1]
+  basename(name)
 }
 
 try_find_topic_in_package <- function(pkg, topic, tag) {
@@ -61,7 +62,8 @@ try_find_topic_in_package <- function(pkg, topic, tag) {
   )
 
   if (is.na(path)) {
-    warn_roxy_tag(tag, "refers to unavailable topic {pkg}::{topic}")
+    message <- warn_roxy_tag(tag, "refers to unavailable topic {pkg}::{topic}", warn = FALSE)
+    cli::cli_warn(message)
     topic
   } else {
     path

diff --git a/R/tag.R b/R/tag.R
@@ -119,13 +119,17 @@ roxy_tag_warning <- function(x, ...) {
 
 #' @export
 #' @rdname roxy_tag
-warn_roxy_tag <- function(tag, message, ...) {
+warn_roxy_tag <- function(tag, message, ..., warn = TRUE) {
   message[[1]] <- paste0(
     link_to(tag$file, tag$line), " @", tag$tag, " ",
     if (is.null(tag$raw)) ("(automatically generated) "),
     message[[1]]
   )
-  cli::cli_warn(message, ..., .envir = parent.frame())
+  if (warn) {
+    cli::cli_warn(message, ..., .envir = parent.frame())
+  } else {
+    message
+  }
 }
 
 link_to <- function(file, line) {

diff --git a/R/utils.R b/R/utils.R
@@ -179,3 +179,85 @@ auto_quote <- function(x) {
 
 is_syntactic <- function(x) make.names(x) == x
 has_quotes <- function(x) str_detect(x, "^(`|'|\").*\\1$")
+
+# Help ------
+
+# Adapted from utils::help
+find.package <- function (package = NULL, lib.loc = NULL, quiet = FALSE, verbose = getOption("verbose"))
+{
+  if (is.null(package) && is.null(lib.loc) && !verbose) {
+    return(path.package())
+  }
+  if (length(package) == 1L && package %in% c("base", "tools",
+                                              "utils", "grDevices", "graphics", "stats", "datasets",
+                                              "methods", "grid", "parallel", "splines", "stats4", "tcltk",
+                                              "compiler"))
+    return(file.path(.Library, package))
+  if (is.null(package))
+    package <- .packages()
+  if (!length(package))
+    return(character())
+  if (use_loaded <- is.null(lib.loc))
+    lib.loc <- .libPaths()
+  bad <- character()
+  out <- character()
+  for (pkg in package) {
+    paths <- file.path(lib.loc, pkg)
+    paths <- paths[file.exists(file.path(paths, "DESCRIPTION"))]
+    if (use_loaded && isNamespaceLoaded(pkg)) {
+      dir <- if (pkg == "base")
+        system.file()
+      else .getNamespaceInfo(asNamespace(pkg), "path")
+      paths <- c(dir, paths)
+    }
+    if (length(paths) && file.exists(file.path(paths[1],
+                                               "dummy_for_check"))) {
+      bad <- c(bad, pkg)
+      next
+    }
+    if (length(paths)) {
+      paths <- unique(paths)
+      valid_package_version_regexp <- .standard_regexps()$valid_package_version
+      db <- lapply(paths, function(p) {
+        pfile <- file.path(p, "Meta", "package.rds")
+        info <- if (file.exists(pfile)) {
+          tryCatch(readRDS(pfile)$DESCRIPTION[c("Package",
+                                                "Version")], error = function(e) c(Package = NA_character_,
+                                                                                   Version = NA_character_))
+        }
+        else {
+          info <- tryCatch(read.dcf(file.path(p, "DESCRIPTION"),
+                                    c("Package", "Version"))[1, ], error = identity)
+          if (inherits(info, "error") || (length(info) !=
+                                          2L) || anyNA(info))
+            c(Package = NA_character_, Version = NA_character_)
+          else info
+        }
+      })
+      db <- do.call(rbind, db)
+      ok <- (apply(!is.na(db), 1L, all) & (db[, "Package"] ==
+                                             pkg) & (grepl(valid_package_version_regexp, db[,
+                                                                                            "Version"])))
+      paths <- paths[ok]
+    }
+    if (length(paths) == 0L) {
+      bad <- c(bad, pkg)
+      next
+    }
+    if (length(paths) > 1L) {
+      if (verbose)
+        warning(gettextf("package %s found more than once, using the first from\n  %s",
+                         sQuote(pkg), paste(dQuote(paths), collapse = ",\n  ")),
+                domain = NA)
+      paths <- paths[1L]
+    }
+    out <- c(out, paths)
+  }
+  if (!quiet && length(bad)) {
+    if (length(out) == 0L)
+      stop(packageNotFoundError(bad, lib.loc, call = FALSE), call. = FALSE)
+    for (pkg in bad) warning(gettextf("there is no package called %s",
+                                      sQuote(pkg)), domain = NA)
+  }
+  out
+}