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