1# This source code file is licensed under the unlicense license
2# https://unlicense.org
3
4# nocov start
5
6#' Register a method for a suggested dependency
7#'
8#' Generally, the recommended way to register an S3 method is to use the
9#' `S3Method()` namespace directive (often generated automatically by the
10#' `@export` roxygen2 tag). However, this technique requires that the generic
11#' be in an imported package, and sometimes you want to suggest a package,
12#' and only provide a method when that package is loaded. `s3_register()`
13#' can be called from your package's `.onLoad()` to dynamically register
14#' a method only if the generic's package is loaded.
15#'
16#' For R 3.5.0 and later, `s3_register()` is also useful when demonstrating
17#' class creation in a vignette, since method lookup no longer always involves
18#' the lexical scope. For R 3.6.0 and later, you can achieve a similar effect
19#' by using "delayed method registration", i.e. placing the following in your
20#' `NAMESPACE` file:
21#'
22#' ```
23#' if (getRversion() >= "3.6.0") {
24#'   S3method(package::generic, class)
25#' }
26#' ```
27#'
28#' @section Usage in other packages:
29#' To avoid taking a dependency on vctrs, you copy the source of
30#' [`s3_register()`](https://github.com/r-lib/rlang/blob/master/R/compat-register.R)
31#' into your own package. It is licensed under the permissive
32#' [unlicense](https://choosealicense.com/licenses/unlicense/) to make it
33#' crystal clear that we're happy for you to do this. There's no need to include
34#' the license or even credit us when using this function.
35#'
36#' @param generic Name of the generic in the form `"pkg::generic"`.
37#' @param class Name of the class
38#' @param method Optionally, the implementation of the method. By default,
39#'   this will be found by looking for a function called `generic.class`
40#'   in the package environment.
41#' @examples
42#' # A typical use case is to dynamically register tibble/pillar methods
43#' # for your class. That way you avoid creating a hard dependency on packages
44#' # that are not essential, while still providing finer control over
45#' # printing when they are used.
46#'
47#' .onLoad <- function(...) {
48#'   s3_register("pillar::pillar_shaft", "vctrs_vctr")
49#'   s3_register("tibble::type_sum", "vctrs_vctr")
50#' }
51#' @keywords internal
52#' @noRd
53s3_register <- function(generic, class, method = NULL) {
54  stopifnot(is.character(generic), length(generic) == 1)
55  stopifnot(is.character(class), length(class) == 1)
56
57  pieces <- strsplit(generic, "::")[[1]]
58  stopifnot(length(pieces) == 2)
59  package <- pieces[[1]]
60  generic <- pieces[[2]]
61
62  caller <- parent.frame()
63
64  get_method_env <- function() {
65    top <- topenv(caller)
66    if (isNamespace(top)) {
67      asNamespace(environmentName(top))
68    } else {
69      caller
70    }
71  }
72  get_method <- function(method, env) {
73    if (is.null(method)) {
74      get(paste0(generic, ".", class), envir = get_method_env())
75    } else {
76      method
77    }
78  }
79
80  register <- function(...) {
81    envir <- asNamespace(package)
82
83    # Refresh the method each time, it might have been updated by
84    # `devtools::load_all()`
85    method_fn <- get_method(method)
86    stopifnot(is.function(method_fn))
87
88
89    # Only register if generic can be accessed
90    if (exists(generic, envir)) {
91      registerS3method(generic, class, method_fn, envir = envir)
92    } else if (identical(Sys.getenv("NOT_CRAN"), "true")) {
93      warn <- .rlang_s3_register_compat("warn")
94
95      warn(c(
96        sprintf(
97          "Can't find generic `%s` in package %s to register S3 method.",
98          generic,
99          package
100        ),
101        "i" = "This message is only shown to developers using devtools.",
102        "i" = sprintf("Do you need to update %s to the latest version?", package)
103      ))
104    }
105  }
106
107  # Always register hook in case package is later unloaded & reloaded
108  setHook(packageEvent(package, "onLoad"), function(...) {
109    register()
110  })
111
112  # Avoid registration failures during loading (pkgload or regular).
113  # Check that environment is locked because the registering package
114  # might be a dependency of the package that exports the generic. In
115  # that case, the exports (and the generic) might not be populated
116  # yet (#1225).
117  if (isNamespaceLoaded(package) && environmentIsLocked(asNamespace(package))) {
118    register()
119  }
120
121  invisible()
122}
123
124.rlang_s3_register_compat <- function(fn) {
125  # Compats that behave the same independently of rlang's presence
126  out <- switch(
127    fn,
128    is_installed = return(function(pkg) requireNamespace(pkg, quietly = TRUE))
129  )
130
131  # Fall back to base compats
132
133  is_interactive_compat <- function() {
134    opt <- getOption("rlang_interactive")
135    if (!is.null(opt)) {
136      opt
137    } else {
138      interactive()
139    }
140  }
141
142  format_msg <- function(x) paste(x, collapse = "\n")
143  switch(
144    fn,
145    is_interactive = return(is_interactive_compat),
146    abort = return(function(msg) stop(format_msg(msg), call. = FALSE)),
147    warn = return(function(msg) warning(format_msg(msg), call. = FALSE)),
148    inform = return(function(msg) message(format_msg(msg)))
149  )
150
151  stop(sprintf("Internal error in rlang shims: Unknown function `%s()`.", fn))
152}
153
154# nocov end
155