#  File src/library/base/R/library.R
#  Part of the R package, https://www.R-project.org
#
#  Copyright (C) 1995-2019 The R Core Team
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2 of the License, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#
#  A copy of the GNU General Public License is available at
#  https://www.R-project.org/Licenses/

## Usage removed in 3.6.0
## testPlatformEquivalence <-
## function(built, run)
## {
##     ## args are "cpu-vendor-os", but os might be 'linux-gnu'!
##     ## remove vendor field
##     built <- gsub("([^-]*)-([^-]*)-(.*)", "\\1-\\3", built)
##     run <- gsub("([^-]*)-([^-]*)-(.*)", "\\1-\\3", run)
##     ## macOS supports multiple CPUs by using 'universal' binaries
##     if (startsWith(built, "universal-darwin") && nzchar(.Platform$r_arch))
##         built <- sub("^universal", R.version$arch, built)
##     ## allow for small mismatches, e.g. OS version number and i686 vs i586.
##     length(agrep(built, run)) > 0
## }

## If we want this it would be better to factor out the core of checkConflicts.
## searchConflicts <- function(pkg) {
##     vars <- getNamespaceExports(pkg)
##     conflicts <- function(pos) intersect(vars, ls(pos, all = TRUE))
##     val <- Filter(length, sapply(search()[-1], conflicts))
##     if (length(val)) val else NULL
## }

conflictRules <-
    local({
        data <- new.env()
        function(pkg, mask.ok = NULL, exclude = NULL) {
            if ((! missing(mask.ok)) || (! missing(exclude)))
                assign(pkg, list(mask.ok = mask.ok, exclude = exclude),
                       envir = data)
            else
                get0(pkg, envir = data, inherits = FALSE)
        }
    })

