#  File src/library/base/R/namespace.R
#  Part of the R package, https://www.R-project.org
#
#  Copyright (C) 1995-2023 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 3 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/

## give the base namespace a table for registered methods
`.__S3MethodsTable__.` <- new.env(hash = TRUE, parent = baseenv())

## NOTA BENE:
##  1) This code should work also when methods is not yet loaded
##  2) We use  ':::' instead of '::' inside the code below, for efficiency only

getNamespace <- function(name) {
    .Internal(getRegisteredNamespace(name)) %||% loadNamespace(name)
}

.getNamespace <- function(name) .Internal(getRegisteredNamespace(name))

..getNamespace <- function(name, where) {
    .Internal(getRegisteredNamespace(name)) %||%
	tryCatch(loadNamespace(name), error = function(e) {
             tr <- Sys.getenv("_R_NO_REPORT_MISSING_NAMESPACES_")
             if( tr == "false" || (where != "<unknown>" && !nzchar(tr)) ) {
                 warning(gettextf("namespace %s is not available and has been replaced\nby .GlobalEnv when processing object %s",
                                  sQuote(name)[1L], sQuote(where)),
                         domain = NA, call. = FALSE, immediate. = TRUE)
                 if(nzchar(Sys.getenv("_R_CALLS_MISSING_NAMESPACES_")))
                     print(sys.calls())
             }
             .GlobalEnv
         })
}

loadedNamespaces <- function() names(.Internal(getNamespaceRegistry()))

isNamespaceLoaded <- function(name) .Internal(isRegisteredNamespace(name))

getNamespaceName <- function(ns) {
    ns <- asNamespace(ns)
    if (isBaseNamespace(ns)) "base"
    else .getNamespaceInfo(ns, "spec")["name"]
}

getNamespaceVersion <- function(ns) {
    ns <- asNamespace(ns)
    if (isBaseNamespace(ns))
        c(version = paste(R.version$major, R.version$minor, sep = "."))
    else .getNamespaceInfo(ns, "spec")["version"]
}

getNamespaceExports <- function(ns) {
    ns <- asNamespace(ns)
    names(if(isBaseNamespace(ns)) .BaseNamespaceEnv
          else .getNamespaceInfo(ns, "exports"))
}

getNamespaceImports <- function(ns) {
    ns <- asNamespace(ns)
    if (isBaseNamespace(ns)) NULL
    else .getNamespaceInfo(ns, "imports")
}

getNamespaceUsers <- function(ns) {
    nsname <- getNamespaceName(asNamespace(ns))
    users <- character()
    for (n in loadedNamespaces()) {
        inames <- names(getNamespaceImports(n))
        if (match(nsname, inames, 0L))
            users <- c(n, users)
    }
    users
}

getExportedValue <- function(ns, name)
    .Internal(getNamespaceValue(ns, name, TRUE))

## NOTE: Both "::" and ":::" must signal an error for non existing objects
## :: and ::: are now SPECIALSXP primitives.
## `::` <- function(pkg, name)
##     .Internal(getNamespaceValue(substitute(pkg), substitute(name), TRUE))
## `:::` <- function(pkg, name)
##     .Internal(getNamespaceValue(substitute(pkg), substitute(name), FALSE))

attachNamespace <- function(ns, pos = 2L, depends = NULL, exclude, include.only)
{
    ## only used to run .onAttach
    runHook <- function(hookname, env, libname, pkgname) {
        if (!is.null(fun <- env[[hookname]])) {
            res <- tryCatch(fun(libname, pkgname), error = identity)
            if (inherits(res, "error")) {
                stop(gettextf("%s failed in %s() for '%s', details:\n  call: %s\n  error: %s",
                              hookname, "attachNamespace", nsname,
                              deparse(conditionCall(res))[1L],
                              conditionMessage(res)),
                     call. = FALSE, domain = NA)
            }
        }
##         else if (exists(".First.lib", envir = env, inherits = FALSE) &&
##                  nsname == Sys.getenv("R_INSTALL_PKG"))
##             warning(sprintf("ignoring .First.lib() for package %s",
##                             sQuote(nsname)), domain = NA, call. = FALSE)
    }
    runUserHook <- function(pkgname, pkgpath) {
        hook <- getHook(packageEvent(pkgname, "attach")) # might be list()
        for(fun in hook) try(fun(pkgname, pkgpath))
    }

    ns <- asNamespace(ns, base.OK = FALSE)
    nsname <- getNamespaceName(ns)
    nspath <- .getNamespaceInfo(ns, "path")
    attname <- paste0("package:", nsname)
    if (attname %in% search())
        stop("namespace is already attached")
    env <- attach(NULL, pos = pos, name = attname)
    ## we do not want to run e.g. .onDetach here
    on.exit(.Internal(detach(pos)))
    attr(env, "path") <- nspath
    exports <- getNamespaceExports(ns)
    importIntoEnv(env, exports, ns, exports)
    ## always exists, might be empty
    dimpenv <- .getNamespaceInfo(ns, "lazydata")
    dnames <- names(dimpenv)
    .Internal(importIntoEnv(env, dnames, dimpenv, dnames))
    if(length(depends) > 0L) env$.Depends <- depends
    Sys.setenv("_R_NS_LOAD_" = nsname)
    on.exit(Sys.unsetenv("_R_NS_LOAD_"), add = TRUE)
    runHook(".onAttach", ns, dirname(nspath), nsname)

    ## adjust variables for 'exclude', 'include.only' arguments
    if (! missing(exclude) && length(exclude) > 0)
        rm(list = exclude, envir = env)
    if (! missing(include.only)) {
        vars <- ls(env, all.names = TRUE)
        nf <- setdiff(include.only, vars)
        if (length(nf) > 0) {
            nf <- strwrap(paste(nf, collapse = ", "),
                          indent = 4L,  exdent = 4L)
            stop(gettextf("not found in namespace %s: \n\n%s\n",
                          sQuote(nsname), nf),
                 call. = FALSE, domain = NA)
        }
        rm(list = setdiff(vars, include.only), envir = env)
    }

    lockEnvironment(env, TRUE)
    runUserHook(nsname, nspath)
    on.exit()
    Sys.unsetenv("_R_NS_LOAD_")
    invisible(env)
}

## *inside* another function, useful to check for cycles
dynGet <- function(x, ifnotfound = stop(gettextf("%s not found",
			     sQuote(x)), domain = NA),
		   minframe = 1L, inherits = FALSE)
{
    n <- sys.nframe()
    myObj <- structure(list(.b = as.raw(7)), foo = 47L)# "very improbable" object
    while (n > minframe) {
	n <- n - 1L
	env <- sys.frame(n)
	r <- get0(x, envir = env, inherits=inherits, ifnotfound = myObj)
	if(!identical(r, myObj))
	    return(r)
    }
    ifnotfound
}

