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