library <-
function(package, help, pos = 2, lib.loc = NULL, character.only = FALSE,
         logical.return = FALSE, warn.conflicts,
	 quietly = FALSE, verbose = getOption("verbose"),
         mask.ok, exclude, include.only,
         attach.required = missing(include.only))
{
    conf.ctrl <- getOption("conflicts.policy")
    if (is.character(conf.ctrl))
        conf.ctrl <-
            switch(conf.ctrl,
                   strict = list(error = TRUE, warn = FALSE),
                   depends.ok = list(error = TRUE,
                                     generics.ok = TRUE,
                                     can.mask = c("base", "methods", "utils",
                                                  "grDevices", "graphics",
                                                  "stats"),
                                     depends.ok = TRUE),
                   warning(gettextf("unknown conflict policy: %s",
                                    sQuote(conf.ctrl)),
                           call. = FALSE, domain = NA))
    if (! is.list(conf.ctrl))
        conf.ctrl <- NULL
    stopOnConflict <- isTRUE(conf.ctrl$error)

    if (missing(warn.conflicts))
        warn.conflicts <- if (isFALSE(conf.ctrl$warn)) FALSE else TRUE
    if ((! missing(include.only)) && (! missing(exclude)))
        stop(gettext("only one of 'include.only' and 'exclude' can be used"),
             call. = FALSE, domain = NA)

    testRversion <- function(pkgInfo, pkgname, pkgpath)
    {
        if(is.null(built <- pkgInfo$Built))
            stop(gettextf("package %s has not been installed properly\n",
                          sQuote(pkgname)),
                 call. = FALSE, domain = NA)

        ## which version was this package built under?
        R_version_built_under <- as.numeric_version(built$R)
        if(R_version_built_under < "3.0.0")
            stop(gettextf("package %s was built before R 3.0.0: please re-install it",
                          sQuote(pkgname)), call. = FALSE, domain = NA)

        current <- getRversion()
        ## depends on R version?
        ## as it was installed >= 2.7.0 it will have Rdepends2
        if(length(Rdeps <- pkgInfo$Rdepends2)) {
            for(dep in Rdeps)
                if(length(dep) > 1L) {
                    target <- dep$version
                    res <-
                        do.call(dep$op,
                           if(is.character(target)) # these are both strings
                               list(as.numeric(R.version[["svn rev"]]),
                                    as.numeric(sub("^r", "", target)))
                           else
                               list(current, as.numeric_version(target)))
                    if(!res)
                        stop(gettextf("This is R %s, package %s needs %s %s",
                                      current, sQuote(pkgname), dep$op, target),
                             call. = FALSE, domain = NA)
                }
        }
        ## warn if installed under a later version of R
        if(R_version_built_under > current)
            warning(gettextf("package %s was built under R version %s",
                             sQuote(pkgname), as.character(built$R)),
                    call. = FALSE, domain = NA)
        platform <- built$Platform
        r_arch <- .Platform$r_arch
        if(.Platform$OS.type == "unix") {
            ## allow mismatches if r_arch is in use, e.g.
            ## i386-gnu-linux vs x86-gnu-linux depending on
            ## build system.
##             if(!nzchar(r_arch) && grepl("\\w", platform) &&
##                !testPlatformEquivalence(platform, R.version$platform))
##                 stop(gettextf("package %s was built for %s",
##                               sQuote(pkgname), platform),
##                      call. = FALSE, domain = NA)
        } else {  # Windows
            ## a check for 'mingw' suffices, since i386 and x86_64
            ## have DLLs in different places.  This allows binary packages
            ## to be merged.
            if(nzchar(platform) && !grepl("mingw", platform))
                stop(gettextf("package %s was built for %s",
                              sQuote(pkgname), platform),
                     call. = FALSE, domain = NA)
        }
        ## if using r_arch subdirs, check for presence
        if(nzchar(r_arch)
           && file.exists(file.path(pkgpath, "libs"))
           && !file.exists(file.path(pkgpath, "libs", r_arch)))
            stop(gettextf("package %s is not installed for 'arch = %s'",
                          sQuote(pkgname), r_arch),
                 call. = FALSE, domain = NA)
    }

    checkNoGenerics <- function(env, pkg)
    {
        nenv <- env
        ns <- .getNamespace(as.name(pkg))
        if(!is.null(ns)) nenv <- asNamespace(ns)
        if (exists(".noGenerics", envir = nenv, inherits = FALSE))
            TRUE
        else {
            ## A package will have created a generic
            ## only if it has created a formal method.
	    !any(startsWith(names(env), ".__T"))
        }
    }

    ## NB: ./attach.R 's attach() has similar checkConflicts() [simpler at the end], keep in sync!
    checkConflicts <- function(package, pkgname, pkgpath, nogenerics, env)
    {
        dont.mind <- c("last.dump", "last.warning", ".Last.value",
                       ".Random.seed", ".Last.lib", ".onDetach",
                       ".packageName", ".noGenerics", ".required",
                       ".no_S3_generics", ".Depends", ".requireCachedGenerics")
        sp <- search()
        lib.pos <- which(sp == pkgname)
        ## ignore generics not defined for the package
        ob <- names(as.environment(lib.pos))
        if(!nogenerics) {
            ##  Exclude generics that are consistent with implicit generic
            ## from another package.  A better test would be to move this
            ## down into the loop and test against specific other package name
            ## but subtle conflicts like that are likely to be found elsewhere
	    these <- ob[startsWith(ob,".__T__")]
            gen  <- gsub(".__T__(.*):([^:]+)", "\\1", these)
            from <- gsub(".__T__(.*):([^:]+)", "\\2", these)
            gen <- gen[from != package]
            ob <- ob[!(ob %in% gen)]
        }

	ipos <- seq_along(sp)[-c(lib.pos, match(c("Autoloads", "CheckExEnv"), sp, 0L))]
        cpos <- NULL
        conflicts <- vector("list", 0)
        for (i in ipos) {
            obj.same <- match(names(as.environment(i)), ob, nomatch = 0L)
            if (any(obj.same > 0L)) {
                same <- ob[obj.same]
                same <- same[!(same %in% dont.mind)]
                Classobjs <- which(startsWith(same,".__"))
                if(length(Classobjs)) same <- same[-Classobjs]
                ## report only objects which are both functions or
                ## both non-functions.
		same.isFn <- function(where)
		    vapply(same, exists, NA,
                           where = where, mode = "function", inherits = FALSE)
		same <- same[same.isFn(i) == same.isFn(lib.pos)]
		## if a package imports and re-exports, there's no problem
		not.Ident <- function(ch, TRAFO=identity, ...)
		    vapply(ch, function(.)
                           !identical(TRAFO(get(., i)),
                                      TRAFO(get(., lib.pos)), ...),
                           NA)
		if(length(same)) same <- same[not.Ident(same)]
		## if the package is 'base' it cannot be imported and re-exported,
		## allow a "copy":
		if(length(same) && identical(sp[i], "package:base"))
		    same <- same[not.Ident(same, ignore.environment = TRUE)]
                if(length(same)) {
                    conflicts[[sp[i]]] <- same
                    cpos[sp[i]] <- i
                }
            }
        }
        if (length(conflicts)) {
            if (stopOnConflict) {
                emsg <- ""
                pkg <- names(conflicts)
                notOK <- vector("list", 0)
                for (i in seq_along(conflicts)) {
                    pkgname <- sub("^package:", "", pkg[i])
                    if (pkgname %in% canMaskEnv$canMask)
                        next
                    same <- conflicts[[i]]
                    if (is.list(mask.ok))
                        myMaskOK <- mask.ok[[pkgname]]
                    else myMaskOK <- mask.ok

                    ## adjust 'same' for conflict resolution specifications
                    if (isTRUE(myMaskOK))
                        same <- NULL
                    else if (is.character(myMaskOK))
                        same <- setdiff(same, myMaskOK)

                    if (length(same)) {
                        notOK[[pkg[i]]] <- same
                        msg <- .maskedMsg(sort(same), pkg = sQuote(pkg[i]),
                                          by = cpos[i] < lib.pos)
                        emsg <- paste(emsg, msg, sep = "\n")
                    }
                }
                if (length(notOK)) {
                    msg <- gettextf("Conflicts attaching package %s:\n%s",
                                    sQuote(package),
                                    emsg)
                    stop(errorCondition(msg,
                                        package = package,
                                        conflicts = conflicts,
                                        class = "packageConflictError"))
                }
            }
            if (warn.conflicts) {
                ## Use separate messages to preserve previous behavior.
                packageStartupMessage(gettextf("\nAttaching package: %s\n",
                                               sQuote(package)), domain = NA)
                pkg <- names(conflicts)
                for (i in seq_along(conflicts)) {
                    msg <- .maskedMsg(sort(conflicts[[i]]),
                                      pkg = sQuote(pkg[i]),
                                      by = cpos[i] < lib.pos)
                    packageStartupMessage(msg, domain = NA)
                }
            }
        }
    }

    if(verbose && quietly)
	message("'verbose' and 'quietly' are both true; being verbose then ..")
    if(!missing(package)) {
        if (is.null(lib.loc)) lib.loc <- .libPaths()
        ## remove any non-existent directories
        lib.loc <- lib.loc[dir.exists(lib.loc)]

	if(!character.only)
	    package <- as.character(substitute(package))
        if(length(package) != 1L)
            stop("'package' must be of length 1")
        if(is.na(package) || (package == ""))
            stop("invalid package name")

	pkgname <- paste0("package:", package)
	newpackage <- is.na(match(pkgname, search()))
	if(newpackage) {
            ## Check for the methods package before attaching this
            ## package.
            ## Only if it is _already_ here do we do cacheMetaData.
            ## The methods package caches all other pkgs when it is
            ## attached.

            ## Too extreme (unfortunately; warning too often):
	    ## pkgpath <- find.package(package, lib.loc, quiet = TRUE, verbose = !quietly)
	    ##   'verbose' here means to warn about packages found more than once
	    pkgpath <- find.package(package, lib.loc, quiet = TRUE,
                                    verbose = verbose)
            if(length(pkgpath) == 0L) {
                if(length(lib.loc) && !logical.return)
                    stop(packageNotFoundError(package, lib.loc, sys.call()))
                txt <- if(length(lib.loc))
                    gettextf("there is no package called %s", sQuote(package))
                else
                    gettext("no library trees found in 'lib.loc'")
                if(logical.return) {
                    warning(txt, domain = NA)
		    return(FALSE)
		} else stop(txt, domain = NA)
            }
            which.lib.loc <- normalizePath(dirname(pkgpath), "/", TRUE)
            pfile <- system.file("Meta", "package.rds", package = package,
                                 lib.loc = which.lib.loc)
            if(!nzchar(pfile))
            	stop(gettextf("%s is not a valid installed package",
                              sQuote(package)), domain = NA)
            pkgInfo <- readRDS(pfile)
            testRversion(pkgInfo, package, pkgpath)

            ## The ABI compatibility check is now in loadNamespace
            ## The licence check is now in loadNamespace
            ## The check for inconsistent naming is now in find.package

            if(is.character(pos)) {
                npos <- match(pos, search())
                if(is.na(npos)) {
                    warning(gettextf("%s not found on search path, using pos = 2",
                                     sQuote(pos)), domain = NA)
                    pos <- 2
                } else pos <- npos
            }

            deps <- unique(names(pkgInfo$Depends))
            depsOK <- isTRUE(conf.ctrl$depends.ok)
            if (depsOK) {
                canMaskEnv <- dynGet("__library_can_mask__", NULL)
                if (is.null(canMaskEnv)) {
                    canMaskEnv <- new.env()
                    canMaskEnv$canMask <- union("base", conf.ctrl$can.mask)
                    "__library_can_mask__" <- canMaskEnv
                }
                canMaskEnv$canMask <- unique(c(package, deps,
                                               canMaskEnv$canMask))
            }
            else canMaskEnv <- NULL

            if (attach.required)
                .getRequiredPackages2(pkgInfo, quietly = quietly)

            cr <- conflictRules(package)
            if (missing(mask.ok))
                mask.ok <- cr$mask.ok
            if (missing(exclude))
                exclude <- cr$exclude

            ## If the namespace mechanism is available and the package
            ## has a namespace, then the namespace loading mechanism
            ## takes over.
            if (packageHasNamespace(package, which.lib.loc)) {
		if (isNamespaceLoaded(package)) {
                    ## Already loaded.  Does the version match?
                    newversion <- as.numeric_version(pkgInfo$DESCRIPTION["Version"])
                    oldversion <- as.numeric_version(getNamespaceVersion(package))
                    if (newversion != oldversion) {
                    	## No, so try to unload the previous one
			tryCatch(unloadNamespace(package),
				 error = function(e) {
				     P <- if(!is.null(cc <- conditionCall(e)))
					      paste("Error in", deparse(cc)[1L], ": ")
					  else "Error : "
				     stop(gettextf("Package %s version %s cannot be unloaded:\n %s",
						   sQuote(package), oldversion,
						   paste0(P, conditionMessage(e),"\n")),
					  domain=NA)})
                    }
                }
		tt <- tryCatch({
                    attr(package, "LibPath") <- which.lib.loc
                    ns <- loadNamespace(package, lib.loc)
                    env <- attachNamespace(ns, pos = pos, deps,
                                           exclude, include.only)
		}, error = function(e) {
		    P <- if(!is.null(cc <- conditionCall(e)))
			     paste(" in", deparse(cc)[1L]) else ""
		    msg <- gettextf("package or namespace load failed for %s%s:\n %s",
				    sQuote(package), P, conditionMessage(e))
		    if(logical.return)
			message(paste("Error:", msg), domain = NA) # returns NULL
		    else stop(msg, call. = FALSE, domain = NA)
		})
		if(logical.return && is.null(tt))
		    return(FALSE)

                attr(package, "LibPath") <- NULL
                {
                    on.exit(detach(pos = pos))
                    ## If there are S4 generics then the package should
                    ## depend on methods
                    nogenerics <-
                        !.isMethodsDispatchOn() || checkNoGenerics(env, package)
                    if (isFALSE(conf.ctrl$generics.ok) ||
                        (stopOnConflict && ! isTRUE(conf.ctrl$generics.ok)))
                        nogenerics <- TRUE ## no silent masking for genrics
                    if(stopOnConflict ||
                       (warn.conflicts && # never will with a namespace
                        !exists(".conflicts.OK", envir = env,
                                inherits = FALSE)))
                        checkConflicts(package, pkgname, pkgpath,
                                       nogenerics, ns)
                    on.exit()
                    if (logical.return)
                        return(TRUE)
                    else
                        return(invisible(.packages()))
                }
            } else
		stop(gettextf("package %s does not have a namespace and should be re-installed",
			      sQuote(package)), domain = NA)
	}
	if (verbose && !newpackage)
            warning(gettextf("package %s already present in search()",
                             sQuote(package)), domain = NA)

    }
    else if(!missing(help)) {
	if(!character.only)
	    help <- as.character(substitute(help))
        pkgName <- help[1L]            # only give help on one package
        pkgPath <- find.package(pkgName, lib.loc, verbose = verbose)
        docFiles <- c(file.path(pkgPath, "Meta", "package.rds"),
                      file.path(pkgPath, "INDEX"))
        if(file.exists(vignetteIndexRDS <-
                       file.path(pkgPath, "Meta", "vignette.rds")))
            docFiles <- c(docFiles, vignetteIndexRDS)
        pkgInfo <- vector("list", 3L)
        readDocFile <- function(f) {
            if(basename(f) %in% "package.rds") {
                txt <- readRDS(f)$DESCRIPTION
                if("Encoding" %in% names(txt)) {
                    to <- if(Sys.getlocale("LC_CTYPE") == "C") "ASCII//TRANSLIT"else ""
                    tmp <- try(iconv(txt, from=txt["Encoding"], to=to))
                    if(!inherits(tmp, "try-error"))
                        txt <- tmp
                    else
                        warning("'DESCRIPTION' has an 'Encoding' field and re-encoding is not possible",
                                call. = FALSE)
                }
                nm <- paste0(names(txt), ":")
                ## indent might be excessive for long field names.
                formatDL(nm, txt, indent = max(nchar(nm, "w")) + 3L)
            } else if(basename(f) %in% "vignette.rds") {
                txt <- readRDS(f)
                ## New-style vignette indices are data frames with more
                ## info than just the base name of the PDF file and the
                ## title.  For such an index, we give the names of the
                ## vignettes, their titles, and indicate whether PDFs
                ## are available.
                ## The index might have zero rows.
                if(is.data.frame(txt) && nrow(txt))
                    cbind(basename(gsub("\\.[[:alpha:]]+$", "",
                                        txt$File)),
                          paste(txt$Title,
                                paste0(rep.int("(source", NROW(txt)),
                                       ifelse(nzchar(txt$PDF),
                                              ", pdf",
                                              ""),
                                       ")")))
                else NULL
            } else
            readLines(f)
        }
        for(i in which(file.exists(docFiles)))
            pkgInfo[[i]] <- readDocFile(docFiles[i])
        y <- list(name = pkgName, path = pkgPath, info = pkgInfo)
        class(y) <- "packageInfo"
        return(y)
    }
    else {
	## library():
        if(is.null(lib.loc))
            lib.loc <- .libPaths()
        db <- matrix(character(), nrow = 0L, ncol = 3L)
        nopkgs <- character()

        for(lib in lib.loc) {
            a <- .packages(all.available = TRUE, lib.loc = lib)
            for(i in sort(a)) {
                ## All packages installed under 2.0.0 should have
                ## 'package.rds' but we have not checked.
                file <- system.file("Meta", "package.rds", package = i,
                                    lib.loc = lib)
                title <- if(nzchar(file)) {
                    txt <- readRDS(file)
                    if(is.list(txt)) txt <- txt$DESCRIPTION
                    ## we may need to re-encode here.
                    if("Encoding" %in% names(txt)) {
                        to <- if(Sys.getlocale("LC_CTYPE") == "C") "ASCII//TRANSLIT" else ""
                        tmp <- try(iconv(txt, txt["Encoding"], to, "?"))
                        if(!inherits(tmp, "try-error"))
                            txt <- tmp
                        else
                            warning("'DESCRIPTION' has an 'Encoding' field and re-encoding is not possible", call.=FALSE)
                    }
                    txt["Title"]
                } else NA
                if(is.na(title))
                    title <- " ** No title available ** "
                db <- rbind(db, cbind(i, lib, title))
            }
            if(length(a) == 0L)
                nopkgs <- c(nopkgs, lib)
        }
        dimnames(db) <- list(NULL, c("Package", "LibPath", "Title"))
        if(length(nopkgs) && !missing(lib.loc)) {
            pkglist <- paste(sQuote(nopkgs), collapse = ", ")
            msg <- sprintf(ngettext(length(nopkgs),
                                    "library %s contains no packages",
                                    "libraries %s contain no packages"),
                           pkglist)
            warning(msg, domain=NA)
        }

        y <- list(header = NULL, results = db, footer = NULL)
        class(y) <- "libraryIQR"
        return(y)
    }

    if (logical.return)
	TRUE
    else invisible(.packages())
} ## {library}

