revdep check for Bugzilla#19079

load_unload_loop.R

# nolint start: line_length_linter, object_name_linter.
library(methods)

# Setup paths
myLib <- normalizePath("myLib")

# Read scan results to get all unique matched packages
results_data <- readRDS("s4_scan_results.rds")
all_pkgs <- unique(sapply(strsplit(sapply(results_data, `[[`, "package"), "_"), `[`, 1))

cat("Total S4 packages to verify with super-targeted validation loop:", length(all_pkgs), "\n\n")

Rcmd <- file.path(R.home("bin"), "Rscript")

results <- list()

for (pkg in all_pkgs) {
  cat("Testing package:", pkg, "... ")

  # Construct R code to execute the targeted uncache and dependency preservation snapshots
  code <- glue::glue(.open = "{{", .close = "}}", '
    pkg <- "{{pkg}}"
        
    # Step 1. Snapshot 1: S4 state BEFORE loading package
    # We must record snap_before at the very top to prevent requireNamespace from polluting it!
    snap_before <- list()
    for (g in methods::getGenerics()) {
      tbl <- tryCatch(methods::findMethods(g), error = function(e) NULL)
      if (is.null(tbl)) next
      snap_before[[g]] <- names(tbl)
    }
    
    # Check if target package is installed
    if (!requireNamespace(pkg, quietly = TRUE)) {
      cat("SKIPPED\\n")
      q(status = 0)
    }
    
    # Step 2. Load package
    load_failed <-
      inherits(tryCatch(loadNamespace(pkg), error=identity), "error")
    
    if (load_failed) {
      cat("FAILED_LOAD\\n")
      q(status = 0)
    }
    
    # Step 3. Snapshot 2: S4 state AFTER loading package
    snap_after <- list()
    for (g in methods::getGenerics()) {
      tbl <- tryCatch(methods::findMethods(g), error = function(e) NULL)
      if (is.null(tbl)) next
      sigs <- names(tbl)
      envs <- sapply(tbl, function(m) {
        env <- environment(m)
        if (is.null(env)) "" else environmentName(env)
      })
      snap_after[[g]] <- data.frame(sig = sigs, env = envs)
    }
    
    # Step 4. Identify S4 generics and methods owned SPECIFICALLY by `pkg`
    pkg_generics <- NULL
    pkg_methods <- list() # generic -> list of method signatures
    
    pkg_ns <- asNamespace(pkg)
    
    for (g in names(snap_after)) {
      # A generic is owned/defined by `pkg` if it exists directly in its namespace
      if (exists(g, envir=pkg_ns, inherits=FALSE)) {
        pkg_generics <- c(pkg_generics, g)
      }
      
      df_after <- snap_after[[g]]
      for (i in seq_len(nrow(df_after))) {
        if (df_after$env[i] != pkg) next
        pkg_methods[[g]] <- c(pkg_methods[[g]], df_after$sig[i])
      }
    }
    
    # Step 5. Unload package namespace
    unload_failed <-
      inherits(tryCatch(unloadNamespace(pkg), error=identity), "error")
    
    if (unload_failed) {
      cat("FAILED_UNLOAD\\n")
      q(status = 0)
    }
    
    # Step 6. Snapshot 3: S4 state AFTER unloading package
    snap_final <- list()
    for (g in methods::getGenerics()) {
      tbl <- tryCatch(methods::findMethods(g), error = function(e) NULL)
      if (is.null(tbl)) next
      snap_final[[g]] <- names(tbl)
    }
    
    # Step 7. VERIFICATIONS!
    
    # VERIFICATION 1: Clean target uncaching
    #   (All generics/methods owned by `pkg` must be gone)
    uncache_clean <- TRUE
    
    for (g in pkg_generics) {
      if (g %in% names(snap_before)) {
        # If it WAS generic in snap_before, all methods defined by `pkg` must be gone in snap_final
        if (!g %in% names(snap_final)) next
        tbl_final <- tryCatch(methods::findMethods(g), error = function(e) NULL)
        if (is.null(tbl_final)) next
        sigs_final <- names(tbl_final)
        for (sig in pkg_methods[[g]]) {
          if (!sig %in% sigs_final) next
          m <- tbl_final[[sig]]
          env <- environment(m)
          if (is.null(env) || environmentName(env) != pkg) next
          cat(sprintf("  [!] Target method [%s] on generic [%s] was not uncached\\n", sig, g))
          uncache_clean <- FALSE
        }
      } else {
        # If it was NOT generic in snap_before, it must NOT be generic in snap_final
        if (!g %in% names(snap_final)) next
        cat(sprintf("  [!] Target generic [%s] was not uncached\\n", g))
        uncache_clean <- FALSE
      }
    }
    
    # VERIFICATION 2: Dependency Preservation
    #  (Dependency S4 generics/methods not owned by `pkg` must be intact)
    #   We exclude base/system packages since base generics revert when unused!
    deps_preserved <- TRUE
    base_system_pkgs <- c("base", "graphics", "stats", "utils", "methods", "grDevices", "tools", "grid", "parallel", "splines", "datasets")
    
    for (g in names(snap_after)) {
      if (g %in% pkg_generics) next
      
      # Skip if generic name is not a function (e.g. implicit generics for packages/namespaces)
      if (!exists(g, mode = "function")) next
      
      # Skip base/system generics (allowed to revert)
      fdef_after <- methods::getGeneric(g)
      if (!is.null(fdef_after) && fdef_after@package %in% base_system_pkgs) next
      
      if (!g %in% names(snap_final)) {
        cat(sprintf("  [!] Dependency generic [%s] was accidentally uncached\\n", g))
        deps_preserved <- FALSE
        next
      }
      
      df_after <- snap_after[[g]]
      tbl_final_names <- snap_final[[g]]
      
      for (i in seq_len(nrow(df_after))) {
        sig <- df_after$sig[i]
        env_name <- df_after$env[i]
        
        if (env_name == pkg) next
        if (env_name %in% base_system_pkgs) next
        
        if (sig %in% tbl_final_names) next
        cat(sprintf("  [!] Dependency method [%s] on generic [%s] was accidentally uncached\\n", sig, g))
        deps_preserved <- FALSE
      }
    }
    
    if (uncache_clean && deps_preserved) {
        cat("PASSED\\n")
    } else if (!uncache_clean) {
        cat("FAILED_UNCACHE\\n")
    } else {
        cat("FAILED_PRESERVATION\\n")
    }
    ')

  # Write R code to a temporary file
  tmp_file <- tempfile("check_pkg_", fileext = ".R")
  writeLines(code, tmp_file)

  # Run child process
  out <- system2(Rcmd, c(tmp_file), 
                 env = c(paste0("R_LIBS=", myLib), "R_DEFAULT_PACKAGES=NULL"),
                 stdout = TRUE, stderr = TRUE)

  unlink(tmp_file)

  # Parse status
  non_empty_out <- trimws(out[out != ""])
  status <- tail(non_empty_out, 1)

  expected_statuses <- c("SKIPPED", "FAILED_LOAD", "FAILED_UNLOAD", "FAILED_UNCACHE", "FAILED_PRESERVATION", "PASSED")
  matched_status <- intersect(status, expected_statuses)

  if (length(matched_status) == 0) {
    for (s in expected_statuses) {
      if (!any(grepl(paste0("^", s, "$"), non_empty_out))) next
      matched_status <- s
      break
    }
  }

  if (length(matched_status) == 0) {
    cat("FAILED_CRASH\n")
    cat("  [-] Child output:\n")
    cat(paste("    >", out), sep = "\n")
    results[[pkg]] <- "FAILED_CRASH"
  } else {
    results[[pkg]] <- matched_status
    cat(matched_status, "\n")
    if (matched_status %in% c("FAILED_PRESERVATION", "FAILED_UNCACHE")) {
      cat("  [-] Diagnostic output:\n")
      cat(paste("    >", out), sep = "\n")
    }
  }
}

# Report Summary
cat("\n=== SUPER-TARGETED S4 UNLOAD SPECIFICITY SUMMARY ===\n")
res_df <- data.frame(Package = names(results), Status = unlist(results))
print(res_df)
write.csv(res_df, "super_targeted_unload_results.csv", row.names = FALSE)

cat("\nSummary of counts:\n")
print(table(res_df$Status))
# nolint end.