#' @title StubRegistry
#' @description stub registry to keep track of [StubbedRequest] stubs
#' @export
#' @family stub-registry
#' @examples \dontrun{
#' # Make a stub
#' stub1 <- StubbedRequest$new(method = "get", uri = "api.crossref.org")
#' stub1$with(headers = list('User-Agent' = 'R'))
#' stub1$to_return(status = 200, body = "foobar", headers = list())
#' stub1
#'
#' # Make another stub
#' stub2 <- StubbedRequest$new(method = "get", uri = "api.crossref.org")
#' stub2
#'
#' # Put both stubs in the stub registry
#' reg <- StubRegistry$new()
#' reg$register_stub(stub = stub1)
#' reg$register_stub(stub = stub2)
#' reg
#' reg$request_stubs
#' }
StubRegistry <- R6::R6Class(
"StubRegistry",
public = list(
#' @field request_stubs (list) list of request stubs
request_stubs = list(),
#' @field global_stubs (list) list of global stubs
global_stubs = list(),
#' @description print method for the `StubRegistry` class
#' @param x self
#' @param ... ignored
print = function(x, ...) {
cat("<webmockr stub registry> ", sep = "\n")
cat(" Registered Stubs", sep = "\n")
for (i in seq_along(self$request_stubs)) {
cat(" ", self$request_stubs[[i]]$to_s(), "\n")
}
invisible(self$request_stubs)
},
#' @description Register a stub
#' @param stub an object of type [StubbedRequest]
#' @return nothing returned; registers the stub
register_stub = function(stub) {
self$request_stubs <- Filter(length, c(self$request_stubs, stub))
},
#' @description Find a stubbed request
#' @param req an object of class [RequestSignature]
#' @return an object of type [StubbedRequest], if matched
find_stubbed_request = function(req) {
stubs <- c(self$global_stubs, self$request_stubs)
stubs[self$request_stub_for(req)]
},
# response_for_request = function(request_signature) {
# stub <- self$request_stub_for(request_signature)
# evaluate_response_for_request(stub$response, request_signature) %||% NULL
# },
#' @description Find a stubbed request
#' @param request_signature an object of class [RequestSignature]
#' @param count (bool) iterate counter or not. default: `TRUE`
#' @return logical, 1 or more
request_stub_for = function(request_signature, count = TRUE) {
stubs <- c(self$global_stubs, self$request_stubs)
mtchs <- vapply(stubs, function(z) {
tmp <- RequestPattern$new(method = z$method, uri = z$uri,
uri_regex = z$uri_regex, query = z$query,
body = z$body, headers = z$request_headers)
tmp$matches(request_signature)
}, logical(1))
if (count) {
for (i in seq_along(stubs)) {
if (mtchs[i]) stubs[[i]]$counter$put(request_signature)
}
}
return(mtchs)
},
#' @description Remove a stubbed request by matching request signature
#' @param stub an object of type [StubbedRequest]
#' @return nothing returned; removes the stub from the registry
remove_request_stub = function(stub) {
xx <- vapply(self$request_stubs, function(x) x$to_s(), "")
if (stub$to_s() %in% xx) {
self$request_stubs <- self$request_stubs[-which(stub$to_s() %in% xx)]
} else {
abort(c(
"This request stub is not registered:",
stub$to_s()
))
}
},
#' @description Remove all request stubs
#' @return nothing returned; removes all request stubs
remove_all_request_stubs = function() {
for (stub in self$request_stubs) {
if (inherits(stub, "StubbedRequest")) stub$reset()
}
self$request_stubs <- list()
},
#' @description Find a stubbed request
#' @param x an object of class [RequestSignature]
#' @return nothing returned; registers the stub
is_registered = function(x) any(self$request_stub_for(x, count = FALSE))
)
)
json_validate <- function(x) {
res <- tryCatch(jsonlite::validate(x), error = function(e) e)
if (inherits(res, "error")) return(FALSE)
res
}
# make body info for print method
make_body <- function(x) {
if (is.null(x)) return("")
if (inherits(x, "mock_file")) x <- x$payload
if (inherits(x, c("form_file", "partial"))) x <- unclass(x)
clzzes <- vapply(x, function(z) inherits(z, "form_file"), logical(1))
if (any(clzzes)) for(i in seq_along(x)) x[[i]] <- unclass(x[[i]])
if (json_validate(x))
body <- x
else
body <- jsonlite::toJSON(x, auto_unbox = TRUE)
paste0(" with body ", body)
}
# make query info for print
make_query <- function(x) {
if (is.null(x)) return("")
txt <- paste(names(x), subs(unname(unlist(x)), 20), sep = "=",
collapse = ", ")
if (attr(x, "partial_match") %||% FALSE) {
txt <- sprintf("%s(%s)",
switch(attr(x, "partial_type"),
include = "including", exclude = "excluding"), txt)
}
paste0(" with query params ", txt)
}
# make headers info for print method
make_headers <- function(x) {
if (is.null(x)) return("")
paste0(" with headers ", jsonlite::toJSON(x, auto_unbox = TRUE))
}
# make body info for print method
make_status <- function(x) {
if (is.null(x)) return("")
paste0(" with status ", as.character(x))
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.