#' Wrapper around 'trace' to untrace when finished
#'
#' @param x Name of function to trace. See [base::trace()].
#' @param where where to look for the function to be traced.
#' @param print Logical: print a message every time the traced function is hit?
#' Default is `FALSE`; note that in `trace`, the default is `TRUE`.
#' @param ... Additional arguments to pass to `trace`. At minimum, must include
#' either `tracer` or `exit`.
#' @param expr Code to run inside the context
#' @return The result of `expr`
#' @export
#' @keywords internal
with_trace <- function(x, where = topenv(parent.frame()), print = getOption("httptest.debug", FALSE), ..., expr) {
quietly(trace(x, print = print, where = where, ...))
on.exit(safe_untrace(x, where = where))
eval.parent(expr)
}
mock_perform <- function(mocker, ...) {
tracer <- substitute_q(fetch_tracer, list(.mocker = mocker))
# trace curl's form_file making the path normalization a no-op so that file
# hashes are the same on different platforms
quietly(trace(curl::form_file, quote(
normalizePath <- function(path, ...) {
return(path)
}
), where = httr::upload_file, print = getOption("httptest.debug", FALSE)))
# trace body_config to close the file connection that it creates when the
# body inherits form_file
quietly(trace("body_config", exit = quote(
if (exists("con")) close.connection(con)
), where = httr::PUT, print = getOption("httptest.debug", FALSE)))
invisible(trace_httr("request_perform", tracer = tracer, ...))
}
#' @importFrom utils sessionInfo
trace_httr <- function(..., print = getOption("httptest.debug", FALSE)) {
# Trace it as seen from within httr
quietly(trace(..., print = print, where = add_headers))
# And if httr is attached and the function is exported, trace the
# function as the user sees it
if ("httr" %in% names(sessionInfo()$otherPkgs) && ..1 %in% getNamespaceExports("httr")) {
try(quietly(trace(..., print = print, where = sys.frame())))
}
}
quietly <- function(expr) {
env <- parent.frame()
if (getOption("httptest.debug", FALSE)) {
eval(expr, env)
} else {
suppressMessages(eval(expr, env))
}
}
#' Turn off request mocking
#'
#' This function "untraces" the `httr` request functions so that normal, real
#' requesting behavior can be resumed.
#' @return Nothing; called for its side effects
#' @export
stop_mocking <- function() {
safe_untrace("request_perform", getNamespace("httr"))
safe_untrace("body_config", getNamespace("httr"))
safe_untrace("form_file", getNamespace("curl"))
invisible()
}
safe_untrace <- function(what, where = sys.frame()) {
# If you attempt to untrace a function (1) that isn't exported from
# whatever namespace it lives in and (2) that isn't currently traced,
# it errors. This prevents that so that it's always safe to call `untrace`
# untrace() and get() handle enviroments differently
if (is.environment(where)) {
env <- where
} else {
env <- environment(where)
}
if (inherits(try(get(what, env), silent = TRUE), "functionWithTrace")) {
quietly(untrace(what, where = where))
}
}
# This is the code that we'll inject into `request_perform` to override some
# internal httr functions. Each mock context will provide its own `.mocker`
# that replaces the actual curl requesting and returns a response object.
fetch_tracer <- quote({
request_fetch <- function(...) .mocker(req)
parse_http_headers <- parse_headers <- function(x, ...) {
# If we're loading a mock response, we've already parsed the headers,
# so just use them.
# In httr <= 1.3.1, the function was called parse_headers
if (length(resp$all_headers)) {
return(resp$all_headers)
} else {
return(list(list(headers = x)))
}
}
pu <- httr::parse_url
parse_url <- function(...) {
# This is a workaround that forces all URLs to be HTTP because
# httr > 1.3.1 supports non-HTTP and does different things with header
# parsing for those requests. That broke some httptest tests that use
# e.g. `GET("api/object1/")`.
# TODO: stop supporting that, especially if httptest is the only
# package that relies on the old behavior.
out <- pu(...)
out$scheme <- "http"
out
}
response <- function(...) {
out <- structure(list(...), class = "response")
# Remove some curl objects/pointers
out$cookies <- resp$cookies
out$handle <- NULL
return(out)
}
})
# cf http://adv-r.had.co.nz/Computing-on-the-language.html#substitute
substitute_q <- function(x, env) eval(substitute(substitute(y, env), list(y = x)))
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.