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
|
#' @export
cleanup <- function(...) UseMethod("cleanup")
#' Drop certain types of globals
#'
#' @param globals A Globals object.
#' @param drop A character vector specifying what type of globals to drop.
#' @param \dots Not used
#'
#' @aliases cleanup
#' @export
cleanup.Globals <- function(globals, drop = c("missing", "base-packages", "nativesymbolinfo"), ...) {
where <- attr(globals, "where", exact = TRUE)
names <- names(globals)
keep <- rep(TRUE, times = length(globals))
names(keep) <- names
## Drop non-found objects
drop_missing <- "missing" %in% drop
## Drop objects that are part of one of the "base" packages
drop_base <- "base-packages" %in% drop
## Drop objects that are primitive functions
drop_primitives <- "primitives" %in% drop
## Drop objects that calls .Internal()
drop_internals <- "internals" %in% drop
## Drop objects that are of class NativeSymbolInfo used in calls
## to .Call(), .Call.graphics(), .External(), .External2(), and
## .External.graphics()
drop_native_symbol_info <- "nativesymbolinfo" %in% drop
for (name in names) {
env <- where[[name]]
if (drop_missing && is.null(env)) {
keep[[name]] <- FALSE
next
}
## Never drop globals that are not in package environments.
## This will drop local copies of package objects, e.g.
## myView <- utils::View and format.aspell <- utils:::format.aspell
if (is.environment(env) && !isPackageNamespace(env)) {
next
}
env_name <- environmentName(env)
env_name <- gsub("^package:", "", env_name)
## Never drop a global that is copy of an exported package object but
## has different name than the exported object. This avoids dropping
## local, renamed copies of package objects in a list, e.g.
## globals <- globals::as.Globals(list(
## identity = base::identity,
## my_identity = base::identity, ## should be kept
## print.aspell = utils:::print.aspell, ## should be kept
## my_print.aspell = utils:::print.aspell ## should be kept
## ))
## https://github.com/HenrikBengtsson/globals/issues/57
## Is the global an exported package object?
is_exported <- exists(name, envir = asPkgEnvironment(env_name))
if (is_exported && drop_base && is_base_pkg(env_name)) {
keep[[name]] <- FALSE
next
}
global <- globals[[name]]
## Example: base::rm()
if (is_exported && drop_primitives && is.primitive(global)) {
keep[[name]] <- FALSE
next
}
## Example: base::quit()
if (is_exported && drop_internals && is_internal(global)) {
keep[[name]] <- FALSE
next
}
## Is the the global a non-exported package object?
is_private <- !is_exported && exists(name, envir = env)
## Example: base::.C_R_addTaskCallback
if ((is_exported || is_private) &&
drop_native_symbol_info && is_native_symbol_info(global)) {
keep[[name]] <- FALSE
next
}
}
if (!all(keep)) {
globals <- globals[keep]
}
globals
}
|
