#  File src/library/base/R/namespace.R
#  Part of the R package, http://www.R-project.org
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2 of the License, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#
#  A copy of the GNU General Public License is available at
#  http://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) {
    ns <- .Internal(getRegisteredNamespace(as.name(name)))
    if (! is.null(ns)) ns
    else tryCatch(loadNamespace(name), error = function(e) stop(e))
}

loadedNamespaces <- function()
    ls(.Internal(getNamespaceRegistry()), all.names = TRUE)

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)
    if (isBaseNamespace(ns)) ls(.BaseNamespaceEnv, all.names = TRUE)
    else ls(getNamespaceInfo(ns, "exports"), all.names = TRUE)
}

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

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

getExportedValue <- function(ns, name) {
    getInternalExportName <- function(name, ns) {
        exports <- getNamespaceInfo(ns, "exports")
        if (! exists(name, envir = exports, inherits = FALSE))
            stop(gettextf("'%s' is not an exported object from 'namespace:%s'",
                          name, getNamespaceName(ns)),
                 call. = FALSE, domain = NA)
        get(name, envir = exports, inherits = FALSE)
    }
    ns <- asNamespace(ns)
    if (isBaseNamespace(ns)) get(name, envir = ns, inherits = FALSE)
    else get(getInternalExportName(name, ns), envir = ns)
}

"::" <- function(pkg, name) {
    pkg <- as.character(substitute(pkg))
    name <- as.character(substitute(name))
    ns <- tryCatch(asNamespace(pkg), hasNoNamespaceError = function(e) NULL)
    if (is.null(ns)) {
        pos <- match(paste("package", pkg, sep=":"), search(), 0L)
        if (pos == 0)
            stop(gettextf("package %s has no name space and is not on the search path", sQuote(pkg)), domain = NA)
        get(name, pos = pos, inherits = FALSE)
    }
    else getExportedValue(pkg, name)
}

":::" <- function(pkg, name) {
    pkg <- as.character(substitute(pkg))
    name <- as.character(substitute(name))
    get(name, envir = asNamespace(pkg), inherits = FALSE)
}

attachNamespace <- function(ns, pos = 2, dataPath = NULL, depends = NULL)
{
    runHook <- function(hookname, env, ...)
        if (exists(hookname, envir = env, inherits = FALSE)) {
            fun <- get(hookname, envir = env, inherits = FALSE)
            res <- tryCatch(fun(...), 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)
            }
        }

    ns <- asNamespace(ns, base.OK = FALSE)
    nsname <- getNamespaceName(ns)
    nspath <- getNamespaceInfo(ns, "path")
    attname <- paste("package", nsname, sep = ":")
    if (attname %in% search())
        stop("name space is already attached")
    env <- attach(NULL, pos = pos, name = attname)
    ## we do not want to run e.g. .Last.lib here
    on.exit(.Internal(detach(pos)))
    attr(env, "path") <- nspath
    exports <- getNamespaceExports(ns)
    importIntoEnv(env, exports, ns, exports)
    if(!is.null(dataPath)) {
        dbbase <- file.path(dataPath, "Rdata")
        if(file.exists(paste(dbbase, ".rdb", sep = ""))) lazyLoad(dbbase, env)
    }
    if(length(depends)) assign(".Depends", depends, env)
    runHook(".onAttach", ns, dirname(nspath), nsname)
    lockEnvironment(env, TRUE)
    on.exit()
    invisible(env)
}

