1# Namespace related functions
2#
3# Author: Renaud Gaujoux
4# Creation: 30 Apr 2012
5###############################################################################
6
7
8is_funcall <- function(fun){
9
10	n <- sys.nframe()
11	i <- 1
12	dg <- digest(fun)
13	while( i <= n ){
14		f <- sys.function(i)
15		ca <- sys.call(i)
16#		cat(digest(f), dg, getPackageName(environment(f), FALSE), "\n")
17		if( digest(f) == dg ) return(i)
18		i <- i + 1
19	}
20	FALSE
21}
22
23is_pkgcall <- function(pkg){
24
25	pkg %in% pkg_calls()
26
27}
28
29pkg_calls <- function(){
30	n <- sys.nframe() - 1
31	i <- 1
32	res <- character()
33	while( i <= n ){
34		f <- sys.function(i)
35		e <- environment(f)
36		if( !is.null(e) ){
37			pkg <- methods::getPackageName(e, create=FALSE)
38			if( pkg != '' ) res <- c(res, pkg)
39		}
40		i <- i + 1
41	}
42	res
43}
44
45#' Namespace Development Functions
46#'
47#' \code{getLoadingNamespace} returns information about the loading namespace.
48#' It is a wrapper to \code{\link{loadingNamespaceInfo}}, that does not throw
49#' an error.
50#'
51#' @param env logical that indicates that the namespace's environment (i.e. the
52#' namespace itself) should be returned.
53#' @param info logical that indicates that the complete information list should
54#' be returned
55#'
56#' @return the name of the loading namespace if \code{env} and \code{info} are
57#' \code{FALSE}, an environment if \code{env=TRUE}, a list with elements
58#' \code{pkgname} and \code{libname} if \code{info=TRUE}.
59#'
60#' @rdname namespace
61#' @export
62#'
63getLoadingNamespace <- function(env=FALSE, info=FALSE, nodev=FALSE){
64	is.loading <- try(nsInfo <- loadingNamespaceInfo(), silent=TRUE)
65	if( !is(is.loading, 'try-error') ){
66		if( env ) asNamespace(as.name(nsInfo$pkgname))
67		else if( info ){
68			nsInfo$path <- file.path(nsInfo$libname, nsInfo$pkgname)
69			nsInfo
70		}else nsInfo$pkgname
71
72	}else if( !nodev ){ # devtools namespaces are allowed
73    if( (is_pkgcall('devtools') && (i <- is_funcall(ns_get('devtools::load_all')))) ||
74        (is_pkgcall('pkgload') && (i <- is_funcall(ns_get('pkgload::load_all')))) || # for devtools > 1.12
75        (is_pkgcall('roxygen24') && (i <- is_funcall(ns_get('roxygen24::source_package')))) ){
76  			# find out the package that is currently being loaded by load_all
77  			e <- sys.frame(i)
78  			pkg <- e[["pkg"]]
79
80        if( is.null(pkg) ){ # try to load from path
81          if( is.null(path <- e[["path"]]) ) stop("Could not infer loading namespace")
82          pkg <- as_package(path)
83
84        }
85
86  			# extract namespace
87  			if( env ){
88          if( isDevNamespace(pkg$package) ) asNamespace(pkg$package)
89          else pkg$ns
90  			}else if( info ){
91  				list(
92  						pkgname = pkg$package
93  						, path = pkg$path
94  						, libname = dirname(pkg$path)
95  				)
96  			}else pkg$package
97		}
98	}
99	else NULL
100}
101
102#' @describeIn namespace Tests if a namespace is being loaded.
103#'
104#' @param ns the name of a namespace or a namespace whose loading state is tested.
105#' If missing \code{isLoadingNamespace} test if any namespace is being loaded.
106#' @param nodev logical that indicates if loading devtools namespace should
107#' be discarded.
108#'
109#' @export
110isLoadingNamespace <- function(ns, nodev=FALSE){
111
112	if( missing(ns) ) !is.null(getLoadingNamespace(nodev=nodev))
113	else{
114		nspkg <- getLoadingNamespace(nodev=nodev, env=is.environment(ns))
115		if( is.null(nspkg) ) FALSE
116		else identical(nspkg, ns)
117	}
118}
119
120#' @describeIn namespace tests if a given namespace is loaded, without loading it,
121#' contrary to \code{\link{isNamespace}}.
122#' It is similar to \code{\link{isNamespaceLoaded}} -- which it uses -- but also accepts
123#' environments.
124#'
125#' @export
126isNamespaceLoaded2 <- isNamespaceLoaded <- function(ns){
127	if( is.environment(ns) ){
128		if( !isNamespace(ns) ) return(FALSE)
129		else ns <- getPackageName(ns)
130	}
131	if( isString(ns) ) base::isNamespaceLoaded(ns)
132	else stop("Invalid argument `ns`: only support strings and environments.")
133}
134
135#' @describeIn namespace tests the -- current -- namespace is a devtools namespace.
136#'
137#' @export
138isDevNamespace <- function(ns){
139	if( missing(ns) ){
140		e <- parent.frame()
141		ns <- methods::getPackageName(topenv(e))
142	}
143
144	# cannot be true if the namespace is not loaded
145	if( !isNamespaceLoaded(ns) ) return( FALSE )
146	# get the namespace environment
147	if( isString(ns) ) ns <- asNamespace(ns)
148	# check for the presence of a .__DEVTOOLS__ object
149	exists('.__DEVTOOLS__', where=ns)
150
151}
152
153#' @describeIn namespace Dynamically adds exported objects into the loading namespace.
154#'
155#' @param x character vector containing the names of R objects to export in the
156#' loading namespace.
157#'
158#' @export
159addNamespaceExport <- function(x){
160	ns <- pkgmaker::getLoadingNamespace(env=TRUE)
161	if( !is.null(ns) ){
162		namespaceExport(ns, x)
163	}
164}
165
166#' @describeIn namespace gets an object from a given namespace.
167#' @param ... extra arguments passed to [get0].
168#'
169#' @export
170ns_get <- function(x, ns = NULL, ...){
171  if( is.null(ns) ){
172    ns <- gsub("^([^:]+)::.*", "\\1", x)
173    x <- gsub(".*::([^:]+)$", "\\1", x)
174  }
175  if( !isNamespace(ns) ){
176    ns <- tryCatch(asNamespace(ns), error = function(e) NULL)
177    if( is.null(ns) ) return()
178  }
179  get0(x, envir = ns, ...)
180}
181