loadNamespace <- function (package, lib.loc = NULL,
                           keep.source = getOption("keep.source.pkgs"),
                           partial = FALSE, versionCheck = NULL,
                           keep.parse.data = getOption("keep.parse.data.pkgs"))
{
    libpath <- attr(package, "LibPath")
    package <- as.character(package)[[1L]]

    loading <- dynGet("__NameSpacesLoading__", NULL)
    if (match(package, loading, 0L))
        stop("cyclic namespace dependency detected when loading ",
             sQuote(package), ", already loading ",
             paste(sQuote(loading), collapse = ", "),
             domain = NA)
    "__NameSpacesLoading__" <- c(package, loading)

    ns <- .Internal(getRegisteredNamespace(package))
    if (! is.null(ns)) {
        if(!is.null(zop <- versionCheck[["op"]]) &&
           !is.null(zversion <- versionCheck[["version"]])) {
            current <- getNamespaceVersion(ns)
            if(!do.call(zop, list(as.numeric_version(current), zversion)))
                stop(gettextf("namespace %s %s is already loaded, but %s %s is required",
                              sQuote(package), current, zop, zversion),
                     domain = NA)
        }
        ## return
        ns
    } else {
        lev <- 0L
        ## Values 1,2,3,4 give increasingly detailed tracing
        ## Negative values trace specific actions, -5 for S4 generics/methods
        msg <- Sys.getenv("_R_TRACE_LOADNAMESPACE_", "")
        if (nzchar(msg)) {
            if(package %in%
               c("base", "tools", "utils", "grDevices", "graphics",
                 "stats", "datasets", "methods", "grid", "splines", "stats4",
                 "tcltk", "compiler", "parallel")) lev <- 0L
            else {
                lev <- as.integer(msg)
                if(is.na(lev)) lev <- 0L
            }
        }
	if(lev > 0L) message("- loading ", dQuote(package))
        ## only used here for .onLoad
        runHook <- function(hookname, env, libname, pkgname) {
	    if (!is.null(fun <- env[[hookname]])) {
                res <- tryCatch(fun(libname, pkgname), error = identity)
                if (inherits(res, "error")) {
                    stop(gettextf("%s failed in %s() for '%s', details:\n  call: %s\n  error: %s",
                                  hookname, "loadNamespace", pkgname,
                                  deparse(conditionCall(res))[1L],
                                  conditionMessage(res)),
                         call. = FALSE, domain = NA)
                }
            }
        }
        runUserHook <- function(pkgname, pkgpath) {
            hooks <- getHook(packageEvent(pkgname, "onLoad")) # might be list()
            for(fun in hooks) try(fun(pkgname, pkgpath))
        }
        makeNamespace <- function(name, version = NULL, lib = NULL) {
            impenv <- new.env(parent = .BaseNamespaceEnv, hash = TRUE)
            attr(impenv, "name") <- paste0("imports:", name)
            env <- new.env(parent = impenv, hash = TRUE)
            name <- as.character(as.name(name))
            version <- as.character(version)
            info <- new.env(hash = TRUE, parent = baseenv())
            env$.__NAMESPACE__. <- info
            info$spec <- c(name = name, version = version)
            setNamespaceInfo(env, "exports", new.env(hash = TRUE, parent = baseenv()))
            dimpenv <- new.env(parent = baseenv(), hash = TRUE)
            attr(dimpenv, "name") <- paste0("lazydata:", name)
            setNamespaceInfo(env, "lazydata", dimpenv)
            setNamespaceInfo(env, "imports", list("base" = TRUE))
            ## this should be an absolute path
            setNamespaceInfo(env, "path",
                             normalizePath(file.path(lib, name), "/", TRUE))
            setNamespaceInfo(env, "dynlibs", NULL)
            setNamespaceInfo(env, "S3methods", matrix(NA_character_, 0L, 4L))
            env$.__S3MethodsTable__. <-
                new.env(hash = TRUE, parent = baseenv())
            .Internal(registerNamespace(name, env))
            env
        }
        sealNamespace <- function(ns) {
            namespaceIsSealed <- function(ns)
               environmentIsLocked(ns)
            ns <- asNamespace(ns, base.OK = FALSE)
            if (namespaceIsSealed(ns))
                stop(gettextf("namespace %s is already sealed in 'loadNamespace'",
                              sQuote(getNamespaceName(ns))),
                     call. = FALSE, domain = NA)
            lockEnvironment(ns, TRUE)
            lockEnvironment(parent.env(ns), TRUE)
        }
        addNamespaceDynLibs <- function(ns, newlibs) {
            dynlibs <- .getNamespaceInfo(ns, "dynlibs")
            setNamespaceInfo(ns, "dynlibs", c(dynlibs, newlibs))
        }

        bindTranslations <- function(pkgname, pkgpath)
        {
            ## standard packages are treated differently
            std <- c("compiler", "grDevices", "graphics", "grid",
                     "methods", "parallel", "splines", "stats", "stats4",
                     "tcltk", "tools", "utils")
            popath <- if (pkgname %in% std) .popath else file.path(pkgpath, "po")
            if(!file.exists(popath)) return()
            bindtextdomain(pkgname, popath)
            bindtextdomain(paste0("R-", pkgname), popath)
        }

        assignNativeRoutines <- function(dll, lib, env, nativeRoutines) {
            if(length(nativeRoutines) == 0L) return(character())

            varnames <- character()
            symnames <- character()

            if(nativeRoutines$useRegistration) {
                ## Use the registration information to register ALL the symbols
                fixes <- nativeRoutines$registrationFixes
                routines <- getDLLRegisteredRoutines.DLLInfo(dll, addNames = FALSE)
                lapply(routines,
                       function(type) {
                           lapply(type,
                                  function(sym) {
                                      varName <- paste0(fixes[1L], sym$name, fixes[2L])
                                      if(exists(varName, envir = env, inherits = FALSE))
                                          warning(gettextf(
		"failed to assign RegisteredNativeSymbol for %s to %s since %s is already defined in the %s namespace",
                                                           sym$name, varName, varName, sQuote(package)),
                                                  domain = NA, call. = FALSE)
                                      else {
                                          env[[varName]] <- sym
                                          varnames <<- c(varnames,
                                                         varName)
                                          symnames <<- c(symnames,
                                                         sym$name)
                                      }
                                  })
                       })
            }

            symNames <- nativeRoutines$symbolNames
            if(length(symNames)) {
                symbols <- getNativeSymbolInfo(symNames, dll, unlist = FALSE,
                                               withRegistrationInfo = TRUE)
                lapply(seq_along(symNames),
                       function(i) {
                           ## could vectorize this outside of the loop
                           ## and assign to different variable to
                           ## maintain the original names.
                           varName <- names(symNames)[i]
                           origVarName <- symNames[i]
                           if(exists(varName, envir = env, inherits = FALSE))
                               if(origVarName != varName)
                                   warning(gettextf(
		"failed to assign NativeSymbolInfo for %s to %s since %s is already defined in the %s namespace",
                                                    origVarName, varName, varName, sQuote(package)),
                                           domain = NA, call. = FALSE)
                               else
                                   warning(gettextf(
		"failed to assign NativeSymbolInfo for %s since %s is already defined in the %s namespace",
                                                    origVarName, varName, sQuote(package)),
                                           domain = NA, call. = FALSE)
                           else {
                               assign(varName, symbols[[origVarName]],
                                      envir = env)
                               varnames <<- c(varnames, varName)
                               symnames <<- c(symnames, origVarName)
                           }
                })
            }

            names(symnames) <- varnames
            symnames
        } ## end{assignNativeRoutines}

        ## find package, allowing a calling handler to retry if not found.
        ## could move the retry functionality into find.package.
        fp.lib.loc <- c(libpath, lib.loc)
        pkgpath <- find.package(package, fp.lib.loc, quiet = TRUE)
        if (length(pkgpath) == 0L) {
            cond <- packageNotFoundError(package, fp.lib.loc, sys.call())
            withRestarts(stop(cond), retry_loadNamespace = function() NULL)
            pkgpath <- find.package(package, fp.lib.loc, quiet = TRUE)
            if (length(pkgpath) == 0L)
                stop(cond)
        }
        bindTranslations(package, pkgpath)
        package.lib <- dirname(pkgpath)
        package <- basename(pkgpath) # need the versioned name
        if (! packageHasNamespace(package, package.lib)) {
            hasNoNamespaceError <-
                function (package, package.lib, call = NULL) {
                class <- c("hasNoNamespaceError", "error", "condition")
                msg <- gettextf("package %s does not have a namespace",
                                sQuote(package))
                structure(list(message = msg, package = package,
                               package.lib = package.lib, call = call),
                          class = class)
            }
            stop(hasNoNamespaceError(package, package.lib))
        }

        ## create namespace; arrange to unregister on error
        ## Can we rely on the existence of R-ng 'nsInfo.rds' and
        ## 'package.rds'?
        ## No, not during builds of standard packages
        ## stats4 depends on methods, but exports do not matter
        ## whilst it is being built
        iniStdPkgs <- c("methods", "stats", "stats4", "tools", "utils")
        nsInfoFilePath <- file.path(pkgpath, "Meta", "nsInfo.rds")
        nsInfo <- if(file.exists(nsInfoFilePath)) readRDS(nsInfoFilePath)
                  else parseNamespaceFile(package, package.lib, mustExist = FALSE)

        pkgInfoFP <- file.path(pkgpath, "Meta", "package.rds")
        if(file.exists(pkgInfoFP)) {
            pkgInfo <- readRDS(pkgInfoFP)
            version <- pkgInfo$DESCRIPTION["Version"]
            vI <- pkgInfo$Imports
            if(is.null(built <- pkgInfo$Built))
                stop(gettextf("package %s has not been installed properly\n",
                              sQuote(package)), # == basename(pkgpath)
                     call. = FALSE, domain = NA)
            R_version_built_under <- as.numeric_version(built$R)
            if(R_version_built_under < "4.0.0")
                stop(gettextf("package %s was installed before R 4.0.0: please re-install it",
                             sQuote(package)),
                     call. = FALSE, domain = NA)
            ## we need to ensure that S4 dispatch is on now if the package
            ## will require it, or the exports will be incomplete.
            dependsMethods <- "methods" %in% c(names(pkgInfo$Depends), names(vI))
            if(dependsMethods) loadNamespace("methods")
            if(!is.null(zop <- versionCheck[["op"]]) &&
               !is.null(zversion <- versionCheck[["version"]]) &&
               !do.call(zop, list(as.numeric_version(version), zversion)))
                stop(gettextf("namespace %s %s is being loaded, but %s %s is required",
                              sQuote(package), version, zop, zversion),
                     domain = NA)
        } else {
            if(!any(package == iniStdPkgs))
                warning(gettextf("package %s has no 'package.rds' in Meta/",
                                 sQuote(package)),
                        domain = NA)
            vI <- NULL
        }

        ## moved from library() in R 3.4.0
        checkLicense <- function(pkg, pkgInfo, pkgPath)
        {
            L <- tools:::analyze_license(pkgInfo$DESCRIPTION["License"])
            if(!L$is_empty && !L$is_verified) {
                site_file <-
                    path.expand(file.path(R.home("etc"), "licensed.site"))
                if(file.exists(site_file) &&
                   pkg %in% readLines(site_file)) return()
                personal_file <- path.expand("~/.R/licensed")
                if(file.exists(personal_file)) {
                    agreed <- readLines(personal_file)
                    if(pkg %in% agreed) return()
                } else agreed <- character()
                if(!interactive())
                    stop(gettextf(
                        "package %s has a license that you need to accept in an interactive session",
                        sQuote(pkg)), domain = NA)
                lfiles <- file.path(pkgpath, c("LICENSE", "LICENCE"))
                lfiles <- lfiles[file.exists(lfiles)]
                if(length(lfiles)) {
                    message(gettextf(
                        "package %s has a license that you need to accept after viewing",
                        sQuote(pkg)), domain = NA)
                    readline("press RETURN to view license")
                    encoding <- pkgInfo$DESCRIPTION["Encoding"]
                    if(is.na(encoding)) encoding <- ""
                    ## difR and EVER have a Windows' 'smart quote' LICEN[CS]E file
                    if(encoding == "latin1") encoding <- "cp1252"
                    file.show(lfiles[1L], encoding = encoding)
                } else {
                    message(gettextf(paste("package %s has a license that you need to accept:",
                                           "according to the DESCRIPTION file it is",
                                           "%s", sep="\n"),
                                     sQuote(pkg),
                                     pkgInfo$DESCRIPTION["License"]), domain = NA)
                }
                choice <- utils::menu(c("accept", "decline"),
                                      title = paste("License for", sQuote(pkg)))
                if(choice != 1)
                    stop(gettextf("license for package %s not accepted",
                                  sQuote(package)), domain = NA, call. = FALSE)
                dir.create(dirname(personal_file), showWarnings=FALSE)
                writeLines(c(agreed, pkg), personal_file)
            }
        }

        ## avoid any bootstrapping issues by these exemptions
        if(!package %in% c("datasets", "grDevices", "graphics", # <- ??
                           iniStdPkgs) &&
           isTRUE(getOption("checkPackageLicense", FALSE)))
            checkLicense(package, pkgInfo, pkgpath)

        ## Check that the internals version used to build this package
        ## matches the version of current R. Failure in this test
        ## should only occur if the R version is an unreleased devel
        ## version or the package was build with an unrelease devel
        ## version.  Other mismatches should be caught earlier by the
        ## version checks.
        ## Meta will not exist when first building tools,
        ## so pkgInfo was not created above.
        if(dir.exists(file.path(pkgpath, "Meta"))) {
            ffile <- file.path(pkgpath, "Meta", "features.rds")
            features <- if (file.exists(ffile)) readRDS(ffile) else NULL
            needsComp <- as.character(pkgInfo$DESCRIPTION["NeedsCompilation"])
            if (identical(needsComp, "yes") ||
                file.exists(file.path(pkgpath, "libs"))) {
                internalsID <- features$internalsID
                if (is.null(internalsID))
                    ## the initial internalsID for packages installed
                    ## prior to introducing features.rds in the meta data
                    internalsID <- "0310d4b8-ccb1-4bb8-ba94-d36a55f60262"
                if (internalsID != .Internal(internalsID()))
                    stop(gettextf("package %s was installed by an R version with different internals; it needs to be reinstalled for use with this R version",
                                  sQuote(package)), call. = FALSE, domain = NA)
            }
        }

        ns <- makeNamespace(package, version = version, lib = package.lib)
        on.exit(.Internal(unregisterNamespace(package)))

        ## process imports
	if(lev > 1L) message("-- processing imports for ", dQuote(package))
        for (i in nsInfo$imports) {
            if (is.character(i))
                namespaceImport(ns,
                                loadNamespace(i, c(lib.loc, .libPaths()),
                                              versionCheck = vI[[i]]),
                                from = package)
            else if (!is.null(i$except))
                namespaceImport(ns,
                                loadNamespace(j <- i[[1L]],
                                              c(lib.loc, .libPaths()),
                                              versionCheck = vI[[j]]),
                                from = package,
                                except = i$except)
            else
                namespaceImportFrom(ns,
                                    loadNamespace(j <- i[[1L]],
                                                  c(lib.loc, .libPaths()),
                                                  versionCheck = vI[[j]]),
                                    i[[2L]], from = package)
        }
        for(imp in nsInfo$importClasses)
            namespaceImportClasses(ns, loadNamespace(j <- imp[[1L]],
                                                     c(lib.loc, .libPaths()),
                                                     versionCheck = vI[[j]]),
                                   imp[[2L]], from = package)
        for(imp in nsInfo$importMethods)
            namespaceImportMethods(ns, loadNamespace(j <- imp[[1L]],
                                                     c(lib.loc, .libPaths()),
                                                     versionCheck = vI[[j]]),
                                   imp[[2L]], from = package)

        if(lev > 1L) message("-- done processing imports for ", dQuote(package))

        ## store info for loading namespace for loadingNamespaceInfo to read
        "__LoadingNamespaceInfo__" <- list(libname = package.lib,
                                           pkgname = package)

        env <- asNamespace(ns)
        ## save the package name in the environment
        env$.packageName <- package

        ## load the code
        codename <- strsplit(package, "_", fixed = TRUE)[[1L]][1L]
        codeFile <- file.path(pkgpath, "R", codename)
        if (file.exists(codeFile)) {
            if(lev > 1L) message("-- loading code for ", dQuote(package))
	    # The code file has been converted to the native encoding
	    save.enc <- options(encoding = "native.enc")
            res <- try(sys.source(codeFile, env, keep.source = keep.source,
                                  keep.parse.data = keep.parse.data))
	    options(save.enc)
            if(inherits(res, "try-error"))
                stop(gettextf("unable to load R code in package %s",
                              sQuote(package)), call. = FALSE, domain = NA)
            if(lev > 1L) message("-- loading code for ", dQuote(package))
        }
        # a package without R code currently is required to have a namespace
        # else warning(gettextf("package %s contains no R code",
        #                        sQuote(package)), call. = FALSE, domain = NA)

        ## partial loading stops at this point
        ## -- used in preparing for lazy-loading
        if (partial) return(ns)

        ## lazy-load any sysdata
        dbbase <- file.path(pkgpath, "R", "sysdata")
        if (file.exists(paste0(dbbase, ".rdb"))) {
            if(lev > 1L) message("-- loading sysdata for ", dQuote(package))
            lazyLoad(dbbase, env)
	}

        ## load any lazydata into a separate environment
        dbbase <- file.path(pkgpath, "data", "Rdata")
        if(file.exists(paste0(dbbase, ".rdb"))) {
            if(lev > 1L) message("-- loading lazydata for ", dQuote(package))
            lazyLoad(dbbase, .getNamespaceInfo(env, "lazydata"))
	}

        ## register any S3 methods
        if(lev > 1L) message("-- registerS3methods for ", dQuote(package))
        registerS3methods(nsInfo$S3methods, package, env)
        if(lev > 1L) message("-- done registerS3methods for ", dQuote(package))

        ## load any dynamic libraries
        dlls <- list()
        dynLibs <- nsInfo$dynlibs
        nativeRoutines <- list()
        for (i in seq_along(dynLibs)) {
            lib <- dynLibs[i]
            dlls[[lib]]  <- library.dynam(lib, package, package.lib)
            routines <- assignNativeRoutines(dlls[[lib]], lib, env,
                                             nsInfo$nativeRoutines[[lib]])
            nativeRoutines[[lib]] <- routines

            ## If the DLL has a name as in useDynLib(alias = foo),
            ## then assign DLL reference to alias.  Check if
            ## names() is NULL to handle case that the nsInfo.rds
            ## file was created before the names were added to the
            ## dynlibs vector.
            if(!is.null(names(nsInfo$dynlibs))
               && nzchar(names(nsInfo$dynlibs)[i]))
                env[[names(nsInfo$dynlibs)[i]]] <- dlls[[lib]]
            setNamespaceInfo(env, "DLLs", dlls)
        }
        addNamespaceDynLibs(env, nsInfo$dynlibs)
        setNamespaceInfo(env, "nativeRoutines", nativeRoutines)

        ## used in e.g. utils::assignInNamespace
        Sys.setenv("_R_NS_LOAD_" = package)
        on.exit(Sys.unsetenv("_R_NS_LOAD_"), add = TRUE)
        ## run the load hook
	if(lev > 1L) message("-- running .onLoad for ", dQuote(package))
        runHook(".onLoad", env, package.lib, package)
	if(lev > 1L) message("-- done running .onLoad for ", dQuote(package))

        ## process exports, seal, and clear on.exit action
        exports <- nsInfo$exports

        for (p in nsInfo$exportPatterns)
            exports <- c(ls(env, pattern = p, all.names = TRUE), exports)
        ##
        if(.isMethodsDispatchOn() &&
           !(hasS4m <- methods:::.hasS4MetaData(ns)) &&
           any(lengths(nsInfo[c("exportClasses", "exportMethods",
                                "exportClassPatterns")])) &&
           Sys.getenv("_R_LOAD_CHECK_S4_EXPORTS_") %in% c(package, "all")) {
            warning(gettextf(
                "S4 exports specified in 'NAMESPACE' but not defined in package %s",
                sQuote(package)), call. = FALSE, domain = NA)
        }
        if(.isMethodsDispatchOn() && hasS4m && !identical(package, "methods") ) {
            if(lev > 1L || lev == -5)
                message("-- processing S4 stuff for ", dQuote(package))
            ## cache generics, classes in this namespace (but not methods itself,
            if(lev > 2L) message('--- caching metadata')
            ## which pre-cached at install time
            methods::cacheMetaData(ns, TRUE, ns)
	    if(lev > 2L) message('--- done caching metadata')
            ## This also ran .doLoadActions
            ## load actions may have added objects matching patterns
            for (p in nsInfo$exportPatterns) {
                expp <- ls(ns, pattern = p, all.names = TRUE)
                newEx <- !(expp %in% exports)
                if(any(newEx))
                    exports <- c(expp[newEx], exports)
            }
            ## process class definition objects
            expClasses <- nsInfo$exportClasses
	    if(lev > 2L) message('--- processing classes')
            ##we take any pattern, but check to see if the matches are classes
            pClasses <- character()
            aClasses <- methods::getClasses(ns)
            classPatterns <- nsInfo$exportClassPatterns
            ## defaults to exportPatterns
            if(!length(classPatterns))
                classPatterns <- nsInfo$exportPatterns
            pClasses <- unique(unlist(lapply(classPatterns, grep, aClasses,
                                             value=TRUE)))
            if( length(pClasses) ) {
                good <- vapply(pClasses, methods::isClass, NA, where = ns)
                if( !any(good) && length(nsInfo$exportClassPatterns))
                    warning(gettextf(
				"'exportClassPattern' specified in 'NAMESPACE' but no matching classes in package %s",
				sQuote(package)),
                            call. = FALSE, domain = NA)
                expClasses <- c(expClasses, pClasses[good])
            }
            if(length(expClasses)) {
                missingClasses <-
                    !vapply(expClasses, methods::isClass, NA, where = ns)
                if(any(missingClasses))
                    stop(gettextf("in package %s classes %s were specified for export but not defined",
                                  sQuote(package),
                                  paste(expClasses[missingClasses],
                                        collapse = ", ")),
                         domain = NA)
                expClasses <- paste0(methods::classMetaName(""), expClasses)
            }
            ## process methods metadata explicitly exported or
            ## implied by exporting the generic function.
            allGenerics <- unique(c(methods:::.getGenerics(ns),
                                    methods:::.getGenerics(parent.env(ns))))
            expMethods <- nsInfo$exportMethods
            ## check for generic functions corresponding to exported methods
            addGenerics <- expMethods[is.na(match(expMethods, exports))]
            if(length(addGenerics)) {
                nowhere <- vapply(addGenerics, function(what) !exists(what, mode = "function", envir = ns),
                                  NA, USE.NAMES=FALSE)
                if(any(nowhere)) {
                    warning(gettextf("no function found corresponding to methods exports from %s for: %s",
                                     sQuote(package),
                                     paste(sQuote(sort(unique(addGenerics[nowhere]))), collapse = ", ")),
                         domain = NA, call. = FALSE)
                    addGenerics <- addGenerics[!nowhere]
                }
                if(length(addGenerics)) {
                    ## skip primitives
                    addGenerics <- addGenerics[vapply(addGenerics, function(what)
                        !is.primitive(get(what, mode = "function", envir = ns)), NA)]
                    ## the rest must be generic functions, implicit or local
                    ## or have been cached via a DEPENDS package
		    ok <- vapply(addGenerics, methods:::.findsGeneric, 1L, ns)
                    if(!all(ok)) {
                        bad <- sort(unique(addGenerics[!ok]))
                        msg <-
                            ngettext(length(bad),
			"Function found when exporting methods from the namespace %s which is not S4 generic: %s",
			"Functions found when exporting methods from the namespace %s which are not S4 generic: %s")
                        stop(sprintf(msg, sQuote(package),
                                     paste(sQuote(bad), collapse = ", ")),
                             domain = NA, call. = FALSE)
                    }
                    else if(any(ok > 1L))  #from the cache, don't add
                        addGenerics <- addGenerics[ok < 2L]
                }
### <note> Uncomment following to report any local generic functions
### that should have been exported explicitly.  But would be reported
### whenever the package is loaded, which is not when it is relevant.
### </note>
                ## local <- sapply(addGenerics, function(what) identical(as.character(get(what, envir = ns)@package), package))
                ## if(any(local))
                ##     message(gettextf("export(%s) from package %s generated by exportMethods()",
                ##        paste(addGenerics[local], collapse = ", ")),
                ##             domain = NA)
                exports <- c(exports, addGenerics)
            }
            expTables <- character()
            if(length(allGenerics)) {
                expMethods <-
                    unique(c(expMethods,
                             exports[!is.na(match(exports, allGenerics))]))
                missingMethods <- !(expMethods %in% allGenerics)
                if(any(missingMethods))
                    stop(gettextf("in %s methods for export not found: %s",
                                  sQuote(package),
                                  paste(expMethods[missingMethods],
                                        collapse = ", ")),
                         domain = NA)
                tPrefix <- methods:::.TableMetaPrefix()
                allMethodTables <-
                    unique(c(methods:::.getGenerics(ns, tPrefix),
                             methods:::.getGenerics(parent.env(ns), tPrefix)))
                needMethods <-
                    (exports %in% allGenerics) & !(exports %in% expMethods)
                if(any(needMethods))
                    expMethods <- c(expMethods, exports[needMethods])
                ## Primitives must have their methods exported as long
                ## as a global table is used in the C code to dispatch them:
                ## The following keeps the exported files consistent with
                ## the internal table.
                pm <- allGenerics[!(allGenerics %in% expMethods)]
                if(length(pm)) {
                    prim <- vapply(pm, function(pmi) {
                                       f <- methods::getFunction(pmi, FALSE,
                                                                 FALSE, ns)
                                       is.primitive(f)
                                   }, logical(1L))
                    expMethods <- c(expMethods, pm[prim])
                }
                for(i in seq_along(expMethods)) {
                    mi <- expMethods[[i]]
                    if(lev > 3L) message("---- export method ", sQuote(mi))
                    if(!(mi %in% exports) &&
                       exists(mi, envir = ns, mode = "function",
                              inherits = FALSE))
                        exports <- c(exports, mi)
                    pattern <- paste0(tPrefix, mi, ":")
                    ii <- grep(pattern, allMethodTables, fixed = TRUE)
                    if(length(ii)) {
			if(length(ii) > 1L) {
			    warning(gettextf("multiple methods tables found for %s",
				    sQuote(mi)), call. = FALSE, domain = NA)
			    ii <- ii[1L]
			}
                        expTables[[i]] <- allMethodTables[ii]
                     }
                    else { ## but not possible?
                      warning(gettextf("failed to find metadata object for %s",
                                       sQuote(mi)), call. = FALSE, domain = NA)
                    }
                }
            }
            else if(length(expMethods))
                stop(gettextf("in package %s methods %s were specified for export but not defined",
                              sQuote(package),
                              paste(expMethods, collapse = ", ")),
                     domain = NA)
            exports <- unique(c(exports, expClasses,  expTables))
            if(lev > 1L || lev == -5)
                message("-- done processing S4 stuff for ", dQuote(package))
        }
        ## certain things should never be exported.
        if (length(exports)) {
            stoplist <- c(".__NAMESPACE__.", ".__S3MethodsTable__.",
                          ".packageName", ".First.lib", ".onLoad",
                          ".onAttach", ".conflicts.OK", ".noGenerics",
                          ".__global__", ".__suppressForeign__")
            exports <- exports[! exports %in% stoplist]
        }
	if(lev > 2L) message("--- processing exports for ", dQuote(package))
        namespaceExport(ns, exports)
	if(lev > 2L) message("--- sealing exports for ", dQuote(package))
        sealNamespace(ns)
        runUserHook(package, pkgpath)
        on.exit()
	if(lev > 0L) message("- done loading ", dQuote(package))
        Sys.unsetenv("_R_NS_LOAD_")
        ns
    }
}