format.libraryIQR <-
function(x, ...)
{
    db <- x$results
    if(!nrow(db)) return(character())
    ## Split according to LibPath, preserving order of libraries.
    libs <- db[, "LibPath"]
    libs <- factor(libs, levels = unique(libs))
    out <- lapply(split(1 : nrow(db), libs),
                  function(ind) db[ind, c("Package", "Title"),
                                   drop = FALSE])
    c(unlist(Map(function(lib, sep) {
        c(gettextf("%sPackages in library %s:\n", sep, sQuote(lib)),
          formatDL(out[[lib]][, "Package"],
                   out[[lib]][, "Title"]))
    },
                 names(out),
                 c("", rep.int("\n", length(out) - 1L)))),
      x$footer)
}

print.libraryIQR <-
function(x, ...)
{
    s <- format(x)
    if(!length(s)) {
        message("no packages found")
    } else {
        outFile <- tempfile("RlibraryIQR")
        writeLines(s, outFile)
        file.show(outFile, delete.file = TRUE,
                  title = gettext("R packages available"))
    }
    invisible(x)
}

library.dynam <-
function(chname, package, lib.loc, verbose = getOption("verbose"),
         file.ext = .Platform$dynlib.ext, ...)
{
    dll_list <- .dynLibs()

    if(missing(chname) || !nzchar(chname)) return(dll_list)

    ## For better error messages, force these to be evaluated.
    package
    lib.loc

    r_arch <- .Platform$r_arch
    chname1 <- paste0(chname, file.ext)
    ## it is not clear we should allow this, rather require a single
    ## package and library.
    for(pkg in find.package(package, lib.loc, verbose = verbose)) {
        DLLpath <- if(nzchar(r_arch)) file.path(pkg, "libs", r_arch)
	else    file.path(pkg, "libs")
        file <- file.path(DLLpath, chname1)
        if(file.exists(file)) break else file <- ""
    }
    if(file == "")
        if(.Platform$OS.type == "windows")
            stop(gettextf("DLL %s not found: maybe not installed for this architecture?", sQuote(chname)), domain = NA)
        else
            stop(gettextf("shared object %s not found", sQuote(chname1)),
                 domain = NA)
    ## for consistency with library.dyn.unload:
    file <- file.path(normalizePath(DLLpath, "/", TRUE), chname1)
    ind <- vapply(dll_list, function(x) x[["path"]] == file, NA)
    if(length(ind) && any(ind)) {
        if(verbose)
            if(.Platform$OS.type == "windows")
                message(gettextf("DLL %s already loaded", sQuote(chname1)),
                        domain = NA)
            else
                message(gettextf("shared object '%s' already loaded",
                                 sQuote(chname1)), domain = NA)
        return(invisible(dll_list[[ seq_along(dll_list)[ind] ]]))
    }
    if(.Platform$OS.type == "windows") {
        ## Make it possible to find other DLLs in the same place as
        ## @code{file}, so that e.g. binary packages can conveniently
        ## provide possibly missing DLL dependencies in this place
        ## (without having to bypass the default package dynload
        ## mechanism).  Note that this only works under Windows, and a
        ## more general solution will have to be found eventually.
        ##
        ## 2.7.0: there's a more general mechanism in DLLpath=,
        ## so not clear if this is still needed.
        PATH <- Sys.getenv("PATH")
        Sys.setenv(PATH = paste(gsub("/", "\\\\", DLLpath), PATH, sep=";"))
        on.exit(Sys.setenv(PATH = PATH))
    }
    if(verbose)
        message(gettextf("now dyn.load(\"%s\") ...", file), domain = NA)
    dll <- if("DLLpath" %in% names(list(...))) dyn.load(file, ...)
    else dyn.load(file, DLLpath = DLLpath, ...)
    .dynLibs(c(dll_list, list(dll)))
    invisible(dll)
}

