This repository was archived by the owner on Nov 11, 2018. It is now read-only.
forked from RcppCore/Rcpp
-
Notifications
You must be signed in to change notification settings - Fork 0
Expand file tree
/
Copy pathloadModule.R
More file actions
121 lines (113 loc) · 4.38 KB
/
loadModule.R
File metadata and controls
121 lines (113 loc) · 4.38 KB
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
# Copyright (C) 2010 - 2012 John Chambers, Dirk Eddelbuettel and Romain Francois
#
# This file is part of Rcpp.
#
# Rcpp 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.
#
# Rcpp 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.
#
# You should have received a copy of the GNU General Public License
# along with Rcpp. If not, see <http://www.gnu.org/licenses/>.
## the following items are to get around some insanity in the
## CMD check of packages using Rcpp that dies in loadModule()
## because some code somewhere can't find the methods package
isBotchedSession <- function()
! ("package:methods" %in% search())
.moduleNames <- function(what) {
assignAs <- allNames(what)
sameNames <- !nzchar(assignAs)
assignAs[sameNames] <- what[sameNames]
assignAs
}
.DummyModule <- function(name, what) {
value <- new.env()
storage <- new.env()
assign("storage", storage, envir = value)
assign("moduleName", name, envir = value)
allNames <- names(.moduleNames(what))
for(el in allNames)
assign(el, NULL, envir = storage)
value
}
.moduleMetaName <- function(name)
methods::methodsPackageMetaName("Mod",name)
moduleIsLoaded <- function(name, env)
exists(.moduleMetaName(name), envir = env, inherits = FALSE)
loadModule <- function( module, what = character(), loadNow,
env = topenv(parent.frame())) {
if(is(module, "character")) {
loadM <- NULL
metaName <- .moduleMetaName(module)
if(exists(metaName, envir = env, inherits = FALSE))
loadM <- get(metaName, envir = env)
}
else if(is(module, "Module")) {
loadM <- as.environment(module)
module <- get(loadM, "moduleName")
}
else
stop(gettextf("Argument \"module\" should be a module or the name of a module: got an object of class \"%s\"", class(module)))
if(missing(loadNow)) { # test it
if(is.null(loadM))
loadM <- tryCatch(Module( module, mustStart = TRUE, where = env ),
error = function(e)e)
loadNow <- !is(loadM, "error")
}
if(loadNow) {
.botched <- isBotchedSession()
if(is.null(loadM))
loadM <- tryCatch(Module( module, mustStart = TRUE, where = env ),
error = function(e)e)
if(is(loadM, "error")) {
if(.botched)
return(.DummyModule(module, what))
stop(gettextf("Unable to load module \"%s\": %s",
as(module, "character"), loadM$message))
}
if(!exists(metaName, envir = env, inherits =FALSE))
assign(metaName, loadM, envir = env)
if(!length(what)) # no assignments
return(loadM)
env <- as.environment(env)
## get the storage environment, for what=TRUE
storage <- as.environment(get( "storage", as.environment(loadM ) ))
if(identical(what, TRUE))
what <- objects(storage)
missingObjs <- !sapply(what, function(symb) exists(symb, envir = storage, inherits = FALSE))
if(any(missingObjs)) {
if(.botched) {
for(el in what[missingObjs])
assign(el, NULL, envir = storage)
}
else {
warning(gettextf("%s not found in module \"%s\"",
paste0('"', what[missingObjs], '"', collapse = ", "),
as.character(module)))
what <- what[!missingObjs]
}
}
assignAs <- .moduleNames(what)
for( i in seq_along(what) ) {
if(.botched)
assign(assignAs[[i]], NULL, envir = storage)
else
assign(assignAs[[i]], get(what[[i]], envir = storage), envir = env)
}
loadM
}
else { # create a load action to recall this function
myCall <- match.call()
f <- function(ns) NULL
myCall$env <- as.name("ns")
myCall$loadNow <- TRUE
body(f, envir = env) <- myCall
setLoadAction(f, where = env)
invisible(myCall)
}
}