loadNamespace <- function (package, lib.loc = NULL,
                           keep.source = getOption("keep.source.pkgs"),
                           partial = FALSE, declarativeOnly = FALSE)
{
    ## eventually allow version as second component; ignore for now.
    package <- as.character(package)[[1L]]

    ## check for cycles
    dynGet <- function(name,
                       notFound = stop(gettextf("%s not found", name),
                       domain = NA))
    {
        n <- sys.nframe()
        while (n > 1) {
            n <- n - 1
            env <- sys.frame(n)
            if (exists(name, envir = env, inherits = FALSE))
                return(get(name, envir = env, inherits = FALSE))
        }
        notFound
    }
    loading <- dynGet("__NameSpacesLoading__", NULL)
    if (match(package, loading, 0L))
        stop("cyclic name space dependencies are not supported")
    "__NameSpacesLoading__" <- c(package, loading)

    ns <- .Internal(getRegisteredNamespace(as.name(package)))
    if (! is.null(ns))
        ns
    else {
        runHook <- function(hookname, pkgname, env, ...) {
            if (exists(hookname, envir = env, inherits = FALSE)) {
                fun <- get(hookname, envir = env, inherits = FALSE)
                res <- tryCatch(fun(...), 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) {
            hook <- getHook(packageEvent(pkgname, "onLoad")) # might be list()
            for(fun in hook) try(fun(pkgname, pkgpath))
        }
        makeNamespace <- function(name, version = NULL, lib = NULL) {
            impenv <- new.env(parent = .BaseNamespaceEnv, hash = TRUE)
            attr(impenv, "name") <- paste("imports", name, sep=":")
            env <- new.env(parent = impenv, hash = TRUE)
            name <- as.character(as.name(name))
            version <- as.character(version)
            info <- new.env(hash = TRUE, parent = baseenv())
            assign(".__NAMESPACE__.", info, envir = env)
            assign("spec", c(name = name,version = version), envir = info)
            setNamespaceInfo(env, "exports", new.env(hash = TRUE, parent = baseenv()))
            setNamespaceInfo(env, "imports", list("base" = TRUE))
            ## this should be an absolute path
            abs_path <- function(x) {cwd <- setwd(x);on.exit(setwd(cwd));getwd()}
            setNamespaceInfo(env, "path", abs_path(file.path(lib, name)))
            setNamespaceInfo(env, "dynlibs", NULL)
            setNamespaceInfo(env, "S3methods", matrix(NA_character_, 0L, 3L))
            assign(".__S3MethodsTable__.",
                   new.env(hash = TRUE, parent = baseenv()),
                   envir = env)
            .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",
                              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)
        {
            popath <- file.path(pkgpath, "po")
            if(!file.exists(popath)) return()
            bindtextdomain(pkgname, popath)
            bindtextdomain(paste("R", pkgname, sep = "-"), popath)
        }

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

            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 <- paste(fixes[1L], sym$name, fixes[2L], sep = "")
                                     if(exists(varName, envir = env))
                                       warning("failed to assign RegisteredNativeSymbol for ",
                                               sym$name,
                                               paste(" to", varName),
                                               " since ", varName,
                                               " is already defined in the ", package,
                                               " namespace")
                                     else
                                       assign(varName, sym, envir = env)
                                 })
                      })

             }

            symNames <- nativeRoutines$symbolNames
            if(length(symNames) == 0L)
              return(NULL)

            symbols <- getNativeSymbolInfo(symNames, dll, unlist = FALSE,
                                               withRegistrationInfo = TRUE)
            sapply(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))
                           warning("failed to assign NativeSymbolInfo for ",
                                   origVarName,
                                   ifelse(origVarName != varName,
                                              paste(" to", varName), ""),
                                   " since ", varName,
                                   " is already defined in the ", package,
                                   " namespace")
                           else
                              assign(varName, symbols[[origVarName]],
                                     envir = env)

                    })



            symbols
          }

        ## find package and check it has a name space
        pkgpath <- .find.package(package, lib.loc, quiet = TRUE)
        if (length(pkgpath) == 0L)
            stop(gettextf("there is no package called '%s'", package),
                 domain = NA)
        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 name space",
                                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 on
        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"]
            if(is.null(built <- pkgInfo$Built))
                stop(gettextf("package '%s' has not been installed properly\n",
                              basename(pkgpath)),
                     call. = FALSE, domain = NA)
            R_version_built_under <- as.numeric_version(built$R)
            if(R_version_built_under < "2.10.0")
                stop(gettextf("package '%s' was built before R 2.10.0: please re-install it",
                              basename(pkgpath)), 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% names(pkgInfo$Depends)
            if(dependsMethods) loadNamespace("methods")
        }
        ns <- makeNamespace(package, version = version, lib = package.lib)
        on.exit(.Internal(unregisterNamespace(package)))

        ## process imports
        for (i in nsInfo$imports) {
            if (is.character(i))
                namespaceImport(ns, loadNamespace(i, c(lib.loc, .libPaths())))
            else
                namespaceImportFrom(ns,
                                    loadNamespace(i[[1L]],
                                                  c(lib.loc, .libPaths())),
                                    i[[2L]])
        }
        for(imp in nsInfo$importClasses)
            namespaceImportClasses(ns, loadNamespace(imp[[1L]],
                                                     c(lib.loc, .libPaths())),
                                   imp[[2L]])
        for(imp in nsInfo$importMethods)
            namespaceImportMethods(ns, loadNamespace(imp[[1L]],
                                                     c(lib.loc, .libPaths())),
                                   imp[[2L]])



        ## dynamic variable to allow/disable .Import and friends
        "__NamespaceDeclarativeOnly__" <- declarativeOnly

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

        env <- asNamespace(ns)
        ## save the package name in the environment
        assign(".packageName", package, envir = env)

        ## load the code
        codename <- strsplit(package, "_", fixed = TRUE)[[1L]][1L]
        codeFile <- file.path(pkgpath, "R", codename)
        if (file.exists(codeFile)) {
            res <- try(sys.source(codeFile, env, keep.source = keep.source))
            if(inherits(res, "try-error"))
                stop(gettextf("unable to load R code in package '%s'", package),
                     call. = FALSE, domain = NA)
        } else warning(gettextf("package '%s' contains no R code", package),
                       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(paste(dbbase, ".rdb", sep = ""))) lazyLoad(dbbase, env)

        ## register any S3 methods
        registerS3methods(nsInfo$S3methods, package, env)

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

            ## 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))
               && names(nsInfo$dynlibs)[i] != "")
                assign(names(nsInfo$dynlibs)[i], dlls[[lib]], envir = env)
            setNamespaceInfo(env, "DLLs", dlls)
        }
        addNamespaceDynLibs(env, nsInfo$dynlibs)


        ## run the load hook
        runHook(".onLoad", package, env, package.lib, 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() && methods:::.hasS4MetaData(ns) &&
           !identical(package, "methods") ) {
            ## cache generics, classes in this namespace (but not methods itself,
            ## which pre-cached at install time
            methods:::cacheMetaData(ns, TRUE, ns)
            ## process class definition objects
            expClasses <- nsInfo$exportClasses
            ##we take any pattern, but check to see if the matches are classes
            pClasses <- character(0L)
            aClasses <- methods:::getClasses(ns)
            for (p in nsInfo$exportClassPatterns) {
                pClasses <- c(aClasses[grep(p, aClasses)], pClasses)
            }
            pClasses <- unique(pClasses)
            if( length(pClasses) ) {
                good <- sapply(pClasses, methods:::isClass, where = ns)
                if( !any(good) )
                    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 <-
                    !sapply(expClasses, methods:::isClass, 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 <- paste(methods:::classMetaName(""), expClasses,
                                    sep = "")
            }
            ## 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
            expTables <- character()
            expMLists <- 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",
                                  package,
                                  paste(expMethods[missingMethods],
                                        collapse = ", ")),
                         domain = NA)
                ## Deprecated note:  the mlistPattern objects are deprecated in 2.7.0
                ## and will disappear later.  For now, deal with them if they exist
                ## but don't complain if they do not.
                mlistPattern <- methods:::methodsPackageMetaName("M","")
                allMethodLists <-
                    unique(c(methods:::.getGenerics(ns, mlistPattern),
                             methods:::.getGenerics(parent.env(ns),
                                                    mlistPattern)))
                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 <- logical(length(pm))
                    for(i in seq_along(prim)) {
                        f <- methods:::getFunction(pm[[i]], FALSE, FALSE, ns)
                        prim[[i]] <- is.primitive(f)
                    }
                    expMethods <- c(expMethods, pm[prim])
                }
                for(i in seq_along(expMethods)) {
                    mi <- expMethods[[i]]
                    if(!(mi %in% exports) &&
                       exists(mi, envir = ns, mode = "function",
                              inherits = FALSE))
                        exports <- c(exports, mi)
                    pattern <- paste(tPrefix, mi, ":", sep="")
                    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]
                        if(exists(allMethodLists[[ii]], envir = ns))
                            expMLists <- c(expMLists, allMethodLists[[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 <- c(exports, expClasses,  expTables, expMLists)
        }
        namespaceExport(ns, exports)
        sealNamespace(ns)
        ## run user hooks here
        runUserHook(package, file.path(package.lib, package))
        on.exit()
        ns
    }
}