library.dynam.unload <-
function(chname, libpath, verbose = getOption("verbose"),
         file.ext = .Platform$dynlib.ext)
{
    dll_list <- .dynLibs()

    if(missing(chname) || nchar(chname, "c") == 0L)
        if(.Platform$OS.type == "windows")
            stop("no DLL was specified")
        else
            stop("no shared object was specified")

    ## We need an absolute path here, and separators consistent with
    ## library.dynam
    libpath <- normalizePath(libpath, "/", TRUE)
    chname1 <- paste0(chname, file.ext)
    file <- if(nzchar(.Platform$r_arch))
             file.path(libpath, "libs", .Platform$r_arch, chname1)
     else    file.path(libpath, "libs", chname1)

    pos <- which(vapply(dll_list, function(x) x[["path"]] == file, NA))
    if(!length(pos))
        if(.Platform$OS.type == "windows")
            stop(gettextf("DLL %s was not loaded", sQuote(chname1)),
                 domain = NA)
        else
            stop(gettextf("shared object %s was not loaded", sQuote(chname1)),
                 domain = NA)

    if(!file.exists(file))
        if(.Platform$OS.type == "windows")
            stop(gettextf("DLL %s not found", sQuote(chname1)), domain = NA)
        else
            stop(gettextf("shared object '%s' not found", sQuote(chname1)),
                 domain = NA)
    if(verbose)
        message(gettextf("now dyn.unload(\"%s\") ...", file), domain = NA)
    dyn.unload(file)
    .dynLibs(dll_list[-pos])
    invisible(dll_list[[pos]])
}

