diff --git a/NEWS.md b/NEWS.md index 0d495261c..d71871501 100644 --- a/NEWS.md +++ b/NEWS.md @@ -8,6 +8,8 @@ * Fixed an issue with `actionLink()` that extended the link underline to whitespace around the text. (#4348) +* Stack traces from render functions (e.g., `renderPlot()`, `renderDataTable()`) now hide internal Shiny rendering pipeline frames, making error messages cleaner and more focused on user code. (#4358) + # shiny 1.12.1 ## New features diff --git a/R/conditions.R b/R/conditions.R index e93b0a022..e30adfb29 100644 --- a/R/conditions.R +++ b/R/conditions.R @@ -87,13 +87,61 @@ getCallNamesForHash <- function(calls) { }) } +# Get the preferred filename from a srcfile object. +# +# For user code, prefer the original path (as typed by user, potentially a +# symlink or relative path) over the normalized absolute path. +# +# For package files (under .libPaths()), keep the srcfile$filename because +# when a package is installed with keep.source.pkgs = TRUE, the original +# srcfilecopy filename may point to a collated build-time path rather than +# the real installed package path. +getSrcfileFilename <- function(srcfile) { + if (!is.null(srcfile$original) && + !is.null(srcfile$original$filename) && + !isPackageFile(srcfile$filename)) { + srcfile$original$filename + } else { + srcfile$filename + } +} + +# Get the source lines and correct line number from a srcfile + srcref. +# +# sourceUTF8() wraps user code with a `#line` directive that remaps line +# numbers. This means srcref[1] (the remapped line) may not correctly index +# into the srcfile's $lines. When a #line directive is present, R extends +# the srcref to 8 elements: [7] and [8] are the original (pre-remap) first +# and last line numbers in the srcfilecopy's coordinate system. +# +# Additionally, when the #line path differs from the srcfilecopy filename +# (e.g. macOS /tmp -> /private/tmp, or Windows path normalization), R wraps +# the srcfile in a srcfilealias whose $lines is NULL. In that case, we +# retrieve lines from the original srcfilecopy via $original. +getSrcfileLines <- function(srcfile, srcref) { + lines <- srcfile$lines + line_num <- srcref[1] + + if (is.null(lines) && inherits(srcfile, "srcfilealias")) { + lines <- srcfile$original$lines + } + + # Use the pre-remap line number when available and different from the + # remapped line, indicating a #line directive shifted line numbering. + if (isTRUE(length(srcref) >= 7 && srcref[7] != srcref[1])) { + line_num <- srcref[7] + } + + list(lines = lines, line_num = line_num) +} + getLocs <- function(calls) { vapply(calls, function(call) { srcref <- attr(call, "srcref", exact = TRUE) if (!is.null(srcref)) { srcfile <- attr(srcref, "srcfile", exact = TRUE) if (!is.null(srcfile) && !is.null(srcfile$filename)) { - loc <- paste0(srcfile$filename, "#", srcref[[1]]) + loc <- paste0(getSrcfileFilename(srcfile), "#", srcref[[1]]) return(paste0(" [", loc, "]")) } } @@ -101,13 +149,36 @@ getLocs <- function(calls) { }, character(1)) } +# Check if a file path is in an R package library +isPackageFile <- function(filepath) { + if (is.null(filepath) || filepath == "") { + return(FALSE) + } + + # Normalize paths for comparison + filepath <- normalizePath(filepath, winslash = "/", mustWork = FALSE) + lib_paths <- normalizePath(.libPaths(), winslash = "/", mustWork = FALSE) + # Ensure trailing slash for proper path-boundary matching, otherwise + # e.g. "/usr/lib/R" would incorrectly match "/usr/lib/Rcpp/..." + lib_paths <- paste0(sub("/$", "", lib_paths), "/") + + # Check if the file is under any library path + any(vapply( + lib_paths, + function(lib) identical(substr(filepath, 1, nchar(lib)), lib), + logical(1) + )) +} + getCallCategories <- function(calls) { vapply(calls, function(call) { srcref <- attr(call, "srcref", exact = TRUE) if (!is.null(srcref)) { srcfile <- attr(srcref, "srcfile", exact = TRUE) - if (!is.null(srcfile)) { - if (!is.null(srcfile$original)) { + if (!is.null(srcfile) && !is.null(srcfile$filename)) { + # Use the absolute path for package detection (srcfile$filename) + # rather than the original path which might be relative + if (isPackageFile(srcfile$filename)) { return("pkg") } else { return("user") @@ -445,43 +516,91 @@ printOneStackTrace <- function(stackTrace, stripResult, full, offset) { invisible(st) } +# Filter stack traces using fence markers to hide internal Shiny frames. +# +# `stackTraces` is a list of character vectors (call names), one per "segment". +# A single synchronous error produces one segment (the immediate call stack). +# Asynchronous errors (e.g. from promises) produce multiple segments: the deep +# stack trace segments come first, then the current segment last. Each deep +# segment may begin with frames that overlap the previous segment; a +# `..stacktracefloor..` marker delimits this redundant prefix from the active +# portion. +# +# Within the active frames, `..stacktraceon..` / `..stacktraceoff..` markers +# act as fences. Frames between a matched off/on pair (reading innermost to +# outermost) are hidden — these are the internal rendering pipeline frames +# that users don't need to see. The algorithm uses a *reverse clamped cumulative +# sum* so that an unmatched `..stacktraceoff..` (one with no corresponding +# inner `..stacktraceon..`) is a no-op, preventing it from hiding user frames. +# Fence matching works globally across segments so that a `..stacktraceoff..` +# at the end of one segment can pair with a `..stacktraceon..` at the start +# of the next. stripStackTraces <- function(stackTraces, values = FALSE) { - score <- 1L # >=1: show, <=0: hide - lapply(seq_along(stackTraces), function(i) { - res <- stripOneStackTrace(stackTraces[[i]], i != 1, score) - score <<- res$score - toShow <- as.logical(res$trace) - if (values) { - as.character(stackTraces[[i]][toShow]) - } else { - as.logical(toShow) - } - }) -} - -stripOneStackTrace <- function(stackTrace, truncateFloor, startingScore) { - prefix <- logical(0) - if (truncateFloor) { - indexOfFloor <- utils::tail(which(stackTrace == "..stacktracefloor.."), 1) - if (length(indexOfFloor)) { - stackTrace <- stackTrace[(indexOfFloor+1L):length(stackTrace)] - prefix <- rep_len(FALSE, indexOfFloor) - } + n_segs <- length(stackTraces) + if (n_segs == 0L) return(list()) + + # Replace NULL segments with empty character vectors + stackTraces <- lapply(stackTraces, function(st) st %||% character(0)) + seg_lengths <- lengths(stackTraces) + total <- sum(seg_lengths) + + if (total == 0L) { + return(lapply(seg_lengths, function(n) { + if (values) character(0) else logical(0) + })) } - if (length(stackTrace) == 0) { - return(list(score = startingScore, character(0))) + # Pre-compute segment boundaries (used in steps 1 and 4) + seg_ends <- cumsum(seg_lengths) + seg_starts <- c(1L, seg_ends[-n_segs] + 1L) + + # Concatenate all segments into one vector for vectorized operations + all <- unlist(stackTraces) + + # 1. Identify prefix elements (at/before last ..stacktracefloor.. in segs 2+) + # Prefix elements are always hidden and excluded from fence scoring. + is_active <- rep.int(TRUE, total) + if (n_segs >= 2L) { + for (i in 2:n_segs) { + if (seg_lengths[i] == 0L) next + seg_idx <- seg_starts[i]:seg_ends[i] + floor_pos <- which(all[seg_idx] == "..stacktracefloor..") + if (length(floor_pos)) { + is_active[seg_idx[seq_len(floor_pos[length(floor_pos)])]] <- FALSE + } + } } - score <- rep.int(0L, length(stackTrace)) - score[stackTrace == "..stacktraceon.."] <- 1L - score[stackTrace == "..stacktraceoff.."] <- -1L - score <- startingScore + cumsum(score) - - toShow <- score > 0 & !(stackTrace %in% c("..stacktraceon..", "..stacktraceoff..", "..stacktracefloor..")) + # 2. Compute fence scores and marker mask (vectorized across all segments) + is_on <- all == "..stacktraceon.." + is_off <- all == "..stacktraceoff.." + is_marker <- is_on | is_off | (all == "..stacktracefloor..") + scores <- integer(total) + scores[is_active & is_on] <- 1L + scores[is_active & is_off] <- -1L + + # 3. Reverse clamped cumsum across all segments. + # Process from innermost (right) to outermost (left). ..stacktraceon.. (+1) + # opens a hidden region working outward, ..stacktraceoff.. (-1) closes it. + # Clamping at 0 means an unmatched ..stacktraceoff.. (one with no inner + # ..stacktraceon..) is a no-op. Prefix elements have score 0 and pass the + # running total through unchanged. + # + # Vectorized via the identity: clamped_cumsum = cumsum - pmin(0, cummin(cumsum)) + rs <- rev(scores) + cs <- cumsum(rs) + depth <- rev(cs - pmin.int(0L, cummin(cs))) + # 4. Compute visibility (vectorized) and split back into segments + toShow <- is_active & depth == 0L & !is_marker - list(score = utils::tail(score, 1), trace = c(prefix, toShow)) + lapply(seq_len(n_segs), function(i) { + if (seg_lengths[i] == 0L) { + if (values) return(character(0)) else return(logical(0)) + } + idx <- seg_starts[i]:seg_ends[i] + if (values) as.character(all[idx[toShow[idx]]]) else toShow[idx] + }) } # Given sys.parents() (which corresponds to sys.calls()), return a logical index diff --git a/R/otel-attr-srcref.R b/R/otel-attr-srcref.R index 34114a30f..c25945560 100644 --- a/R/otel-attr-srcref.R +++ b/R/otel-attr-srcref.R @@ -16,7 +16,9 @@ otel_srcref_attributes <- function(srcref, fn_name = NULL) { # Semantic conventions for code: https://opentelemetry.io/docs/specs/semconv/registry/attributes/code/ # # Inspiration from https://github.com/r-lib/testthat/pull/2087/files#diff-92de3306849d93d6f7e76c5aaa1b0c037e2d716f72848f8a1c70536e0c8a1564R123-R124 - filename <- attr(srcref, "srcfile")$filename + srcfile <- attr(srcref, "srcfile") + # Prefer the original filename (as user typed it) over the normalized path + filename <- getSrcfileFilename(srcfile) dropNulls(list( "code.function.name" = fn_name, # Location attrs diff --git a/R/reactives.R b/R/reactives.R index 8d098c7f9..f355feb00 100644 --- a/R/reactives.R +++ b/R/reactives.R @@ -304,20 +304,23 @@ rassignSrcrefToLabel <- function( if (is.null(srcfile)) return(defaultLabel) - if (is.null(srcfile$lines)) + src <- getSrcfileLines(srcfile, srcref) + lines <- src$lines + line_num <- src$line_num + + if (is.null(lines)) return(defaultLabel) - lines <- srcfile$lines # When pasting at the Console, srcfile$lines is not split if (length(lines) == 1) { lines <- strsplit(lines, "\n")[[1]] } - if (length(lines) < srcref[1]) { + if (length(lines) < line_num) { return(defaultLabel) } - firstLine <- substring(lines[srcref[1]], srcref[2] - 1) + firstLine <- substring(lines[line_num], srcref[2] - 1) m <- regexec( # Require the first assignment within the line @@ -1160,20 +1163,23 @@ rexprSrcrefToLabel <- function(srcref, defaultLabel, fnName) { if (is.null(srcfile)) return(defaultLabel) - if (is.null(srcfile$lines)) + src <- getSrcfileLines(srcfile, srcref) + lines <- src$lines + line_num <- src$line_num + + if (is.null(lines)) return(defaultLabel) - lines <- srcfile$lines # When pasting at the Console, srcfile$lines is not split if (length(lines) == 1) { lines <- strsplit(lines, "\n")[[1]] } - if (length(lines) < srcref[1]) { + if (length(lines) < line_num) { return(defaultLabel) } - firstLine <- substring(lines[srcref[1]], 1, srcref[2] - 1) + firstLine <- substring(lines[line_num], 1, srcref[2] - 1) # Require the assignment to be parsed from the start m <- regexec(paste0("^(.*)(<<-|<-|=)\\s*", fnName, "\\s*\\($"), firstLine) diff --git a/R/shinywrappers.R b/R/shinywrappers.R index dca587398..d5f1a4bbe 100644 --- a/R/shinywrappers.R +++ b/R/shinywrappers.R @@ -130,8 +130,10 @@ markRenderFunction <- function( # stop warning from happening again for the same object hasExecuted$set(TRUE) } - if (is.null(formals(renderFunc))) renderFunc() - else renderFunc(...) + ..stacktraceoff..( + if (is.null(formals(renderFunc))) renderFunc() + else renderFunc(...) + ) } otelAttrs <- @@ -275,7 +277,7 @@ createRenderFunction <- function( ) { renderFunc <- function(shinysession, name, ...) { hybrid_chain( - func(), + ..stacktraceon..(func()), function(value) { transform(value, shinysession, name, ...) } @@ -628,7 +630,7 @@ renderPrint <- function(expr, env = parent.frame(), quoted = FALSE, domain <- createRenderPrintPromiseDomain(width) hybrid_chain( { - with_promise_domain(domain, func()) + with_promise_domain(domain, ..stacktraceon..(func())) }, function(value) { res <- withVisible(value) @@ -963,7 +965,7 @@ legacyRenderDataTable <- function(expr, options = NULL, searchDelay = 500, options <- checkDT9(options) res <- checkAsIs(options) hybrid_chain( - func(), + ..stacktraceon..(func()), function(data) { if (length(dim(data)) != 2) return() # expects a rectangular data object if (is.data.frame(data)) data <- as.data.frame(data) diff --git a/R/utils.R b/R/utils.R index cce8e6e63..ac4bc9fe3 100644 --- a/R/utils.R +++ b/R/utils.R @@ -1394,8 +1394,7 @@ maybeAnnotateSourceForArk <- function(file, lines) { # similarly, try to source() a file with UTF-8 sourceUTF8 <- function(file, envir = globalenv()) { - file <- normalizePath(file, mustWork = TRUE, winslash = "/") - + file_norm <- normalizePath(file, mustWork = TRUE, winslash = "/") lines <- readUTF8(file) enc <- if (any(Encoding(lines) == 'UTF-8')) 'UTF-8' else 'unknown' @@ -1406,7 +1405,7 @@ sourceUTF8 <- function(file, envir = globalenv()) { # with a `#line` directive to map source references back to the original file lines <- c( "..stacktraceon..({", - sprintf('#line 1 "%s"', file), + sprintf('#line 1 "%s"', file_norm), lines, "})" ) diff --git a/tests/testthat/_snaps/stacks.md b/tests/testthat/_snaps/stacks.md index e57a2c35f..5ce7850e2 100644 --- a/tests/testthat/_snaps/stacks.md +++ b/tests/testthat/_snaps/stacks.md @@ -1,111 +1,103 @@ # integration tests Code - df + df_integration_slim Output num call loc - 1 68 A [test-stacks.R#3] - 2 67 B [test-stacks.R#7] - 3 66 [test-stacks.R#11] - 4 44 C - 5 43 renderTable [test-stacks.R#18] - 6 42 func - 7 41 force - 8 40 withVisible - 9 39 withCallingHandlers - 10 38 domain$wrapSync - 11 37 promises::with_promise_domain - 12 36 captureStackTraces - 13 32 tryCatch - 14 31 do - 15 30 hybrid_chain - 16 29 renderFunc - 17 28 renderTable({ C() }, server = FALSE) - 18 10 isolate - 19 9 withCallingHandlers [test-stacks.R#16] - 20 8 domain$wrapSync - 21 7 promises::with_promise_domain - 22 6 captureStackTraces - 23 2 tryCatch - 24 1 try - 25 0 causeError [test-stacks.R#14] + 1 70 A [test-stacks.R#3] + 2 69 B [test-stacks.R#7] + 3 68 [test-stacks.R#11] + 4 46 C + 5 45 renderTable [test-stacks.R#18] + 6 44 func + 7 28 renderTable({ C() }, server = FALSE) + 8 10 isolate + 9 9 withCallingHandlers [test-stacks.R#16] + 10 8 domain$wrapSync + 11 7 promises::with_promise_domain + 12 6 captureStackTraces + 13 2 tryCatch + 14 1 try + 15 0 causeError [test-stacks.R#14] --- Code - df + df_integration_full Output num call loc - 1 71 h - 2 70 .handleSimpleError - 3 69 stop - 4 68 A [test-stacks.R#3] - 5 67 B [test-stacks.R#7] - 6 66 [test-stacks.R#11] - 7 65 ..stacktraceon.. - 8 64 .func - 9 63 withVisible - 10 62 withCallingHandlers - 11 61 contextFunc - 12 60 env$runWith - 13 59 withCallingHandlers - 14 58 domain$wrapSync - 15 57 promises::with_promise_domain - 16 56 captureStackTraces - 17 55 force - 18 54 with_otel_span_context - 19 53 force - 20 52 domain$wrapSync - 21 51 promises::with_promise_domain - 22 50 withReactiveDomain - 23 49 domain$wrapSync - 24 48 promises::with_promise_domain - 25 47 ctx$run - 26 46 self$.updateValue - 27 45 ..stacktraceoff.. - 28 44 C - 29 43 renderTable [test-stacks.R#18] - 30 42 func - 31 41 force - 32 40 withVisible - 33 39 withCallingHandlers - 34 38 domain$wrapSync - 35 37 promises::with_promise_domain - 36 36 captureStackTraces - 37 35 doTryCatch - 38 34 tryCatchOne - 39 33 tryCatchList - 40 32 tryCatch - 41 31 do - 42 30 hybrid_chain - 43 29 renderFunc - 44 28 renderTable({ C() }, server = FALSE) - 45 27 ..stacktraceon.. [test-stacks.R#17] - 46 26 contextFunc - 47 25 env$runWith - 48 24 withCallingHandlers - 49 23 domain$wrapSync - 50 22 promises::with_promise_domain - 51 21 captureStackTraces - 52 20 force - 53 19 with_otel_span_context - 54 18 force - 55 17 domain$wrapSync - 56 16 promises::with_promise_domain - 57 15 withReactiveDomain - 58 14 domain$wrapSync - 59 13 promises::with_promise_domain - 60 12 ctx$run - 61 11 ..stacktraceoff.. - 62 10 isolate - 63 9 withCallingHandlers [test-stacks.R#16] - 64 8 domain$wrapSync - 65 7 promises::with_promise_domain - 66 6 captureStackTraces - 67 5 doTryCatch [test-stacks.R#15] - 68 4 tryCatchOne - 69 3 tryCatchList - 70 2 tryCatch - 71 1 try - 72 0 causeError [test-stacks.R#14] + 1 73 h + 2 72 .handleSimpleError + 3 71 stop + 4 70 A [test-stacks.R#3] + 5 69 B [test-stacks.R#7] + 6 68 [test-stacks.R#11] + 7 67 ..stacktraceon.. + 8 66 .func + 9 65 withVisible + 10 64 withCallingHandlers + 11 63 contextFunc + 12 62 env$runWith + 13 61 withCallingHandlers + 14 60 domain$wrapSync + 15 59 promises::with_promise_domain + 16 58 captureStackTraces + 17 57 force + 18 56 with_otel_span_context + 19 55 force + 20 54 domain$wrapSync + 21 53 promises::with_promise_domain + 22 52 withReactiveDomain + 23 51 domain$wrapSync + 24 50 promises::with_promise_domain + 25 49 ctx$run + 26 48 self$.updateValue + 27 47 ..stacktraceoff.. + 28 46 C + 29 45 renderTable [test-stacks.R#18] + 30 44 func + 31 43 ..stacktraceon.. + 32 42 force + 33 41 withVisible + 34 40 withCallingHandlers + 35 39 domain$wrapSync + 36 38 promises::with_promise_domain + 37 37 captureStackTraces + 38 36 doTryCatch + 39 35 tryCatchOne + 40 34 tryCatchList + 41 33 tryCatch + 42 32 do + 43 31 hybrid_chain + 44 30 renderFunc + 45 29 ..stacktraceoff.. + 46 28 renderTable({ C() }, server = FALSE) + 47 27 ..stacktraceon.. [test-stacks.R#17] + 48 26 contextFunc + 49 25 env$runWith + 50 24 withCallingHandlers + 51 23 domain$wrapSync + 52 22 promises::with_promise_domain + 53 21 captureStackTraces + 54 20 force + 55 19 with_otel_span_context + 56 18 force + 57 17 domain$wrapSync + 58 16 promises::with_promise_domain + 59 15 withReactiveDomain + 60 14 domain$wrapSync + 61 13 promises::with_promise_domain + 62 12 ctx$run + 63 11 ..stacktraceoff.. + 64 10 isolate + 65 9 withCallingHandlers [test-stacks.R#16] + 66 8 domain$wrapSync + 67 7 promises::with_promise_domain + 68 6 captureStackTraces + 69 5 doTryCatch [test-stacks.R#15] + 70 4 tryCatchOne + 71 3 tryCatchList + 72 2 tryCatch + 73 1 try + 74 0 causeError [test-stacks.R#14] diff --git a/tests/testthat/helper-otel.R b/tests/testthat/helper-otel.R index f32e81863..b450bcd2a 100644 --- a/tests/testthat/helper-otel.R +++ b/tests/testthat/helper-otel.R @@ -1,3 +1,9 @@ +skip_if_shiny_otel_tracer_is_enabled <- function() { + if (shiny_otel_tracer()$is_enabled()) { + skip("Skipping stack trace tests when OpenTelemetry is already enabled") + } +} + # Helper function to create a mock otel span create_mock_otel_span <- function(name = "test_span") { structure( diff --git a/tests/testthat/helper-stacks.R b/tests/testthat/helper-stacks.R new file mode 100644 index 000000000..27c9309be --- /dev/null +++ b/tests/testthat/helper-stacks.R @@ -0,0 +1,118 @@ +#' @details `extractStackTrace` takes a list of calls (e.g. as returned +#' from `conditionStackTrace(cond)`) and returns a data frame with one +#' row for each stack frame and the columns `num` (stack frame number), +#' `call` (a function name or similar), and `loc` (source file path +#' and line number, if available). It was deprecated after shiny 1.0.5 because +#' it doesn't support deep stack traces. +#' @rdname stacktrace +#' @export +extractStackTrace <- function(calls, + full = get_devmode_option("shiny.fullstacktrace", FALSE), + offset = getOption("shiny.stacktraceoffset", TRUE)) { + + srcrefs <- getSrcRefs(calls) + if (offset) { + # Offset calls vs. srcrefs by 1 to make them more intuitive. + # E.g. for "foo [bar.R:10]", line 10 of bar.R will be part of + # the definition of foo(). + srcrefs <- c(utils::tail(srcrefs, -1), list(NULL)) + } + calls <- setSrcRefs(calls, srcrefs) + + callnames <- getCallNames(calls) + + # Hide and show parts of the callstack based on ..stacktrace(on|off).. + if (full) { + toShow <- rep.int(TRUE, length(calls)) + } else { + # Remove stop(), .handleSimpleError(), and h() calls from the end of + # the calls--they don't add any helpful information. But only remove + # the last *contiguous* block of them, and then, only if they are the + # last thing in the calls list. + hideable <- callnames %in% c("stop", ".handleSimpleError", "h") + # What's the last that *didn't* match stop/.handleSimpleError/h? + lastGoodCall <- max(which(!hideable)) + toRemove <- length(calls) - lastGoodCall + # But don't remove more than 5 levels--that's an indication we might + # have gotten it wrong, I guess + if (toRemove > 0 && toRemove < 5) { + calls <- utils::head(calls, -toRemove) + callnames <- utils::head(callnames, -toRemove) + } + + toShow <- stripStackTraces(list(callnames))[[1]] + + toShow <- + toShow & + # doTryCatch, tryCatchOne, and tryCatchList are not informative--they're + # just internals for tryCatch + !(callnames %in% c("doTryCatch", "tryCatchOne", "tryCatchList")) & + # doWithOneRestart and withOneRestart are not informative--they're + # just internals for withRestarts + !(callnames %in% c("withOneRestart", "doWithOneRestart")) + } + calls <- calls[toShow] + + + calls <- rev(calls) # Show in traceback() order + index <- rev(which(toShow)) + width <- floor(log10(max(index))) + 1 + + data.frame( + num = index, + call = getCallNames(calls), + loc = getLocs(calls), + # category = getCallCategories(calls), + stringsAsFactors = FALSE + ) +} + +cleanLocs <- function(locs) { + locs[!grepl("test-stacks\\.R", locs, perl = TRUE)] <- "" + # sub("^.*#", "", locs) + locs +} + +dumpTests <- function(df) { + print(bquote({ + expect_equal(df$num, .(df$num)) + expect_equal(df$call, .(df$call)) + expect_equal(nzchar(df$loc), .(nzchar(df$loc))) + })) +} + +# Helper: run a render function whose body throws an error, capture the +# stack trace, apply fence-based filtering, and return the filtered data +# frame. The render function body should call a function that calls stop(). +# `needs_session` indicates whether the render function requires +# shinysession/name parameters (TRUE for markRenderFunction-based renders +# like renderPlot and renderPrint, FALSE for createRenderFunction-based +# renders like renderText/renderTable/renderUI/renderImage which can be +# called with no args). +captureFilteredRenderTrace <- function(render_fn, needs_session = TRUE) { + session <- MockShinySession$new() + on.exit(if (!session$isClosed()) session$close()) + + res <- try({ + captureStackTraces({ + isolate({ + withReactiveDomain(session, { + if (needs_session) { + render_fn(shinysession = session, name = "testoutput") + } else { + render_fn() + } + }) + }) + }) + }, + silent = TRUE) + + cond <- attr(res, "condition", exact = TRUE) + stopifnot(!is.null(cond)) + stopifnot(!is.null(conditionStackTrace(cond))) + + suppressMessages( + extractStackTrace(conditionStackTrace(cond), full = FALSE) + ) +} diff --git a/tests/testthat/test-bind-cache.R b/tests/testthat/test-bind-cache.R index 648ea998f..9dc98c76f 100644 --- a/tests/testthat/test-bind-cache.R +++ b/tests/testthat/test-bind-cache.R @@ -1140,7 +1140,7 @@ test_that("Custom render functions that call installExprFunction", { test_that("cacheWriteHook and cacheReadHook for render functions", { - testthat::skip_if(shiny_otel_tracer()$is_enabled(), "Skipping stack trace tests when OpenTelemetry is already enabled") + skip_if_shiny_otel_tracer_is_enabled() write_hook_n <- 0 read_hook_n <- 0 diff --git a/tests/testthat/test-reactives.R b/tests/testthat/test-reactives.R index 38af0d72c..fd18f81b4 100644 --- a/tests/testthat/test-reactives.R +++ b/tests/testthat/test-reactives.R @@ -14,6 +14,140 @@ test_that("can access reactive values directly", { expect_equal(y(), 4) }) +describe("srcfilealias in reactive labels", { + # When a #line directive specifies a path that differs from the srcfilecopy + # filename, R's parser wraps the srcfile in a srcfilealias whose $lines is + # NULL. This is exactly what happens in sourceUTF8() when the normalized path + # differs from the original. + parse_as_srcfilealias <- function(user_code) { + code <- c('#line 1 "/absolute/path/to/app.R"', user_code) + src <- base::srcfilecopy("app.R", code, isFile = TRUE) + exprs <- parse(text = code, keep.source = TRUE, srcfile = src) + list(code = code, exprs = exprs, srcrefs = attr(exprs, "srcref")) + } + + it("getSrcfileLines() resolves lines from srcfilealias", { + parsed <- parse_as_srcfilealias("my_val <- reactiveVal(1)") + + srcref <- parsed$srcrefs[[1]] + srcfile <- attr(srcref, "srcfile", exact = TRUE) + + expect_s3_class(srcfile, "srcfilealias") + expect_null(srcfile$lines) + + result <- getSrcfileLines(srcfile, srcref) + expect_false(is.null(result$lines)) + expect_equal(result$lines, parsed$code) + expect_match(result$lines[result$line_num], "my_val <- reactiveVal") + }) + + it("getSrcfileLines() works with regular srcfile", { + code <- c("x <- 1", "y <- 2") + src <- base::srcfilecopy("test.R", code, isFile = TRUE) + exprs <- parse(text = code, keep.source = TRUE, srcfile = src) + + srcref <- attr(exprs, "srcref")[[1]] + srcfile <- attr(srcref, "srcfile", exact = TRUE) + + expect_false(inherits(srcfile, "srcfilealias")) + + result <- getSrcfileLines(srcfile, srcref) + expect_equal(result$lines, code) + expect_equal(result$line_num, 1L) + }) + + it("rassignSrcrefToLabel() extracts label from srcfilealias", { + parsed <- parse_as_srcfilealias("my_val <- reactiveVal(1)") + srcref <- parsed$srcrefs[[1]] + + label <- rassignSrcrefToLabel(srcref, defaultLabel = "fallback") + expect_equal(label, "my_val") + }) + + it("rexprSrcrefToLabel() extracts label from srcfilealias", { + parsed <- parse_as_srcfilealias("my_r <- reactive({ 1 + 1 })") + + # rexprSrcrefToLabel() expects the srcref of the reactive body (the { }), + # not the entire assignment. This mirrors how exprToLabel() calls it with + # the srcref from the body of the expression created by installExprFunction. + assign_expr <- parsed$exprs[[1]] + reactive_body <- assign_expr[[3]][[2]] # reactive( ) + body_srcrefs <- attr(reactive_body, "srcref") + srcref <- body_srcrefs[[1]] + + label <- rexprSrcrefToLabel(srcref, defaultLabel = "fallback", fnName = "reactive") + expect_equal(label, "my_r") + }) +}) + +test_that("sourceUTF8() auto-labels reactives despite srcfilealias", { + # sourceUTF8() uses normalizePath() in its #line directive but the original + # path for srcfilecopy. When these differ (e.g. macOS /tmp -> /private/tmp), + # R creates a srcfilealias whose $lines is NULL. When they match (e.g. + # Ubuntu), the #line directive still remaps line numbers. getSrcfileLines() + # handles both cases by using srcref[7] (the pre-remap line number). + tmp <- tempfile(fileext = ".R") + on.exit(unlink(tmp), add = TRUE) + + reactiveConsole(TRUE) + on.exit(reactiveConsole(FALSE), add = TRUE) + + writeLines(c( + "my_val <- reactiveVal(1)", + "my_react <- reactive({ my_val() + 1 })" + ), tmp) + + env <- new.env(parent = globalenv()) + sourceUTF8(tmp, envir = env) + + # reactiveVal label (uses rassignSrcrefToLabel) + rv_impl <- attr(env$my_val, ".impl", exact = TRUE) + expect_equal( + rv_impl$.__enclos_env__$private$label, + "my_val" + ) + + # reactive label (uses rexprSrcrefToLabel via exprToLabel) + r_observable <- attr(env$my_react, "observable", exact = TRUE) + expect_equal(as.character(r_observable$.label), "my_react") +}) + +describe("srcfilealias filename selection", { + parse_as_srcfilealias <- function(user_code, alias_path = "/absolute/path/to/app.R") { + code <- c(sprintf('#line 1 "%s"', alias_path), user_code) + src <- base::srcfilecopy("app.R", code, isFile = TRUE) + exprs <- parse(text = code, keep.source = TRUE, srcfile = src) + list(code = code, exprs = exprs, srcrefs = attr(exprs, "srcref")) + } + + it("getSrcfileFilename() prefers original unless package file", { + lib <- normalizePath(.libPaths()[[1]], winslash = "/", mustWork = FALSE) + pkg_path <- file.path(lib, "pkg", "R", "foo.R") + + parsed_pkg <- parse_as_srcfilealias("x <- 1", alias_path = pkg_path) + srcref_pkg <- parsed_pkg$srcrefs[[1]] + srcfile_pkg <- attr(srcref_pkg, "srcfile", exact = TRUE) + expect_equal(getSrcfileFilename(srcfile_pkg), pkg_path) + + parsed_user <- parse_as_srcfilealias("y <- 2", alias_path = "/tmp/user.R") + srcref_user <- parsed_user$srcrefs[[1]] + srcfile_user <- attr(srcref_user, "srcfile", exact = TRUE) + expect_equal(getSrcfileFilename(srcfile_user), "app.R") + }) +}) + +test_that("isPackageFile() uses path-boundary matching", { + lib <- normalizePath(.libPaths()[[1]], winslash = "/", mustWork = FALSE) + + # A path like "{lib}Extra/foo.R" shares the prefix but is NOT inside the lib + fake_path <- paste0(lib, "Extra/foo.R") + expect_false(isPackageFile(fake_path)) + + # A path actually inside the library SHOULD match + real_path <- file.path(lib, "pkg", "R", "foo.R") + expect_true(isPackageFile(real_path)) +}) + test_that("errors in throttled/debounced reactives are catchable", { reactiveConsole(TRUE) on.exit(reactiveConsole(FALSE)) diff --git a/tests/testthat/test-stacks.R b/tests/testthat/test-stacks.R index 31f551d78..f3ed1881f 100644 --- a/tests/testthat/test-stacks.R +++ b/tests/testthat/test-stacks.R @@ -32,97 +32,6 @@ causeError <- function(full) { df } -#' @details `extractStackTrace` takes a list of calls (e.g. as returned -#' from `conditionStackTrace(cond)`) and returns a data frame with one -#' row for each stack frame and the columns `num` (stack frame number), -#' `call` (a function name or similar), and `loc` (source file path -#' and line number, if available). It was deprecated after shiny 1.0.5 because -#' it doesn't support deep stack traces. -#' @rdname stacktrace -#' @export -extractStackTrace <- function(calls, - full = get_devmode_option("shiny.fullstacktrace", FALSE), - offset = getOption("shiny.stacktraceoffset", TRUE)) { - - srcrefs <- getSrcRefs(calls) - if (offset) { - # Offset calls vs. srcrefs by 1 to make them more intuitive. - # E.g. for "foo [bar.R:10]", line 10 of bar.R will be part of - # the definition of foo(). - srcrefs <- c(utils::tail(srcrefs, -1), list(NULL)) - } - calls <- setSrcRefs(calls, srcrefs) - - callnames <- getCallNames(calls) - - # Hide and show parts of the callstack based on ..stacktrace(on|off).. - if (full) { - toShow <- rep.int(TRUE, length(calls)) - } else { - # Remove stop(), .handleSimpleError(), and h() calls from the end of - # the calls--they don't add any helpful information. But only remove - # the last *contiguous* block of them, and then, only if they are the - # last thing in the calls list. - hideable <- callnames %in% c("stop", ".handleSimpleError", "h") - # What's the last that *didn't* match stop/.handleSimpleError/h? - lastGoodCall <- max(which(!hideable)) - toRemove <- length(calls) - lastGoodCall - # But don't remove more than 5 levels--that's an indication we might - # have gotten it wrong, I guess - if (toRemove > 0 && toRemove < 5) { - calls <- utils::head(calls, -toRemove) - callnames <- utils::head(callnames, -toRemove) - } - - # This uses a ref-counting scheme. It might make sense to switch this - # to a toggling scheme, so the most recent ..stacktrace(on|off).. - # directive wins, regardless of what came before it. - # Also explicitly remove ..stacktraceon.. because it can appear with - # score > 0 but still should never be shown. - score <- rep.int(0, length(callnames)) - score[callnames == "..stacktraceoff.."] <- -1 - score[callnames == "..stacktraceon.."] <- 1 - toShow <- (1 + cumsum(score)) > 0 & !(callnames %in% c("..stacktraceon..", "..stacktraceoff..", "..stacktracefloor..")) - - toShow <- - toShow & - # doTryCatch, tryCatchOne, and tryCatchList are not informative--they're - # just internals for tryCatch - !(callnames %in% c("doTryCatch", "tryCatchOne", "tryCatchList")) & - # doWithOneRestart and withOneRestart are not informative--they're - # just internals for withRestarts - !(callnames %in% c("withOneRestart", "doWithOneRestart")) - } - calls <- calls[toShow] - - - calls <- rev(calls) # Show in traceback() order - index <- rev(which(toShow)) - width <- floor(log10(max(index))) + 1 - - data.frame( - num = index, - call = getCallNames(calls), - loc = getLocs(calls), - # category = getCallCategories(calls), - stringsAsFactors = FALSE - ) -} - -cleanLocs <- function(locs) { - locs[!grepl("test-stacks\\.R", locs, perl = TRUE)] <- "" - # sub("^.*#", "", locs) - locs -} - -dumpTests <- function(df) { - print(bquote({ - expect_equal(df$num, .(df$num)) - expect_equal(df$call, .(df$call)) - expect_equal(nzchar(df$loc), .(nzchar(df$loc))) - })) -} - test_that("integration tests", { if (shiny_otel_tracer()$is_enabled()) { announce_snapshot_file(name = "stacks.md") @@ -139,15 +48,15 @@ test_that("integration tests", { # problems on CRAN. skip_on_cran() - df <- causeError(full = FALSE) - # dumpTests(df) + df_integration_slim <- causeError(full = FALSE) + # dumpTests(df_integration_slim) - expect_snapshot(df) + expect_snapshot(df_integration_slim) - df <- causeError(full = TRUE) + df_integration_full <- causeError(full = TRUE) - expect_snapshot(df) - # dumpTests(df) + expect_snapshot(df_integration_full) + # dumpTests(df_integration_full) }) test_that("shiny.error", { @@ -272,3 +181,170 @@ test_that("observeEvent is not overly stripped (#4162)", { expect_match(st_str, "A__", all = FALSE) expect_match(st_str, "B__", all = FALSE) }) + +test_that("renderPlot stack trace fences hide internal rendering pipeline (#4357)", { + skip_on_cran() + + skip_if_shiny_otel_tracer_is_enabled() + + userFunc <- function() { + stop("test error in renderPlot") + } + + df <- captureFilteredRenderTrace(renderPlot({ userFunc() })) + + expect_true("userFunc" %in% df$call) + + # Internal rendering pipeline frames should NOT appear in the filtered + # stack trace. These are Shiny internals between the stack trace fences + # that currently leak through due to missing fences. + internal_render_frames <- c( + "drawPlot", + "drawReactive", + "renderFunc", + "startPNG" + ) + + leaked <- df$call[df$call %in% internal_render_frames] + expect_length(leaked, 0) +}) + +test_that("renderPrint stack trace fences hide internal rendering pipeline (#4357)", { + skip_on_cran() + + skip_if_shiny_otel_tracer_is_enabled() + + userFunc <- function() { + stop("test error in renderPrint") + } + + df <- captureFilteredRenderTrace(renderPrint({ userFunc() })) + + expect_true("userFunc" %in% df$call) + + internal_render_frames <- c("renderFunc") + leaked <- df$call[df$call %in% internal_render_frames] + expect_length(leaked, 0) +}) + +test_that("renderText stack trace fences hide internal rendering pipeline (#4357)", { + skip_on_cran() + + skip_if_shiny_otel_tracer_is_enabled() + + userFunc <- function() { + stop("test error in renderText") + } + + df <- captureFilteredRenderTrace(renderText({ userFunc() }), needs_session = FALSE) + + expect_true("userFunc" %in% df$call) + + internal_render_frames <- c("renderFunc") + leaked <- df$call[df$call %in% internal_render_frames] + expect_length(leaked, 0) +}) + +test_that("renderUI stack trace fences hide internal rendering pipeline (#4357)", { + skip_on_cran() + + skip_if_shiny_otel_tracer_is_enabled() + + userFunc <- function() { + stop("test error in renderUI") + } + + df <- captureFilteredRenderTrace(renderUI({ userFunc() }), needs_session = FALSE) + + expect_true("userFunc" %in% df$call) + + internal_render_frames <- c("renderFunc") + leaked <- df$call[df$call %in% internal_render_frames] + expect_length(leaked, 0) +}) + +test_that("renderTable stack trace fences hide internal rendering pipeline (#4357)", { + skip_on_cran() + + skip_if_shiny_otel_tracer_is_enabled() + + userFunc <- function() { + stop("test error in renderTable") + } + + df <- captureFilteredRenderTrace( + renderTable({ userFunc() }, server = FALSE), + needs_session = FALSE + ) + + expect_true("userFunc" %in% df$call) + + internal_render_frames <- c("renderFunc") + leaked <- df$call[df$call %in% internal_render_frames] + expect_length(leaked, 0) +}) + +test_that("renderImage stack trace fences hide internal rendering pipeline (#4357)", { + skip_on_cran() + + skip_if_shiny_otel_tracer_is_enabled() + + userFunc <- function() { + stop("test error in renderImage") + } + + df <- captureFilteredRenderTrace( + renderImage({ userFunc() }, deleteFile = FALSE), + needs_session = FALSE + ) + + expect_true("userFunc" %in% df$call) + + internal_render_frames <- c("renderFunc") + leaked <- df$call[df$call %in% internal_render_frames] + expect_length(leaked, 0) +}) + +test_that("legacyRenderDataTable stack trace fences hide internal rendering pipeline (#4357)", { + skip_on_cran() + + skip_if_shiny_otel_tracer_is_enabled() + + userFunc <- function() { + stop("test error in renderDataTable") + } + + df <- captureFilteredRenderTrace( + legacyRenderDataTable({ userFunc() }) + ) + + expect_true("userFunc" %in% df$call) + + internal_render_frames <- c("renderFunc") + leaked <- df$call[df$call %in% internal_render_frames] + expect_length(leaked, 0) +}) + +test_that("markRenderFunction preserves user frames outside reactive domain", { + skip_on_cran() + + skip_if_shiny_otel_tracer_is_enabled() + + # htmlwidgets-style: exprToFunction + markRenderFunction, no ..stacktraceon.. + renderWidgetLike <- function(expr, env = parent.frame(), quoted = FALSE) { + if (!quoted) expr <- substitute(expr) + func <- exprToFunction(expr, env, TRUE) + renderFunc <- function() { func() } + markRenderFunction(textOutput, renderFunc) + } + + userFunc <- function() stop("boom") + render_fn <- renderWidgetLike({ userFunc() }) + + res <- try(captureStackTraces({ render_fn() }), silent = TRUE) + cond <- attr(res, "condition", exact = TRUE) + df <- extractStackTrace(conditionStackTrace(cond), full = FALSE) + + expect_true("userFunc" %in% df$call) +}) +