View | Details | Raw Unified | Return to bug 16490 | Differences between
and this patch

Collapse All | Expand All

(-)src/library/base/R/namespace.R (-48 / +34 lines)
Lines 19-24 Link Here
19
## give the base namespace a table for registered methods
19
## give the base namespace a table for registered methods
20
`.__S3MethodsTable__.` <- new.env(hash = TRUE, parent = baseenv())
20
`.__S3MethodsTable__.` <- new.env(hash = TRUE, parent = baseenv())
21
21
22
.hasS4MetaData <- function(env) {
23
    length(grep("^[.]__[CTA]_", names(env))) > 0L
24
}
25
                          
26
22
## NOTA BENE:
27
## NOTA BENE:
23
##  1) This code should work also when methods is not yet loaded
28
##  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
29
##  2) We use  ':::' instead of '::' inside the code below, for efficiency only
Lines 89-100 Link Here
89
	get(name, envir = ns, inherits = FALSE) # incl. error
94
	get(name, envir = ns, inherits = FALSE) # incl. error
90
    else {
95
    else {
91
	if (!is.null(oNam <- .getNamespaceInfo(ns, "exports")[[name]])) {
96
	if (!is.null(oNam <- .getNamespaceInfo(ns, "exports")[[name]])) {
92
	    get0(oNam, envir = ns)
97
	    get0(oNam, envir = ns) # inherits = TRUE necessary, so can't be [[
93
	} else { ##  <pkg> :: <dataset>  for lazydata :
98
	} else { ##  <pkg> :: <dataset>  for lazydata :
94
	    ld <- .getNamespaceInfo(ns, "lazydata")
99
	    ld <- .getNamespaceInfo(ns, "lazydata")
95
	    if (!is.null(obj <- get0(name, envir = ld, inherits = FALSE)))
100
	    if (!is.null(obj <- ld[[name]])) {
96
		obj
101
		obj
97
	    else { ## if there's a lazydata object with value NULL:
102
	    } else { ## if there's a lazydata object with value NULL:
98
		if(exists(name, envir = ld, inherits = FALSE))
103
		if(exists(name, envir = ld, inherits = FALSE))
99
		    NULL
104
		    NULL
100
		else
105
		else
Lines 126-132 Link Here
126
{
131
{
127
    ## only used to run .onAttach
132
    ## only used to run .onAttach
128
    runHook <- function(hookname, env, libname, pkgname) {
133
    runHook <- function(hookname, env, libname, pkgname) {
129
        if (!is.null(fun <- get0(hookname, envir = env, inherits = FALSE))) {
134
        if (!is.null(fun <- env[[hookname]])) {
130
            res <- tryCatch(fun(libname, pkgname), error = identity)
135
            res <- tryCatch(fun(libname, pkgname), error = identity)
131
            if (inherits(res, "error")) {
136
            if (inherits(res, "error")) {
132
                stop(gettextf("%s failed in %s() for '%s', details:\n  call: %s\n  error: %s",
137
                stop(gettextf("%s failed in %s() for '%s', details:\n  call: %s\n  error: %s",
Lines 162-168 Link Here
162
    dimpenv <- .getNamespaceInfo(ns, "lazydata")
167
    dimpenv <- .getNamespaceInfo(ns, "lazydata")
163
    dnames <- names(dimpenv)
168
    dnames <- names(dimpenv)
164
    .Internal(importIntoEnv(env, dnames, dimpenv, dnames))
169
    .Internal(importIntoEnv(env, dnames, dimpenv, dnames))
165
    if(length(depends)) assign(".Depends", depends, env)
170
    if(length(depends)) env[[".Depends"]] <- depends
166
    Sys.setenv("_R_NS_LOAD_" = nsname)
171
    Sys.setenv("_R_NS_LOAD_" = nsname)
167
    on.exit(Sys.unsetenv("_R_NS_LOAD_"), add = TRUE)
172
    on.exit(Sys.unsetenv("_R_NS_LOAD_"), add = TRUE)
168
    runHook(".onAttach", ns, dirname(nspath), nsname)
173
    runHook(".onAttach", ns, dirname(nspath), nsname)
Lines 217-223 Link Here
217
    } else {
222
    } else {
218
        ## only used here for .onLoad
223
        ## only used here for .onLoad
219
        runHook <- function(hookname, env, libname, pkgname) {
224
        runHook <- function(hookname, env, libname, pkgname) {
220
	    if (!is.null(fun <- get0(hookname, envir = env, inherits = FALSE))) {
225
	    if (!is.null(fun <- env[[hookname]])) {
221
                res <- tryCatch(fun(libname, pkgname), error = identity)
226
                res <- tryCatch(fun(libname, pkgname), error = identity)
222
                if (inherits(res, "error")) {
227
                if (inherits(res, "error")) {
223
                    stop(gettextf("%s failed in %s() for '%s', details:\n  call: %s\n  error: %s",
228
                    stop(gettextf("%s failed in %s() for '%s', details:\n  call: %s\n  error: %s",
Lines 239-246 Link Here
239
            name <- as.character(as.name(name))
244
            name <- as.character(as.name(name))
240
            version <- as.character(version)
245
            version <- as.character(version)
241
            info <- new.env(hash = TRUE, parent = baseenv())
246
            info <- new.env(hash = TRUE, parent = baseenv())
242
            assign(".__NAMESPACE__.", info, envir = env)
247
            env[[".__NAMESPACE__."]] <- info
243
            assign("spec", c(name = name, version = version), envir = info)
248
            info[["spec"]] <- c(name = name, version = version)
244
            setNamespaceInfo(env, "exports", new.env(hash = TRUE, parent = baseenv()))
249
            setNamespaceInfo(env, "exports", new.env(hash = TRUE, parent = baseenv()))
245
            dimpenv <- new.env(parent = baseenv(), hash = TRUE)
250
            dimpenv <- new.env(parent = baseenv(), hash = TRUE)
246
            attr(dimpenv, "name") <- paste("lazydata", name, sep = ":")
251
            attr(dimpenv, "name") <- paste("lazydata", name, sep = ":")
Lines 251-259 Link Here
251
                             normalizePath(file.path(lib, name), "/", TRUE))
256
                             normalizePath(file.path(lib, name), "/", TRUE))
252
            setNamespaceInfo(env, "dynlibs", NULL)
257
            setNamespaceInfo(env, "dynlibs", NULL)
253
            setNamespaceInfo(env, "S3methods", matrix(NA_character_, 0L, 3L))
258
            setNamespaceInfo(env, "S3methods", matrix(NA_character_, 0L, 3L))
254
            assign(".__S3MethodsTable__.",
259
            env[[".__S3MethodsTable__."]] <- new.env(hash = TRUE, parent = baseenv())
255
                   new.env(hash = TRUE, parent = baseenv()),
256
                   envir = env)
257
            .Internal(registerNamespace(name, env))
260
            .Internal(registerNamespace(name, env))
258
            env
261
            env
259
        }
262
        }
Lines 302-308 Link Here
302
                                                           sym$name, varName, varName, sQuote(package)),
305
                                                           sym$name, varName, varName, sQuote(package)),
303
                                                  domain = NA)
306
                                                  domain = NA)
304
                                      else
307
                                      else
305
                                          assign(varName, sym, envir = env)
308
                                          env[[varName]] <- sym
306
                                  })
309
                                  })
307
                       })
310
                       })
308
311
Lines 330-336 Link Here
330
                                                origVarName, varName, sQuote(package)),
333
                                                origVarName, varName, sQuote(package)),
331
                                       domain = NA)
334
                                       domain = NA)
332
                       else
335
                       else
333
                           assign(varName, symbols[[origVarName]], envir = env)
336
                           env[[varName]] <- symbols[[origVarName]]
334
337
335
                   })
338
                   })
336
            symbols
339
            symbols
Lines 426-432 Link Here
426
429
427
        env <- asNamespace(ns)
430
        env <- asNamespace(ns)
428
        ## save the package name in the environment
431
        ## save the package name in the environment
429
        assign(".packageName", package, envir = env)
432
        env[[".packageName"]] <- package
430
433
431
        ## load the code
434
        ## load the code
432
        codename <- strsplit(package, "_", fixed = TRUE)[[1L]][1L]
435
        codename <- strsplit(package, "_", fixed = TRUE)[[1L]][1L]
Lines 473-479 Link Here
473
            ## dynlibs vector.
476
            ## dynlibs vector.
474
            if(!is.null(names(nsInfo$dynlibs))
477
            if(!is.null(names(nsInfo$dynlibs))
475
               && nzchar(names(nsInfo$dynlibs)[i]))
478
               && nzchar(names(nsInfo$dynlibs)[i]))
476
                assign(names(nsInfo$dynlibs)[i], dlls[[lib]], envir = env)
479
                env[[names(nsInfo$dynlibs)[i]]] <- dlls[[lib]]
477
            setNamespaceInfo(env, "DLLs", dlls)
480
            setNamespaceInfo(env, "DLLs", dlls)
478
        }
481
        }
479
        addNamespaceDynLibs(env, nsInfo$dynlibs)
482
        addNamespaceDynLibs(env, nsInfo$dynlibs)
Lines 491-497 Link Here
491
        for (p in nsInfo$exportPatterns)
494
        for (p in nsInfo$exportPatterns)
492
            exports <- c(ls(env, pattern = p, all.names = TRUE), exports)
495
            exports <- c(ls(env, pattern = p, all.names = TRUE), exports)
493
        ##
496
        ##
494
        if(.isMethodsDispatchOn() && methods:::.hasS4MetaData(ns) &&
497
        if(.isMethodsDispatchOn() && .hasS4MetaData(ns) &&
495
           !identical(package, "methods") ) {
498
           !identical(package, "methods") ) {
496
            ## cache generics, classes in this namespace (but not methods itself,
499
            ## cache generics, classes in this namespace (but not methods itself,
497
            ## which pre-cached at install time
500
            ## which pre-cached at install time
Lines 609-619 Link Here
609
                ## the internal table.
612
                ## the internal table.
610
                pm <- allGenerics[!(allGenerics %in% expMethods)]
613
                pm <- allGenerics[!(allGenerics %in% expMethods)]
611
                if(length(pm)) {
614
                if(length(pm)) {
612
                    prim <- logical(length(pm))
615
                    prim <- vapply(pm, function(x) {
613
                    for(i in seq_along(prim)) {
616
                                       is.primitive(methods::getFunction(x, FALSE, FALSE, ns))
614
                        f <- methods::getFunction(pm[[i]], FALSE, FALSE, ns)
617
                                   }, logical(1))
615
                        prim[[i]] <- is.primitive(f)
616
                    }
617
                    expMethods <- c(expMethods, pm[prim])
618
                    expMethods <- c(expMethods, pm[prim])
618
                }
619
                }
619
                for(i in seq_along(expMethods)) {
620
                for(i in seq_along(expMethods)) {
Lines 691-710 Link Here
691
692
692
topenv <- function(envir = parent.frame(),
693
topenv <- function(envir = parent.frame(),
693
                   matchThisEnv = getOption("topLevelEnvironment")) {
694
                   matchThisEnv = getOption("topLevelEnvironment")) {
694
    ## while (! identical(envir, emptyenv())) {
695
    ##     nm <- attributes(envir)[["names", exact = TRUE]]
696
    ##     if ((is.character(nm) && length(grep("^package:" , nm))) ||
697
    ##         ## matchThisEnv is used in sys.source
698
    ##         identical(envir, matchThisEnv) ||
699
    ##         identical(envir, .GlobalEnv) ||
700
    ##         identical(envir, baseenv()) ||
701
    ##         .Internal(isNamespaceEnv(envir)) ||
702
    ##         ## packages except base and those with a separate namespace have .packageName
703
    ##         exists(".packageName", envir = envir, inherits = FALSE))
704
    ##         return(envir)
705
    ##     else envir <- parent.env(envir)
706
    ## }
707
    ## return(.GlobalEnv)
708
    .Internal(topenv(envir, matchThisEnv))
695
    .Internal(topenv(envir, matchThisEnv))
709
}
696
}
710
697
Lines 712-718 Link Here
712
{
699
{
713
    ## only used to run .onUnload
700
    ## only used to run .onUnload
714
    runHook <- function(hookname, env, ...) {
701
    runHook <- function(hookname, env, ...) {
715
	if (!is.null(fun <- get0(hookname, envir = env, inherits = FALSE))) {
702
	if (!is.null(fun <- env[[hookname]])) {
716
            res <- tryCatch(fun(...), error=identity)
703
            res <- tryCatch(fun(...), error=identity)
717
            if (inherits(res, "error")) {
704
            if (inherits(res, "error")) {
718
                warning(gettextf("%s failed in %s() for '%s', details:\n  call: %s\n  error: %s",
705
                warning(gettextf("%s failed in %s() for '%s', details:\n  call: %s\n  error: %s",
Lines 738-744 Link Here
738
    for(fun in rev(hook)) try(fun(nsname, nspath))
725
    for(fun in rev(hook)) try(fun(nsname, nspath))
739
    runHook(".onUnload", ns, nspath)
726
    runHook(".onUnload", ns, nspath)
740
    .Internal(unregisterNamespace(nsname))
727
    .Internal(unregisterNamespace(nsname))
741
    if(.isMethodsDispatchOn() && methods:::.hasS4MetaData(ns))
728
    if(.isMethodsDispatchOn() && .hasS4MetaData(ns))
742
        methods::cacheMetaData(ns, FALSE, ns)
729
        methods::cacheMetaData(ns, FALSE, ns)
743
    .Internal(lazyLoadDBflush(paste0(nspath, "/R/", nsname, ".rdb")))
730
    .Internal(lazyLoadDBflush(paste0(nspath, "/R/", nsname, ".rdb")))
744
    invisible()
731
    invisible()
Lines 881-887 Link Here
881
	}
868
	}
882
    }
869
    }
883
    for (n in impnames)
870
    for (n in impnames)
884
	if (!is.null(genImp <- get0(n, envir = impenv, inherits = FALSE))) {
871
	if (!is.null(genImp <- impenv[[n]])) {
885
	    if (.isMethodsDispatchOn() && methods::isGeneric(n, ns)) {
872
	    if (.isMethodsDispatchOn() && methods::isGeneric(n, ns)) {
886
		## warn only if generic overwrites a function which
873
		## warn only if generic overwrites a function which
887
		## it was not derived from
874
		## it was not derived from
Lines 1016-1022 Link Here
1016
                                paste(sQuote(expnames[ex]), collapse = ", ")),
1003
                                paste(sQuote(expnames[ex]), collapse = ", ")),
1017
                        call. = FALSE, domain = NA)
1004
                        call. = FALSE, domain = NA)
1018
            for (i in seq_along(new))
1005
            for (i in seq_along(new))
1019
                assign(expnames[i], intnames[i], envir = exports)
1006
                exports[[expnames[i]]] <- intnames[i]
1020
        }
1007
        }
1021
        makeImportExportNames <- function(spec) {
1008
        makeImportExportNames <- function(spec) {
1022
            old <- as.character(spec)
1009
            old <- as.character(spec)
Lines 1048-1056 Link Here
1048
    newMethods <- new[substr(new, 1L, nchar(mm, type = "c")) == mm]
1035
    newMethods <- new[substr(new, 1L, nchar(mm, type = "c")) == mm]
1049
    nsimports <- parent.env(ns)
1036
    nsimports <- parent.env(ns)
1050
    for(what in newMethods) {
1037
    for(what in newMethods) {
1051
	if(!is.null(m1 <- get0(what, envir = nsimports, inherits = FALSE))) {
1038
	if(!is.null(m1 <- nsimports[[what]])) {
1052
            m2 <- get(what, envir = ns)
1039
            m2 <- get(what, envir = ns)
1053
            assign(what, envir = ns, methods::mergeMethods(m1, m2))
1040
            ns[[what]] <- methods::mergeMethods(m1, m2)
1054
        }
1041
        }
1055
    }
1042
    }
1056
}
1043
}
Lines 1336-1344 Link Here
1336
        if (typeof(genfun) == "closure") environment(genfun)
1323
        if (typeof(genfun) == "closure") environment(genfun)
1337
	else .BaseNamespaceEnv
1324
	else .BaseNamespaceEnv
1338
    }
1325
    }
1339
    if (is.null(table <- get0(".__S3MethodsTable__.", envir = defenv, inherits = FALSE))) {
1326
    if (is.null(table <- defenv[[".__S3MethodsTable__."]])) {
1340
	table <- new.env(hash = TRUE, parent = baseenv())
1327
	table <- 
1341
	assign(".__S3MethodsTable__.", table, envir = defenv)
1328
	defenv[[".__S3MethodsTable__."]] <- table
1342
    }
1329
    }
1343
1330
1344
    if (is.character(method)) {
1331
    if (is.character(method)) {
Lines 1394-1402 Link Here
1394
            if (typeof(genfun) == "closure") environment(genfun)
1381
            if (typeof(genfun) == "closure") environment(genfun)
1395
            else .BaseNamespaceEnv
1382
            else .BaseNamespaceEnv
1396
        }
1383
        }
1397
	if (is.null(table <- get0(".__S3MethodsTable__.", envir = defenv, inherits = FALSE))) {
1384
	if (is.null(table <- defenv[[".__S3MethodsTable__."]])) {
1398
	    table <- new.env(hash = TRUE, parent = baseenv())
1385
	    table <- new.env(hash = TRUE, parent = baseenv())
1399
	    assign(".__S3MethodsTable__.", table, envir = defenv)
1386
	    defenv[[".__S3MethodsTable__."]] <- table
1400
	}
1387
	}
1401
        if(!is.null(e <- table[[nm]])) {
1388
        if(!is.null(e <- table[[nm]])) {
1402
            current <- environmentName(environment(e))
1389
            current <- environmentName(environment(e))
Lines 1434-1441 Link Here
1434
        }
1421
        }
1435
    if(any(localGeneric)) {
1422
    if(any(localGeneric)) {
1436
        lin <- Info[localGeneric, , drop = FALSE]
1423
        lin <- Info[localGeneric, , drop = FALSE]
1437
        S3MethodsTable <-
1424
        S3MethodsTable <- env[[".__S3MethodsTable__."]]
1438
            get(".__S3MethodsTable__.", envir = env, inherits = FALSE)
1439
        ## we needed to move this to C for speed.
1425
        ## we needed to move this to C for speed.
1440
        ## for(i in seq_len(nrow(lin)))
1426
        ## for(i in seq_len(nrow(lin)))
1441
        ##    assign(lin[i,4], get(lin[i,3], envir = env),
1427
        ##    assign(lin[i,4], get(lin[i,3], envir = env),
(-)src/library/methods/R/RMethodUtils.R (-4 lines)
Lines 1532-1541 Link Here
1532
}
1532
}
1533
1533
1534
1534
1535
.hasS4MetaData <- function(env)
1536
  (length(objects(env, all.names = TRUE,
1537
                          pattern = "^[.]__[CTA]_")))
1538
1539
## turn ordinary generic into one that dispatches on "..."
1535
## turn ordinary generic into one that dispatches on "..."
1540
## currently only called in one place from setGeneric()
1536
## currently only called in one place from setGeneric()
1541
.dotsGeneric <- function(f)
1537
.dotsGeneric <- function(f)
(-)src/library/methods/R/zzz.R (-1 / +1 lines)
Lines 129-135 Link Here
129
    env <- environment(sys.function())
129
    env <- environment(sys.function())
130
    ## unlock some bindings that must be modifiable
130
    ## unlock some bindings that must be modifiable
131
    unlockBinding(".BasicFunsList", env)
131
    unlockBinding(".BasicFunsList", env)
132
    if(methods:::.hasS4MetaData(.GlobalEnv)) {
132
    if(.hasS4MetaData(.GlobalEnv)) {
133
        result <- try(cacheMetaData(.GlobalEnv, TRUE))
133
        result <- try(cacheMetaData(.GlobalEnv, TRUE))
134
        ## still attach  methods package if global env has bad objets
134
        ## still attach  methods package if global env has bad objets
135
        if(is(result, "try-error"))
135
        if(is(result, "try-error"))

Return to bug 16490