Rev 84031 | Blame | Compare with Previous | Last modification | View Log | Download | RSS feed
.R_LIBS <- function(libp = .libPaths()) { # (>> in utils?)libp <- libp[! libp %in% .Library]if(length(libp))paste(libp, collapse = .Platform$path.sep)else "" # character(0) is invalid for Sys.setenv()}.libPaths(tail(.libPaths(), 1), include.site=FALSE) # no extra libraries (w/ many pkgs)\n")Sys.setenv(R_LIBS = .R_LIBS() # for build.pkg() & install.packages(), R_BUILD_ENVIRON = "nothing" # avoid ~/.R/build.environ which might set R_LIBS, R_ENVIRON = "none", R_PROFILE = "none")showProc.time <- local({ ## function + 'pct' variablepct <- proc.time()function(final="\n") { ## CPU elapsed __since last called__ot <- pct ; pct <<- proc.time()cat('Time elapsed: ',format.default(round((pct - ot)[1:3], digits=3), digits=4),final)}})## PR 1271 detach("package:base") crashes R.tools::assertError(detach("package:base"))## invalid 'lib.loc'stopifnot(length(installed.packages("mgcv")) == 0)## gave a low-level error messageshowProc.time()## package.skeleton() with metadata-only code## work in current (= ./tests/ directory):tmp <- tempfile()writeLines(c('setClass("foo", contains="numeric")','setMethod("show", "foo",',' function(object) cat("I am a \\"foo\\"\\n"))'),tmp)if(file.exists("myTst")) unlink("myTst", recursive=TRUE)package.skeleton("myTst", code_files = tmp)# with a file name warningfile.copy(tmp, (tm2 <- paste(tmp,".R", sep="")))unlink("myTst", recursive=TRUE)op <- options(warn=2) # *NO* "invalid file name" warning {failed in 2.7.[01]}:package.skeleton("myTst", code_files = tm2)options(op)##_2_ only a class, no generics/methods:writeLines(c('setClass("DocLink",','representation(name="character",',' desc="character"))'), tmp)if(file.exists("myTst2")) unlink("myTst2", recursive=TRUE)package.skeleton("myTst2", code_files = tmp)##- end_2_ # failed in R 2.11.0stopifnot(1 == grep("setClass",readLines(list.files("myTst/R", full.names=TRUE))),c("foo-class.Rd","show-methods.Rd") %in% list.files("myTst/man"))## failed for several reasons in R < 2.7.0#### Part 2: -- build, install, load and "inspect" the package:build.pkg <- function(dir, destdir = NULL, ignore.stderr = FALSE, no.latex=TRUE) {dir <- normalizePath(dir)if(length(dir) > 1)return(lapply(dir, build.pkg, destdir=destdir,ignore.stderr=ignore.stderr, no.latex=no.latex))## else one 'dir':stopifnot(dir.exists(dir), file.exists(DESC <- file.path(dir, "DESCRIPTION")))pkgName <- sub("^[A-Za-z]+: ", "", grep("^Package: ", readLines(DESC), value=TRUE))patt <- paste(pkgName, ".*tar\\.gz$", sep="_")unlink(dir('.', pattern = patt))Rcmd <- paste(shQuote(file.path(R.home("bin"), "R")), "CMD")r <- system(paste(Rcmd, "build --keep-empty-dirs",if(no.latex) "--no-manual", shQuote(dir)),ignore.stderr=ignore.stderr, intern = TRUE)## return name of tar file built {plus the build log} :tball <- structure(dir('.', pattern = patt), log3 = r)if(is.null(destdir))tballelse {file.copy(tball, destdir)file.path(destdir, basename(tball))}}build.pkg("myTst")## clean up any previous attempt (which might have left a 00LOCK)unlink("myLib", recursive = TRUE)dir.create("myLib")install.packages("myTst", lib = "myLib", repos=NULL, type = "source") # with warningsprint(installed.packages(lib.loc= "myLib", priority= "NA"))## (PR#13332)stopifnot(require("myTst",lib = "myLib"))sm <- findMethods(show, where= as.environment("package:myTst"))stopifnot(sm@names == "foo")unlink("myTst_*")## getPackageName() for "package:foo":require('methods')library(tools)oo <- options(warn=2)detach("package:tools", unload=TRUE)options(oo)## gave warning (-> Error) about creating package name## More building & installing packages## NB: tests were added here for 2.11.0.## NB^2: do not do this in the R sources (but in a build != src directory!)## and this testdir is not installed.if(interactive() && Sys.getenv("USER") == "maechler")Sys.setenv(SRCDIR = normalizePath("~/R/D/r-devel/R/tests"))(pkgSrcPath <- file.path(Sys.getenv("SRCDIR"), "Pkgs"))# e.g., -> "../../R/tests/Pkgs"## SRCDIR not available on windows, so pkgSrcPath won't be populated## if this happens non-interactively, cleanup and quit gracefullyif(!file_test("-d", pkgSrcPath) && !interactive()) {unlink("myTst", recursive=TRUE)showProc.time()q("no")}## else w/o clause:showProc.time()do.cleanup <- !nzchar(Sys.getenv("R_TESTS_NO_CLEAN"))isWIN <- .Platform$OS.type == "windows"has.symlink <- !isWIN## Installing "on to" a package existing as symlink in the lib.loc## -- used to fail with misleading error message (#PR 16725):if(has.symlink && !unlink("myLib_2", recursive=TRUE) && dir.create("myLib_2") &&file.rename("myLib/myTst", "myLib_2/myTst") &&file.symlink("../myLib_2/myTst", "myLib/myTst"))install.packages("myTst", lib = "myLib", repos=NULL, type = "source")## In R <= 3.3.2 gave error with *misleading* error message:## ERROR: ‘myTst’ is not a legal package nameif(isWIN) { # (has no symlinks anyway)file.copy(pkgSrcPath, tempdir(), recursive = TRUE)} else { # above file.copy() not useful as it replaces symlink by copysystem(paste('cp -R', shQuote(pkgSrcPath), shQuote(tempdir())))}pkgPath <- file.path(tempdir(), "Pkgs")if(!dir.exists(pkgPath)) {message("No valid 'pkgPath' (from 'pkgSrcPath') - exit this test")if(!interactive()) q("no")}## pkgB tests an empty R directorydir.create(file.path(pkgPath, "pkgB", "R"), recursive = TRUE,showWarnings = FALSE)## (how can this happen reliably more easily?)##' Copy directory d1 to *(newly created |cleaned)* directory d2 -- also with*in* same directory##' "cp -a d1/ d2/"dirCopy <- function(d1, d2) {stopifnot(exprs = {length(d1) == length(d2) ; length(d1) == 1Ldir.exists(d1)dir.exists(D2 <- dirname(d2)) || dir.create(D2, recursive=TRUE)!dir.exists(d2) || unlink(d2, recursive=TRUE) == 0## unbelievable contortion just so it works within the *same* directory (really ??)## 1. copy to *other dir* :dir.create(tD <- tempfile("dirCp"))file.copy(d1, tD, recursive = TRUE)## 2. correctly "rename" ( i.e., *move*) to "this" dir:file.rename(file.path(tD, basename(d1)),file.path(D2, basename(d2)))})}#### pkgB{2,3} := pkgB but with missing/incomplete 'Imports:' entry in DESCRIPTIONpBp <- file.path(pkgPath, "pkgB")dirCopy(pBp, pB2p <- file.path(pkgPath, "pkgB2"))dirCopy(pBp, pB3p <- file.path(pkgPath, "pkgB3"))if(okB2 <- file.exists(DN <- file.path(pB2p, "DESCRIPTION"))) {Dlns <- readLines(DN); i <- grep("^Imports:", Dlns)## drop 'Imports: ' completely (and replace [Pp]kgB by [Pp]kgB2):writeLines(gsub("kgB", "kgB2", Dlns[-i]), con = DN)}if(okB3 <- file.exists(DN <- file.path(pB3p, "DESCRIPTION"))) {Dlns <- readLines(DN); i <- grep("^Imports:", Dlns)## Only keep the first 'Imports: ' (and replace [Pp]kgB by [Pp]kgB3):Dlns[i] <- sub(",.*", "", Dlns[i])writeLines(gsub("kgB", "kgB3", Dlns), con = DN)}## PR17859.3 := PR17859.2, but with missing '}' in <pkg>/R/f3.3 :pP2 <- file.path(pkgPath, "PR17859.2"); f2nm <- file.path(pP2, "R", "f3.R")pP3 <- file.path(pkgPath, "PR17859.3"); f3nm <- file.path(pP3, "R", "f3.R")dirCopy(pP2, pP3); DN <- "DESCRIPTION" # --> fix up pkg namewriteLines(sub("^(Package: .*)\\.2$", "\\1.3", readLines(file.path(pP2, DN))),file.path(pP3, DN))f3lns <- f2lns <- readLines(f2nm)iBrace <- grep("closing brace", f2lns, fixed=TRUE)(f3lns[iBrace] <- sub("^", "#> ", f2lns[iBrace]))(writeLines(f3lns, f3nm))p.fails <- paste0("PR17859.", 1:3)io859 <- c("--no-help", "--no-test-load", "--no-byte-compile")InstOpts <- list("exSexpr" = "--html")for(p in p.fails) InstOpts <- c(InstOpts, `names<-`(list(io859), p))p.lis <- c(if("Matrix" %in% row.names(installed.packages(.Library)))c("pkgA", "pkgB", if(okB2) "pkgB2", if(okB3) "pkgB3", "pkgC"),"PR17501",p.fails,"exNSS4", "exNSS4nil", "exSexpr")p.lis; (pBlis <- grep("^pkgB", p.lis, value=TRUE))pkgApath <- file.path(pkgPath, "pkgA")if("pkgA" %in% p.lis && !dir.exists(d <- pkgApath)) {# on Windows, 'pkgA' may end up being a text file with a single line# with a note it is meant to be a link to xDir/pkgcat("symlink 'pkgA' does not exist as directory ",d,"; copying it\n", sep='')unlink(d, recursive=TRUE)dir.create(d) # ensure it is a single existing directorypkgdir <- file.path(pkgPath, "xDir", "pkg")file.copy(file.path(pkgdir, list.files(pkgdir)), to = d, recursive=TRUE)## if even the copy failed (NB: pkgB, pkgC depend on pkgA)if(!dir.exists(d)) p.lis <- p.lis[!(p.lis %in% c("pkgA", pBlis, "pkgC"))]}dir2pkg <- function(dir) sub("^pkgC", "PkgC", dir)if(is.na(match("myLib", .lP <- .libPaths()))) {.libPaths(c("myLib", .lP)) # PkgC needs pkgA from there.lP <- .libPaths()}Sys.setenv(R_LIBS = .R_LIBS(.lP)) # for build.pkg() & install.packages()showProc.time()for(p in p.lis) {p. <- dir2pkg(p) # 'p' is sub directory name; 'p.' is package namecat("===--===\nFrom pkgPath sub directory", p, " building package", p., "...\n")pkgP <- file.path(pkgPath, p)r <- build.pkg(pkgP, ignore.stderr = (p != "exSexpr")) # 1-2 secshowProc.time()if(!length(r)) # so some sort of failure, show logcat(attr(r, "log3"), sep = "\n")if(!isTRUE(file.exists(r)))stop("R CMD build failed (no tarball) for package ", p.)if(p %in% pBlis) { ## R CMD check "dependencies"res <- tools:::.check_package_depends(dir=pkgP, force_suggest=FALSE)cat("check_package_depends:\n") ; print(res)if(length(res)) pres <- capture.output(res)switch(p, "pkgB" = stopifnot(length(res) == 0), "pkgB2" = stopifnot(exprs = {length(res) == 1identical(res$missing_namespace_depends, c("methods", "pkgA"))grepl("Namespace dependencies .* DESCRIPTION" , pres[1])}), "pkgB3" = stopifnot(exprs = {length(res) == 1identical(res[[1]], "pkgA")grepl("Namespace dependency .* DESCRIPTION" , pres[1])}))showProc.time()} else if(p %in% p.fails) {## NB: Fail with *parse* errors which are *not* tryCatch-able ==> need to call R## tryCatch(error = identity,## install.packages(r, lib = "myLib", repos=NULL, type = "source",## INSTALL_opts = InstOpts[[p.]])) -> err## cat("tryCatch gave "); dput(err)## stopifnot(inherits(err, "error"))## FIXME: do a bit moretf <- tempfile(paste0("regP-inst_",p))status <- tools:::run_Rcmd(c("INSTALL", r, InstOpts[[p.]]),out=tf, timeout = 10)writeLines(errlns <- readLines(tf))stopifnot(exprs = {status > 0 # see status == 1Llength(iE <- grep("Error in parse(", errlns, fixed=TRUE)) > 0local({parseM1 <- "(syntax error|unexpected symbol)" # may depend on bison versionparseM2 <- "(syntax error|unexpected end of input)" # (ditto)switch(p, "PR17859.1" = grepl(paste0(p, "/R/f2.R:3:[0-9]+: ", parseM1), errlns[iE+1]), "PR17859.2" =, "PR17859.3" = grepl(paste0(p, "/R/f2.R:6:0: ", parseM2), errlns[iE+1]), stop("invalid package p=", p))})})next # pkg in for(...)}## otherwise install the tar file:cat("installing package", p., "using built file", r, "...\n")## "FIXME": want to catch warnings in the "console output" of this,## e.g. exNSS4nil, "S4 exports specified in 'NAMESPACE' but not defined .."install.packages(r, lib = "myLib", repos=NULL, type = "source",INSTALL_opts = InstOpts[[p.]])stopifnot(require(p., lib = "myLib", character.only=TRUE))detach(pos = match(p., sub("^package:","", search())))showProc.time()}cat("\n-------------------end { for(p in p.lis) }----------------------------\n")(res <- installed.packages(lib.loc = "myLib", priority = "NA"))(p.lis <- dir2pkg(setdiff(p.lis, p.fails))) # --> *package* names of installed pkgsstopifnot(exprs = {identical(res[,"Package"], setNames(, sort(c(p.lis, "myTst"))))res[,"LibPath"] == "myLib"})### Specific Tests on our "special" packages: ------------------------------tf <- tempfile("chk_donttest")## why does this not work (not catch stderr)? textConnection("checkTxt", open="w")system.time(status <-tools:::run_Rcmd(c("check", "PR17501_1.0.tar.gz", "--no-manual"),out = tf,## avoid delays/timeouts with a broken network route:env = c("R_REPOSITORIES=NULL"), # (no cyclic dep check)timeout = 50))# see 5--7 sec; Solaris needed > 30stopifnot(exprs = {status == 1 # an ERROR nowis.character(exLines <-readLines(file.path("PR17501.Rcheck", "PR17501-Ex.R"))){ str(exLines); length(exLines) > 20 } # str(): diagnostic in caseis.integer(i <- grep("^R\\.Version\\( *# missing closing paren", exLines))grepl("^## No test", exLines[i-1]){ str(tlines <- readLines(tf)); length(tlines) > 20 }length(iw <- grep("^Warning: parse error", tlines)) == 1(lenN <- length(print(iN <- grep("^[1-9][0-9]:", tlines)))) >= 2iN - iw == seq_len(lenN) # these (3) lines come immediately after 'Warning',## and "related" to the some 'missing .. paren' above:!is.na(ierr <- as.integer(substr(print(tlines[iN[1]]), 1, 2)))8 <= print(ierr - i) & ierr - i <= 14 # see 11}) ## failed in R <= 4.1.1## These used to fail because of the sym.link in pkgAif("pkgA" %in% p.lis && dir.exists(pkgApath)) {cat("undoc(pkgA):\n"); print(uA <- tools::undoc(dir = pkgApath))cat("codoc(pkgA):\n"); print(cA <- tools::codoc(dir = pkgApath))cat("extends(\"classApp\"):\n"); print(ext.cA <- extends("classApp"))stopifnot(exprs = {identical(uA$`code objects`, c("nil", "search"))identical(uA$`data sets`, "nilData")## pkgC's class union is now (after loading pkgC) also visible in the "classApp" subclass## (which gave warning). ==> warning "wrong": somehow it *did* get updated:"numericA" %in% ext.cA})} else message("'pkgA' not available")showProc.time()## - Check conflict message.## - Find objects which are NULL via "::" -- not to be expected often## we have one in our pkgA, but only if Matrix is present.if(dir.exists(file.path("myLib", "pkgA"))) {msgs <- capture.output(require(pkgA, lib="myLib"), type = "message")writeLines(msgs)stopifnot(length(msgs) > 2,length(grep("The following object is masked.*package:base", msgs)) > 0,length(grep("\\bsearch\\b", msgs)) > 0)data(package = "pkgA") # -> nilDatastopifnot(is.null( pkgA:: nil),is.null( pkgA::: nil),is.null( pkgA:: nilData)) # <-## R-devel (pre 3.2.0) wrongly errored for NULL lazy data## ::: does not apply to data sets:tools::assertError(is.null(pkgA:::nilData))} else message("'pkgA' not in 'myLib'")showProc.time()## Check error from invalid logical field in DESCRIPTION:(okA <- ("pkgA" %in% p.lis) && dir.exists(pkgApath) &&file.exists(DN <- file.path(pkgApath, "DESCRIPTION")))if(okA) {Dlns <- readLines(DN); i <- grep("^LazyData:", Dlns)Dlns[i] <- paste0(Dlns[i], ",") ## adding a ","writeLines(Dlns, con = DN)## do not test installation failure in myLib as previous pkgA would be removed## from there (because no.q=TRUE causes do_exit_on_error() to be called twice)## and if getNamespaceInfo("pkgA", "path") no longer exists,## sessionInfo() fails in the "exSexpr" test belowinstEXPR <- quote(tools:::.install_packages(c("--clean", paste0("--library=", tempdir()), pkgApath), no.q = TRUE)) ## ----------------- ----if(interactive()) { ## << "FIXME!" This (sink(.) ..) fails, when run via 'make'.## install.packages() should give "the correct" error but we cannot catch it## One level lower is not much better, needing sink() as capture.output() failsftf <- file(tf <- tempfile("inst_pkg"), open = "wt")sink(ftf); sink(ftf, type = "message")# "message" should be sufficienteval(instEXPR)sink(type="message"); sink()## ; close(ftf); rm(ftf)# end sink()writeLines(paste(" ", msgs <- readLines(tf)))message(err <- grep("^ERROR:", msgs, value=TRUE))stopifnot(exprs = {length(err) > 0grepl("invalid .*LazyData .*DESCRIPTION", err)})} else {message("non-interactive -- tools:::.install_packages(..) : ")try( eval(instEXPR) ) # showing the error message in the *.Rout file}} else message("pkgA/DESCRIPTION not available")showProc.time()## R CMD check should *not* warn about \Sexpr{} built sections in Rd (PR#17479):msg <- capture.output(tools:::.check_package_parseRd(dir=file.path(pkgPath, "exSexpr")))if(length(msg))stop(".check_package_parseRd() gave message\n",msg)## in R <= 3.5.1, gave## "prepare_Rd: foo.Rd:14: Section \\Sexpr is unrecognized and will be dropped"showProc.time()if(dir.exists(file.path("myLib", "exNSS4"))) withAutoprint({require("exNSS4", lib="myLib")validObject(dd <- new("ddiM"))print(is(dd)) # 5 of them ..writeLines(myGmeth <- capture.output(show(exNSS4:::myGenf)))stopifnot(exprs = {is(dd, "mM")inherits(dd, "mM")grepl("showMethods(exNSS4:::myGenf)", myGmeth[length(myGmeth)], fixed=TRUE)})## tests here should *NOT* assume recommended packages,## let alone where they are installedif(dir.exists(file.path(.Library, "Matrix"))) {for(ns in c(rev(p.lis), "Matrix")) unloadNamespace(ns)## Both exNSS4 and Matrix define "atomicVector" *the same*,## but 'exNSS4' has it extended - and hence *both* are registered in cache -> "conflicts"requireNamespace("exNSS4", lib= "myLib")## Found in cache, since there is only one definition.## Might confuse users.stopifnot(isVirtualClass(getClass("atomicVector")))requireNamespace("Matrix", lib= .Library)## Throws an error, because there is ambiguity in the cache,## and the dynamic search will not find anything, since the packages## are not attached.tools::assertCondition(acl <- getClass("atomicVector"))## Once Matrix is attached, we find a unique definition.library(Matrix)stopifnot(isVirtualClass(getClass("atomicVector")))}})showProc.time()## Part 3: repository construction ---------------------------------------------## test tools::write_PACKAGES and tools::update_PACKAGESoldpkgdir <- file.path(tempdir(), "pkgfiles/old")newpkgdir <- file.path(tempdir(), "pkgfiles/new")repodir <- file.path(tempdir(), "pkgrepo")dir.create(oldpkgdir, recursive = TRUE)dir.create(newpkgdir)if(file.exists(repodir))unlink(repodir, recursive = TRUE)dir.create(repodir)ro <- build.pkg(file.path(pkgPath, c("pkgD", "pkgB")), oldpkgdir)rn <- build.pkg(file.path(pkgPath, c("pkgD_2", "pkgD_3")), newpkgdir)unlist(ro)unlist(rn)##' A repo package database in directory 'dir'mkPkgfiles <- function(dir)file.path(dir, c("PACKAGES","PACKAGES.gz","PACKAGES.rds"))##' safe read.dcf()read.safe.dcf <- function(f) if(file.exists(f)) read.dcf(f) # else NULL## this will fail with an error if write_PACKAGES## and update_PACKAGES do not generate the same## PACKAGE file entries, in the same order, with## the same field order.docompare <- function(..., repdir = repodir, strict = TRUE) {Pfiles <- mkPkgfiles(repdir)backupPfiles <- file.path(tempdir(), basename(Pfiles))indfile <- Pfiles[1]## vvvvvvvvvvvvvvvtools::write_PACKAGES(repdir, type = "source", ...)wpres <- read.safe.dcf(indfile) # write_P result## reset the PACKAGES files so that update_PACKAGES thinks any deviations are "new"if(all(file.exists(backupPfiles)))file.copy(backupPfiles, Pfiles, overwrite = TRUE)## vvvvvvvvvvvvvvvtools::update_PACKAGES(repdir, type = "source", strict=strict, ...)upres <- read.safe.dcf(indfile) # update_P resultstopifnot(identical(wpres, upres))}Pfiles <- mkPkgfiles(repodir)backupPfiles <- file.path(tempdir(), basename(Pfiles))if(all(file.exists(backupPfiles)))unlink(backupPfiles)showProc.time()## test write_PACKAGES and update_PACKAGES## on empty dir## IGNORE_RDIFF_BEGINdocompare() ## one warning expected, has a temp path in it so ignore diff## IGNORE_RDIFF_ENDoldpfs <- list.files(oldpkgdir, pattern = "\\.tar\\.gz$", recursive = TRUE, full.names = TRUE)newpfs <- list.files(newpkgdir, pattern = "\\.tar\\.gz$", recursive = TRUE, full.names = TRUE)## generate and backup "original repo state"file.copy(oldpfs, to = repodir)tools::write_PACKAGES(repodir, type = "source")file.copy(Pfiles, backupPfiles, overwrite = TRUE)showProc.time()## test update_PACKAGES with no changedocompare()## all old files gone, new files presentunlink(file.path(repodir, basename(oldpfs)))file.copy(newpfs, to = repodir)docompare()docompare(strict=FALSE)## put old ones backfile.copy(oldpfs, to = repodir)showProc.time()if(isWIN){nrepodir <- normalizePath(repodir)if(grepl("^\\\\", nrepodir)) #\\laptop\whateverrepourl <- paste0("file:", gsub("\\\\", "/", nrepodir))else #C:\whateverrepourl <- paste0("file:///", gsub("\\\\", "/", nrepodir))} elserepourl <- paste0("file://", normalizePath(repodir))## make sure the ordering is right when## old and new entries are mixed in final db####' care: stopifnot(nrow(1) == 2) # does *not* triggercheckMatrix <- function(x, n) stopifnot(is.matrix(x), nrow(x) == n)docompare(latestOnly = TRUE)str(ap <- available.packages(repourl, filters = list()))checkMatrix(ap, 2)docompare(latestOnly = FALSE)str(ap <- available.packages(repourl, filters = list()))checkMatrix(ap, 4)docompare(latestOnly = TRUE, strict = FALSE)str(ap <- available.packages(repourl, filters = list()))checkMatrix(ap, 2)docompare(latestOnly = FALSE, strict = FALSE)str(ap <- available.packages(repourl, filters = list()))checkMatrix(ap, 4)## clean uprmL <- c("myLib", if(has.symlink) "myLib_2", "myTst", "myTst2","PR17501.Rcheck")if(do.cleanup) {for(nm in rmL) unlink(nm, recursive = TRUE)} else {cat("Not cleaning, i.e., keeping ", paste(rmL, collapse=", "), "\n")}showProc.time()## And the final:environment(showProc.time)[["pct"]]