## A version which returns TRUE/FALSE
requireNamespace <- function (package, ..., quietly = FALSE)
{
    package <- as.character(package)[[1L]] # like loadNamespace
    ns <- .Internal(getRegisteredNamespace(package))
    res <- TRUE
    if (is.null(ns)) {
        if(!quietly)
            packageStartupMessage(gettextf("Loading required namespace: %s",
                                           package), domain = NA)
        value <- tryCatch(loadNamespace(package, ...), 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())
            }
            res <- FALSE
        }
    }
    invisible(res)
}

loadingNamespaceInfo <- function() {
    dynGet("__LoadingNamespaceInfo__", stop("not loading a namespace"))
}

topenv <- function(envir = parent.frame(),
                   matchThisEnv = getOption("topLevelEnvironment")) {
    .Internal(topenv(envir, matchThisEnv))
}

unloadNamespace <- function(ns)
{
    ## check, so we do not load & unload:
    if ((is.character(ns) && any(ns == loadedNamespaces())) ||
        (is.environment(ns) && any(getNamespaceName(ns) == loadedNamespaces()))) {
	## only used to run .onUnload
	runHook <- function(hookname, env, ...) {
	    if (!is.null(fun <- env[[hookname]])) {
		res <- tryCatch(fun(...), error=identity)
		if (inherits(res, "error")) {
		    warning(gettextf("%s failed in %s() for '%s', details:\n  call: %s\n  error: %s",
				     hookname, "unloadNamespace", nsname,
				     deparse(conditionCall(res))[1L],
				     conditionMessage(res)),
			    call. = FALSE, domain = NA)
		}
	    }
	}
	ns <- asNamespace(ns, base.OK = FALSE)
	nsname <- getNamespaceName(ns)
	pos <- match(paste0("package:", nsname), search())
	if (! is.na(pos)) detach(pos = pos)
	users <- getNamespaceUsers(ns)
	if (length(users))
	    stop(gettextf("namespace %s is imported by %s so cannot be unloaded",
			  sQuote(getNamespaceName(ns)),
			  paste(sQuote(users), collapse = ", ")),
		 domain = NA)
	nspath <- .getNamespaceInfo(ns, "path")
	hook <- getHook(packageEvent(nsname, "onUnload")) # might be list()
	for(fun in rev(hook)) try(fun(nsname, nspath))
	runHook(".onUnload", ns, nspath)
	.Internal(unregisterNamespace(nsname))
	if(.isMethodsDispatchOn() && methods:::.hasS4MetaData(ns))
	    methods::cacheMetaData(ns, FALSE, ns)
	.Internal(lazyLoadDBflush(paste0(nspath, "/R/", nsname, ".rdb")))
    }
    invisible()
}

