0byt3m1n1
Path:
C:
/
Program Files
/
RStudio
/
resources
/
app
/
R
/
modules
/
[
Home
]
File: SessionBreakpoints.R
# # SessionBreakpoints.R # # Copyright (C) 2022 by Posit Software, PBC # # Unless you have received this program directly from Posit Software pursuant # to the terms of a commercial license agreement with Posit Software, then # this program is licensed to you under the terms of version 3 of the # GNU Affero General Public License. This program is distributed WITHOUT # ANY EXPRESS OR IMPLIED WARRANTY, INCLUDING THOSE OF NON-INFRINGEMENT, # MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE. Please refer to the # AGPL (http://www.gnu.org/licenses/agpl-3.0.txt) for more details. # # # given a function name and filename, find the environment that contains a # function with the given name that originated from the given file. .rs.addFunction("getEnvironmentOfFunction", function( objName, fileName, packageName) { objName <- .rs.unquote(objName) # assume fileName is UTF-8 encoded unless it's already got a labelled # encoding if (Encoding(fileName) == "unknown") { Encoding(fileName) <- "UTF-8" } isPackage <- nchar(packageName) > 0 # when searching specifically for a function in a package, search from the # package namespace to the global environment (considers package imports and # non-exported functions); otherwise, search from the global environment to # the empty namespace lastEnvir <- if (isPackage) "R_GlobalEnv" else "R_EmptyEnv" env <- if (isPackage) asNamespace(packageName) else globalenv() while (environmentName(env) != lastEnvir) { # if the function with the given name exists in this environment... if (!is.null(env) && exists(objName, env, mode = "function", inherits = FALSE)) { # we need the source reference to look up the filename; we may need to # access the original copy of a traced function to get this srcref <- .rs.getSrcref(get(objName, env)) if (!is.null(srcref)) { # get the name of the file from which the function originated, and # trim off the trailing space fileattr <- attr(srcref, "srcfile") # if the srcref has a srcfile, resolve it (if it exists) and # compare with the input we were given if (!is.null(fileattr) && (normalizePath(fileattr$filename, mustWork = FALSE) == normalizePath(fileName))) { return (env) } } } env <- parent.env(env) } return(NULL) }) # given the body of a function, search recursively through its parsed # representation for a step with a given source reference line number. .rs.addFunction("stepsAtLine", function(funBody, line) { if (typeof(funBody) != "language") { return(NULL) } refs <- attr(funBody, "srcref") for (idx in 1:length(funBody)) { # if there's a source ref on this line, check it against the line number # provided by the caller ref <- refs[[idx]] if (length(ref) > 0) { if (line > ref[3] || line < ref[1]) { next } } # check for sub-steps--these exist when there's a nested function nestedFunSteps <- .rs.stepsAtLine(funBody[[idx]], line) if (!is.null(nestedFunSteps)) { return(c(idx, nestedFunSteps)) } # match functions rather than opening brackets if (length(ref) > 0 && !(typeof(funBody[[idx]]) == "symbol" && identical(as.character(funBody[[idx]]), "{"))) { return(idx) } } return(NULL) }) # Given the body of the function, return the substeps of the function on which # a breakpoint was set (not the substep of the breakpoint itself). .rs.addFunction("findBreakpointSteps", function(funBody) { if (typeof(funBody) != "language") { return(NULL) } for (idx in 1:length(funBody)) { # if this is a doTrace call, we found a breakpoint; stop recursion here if (is.call(funBody[[idx]]) && identical(as.character(funBody[[idx]][[1]])[[1]], ".doTrace")) { return(idx + 1) } nestedSteps <- .rs.findBreakpointSteps(funBody[[idx]]) if (!is.null(nestedSteps)) { return(c(idx, nestedSteps)) } } }) # Given a function, return the function with all of the breakpoints removed. .rs.addFunction("removeBreakpoints", function(fun) { repeat { # Find the step on which a breakpoint was set inner <- .rs.findBreakpointSteps(body(fun)) if (length(inner) < 2) break; # Replace the outer expression (which contains the breakpoint) with the # inner one (which contains the expression formerly wrapped by the # breakpoint) outer <- inner[1:(length(inner)-1)] body(fun)[[outer]] <- body(fun)[[inner]] } fun }) # given a traced function body and the original function body, recursively copy # the source references from the original body to the traced body, adding # source references to the injected trace code from the line being traced .rs.addFunction("tracedSourceRefs",function(funBody, originalFunBody) { if (is.symbol(funBody) || is.symbol(originalFunBody)) { return (funBody) } # start with a copy of the original source references attr(funBody, "srcref") <- attr(originalFunBody, "srcref") for (idx in 1:length(funBody)) { # Check to see if this is one of the several types of objects we can't do # equality testing for. Note that these object types are all leaf nodes in # the parse tree, so it's safe to stop recursion here. Also note that we # can't use the helpful is.na() here since that function emits warnings # for some types of objects in the parse tree. if (is.null(funBody[[idx]]) || identical(funBody[[idx]], NA) || identical(funBody[[idx]], NA_character_) || identical(funBody[[idx]], NA_complex_) || identical(funBody[[idx]], NA_integer_) || identical(funBody[[idx]], NA_real_) || identical(funBody[[idx]], NaN) || is.pairlist(funBody[[idx]])) next # if this expression was replaced by trace(), copy the source references # from the original expression over each expression injected by trace() if (length(funBody[[idx]]) != length(originalFunBody[[idx]]) || isTRUE(sum(funBody[[idx]] != originalFunBody[[idx]]) > 0)) { attr(funBody[[idx]], "srcref") <- rep(list(attr(originalFunBody, "srcref")[[idx]]), length(funBody[[idx]])) } # recurse to symbol level else if (is.language(funBody[[idx]])) { funBody[[idx]] <- .rs.tracedSourceRefs( funBody[[idx]], originalFunBody[[idx]]) } } return(funBody) }) .rs.addFunction("getFunctionSteps", function(fun, functionName, lineNumbers) { funBody <- body(fun) lineNumbers <- unique(lineNumbers) # attempt to find the end line of the function funStartLine <- 0 funEndLine <- 0 funSrcRef <- attr(fun, "srcref") if (!is.null(funSrcRef) && length(funSrcRef) > 3) { funStartLine <- funSrcRef[1] funEndLine <- funSrcRef[3] } else { return(list()) } # process each line on which a breakpoint was requested lapply(lineNumbers, function(lineNumber) { # don't try to process lines that aren't inside the body of the function steps <- integer() if (lineNumber >= funStartLine && lineNumber <= funEndLine) { # if we don't find any function steps associated with the given line # number, keep trying the next one until we do, up to the end of the # function (as marked by its source references) repeat { steps <- .rs.stepsAtLine(funBody, lineNumber) if (length(steps) > 0 || lineNumber >= funEndLine) { break } lineNumber <- lineNumber + 1 } } list( name=.rs.scalar(functionName), line=.rs.scalar(lineNumber), at=.rs.scalar(paste(steps, collapse=","))) }) }) # this function is used to get the steps in the given function that are # associated with the given line number, using the function's source # references. .rs.addFunction("getSteps", function( functionName, fileName, packageName, lineNumbers) { .rs.getFunctionSteps( .rs.getUntracedFunction(functionName, fileName, packageName), functionName, lineNumbers) }) .rs.addFunction("setFunctionBreakpoints", function( functionName, envir, steps) { functionName <- .rs.unquote(functionName) if (length(steps) == 0 || all(nchar(steps) == 0)) { # Restore the function to its original state. Note that trace/untrace # emit messages when they act on a function in a package environment; hide # those messages since they're just noise to the user. fun <- get(functionName, envir = envir) if (.rs.isTraced(fun)) { suppressMessages(untrace( what = functionName, where = envir)) } } else { # inject the browser calls suppressMessages(trace( what = functionName, where = envir, at = lapply(strsplit(as.character(steps), ","), as.numeric), tracer = browser, print = FALSE)) # unlock the binding if necessary to inject the source references; # bindings are often locked in package environments lockedBinding <- FALSE # remap the source references so that the code injected by trace() is # mapped back to the line on which the breakpoint was set. We need to # assign directly to the @.Data internal slot since assignment to the # public-facing body of the function will remove the tracing information. tryCatch({ if (bindingIsLocked(functionName, envir)) { unlockBinding(functionName, envir) lockedBinding <- TRUE } body(envir[[functionName]]@.Data) <- .rs.tracedSourceRefs( body(envir[[functionName]]@.Data), body(envir[[functionName]]@original)) }, finally = { # restore the lock if (lockedBinding) { lockBinding(functionName, envir) } } ) } return(functionName) }) .rs.addFunction("getUntracedFunction", function( functionName, fileName, packageName) { functionName <- .rs.unquote(functionName) envir <- .rs.getEnvironmentOfFunction(functionName, fileName, packageName) if (is.null(envir)) { return(NULL) } .rs.untraced(get(functionName, mode = "function", envir = envir)) }) .rs.addFunction("getFunctionSourceRefs", function( functionName, fileName, packageName) { functionName <- .rs.unquote(functionName) fun <- .rs.getUntracedFunction(functionName, fileName, packageName) if (is.null(fun)) { return(NULL) } attr(fun, "srcref") }) .rs.addFunction("getFunctionSourceCode", function( functionName, fileName, packageName) { functionName <- .rs.unquote(functionName) paste(capture.output( .rs.getFunctionSourceRefs(functionName, fileName, packageName)), collapse="\n") }) # Parses and executes a file for debugging .rs.addFunction("executeDebugSource", function(fileName, encoding, breaklines, local) { envir <- if (isTRUE(local)) { # If local is TRUE, we take the first frame as it's what was artificially # constructed in earlier code sys.frames()[[1]] } else if (identical(local, FALSE)) { .GlobalEnv } else if (is.environment(local)) { local } else { stop("'local' must be TRUE, FALSE or an environment") } # Create a function containing the parsed contents of the file env <- new.env(parent = emptyenv()) env$fun <- .rs.makeSourceEquivFunction(fileName, encoding, envir) breakSteps <- character() # Inject the breakpoints if (length(breaklines) > 0) { steps <- .rs.getFunctionSteps(env$fun, "fun", breaklines) breakSteps <- unlist(lapply(steps, function(step) step$at)) suppressWarnings(.rs.setFunctionBreakpoints( "fun", env, lapply(steps, function(step) { step$at } ))) } # Run it! env$fun() # We injected function breakpoints above, but we don't want to leave them # in the in-memory copies of the functions. Replay the assignment that # created the original copy of the function. The client will set proper # breakpoints on the functions later. env$fun <- .rs.removeBreakpoints(env$fun) breakSteps <- breakSteps[nchar(breakSteps) > 6] for (steps in breakSteps) { step <- as.numeric(strsplit(breakSteps, ",")[[1]][3]) op <- deparse(body(env$fun)[[2]][[2]][[step]][[1]]) if (op == "<-" || op == "=") eval(body(env$fun)[[2]][[2]][[step]], envir = globalenv()) } return(NULL) }, attrs = list(hideFromDebugger = TRUE)) .rs.addFunction("getShinyFunction", function(name, where) { if (is(where, "refClass")) where$field(name) else get(name, where) }) .rs.addFunction("setShinyFunction", function(name, where, val) { if (is(where, "refClass")) where$field(name, val) else assign(name, val, where) }) .rs.addFunction("setShinyBreakpoints", function(name, where, lines) { # Create a blank environment and load the function into it env <- new.env(parent = emptyenv()) env$fun <- .rs.getShinyFunction(name, where) # Get the steps of the function corresponding to the lines on # which breakpoints are to be set, and set breakpoints there steps <- .rs.getFunctionSteps(env$fun, "fun", lines) suppressWarnings(.rs.setFunctionBreakpoints( "fun", env, lapply(steps, function(step) { step$at } ))) # Store the updated copy of the function back into Shiny .rs.setShinyFunction(name, where, env$fun) }) # Given a filename, creates a source-equivalent function: a function that, # when executed, has the same effect as sourcing the file. .rs.addFunction("makeSourceEquivFunction", function(filename, encoding, envir = globalenv()) { content <- suppressWarnings(parse(filename, encoding = encoding)) # Create an empty function to host the expressions in the file fun <- function() { evalq({ 1 }, envir = envir) } # Copy each statement from the file into the eval body of the function for (i in 1:length(content)) { body(fun)[[2]][[2]][[i + 1]] <- content[[i]] } # Set up the source references refs <- attr(content, "srcref") lastref <- length(refs) attr(body(fun), "srcfile") <- attr(content, "srcfile") # Simulate a source reference that contains the whole function by # combining the first and last source references of each statement in # the function ref <- structure(c(refs[[1]][1], refs[[1]][2], refs[[lastref]][3], refs[[lastref]][[4]], refs[[1]][5], refs[[lastref]][6], refs[[1]][1], refs[[lastref]][3]), srcfile = attr(content, "srcfile"), class = "srcref") attr(body(fun), "srcref")[[2]] <- ref linerefs <- list(attr(content, "srcref")[[1]]) for (i in 1:length(content)) { linerefs[[i + 1]] <- attr(content, "srcref")[[i]] } attr(body(fun)[[2]][[2]], "srcref") <- linerefs attr(fun, "srcref") <- ref return(fun) }) .rs.addGlobalFunction("debugSource", function(fileName, echo = FALSE, encoding = "unknown", local = FALSE) { # NYI: Consider whether we need to implement source with echo for debugging. # This would likely involve injecting print statements into the generated # source-equivalent function. # convert filename to UTF-8 before proceeding invisible(.Call("rs_debugSourceFile", enc2utf8(fileName), encoding, local)) }) # Parameters expected to be in environment: # where - environment or reference object # name - name of function or reference field name # label - friendly label for function to show in callstack .rs.addGlobalFunction("registerShinyDebugHook", function(params) { # Get the function from storage in Shiny, and remove any breakpoints it may # already contain fun <- .rs.getShinyFunction(params$name, params$where) fun <- .rs.removeBreakpoints(fun) params$expr <- body(fun) # Copy source refs to the body of the function attr(fun, "srcref") <- attr(body(fun), "wholeSrcref") params$fun <- fun # Register the function with RStudio (may set breakpoints) .Call("rs_registerShinyFunction", params) }) .rs.addJsonRpcHandler("get_function_steps", function( functionName, fileName, packageName, lineNumbers) { .rs.getSteps(functionName, fileName, packageName, lineNumbers) }) .rs.addFunction("haveAdvancedSteppingCommands", function() { getRversion() >= "3.1" && .rs.haveRequiredRSvnRev(63400) }) .rs.addFunction("unquote", function(strings) { tryCatch( .rs.unquoteImpl(strings), error = function(e) strings ) }) .rs.addFunction("unquoteImpl", function(strings) { if (!is.character(strings)) return(strings) parsed <- parse(text = strings) vapply(parsed, as.character, FUN.VALUE = character(1)) })