require <-
function(package, lib.loc = NULL, quietly = FALSE, warn.conflicts,
         character.only = FALSE, mask.ok, exclude, include.only,
         attach.required = missing(include.only))
{
    if(!character.only)
        package <- as.character(substitute(package)) # allowing "require(eda)"
    loaded <- paste0("package:", package) %in% search()

    if (!loaded) {
	if (!quietly)
            packageStartupMessage(gettextf("Loading required package: %s",
                                           package), domain = NA)
	value <- tryCatch(library(package, lib.loc = lib.loc,
                                  character.only = TRUE,
                                  logical.return = TRUE,
                                  warn.conflicts = warn.conflicts,
				  quietly = quietly,
                                  mask.ok = mask.ok,
                                  exclude = exclude,
                                  include.only = include.only,
                                  attach.required = attach.required),
                          error = function(e) e)
        if (inherits(value, "error")) {
            if (!quietly) {
                msg <- conditionMessage(value)
                cat("Failed with error:  ",
                    sQuote(msg), "\n", file = stderr(), sep = "")
                .Internal(printDeferredWarnings())
            }
            return(invisible(FALSE))
        }
        if (!value) return(invisible(FALSE))
    } else value <- TRUE
    invisible(value)
}

.packages <-
function(all.available = FALSE, lib.loc = NULL)
{
    if(is.null(lib.loc))
        lib.loc <- .libPaths()
    if(all.available) {
	ans <- character()
        for(lib in lib.loc[file.exists(lib.loc)]) {
            a <- list.files(lib, all.files = FALSE, full.names = FALSE)
            pfile <- file.path(lib, a, "Meta", "package.rds")
            ans <- c(ans, a[file.exists(pfile)])
        }
        return(unique(ans))
    } ## else
    s <- search()
    invisible(.rmpkg(s[startsWith(s, "package:")]))
}

