1# File src/library/base/R/namespace.R 2# Part of the R package, https://www.R-project.org 3# 4# Copyright (C) 1995-2021 The R Core Team 5# 6# This program is free software; you can redistribute it and/or modify 7# it under the terms of the GNU General Public License as published by 8# the Free Software Foundation; either version 2 of the License, or 9# (at your option) any later version. 10# 11# This program is distributed in the hope that it will be useful, 12# but WITHOUT ANY WARRANTY; without even the implied warranty of 13# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14# GNU General Public License for more details. 15# 16# A copy of the GNU General Public License is available at 17# https://www.R-project.org/Licenses/ 18 19## give the base namespace a table for registered methods 20`.__S3MethodsTable__.` <- new.env(hash = TRUE, parent = baseenv()) 21 22## NOTA BENE: 23## 1) This code should work also when methods is not yet loaded 24## 2) We use ':::' instead of '::' inside the code below, for efficiency only 25 26getNamespace <- function(name) { 27 ns <- .Internal(getRegisteredNamespace(name)) 28 if (! is.null(ns)) ns 29 else loadNamespace(name) 30} 31 32.getNamespace <- function(name) .Internal(getRegisteredNamespace(name)) 33 34..getNamespace <- function(name, where) { 35 ns <- .Internal(getRegisteredNamespace(name)) 36 if (!is.null(ns)) ns 37 else tryCatch(loadNamespace(name), error = function(e) { 38 tr <- Sys.getenv("_R_NO_REPORT_MISSING_NAMESPACES_") 39 if( tr == "false" || (where != "<unknown>" && !nzchar(tr)) ) { 40 warning(gettextf("namespace %s is not available and has been replaced\nby .GlobalEnv when processing object %s", 41 sQuote(name)[1L], sQuote(where)), 42 domain = NA, call. = FALSE, immediate. = TRUE) 43 if(nzchar(Sys.getenv("_R_CALLS_MISSING_NAMESPACES_"))) 44 print(sys.calls()) 45 } 46 .GlobalEnv 47 }) 48} 49 50loadedNamespaces <- function() names(.Internal(getNamespaceRegistry())) 51 52isNamespaceLoaded <- function(name) .Internal(isRegisteredNamespace(name)) 53 54getNamespaceName <- function(ns) { 55 ns <- asNamespace(ns) 56 if (isBaseNamespace(ns)) "base" 57 else .getNamespaceInfo(ns, "spec")["name"] 58} 59 60getNamespaceVersion <- function(ns) { 61 ns <- asNamespace(ns) 62 if (isBaseNamespace(ns)) 63 c(version = paste(R.version$major, R.version$minor, sep = ".")) 64 else .getNamespaceInfo(ns, "spec")["version"] 65} 66 67getNamespaceExports <- function(ns) { 68 ns <- asNamespace(ns) 69 names(if(isBaseNamespace(ns)) .BaseNamespaceEnv 70 else .getNamespaceInfo(ns, "exports")) 71} 72 73getNamespaceImports <- function(ns) { 74 ns <- asNamespace(ns) 75 if (isBaseNamespace(ns)) NULL 76 else .getNamespaceInfo(ns, "imports") 77} 78 79getNamespaceUsers <- function(ns) { 80 nsname <- getNamespaceName(asNamespace(ns)) 81 users <- character() 82 for (n in loadedNamespaces()) { 83 inames <- names(getNamespaceImports(n)) 84 if (match(nsname, inames, 0L)) 85 users <- c(n, users) 86 } 87 users 88} 89 90getExportedValue <- function(ns, name) 91 .Internal(getNamespaceValue(ns, name, TRUE)) 92 93## NOTE: Both "::" and ":::" must signal an error for non existing objects 94## :: and ::: are now SPECIALSXP primitives. 95## `::` <- function(pkg, name) 96## .Internal(getNamespaceValue(substitute(pkg), substitute(name), TRUE)) 97## `:::` <- function(pkg, name) 98## .Internal(getNamespaceValue(substitute(pkg), substitute(name), FALSE)) 99 100attachNamespace <- function(ns, pos = 2L, depends = NULL, exclude, include.only) 101{ 102 ## only used to run .onAttach 103 runHook <- function(hookname, env, libname, pkgname) { 104 if (!is.null(fun <- env[[hookname]])) { 105 res <- tryCatch(fun(libname, pkgname), error = identity) 106 if (inherits(res, "error")) { 107 stop(gettextf("%s failed in %s() for '%s', details:\n call: %s\n error: %s", 108 hookname, "attachNamespace", nsname, 109 deparse(conditionCall(res))[1L], 110 conditionMessage(res)), 111 call. = FALSE, domain = NA) 112 } 113 } 114## else if (exists(".First.lib", envir = env, inherits = FALSE) && 115## nsname == Sys.getenv("R_INSTALL_PKG")) 116## warning(sprintf("ignoring .First.lib() for package %s", 117## sQuote(nsname)), domain = NA, call. = FALSE) 118 } 119 runUserHook <- function(pkgname, pkgpath) { 120 hook <- getHook(packageEvent(pkgname, "attach")) # might be list() 121 for(fun in hook) try(fun(pkgname, pkgpath)) 122 } 123 124 ns <- asNamespace(ns, base.OK = FALSE) 125 nsname <- getNamespaceName(ns) 126 nspath <- .getNamespaceInfo(ns, "path") 127 attname <- paste0("package:", nsname) 128 if (attname %in% search()) 129 stop("namespace is already attached") 130 env <- attach(NULL, pos = pos, name = attname) 131 ## we do not want to run e.g. .onDetach here 132 on.exit(.Internal(detach(pos))) 133 attr(env, "path") <- nspath 134 exports <- getNamespaceExports(ns) 135 importIntoEnv(env, exports, ns, exports) 136 ## always exists, might be empty 137 dimpenv <- .getNamespaceInfo(ns, "lazydata") 138 dnames <- names(dimpenv) 139 .Internal(importIntoEnv(env, dnames, dimpenv, dnames)) 140 if(length(depends) > 0L) env$.Depends <- depends 141 Sys.setenv("_R_NS_LOAD_" = nsname) 142 on.exit(Sys.unsetenv("_R_NS_LOAD_"), add = TRUE) 143 runHook(".onAttach", ns, dirname(nspath), nsname) 144 145 ## adjust variables for 'exclude', 'include.only' arguments 146 if (! missing(exclude) && length(exclude) > 0) 147 rm(list = exclude, envir = env) 148 if (! missing(include.only)) { 149 vars <- ls(env, all.names = TRUE) 150 nf <- setdiff(include.only, vars) 151 if (length(nf) > 0) { 152 nf <- strwrap(paste(nf, collapse = ", "), 153 indent = 4L, exdent = 4L) 154 stop(gettextf("not found in namespace %s: \n\n%s\n", 155 sQuote(nsname), nf), 156 call. = FALSE, domain = NA) 157 } 158 rm(list = setdiff(vars, include.only), envir = env) 159 } 160 161 lockEnvironment(env, TRUE) 162 runUserHook(nsname, nspath) 163 on.exit() 164 Sys.unsetenv("_R_NS_LOAD_") 165 invisible(env) 166} 167 168## *inside* another function, useful to check for cycles 169dynGet <- function(x, ifnotfound = stop(gettextf("%s not found", 170 sQuote(x)), domain = NA), 171 minframe = 1L, inherits = FALSE) 172{ 173 n <- sys.nframe() 174 myObj <- structure(list(.b = as.raw(7)), foo = 47L)# "very improbable" object 175 while (n > minframe) { 176 n <- n - 1L 177 env <- sys.frame(n) 178 r <- get0(x, envir = env, inherits=inherits, ifnotfound = myObj) 179 if(!identical(r, myObj)) 180 return(r) 181 } 182 ifnotfound 183} 184 185loadNamespace <- function (package, lib.loc = NULL, 186 keep.source = getOption("keep.source.pkgs"), 187 partial = FALSE, versionCheck = NULL, 188 keep.parse.data = getOption("keep.parse.data.pkgs")) 189{ 190 libpath <- attr(package, "LibPath") 191 package <- as.character(package)[[1L]] 192 193 loading <- dynGet("__NameSpacesLoading__", NULL) 194 if (match(package, loading, 0L)) 195 stop("cyclic namespace dependency detected when loading ", 196 sQuote(package), ", already loading ", 197 paste(sQuote(loading), collapse = ", "), 198 domain = NA) 199 "__NameSpacesLoading__" <- c(package, loading) 200 201 ns <- .Internal(getRegisteredNamespace(package)) 202 if (! is.null(ns)) { 203 if(!is.null(zop <- versionCheck[["op"]]) && 204 !is.null(zversion <- versionCheck[["version"]])) { 205 current <- getNamespaceVersion(ns) 206 if(!do.call(zop, list(as.numeric_version(current), zversion))) 207 stop(gettextf("namespace %s %s is already loaded, but %s %s is required", 208 sQuote(package), current, zop, zversion), 209 domain = NA) 210 } 211 ns 212 } else { 213 lev <- 0L 214 ## Values 1,2,3,4 give increasingly detailed tracing 215 ## Negative values trace specific actions, -5 for S4 generics/methods 216 msg <- Sys.getenv("_R_TRACE_LOADNAMESPACE_", "") 217 if (nzchar(msg)) { 218 if(package %in% 219 c("base", "tools", "utils", "grDevices", "graphics", 220 "stats", "datasets", "methods", "grid", "splines", "stats4", 221 "tcltk", "compiler", "parallel")) lev <- 0L 222 else { 223 lev <- as.integer(msg) 224 if(is.na(lev)) lev <- 0L 225 } 226 } 227 if(lev > 0L) message("- loading ", dQuote(package)) 228 ## only used here for .onLoad 229 runHook <- function(hookname, env, libname, pkgname) { 230 if (!is.null(fun <- env[[hookname]])) { 231 res <- tryCatch(fun(libname, pkgname), error = identity) 232 if (inherits(res, "error")) { 233 stop(gettextf("%s failed in %s() for '%s', details:\n call: %s\n error: %s", 234 hookname, "loadNamespace", pkgname, 235 deparse(conditionCall(res))[1L], 236 conditionMessage(res)), 237 call. = FALSE, domain = NA) 238 } 239 } 240 } 241 runUserHook <- function(pkgname, pkgpath) { 242 hooks <- getHook(packageEvent(pkgname, "onLoad")) # might be list() 243 for(fun in hooks) try(fun(pkgname, pkgpath)) 244 } 245 makeNamespace <- function(name, version = NULL, lib = NULL) { 246 impenv <- new.env(parent = .BaseNamespaceEnv, hash = TRUE) 247 attr(impenv, "name") <- paste0("imports:", name) 248 env <- new.env(parent = impenv, hash = TRUE) 249 name <- as.character(as.name(name)) 250 version <- as.character(version) 251 info <- new.env(hash = TRUE, parent = baseenv()) 252 env$.__NAMESPACE__. <- info 253 info$spec <- c(name = name, version = version) 254 setNamespaceInfo(env, "exports", new.env(hash = TRUE, parent = baseenv())) 255 dimpenv <- new.env(parent = baseenv(), hash = TRUE) 256 attr(dimpenv, "name") <- paste0("lazydata:", name) 257 setNamespaceInfo(env, "lazydata", dimpenv) 258 setNamespaceInfo(env, "imports", list("base" = TRUE)) 259 ## this should be an absolute path 260 setNamespaceInfo(env, "path", 261 normalizePath(file.path(lib, name), "/", TRUE)) 262 setNamespaceInfo(env, "dynlibs", NULL) 263 setNamespaceInfo(env, "S3methods", matrix(NA_character_, 0L, 4L)) 264 env$.__S3MethodsTable__. <- 265 new.env(hash = TRUE, parent = baseenv()) 266 .Internal(registerNamespace(name, env)) 267 env 268 } 269 sealNamespace <- function(ns) { 270 namespaceIsSealed <- function(ns) 271 environmentIsLocked(ns) 272 ns <- asNamespace(ns, base.OK = FALSE) 273 if (namespaceIsSealed(ns)) 274 stop(gettextf("namespace %s is already sealed in 'loadNamespace'", 275 sQuote(getNamespaceName(ns))), 276 call. = FALSE, domain = NA) 277 lockEnvironment(ns, TRUE) 278 lockEnvironment(parent.env(ns), TRUE) 279 } 280 addNamespaceDynLibs <- function(ns, newlibs) { 281 dynlibs <- .getNamespaceInfo(ns, "dynlibs") 282 setNamespaceInfo(ns, "dynlibs", c(dynlibs, newlibs)) 283 } 284 285 bindTranslations <- function(pkgname, pkgpath) 286 { 287 ## standard packages are treated differently 288 std <- c("compiler", "foreign", "grDevices", "graphics", "grid", 289 "methods", "parallel", "splines", "stats", "stats4", 290 "tcltk", "tools", "utils") 291 popath <- if (pkgname %in% std) .popath else file.path(pkgpath, "po") 292 if(!file.exists(popath)) return() 293 bindtextdomain(pkgname, popath) 294 bindtextdomain(paste0("R-", pkgname), popath) 295 } 296 297 assignNativeRoutines <- function(dll, lib, env, nativeRoutines) { 298 if(length(nativeRoutines) == 0L) return(character()) 299 300 varnames <- character() 301 symnames <- character() 302 303 if(nativeRoutines$useRegistration) { 304 ## Use the registration information to register ALL the symbols 305 fixes <- nativeRoutines$registrationFixes 306 routines <- getDLLRegisteredRoutines.DLLInfo(dll, addNames = FALSE) 307 lapply(routines, 308 function(type) { 309 lapply(type, 310 function(sym) { 311 varName <- paste0(fixes[1L], sym$name, fixes[2L]) 312 if(exists(varName, envir = env, inherits = FALSE)) 313 warning(gettextf( 314 "failed to assign RegisteredNativeSymbol for %s to %s since %s is already defined in the %s namespace", 315 sym$name, varName, varName, sQuote(package)), 316 domain = NA, call. = FALSE) 317 else { 318 env[[varName]] <- sym 319 varnames <<- c(varnames, 320 varName) 321 symnames <<- c(symnames, 322 sym$name) 323 } 324 }) 325 }) 326 } 327 328 symNames <- nativeRoutines$symbolNames 329 if(length(symNames)) { 330 symbols <- getNativeSymbolInfo(symNames, dll, unlist = FALSE, 331 withRegistrationInfo = TRUE) 332 lapply(seq_along(symNames), 333 function(i) { 334 ## could vectorize this outside of the loop 335 ## and assign to different variable to 336 ## maintain the original names. 337 varName <- names(symNames)[i] 338 origVarName <- symNames[i] 339 if(exists(varName, envir = env, inherits = FALSE)) 340 if(origVarName != varName) 341 warning(gettextf( 342 "failed to assign NativeSymbolInfo for %s to %s since %s is already defined in the %s namespace", 343 origVarName, varName, varName, sQuote(package)), 344 domain = NA, call. = FALSE) 345 else 346 warning(gettextf( 347 "failed to assign NativeSymbolInfo for %s since %s is already defined in the %s namespace", 348 origVarName, varName, sQuote(package)), 349 domain = NA, call. = FALSE) 350 else { 351 assign(varName, symbols[[origVarName]], 352 envir = env) 353 varnames <<- c(varnames, varName) 354 symnames <<- c(symnames, origVarName) 355 } 356 }) 357 } 358 359 names(symnames) <- varnames 360 symnames 361 } ## end{assignNativeRoutines} 362 363 ## find package, allowing a calling handler to retry if not found. 364 ## could move the retry functionality into find.package. 365 fp.lib.loc <- c(libpath, lib.loc) 366 pkgpath <- find.package(package, fp.lib.loc, quiet = TRUE) 367 if (length(pkgpath) == 0L) { 368 cond <- packageNotFoundError(package, fp.lib.loc, sys.call()) 369 withRestarts(stop(cond), retry_loadNamespace = function() NULL) 370 pkgpath <- find.package(package, fp.lib.loc, quiet = TRUE) 371 if (length(pkgpath) == 0L) 372 stop(cond) 373 } 374 bindTranslations(package, pkgpath) 375 package.lib <- dirname(pkgpath) 376 package <- basename(pkgpath) # need the versioned name 377 if (! packageHasNamespace(package, package.lib)) { 378 hasNoNamespaceError <- 379 function (package, package.lib, call = NULL) { 380 class <- c("hasNoNamespaceError", "error", "condition") 381 msg <- gettextf("package %s does not have a namespace", 382 sQuote(package)) 383 structure(list(message = msg, package = package, 384 package.lib = package.lib, call = call), 385 class = class) 386 } 387 stop(hasNoNamespaceError(package, package.lib)) 388 } 389 390 ## create namespace; arrange to unregister on error 391 ## Can we rely on the existence of R-ng 'nsInfo.rds' and 392 ## 'package.rds'? 393 ## No, not during builds of standard packages 394 ## stats4 depends on methods, but exports do not matter 395 ## whilst it is being built 396 iniStdPkgs <- c("methods", "stats", "stats4", "tools", "utils") 397 nsInfoFilePath <- file.path(pkgpath, "Meta", "nsInfo.rds") 398 nsInfo <- if(file.exists(nsInfoFilePath)) readRDS(nsInfoFilePath) 399 else parseNamespaceFile(package, package.lib, mustExist = FALSE) 400 401 pkgInfoFP <- file.path(pkgpath, "Meta", "package.rds") 402 if(file.exists(pkgInfoFP)) { 403 pkgInfo <- readRDS(pkgInfoFP) 404 version <- pkgInfo$DESCRIPTION["Version"] 405 vI <- pkgInfo$Imports 406 if(is.null(built <- pkgInfo$Built)) 407 stop(gettextf("package %s has not been installed properly\n", 408 sQuote(package)), # == basename(pkgpath) 409 call. = FALSE, domain = NA) 410 R_version_built_under <- as.numeric_version(built$R) 411 if(R_version_built_under < "4.0.0") 412 stop(gettextf("package %s was installed before R 4.0.0: please re-install it", 413 sQuote(package)), 414 call. = FALSE, domain = NA) 415 ## we need to ensure that S4 dispatch is on now if the package 416 ## will require it, or the exports will be incomplete. 417 dependsMethods <- "methods" %in% names(pkgInfo$Depends) 418 if(dependsMethods) loadNamespace("methods") 419 if(!is.null(zop <- versionCheck[["op"]]) && 420 !is.null(zversion <- versionCheck[["version"]]) && 421 !do.call(zop, list(as.numeric_version(version), zversion))) 422 stop(gettextf("namespace %s %s is being loaded, but %s %s is required", 423 sQuote(package), version, zop, zversion), 424 domain = NA) 425 } else { 426 if(!any(package == iniStdPkgs)) 427 warning(gettextf("package %s has no 'package.rds' in Meta/", 428 sQuote(package)), 429 domain = NA) 430 vI <- NULL 431 } 432 433 ## moved from library() in R 3.4.0 434 checkLicense <- function(pkg, pkgInfo, pkgPath) 435 { 436 L <- tools:::analyze_license(pkgInfo$DESCRIPTION["License"]) 437 if(!L$is_empty && !L$is_verified) { 438 site_file <- 439 path.expand(file.path(R.home("etc"), "licensed.site")) 440 if(file.exists(site_file) && 441 pkg %in% readLines(site_file)) return() 442 personal_file <- path.expand("~/.R/licensed") 443 if(file.exists(personal_file)) { 444 agreed <- readLines(personal_file) 445 if(pkg %in% agreed) return() 446 } else agreed <- character() 447 if(!interactive()) 448 stop(gettextf( 449 "package %s has a license that you need to accept in an interactive session", 450 sQuote(pkg)), domain = NA) 451 lfiles <- file.path(pkgpath, c("LICENSE", "LICENCE")) 452 lfiles <- lfiles[file.exists(lfiles)] 453 if(length(lfiles)) { 454 message(gettextf( 455 "package %s has a license that you need to accept after viewing", 456 sQuote(pkg)), domain = NA) 457 readline("press RETURN to view license") 458 encoding <- pkgInfo$DESCRIPTION["Encoding"] 459 if(is.na(encoding)) encoding <- "" 460 ## difR and EVER have a Windows' 'smart quote' LICEN[CS]E file 461 if(encoding == "latin1") encoding <- "cp1252" 462 file.show(lfiles[1L], encoding = encoding) 463 } else { 464 message(gettextf(paste("package %s has a license that you need to accept:", 465 "according to the DESCRIPTION file it is", 466 "%s", sep="\n"), 467 sQuote(pkg), 468 pkgInfo$DESCRIPTION["License"]), domain = NA) 469 } 470 choice <- utils::menu(c("accept", "decline"), 471 title = paste("License for", sQuote(pkg))) 472 if(choice != 1) 473 stop(gettextf("license for package %s not accepted", 474 sQuote(package)), domain = NA, call. = FALSE) 475 dir.create(dirname(personal_file), showWarnings=FALSE) 476 writeLines(c(agreed, pkg), personal_file) 477 } 478 } 479 480 ## avoid any bootstrapping issues by these exemptions 481 if(!package %in% c("datasets", "grDevices", "graphics", # <- ?? 482 iniStdPkgs) && 483 isTRUE(getOption("checkPackageLicense", FALSE))) 484 checkLicense(package, pkgInfo, pkgpath) 485 486 ## Check that the internals version used to build this package 487 ## matches the version of current R. Failure in this test 488 ## should only occur if the R version is an unreleased devel 489 ## version or the package was build with an unrelease devel 490 ## version. Other mismatches should be caught earlier by the 491 ## version checks. 492 ## Meta will not exist when first building tools, 493 ## so pkgInfo was not created above. 494 if(dir.exists(file.path(pkgpath, "Meta"))) { 495 ffile <- file.path(pkgpath, "Meta", "features.rds") 496 features <- if (file.exists(ffile)) readRDS(ffile) else NULL 497 needsComp <- as.character(pkgInfo$DESCRIPTION["NeedsCompilation"]) 498 if (identical(needsComp, "yes") || 499 file.exists(file.path(pkgpath, "libs"))) { 500 internalsID <- features$internalsID 501 if (is.null(internalsID)) 502 ## the initial internalsID for packages installed 503 ## prior to introducing features.rds in the meta data 504 internalsID <- "0310d4b8-ccb1-4bb8-ba94-d36a55f60262" 505 if (internalsID != .Internal(internalsID())) 506 stop(gettextf("package %s was installed by an R version with different internals; it needs to be reinstalled for use with this R version", 507 sQuote(package)), call. = FALSE, domain = NA) 508 } 509 } 510 511 ns <- makeNamespace(package, version = version, lib = package.lib) 512 on.exit(.Internal(unregisterNamespace(package))) 513 514 ## process imports 515 if(lev > 1L) message("-- processing imports for ", dQuote(package)) 516 for (i in nsInfo$imports) { 517 if (is.character(i)) 518 namespaceImport(ns, 519 loadNamespace(i, c(lib.loc, .libPaths()), 520 versionCheck = vI[[i]]), 521 from = package) 522 else if (!is.null(i$except)) 523 namespaceImport(ns, 524 loadNamespace(j <- i[[1L]], 525 c(lib.loc, .libPaths()), 526 versionCheck = vI[[j]]), 527 from = package, 528 except = i$except) 529 else 530 namespaceImportFrom(ns, 531 loadNamespace(j <- i[[1L]], 532 c(lib.loc, .libPaths()), 533 versionCheck = vI[[j]]), 534 i[[2L]], from = package) 535 } 536 for(imp in nsInfo$importClasses) 537 namespaceImportClasses(ns, loadNamespace(j <- imp[[1L]], 538 c(lib.loc, .libPaths()), 539 versionCheck = vI[[j]]), 540 imp[[2L]], from = package) 541 for(imp in nsInfo$importMethods) 542 namespaceImportMethods(ns, loadNamespace(j <- imp[[1L]], 543 c(lib.loc, .libPaths()), 544 versionCheck = vI[[j]]), 545 imp[[2L]], from = package) 546 547 if(lev > 1L) message("-- done processing imports for ", dQuote(package)) 548 549 ## store info for loading namespace for loadingNamespaceInfo to read 550 "__LoadingNamespaceInfo__" <- list(libname = package.lib, 551 pkgname = package) 552 553 env <- asNamespace(ns) 554 ## save the package name in the environment 555 env$.packageName <- package 556 557 ## load the code 558 codename <- strsplit(package, "_", fixed = TRUE)[[1L]][1L] 559 codeFile <- file.path(pkgpath, "R", codename) 560 if (file.exists(codeFile)) { 561 if(lev > 1L) message("-- loading code for ", dQuote(package)) 562 # The code file has been converted to the native encoding 563 save.enc <- options(encoding = "native.enc") 564 res <- try(sys.source(codeFile, env, keep.source = keep.source, 565 keep.parse.data = keep.parse.data)) 566 options(save.enc) 567 if(inherits(res, "try-error")) 568 stop(gettextf("unable to load R code in package %s", 569 sQuote(package)), call. = FALSE, domain = NA) 570 if(lev > 1L) message("-- loading code for ", dQuote(package)) 571 } 572 # a package without R code currently is required to have a namespace 573 # else warning(gettextf("package %s contains no R code", 574 # sQuote(package)), call. = FALSE, domain = NA) 575 576 ## partial loading stops at this point 577 ## -- used in preparing for lazy-loading 578 if (partial) return(ns) 579 580 ## lazy-load any sysdata 581 dbbase <- file.path(pkgpath, "R", "sysdata") 582 if (file.exists(paste0(dbbase, ".rdb"))) { 583 if(lev > 1L) message("-- loading sysdata for ", dQuote(package)) 584 lazyLoad(dbbase, env) 585 } 586 587 ## load any lazydata into a separate environment 588 dbbase <- file.path(pkgpath, "data", "Rdata") 589 if(file.exists(paste0(dbbase, ".rdb"))) { 590 if(lev > 1L) message("-- loading lazydata for ", dQuote(package)) 591 lazyLoad(dbbase, .getNamespaceInfo(env, "lazydata")) 592 } 593 594 ## register any S3 methods 595 if(lev > 1L) message("-- registerS3methods for ", dQuote(package)) 596 registerS3methods(nsInfo$S3methods, package, env) 597 if(lev > 1L) message("-- done registerS3methods for ", dQuote(package)) 598 599 ## load any dynamic libraries 600 dlls <- list() 601 dynLibs <- nsInfo$dynlibs 602 nativeRoutines <- list() 603 for (i in seq_along(dynLibs)) { 604 lib <- dynLibs[i] 605 dlls[[lib]] <- library.dynam(lib, package, package.lib) 606 routines <- assignNativeRoutines(dlls[[lib]], lib, env, 607 nsInfo$nativeRoutines[[lib]]) 608 nativeRoutines[[lib]] <- routines 609 610 ## If the DLL has a name as in useDynLib(alias = foo), 611 ## then assign DLL reference to alias. Check if 612 ## names() is NULL to handle case that the nsInfo.rds 613 ## file was created before the names were added to the 614 ## dynlibs vector. 615 if(!is.null(names(nsInfo$dynlibs)) 616 && nzchar(names(nsInfo$dynlibs)[i])) 617 env[[names(nsInfo$dynlibs)[i]]] <- dlls[[lib]] 618 setNamespaceInfo(env, "DLLs", dlls) 619 } 620 addNamespaceDynLibs(env, nsInfo$dynlibs) 621 setNamespaceInfo(env, "nativeRoutines", nativeRoutines) 622 623 ## used in e.g. utils::assignInNamespace 624 Sys.setenv("_R_NS_LOAD_" = package) 625 on.exit(Sys.unsetenv("_R_NS_LOAD_"), add = TRUE) 626 ## run the load hook 627 if(lev > 1L) message("-- running .onLoad for ", dQuote(package)) 628 runHook(".onLoad", env, package.lib, package) 629 if(lev > 1L) message("-- done running .onLoad for ", dQuote(package)) 630 631 ## process exports, seal, and clear on.exit action 632 exports <- nsInfo$exports 633 634 for (p in nsInfo$exportPatterns) 635 exports <- c(ls(env, pattern = p, all.names = TRUE), exports) 636 ## 637 if(.isMethodsDispatchOn() && 638 !(hasS4m <- methods:::.hasS4MetaData(ns)) && 639 any(lengths(nsInfo[c("exportClasses", "exportMethods", 640 "exportClassPatterns")])) && 641 Sys.getenv("_R_LOAD_CHECK_S4_EXPORTS_") %in% c(package, "all")) { 642 warning(gettextf( 643 "S4 exports specified in 'NAMESPACE' but not defined in package %s", 644 sQuote(package)), call. = FALSE, domain = NA) 645 } 646 if(.isMethodsDispatchOn() && hasS4m && !identical(package, "methods") ) { 647 if(lev > 1L || lev == -5) 648 message("-- processing S4 stuff for ", dQuote(package)) 649 ## cache generics, classes in this namespace (but not methods itself, 650 if(lev > 2L) message('--- caching metadata') 651 ## which pre-cached at install time 652 methods::cacheMetaData(ns, TRUE, ns) 653 if(lev > 2L) message('--- done caching metadata') 654 ## This also ran .doLoadActions 655 ## load actions may have added objects matching patterns 656 for (p in nsInfo$exportPatterns) { 657 expp <- ls(ns, pattern = p, all.names = TRUE) 658 newEx <- !(expp %in% exports) 659 if(any(newEx)) 660 exports <- c(expp[newEx], exports) 661 } 662 ## process class definition objects 663 expClasses <- nsInfo$exportClasses 664 if(lev > 2L) message('--- processing classes') 665 ##we take any pattern, but check to see if the matches are classes 666 pClasses <- character() 667 aClasses <- methods::getClasses(ns) 668 classPatterns <- nsInfo$exportClassPatterns 669 ## defaults to exportPatterns 670 if(!length(classPatterns)) 671 classPatterns <- nsInfo$exportPatterns 672 pClasses <- unique(unlist(lapply(classPatterns, grep, aClasses, 673 value=TRUE))) 674 if( length(pClasses) ) { 675 good <- vapply(pClasses, methods::isClass, NA, where = ns) 676 if( !any(good) && length(nsInfo$exportClassPatterns)) 677 warning(gettextf( 678 "'exportClassPattern' specified in 'NAMESPACE' but no matching classes in package %s", 679 sQuote(package)), 680 call. = FALSE, domain = NA) 681 expClasses <- c(expClasses, pClasses[good]) 682 } 683 if(length(expClasses)) { 684 missingClasses <- 685 !vapply(expClasses, methods::isClass, NA, where = ns) 686 if(any(missingClasses)) 687 stop(gettextf("in package %s classes %s were specified for export but not defined", 688 sQuote(package), 689 paste(expClasses[missingClasses], 690 collapse = ", ")), 691 domain = NA) 692 expClasses <- paste0(methods::classMetaName(""), expClasses) 693 } 694 ## process methods metadata explicitly exported or 695 ## implied by exporting the generic function. 696 allGenerics <- unique(c(methods:::.getGenerics(ns), 697 methods:::.getGenerics(parent.env(ns)))) 698 expMethods <- nsInfo$exportMethods 699 ## check for generic functions corresponding to exported methods 700 addGenerics <- expMethods[is.na(match(expMethods, exports))] 701 if(length(addGenerics)) { 702 nowhere <- vapply(addGenerics, function(what) !exists(what, mode = "function", envir = ns), 703 NA, USE.NAMES=FALSE) 704 if(any(nowhere)) { 705 warning(gettextf("no function found corresponding to methods exports from %s for: %s", 706 sQuote(package), 707 paste(sQuote(sort(unique(addGenerics[nowhere]))), collapse = ", ")), 708 domain = NA, call. = FALSE) 709 addGenerics <- addGenerics[!nowhere] 710 } 711 if(length(addGenerics)) { 712 ## skip primitives 713 addGenerics <- addGenerics[vapply(addGenerics, function(what) 714 !is.primitive(get(what, mode = "function", envir = ns)), NA)] 715 ## the rest must be generic functions, implicit or local 716 ## or have been cached via a DEPENDS package 717 ok <- vapply(addGenerics, methods:::.findsGeneric, 1L, ns) 718 if(!all(ok)) { 719 bad <- sort(unique(addGenerics[!ok])) 720 msg <- 721 ngettext(length(bad), 722 "Function found when exporting methods from the namespace %s which is not S4 generic: %s", 723 "Functions found when exporting methods from the namespace %s which are not S4 generic: %s") 724 stop(sprintf(msg, sQuote(package), 725 paste(sQuote(bad), collapse = ", ")), 726 domain = NA, call. = FALSE) 727 } 728 else if(any(ok > 1L)) #from the cache, don't add 729 addGenerics <- addGenerics[ok < 2L] 730 } 731### <note> Uncomment following to report any local generic functions 732### that should have been exported explicitly. But would be reported 733### whenever the package is loaded, which is not when it is relevant. 734### </note> 735 ## local <- sapply(addGenerics, function(what) identical(as.character(get(what, envir = ns)@package), package)) 736 ## if(any(local)) 737 ## message(gettextf("export(%s) from package %s generated by exportMethods()", 738 ## paste(addGenerics[local], collapse = ", ")), 739 ## domain = NA) 740 exports <- c(exports, addGenerics) 741 } 742 expTables <- character() 743 if(length(allGenerics)) { 744 expMethods <- 745 unique(c(expMethods, 746 exports[!is.na(match(exports, allGenerics))])) 747 missingMethods <- !(expMethods %in% allGenerics) 748 if(any(missingMethods)) 749 stop(gettextf("in %s methods for export not found: %s", 750 sQuote(package), 751 paste(expMethods[missingMethods], 752 collapse = ", ")), 753 domain = NA) 754 tPrefix <- methods:::.TableMetaPrefix() 755 allMethodTables <- 756 unique(c(methods:::.getGenerics(ns, tPrefix), 757 methods:::.getGenerics(parent.env(ns), tPrefix))) 758 needMethods <- 759 (exports %in% allGenerics) & !(exports %in% expMethods) 760 if(any(needMethods)) 761 expMethods <- c(expMethods, exports[needMethods]) 762 ## Primitives must have their methods exported as long 763 ## as a global table is used in the C code to dispatch them: 764 ## The following keeps the exported files consistent with 765 ## the internal table. 766 pm <- allGenerics[!(allGenerics %in% expMethods)] 767 if(length(pm)) { 768 prim <- vapply(pm, function(pmi) { 769 f <- methods::getFunction(pmi, FALSE, 770 FALSE, ns) 771 is.primitive(f) 772 }, logical(1L)) 773 expMethods <- c(expMethods, pm[prim]) 774 } 775 for(i in seq_along(expMethods)) { 776 mi <- expMethods[[i]] 777 if(lev > 3L) message("---- export method ", sQuote(mi)) 778 if(!(mi %in% exports) && 779 exists(mi, envir = ns, mode = "function", 780 inherits = FALSE)) 781 exports <- c(exports, mi) 782 pattern <- paste0(tPrefix, mi, ":") 783 ii <- grep(pattern, allMethodTables, fixed = TRUE) 784 if(length(ii)) { 785 if(length(ii) > 1L) { 786 warning(gettextf("multiple methods tables found for %s", 787 sQuote(mi)), call. = FALSE, domain = NA) 788 ii <- ii[1L] 789 } 790 expTables[[i]] <- allMethodTables[ii] 791 } 792 else { ## but not possible? 793 warning(gettextf("failed to find metadata object for %s", 794 sQuote(mi)), call. = FALSE, domain = NA) 795 } 796 } 797 } 798 else if(length(expMethods)) 799 stop(gettextf("in package %s methods %s were specified for export but not defined", 800 sQuote(package), 801 paste(expMethods, collapse = ", ")), 802 domain = NA) 803 exports <- unique(c(exports, expClasses, expTables)) 804 if(lev > 1L || lev == -5) 805 message("-- done processing S4 stuff for ", dQuote(package)) 806 } 807 ## certain things should never be exported. 808 if (length(exports)) { 809 stoplist <- c(".__NAMESPACE__.", ".__S3MethodsTable__.", 810 ".packageName", ".First.lib", ".onLoad", 811 ".onAttach", ".conflicts.OK", ".noGenerics") 812 exports <- exports[! exports %in% stoplist] 813 } 814 if(lev > 2L) message("--- processing exports for ", dQuote(package)) 815 namespaceExport(ns, exports) 816 if(lev > 2L) message("--- sealing exports for ", dQuote(package)) 817 sealNamespace(ns) 818 runUserHook(package, pkgpath) 819 on.exit() 820 if(lev > 0L) message("- done loading ", dQuote(package)) 821 Sys.unsetenv("_R_NS_LOAD_") 822 ns 823 } 824} 825 826## A version which returns TRUE/FALSE 827requireNamespace <- function (package, ..., quietly = FALSE) 828{ 829 package <- as.character(package)[[1L]] # like loadNamespace 830 ns <- .Internal(getRegisteredNamespace(package)) 831 res <- TRUE 832 if (is.null(ns)) { 833 if(!quietly) 834 packageStartupMessage(gettextf("Loading required namespace: %s", 835 package), domain = NA) 836 value <- tryCatch(loadNamespace(package, ...), error = function(e) e) 837 if (inherits(value, "error")) { 838 if (!quietly) { 839 msg <- conditionMessage(value) 840 cat("Failed with error: ", 841 sQuote(msg), "\n", file = stderr(), sep = "") 842 .Internal(printDeferredWarnings()) 843 } 844 res <- FALSE 845 } 846 } 847 invisible(res) 848} 849 850loadingNamespaceInfo <- function() { 851 dynGet("__LoadingNamespaceInfo__", stop("not loading a namespace")) 852} 853 854topenv <- function(envir = parent.frame(), 855 matchThisEnv = getOption("topLevelEnvironment")) { 856 .Internal(topenv(envir, matchThisEnv)) 857} 858 859unloadNamespace <- function(ns) 860{ 861 ## check, so we do not load & unload: 862 if ((is.character(ns) && any(ns == loadedNamespaces())) || 863 (is.environment(ns) && any(getNamespaceName(ns) == loadedNamespaces()))) { 864 ## only used to run .onUnload 865 runHook <- function(hookname, env, ...) { 866 if (!is.null(fun <- env[[hookname]])) { 867 res <- tryCatch(fun(...), error=identity) 868 if (inherits(res, "error")) { 869 warning(gettextf("%s failed in %s() for '%s', details:\n call: %s\n error: %s", 870 hookname, "unloadNamespace", nsname, 871 deparse(conditionCall(res))[1L], 872 conditionMessage(res)), 873 call. = FALSE, domain = NA) 874 } 875 } 876 } 877 ns <- asNamespace(ns, base.OK = FALSE) 878 nsname <- getNamespaceName(ns) 879 pos <- match(paste0("package:", nsname), search()) 880 if (! is.na(pos)) detach(pos = pos) 881 users <- getNamespaceUsers(ns) 882 if (length(users)) 883 stop(gettextf("namespace %s is imported by %s so cannot be unloaded", 884 sQuote(getNamespaceName(ns)), 885 paste(sQuote(users), collapse = ", ")), 886 domain = NA) 887 nspath <- .getNamespaceInfo(ns, "path") 888 hook <- getHook(packageEvent(nsname, "onUnload")) # might be list() 889 for(fun in rev(hook)) try(fun(nsname, nspath)) 890 runHook(".onUnload", ns, nspath) 891 .Internal(unregisterNamespace(nsname)) 892 if(.isMethodsDispatchOn() && methods:::.hasS4MetaData(ns)) 893 methods::cacheMetaData(ns, FALSE, ns) 894 .Internal(lazyLoadDBflush(paste0(nspath, "/R/", nsname, ".rdb"))) 895 } 896 invisible() 897} 898 899isNamespace <- function(ns) .Internal(isNamespaceEnv(ns)) 900 901isBaseNamespace <- function(ns) identical(ns, .BaseNamespaceEnv) 902 903getNamespaceInfo <- function(ns, which) { 904 ns <- asNamespace(ns, base.OK = FALSE) 905 get(which, envir = ns[[".__NAMESPACE__."]]) 906} 907 908.getNamespaceInfo <- function(ns, which) { 909 ns[[".__NAMESPACE__."]][[which]] 910} 911 912setNamespaceInfo <- function(ns, which, val) { 913 ns <- asNamespace(ns, base.OK = FALSE) 914 info <- ns[[".__NAMESPACE__."]] 915 info[[which]] <- val 916} 917 918asNamespace <- function(ns, base.OK = TRUE) { 919 if (is.character(ns) || is.name(ns)) 920 ns <- getNamespace(ns) 921 if (! isNamespace(ns)) 922 stop("not a namespace") 923 else if (! base.OK && isBaseNamespace(ns)) 924 stop("operation not allowed on base namespace") 925 else ns 926} 927 928namespaceImport <- function(self, ..., from = NULL, except = character(0L)) 929 for (ns in list(...)) 930 namespaceImportFrom(self, asNamespace(ns), from = from, 931 except = except) 932 933namespaceImportFrom <- function(self, ns, vars, generics, packages, 934 from = "non-package environment", 935 except = character(0L)) 936{ 937 addImports <- function(ns, from, what) { 938 imp <- structure(list(what), names = getNamespaceName(from)) 939 imports <- getNamespaceImports(ns) 940 setNamespaceInfo(ns, "imports", c(imports, imp)) 941 } 942 namespaceIsSealed <- function(ns) 943 environmentIsLocked(ns) 944 makeImportExportNames <- function(spec) { 945 old <- as.character(spec) 946 new <- names(spec) 947 if (is.null(new)) new <- old 948 else { 949 change <- !nzchar(new) 950 new[change] <- old[change] 951 } 952 names(old) <- new 953 old 954 } 955 whichMethodMetaNames <- function(impvars) { 956 if(!.isMethodsDispatchOn()) 957 return(numeric()) 958 seq_along(impvars)[startsWith(impvars, ".__T__")] 959 } 960 genericPackage <- function(f) { 961 if(methods::is(f, "genericFunction")) f@package 962 else if(is.primitive(f)) "base" 963 else "<unknown>" 964 } 965 if (is.character(self)) 966 self <- getNamespace(self) 967 ns <- asNamespace(ns) 968 nsname <- getNamespaceName(ns) 969 impvars <- if (missing(vars)) { 970 ## certain things should never be imported: 971 ## but most of these are never exported (exception: .Last.lib) 972 stoplist <- c(".__NAMESPACE__.", ".__S3MethodsTable__.", 973 ".packageName", ".First.lib", ".Last.lib", 974 ".onLoad", ".onAttach", ".onDetach", 975 ".conflicts.OK", ".noGenerics") 976 vars <- getNamespaceExports(ns) 977 vars <- vars[! vars %in% stoplist] 978 } else vars 979 impvars <- impvars[! impvars %in% except] 980 impvars <- makeImportExportNames(impvars) 981 impnames <- names(impvars) 982 if (anyDuplicated(impnames)) { 983 stop(gettextf("duplicate import names %s", 984 paste(sQuote(impnames[duplicated(impnames)]), 985 collapse = ", ")), domain = NA) 986 } 987 if (isNamespace(self)) { 988 if(isBaseNamespace(self)) { 989 impenv <- self 990 msg <- gettext("replacing local value with import %s when loading %s") 991 register <- FALSE 992 } 993 else { 994 if (namespaceIsSealed(self)) 995 stop("cannot import into a sealed namespace") 996 impenv <- parent.env(self) 997 msg <- gettext("replacing previous import by %s when loading %s") 998 register <- TRUE 999 } 1000 } 1001 else if (is.environment(self)) { 1002 impenv <- self 1003 msg <- gettext("replacing local value with import %s when loading %s") 1004 register <- FALSE 1005 } 1006 else stop("invalid import target") 1007 which <- whichMethodMetaNames(impvars) 1008 if(length(which)) { 1009 ## If methods are already in impenv, merge and don't import 1010 delete <- integer() 1011 for(i in which) { 1012 methodsTable <- .mergeImportMethods(impenv, ns, impvars[[i]]) 1013 if(is.null(methodsTable)) 1014 {} ## first encounter, just import it 1015 else { ## 1016 delete <- c(delete, i) 1017 if(!missing(generics)) { 1018 genName <- generics[[i]] 1019 ## if(i > length(generics) || !nzchar(genName)) 1020 ## {warning("got invalid index for importing ",mlname); next} 1021 fdef <- methods::getGeneric(genName, 1022 where = impenv, 1023 package = packages[[i]]) 1024 if(is.null(fdef)) 1025 warning(gettextf("found methods to import for function %s but not the generic itself", 1026 sQuote(genName)), 1027 call. = FALSE, domain = NA) 1028 else 1029 methods:::.updateMethodsInTable(fdef, ns, TRUE) 1030 } 1031 } 1032 } 1033 if(length(delete)) { 1034 impvars <- impvars[-delete] 1035 impnames <- impnames[-delete] 1036 } 1037 } 1038 for (n in impnames) 1039 if (!is.null(genImp <- impenv[[n]])) { 1040 if (.isMethodsDispatchOn() && methods::isGeneric(n, ns)) { 1041 ## warn only if generic overwrites a function which 1042 ## it was not derived from 1043 genNs <- genericPackage(get(n, envir = ns)) 1044 if(identical(genNs, genericPackage(genImp))) next # same generic 1045 genImpenv <- environmentName(environment(genImp)) 1046 ## May call environment() on a non-function--an undocumented 1047 ## "feature" of environment() is that it returns a special 1048 ## attribute for non-functions, usually NULL 1049 if (!identical(genNs, genImpenv) || 1050 methods::isGeneric(n, impenv)) {} 1051 else next 1052 } 1053 if (identical(genImp, get(n, ns))) next 1054 if (isNamespace(self) && !isBaseNamespace(self)) { 1055 ## Now try to figure out where we imported from 1056 ## The 'imports' list is named by where-from 1057 ## and is in order of adding. 1058 current <- getNamespaceInfo(self, "imports") 1059 poss <- lapply(rev(current), "[", n) 1060 poss <- poss[!sapply(poss, is.na)] 1061 if(length(poss) >= 1L) { 1062 prev <- names(poss)[1L] 1063 warning(sprintf(gettext("replacing previous import %s by %s when loading %s"), 1064 sQuote(paste(prev, n, sep = "::")), 1065 sQuote(paste(nsname, n, sep = "::")), 1066 sQuote(from)), 1067 call. = FALSE, domain = NA) 1068 } else 1069 warning(sprintf(msg, sQuote(paste(nsname, n, sep = "::")), 1070 sQuote(from)), 1071 call. = FALSE, domain = NA) 1072 } else { 1073 ## this is always called from another function, 1074 ## so reporting call is unhelpful 1075 warning(sprintf(msg, sQuote(paste(nsname, n, sep = "::")), 1076 sQuote(from)), 1077 call. = FALSE, domain = NA) 1078 } 1079 } 1080 importIntoEnv(impenv, impnames, ns, impvars) 1081 if (register) 1082 addImports(self, ns, if (missing(vars)) TRUE else impvars) 1083} 1084 1085namespaceImportClasses <- function(self, ns, vars, from = NULL) 1086{ 1087 for(i in seq_along(vars)) 1088 vars[[i]] <- methods::classMetaName(vars[[i]]) 1089 namespaceImportFrom(self, asNamespace(ns), vars, from = from) 1090} 1091 1092namespaceImportMethods <- function(self, ns, vars, from = NULL) 1093{ 1094 allVars <- character() 1095 generics <- character() 1096 packages <- character() 1097 allFuns <- methods:::.getGenerics(ns) # all the methods tables in ns 1098 allPackages <- attr(allFuns, "package") 1099 pkg <- methods::getPackageName(ns) 1100 found <- vars %in% allFuns 1101 if(!all(found)) { 1102 message(sprintf(ngettext(sum(!found), 1103 "No methods found in package %s for request: %s when loading %s", 1104 "No methods found in package %s for requests: %s when loading %s"), 1105 sQuote(pkg), 1106 paste(sQuote(vars[!found]), collapse = ", "), 1107 sQuote(getNamespaceName(self))), 1108 domain = NA) 1109 vars <- vars[found] 1110 } 1111 found <- vars %in% allFuns 1112 if(!all(found)) 1113 stop(sprintf(ngettext(sum(!found), 1114 "requested method not found in environment/package %s: %s when loading %s", 1115 "requested methods not found in environment/package %s: %s when loading %s"), 1116 sQuote(pkg), 1117 paste(sQuote(vars[!found]), collapse = ", "), 1118 sQuote(getNamespaceName(self))), 1119 call. = FALSE, domain = NA) 1120 for(i in seq_along(allFuns)) { 1121 ## import methods tables if asked for 1122 ## or if the corresponding generic was imported 1123 g <- allFuns[[i]] 1124 p <- allPackages[[i]] 1125 if(exists(g, envir = self, inherits = FALSE) # already imported 1126 || g %in% vars) { # requested explicitly 1127 tbl <- methods:::.TableMetaName(g, p) 1128 if(is.null(.mergeImportMethods(self, ns, tbl))) { # a new methods table 1129 allVars <- c(allVars, tbl) # import it;else, was merged 1130 generics <- c(generics, g) 1131 packages <- c(packages, p) 1132 } 1133 } 1134 if(g %in% vars && !exists(g, envir = self, inherits = FALSE)) { 1135 if(!is.null(f <- get0(g, envir = ns)) && methods::is(f, "genericFunction")) { 1136 allVars <- c(allVars, g) 1137 generics <- c(generics, g) 1138 packages <- c(packages, p) 1139 } else if (g %in% c("as.vector", "is.unsorted", "unlist")) { 1140 ## implicit generics 1141 } else { # should be primitive 1142 fun <- methods::getFunction(g, mustFind = FALSE, where = self) 1143 if(is.primitive(fun) || methods::is(fun, "genericFunction")) {} 1144 else 1145 warning(gettextf( 1146 "No generic function %s found corresponding to requested imported methods from package %s when loading %s (malformed exports?)", 1147 sQuote(g), sQuote(pkg), sQuote(from)), 1148 domain = NA, call. = FALSE) 1149 } 1150 } 1151 } 1152 namespaceImportFrom(self, asNamespace(ns), allVars, generics, packages, 1153 from = from) 1154} 1155 1156importIntoEnv <- function(impenv, impnames, expenv, expnames) { 1157 exports <- getNamespaceInfo(expenv, "exports") 1158 ex <- names(exports) 1159 if(!all(eie <- expnames %in% ex)) { 1160 miss <- expnames[!eie] 1161 ## if called (indirectly) for namespaceImportClasses 1162 ## these are all classes 1163 if(all(startsWith(miss, ".__C__"))) { 1164 miss <- sub("^\\.__C__", "", miss) 1165 stop(sprintf(ngettext(length(miss), 1166 "class %s is not exported by 'namespace:%s'", 1167 "classes %s are not exported by 'namespace:%s'"), 1168 paste(paste0('"', miss, '"'), collapse = ", "), 1169 getNamespaceName(expenv)), 1170 call. = FALSE, domain = NA) 1171 } else { 1172 stop(sprintf(ngettext(length(miss), 1173 "object %s is not exported by 'namespace:%s'", 1174 "objects %s are not exported by 'namespace:%s'"), 1175 paste(sQuote(miss), collapse = ", "), 1176 getNamespaceName(expenv)), 1177 call. = FALSE, domain = NA) 1178 } 1179 } 1180 expnames <- unlist(mget(expnames, envir = exports, inherits = FALSE), recursive=FALSE) 1181 if (is.null(impnames)) impnames <- character() 1182 if (is.null(expnames)) expnames <- character() 1183 .Internal(importIntoEnv(impenv, impnames, expenv, expnames)) 1184} 1185 1186namespaceExport <- function(ns, vars) { 1187 namespaceIsSealed <- function(ns) 1188 environmentIsLocked(ns) 1189 if (namespaceIsSealed(ns)) 1190 stop("cannot add to exports of a sealed namespace") 1191 ns <- asNamespace(ns, base.OK = FALSE) 1192 if (length(vars)) { 1193 addExports <- function(ns, new) { 1194 exports <- .getNamespaceInfo(ns, "exports") 1195 expnames <- names(new) 1196 objs <- names(exports) 1197 ex <- expnames %in% objs 1198 if(any(ex)) 1199 warning(sprintf(ngettext(sum(ex), 1200 "previous export '%s' is being replaced", 1201 "previous exports '%s' are being replaced"), 1202 paste(sQuote(expnames[ex]), collapse = ", ")), 1203 call. = FALSE, domain = NA) 1204 list2env(as.list(new), exports) 1205 } 1206 makeImportExportNames <- function(spec) { 1207 old <- as.character(spec) 1208 new <- names(spec) 1209 if (is.null(new)) new <- old 1210 else { 1211 change <- !nzchar(new) 1212 new[change] <- old[change] 1213 } 1214 names(old) <- new 1215 old 1216 } 1217 new <- makeImportExportNames(unique(vars)) 1218 ## calling exists each time is too slow, so do two phases 1219 undef <- new[! new %in% names(ns)] 1220 undef <- undef[! vapply(undef, exists, NA, envir = ns)] 1221 if (length(undef)) { 1222 undef <- do.call("paste", as.list(c(undef, sep = ", "))) 1223 undef <- gsub("^\\.__C__", "class ", undef) 1224 stop(gettextf("undefined exports: %s", undef), domain = NA) 1225 } 1226 if(.isMethodsDispatchOn()) .mergeExportMethods(new, ns) 1227 addExports(ns, new) 1228 } 1229} 1230 1231.mergeExportMethods <- function(new, ns) 1232{ 1233 ## avoid bootstrapping issues when using methods:::methodsPackageMetaName("M","") 1234 ## instead of ".__M__" : 1235 newMethods <- new[startsWith(new, ".__M__")] 1236 nsimports <- parent.env(ns) 1237 for(what in newMethods) { 1238 if(!is.null(m1 <- nsimports[[what]])) { 1239 m2 <- get(what, envir = ns) 1240 ns[[what]] <- methods::mergeMethods(m1, m2) 1241 } 1242 } 1243} 1244 1245packageHasNamespace <- function(package, package.lib) 1246 file.exists(file.path(package.lib, package, "NAMESPACE")) 1247 1248parseNamespaceFile <- function(package, package.lib, mustExist = TRUE) 1249{ 1250 namespaceFilePath <- function(package, package.lib) 1251 file.path(package.lib, package, "NAMESPACE") 1252 1253 ## These two functions are essentially local to the parsing of 1254 ## the namespace file and don't need to be made available to 1255 ## users. These manipulate the data from useDynLib() directives 1256 ## for the same DLL to determine how to map the symbols to R 1257 ## variables. 1258 1259 nativeRoutineMap <- 1260 ## Creates a new NativeRoutineMap. 1261 function(useRegistration, symbolNames, fixes) { 1262 proto <- list(useRegistration = FALSE, 1263 symbolNames = character()) 1264 class(proto) <- "NativeRoutineMap" 1265 1266 mergeNativeRoutineMaps(proto, useRegistration, symbolNames, fixes) 1267 } 1268 1269 mergeNativeRoutineMaps <- 1270 ## Merges new settings into a NativeRoutineMap 1271 function(map, useRegistration, symbolNames, fixes) { 1272 if(!useRegistration) 1273 names(symbolNames) <- 1274 paste0(fixes[1L], names(symbolNames), fixes[2L]) 1275 else 1276 map$registrationFixes <- fixes 1277 map$useRegistration <- map$useRegistration || useRegistration 1278 map$symbolNames <- c(map$symbolNames, symbolNames) 1279 map 1280 } 1281 1282 nsFile <- namespaceFilePath(package, package.lib) 1283 descfile <- file.path(package.lib, package, "DESCRIPTION") 1284 enc <- if (file.exists(descfile)) { 1285 read.dcf(file = descfile, "Encoding")[1L] 1286 } else NA_character_ 1287 if (file.exists(nsFile)) 1288 directives <- if (!is.na(enc) && 1289 ! Sys.getlocale("LC_CTYPE") %in% c("C", "POSIX")) { 1290 lines <- readLines(nsFile, warn = FALSE) 1291 tmp <- iconv(lines, from = enc, to = "") 1292 bad <- which(is.na(tmp)) 1293 ## do not report purely comment lines, 1294 comm <- grep("^[[:space:]]*#", lines[bad], 1295 invert = TRUE, useBytes = TRUE) 1296 if(length(bad[comm])) 1297 stop("unable to re-encode some lines in NAMESPACE file") 1298 tmp <- iconv(lines, from = enc, to = "", sub = "byte") 1299 con <- textConnection(tmp) 1300 on.exit(close(con)) 1301 parse(con, keep.source = FALSE, srcfile = NULL) 1302 } else parse(nsFile, keep.source = FALSE, srcfile = NULL) 1303 else if (mustExist) 1304 stop(gettextf("package %s has no 'NAMESPACE' file", sQuote(package)), 1305 domain = NA) 1306 else directives <- NULL 1307 exports <- character() 1308 exportPatterns <- character() 1309 exportClasses <- character() 1310 exportClassPatterns <- character() 1311 exportMethods <- character() 1312 imports <- list() 1313 importMethods <- list() 1314 importClasses <- list() 1315 dynlibs <- character() 1316 nS3methods <- 1000L 1317 S3methods <- matrix(NA_character_, nS3methods, 4L) 1318 nativeRoutines <- list() 1319 nS3 <- 0L 1320 parseDirective <- function(e) { 1321 ## trying to get more helpful error message: 1322 asChar <- function(cc) { 1323 r <- as.character(cc) 1324 if(any(r == "")) 1325 stop(gettextf("empty name in directive '%s' in 'NAMESPACE' file", 1326 as.character(e[[1L]])), 1327 domain = NA) 1328 r 1329 } 1330 evalToChar <- function(cc) { 1331 vars <- all.vars(cc) 1332 names(vars) <- vars 1333 as.character(eval(eval(call("substitute", cc, as.list(vars))), 1334 .GlobalEnv)) 1335 } 1336 switch(as.character(e[[1L]]), 1337 "if" = if (eval(e[[2L]], .GlobalEnv)) 1338 parseDirective(e[[3L]]) 1339 else if (length(e) == 4L) 1340 parseDirective(e[[4L]]), 1341 "{" = for (ee in as.list(e[-1L])) parseDirective(ee), 1342 "=" =, 1343 "<-" = { 1344 parseDirective(e[[3L]]) 1345 if(as.character(e[[3L]][[1L]]) == "useDynLib") 1346 names(dynlibs)[length(dynlibs)] <<- asChar(e[[2L]]) 1347 }, 1348 export = { 1349 exp <- e[-1L] 1350 exp <- structure(asChar(exp), names = names(exp)) 1351 exports <<- c(exports, exp) 1352 }, 1353 exportPattern = { 1354 pat <- asChar(e[-1L]) 1355 exportPatterns <<- c(pat, exportPatterns) 1356 }, 1357 exportClassPattern = { 1358 pat <- asChar(e[-1L]) 1359 exportClassPatterns <<- c(pat, exportClassPatterns) 1360 }, 1361 exportClass = , exportClasses = { 1362 exportClasses <<- c(asChar(e[-1L]), exportClasses) 1363 }, 1364 exportMethods = { 1365 exportMethods <<- c(asChar(e[-1L]), exportMethods) 1366 }, 1367 import = { 1368 except <- e$except 1369 e$except <- NULL 1370 pkgs <- as.list(asChar(e[-1L])) 1371 if (!is.null(except)) { 1372 pkgs <- lapply(pkgs, list, except=evalToChar(except)) 1373 } 1374 imports <<- c(imports, pkgs) 1375 }, 1376 importFrom = { 1377 imp <- e[-1L] 1378 ivars <- imp[-1L] 1379 inames <- names(ivars) 1380 imp <- list(asChar(imp[1L]), 1381 structure(asChar(ivars), names = inames)) 1382 imports <<- c(imports, list(imp)) 1383 }, 1384 importClassFrom = , importClassesFrom = { 1385 imp <- asChar(e[-1L]) 1386 pkg <- imp[[1L]] 1387 impClasses <- imp[-1L] 1388 imp <- list(asChar(pkg), asChar(impClasses)) 1389 importClasses <<- c(importClasses, list(imp)) 1390 }, 1391 importMethodsFrom = { 1392 imp <- asChar(e[-1L]) 1393 pkg <- imp[[1L]] 1394 impMethods <- imp[-1L] 1395 imp <- list(asChar(pkg), asChar(impMethods)) 1396 importMethods <<- c(importMethods, list(imp)) 1397 }, 1398 useDynLib = { 1399 1400 ## This attempts to process as much of the 1401 ## information as possible when NAMESPACE is parsed 1402 ## rather than when it is loaded and creates 1403 ## NativeRoutineMap objects to handle the mapping 1404 ## of symbols to R variable names. 1405 1406 ## The name is the second element after useDynLib 1407 dyl <- as.character(e[2L]) 1408 ## We ensure uniqueness at the end. 1409 dynlibs <<- 1410 structure(c(dynlibs, dyl), 1411 names = c(names(dynlibs), 1412 ifelse(!is.null(names(e)) && 1413 nzchar(names(e)[2L]), names(e)[2L], "" ))) 1414 if (length(e) > 2L) { 1415 ## Author has specified some mappings for the symbols 1416 1417 symNames <- as.character(e[-c(1L, 2L)]) 1418 names(symNames) <- names(e[-c(1, 2)]) 1419 1420 ## If there are no names, then use the names of 1421 ## the symbols themselves. 1422 if (length(names(symNames)) == 0L) 1423 names(symNames) <- symNames 1424 else if (any(w <- names(symNames) == "")) { 1425 names(symNames)[w] <- symNames[w] 1426 } 1427 1428 ## For each DLL, we build up a list the (R 1429 ## variable name, symbol name) mappings. We do 1430 ## this in a NativeRoutineMap object and we 1431 ## merge potentially multiple useDynLib() 1432 ## directives for the same DLL into a single 1433 ## map. Then we have separate NativeRoutineMap 1434 ## for each different DLL. E.g. if we have 1435 ## useDynLib(foo, a, b, c) and useDynLib(bar, 1436 ## a, x, y) we would maintain and resolve them 1437 ## separately. 1438 1439 dup <- duplicated(names(symNames)) 1440 if (any(dup)) 1441 warning(gettextf("duplicate symbol names %s in useDynLib(\"%s\")", 1442 paste(sQuote(names(symNames)[dup]), 1443 collapse = ", "), dyl), 1444 domain = NA, call. = FALSE) 1445 1446 symNames <- symNames[!dup] 1447 1448 ## Deal with any prefix/suffix pair. 1449 fixes <- c("", "") 1450 idx <- match(".fixes", names(symNames)) 1451 if(!is.na(idx)) { 1452 ## Take .fixes and treat it as a call, 1453 ## e.g. c("pre", "post") or a regular name 1454 ## as the prefix. 1455 if(nzchar(symNames[idx])) { 1456 e <- parse(text = symNames[idx], 1457 keep.source = FALSE, 1458 srcfile = NULL)[[1L]] 1459 if(is.call(e)) 1460 val <- eval(e, .GlobalEnv) 1461 else 1462 val <- as.character(e) 1463 if(length(val)) 1464 fixes[seq_along(val)] <- val 1465 } 1466 symNames <- symNames[-idx] 1467 } 1468 1469 ## Deal with a .registration entry. It must be 1470 ## .registration = value and value will be coerced 1471 ## to a logical. 1472 useRegistration <- FALSE 1473 idx <- match(".registration", names(symNames)) 1474 if(!is.na(idx)) { 1475 useRegistration <- as.logical(symNames[idx]) 1476 symNames <- symNames[-idx] 1477 } 1478 1479 ## Now merge into the NativeRoutineMap. 1480 nativeRoutines[[ dyl ]] <<- 1481 if(dyl %in% names(nativeRoutines)) 1482 mergeNativeRoutineMaps(nativeRoutines[[ dyl ]], 1483 useRegistration, 1484 symNames, fixes) 1485 else 1486 nativeRoutineMap(useRegistration, symNames, 1487 fixes) 1488 } 1489 }, 1490 S3method = { 1491 spec <- e[-1L] 1492 if (length(spec) != 2L && length(spec) != 3L) 1493 stop(gettextf("bad 'S3method' directive: %s", 1494 deparse(e)), 1495 call. = FALSE, domain = NA) 1496 nS3 <<- nS3 + 1L 1497 if(nS3 > nS3methods) { 1498 old <- S3methods 1499 nold <- nS3methods 1500 nS3methods <<- nS3methods * 2L 1501 new <- matrix(NA_character_, nS3methods, 4L) 1502 ind <- seq_len(nold) 1503 for (i in 1:4) new[ind, i] <- old[ind, i] 1504 S3methods <<- new 1505 rm(old, new) 1506 } 1507 if(is.call(gen <- spec[[1L]]) && 1508 identical(as.character(gen[[1L]]), "::")) { 1509 pkg <- as.character(gen[[2L]])[1L] 1510 gen <- as.character(gen[[3L]])[1L] 1511 S3methods[nS3, c(seq_along(spec), 4L)] <<- 1512 c(gen, asChar(spec[-1L]), pkg) 1513 } else 1514 S3methods[nS3, seq_along(spec)] <<- asChar(spec) 1515 }, 1516 stop(gettextf("unknown namespace directive: %s", deparse(e, nlines=1L)), 1517 call. = FALSE, domain = NA) 1518 ) 1519 } 1520 for (e in directives) 1521 parseDirective(e) 1522 1523 ## need to preserve the names on dynlibs, so unique() is not appropriate. 1524 dynlibs <- dynlibs[!duplicated(dynlibs)] 1525 list(imports = imports, exports = exports, 1526 exportPatterns = unique(exportPatterns), 1527 importClasses = importClasses, importMethods = importMethods, 1528 exportClasses = unique(exportClasses), 1529 exportMethods = unique(exportMethods), 1530 exportClassPatterns = unique(exportClassPatterns), 1531 dynlibs = dynlibs, nativeRoutines = nativeRoutines, 1532 S3methods = unique(S3methods[seq_len(nS3), , drop = FALSE]) ) 1533} ## end{parseNamespaceFile} 1534 1535## Still used inside registerS3methods(). 1536registerS3method <- function(genname, class, method, envir = parent.frame()) { 1537 addNamespaceS3method <- function(ns, generic, class, method) { 1538 regs <- rbind(.getNamespaceInfo(ns, "S3methods"), 1539 c(generic, class, method, NA_character_)) 1540 setNamespaceInfo(ns, "S3methods", regs) 1541 } 1542 groupGenerics <- c("Math", "Ops", "Summary", "Complex") 1543 defenv <- if(genname %in% groupGenerics) .BaseNamespaceEnv 1544 else { 1545 genfun <- get(genname, envir = envir) 1546 if(.isMethodsDispatchOn() && methods::is(genfun, "genericFunction")) 1547 genfun <- methods::finalDefaultMethod(genfun@default) 1548 if (typeof(genfun) == "closure") environment(genfun) 1549 else .BaseNamespaceEnv 1550 } 1551 if (is.null(table <- defenv[[".__S3MethodsTable__."]])) { 1552 table <- new.env(hash = TRUE, parent = baseenv()) 1553 defenv[[".__S3MethodsTable__."]] <- table 1554 } 1555 1556 if (is.character(method)) { 1557 assignWrapped <- function(x, method, home, envir) { 1558 method <- method # force evaluation 1559 home <- home # force evaluation 1560 delayedAssign(x, get(method, envir = home), assign.env = envir) 1561 } 1562 if(!exists(method, envir = envir)) { 1563 ## need to avoid conflict with message at l.1298 1564 warning(gettextf("S3 method %s was declared but not found", 1565 sQuote(method)), call. = FALSE) 1566 } else { 1567 assignWrapped(paste(genname, class, sep = "."), method, home = envir, 1568 envir = table) 1569 } 1570 } 1571 else if (is.function(method)) 1572 assign(paste(genname, class, sep = "."), method, envir = table) 1573 else stop("bad method") 1574 if (isNamespace(envir) && ! identical(envir, .BaseNamespaceEnv)) 1575 addNamespaceS3method(envir, genname, class, method) 1576} 1577 1578 1579registerS3methods <- function(info, package, env) 1580{ 1581 n <- NROW(info) 1582 if(n == 0L) return() 1583 1584 assignWrapped <- function(x, method, home, envir) { 1585 method <- method # force evaluation 1586 home <- home # force evaluation 1587 delayedAssign(x, get(method, envir = home), assign.env = envir) 1588 } 1589 overwrite <- matrix(NA_character_, 0, 2) 1590 .registerS3method <- function(genname, class, method, nm, envir) 1591 { 1592 ## S3 generics should either be imported explicitly or be in 1593 ## the base namespace, so we start the search at the imports 1594 ## environment, parent.env(envir), which is followed by the 1595 ## base namespace. (We have already looked in the namespace.) 1596 ## However, in case they have not been imported, we first 1597 ## look up where some commonly used generics are (including the 1598 ## group generics). 1599 defenv <- if(!is.na(w <- .knownS3Generics[genname])) asNamespace(w) 1600 else { 1601 if(is.null(genfun <- get0(genname, envir = parent.env(envir)))) 1602 stop(gettextf("object '%s' not found whilst loading namespace '%s'", 1603 genname, package), call. = FALSE, domain = NA) 1604 if(.isMethodsDispatchOn() && methods::is(genfun, "genericFunction")) 1605 genfun <- genfun@default # nearly always, the S3 generic 1606 if (typeof(genfun) == "closure") environment(genfun) 1607 else .BaseNamespaceEnv 1608 } 1609 if (is.null(table <- defenv[[".__S3MethodsTable__."]])) { 1610 table <- new.env(hash = TRUE, parent = baseenv()) 1611 defenv[[".__S3MethodsTable__."]] <- table 1612 } 1613 if(!is.null(e <- table[[nm]]) && 1614 !identical(e, get(method, envir = envir))) { 1615 current <- environmentName(environment(e)) 1616 overwrite <<- rbind(overwrite, c(as.vector(nm), current)) 1617 } 1618 assignWrapped(nm, method, home = envir, envir = table) 1619 } 1620 1621 methname <- paste(info[,1], info[,2], sep = ".") 1622 z <- is.na(info[,3]) 1623 info[z,3] <- methname[z] 1624 ## Simpler to re-arrange so that packages for delayed registration 1625 ## come in the last column, and the non-delayed registration code 1626 ## can remain unchanged. 1627 if(ncol(info) == 3L) 1628 info <- cbind(info, NA_character_) 1629 Info <- cbind(info[, 1L : 3L, drop = FALSE], methname, info[, 4L]) 1630 loc <- names(env) 1631 if(any(notex <- match(info[,3], loc, nomatch=0L) == 0L)) { # not %in% 1632 warning(sprintf(ngettext(sum(notex), 1633 "S3 method %s was declared in NAMESPACE but not found", 1634 "S3 methods %s were declared in NAMESPACE but not found"), 1635 paste(sQuote(info[notex, 3]), collapse = ", ")), 1636 call. = FALSE, domain = NA) 1637 Info <- Info[!notex, , drop = FALSE] 1638 } 1639 eager <- is.na(Info[, 5L]) 1640 delayed <- Info[!eager, , drop = FALSE] 1641 Info <- Info[ eager, , drop = FALSE] 1642 1643 ## Do local generics first (this could be load-ed if pre-computed). 1644 ## However, the local generic could be an S4 takeover of a non-local 1645 ## (or local) S3 generic. We can't just pass S4 generics on to 1646 ## .registerS3method as that only looks non-locally (for speed). 1647 l2 <- localGeneric <- Info[,1] %in% loc 1648 if(.isMethodsDispatchOn()) 1649 for(i in which(localGeneric)) { 1650 genfun <- get(Info[i, 1], envir = env) 1651 if(methods::is(genfun, "genericFunction")) { 1652 localGeneric[i] <- FALSE 1653 registerS3method(Info[i, 1], Info[i, 2], Info[i, 3], env) 1654 } 1655 } 1656 if(any(localGeneric)) { 1657 lin <- Info[localGeneric, , drop = FALSE] 1658 S3MethodsTable <- env[[".__S3MethodsTable__."]] 1659 ## we needed to move this to C for speed. 1660 ## for(i in seq_len(nrow(lin))) 1661 ## assign(lin[i,4], get(lin[i,3], envir = env), 1662 ## envir = S3MethodsTable) 1663 .Internal(importIntoEnv(S3MethodsTable, lin[,4], env, lin[,3])) 1664 } 1665 1666 ## now the rest 1667 fin <- Info[!l2, , drop = FALSE] 1668 for(i in seq_len(nrow(fin))) 1669 .registerS3method(fin[i, 1], fin[i, 2], fin[i, 3], fin[i, 4], env) 1670 if(package != "MASS" && nrow(overwrite)) { 1671 ## MASS is providing methods for stubs in stats. 1672 .fmt <- function(o) { 1673 sprintf(" %s %s", 1674 format(c("method", o[, 1L])), 1675 format(c("from", o[, 2L]))) 1676 } 1677 ## Unloading does not unregister, so reloading "overwrites": 1678 ## hence, always drop same-package overwrites. 1679 overwrite <- 1680 overwrite[overwrite[, 2L] != package, , drop = FALSE] 1681 ## (Seen e.g. for recommended packages in reg-tests-3.R.) 1682 if(Sys.getenv("_R_LOAD_CHECK_OVERWRITE_S3_METHODS_") %in% c(package, "all")) { 1683 ind <- overwrite[, 2L] %in% 1684 unlist(tools:::.get_standard_package_names(), 1685 use.names = FALSE) 1686 bad <- overwrite[ind, , drop = FALSE] 1687 if(nr <- nrow(bad)) { 1688 msg <- ngettext(nr, 1689 "Registered S3 method from a standard package overwritten by '%s':", 1690 "Registered S3 methods from standard package(s) overwritten by '%s':", 1691 domain = NA) 1692 msg <- paste(c(sprintf(msg, package), .fmt(bad)), 1693 collapse = "\n") 1694 message(msg, domain = NA) 1695 overwrite <- overwrite[!ind, , drop = FALSE] 1696 } 1697 } 1698 ## Do not note when 1699 ## * There are no overwrites (left) 1700 ## * Env var _R_S3_METHOD_REGISTRATION_NOTE_OVERWRITES_ is set 1701 ## to something false (for the time being) 1702 ## * Env var _R_CHECK_PACKAGE_NAME_ is set to something 1703 ## different than 'package'. 1704 ## With the last, when checking we only note overwrites from the 1705 ## package under check (as recorded via _R_CHECK_PACKAGE_NAME_). 1706 if((nr <- nrow(overwrite)) && 1707 is.na(match(tolower(Sys.getenv("_R_S3_METHOD_REGISTRATION_NOTE_OVERWRITES_")), 1708 c("0", "no", "false"))) && 1709 (!is.na(match(Sys.getenv("_R_CHECK_PACKAGE_NAME_"), 1710 c("", package))))) { 1711 msg <- ngettext(nr, 1712 "Registered S3 method overwritten by '%s':", 1713 "Registered S3 methods overwritten by '%s':", 1714 domain = NA) 1715 msg <- paste(c(sprintf(msg, package), .fmt(overwrite)), 1716 collapse = "\n") 1717 packageStartupMessage(msg, domain = NA) 1718 } 1719 } 1720 1721 register_S3_method_delayed <- function(pkg, gen, cls, fun) { 1722 pkg <- pkg # force evaluation 1723 gen <- gen # force evaluation 1724 cls <- cls # force evaluation 1725 fun <- fun # force evaluation 1726 if(isNamespaceLoaded(pkg)) { 1727 registerS3method(gen, cls, fun, 1728 envir = asNamespace(pkg)) 1729 } 1730 setHook(packageEvent(pkg, "onLoad"), 1731 function(...) { 1732 registerS3method(gen, cls, fun, 1733 envir = asNamespace(pkg)) 1734 }) 1735 } 1736 if(nrow(delayed)) { 1737 for(i in seq_len(nrow(delayed))) { 1738 gen <- delayed[i, 1L] 1739 cls <- delayed[i, 2L] 1740 fun <- get(delayed[i, 3L], envir = env) 1741 pkg <- delayed[i, 5L] 1742 register_S3_method_delayed(pkg, gen, cls, fun) 1743 } 1744 } 1745 1746 ## Provide useful error message to user in case of ncol() mismatch: 1747 nsI <- getNamespaceInfo(env, "S3methods") 1748 if(!is.null(p1 <- ncol(nsI)) && !is.null(p2 <- ncol(info)) && p1 != p2) 1749 stop(gettextf( 1750 paste('While loading namespace "%s": "%s" differ in ncol(.), env=%d, newNS=%d.', 1751 "Maybe package installed with version of R newer than %s ?", 1752 sep="\n"), 1753 package, "S3methods", p1, p2, getRversion()), domain = NA) 1754 setNamespaceInfo(env, "S3methods", rbind(info, nsI)) 1755} 1756 1757.mergeImportMethods <- function(impenv, expenv, metaname) 1758{ 1759 impMethods <- impenv[[metaname]] 1760 if(!is.null(impMethods)) 1761 impenv[[metaname]] <- 1762 methods:::.mergeMethodsTable2(impMethods, 1763 newtable = expenv[[metaname]], # known to exist by caller 1764 expenv, metaname) 1765 impMethods # possibly NULL 1766} 1767 1768.S3method <- function(generic, class, method) { 1769 if(missing(method)) method <- paste(generic, class, sep = ".") 1770 method <- match.fun(method) 1771 registerS3method(generic, class, method, envir = parent.frame()) 1772 invisible(NULL) 1773} 1774