isNamespace <- function(ns) .Internal(isNamespaceEnv(ns))

isBaseNamespace <- function(ns) identical(ns, .BaseNamespaceEnv)

getNamespaceInfo <- function(ns, which) {
    ns <- asNamespace(ns, base.OK = FALSE)
    get(which, envir = ns[[".__NAMESPACE__."]])
}

.getNamespaceInfo <- function(ns, which) {
    ns[[".__NAMESPACE__."]][[which]]
}

setNamespaceInfo <- function(ns, which, val) {
    ns <- asNamespace(ns, base.OK = FALSE)
    info <- ns[[".__NAMESPACE__."]]
    info[[which]] <- val
}

asNamespace <- function(ns, base.OK = TRUE) {
    if (is.character(ns) || is.name(ns))
        ns <- getNamespace(ns)
    if (! isNamespace(ns))
        stop("not a namespace")
    else if (! base.OK && isBaseNamespace(ns))
        stop("operation not allowed on base namespace")
    else ns
}

namespaceImport <- function(self, ..., from = NULL, except = character(0L))
    for (ns in list(...))
        namespaceImportFrom(self, asNamespace(ns), from = from,
                            except = except)

namespaceImportFrom <- function(self, ns, vars, generics, packages,
                                from = "non-package environment",
                                except = character(0L))
{
    addImports <- function(ns, from, what) {
        imp <- structure(list(what), names = getNamespaceName(from))
        imports <- getNamespaceImports(ns)
        setNamespaceInfo(ns, "imports", c(imports, imp))
    }
    namespaceIsSealed <- function(ns)
       environmentIsLocked(ns)
    makeImportExportNames <- function(spec) {
        old <- as.character(spec)
        new <- names(spec)
        if (is.null(new)) new <- old
        else {
            change <- !nzchar(new)
            new[change] <- old[change]
        }
        names(old) <- new
        old
    }
    whichMethodMetaNames <- function(impvars) {
        if(!.isMethodsDispatchOn())
            return(numeric())
	seq_along(impvars)[startsWith(impvars, ".__T__")]
    }
    genericPackage <- function(f) {
        if(methods::is(f, "genericFunction")) f@package
        else if(is.primitive(f)) "base"
        else "<unknown>"
    }
    if (is.character(self))
        self <- getNamespace(self)
    ns <- asNamespace(ns)
    nsname <- getNamespaceName(ns)
    impvars <- if (missing(vars)) {
        ## certain things should never be imported:
        ## but most of these are never exported (exception: .Last.lib)
        stoplist <- c(".__NAMESPACE__.", ".__S3MethodsTable__.",
                      ".packageName", ".First.lib", ".Last.lib",
                      ".onLoad", ".onAttach", ".onDetach",
                      ".conflicts.OK", ".noGenerics")
        vars <- getNamespaceExports(ns)
        vars <- vars[! vars %in% stoplist]
    } else vars
    impvars <- impvars[! impvars %in% except]
    impvars <- makeImportExportNames(impvars)
    impnames <- names(impvars)
    if (anyDuplicated(impnames)) {
        stop(gettextf("duplicate import names %s",
                      paste(sQuote(impnames[duplicated(impnames)]),
                            collapse = ", ")), domain = NA)
    }
    if (isNamespace(self)) {
        if(isBaseNamespace(self)) {
            impenv <- self
            msg <- gettext("replacing local value with import %s when loading %s")
            register <- FALSE
        }
        else {
            if (namespaceIsSealed(self))
                stop("cannot import into a sealed namespace")
            impenv <- parent.env(self)
            msg <- gettext("replacing previous import by %s when loading %s")
            register <- TRUE
        }
    }
    else if (is.environment(self)) {
        impenv <- self
        msg <- gettext("replacing local value with import %s when loading %s")
        register <- FALSE
    }
    else stop("invalid import target")
    which <- whichMethodMetaNames(impvars)
    if(length(which)) {
	## If methods are already in impenv, merge and don't import
	delete <- integer()
	for(i in which) {
	    methodsTable <- .mergeImportMethods(impenv, ns, impvars[[i]])
	    if(is.null(methodsTable))
	    {} ## first encounter, just import it
	    else { ##
		delete <- c(delete, i)
		if(!missing(generics)) {
		    genName <- generics[[i]]
                    ## if(i > length(generics) || !nzchar(genName))
                    ##   {warning("got invalid index for importing ",mlname); next}
		    fdef <- methods::getGeneric(genName,
                                                where = impenv,
                                                package = packages[[i]])
		    if(is.null(fdef))
			warning(gettextf("found methods to import for function %s but not the generic itself",
					 sQuote(genName)),
                                call. = FALSE, domain = NA)
		    else
			methods:::.updateMethodsInTable(fdef, ns, TRUE)
		}
	    }
	}
	if(length(delete)) {
	    impvars <- impvars[-delete]
	    impnames <- impnames[-delete]
	}
    }
    for (n in impnames)
	if (!is.null(genImp <- impenv[[n]])) {
	    if (.isMethodsDispatchOn() && methods::isGeneric(n, ns)) {
		## warn only if generic overwrites a function which
		## it was not derived from
		genNs <- genericPackage(get(n, envir = ns))
                if(identical(genNs, genericPackage(genImp))) next # same generic
		genImpenv <- environmentName(environment(genImp))
                ## May call environment() on a non-function--an undocumented
                ## "feature" of environment() is that it returns a special
                ## attribute for non-functions, usually NULL
		if (!identical(genNs, genImpenv) ||
                    methods::isGeneric(n, impenv)) {}
                else next
	    }
            if (identical(genImp, get(n, ns))) next
            if (isNamespace(self) && !isBaseNamespace(self)) {
                ## Now try to figure out where we imported from
                ## The 'imports' list is named by where-from
                ## and is in order of adding.
                current <- getNamespaceInfo(self, "imports")
                poss <- lapply(rev(current), `[`, n)
                poss <- poss[!sapply(poss, is.na)]
                if(length(poss) >= 1L) {
                    prev <- names(poss)[1L]
                    warning(sprintf(gettext("replacing previous import %s by %s when loading %s"),
                                    sQuote(paste(prev, n, sep = "::")),
                                    sQuote(paste(nsname, n, sep = "::")),
                                    sQuote(from)),
                            call. = FALSE, domain = NA)
                } else
                    warning(sprintf(msg, sQuote(paste(nsname, n, sep = "::")),
                                    sQuote(from)),
                            call. = FALSE, domain = NA)
            } else {
                ## this is always called from another function,
                ## so reporting call is unhelpful
                warning(sprintf(msg, sQuote(paste(nsname, n, sep = "::")),
                                sQuote(from)),
                        call. = FALSE, domain = NA)
            }
	}
    importIntoEnv(impenv, impnames, ns, impvars)
    if (register)
        addImports(self, ns, if (missing(vars)) TRUE else impvars)
}