path.package <-
function(package = NULL, quiet = FALSE)
{
    if(is.null(package)) package <- .packages()
    if(length(package) == 0L) return(character())
    s <- search()
    searchpaths <-
        lapply(seq_along(s), function(i) attr(as.environment(i), "path"))
    searchpaths[[length(s)]] <- system.file()
    pkgs <- paste0("package:", package)
    pos <- match(pkgs, s)
    if(any(m <- is.na(pos))) {
        if(!quiet) {
            if(all(m))
                stop("none of the packages are loaded")
            else
                warning(sprintf(ngettext(as.integer(sum(m)),
                                         "package %s is not loaded",
                                         "packages %s are not loaded"),
                                paste(package[m], collapse=", ")),
                        domain = NA)
        }
        pos <- pos[!m]
    }
    unlist(searchpaths[pos], use.names = FALSE)
}

## As from 2.9.0 ignore versioned installs
find.package <-
function(package = NULL, lib.loc = NULL, quiet = FALSE,
         verbose = getOption("verbose"))
{
    if(is.null(package) && is.null(lib.loc) && !verbose) {
        ## We only want the paths to the attached packages.
        return(path.package())
    }

    ## don't waste time looking for the standard packages:
    ## we know where they are and this can take a significant
    ## time with 1000+ packages installed.
    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)
        }
        ## trapdoor for tools:::setRlibs
        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) {
                ## Note that this is sometimes used for source
                ## packages, e.g. by promptPackage from package.skeleton
                pfile <- file.path(p, "Meta", "package.rds")
                info <- if(file.exists(pfile))
                    ## this must have these fields to get installed
                    readRDS(pfile)$DESCRIPTION[c("Package", "Version")]
                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, Version = NA) # need dimnames below
                    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 a package was found more than once ...
	    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, sys.call()))
        for(pkg in bad)
            warning(gettextf("there is no package called %s", sQuote(pkg)),
                    domain = NA)
    }

    out
}