loadingNamespaceInfo <- function() {
    dynGet <- function(name, notFound = stop(name, " not found")) {
        n <- sys.nframe()
        while (n > 1) {
            n <- n - 1
            env <- sys.frame(n)
            if (exists(name, envir = env, inherits = FALSE))
                return(get(name, envir = env, inherits = FALSE))
        }
        notFound
    }
    dynGet("__LoadingNamespaceInfo__", stop("not loading a name space"))
}

topenv <- function(envir = parent.frame(),
                   matchThisEnv = getOption("topLevelEnvironment")) {
    while (! identical(envir, emptyenv())) {
        nm <- attributes(envir)[["names", exact = TRUE]]
        if ((is.character(nm) && length(grep("^package:" , nm))) ||
	    ## matchThisEnv is used in sys.source
            identical(envir, matchThisEnv) ||
            identical(envir, .GlobalEnv) ||
            identical(envir, baseenv()) ||
            .Internal(isNamespaceEnv(envir)) ||
	    ## packages except base and those with a separate namespace have .packageName
            exists(".packageName", envir = envir, inherits = FALSE))
            return(envir)
        else envir <- parent.env(envir)
    }
    return(.GlobalEnv)
}

unloadNamespace <- function(ns)
{
    ## only used to run .onUnload
    runHook <- function(hookname, env, ...) {
        if (exists(hookname, envir = env, inherits = FALSE)) {
            fun <- get(hookname, envir = env, inherits = FALSE)
            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(paste("package", nsname, sep = ":"), search())
    if (! is.na(pos)) detach(pos = pos)
    users <- getNamespaceUsers(ns)
    if (length(users))
        stop(gettextf("name space %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)
    .Call("R_lazyLoadDBflush",
          paste(nspath, "/R/", nsname, ".rdb", sep=""),
          PACKAGE="base")
    invisible()
}

.Import <- function(...) {
    dynGet <- function(name, notFound = stop(name, " not found")) {
        n <- sys.nframe()
        while (n > 1) {
            n <- n - 1
            env <- sys.frame(n)
            if (exists(name, envir = env, inherits = FALSE))
                return(get(name, envir = env, inherits = FALSE))
        }
        notFound
    }
    if (dynGet("__NamespaceDeclarativeOnly__", FALSE))
        stop("imperative name space directives are disabled")
    envir <- parent.frame()
    names <- as.character(substitute(list(...)))[-1L]
    for (n in names)
        namespaceImportFrom(envir, n)
}

.ImportFrom <- function(name, ...) {
    dynGet <- function(name, notFound = stop(name, " not found")) {
        n <- sys.nframe()
        while (n > 1) {
            n <- n - 1
            env <- sys.frame(n)
            if (exists(name, envir = env, inherits = FALSE))
                return(get(name, envir = env, inherits = FALSE))
        }
        notFound
    }
    if (dynGet("__NamespaceDeclarativeOnly__", FALSE))
        stop("imperative name space directives are disabled")
    envir <- parent.frame()
    name <-  as.character(substitute(name))
    names <- as.character(substitute(list(...)))[-1L]
    namespaceImportFrom(envir, name, names)
}

.Export <- function(...) {
    dynGet <- function(name, notFound = stop(name, " not found")) {
        n <- sys.nframe()
        while (n > 1) {
            n <- n - 1
            env <- sys.frame(n)
            if (exists(name, envir = env, inherits = FALSE))
                return(get(name, envir = env, inherits = FALSE))
        }
        notFound
    }
    if (dynGet("__NamespaceDeclarativeOnly__", FALSE))
        stop("imperative name space directives are disabled")
    ns <- topenv(parent.frame(), NULL)
    if (identical(ns, .BaseNamespaceEnv))
        warning("all objects in base name space are currently exported.")
    else if (! isNamespace(ns))
        stop("can only export from a name space")
    else {
        names <- as.character(substitute(list(...)))[-1L]
        namespaceExport(ns, names)
    }
}

.S3method <- function(generic, class, method) {
    dynGet <- function(name, notFound = stop(name, " not found")) {
        n <- sys.nframe()
        while (n > 1) {
            n <- n - 1
            env <- sys.frame(n)
            if (exists(name, envir = env, inherits = FALSE))
                return(get(name, envir = env, inherits = FALSE))
        }
        notFound
    }
    if (dynGet("__NamespaceDeclarativeOnly__", FALSE))
        stop("imperative name space directives are disabled")
    generic <- as.character(substitute(generic))
    class <- as.character(substitute(class))
    if (missing(method)) method <- paste(generic, class, sep = ".")
    registerS3method(generic, class, method, envir = parent.frame())
    invisible(NULL)
}

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

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

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

setNamespaceInfo <- function(ns, which, val) {
    ns <- asNamespace(ns, base.OK = FALSE)
    info <- get(".__NAMESPACE__.", envir = ns, inherits = FALSE)
    assign(which, val, envir = info)
}

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

namespaceImport <- function(self, ...)
    for (ns in list(...)) namespaceImportFrom(self, asNamespace(ns))

namespaceImportFrom <- function(self, ns, vars, generics, packages)
{
    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 new[new == ""] <- old[new == ""]
        names(old) <- new
        old
    }
    whichMethodMetaNames <- function(impvars) {
        if(!.isMethodsDispatchOn())
            return(numeric())
        mm <- ".__T__"
        seq_along(impvars)[substr(impvars, 1L, nchar(mm, type = "c")) == mm]
    }
    if (is.character(self))
        self <- getNamespace(self)
    ns <- asNamespace(ns)
    nsname <- getNamespaceName(ns)
    impvars <- if (missing(vars)) getNamespaceExports(ns) else vars
    impvars <- makeImportExportNames(impvars)
    impnames <- names(impvars)
    if (anyDuplicated(impnames)) {
        stop("duplicate import names ",
             paste(impnames[duplicated(impnames)], collapse = ", "))
    }
    if (isNamespace(self) && isBaseNamespace(self)) {
        impenv <- self
        msg <- gettext("replacing local value with import %s when loading %s")
        register <- FALSE
    }
    else if (isNamespace(self)) {
        if (namespaceIsSealed(self))
            stop("cannot import into a sealed name space")
        impenv <- parent.env(self)
        msg <- gettext("replacing previous import %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)
		## eventually mlist objects will disappear, for now
		## just don't import any duplicated names
		mlname = sub("__T__", "__M__", impvars[[i]], fixed=TRUE)
		ii = match(mlname, impvars, 0L)
		if(ii > 0)
		    delete <- c(delete, ii)
		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 (exists(n, envir = impenv, inherits = FALSE)) {
	    if (.isMethodsDispatchOn() && methods:::isGeneric(n, ns)) {
		## warn only if generic overwrites a function which
		## it was not derived from
		genNs <- get(n, envir = ns)@package
		genImpenv <- environmentName(environment(get(n, envir = impenv)))
		if (!identical(genNs, genImpenv) ||
		    ## warning if generic overwrites another generic
		    methods:::isGeneric(n, impenv)) {}
                else next
	    }
            ## this is always called from another function, so reporting call
            ## is unhelpful
            warning(sprintf(msg, sQuote(n), sQuote(nsname)),
                    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) {
    for(i in seq_along(vars))
        vars[[i]] <- methods:::classMetaName(vars[[i]])
    namespaceImportFrom(self, asNamespace(ns), vars)
}

namespaceImportMethods <- function(self, ns, vars) {
    allVars <- character()
    allFuns <- methods:::.getGenerics(ns)
    packages <- attr(allFuns, "package")
    tPrefix <- methods:::.TableMetaPrefix()
    pkg <- methods:::getPackageName(ns)
    allMethodTables <- methods:::.getGenerics(ns, tPrefix)
    if(any(is.na(match(vars, allFuns))))
        stop(gettextf("requested methods not found in environment/package %s: %s",
                      sQuote(pkg),
                      paste(vars[is.na(match(vars, allFuns))],
                            collapse = ", ")), call. = FALSE, domain = NA)
    for(i in seq_along(allFuns)) {
        ## import methods list objects if asked for
        ## or if the corresponding generic was imported
        g <- allFuns[[i]]
        if(exists(g, envir = self, inherits = FALSE) # already imported
           || g %in% vars) { # requested explicitly
            tbl <- methods:::.TableMetaName(g, packages[[i]])
            if(is.null(.mergeImportMethods(self, ns, tbl))) # a new methods table
               allVars <- c(allVars, tbl) # import it;else, was merged
        }
        if(g %in% vars && !exists(g, envir = self, inherits = FALSE) &&
           exists(g, envir = ns, inherits = FALSE) &&
           methods:::is(get(g, envir = ns), "genericFunction"))
            allVars <- c(allVars, g)
    }
    namespaceImportFrom(self, asNamespace(ns), allVars, allFuns, packages)
}

importIntoEnv <- function(impenv, impnames, expenv, expnames) {
    exports <- getNamespaceInfo(expenv, "exports")
    ex <- .Internal(ls(exports, TRUE))
    if(!all(expnames %in% ex)) {
        miss <- expnames[! expnames %in% ex]
        ## if called (indirectly) for namespaceImportClasses
        ## these are all classes
        if(all(grepl("^\\.__C__", miss))) {
            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(paste('"', miss, '"', sep = ""),
                               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(lapply(expnames, get, envir = exports, inherits = FALSE))
    if (is.null(impnames)) impnames <- character(0L)
    if (is.null(expnames)) expnames <- character(0L)
    .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 name space")
    ns <- asNamespace(ns, base.OK = FALSE)
    if (length(vars)) {
        addExports <- function(ns, new) {
            exports <- getNamespaceInfo(ns, "exports")
            expnames <- names(new)
            intnames <- new
            objs <- .Internal(ls(exports, TRUE))
            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)
            for (i in seq_along(new))
                assign(expnames[i], intnames[i], envir = exports)
        }
        makeImportExportNames <- function(spec) {
            old <- as.character(spec)
            new <- names(spec)
            if (is.null(new)) new <- old
            else new[new == ""] <- old[new == ""]
            names(old) <- new
            old
        }
        new <- makeImportExportNames(unique(vars))
        ## calling exists each time is too slow, so do two phases
        undef <- new[! new %in% .Internal(ls(ns, TRUE))]
        if (length(undef)) { # avoid list result from sapply
            undef <- undef[! sapply(undef, exists, envir = ns)]
            if (length(undef)) {
                undef <- do.call("paste", as.list(c(undef, sep = ", ")))
                stop("undefined exports: ", undef)
            }
        }
        if(.isMethodsDispatchOn()) .mergeExportMethods(new, ns)
        addExports(ns, new)
    }
}

.mergeExportMethods <- function(new, ns) {
##    if(!.isMethodsDispatchOn()) return(FALSE)
    mm <- methods:::methodsPackageMetaName("M","")
    newMethods <- new[substr(new, 1L, nchar(mm, type = "c")) == mm]
    nsimports <- parent.env(ns)
    for(what in newMethods) {
        if(exists(what, envir = nsimports, inherits = FALSE)) {
            m1 <- get(what, envir = nsimports)
            m2 <- get(what, envir = ns)
            assign(what, envir = ns, methods:::mergeMethods(m1, m2))
        }
    }
}


## NB this needs a decorated name, foo_ver, if appropriate
packageHasNamespace <- function(package, package.lib) {
    namespaceFilePath <- function(package, package.lib)
        file.path(package.lib, package, "NAMESPACE")
    file.exists(namespaceFilePath(package, package.lib))
}

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(0L))
            class(proto) <- "NativeRoutineMap"

            mergeNativeRoutineMaps(proto, useRegistration, symbolNames, fixes)
        }

    mergeNativeRoutineMaps <-
        ## Merges new settings into a NativeRoutineMap
        function(map, useRegistration, symbolNames, fixes) {
            if(!useRegistration)
                names(symbolNames) <-
                    paste(fixes[1L],  names(symbolNames), fixes[2L], sep = "")
            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 <- NA
    if (file.exists(descfile)) {
        dcf <- read.dcf(file = descfile)
        if(NROW(dcf) >= 1) enc <- as.list(dcf[1, ])[["Encoding"]]
        if(is.null(enc)) enc <- NA
    }
    if (file.exists(nsFile))
        directives <- if (!is.na(enc) &&
                          ! Sys.getlocale("LC_CTYPE") %in% c("C", "POSIX")) {
	    con <- file(nsFile, encoding=enc)
            on.exit(close(con))
	    parse(con)
        } else parse(nsFile)
    else if (mustExist)
        stop(gettextf("package '%s' has no NAMESPACE file", package),
             domain = NA)
    else directives <- NULL
    exports <- character(0L)
    exportPatterns <- character(0L)
    exportClasses <- character(0L)
    exportClassPatterns <- character(0L)
    exportMethods <- character(0L)
    imports <- list()
    importMethods <- list()
    importClasses <- list()
    dynlibs <- character(0L)
    S3methods <- matrix(NA_character_, 500L, 3L)
    nativeRoutines <- list()
    nS3 <- 0
    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
	}
        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 = imports <<- c(imports,as.list(asChar(e[-1L]))),
               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)) &&
                                        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("duplicated symbol names %s in useDynlib(\"%s\")", paste(names(symNames)[dup], collapse = ", "), dyl),
                                   domain = NA)

                       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(symNames[idx] != "") {
                               e <- parse(text = symNames[idx])[[1L]]
                               if(is.call(e))
                                   val <- eval(e)
                               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 > 500L)
                       stop("too many 'S3method' directives", call. = FALSE)
                   S3methods[nS3, seq_along(spec)] <<- asChar(spec)
               },
               warning(gettextf("unknown namespace directive: %s", deparse(e, nlines=1L)),
                    call. = FALSE, domain = NA)
               )
    }
    for (e in directives)
        parseDirective(e)

    dynlibs <- unique(dynlibs)
    list(imports = imports, exports = exports, exportPatterns = exportPatterns,
         importClasses = importClasses, importMethods = importMethods,
         exportClasses = exportClasses,  exportMethods = exportMethods,
         exportClassPatterns = exportClassPatterns,
         dynlibs = dynlibs, nativeRoutines = nativeRoutines,
         S3methods = S3methods[seq_len(nS3), ,drop = FALSE])
} ## end{parseNamespaceFile}

