library <-
function(package, help, pos = 2, lib.loc = NULL, character.only = FALSE,
         logical.return = FALSE, warn.conflicts = TRUE,
         keep.source = getOption("keep.source.pkgs"),
         verbose = getOption("verbose"), version)
{
    testRversion <- function(fields)
    {
        current <- paste(R.version[c("major", "minor")], collapse = ".")
        ## depends on R version?
        if(!package.dependencies(fields, check = TRUE)) {
            dep <- package.dependencies(fields)[[1]]
            o <- match("R", dep[, 1])
            stop(paste("This is R ", current, ", package ",
                       fields[1, "Package"],
                       " needs ", dep[o, 2], " ", dep[o, 3], sep=""),
                 call. = FALSE)
        }
        ## which version was this package built under?
        if(!is.na(built <- fields[1, "Built"])) {
            builtFields <- strsplit(built, ";", fixed=TRUE)[[1]]
            builtunder <- substring(builtFields[1], 3)
            if(nchar(builtunder) &&
               compareVersion(current, builtunder) < 0) {
                warning(paste("package", fields[1, "Package"],
                              "was built under R version", builtunder),
                        call. = FALSE)
            }
            if(.Platform$OS.type == "unix") {
                platform <- builtFields[2]
                if(length(grep("\\w", platform))) {
                    ## allow for small mismatches, e.g. OS version number.
                    m <- agrep(platform, R.version$platform)
                    if(!length(m))
                        stop(paste("package", fields[1, "Package"],
                                   "was built for", platform),
                             call. = FALSE)
		}
            }
        }
        else
            stop(paste("This package has not been installed properly\n",
                       "See the Note in ?library"))
    }

    checkNoGenerics <- function(env, pkg)
    {
        nenv <- env
        ns <- .Internal(getRegisteredNamespace(as.name(libraryPkgName(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.
            length(objects(env, pattern="^\\.__M", all=TRUE)) == 0
        }
    }

    checkConflicts <- function(package, pkgname, pkgpath, nogenerics)
    {
        dont.mind <- c("last.dump", "last.warning", ".Last.value",
                       ".Random.seed", ".First.lib", ".Last.lib",
                       ".packageName", ".noGenerics", ".required")
        sp <- search()
        lib.pos <- match(pkgname, sp)
        ## ignore generics not defined for the package
        ob <- objects(lib.pos, all = TRUE)
        if(!nogenerics && .isMethodsDispatchOn()) {
            these <- objects(lib.pos, all = TRUE)
            these <- these[substr(these, 1, 6) == ".__M__"]
            gen <- gsub(".__M__(.*):([^:]+)", "\\1", these)
            from <- gsub(".__M__(.*):([^:]+)", "\\2", these)
            gen <- gen[from != ".GlobalEnv"]
            ob <- ob[!(ob %in% gen)]
        }
        fst <- TRUE
        ipos <- seq(along = sp)[-c(lib.pos, match("Autoloads", sp))]
        for (i in ipos) {
            obj.same <- match(objects(i, all = TRUE), ob, nomatch = 0)
            if (any(obj.same > 0)) {
                same <- ob[obj.same]
                same <- same[!(same %in% dont.mind)]
                Classobjs <- grep("^\\.__", same)
                if(length(Classobjs)) same <- same[-Classobjs]
                if(length(same)) {
                    if (fst) {
                        fst <- FALSE
                        cat("\nAttaching package ", sQuote(package),
                            ":\n\n", sep = "")
                    }
                    cat("\n\tThe following object(s) are masked",
                        if (i < lib.pos) "_by_" else "from", sp[i],
                        ":\n\n\t", same, "\n\n")
                }
            }
        }
    }

    libraryPkgName <- function(pkgName, sep = "_")
	unlist(strsplit(pkgName, sep, fixed=TRUE))[1]

    libraryPkgVersion <- function(pkgName, sep = "_")
    {
        splitName <- unlist(strsplit(pkgName, sep, fixed=TRUE))
	if (length(splitName) > 1) splitName[2] else NULL
    }

    libraryMaxVersPos <- function(vers)
    {
	## Takes in a character vector of version numbers
        ## returns the position of the maximum version utilizing
        ## compareVersion.  Can't do as.numeric due to the "-" in versions.
	max <- vers[1]

        for (ver in vers) if (compareVersion(max, ver) < 0) max <- ver
	out <- match(max, vers)
	out
    }

    runUserHook <- function(pkgname, pkgpath) {
        hook <- getHook(packageEvent(pkgname, "attach")) # might be list()
        for(fun in hook) try(fun(pkgname, pkgpath))
    }

    if(!missing(package)) {
        if (is.null(lib.loc)) lib.loc <- .libPaths()
        
	if(!character.only)
	    package <- as.character(substitute(package))

	if (!missing(version)) {
	     package <- manglePackageName(package, version)
        } else {
	   ## Need to find the proper package to install
	   pkgDirs <- list.files(lib.loc,
                                 pattern = paste("^", package, sep=""))
           ## See if any directories in lib.loc match the pattern of
           ## 'package', if none do, just continue as it will get caught
           ## below.  Otherwise, if there is actually a 'package', use
           ## that, and if not, then use the highest versioned dir.
	   if (length(pkgDirs) > 0) {
	       if (!(package %in% pkgDirs)) {
		   ## Need to find the highest version available
		   vers <- unlist(lapply(pkgDirs, libraryPkgVersion))
		   pos <- libraryMaxVersPos(vers)
		   if (length(pos) > 0) package <- pkgDirs[pos]
               }
           }
        }

        ## NB from this point on `package' is either the original name or
        ## something like ash_1.0-8
        if(length(package) != 1)
            stop(paste("argument", sQuote("package"), "must be of length 1"))
	pkgname <- paste("package", package, sep = ":")
	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 libs when it is
            ## attached.

            pkgpath <- .find.package(package, lib.loc, quiet = TRUE,
                                     verbose = verbose)
            if(length(pkgpath) == 0) {
               txt <- paste("There is no package called",
			     sQuote(libraryPkgName(package)))
		vers <- libraryPkgVersion(package)
		if (!is.null(vers))
		   txt <- paste(txt, ", version ", vers, sep="")
                if(logical.return) {
                    warning(txt)
		    return(FALSE)
		} else stop(txt)
            }
            which.lib.loc <- dirname(pkgpath)
            descfile <- system.file("DESCRIPTION", package = package,
                                    lib.loc = which.lib.loc)
            if(!nchar(descfile))
            	stop("This is not a valid package -- no DESCRIPTION exists")

            descfields <- read.dcf(descfile, fields =
                                   c("Package", "Depends", "Built"))
            testRversion(descfields)

            ## Check for inconsistent naming
            if(descfields[1, "Package"] != libraryPkgName(package)) {
            	warning(paste("Package", sQuote(package), "not found.\n",
			"Using case-insensitive match",
            		sQuote(descfields[1, "Package"]), ".\n",
			"Future versions of R will require exact matches."),
			call.=FALSE)
            	package <- descfields[1, "Package"]
            	pkgname <- paste("package", package, sep = ":")
            	newpackage <- is.na(match(pkgname, search()))
	    }
            if(is.character(pos)) {
                npos <- match(pos, search())
                if(is.na(npos)) {
                    warning(paste(sQuote(pos),
                                  "not found on search path, using",
                                  sQuote("pos=2")))
                    pos <- 2
                } else pos <- npos
            }
            if(newpackage) {
		## If the name space mechanism is available and the package
		## has a name space, then the name space loading mechanism
		## takes over.
		if (packageHasNamespace(package, which.lib.loc)) {
		    tt <- try({
			ns <- loadNamespace(package, c(which.lib.loc, lib.loc))
			env <- attachNamespace(ns, pos = pos)
		    })
		    if (inherits(tt, "try-error"))
			if (logical.return)
			    return(FALSE)
			else stop("package/namespace load failed")
		    else {
			on.exit(do.call("detach", list(name = pkgname)))
			nogenerics <- checkNoGenerics(env, package)
			if(warn.conflicts &&
			   !exists(".conflicts.OK", envir = env, inherits = FALSE))
                            checkConflicts(package, pkgname, pkgpath, nogenerics)

                        if(!nogenerics && .isMethodsDispatchOn() &&
                           !identical(pkgname, "package:methods"))
                            methods::cacheMetaData(env, TRUE, searchWhere = .GlobalEnv)
                        runUserHook(package, pkgpath)
			on.exit()
			if (logical.return)
			    return(TRUE)
			else
			    return(invisible(.packages()))
		    }
		}
		codeFile <- file.path(which.lib.loc, package, "R",
				      libraryPkgName(package))
		## create environment (not attached yet)
		loadenv <- new.env(hash = TRUE, parent = .GlobalEnv)
		## save the package name in the environment
		assign(".packageName", package, envir = loadenv)
		## source file into loadenv
		if(file.exists(codeFile))
		    sys.source(codeFile, loadenv, keep.source = keep.source)
		else if(verbose)
		    warning(paste("Package ", sQuote(package),
				  "contains no R code"))
		## now transfer contents of loadenv to an attached frame
		env <- attach(NULL, pos = pos, name = pkgname)
		## detach does not allow character vector args
		on.exit(do.call("detach", list(name = pkgname)))
		attr(env, "path") <- file.path(which.lib.loc, package)
		## the actual copy has to be done by C code to avoid forcing
		## promises that might have been created using delay().
		.Internal(lib.fixup(loadenv, env))

		## run .First.lib
		if(exists(".First.lib", mode = "function",
                          envir = env, inherits = FALSE)) {
		    firstlib <- get(".First.lib", mode = "function",
                                    envir = env, inherits = FALSE)
		    tt<- try(firstlib(which.lib.loc, package))
		    if(inherits(tt, "try-error"))
			if (logical.return) return(FALSE)
			else stop(".First.lib failed")
		}
		if(!is.null(firstlib <- getOption(".First.lib")[[package]])){
		    tt<- try(firstlib(which.lib.loc, package))
		    if(inherits(tt, "try-error"))
			if (logical.return) return(FALSE)
			else stop(".First.lib failed")
		}
		nogenerics <- checkNoGenerics(env, package)
		if(warn.conflicts &&
		   !exists(".conflicts.OK", envir = env, inherits = FALSE))
		    checkConflicts(package, pkgname, pkgpath, nogenerics)

		if(!nogenerics && .isMethodsDispatchOn() &&
		   !identical(pkgname, "package:methods"))
                    methods::cacheMetaData(env, TRUE, searchWhere = .GlobalEnv)
                runUserHook(package, pkgpath)
		on.exit()
	    }
	}
	if (verbose && !newpackage)
            warning(paste("Package", sQuote(package),
                          "already present in search()"))
    }
    else if(!missing(help)) {
	if(!character.only)
	    help <- as.character(substitute(help))
        pkgName <- help[1]              # only give help on one package
        pkgPath <- .find.package(pkgName, lib.loc, verbose = verbose)
        docFiles <- file.path(pkgPath, c("DESCRIPTION", "INDEX"))
        ## This is a bit ugly, but in the future we might also have
        ## DESCRIPTION or INDEX files as serialized R objects ...
        if(file.exists(vignetteIndexRDS <-
                       file.path(pkgPath, "Meta", "vignette.rds")))
            docFiles <- c(docFiles, vignetteIndexRDS)
        else
            docFiles <- c(docFiles,
                          file.path(pkgPath, "doc", "00Index.dcf"))
        pkgInfo <- vector(length = 4, mode = "list")
        pkgInfo[[1]] <- paste("\n\t\tInformation on Package",
                              sQuote(pkgName))
        readDocFile <- function(f) {
            if(basename(f) %in% c("DESCRIPTION", "00Index.dcf")) {
                ## This should be in valid DCF format ...
                txt <- try(read.dcf(f))
                if(inherits(txt, "try-error")) {
                    warning(paste("file",
                                  sQuote(f),
                                  "is not in valid DCF format"))
                    return(NULL)
                }
                ## Return a list so that the print method knows to
                ## format as a description list (if non-empty).
                txt <- if(all(dim(txt) >= 1))
                    list(colnames(txt), as.character(txt[1, ]))
                else
                    NULL
            }
            else if(basename(f) %in% c("vignette.rds")) {
                txt <- .readRDS(f)
                ## New-style vignette indexes 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.
                txt <- if(is.data.frame(txt) && nrow(txt))
                    cbind(basename(gsub("\\.[[:alpha:]]+$", "",
                                        txt$File)),
                          paste(txt$Title,
                                paste(rep.int("(source", NROW(txt)),
                                      ifelse(txt$PDF != "",
                                             ", pdf",
                                             ""),
                                      ")", sep = "")))
                else NULL
            }
            else
                txt <- readLines(f)
            txt
        }
        for(i in which(file.exists(docFiles)))
            pkgInfo[[i+1]] <- 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(0), nr = 0, nc = 3)
        nopkgs <- character(0)

        for(lib in lib.loc) {
            a <- .packages(all.available = TRUE, lib.loc = lib)
            for(i in sort(a)) {
                title <- packageDescription(i, lib.loc = lib, field="Title")
                if(is.na(title)) title <- ""
                db <- rbind(db, cbind(i, lib, title))
            }
            if(length(a) == 0)
                nopkgs <- c(nopkgs, lib)
        }
        colnames(db) <- c("Package", "LibPath", "Title")
        if((length(nopkgs) > 0) && !missing(lib.loc)) {
            if(length(nopkgs) > 1)
                warning(paste("libraries",
                              paste(sQuote(nopkgs), collapse = ", "),
                              "contain no packages"))
            else
                warning(paste("library",
                              paste(sQuote(nopkgs)),
                              "contains no package"))
        }

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

    if (logical.return)
	TRUE
    else invisible(.packages())
}

library.dynam <-
function(chname, package = .packages(), lib.loc = NULL, verbose =
         getOption("verbose"), file.ext = .Platform$dynlib.ext, ...)
{
    .Dyn.libs <- .dynLibs()
    if(missing(chname) || (ncChname <- nchar(chname)) == 0)
        return(.Dyn.libs)
    ncFileExt <- nchar(file.ext)
    if(substr(chname, ncChname - ncFileExt + 1, ncChname) == file.ext)
        chname <- substr(chname, 1, ncChname - ncFileExt)
    if(is.na(match(chname, .Dyn.libs))) {
        for(pkg in .find.package(package, lib.loc, verbose = verbose)) {
            file <- file.path(pkg, "libs",
                              paste(chname, file.ext, sep = ""))
            if(file.exists(file)) break
            else
                file <- ""
        }
        if(file == "") {
            stop(paste("shared library", sQuote(chname), "not found"))
        }
        if(verbose)
            cat("now dyn.load(", file, ") ...\n", sep = "")
        dyn.load(file, ...)
        .dynLibs(c(.Dyn.libs, chname))
    }
    invisible(.dynLibs())
}

library.dynam.unload <-
function(chname, libpath, verbose = getOption("verbose"),
         file.ext = .Platform$dynlib.ext)
{
    .Dyn.libs <- .dynLibs()
    if(missing(chname) || (ncChname <- nchar(chname)) == 0)
        stop("no shared library was specified")
    ncFileExt <- nchar(file.ext)
    if(substr(chname, ncChname - ncFileExt + 1, ncChname) == file.ext)
        chname <- substr(chname, 1, ncChname - ncFileExt)
    num <- match(chname, .Dyn.libs, 0)
    if(is.na(num))
        stop(paste("shared library", sQuote(chname), "was not loaded"))
    file <- file.path(libpath, "libs", paste(chname, file.ext, sep = ""))
    if(!file.exists(file))
        stop(paste("shared library", sQuote(chname), "not found"))
    if(verbose)
        cat("now dyn.unload(", file, ") ...\n", sep = "")
    dyn.unload(file)
    .dynLibs(.Dyn.libs[-num])
    invisible(.dynLibs())
}

require <-
function(package, quietly = FALSE, warn.conflicts = TRUE,
         keep.source = getOption("keep.source.pkgs"),
         character.only = FALSE, version, save = TRUE)
{
    if( !character.only )
        package <- as.character(substitute(package)) # allowing "require(eda)"
    if (missing(version))
        pkgName <- package
    else
        pkgName <- manglePackageName(package, version)


    if (is.na(match(paste("package", pkgName, sep = ":"), search()))) {
	if (!quietly) cat("Loading required package:", package, "\n")
	value <- library(package, character.only = TRUE, logical = TRUE,
		warn.conflicts = warn.conflicts, keep.source = keep.source,
                version = version)
    } else value <- TRUE

    if(identical(save, FALSE)) {}
    else {
        ## update the ".required" variable
        if(identical(save, TRUE)) {
            save <- topenv(parent.frame())
            ## (a package namespace, topLevelEnvironment option or
            ## .GlobalEnv)
            if(identical(save, .GlobalEnv)) {
                ## try to detect call from .First.lib in  a package
                ## <FIXME>
                ## Although the docs have long and perhaps always had
                ##   .First.lib(libname, pkgname)
                ## the majority of CRAN packages seems to use arguments
                ## 'lib' and 'pkg'.
                objectsInParentFrame <- sort(objects(parent.frame()))
                if(identical(sort(c("libname", "pkgname")),
                             objectsInParentFrame))
                    save <-
                        as.environment(paste("package:",
                                             get("pkgname",
                                                 parent.frame()),
                                             sep = ""))
                else if(identical(sort(c("lib", "pkg")),
                                  objectsInParentFrame))
                    save <-
                        as.environment(paste("package:",
                                             get("pkg",
                                                 parent.frame()),
                                             sep = ""))
                ## </FIXME>
                ## else either from prompt or in the source for install
                ## with saved image ?
            }
        }
        else
            save <- as.environment(save)
        hasDotRequired <- exists(".required", save, inherits=FALSE)
        if(!isNamespace(save) || hasDotRequired) { ## so assignment allowed
            if(hasDotRequired)
                packages <- unique(c(package, get(".required", save)))
            else
                packages <- package
            assign(".required", packages, save)
        }
    }
    value
}

.packages <- function(all.available = FALSE, lib.loc = NULL)
{
    if(is.null(lib.loc))
        lib.loc <- .libPaths()
    if(all.available) {
	ans <- character(0)
        lib.loc <- lib.loc[file.exists(lib.loc)]
        for(lib in lib.loc) {
            a <- list.files(lib, all.files = FALSE, full.names = FALSE)
            for(nam in a) {
                if(file.exists(file.path(lib, nam, "DESCRIPTION")))
                    ans <- c(ans, nam)
            }
        }
        return(unique(ans))
    } ## else
    s <- search()
    return(invisible(substring(s[substr(s, 1, 8) == "package:"], 9)))
}

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

.find.package <-
    function(package, lib.loc = NULL, quiet = FALSE,
             verbose = getOption("verbose"))
{
    .filePathAsAbsolute <- function(x) {
        ## Note that we cannot use tools::filePathAsAbsolute() here, as
        ## cyclic name space dependencies are not supported.  Argh.
        ## This version is simpler: we only need it for directories
        ## already known to exist.
        cwd <- getwd(); on.exit(setwd(cwd))
        setwd(path.expand(x))
        getwd()
    }

    useAttached <- FALSE
    if(is.null(lib.loc)) {
        useAttached <- TRUE
        lib.loc <- .libPaths()
    }

    n <- length(package)
    if(n == 0) return(character(0))

    bad <- character(0)                 # names of packages not found
    paths <- character(0)               # paths to packages found

    for(pkg in package) {
        fp <- file.path(lib.loc, pkg)
        if(useAttached)
            fp <- c(.path.package(pkg, TRUE), fp)
        ## Note that we cannot use tools::fileTest() here, as cyclic
        ## name space dependencies are not supported.  Argh.
        fp <- unique(fp[file.exists(fp) &
                        file.exists(file.path(fp, "DESCRIPTION"))])
        if(length(fp) == 0) {
            bad <- c(bad, pkg)
            next
        }
        afp <- .filePathAsAbsolute(fp[1])
        if(verbose && (length(fp) > 1))
            warning(paste("package ", sQuote(pkg),
                          " found more than once,\n",
                          "using the one found in ",
                          sQuote(dirname(afp)),
                          sep = ""))
        paths <- c(paths, afp)
    }

    if(!quiet && (length(bad) > 0)) {
        if(length(paths) == 0)
            stop("none of the packages were found")
        for(pkg in bad)
            warning(paste("there is no package called", sQuote(pkg)))
    }

    paths
}

print.packageInfo <- function(x, ...)
{
    if(!inherits(x, "packageInfo")) stop("wrong class")
    outFile <- tempfile("RpackageInfo")
    outConn <- file(outFile, open = "w")
    vignetteMsg <-
        paste("Further information is available in the following ",
              "vignettes in directory ",
              sQuote(file.path(x$path, "doc")),
              ":",
              sep = "")
    headers <- c("", "Description:\n\n", "Index:\n\n",
                 paste(paste(strwrap(vignetteMsg), collapse = "\n"),
                       "\n\n", sep = ""))
    footers <- c("\n", "\n", "\n", "")
    formatDocEntry <- function(entry) {
        if(is.list(entry) || is.matrix(entry))
            formatDL(entry, style = "list")
        else
            entry
    }
    for(i in which(!sapply(x$info, is.null))) {
        writeLines(headers[i], outConn, sep = "")
        writeLines(formatDocEntry(x$info[[i]]), outConn)
        writeLines(footers[i], outConn, sep = "")
    }
    close(outConn)
    file.show(outFile, delete.file = TRUE,
              title = paste("Documentation for package",
              sQuote(x$name)))
    invisible(x)
}

manglePackageName <- function(pkgName, pkgVersion)
    paste(pkgName, "_", pkgVersion, sep = "")