namespaceImportClasses <- function(self, ns, vars, from = NULL)
{
    for(i in seq_along(vars))
        vars[[i]] <- methods::classMetaName(vars[[i]])
    namespaceImportFrom(self, asNamespace(ns), vars, from = from)
}

namespaceImportMethods <- function(self, ns, vars, from = NULL)
{
    allVars <- character()
    generics <- character()
    packages <- character()
    allFuns <- methods:::.getGenerics(ns) # all the methods tables in ns
    allPackages <- attr(allFuns, "package")
    pkg <- methods::getPackageName(ns)
    found <- vars %in% allFuns
    if(!all(found)) {
        message(sprintf(ngettext(sum(!found),
                                 "No methods found in package %s for request: %s when loading %s",
                                 "No methods found in package %s for requests: %s when loading %s"),
                        sQuote(pkg),
                        paste(sQuote(vars[!found]), collapse = ", "),
                        sQuote(getNamespaceName(self))),
                domain = NA)
        vars <- vars[found]
    }
    found <- vars %in% allFuns
    if(!all(found))
        stop(sprintf(ngettext(sum(!found),
                              "requested method not found in environment/package %s: %s when loading %s",
                              "requested methods not found in environment/package %s: %s when loading %s"),
                     sQuote(pkg),
                     paste(sQuote(vars[!found]), collapse = ", "),
                     sQuote(getNamespaceName(self))),
             call. = FALSE, domain = NA)
    for(i in seq_along(allFuns)) {
        ## import methods tables if asked for
        ## or if the corresponding generic was imported
        g <- allFuns[[i]]
        p <- allPackages[[i]]
        if(exists(g, envir = self, inherits = FALSE) # already imported
           || g %in% vars) { # requested explicitly
            tbl <- methods:::.TableMetaName(g, p)
            if(is.null(.mergeImportMethods(self, ns, tbl))) { # a new methods table
               allVars <- c(allVars, tbl) # import it;else, was merged
               generics <- c(generics, g)
               packages <- c(packages, p)
            }
        }
        if(g %in% vars && !exists(g, envir = self, inherits = FALSE)) {
	    if(!is.null(f <- get0(g, envir = ns)) && methods::is(f, "genericFunction")) {
                allVars <- c(allVars, g)
                generics <- c(generics, g)
                packages <- c(packages, p)
            } else if (g %in% c("as.vector", "is.unsorted", "unlist")) {
                ## implicit generics
            } else { # should be primitive
                fun <- methods::getFunction(g, mustFind = FALSE, where = self)
                if(is.primitive(fun) || methods::is(fun, "genericFunction")) {}
                else
                    warning(gettextf(
	"No generic function %s found corresponding to requested imported methods from package %s when loading %s (malformed exports?)",
				     sQuote(g), sQuote(pkg), sQuote(from)),
			    domain = NA, call. = FALSE)
            }
        }
    }
    namespaceImportFrom(self, asNamespace(ns), allVars, generics, packages,
                        from = from)
}

