1#' Return the namespace environment for a package.
2#'
3#' Contains all (exported and non-exported) objects, and is a descendant of
4#' `R_GlobalEnv`. The hierarchy is `<namespace:pkg>`,
5#' `<imports:pkg>`, `<namespace:base>`, and then
6#' `R_GlobalEnv`.
7#'
8#' If the package is not loaded, this function returns `NULL`.
9#'
10#' @param package package name.
11#' @keywords internal
12#' @seealso [pkg_env()] for the attached environment that
13#'   contains the exported objects.
14#' @seealso [imports_env()] for the environment that contains
15#'   imported objects for the package.
16#' @export
17ns_env <- function(package) {
18  if (!is_loaded(package)) return(NULL)
19
20  asNamespace(package)
21}
22
23ns_path <- function(package) {
24  ns <- asNamespace(package)
25  if (isBaseNamespace(ns))
26    return(path.package(package))
27  getNamespaceInfo(ns, "path")
28}
29
30# Create the namespace environment for a package
31create_ns_env <- function(path = ".") {
32  path <- pkg_path(path)
33  package <- pkg_name(path)
34  version <- pkg_version(path)
35
36  if (is_loaded(package)) {
37    stop("Namespace for ", package, " already exists.")
38  }
39
40  env <- makeNamespace(package, version)
41  methods::setPackageName(package, env)
42  # Create devtools metadata in namespace
43  create_dev_meta(package)
44
45  setNamespaceInfo(env, "path", path)
46  setup_ns_imports(path)
47
48  env
49}
50
51# This is taken directly from base::loadNamespace()
52# https://github.com/wch/r-source/blob/tags/R-3-3-0/src/library/base/R/namespace.R#L235-L258
53onload_assign("makeNamespace",
54  eval(
55    modify_lang(
56      extract_lang(body(loadNamespace),
57
58        # Find makeNamespace definition
59        comp_lang, y = quote(makeNamespace <- NULL), idx = 1:2)[[3]],
60
61      # Replace call to .Internal(registerNamespace()) is replaced by a call to
62      # register_namespace
63      function(x) {
64        if (comp_lang(x, quote(.Internal(registerNamespace(name, env))))) {
65          quote(register_namespace(name, env))
66        } else {
67          x
68        }
69      }))
70)
71
72# Read the NAMESPACE file and set up the imports metdata.
73# (which is stored in .__NAMESPACE__.)
74setup_ns_imports <- function(path = ".") {
75  path <- pkg_path(path)
76  package <- pkg_name(path)
77
78  nsInfo <- parse_ns_file(path)
79  setNamespaceInfo(package, "imports", nsInfo$imports)
80}
81
82
83# Read the NAMESPACE file and set up the exports metdata. This must be
84# run after all the objects are loaded into the namespace because
85# namespaceExport throw errors if the objects are not present.
86setup_ns_exports <- function(path = ".", export_all = FALSE, export_imports = export_all) {
87  path <- pkg_path(path)
88  package <- pkg_name(path)
89
90  nsInfo <- parse_ns_file(path)
91  nsenv <- ns_env(package)
92
93  if (export_all) {
94    exports <- ls(nsenv, all.names = TRUE)
95    # Make sure to re-export objects that are imported from other packages but
96    # not copied.
97    exports <- union(exports, nsInfo$exports)
98
99    # if export_imports export all imports as well
100    if (export_imports) {
101      exports <- c(exports, ls(imports_env(package), all.names = TRUE))
102    }
103
104    # List of things to ignore is from loadNamespace. There are also a
105    # couple things to ignore from devtools.
106    ignoreidx <- exports %in% c( ".__NAMESPACE__.",
107      ".__S3MethodsTable__.", ".packageName", ".First.lib", ".onLoad",
108      ".onAttach", ".conflicts.OK", ".noGenerics",
109      ".__DEVTOOLS__", ".cache")
110    exports <- exports[!ignoreidx]
111
112  } else {
113    # This code is from base::loadNamespace
114    exports <- nsInfo$exports
115    for (p in nsInfo$exportPatterns)
116      exports <- c(ls(nsenv, pattern = p, all.names = TRUE), exports)
117  }
118  # Don't try to export objects that are missing from the namespace and imports
119  ns_and_imports <- c(ls(nsenv, all.names = TRUE),
120                      ls(imports_env(package), all.names = TRUE))
121  extra_exports <- setdiff(exports, ns_and_imports)
122
123  if (length(extra_exports) > 0) {
124    warning("Objects listed as exports, but not present in namespace: ",
125            paste(extra_exports, collapse = ", "))
126    exports <- intersect(ns_and_imports, exports)
127  }
128
129  # Add any S4 methods or classes, this needs to be done after checking for
130  # missing exports as S4 methods with generics imported from other packages
131  # are not defined in the namespace.
132  exports <- add_classes_to_exports(ns = nsenv, package = package,
133    exports = exports, nsInfo = nsInfo)
134
135  # Update the exports metadata for the namespace with base::namespaceExport
136  # It will throw warnings if objects are already listed in the exports
137  # metadata, so catch those warnings and ignore them.
138  suppressWarnings(namespaceExport(nsenv, exports))
139
140  invisible()
141}
142
143# Lookup S4 classes for export
144#
145# This function uses code from base::loadNamespace. Previously this code was
146# copied directly, now it is dynamically looked up instead, to prevent drift as
147# base::loadNamespace changes.
148onload_assign("add_classes_to_exports",
149  {
150    pattern <- if (getRversion() >= "4.1.0") {
151      quote(if (.isMethodsDispatchOn() && hasS4m && !identical(package, "methods"))  NULL)
152    } else {
153      quote(if (.isMethodsDispatchOn() && .hasS4MetaData(ns) && !identical(package, "methods"))  NULL)
154    }
155    make_function(alist(ns =, package =, exports =, nsInfo =),
156      call("{",
157        quote(lev <- 0L),
158        quote(hasS4m <- .hasS4MetaData(ns)),
159        extract_lang(
160          f = comp_lang,
161          y = pattern,
162          idx = c(1, 2),
163          modify_lang(body(base::loadNamespace), strip_internal_calls, "methods")
164        ),
165        quote(exports)
166      ), asNamespace("methods")
167    )
168  }
169)
170
171#' Parses the NAMESPACE file for a package
172#'
173#' @inheritParams load_all
174#' @examples
175#' if (has_tests()) {
176#' parse_ns_file(pkgtest("testLoadHooks"))
177#' }
178#' @keywords internal
179#' @export
180parse_ns_file <- function(path = ".") {
181  path <- pkg_path(path)
182
183  parseNamespaceFile(basename(path), dirname(path),
184    mustExist = FALSE)
185}
186
187
188# Register the S3 methods for this package
189register_s3 <- function(path = ".") {
190  path <- pkg_path(path)
191  package <- pkg_name(path)
192
193  nsInfo <- parse_ns_file(path)
194
195  # Adapted from loadNamespace
196  try(registerS3methods(nsInfo$S3methods, package, ns_env(package)))
197}
198
199
200# Reports whether a package is loaded into a namespace. It may be
201# attached or not attached.
202is_loaded <- function(package) {
203  package %in% loadedNamespaces()
204}
205
206
207# Returns the namespace registry
208ns_registry <- function() {
209  (get(".Internal", envir = baseenv(), mode = "function"))(getNamespaceRegistry())
210}
211# To avoid a note about getNamespaceRegistry being missing
212utils::globalVariables("getNamespaceRegistry")
213
214# Register a namespace
215register_namespace <- function(name = NULL, env = NULL) {
216  # Be careful about what we allow
217  if (!is.character(name) || name == "" || length(name) != 1)
218    stop("'name' must be a non-empty character string.")
219
220  if (!is.environment(env))
221    stop("'env' must be an environment.")
222
223  if (name %in% loadedNamespaces())
224    stop("Namespace ", name, " is already registered.")
225
226  # Add the environment to the registry
227  nsr <- ns_registry()
228  nsr[[name]] <- env
229
230  env
231}
232
233
234# unregister a namespace - should be used only if unloadNamespace()
235# fails for some reason
236unregister_namespace <- function(name = NULL) {
237  # Be careful about what we allow
238  if (!is.character(name) || name == "" || length(name) != 1)
239    stop("'name' must be a non-empty character string.")
240
241  if (!(name %in% loadedNamespaces()))
242    stop(name, " is not a registered namespace.")
243
244  # Force all bindings of the namespace in case of dangling
245  # references. If lazy bindings are forced after the namespace is
246  # unloaded, it might lead to decompress errors if unloaded or to
247  # inconsistencies if reloaded (the bindings are resolved in the new
248  # namespace).
249  eapply(ns_env(name), force, all.names = TRUE)
250
251  # Remove the item from the registry
252  do.call(rm, args = list(name, envir = ns_registry()))
253  invisible()
254}
255
256unregister_methods <- function(package) {
257  # Unloading S3 methods manually avoids lazy-load errors when the new
258  # package is loaded overtop the old one. It also prevents removed
259  # methods from staying registered.
260  s3_unregister(package)
261
262  # S4 classes that were created by the package need to be removed in a special way.
263  remove_s4_classes(package)
264}
265