1# File src/library/base/R/conditions.R 2# Part of the R package, https://www.R-project.org 3# 4# Copyright (C) 1995-2021 The R Core Team 5# 6# This program is free software; you can redistribute it and/or modify 7# it under the terms of the GNU General Public License as published by 8# the Free Software Foundation; either version 2 of the License, or 9# (at your option) any later version. 10# 11# This program is distributed in the hope that it will be useful, 12# but WITHOUT ANY WARRANTY; without even the implied warranty of 13# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14# GNU General Public License for more details. 15# 16# A copy of the GNU General Public License is available at 17# https://www.R-project.org/Licenses/ 18 19## 20## Handling Conditions 21## 22 23## CARE: try() in ./New-Internal.R depends on *internal* coding of tryCatch()! 24## ---- If you change this, be sure to adapt try(). 25tryCatch <- function(expr, ..., finally) { 26 tryCatchList <- function(expr, names, parentenv, handlers) { 27 nh <- length(names) 28 if (nh > 1L) 29 tryCatchOne(tryCatchList(expr, names[-nh], parentenv, 30 handlers[-nh]), 31 names[nh], parentenv, handlers[[nh]]) 32 else if (nh == 1L) 33 tryCatchOne(expr, names, parentenv, handlers[[1L]]) 34 else expr 35 } 36 tryCatchOne <- function(expr, name, parentenv, handler) { 37 doTryCatch <- function(expr, name, parentenv, handler) { 38 .Internal(.addCondHands(name, list(handler), parentenv, 39 environment(), FALSE)) 40 expr 41 } 42 value <- doTryCatch(return(expr), name, parentenv, handler) 43 # The return in the call above will exit tryCatchOne unless 44 # the handler is invoked; we only get to this point if the handler 45 # is invoked. If we get here then the handler will have been 46 # popped off the internal handler stack. 47 if (is.null(value[[1L]])) { 48 # a simple error; message is stored internally 49 # and call is in result; this defers all allocs until 50 # after the jump 51 msg <- .Internal(geterrmessage()) 52 call <- value[[2L]] 53 cond <- simpleError(msg, call) 54 } 55 else if (is.character(value[[1L]])) { 56 # if the jump for a simple error is intercepted to handle 57 # an on.exit() action then the error message is encoded as 58 # a character object at that point 59 msg <- value[[1L]] 60 call <- value[[2L]] 61 cond <- simpleError(msg, call) 62 } 63 else cond <- value[[1L]] 64 value[[3L]](cond) 65 } 66 if (! missing(finally)) 67 on.exit(finally) 68 handlers <- list(...) 69 classes <- names(handlers) 70 parentenv <- parent.frame() 71 if (length(classes) != length(handlers)) 72 stop("condition handlers must be specified with a condition class") 73 tryCatchList(expr, classes, parentenv, handlers) 74} 75 76withCallingHandlers <- function(expr, ...) { 77 handlers <- list(...) 78 classes <- names(handlers) 79 parentenv <- parent.frame() 80 if (length(classes) != length(handlers)) 81 stop("condition handlers must be specified with a condition class") 82 .Internal(.addCondHands(classes, handlers, parentenv, NULL, TRUE)) 83 expr 84} 85 86suppressWarnings <- function(expr, classes = "warning") { 87 withCallingHandlers(expr, 88 warning = function(w) 89 if (inherits(w, classes)) 90 tryInvokeRestart("muffleWarning")) 91} 92 93 94## 95## Conditions and Condition Signaling 96## 97 98simpleCondition <- function(message, call = NULL) { 99 class <- c("simpleCondition", "condition") 100 structure(list(message=as.character(message), call = call), class=class) 101} 102 103simpleError <- function(message, call = NULL) { 104 class <- c("simpleError", "error", "condition") 105 structure(list(message=as.character(message), call = call), class=class) 106} 107 108simpleWarning <- function(message, call = NULL) { 109 class <- c("simpleWarning", "warning", "condition") 110 structure(list(message=as.character(message), call = call), class=class) 111} 112 113errorCondition <- function(message, ..., class = NULL, call = NULL) 114 structure(list(message = as.character(message), call = call, ...), 115 class = c(class, "error", "condition")) 116 117warningCondition <- function(message, ..., class = NULL, call = NULL) 118 structure(list(message = as.character(message), call = call, ...), 119 class = c(class, "warning", "condition")) 120 121conditionMessage <- function(c) UseMethod("conditionMessage") 122conditionCall <- function(c) UseMethod("conditionCall") 123 124conditionMessage.condition <- function(c) c$message 125conditionCall.condition <- function(c) c$call 126 127print.condition <- function(x, ...) { 128 msg <- conditionMessage(x) 129 call <- conditionCall(x) 130 cl <- class(x)[1L] 131 if (! is.null(call)) 132 cat("<", cl, " in ", deparse(call), ": ", msg, ">\n", sep="") 133 else 134 cat("<", cl, ": ", msg, ">\n", sep="") 135 invisible(x) 136} 137 138as.character.condition <- function(x, ...) { 139 msg <- conditionMessage(x) 140 call <- conditionCall(x) 141 cl <- class(x)[1L] 142 if (! is.null(call)) 143 paste0(cl, " in ", deparse(call, nlines=1L), ": ", msg, "\n") 144 else 145 paste0(cl, ": ", msg, "\n") 146} 147 148as.character.error <- function(x, ...) { 149 msg <- conditionMessage(x) 150 call <- conditionCall(x) 151 if (! is.null(call)) 152 paste0("Error in ", deparse(call, nlines=1L), ": ", msg, "\n") 153 else 154 paste0("Error: ", msg, "\n") 155} 156 157signalCondition <- function(cond) { 158 if (! inherits(cond, "condition")) 159 cond <- simpleCondition(cond) 160 msg <- conditionMessage(cond) 161 call <- conditionCall(cond) 162 .Internal(.signalCondition(cond, msg, call)) 163} 164 165 166## 167## Restarts 168## 169 170restartDescription <- function(r) r$description 171restartFormals <- function(r) formals(r$handler) 172 173print.restart <- function(x, ...) { 174 cat(paste("<restart:", x[[1L]], ">\n")) 175 invisible(x) 176} 177 178isRestart <- function(x) inherits(x, "restart") 179 180findRestart <- function(name, cond = NULL) { 181 i <- 1L 182 repeat { 183 r <- .Internal(.getRestart(i)) 184 if (is.null(r)) 185 return(NULL) 186 else if (name == r[[1L]] && 187 (is.null(cond) || is.null(r$test) || r$test(cond))) 188 return(r) 189 else i <- i + 1L 190 } 191} 192 193computeRestarts <- function(cond = NULL) { 194 val <- NULL 195 i <- 1L 196 repeat { 197 r <- .Internal(.getRestart(i)) 198 if (is.null(r)) 199 return(val) 200 else if (is.null(cond) || is.null(r$test) || r$test(cond)) 201 val <- c(val, list(r)) 202 i <- i + 1L 203 } 204} 205 206invokeRestart <- function(r, ...) { 207 if (! isRestart(r)) { 208 res <- findRestart(r) 209 if (is.null(res)) 210 stop(gettextf("no 'restart' '%s' found", as.character(r)), 211 domain = NA) 212 r <- res 213 } 214 .Internal(.invokeRestart(r, list(...))) 215} 216 217tryInvokeRestart <- function(r, ...) { 218 if (!isRestart(r)) 219 r <- findRestart(r) 220 221 if (is.null(r)) 222 invisible(NULL) 223 else 224 .Internal(.invokeRestart(r, list(...))) 225} 226 227invokeRestartInteractively <- function(r) { 228 if (! interactive()) 229 stop("not an interactive session") 230 if (! isRestart(r)) { 231 res <- findRestart(r) 232 if (is.null(res)) 233 stop(gettextf("no 'restart' '%s' found", as.character(r)), 234 domain = NA) 235 r <- res 236 } 237 if (is.null(r$interactive)) { 238 pars <- names(restartFormals(r)) 239 args <- NULL 240 if (length(pars)) { 241 cat("Enter values for restart arguments:\n\n") 242 for (p in pars) { 243 if (p == "...") { 244 prompt <- "... (a list): " 245 args <- c(args, eval(parse(prompt = prompt))) 246 } 247 else { 248 prompt <- paste0(p, ": ") 249 args <- c(args, list(eval(parse(prompt = prompt)))) 250 } 251 } 252 } 253 } 254 else args <- r$interactive() 255 .Internal(.invokeRestart(r, args)) 256} 257 258withRestarts <- function(expr, ...) { 259 docall <- function(fun, args) { 260 if ((is.character(fun) && length(fun) == 1L) || is.name(fun)) 261 fun <- get(as.character(fun), envir = parent.frame(), 262 mode = "function") 263 do.call("fun", lapply(args, enquote)) 264 } 265 makeRestart <- function(name = "", 266 handler = function(...) NULL, 267 description = "", 268 test = function(c) TRUE, 269 interactive = NULL) { 270 structure(list(name = name, exit = NULL, handler = handler, 271 description = description, test = test, 272 interactive = interactive), 273 class = "restart") 274 } 275 makeRestartList <- function(...) { 276 specs <- list(...) 277 names <- names(specs) 278 restarts <- vector("list", length(specs)) 279 for (i in seq_along(specs)) { 280 spec <- specs[[i]] 281 name <- names[i] 282 if (is.function(spec)) 283 restarts[[i]] <- makeRestart(handler = spec) 284 else if (is.character(spec)) 285 restarts[[i]] <- makeRestart(description = spec) 286 else if (is.list(spec)) 287 restarts[[i]] <- docall("makeRestart", spec) 288 else 289 stop("not a valid restart specification") 290 restarts[[i]]$name <- name 291 } 292 restarts 293 } 294 withOneRestart <- function(expr, restart) { 295 doWithOneRestart <- function(expr, restart) { 296 restart$exit <- environment() 297 .Internal(.addRestart(restart)) 298 expr 299 } 300 restartArgs <- doWithOneRestart(return(expr), restart) 301 # The return in the call above will exit withOneRestart unless 302 # the restart is invoked; we only get to this point if the restart 303 # is invoked. If we get here then the restart will have been 304 # popped off the internal restart stack. 305 docall(restart$handler, restartArgs) 306 } 307 withRestartList <- function(expr, restarts) { 308 nr <- length(restarts) 309 if (nr > 1L) 310 withOneRestart(withRestartList(expr, restarts[-nr]), 311 restarts[[nr]]) 312 else if (nr == 1L) 313 withOneRestart(expr, restarts[[1L]]) 314 else expr 315 } 316 restarts <- makeRestartList(...) 317 if (length(restarts) == 0L) 318 expr 319 else if (length(restarts) == 1L) 320 withOneRestart(expr, restarts[[1L]]) 321 else withRestartList(expr, restarts) 322} 323 324 325## 326## Callbacks 327## 328 329.signalSimpleWarning <- function(msg, call) 330 withRestarts({ 331 .Internal(.signalCondition(simpleWarning(msg, call), msg, call)) 332 .Internal(.dfltWarn(msg, call)) 333 }, muffleWarning = function() NULL) 334 335.handleSimpleError <- function(h, msg, call) 336 h(simpleError(msg, call)) 337 338.tryResumeInterrupt <- function() { 339 r <- findRestart("resume") 340 if (! is.null(r)) 341 invokeRestart(r) 342} 343 344 345## 346## Suspending/Allowing Interrupts 347## 348 349 350suspendInterrupts <- function(expr) { 351 suspended <- .Internal(interruptsSuspended()) 352 if (suspended) 353 expr 354 else { 355 on.exit(.Internal(interruptsSuspended(suspended))) 356 .Internal(interruptsSuspended(TRUE)) 357 expr 358 } 359} 360 361allowInterrupts <- function(expr) { 362 suspended <- .Internal(interruptsSuspended()) 363 if (suspended) { 364 on.exit(.Internal(interruptsSuspended(suspended))) 365 .Internal(interruptsSuspended(FALSE)) 366 expr 367 } 368 else 369 expr 370} 371 372## local() is not yet available when this is evaluated so we use a 373## throw-away closure instead 374## **** We may want to reserve the bottom slot for what is now the default 375## **** handler to allow the code in error.c to be simplified 376globalCallingHandlers <- 377 (function() { 378 gh <- list() 379 function(...) { 380 handlers <- list(...) 381 if (length(handlers) == 0) 382 gh 383 else { 384 ## Unwrap list of handlers passed as single argument 385 if (length(handlers) == 1 && is.list(handlers[[1]])) 386 handlers <- handlers[[1]] 387 388 if (identical(handlers, list(NULL))) { 389 out <- gh 390 gh <<- list() 391 } else { 392 classes <- names(handlers) 393 if (length(classes) != length(handlers)) 394 stop("condition handlers must be specified with a condition class") 395 if (! all(vapply(handlers, is.function, logical(1)))) 396 stop("condition handlers must be functions") 397 out <- NULL 398 gh <<- c(handlers, gh) 399 } 400 401 ## Remove duplicate handlers within class. We do it here so 402 ## duplicates in `...` inputs are also removed. This 403 ## preserves the ordering of handlers. We keep only the 404 ## first duplicate on the stack, so that registering a 405 ## handler again has the effect of pushing it on top of the 406 ## stack. 407 for (class in unique(names(gh))) { 408 idx <- which(class == names(gh)) 409 410 ## Ideally we'd just use `duplicated()` on the list 411 ## of handlers. Since that doesn't take into 412 ## account the closure environments, we first 413 ## convert the functions to lists and also remove 414 ## source references. 415 funAsList <- function(x) { 416 x <- utils::removeSource(x) 417 out <- list(formals(x), body(x), environment(x)) 418 attributes(out) <- attributes(x) 419 out 420 } 421 classHandlers <- lapply(gh[idx], funAsList) 422 dups <- duplicated(classHandlers) 423 if (any(dups)) { 424 message(sprintf("pushing duplicate `%s` handler on top of the stack", class)) 425 gh <<- gh[-idx[dups]] 426 } 427 } 428 429 ## Update the handler stack of the top-level context 430 .Internal(.addGlobHands(names(gh), gh, .GlobalEnv, NULL, TRUE)) 431 432 invisible(out) 433 } 434 } 435 })() 436