packageNotFoundError <-
function(package, lib.loc, call = NULL) {
    if(length(package) == 1L)
        msg <- gettextf("there is no package called %s", sQuote(package))
    else
        msg <- paste0(ngettext(length(package),
                               "there is no package called",
                               "there are no packages called"), " ",
                      paste(sQuote(package), collapse = ", "))
    errorCondition(msg, package = package, lib.loc = lib.loc, call = call,
                   class = "packageNotFoundError")
}

format.packageInfo <-
function(x, ...)
{
    if(!inherits(x, "packageInfo")) stop("wrong class")
    vignetteMsg <-
        gettextf("Further information is available in the following vignettes in directory %s:",
                 sQuote(file.path(x$path, "doc")))
    headers <- sprintf("\n%s\n",
                       c(gettext("Description:"),
                         gettext("Index:"),
                         paste(strwrap(vignetteMsg), collapse = "\n")))
    formatDocEntry <- function(entry) {
        if(is.list(entry) || is.matrix(entry))
            formatDL(entry, style = "list")
        else
            entry
    }
    c(gettextf("\n\t\tInformation on package %s", sQuote(x$name)),
      unlist(lapply(which(!vapply(x$info, is.null, NA)),
                    function(i)
                        c(headers[i], formatDocEntry(x$info[[i]])))))

}