importIntoEnv <- function(impenv, impnames, expenv, expnames) {
    exports <- getNamespaceInfo(expenv, "exports")
    ex <- names(exports)
    if(!all(eie <- expnames %in% ex)) {
        miss <- expnames[!eie]
        ## if called (indirectly) for namespaceImportClasses
        ## these are all classes
        if(all(startsWith(miss, ".__C__"))) {
            miss <- sub("^\\.__C__", "", miss)
            stop(sprintf(ngettext(length(miss),
                                  "class %s is not exported by 'namespace:%s'",
                                  "classes %s are not exported by 'namespace:%s'"),
                         paste(paste0('"', miss, '"'), collapse = ", "),
                         getNamespaceName(expenv)),
                 call. = FALSE, domain = NA)
        } else {
            stop(sprintf(ngettext(length(miss),
                                  "object %s is not exported by 'namespace:%s'",
                                  "objects %s are not exported by 'namespace:%s'"),
                         paste(sQuote(miss), collapse = ", "),
                         getNamespaceName(expenv)),
                 call. = FALSE, domain = NA)
        }
    }
    expnames <- unlist(mget(expnames, envir = exports, inherits = FALSE), recursive=FALSE)
    if (is.null(impnames)) impnames <- character()
    if (is.null(expnames)) expnames <- character()
    .Internal(importIntoEnv(impenv, impnames, expenv, expnames))
}

namespaceExport <- function(ns, vars) {
    namespaceIsSealed <- function(ns)
       environmentIsLocked(ns)
    if (namespaceIsSealed(ns))
        stop("cannot add to exports of a sealed namespace")
    ns <- asNamespace(ns, base.OK = FALSE)
    if (length(vars)) {
        addExports <- function(ns, new) {
            exports <- .getNamespaceInfo(ns, "exports")
            expnames <- names(new)
            objs <- names(exports)
            ex <- expnames %in% objs
            if(any(ex))
                warning(sprintf(ngettext(sum(ex),
                                         "previous export '%s' is being replaced",
                                         "previous exports '%s' are being replaced"),
                                paste(sQuote(expnames[ex]), collapse = ", ")),
                        call. = FALSE, domain = NA)
            list2env(as.list(new), exports)
        }
        makeImportExportNames <- function(spec) {
            old <- as.character(spec)
            new <- names(spec)
            if (is.null(new)) new <- old
            else {
                change <- !nzchar(new)
                new[change] <- old[change]
            }
            names(old) <- new
            old
        }
        new <- makeImportExportNames(unique(vars))
        ## calling exists each time is too slow, so do two phases
        undef <- new[! new %in% names(ns)]
        undef <- undef[! vapply(undef, exists, NA, envir = ns)]
        if (length(undef)) {
            undef <- do.call("paste", as.list(c(undef, sep = ", ")))
            undef <- gsub("^\\.__C__", "class ", undef)
            stop(gettextf("undefined exports: %s", undef), domain = NA)
        }
        if(.isMethodsDispatchOn()) .mergeExportMethods(new, ns)
        addExports(ns, new)
    }
}

.mergeExportMethods <- function(new, ns)
{
    ## avoid bootstrapping issues when using methods:::methodsPackageMetaName("M","")
    ## instead of  ".__M__" :
    newMethods <- new[startsWith(new, ".__M__")]
    nsimports <- parent.env(ns)
    for(what in newMethods) {
	if(!is.null(m1 <- nsimports[[what]])) {
            m2 <- get(what, envir = ns)
            ns[[what]] <- methods::mergeMethods(m1, m2)
        }
    }
}

packageHasNamespace <- function(package, package.lib)
    file.exists(file.path(package.lib, package, "NAMESPACE"))