registerS3method <- function(genname, class, method, envir = parent.frame()) {
    addNamespaceS3method <- function(ns, generic, class, method) {
        regs <- getNamespaceInfo(ns, "S3methods")
        regs <- rbind(regs, c(generic, class, method))
        setNamespaceInfo(ns, "S3methods", regs)
    }
    groupGenerics <- c("Math", "Ops",  "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 (! exists(".__S3MethodsTable__.", envir = defenv, inherits = FALSE))
        assign(".__S3MethodsTable__.", new.env(hash = TRUE, parent = baseenv()),
               envir = defenv)
    table <- get(".__S3MethodsTable__.", envir = defenv, inherits = FALSE)
    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 message at l.1298
            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 == 0) return()

    assignWrapped <- function(x, method, home, envir) {
	method <- method            # force evaluation
	home <- home                # force evaluation
	delayedAssign(x, get(method, envir = home), assign.env = envir)
    }
    .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(!exists(genname, envir = parent.env(envir)))
                stop(gettextf("object '%s' not found whilst loading namespace '%s'",
                              genname, package), call. = FALSE, domain = NA)
            genfun <- get(genname, envir = parent.env(envir))
            if(.isMethodsDispatchOn() && methods:::is(genfun, "genericFunction")) {
		genfun <- methods:::finalDefaultMethod(genfun@default)
                warning(gettextf("found an S4 version of %s so it has not been imported correctly",
                                 sQuote(genname)), call. = FALSE, domain = NA)
            }
            if (typeof(genfun) == "closure") environment(genfun)
            else .BaseNamespaceEnv
        }
        if (! exists(".__S3MethodsTable__.", envir = defenv, inherits = FALSE))
            assign(".__S3MethodsTable__.", new.env(hash = TRUE, parent = baseenv()),
                   envir = defenv)
        table <- get(".__S3MethodsTable__.", envir = defenv, inherits = FALSE)
	assignWrapped(nm, method, home = envir, envir = table)
    }

    methname <- paste(info[,1], info[,2], sep = ".")
    z <- is.na(info[,3])
    info[z,3] <- methname[z]
    Info <- cbind(info, methname)
    loc <- .Internal(ls(env, TRUE))
    notex <- !(info[,3] %in% loc)
    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]

    ## 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 <-
            get(".__S3MethodsTable__.", envir = env, inherits = FALSE)
        ## 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)

    setNamespaceInfo(env, "S3methods",
                     rbind(info, getNamespaceInfo(env, "S3methods")))
}

.mergeImportMethods <- function(impenv, expenv, metaname)
{
    expMethods <- get(metaname, envir = expenv)
    if(exists(metaname, envir = impenv, inherits = FALSE)) {
        impMethods <- get(metaname, envir = impenv)
        assign(metaname,
               methods:::.mergeMethodsTable2(impMethods,
                                             expMethods, expenv, metaname),
               envir = impenv)
        impMethods
    } else NULL
}