print.packageInfo <-
function(x, ...)
{
    outFile <- tempfile("RpackageInfo")
    writeLines(format(x), outFile)
    file.show(outFile, delete.file = TRUE,
              title =
              gettextf("Documentation for package %s", sQuote(x$name)))
    invisible(x)
}

.getRequiredPackages <-
function(file="DESCRIPTION", lib.loc = NULL, quietly = FALSE, useImports = FALSE)
{
    ## OK to call tools as only used during installation.
    pkgInfo <- tools:::.split_description(tools:::.read_description(file))
    .getRequiredPackages2(pkgInfo, quietly, lib.loc, useImports)
    invisible()
}

.getRequiredPackages2 <-
function(pkgInfo, quietly = FALSE, lib.loc = NULL, useImports = FALSE)
{
### FIXME: utils::packageVersion() should be pushed up here instead
    .findVersion <- function(pkg, lib.loc) {
        pfile <- system.file("Meta", "package.rds",
                             package = pkg, lib.loc = lib.loc)
        if (nzchar(pfile))
            as.numeric_version(readRDS(pfile)$DESCRIPTION["Version"])
        ## else NULL
    }
    pkgs <- unique(names(pkgInfo$Depends))
    pkgname <- pkgInfo$DESCRIPTION["Package"]
    for(pkg in setdiff(pkgs, "base")) {
        ## allow for multiple occurrences
        depends <- pkgInfo$Depends[names(pkgInfo$Depends) == pkg]
        attached <- paste0("package:", pkg) %in% search()
        current <- .findVersion(pkg, lib.loc)
        if(is.null(current))
            stop(gettextf("package %s required by %s could not be found",
                          sQuote(pkg), sQuote(pkgname)),
                 call. = FALSE, domain = NA)
        have_vers <- lengths(depends) > 1L
        for(dep in depends[have_vers]) {
            target <- as.numeric_version(dep$version)
            sufficient <- do.call(dep$op, list(current, target))
            if (!sufficient) {
                if (is.null(lib.loc))
                    lib.loc <- .libPaths()
		allV <- lapply(lib.loc, .findVersion, pkg=pkg)
		versions <- do.call(c, allV[iV <- which(!vapply(allV, is.null, NA))])
                sufficient <- vapply(versions, dep$op, logical(1L), target)
                if (any(sufficient)) {
                    warning(gettextf("version %s of %s masked by %s in %s",
                                     versions[which(sufficient)[1L]],
                                     sQuote(pkg),
                                     current,
				     lib.loc[iV[!sufficient][1L]]),
                            call. = FALSE, domain = NA)
                }
		msg <- if (attached)
			   "package %s %s is loaded, but %s %s is required by %s"
		       else
			   "package %s %s was found, but %s %s is required by %s"
                stop(gettextf(msg, sQuote(pkg), current, dep$op,
                              target, sQuote(pkgname)),
                     call. = FALSE, domain = NA)
            }
        }

        if (!attached) {
            if (!quietly)
                packageStartupMessage(gettextf("Loading required package: %s",
                                               pkg), domain = NA)
            library(pkg, character.only = TRUE, logical.return = TRUE,
                    lib.loc = lib.loc, quietly = quietly) ||
                stop(gettextf("package %s could not be loaded", sQuote(pkg)),
                     call. = FALSE, domain = NA)
        }
    }
    if(useImports) {
        nss <- names(pkgInfo$Imports)
        for(ns in nss) loadNamespace(ns, lib.loc)
    }
}

.expand_R_libs_env_var <-
function(x)
{
    v <- paste(R.version[c("major", "minor")], collapse = ".")

    expand <- function(x, spec, expansion)
        gsub(paste0("(^|[^%])(%%)*%", spec),
             sprintf("\\1\\2%s", expansion), x)

    ## %V => version x.y.z
    x <- expand(x, "V", v)
    ## %v => version x.y
    x <- expand(x, "v", sub("\\.[^.]*$", "", v))
    ## %p => platform
    x <- expand(x, "p", R.version$platform)
    ## %a => arch
    x <- expand(x, "a", R.version$arch)
    ## %o => os
    x <- expand(x, "o", R.version$os)

    gsub("%%", "%", x, fixed=TRUE)
}
