# Copyright (C) Brodie Gaslam
#
# This file is part of "unitizer - Interactive R Unit Tests"
#
# This program is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 2 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# Go to <https://www.r-project.org/Licenses/GPL-2> for a copy of the license.
#' @include unitizer.R
NULL
setGeneric("exec", function(x, ...) standardGeneric("exec"))
## Functions To Manage Evaluation of Tests
##
## Runs test, captures value, stdout, stderr, conditions, etc.
##
## \code{exec} is designed to run tests, capture output, etc,
## \code{eval_user_exp} does the actual evaluation, \code{eval_with_capture},
## is a wrapper around \code{eval_user_exp} that also captures output,
## \code{user_exp_display} and \code{user_exp_handle} are utility function to
## deal with evaluations that invoke print/show,
## \code{set_trace} and \code{get_trace} are used to set the tracebacks when
## there are failures.
##
## @section \code{eval_user_exp}:
##
## A fair bit of manipulation required to ensure the trace and calls associated
## with conditions are reasonable. This should be mostly correct except for the
## notable exception of top-level conditions, which will be recorded correctly,
## but for which the \code{std.err()} output will show the
## \code{withVisible(...)} call. Doesn't seem to be a straightforward way of
## capturing that short of tossing the \code{stderr} and spoofing the message.
##
## @section \code{set_trace}, \code{get_trace}:
##
## Used for cases where the trace isn't generated because the error was run
## within a handling loop, but we still want the trace so we can emulate command
## line behavior.
##
## This will modify the .Traceback system variable (see \code{\link{traceback}}
## documentation).
##
## Assumption right now is that the outer most call to \code{withCallingHandlers}
## is the baseline level from which we want to repor the traceback.
##
## Only intended for use within \code{eval_user_exp}, will clean up the result
## from two different \code{sys.calls} calls to extract the calls that a
## trace would show on error.
##
## How much of the stack is used is affected by the \code{printed}
## argument because if something didn't pass evaluation, it means the error
## occurred within \code{withVisible} which in this setup means we need to
## remove two additional levels.
##
## Relies on calls being evaluated in a very particular environment.
##
## @rdname exec
## @param trace a list of type generated by sys.calls()
## @param trace.base starting point for what we care about in the trace, as
## produced by \code{sys.calls}
## @param trace.new the trace within the condition handler, as produced by
## \code{sys.calls}
## @param passsed.eval whether the evaluatation succeeded in the first step (see
## details)
## @param print.type character(1L) one of "print", "show", or ""
## @param exp the expression to sub in to the print/show statements if we passed
## eval
## @param test the call to test
## @param test.env the environment to evaluate the \code{test} in
## @param global unitizerGlobal, required by \code{eval_user_exp} to record
## state every time a user expression is evaluated
## @param with.display whether to print/show output if visible
## @param with.state whether to log state after each evaluation
setMethod("exec", "ANY", valueClass="unitizerItem",
function(x, test.env, global) {
if(!is.environment(test.env))
stop("Argument `test.env` must be an environment.")
# Check whether we are dealing with a unitizer_sect
is_unitizer_sect <- FALSE
if(is.call(x))
is_unitizer_sect <-
identical(try(eval(x[[1L]], test.env), silent=TRUE), unitizer_sect)
# Prep message and std output capture, note this is reset with every test
# expressionevaluation
x.comments <- character()
if(!is_unitizer_sect) {
x.extracted <- comm_and_call_extract(x)
# need to recover comments from container since we can't attach comments
# directly to name
x.comments <- x.extracted$comments
x <- x.extracted$call # get rid of comment container
}
x.to.eval <- `attributes<-`(x, NULL)
res <- eval_with_capture(
x.to.eval, test.env, global=global, with.capture=!global$transcript
)
global$cons <- res$cons # Need to recover connections
if(res$aborted & is_unitizer_sect) # check to see if `unitizer_sect` failed
stop(
"Failed instantiating a unitizer section:\n",
paste0(res$message, "\n")
)
if(!is(res$state, "unitizerGlobalIndices")) {
stop("Internal Error: failed recording state; contact maintainer.")# nocov
}
new(
"unitizerItem", call=x.to.eval, value=res$value,
conditions=new("conditionList", .items=res$conditions),
output=res$output, message=res$message,
aborted=res$aborted,
env=test.env, comment=x.comments, trace=res$trace,
glob.indices=res$state,
ignore=identical(res$visible, FALSE) && !length(res$conditions)
)
} )
# ## Three places eval_user_exp is called
#
# ## This is used by unitizer_browse, and also all over the place so a real
# ## problem to isolate!
#
# unitizer_prompt
# eval_user_exp
#
# ## This is used to evaluate the test expression
# ## and produce unitizerItems
#
# unitize_eval
# `+`("unitizer", "unitizerTestsOrExpression")
# exec
# eval_with_capture
# eval_user_exp <-----
# `+`("unitizer", "unitizerItem")
# testItem("unitizer", "unitizerItem")
# eval_user_exp <-----
# @param warn.sticky TRUE or FALSE whether to let the warning option state
# persist past the call. If TRUE, then whatever is invoking this function is
# responsible for resetting it. At the moment it is when this is invoked via
# the `unitizer_prompt` in browsing test results.
eval_user_exp <- function(
unitizerUSEREXP, env, global, with.display=TRUE,
warn.sticky=FALSE, with.display.unitizer_sect=FALSE
) {
if(!is(global, "unitizerGlobal") && !is.null(global)) {
# nocov start
stop(
"Internal Error: `global` argument must be a 'unitizerGlobal' object ",
"or NULL, contact maintainer."
)
# nocov end
}
if(getOption('warn') < 1L) {
old.opt <- options(warn=1L)
if(!warn.sticky) on.exit(options(old.opt))
}
exp <- if(is.expression(unitizerUSEREXP)) {
call("withVisible", call("eval", unitizerUSEREXP))
} else call("withVisible", unitizerUSEREXP)
res <- user_exp_handle(exp, env, "", unitizerUSEREXP)
if(
!res$aborted && res$value$visible && length(unitizerUSEREXP) &&
with.display &&
(
!is(res$value$value, "unitizerSectionExpression") ||
with.display.unitizer_sect
)
) {
res2 <- user_exp_display(res$value$value, env, unitizerUSEREXP)
res$conditions <- append(res$conditions, res2$conditions)
if(length(res2$trace)) res$trace <- res2$trace
res$aborted <- res2$aborted
}
# convolution required due to possible NULL value so can't assign directly to
# elements; also, note that the `state` return value is not used in most
# `eval_user_exp` uses; the
c(
list(
value=res$value$value, visible=res$value$visible,
state=if(is(global, "unitizerGlobal")) global$state()
),
res[-1L]
)
}
# @param with.display output result of evaluation after evaluation
# @param with.capture turns capture on and off for each expression, different
# from with.display as this will allow display of e.g. segfaults, etc. Gives
# more fine grained control than "unitizer.disable.capt" as that does it for
# every use of this function, whereas we might only want it for test
# expressions.
eval_with_capture <- function(
x, test.env=new.env(), global, with.display=TRUE, with.state=TRUE,
with.capture=TRUE
) {
stopifnot(is(global, "unitizerGlobal"))
# These used to be parameters, but now that we have `global` we use that
# instead; note that the options come in as NULL quietly in some tests where
# we're e.g. directly accessing the unitizers instead of using `unitize`, and
# those NULLs ar just dropped implicitly by the way we call `set_capture`.
cons <- global$cons
disable.capt <- global$unitizer.opts[["unitizer.disable.capt"]]
max.capt.chars <- global$unitizer.opts[["unitizer.max.capture.chars"]]
if(!is.null(disable.capt)) disable.capt <- disable.capt | !with.capture
# Disable error handler; warn gets set to one when we eval the expression
err.opt <- getOption("error")
# Setup text capture; a bit messy due to funny way we have to pull in
# unitize specific options; do.call business is to use default arguments
# if options are NULL
came.with.capts <- TRUE
if(is.null(cons)) {
capt.cons <- new("unitizerCaptCons")
came.with.capts <- FALSE
} else {
capt.cons <- cons
}
# disable.capt and max.capt.chars could be NULL in some cases (see above)
set_args <- list()
set_args[["capt.disabled"]] <- disable.capt
capt.cons <- do.call(set_capture, c(list(capt.cons), set_args))
get_args <- list(capt.cons)
get_args[["chrs.max"]] <- max.capt.chars
# Manage unexpected outcomes
on.exit({
options(error=err.opt)
get.try <- try(capt <- do.call(get_capture, get_args))
unsink.try <- try(capt.cons <- unsink_cons(capt.cons))
if(!inherits(get.try, "try-error")) {
cat(c(capt$message, "\n"), file=stderr(), sep="\n")
cat(c(capt$output, "\n"), sep="\n")
}
if(inherits(unsink.try, "try-error")) failsafe_con(capt.cons)
if(!came.with.capts) close_and_clear(capt.cons)
meta_word_msg(
"Unexpectedly exited evaluation attempt when executing test ",
"expression:\n> ", paste0(deparse(x), collapse=""), "\nMake sure you ",
"are not calling `unitize` inside a `tryCatch`/`try` block, invoking a ",
"restart defined outside `unitize`, evaluating an expression that ",
"calls `quit()`/`q()`, or quitting from a `browser()`/`debug()`/",
"`trace()`. If none of these apply yet you are seeing this message ",
"please contact package maintainer.",
sep=""
)
})
# Evaluate expression
options(error=NULL)
res <- eval_user_exp(
x, test.env, global=if(with.state) global, with.display=with.display
)
# Revert settings, get captured messages, if any and if user isn't capturing
# already; do.call so we can rely on default get_capture settings if those
# in `unitizer.opts` are NULL
capt <- do.call(get_capture, get_args)
capt.cons <- unsink_cons(capt.cons)
if(getOption("unitizer.show.output", TRUE)) {
cat(c(capt$message, "\n"), file=stderr(), sep="\n")
cat(c(capt$output, "\n"), sep="\n")
}
on.exit(NULL)
options(error=err.opt)
# Need to make sure we either close the connections or return the updated
# values since we might be changing connections depending on sink status, etc
if(!came.with.capts) close_and_clear(capt.cons)
# Cleanup and
res[c("output", "message")] <- lapply(
capt[c("output", "message")], function(x) if(!length(x)) "" else x
)
res[["cons"]] <- capt.cons
clean_message(res)
}
user_exp_display <- function(value, env, expr, default=FALSE) {
if(isS4(value)) {
print.type <- "show"
disp.expr <- call("show", if(is.language(value)) enquote(value) else value)
} else {
print.type <- "print"
disp.expr <- call(
if(default) "print.default" else "print",
if(is.language(value)) enquote(value) else value
)
}
user_exp_handle(disp.expr, env, print.mode=print.type, expr.raw=expr)
}
# It used to matter what precise value `print.mode`, but now the only thing
# that matters is whether it is zero char or not
user_exp_handle <- function(expr, env, print.mode, expr.raw) {
aborted <- FALSE
conditions <- list()
trace <- list()
printed <- nchar(print.mode) > 1
value <- NULL
withRestarts(
withCallingHandlers(
{
trace.base <- sys.calls()
value <- eval(expr, env)
},
condition=function(cond) {
attr(cond, "unitizer.printed") <- printed
trace.new <- sys.calls()
trace.net <- get_trace(
trace.base, trace.new, printed, expr.raw
)
if(attr(trace.net, "set.trace")) trace <<- c(trace.net)
# manipulate call so it looks like it should
cond.call.noattr <- `attributes<-`(cond$call, NULL)
if(!printed && identical(cond.call.noattr, trace.net[[1L]])) {
cond <- modifyList(cond, list(call=NULL), keep.null=TRUE)
}
conditions[[length(conditions) + 1L]] <<- cond
}
),
abort=function() {
aborted <<- structure(TRUE, printed=printed)
}
)
list(
value=value,
aborted=aborted,
conditions=conditions,
trace=tail(trace, -1L)
)
}
## Trace is undeparsed
set_trace <- function(trace) {
if(length(trace)) .global$traceback <- rev(trace)
TRUE
}
get_trace <- function(trace.base, trace.new, printed, exp) {
# because withCallingHandlers/withRestarts don't register when calling
# sys.calls() within them, but do when calling sys.calls() from the handling
# function, we need to remove at least 4 calls from trace.new, and possibly
# more if we ended up evaluating within withVisible
len.new <- length(trace.new)
if(
len.new > length(trace.base) &&
all(
vapply(
seq_along(trace.base), FUN.VALUE=logical(1L),
function(x) identical(trace.base[[x]], trace.new[[x]])
) )
) {
# Filter out calls through signalCondition rather than stop and
# `stop+condition`
is.stop <- identical(trace.new[[len.new]], quote(h(simpleError(msg, call))))
is.stop.cond <- length(trace.new) > 1L &&
identical(trace.new[[len.new - 1L]][[1L]], quote(stop))
trace.new[seq_along(trace.base)] <- NULL
# remove srcref attributes
trace.new.clean <- lapply(trace.new, `attributes<-`, NULL)
if(
length(trace.new.clean) >= 7L ||
(printed && length(trace.new.clean) >= 6L)
) {
# printing removes expression
trace.new.clean[
1L:(if(printed) 5L else 6L + is.expression(exp) * 2L)
] <- NULL
if(printed) {
# Find any calls from the beginning that are length 2 and start with
# print/show and then replace the part inside the print/show call with
# the actual call
exp.rep <- if(is.expression(exp)) exp[[length(exp)]] else exp
trace.new.clean <- lapply(
trace.new.clean,
function(x) eval(call("substitute", x, list(unitizerTESTRES=exp.rep)))
)
}
if(length(trace.new.clean) >= 2L) {
trace.drop <- if(is.stop) -2L else if (is.stop.cond) -1L else 0L
trace.trim <- trace.new.clean[1L:(length(trace.new.clean) + trace.drop)]
} else {
stop("Internal Error: unexpected trace length") # nocov
}
attr(trace.trim, "set.trace") <- is.stop || is.stop.cond # only actually set trace on `stop` calls
return(trace.trim)
} }
stop("Internal Error: couldn't extract trace; contact maintainer.") # nocov
}
clean_message <- function(res) {
# Deal with top level warnings and errors that show up weird in the message
# output because they are not truly top level within unitizer; top level
# warnings will have the `call` component set to NULL; we compose a regular
# expression that contains all the warning / errors and their messages to
# match against the output stream to give use the location of the
# "Error in .*: " and such
stopifnot(
is.list(res), is.character(res$message), identical(length(res$message), 1L)
)
# this all assumes options(warn>=1)
reg.base <- "(%s in .*? :)((?:\\n|\\s)*%%s)\\n.*"
if(nchar(res$message)) {
pats <- lapply(
res$conditions,
function(cond) {
token <- NULL
if(
is.null(conditionCall(cond)) &&
(
(is.warn <- inherits(cond, "simpleWarning")) ||
inherits(cond, "simpleError")
)
) {
type <- if(is.warn) "Warning" else "Error"
sprintf(
sprintf(reg.base, type),
gsub(
"([-\\\\^$*+?.()|[\\]{}])", "\\\\\\1", conditionMessage(cond),
perl=TRUE
) ) } } )
if(!all(vapply(pats, is.null, logical(1L)))) {
# Our pattern has two matching elements per match, and these are going to
# show up sequentially in our match, so we turn the capture data into
# a matrix where col 1 is the first match, and col 2 the second match
pats.fin <- do.call(paste0, c(list("(?s)"), pats))
m <- regexpr(pats.fin, res$message, perl=T)
m.st <- t(matrix(attr(m, "capture.start"), nrow=2))
m.len <- t(matrix(attr(m, "capture.length"), nrow=2))
# Loop backwards through string so that modifications don't affect character
# locations for subsequent replacements
msg <- res$message
width <- getOption("width")
for(i in rev(seq.int(nrow(m.st)))) {
if(m.st[i, 1L] < 1L || m.len[i, 1L] < 1L) next
pre <- if(m.st[i, 1L] == 1L) "" else substr(msg, 1L, m.st[i, 1L] - 1L)
obj <- sub(
"^(\\w+).*", "\\1:", # replace obj with first word
substr(msg, m.st[i, 1L], m.st[i, 1L] + m.len[i, 1L] - 1),
perl=TRUE
)
obj2 <- substr(msg, m.st[i, 2L], m.st[i, 2L] + m.len[i, 2L] - 1)
post <- if(m.st[i, 2L] + m.len[i, 2L] > nchar(msg)) "" else
substr(msg, m.st[i, 2L] + m.len[i, 2L], nchar(msg))
# Undo line break if shorter call doesn't warrant it anymore
obj2.short <- sub("^(?s)\\s*(.*)$", " \\1", obj2, perl=TRUE)
msg <- if(nchar(paste0(obj, obj2.short)) <= width)
paste0(pre, obj, obj2.short, post) else
paste0(pre, obj, obj2, post)
}
res$message <- msg
} }
res
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.