parseNamespaceFile <- function(package, package.lib, mustExist = TRUE)
{
    namespaceFilePath <- function(package, package.lib)
        file.path(package.lib, package, "NAMESPACE")

    ## These two functions are essentially local to the parsing of
    ## the namespace file and don't need to be made available to
    ## users.  These manipulate the data from useDynLib() directives
    ## for the same DLL to determine how to map the symbols to R
    ## variables.

    nativeRoutineMap <-
        ## Creates a new NativeRoutineMap.
        function(useRegistration, symbolNames, fixes) {
            proto <- list(useRegistration = FALSE,
                          symbolNames = character())
            class(proto) <- "NativeRoutineMap"

            mergeNativeRoutineMaps(proto, useRegistration, symbolNames, fixes)
        }

    mergeNativeRoutineMaps <-
        ## Merges new settings into a NativeRoutineMap
        function(map, useRegistration, symbolNames, fixes) {
            if(!useRegistration)
                names(symbolNames) <-
                    paste0(fixes[1L],  names(symbolNames), fixes[2L])
            else
                map$registrationFixes <- fixes
            map$useRegistration <- map$useRegistration || useRegistration
            map$symbolNames <- c(map$symbolNames, symbolNames)
            map
        }

    nsFile <- namespaceFilePath(package, package.lib)
    descfile <- file.path(package.lib, package, "DESCRIPTION")
    enc <- if (file.exists(descfile)) {
        read.dcf(file = descfile, "Encoding")[1L]
    } else NA_character_
    if (file.exists(nsFile))
        directives <- if (!is.na(enc) &&
                          ! Sys.getlocale("LC_CTYPE") %in% c("C", "POSIX")) {
            lines <- readLines(nsFile, warn = FALSE)
            tmp <- iconv(lines, from = enc, to = "")
            bad <- which(is.na(tmp))
            ## do not report purely comment lines,
            comm <- grep("^[[:space:]]*#", lines[bad],
                         invert = TRUE, useBytes = TRUE)
            if(length(bad[comm]))
                stop("unable to re-encode some lines in NAMESPACE file")
            tmp <- iconv(lines, from = enc, to = "", sub = "byte")
	    con <- textConnection(tmp)
            on.exit(close(con))
	    parse(con, keep.source = FALSE, srcfile = NULL)
        } else parse(nsFile, keep.source = FALSE, srcfile = NULL)
    else if (mustExist)
        stop(gettextf("package %s has no 'NAMESPACE' file", sQuote(package)),
             domain = NA)
    else directives <- NULL
    exports <- character()
    exportPatterns <- character()
    exportClasses <- character()
    exportClassPatterns <- character()
    exportMethods <- character()
    imports <- list()
    importMethods <- list()
    importClasses <- list()
    dynlibs <- character()
    nS3methods <- 1000L
    S3methods <- matrix(NA_character_, nS3methods, 4L)
    nativeRoutines <- list()
    nS3 <- 0L
    parseDirective <- function(e) {
        ## trying to get more helpful error message:
	asChar <- function(cc) {
	    r <- as.character(cc)
	    if(any(r == ""))
		stop(gettextf("empty name in directive '%s' in 'NAMESPACE' file",
			      as.character(e[[1L]])),
		     domain = NA)
	    r
	}
        evalToChar <- function(cc) {
            vars <- all.vars(cc)
            names(vars) <- vars
            as.character(eval(eval(call("substitute", cc, as.list(vars))),
                              .GlobalEnv))
        }
        switch(as.character(e[[1L]]),
               "if" = if (eval(e[[2L]], .GlobalEnv))
               parseDirective(e[[3L]])
               else if (length(e) == 4L)
               parseDirective(e[[4L]]),
               "{" =  for (ee in as.list(e[-1L])) parseDirective(ee),
               "=" =,
               "<-" = {
                   parseDirective(e[[3L]])
                   if(as.character(e[[3L]][[1L]]) == "useDynLib")
                       names(dynlibs)[length(dynlibs)] <<- asChar(e[[2L]])
               },
               export = {
                   exp <- e[-1L]
                   exp <- structure(asChar(exp), names = names(exp))
                   exports <<- c(exports, exp)
               },
               exportPattern = {
                   pat <- asChar(e[-1L])
                   exportPatterns <<- c(pat, exportPatterns)
               },
               exportClassPattern = {
                   pat <- asChar(e[-1L])
                   exportClassPatterns <<- c(pat, exportClassPatterns)
               },
               exportClass = , exportClasses = {
                   exportClasses <<- c(asChar(e[-1L]), exportClasses)
               },
               exportMethods = {
                   exportMethods <<- c(asChar(e[-1L]), exportMethods)
               },
               import = {
                   except <- e$except
                   e$except <- NULL
                   pkgs <- as.list(asChar(e[-1L]))
                   if (!is.null(except)) {
                       pkgs <- lapply(pkgs, list, except=evalToChar(except))
                   }
                   imports <<- c(imports, pkgs)
               },
               importFrom = {
                   imp <- e[-1L]
                   ivars <- imp[-1L]
                   inames <- names(ivars)
                   imp <- list(asChar(imp[1L]),
                               structure(asChar(ivars), names = inames))
                   imports <<- c(imports, list(imp))
               },
               importClassFrom = , importClassesFrom = {
                   imp <- asChar(e[-1L])
                   pkg <- imp[[1L]]
                   impClasses <- imp[-1L]
                   imp <- list(asChar(pkg), asChar(impClasses))
                   importClasses <<- c(importClasses, list(imp))
               },
               importMethodsFrom = {
                   imp <- asChar(e[-1L])
                   pkg <- imp[[1L]]
                   impMethods <- imp[-1L]
                   imp <- list(asChar(pkg), asChar(impMethods))
                   importMethods <<- c(importMethods, list(imp))
               },
               useDynLib = {

                   ## This attempts to process as much of the
                   ## information as possible when NAMESPACE is parsed
                   ## rather than when it is loaded and creates
                   ## NativeRoutineMap objects to handle the mapping
                   ## of symbols to R variable names.

                   ## The name is the second element after useDynLib
                   dyl <- as.character(e[2L])
                   ## We ensure uniqueness at the end.
                   dynlibs <<-
                       structure(c(dynlibs, dyl),
                                 names = c(names(dynlibs),
                                 ifelse(!is.null(names(e)) &&
                                        nzchar(names(e)[2L]), names(e)[2L], "" )))
                   if (length(e) > 2L) {
                       ## Author has specified some mappings for the symbols

                       symNames <- as.character(e[-c(1L, 2L)])
                       names(symNames) <- names(e[-c(1, 2)])

                       ## If there are no names, then use the names of
                       ## the symbols themselves.
                       if (length(names(symNames)) == 0L)
                           names(symNames) <- symNames
                       else if (any(w <- names(symNames) == "")) {
                           names(symNames)[w] <- symNames[w]
                       }

                       ## For each DLL, we build up a list the (R
                       ## variable name, symbol name) mappings. We do
                       ## this in a NativeRoutineMap object and we
                       ## merge potentially multiple useDynLib()
                       ## directives for the same DLL into a single
                       ## map.  Then we have separate NativeRoutineMap
                       ## for each different DLL.  E.g. if we have
                       ## useDynLib(foo, a, b, c) and useDynLib(bar,
                       ## a, x, y) we would maintain and resolve them
                       ## separately.

                       dup <- duplicated(names(symNames))
                       if (any(dup))
                           warning(gettextf("duplicate symbol names %s in useDynLib(\"%s\")",
                                            paste(sQuote(names(symNames)[dup]),
                                                  collapse = ", "), dyl),
                                   domain = NA, call. = FALSE)

                       symNames <- symNames[!dup]

                       ## Deal with any prefix/suffix pair.
                       fixes <- c("", "")
                       idx <- match(".fixes", names(symNames))
                       if(!is.na(idx)) {
                           ## Take .fixes and treat it as a call,
                           ## e.g. c("pre", "post") or a regular name
                           ## as the prefix.
                           if(nzchar(symNames[idx])) {
                               e <- parse(text = symNames[idx],
                                          keep.source = FALSE,
                                          srcfile = NULL)[[1L]]
                               if(is.call(e))
                                   val <- eval(e, .GlobalEnv)
                               else
                                   val <- as.character(e)
                               if(length(val))
                                   fixes[seq_along(val)] <- val
                           }
                           symNames <- symNames[-idx]
                       }

                       ## Deal with a .registration entry. It must be
                       ## .registration = value and value will be coerced
                       ## to a logical.
                       useRegistration <- FALSE
                       idx <- match(".registration", names(symNames))
                       if(!is.na(idx)) {
                           useRegistration <- as.logical(symNames[idx])
                           symNames <- symNames[-idx]
                       }

                       ## Now merge into the NativeRoutineMap.
                       nativeRoutines[[ dyl ]] <<-
                           if(dyl %in% names(nativeRoutines))
                               mergeNativeRoutineMaps(nativeRoutines[[ dyl ]],
                                                      useRegistration,
                                                      symNames, fixes)
                           else
                               nativeRoutineMap(useRegistration, symNames,
                                                fixes)
                   }
               },
               S3method = {
                   spec <- e[-1L]
                   if (length(spec) != 2L && length(spec) != 3L)
                       stop(gettextf("bad 'S3method' directive: %s",
                                     deparse(e)),
                            call. = FALSE, domain = NA)
                   nS3 <<- nS3 + 1L
                   if(nS3 > nS3methods) {
                       old <- S3methods
                       nold <- nS3methods
                       nS3methods <<- nS3methods * 2L
                       new <- matrix(NA_character_, nS3methods, 4L)
                       ind <- seq_len(nold)
                       for (i in 1:4) new[ind, i] <- old[ind, i]
                       S3methods <<- new
                       rm(old, new)
                   }
                   if(is.call(gen <- spec[[1L]]) &&
                      identical(as.character(gen[[1L]]), "::")) {
                       pkg <- as.character(gen[[2L]])[1L]
                       gen <- as.character(gen[[3L]])[1L]
                       S3methods[nS3, c(seq_along(spec), 4L)] <<-
                           c(gen, asChar(spec[-1L]), pkg)
                   } else
                   S3methods[nS3, seq_along(spec)] <<- asChar(spec)
               },
               stop(gettextf("unknown namespace directive: %s", deparse(e, nlines=1L)),
                    call. = FALSE, domain = NA)
               )
    }
    for (e in directives)
        parseDirective(e)

    ## need to preserve the names on dynlibs, so unique() is not appropriate.
    dynlibs <- dynlibs[!duplicated(dynlibs)]
    list(imports = imports, exports = exports,
         exportPatterns = unique(exportPatterns),
         importClasses = importClasses, importMethods = importMethods,
         exportClasses = unique(exportClasses),
         exportMethods = unique(exportMethods),
         exportClassPatterns = unique(exportClassPatterns),
         dynlibs = dynlibs, nativeRoutines = nativeRoutines,
         S3methods = unique(S3methods[seq_len(nS3), , drop = FALSE]) )
} ## end{parseNamespaceFile}

## used inside registerS3methods(); workhorse of .S3method()
registerS3method <- function(genname, class, method, envir = parent.frame()) {
    addNamespaceS3method <- function(ns, generic, class, method) {
	regs <- rbind(.getNamespaceInfo(ns, "S3methods"),
		      c(generic, class, method, NA_character_))
        setNamespaceInfo(ns, "S3methods", regs)
    }
    groupGenerics <- c("Math", "Ops", "matrixOps", "Summary", "Complex")
    defenv <- if(genname %in% groupGenerics) .BaseNamespaceEnv
    else {
        genfun <- get(genname, envir = envir)
        if(.isMethodsDispatchOn() && methods::is(genfun, "genericFunction"))
            genfun <- methods::finalDefaultMethod(genfun@default)
        if (typeof(genfun) == "closure") environment(genfun)
	else .BaseNamespaceEnv
    }
    if (is.null(table <- defenv[[".__S3MethodsTable__."]])) {
	table <- new.env(hash = TRUE, parent = baseenv())
	defenv[[".__S3MethodsTable__."]] <- table
    }

    if (is.character(method)) {
        assignWrapped <- function(x, method, home, envir) {
            method <- method            # force evaluation
            home <- home                # force evaluation
            delayedAssign(x, get(method, envir = home), assign.env = envir)
        }
        if(!exists(method, envir = envir)) {
            ## need to avoid conflict with any(notex) warning message
            warning(gettextf("S3 method %s was declared but not found",
                             sQuote(method)), call. = FALSE)
        } else {
	    assignWrapped(paste(genname, class, sep = "."), method, home = envir,
			  envir = table)
        }
    }
    else if (is.function(method))
        assign(paste(genname, class, sep = "."), method, envir = table)
    else stop("bad method")
    if (isNamespace(envir) && ! identical(envir, .BaseNamespaceEnv))
        addNamespaceS3method(envir, genname, class, method)
}


registerS3methods <- function(info, package, env)
{
    n <- NROW(info)
    if(n == 0L) return()

    assignWrapped <- function(x, method, home, envir) {
	method <- method            # force evaluation
	home <- home                # force evaluation
	delayedAssign(x, get(method, envir = home), assign.env = envir)
    }
    overwrite <- matrix(NA_character_, 0, 2)
    .registerS3method <- function(genname, class, method, nm, envir)
    {
        ## S3 generics should either be imported explicitly or be in
        ## the base namespace, so we start the search at the imports
        ## environment, parent.env(envir), which is followed by the
        ## base namespace.  (We have already looked in the namespace.)
        ## However, in case they have not been imported, we first
        ## look up where some commonly used generics are (including the
        ## group generics).
        defenv <- if(!is.na(w <- .knownS3Generics[genname])) asNamespace(w)
        else {
	    if(is.null(genfun <- get0(genname, envir = parent.env(envir))))
		stop(gettextf("object '%s' not found whilst loading namespace '%s'",
			      genname, package), call. = FALSE, domain = NA)
            if(.isMethodsDispatchOn() && methods::is(genfun, "genericFunction"))
		genfun <- genfun@default  # nearly always, the S3 generic
            if (typeof(genfun) == "closure") environment(genfun)
            else .BaseNamespaceEnv
        }
	if (is.null(table <- defenv[[".__S3MethodsTable__."]])) {
	    table <- new.env(hash = TRUE, parent = baseenv())
	    defenv[[".__S3MethodsTable__."]] <- table
	}
        ## Use tryCatch in case lazy loading promise has gone stale
        ## from unloading/changing/reinstalling (PR16644).
        ## This might make unloading work marginally better; still
        ## safest to restart
        e <- tryCatch(table[[nm]], error = function(e) NULL)
        if(!is.null(e) &&
           !identical(e, get(method, envir = envir))) {
            current <- environmentName(environment(e))
            overwrite <<- rbind(overwrite, c(as.vector(nm), current))
        }
	assignWrapped(nm, method, home = envir, envir = table)
    }

    methname <- paste(info[,1], info[,2], sep = ".")
    z <- is.na(info[,3])
    info[z,3] <- methname[z]
    ## Simpler to re-arrange so that packages for delayed registration
    ## come in the last column, and the non-delayed registration code
    ## can remain unchanged.
    if(ncol(info) == 3L)
        info <- cbind(info, NA_character_)
    Info <- cbind(info[, 1L:3L, drop = FALSE], methname, info[, 4L])
    loc <- names(env)
    if(any(notex <- match(info[,3L], loc, nomatch=0L) == 0L)) { # not %in%
      ## Try harder, as in registerS3method(); parent since *not* in env:
      found <- vapply(info[notex, 3L], exists, logical(1), envir = parent.env(env))
      notex[notex] <- !found
      if(any(notex)) {
        warning(sprintf(ngettext(sum(notex),
                                 "S3 method %s was declared in NAMESPACE but not found",
                                 "S3 methods %s were declared in NAMESPACE but not found"),
                        paste(sQuote(info[notex, 3]), collapse = ", ")),
                call. = FALSE, domain = NA)
        Info <- Info[!notex, , drop = FALSE]
      }
    }
    eager <- is.na(Info[, 5L])
    delayed <- Info[!eager, , drop = FALSE]
    Info    <- Info[ eager, , drop = FALSE]

    ## Do local generics first (this could be load-ed if pre-computed).
    ## However, the local generic could be an S4 takeover of a non-local
    ## (or local) S3 generic.  We can't just pass S4 generics on to
    ## .registerS3method as that only looks non-locally (for speed).
    l2 <- localGeneric <- Info[,1] %in% loc
    if(.isMethodsDispatchOn())
        for(i in which(localGeneric)) {
            genfun <- get(Info[i, 1], envir = env)
            if(methods::is(genfun, "genericFunction")) {
                localGeneric[i] <- FALSE
                registerS3method(Info[i, 1], Info[i, 2], Info[i, 3], env)
            }
        }
    if(any(localGeneric)) {
        lin <- Info[localGeneric, , drop = FALSE]
        S3MethodsTable <- env[[".__S3MethodsTable__."]]
        ## we needed to move this to C for speed.
        ## for(i in seq_len(nrow(lin)))
        ##    assign(lin[i,4], get(lin[i,3], envir = env),
        ##           envir = S3MethodsTable)
        .Internal(importIntoEnv(S3MethodsTable, lin[,4], env, lin[,3]))
    }

    ## now the rest
    fin <- Info[!l2, , drop = FALSE]
    for(i in seq_len(nrow(fin)))
        .registerS3method(fin[i, 1], fin[i, 2], fin[i, 3], fin[i, 4], env)
    if(package != "MASS" && nrow(overwrite)) {
        ## MASS is providing methods for stubs in stats.
        .fmt <- function(o) {
            sprintf("  %s %s",
                    format(c("method", o[, 1L])),
                    format(c("from",   o[, 2L])))
        }
        ## Unloading does not unregister, so reloading "overwrites":
        ## hence, always drop same-package overwrites.
        overwrite <-
            overwrite[overwrite[, 2L] != package, , drop = FALSE]
        ## (Seen e.g. for recommended packages in reg-tests-3.R.)
        if(Sys.getenv("_R_LOAD_CHECK_OVERWRITE_S3_METHODS_") %in% c(package, "all")) {
            ind <- overwrite[, 2L] %in%
                unlist(tools:::.get_standard_package_names(),
                       use.names = FALSE)
            bad <- overwrite[ind, , drop = FALSE]
            if(nr <- nrow(bad)) {
                msg <- ngettext(nr,
                                "Registered S3 method from a standard package overwritten by '%s':",
                                "Registered S3 methods from standard package(s) overwritten by '%s':",
                                domain = NA)
                msg <- paste(c(sprintf(msg, package), .fmt(bad)),
                             collapse = "\n")
                message(msg, domain = NA)
                overwrite <- overwrite[!ind, , drop = FALSE]
            }
        }
        ## Do not note when
        ## * There are no overwrites (left)
        ## * Env var _R_S3_METHOD_REGISTRATION_NOTE_OVERWRITES_ is set
        ##   to something false (for the time being)
        ## * Env var _R_CHECK_PACKAGE_NAME_ is set to something
        ##   different than 'package'.
        ## With the last, when checking we only note overwrites from the
        ## package under check (as recorded via _R_CHECK_PACKAGE_NAME_).
        if((nr <- nrow(overwrite)) &&
           is.na(match(tolower(Sys.getenv("_R_S3_METHOD_REGISTRATION_NOTE_OVERWRITES_")),
                       c("0", "no", "false"))) &&
           (!is.na(match(Sys.getenv("_R_CHECK_PACKAGE_NAME_"),
                         c("", package))))) {
            msg <- ngettext(nr,
                            "Registered S3 method overwritten by '%s':",
                            "Registered S3 methods overwritten by '%s':",
                            domain = NA)
            msg <- paste(c(sprintf(msg, package), .fmt(overwrite)),
                         collapse = "\n")
            packageStartupMessage(msg, domain = NA)
        }
    }

    register_S3_method_delayed <- function(pkg, gen, cls, fun) {
        pkg <- pkg                      # force evaluation
        gen <- gen                      # force evaluation
        cls <- cls                      # force evaluation
        fun <- fun                      # force evaluation
        if(isNamespaceLoaded(pkg)) {
            registerS3method(gen, cls, fun,
                             envir = asNamespace(pkg))
        }
        setHook(packageEvent(pkg, "onLoad"),
                function(...) {
                    registerS3method(gen, cls, fun,
                                     envir = asNamespace(pkg))
                })
    }
    if(nrow(delayed)) {
        for(i in seq_len(nrow(delayed))) {
            gen <- delayed[i, 1L]
            cls <- delayed[i, 2L]
            fun <- get(delayed[i, 3L], envir = env)
            pkg <- delayed[i, 5L]
            register_S3_method_delayed(pkg, gen, cls, fun)
        }
    }

    ## Provide useful error message to user in case of ncol() mismatch:
    nsI <- getNamespaceInfo(env, "S3methods")
    if(!is.null(p1 <- ncol(nsI)) && !is.null(p2 <- ncol(info)) && p1 != p2)
        stop(gettextf(
            paste('While loading namespace "%s": "%s" differ in ncol(.), env=%d, newNS=%d.',
                  "Maybe package installed with version of R newer than %s ?",
                  sep="\n"),
            package, "S3methods", p1, p2, getRversion()), domain = NA)
    setNamespaceInfo(env, "S3methods", rbind(info, nsI))
}

.mergeImportMethods <- function(impenv, expenv, metaname)
{
    impMethods <- impenv[[metaname]]
    if(!is.null(impMethods))
	impenv[[metaname]] <-
	    methods:::.mergeMethodsTable2(impMethods,
					  newtable = expenv[[metaname]], # known to exist by caller
					  expenv, metaname)
    impMethods # possibly NULL
}

.S3method <- function(generic, class, method) {
    if(missing(method)) method <- paste(generic, class, sep = ".")
    method <- match.fun(method)
    registerS3method(generic, class, method, envir = parent.frame())
    invisible(NULL)
}