1#  File src/library/base/R/taskCallback.R
2#  Part of the R package, https://www.R-project.org
3#
4#  Copyright (C) 1995-2018 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
19addTaskCallback <- function(f, data = NULL, name = character())
20{
21    if(!is.function(f))
22        stop("handler must be a function")
23    val <- .Call(.C_R_addTaskCallback, f, data, !missing(data),
24                 as.character(name))
25    val + 1L
26}
27
28removeTaskCallback <- function(id)
29{
30    if(!is.character(id))
31        id <- as.integer(id)
32
33    .Call(.C_R_removeTaskCallback, id)
34}
35
36getTaskCallbackNames <- function() .Call(.C_R_getTaskCallbackNames)
37
38
39taskCallbackManager <-
40  #
41  #
42  #
43function(handlers = list(), registered = FALSE, verbose = FALSE)
44{
45    suspended <- FALSE
46    .verbose <- verbose
47
48    add <-
49    #
50    # this is used to register a callback.
51    # It has the same call sequence and semantics
52    # as addTaskCallback but provides an optional
53    # name by which to identify the element.
54    # This can be used to remove the value in the future.
55    # The default name is the next available position in the
56    # list.
57    # The result is stored in the `handlers' list using the
58    # name.
59    #
60    # The element in the list contains the function
61    # in the `f' slot,  and optionally a data field
62    # to store the `data' argument.
63    #
64    # This could arrange to register itself using
65    # addTaskCallback() if the size of the handlers list
66    # becomes 1.
67        function(f, data = NULL, name = NULL, register = TRUE)
68        {
69
70      # generate default name if none supplied
71            if(is.null(name))
72                name <- as.character(length(handlers) + 1L)
73
74      # Add to handlers, replacing any element with that name
75      # if needed.
76            handlers[[name]] <<- list(f = f)
77
78      # If data was specified, add this to the new element
79      # so that it will be included in the call for this function
80            if(!missing(data))
81                handlers[[name]][["data"]] <<- data
82
83      # We could arrange to register the evaluate function
84      # so that the handlers list would be active. However,
85      # we would have to unregister it in the remove()
86      # function when there were no handlers.
87            if(!registered && register) {
88                register()
89            }
90
91            name
92        }
93
94    remove <- function(which)
95    {
96        if (length(which) != 1L)
97            stop("'which' must be of length 1")
98        if(is.character(which)) {
99            tmp <- match(which, names(handlers))
100            if(is.na(tmp))
101                stop(gettextf("no such element '%s'", which), domain = NA)
102            which <- tmp
103        } else if(is.numeric(which)) {
104            which <- as.integer(which)
105            if (which <= 0 || which > length(handlers))
106                stop("invalid 'which' argument")
107        } else
108            stop("'which' must be character or numeric")
109
110        handlers <<- handlers[-which]
111
112        return(TRUE)
113    }
114
115
116    evaluate <-
117    #
118    # This is the actual callback that is registered with the C-level
119    # mechanism. It is invoked by R when a top-level task is completed.
120    # It then calls each of the functions in the handlers list
121    # passing these functions the arguments it received and any
122    # user-level data for those functions registered in the call to
123    # add() via the `data' argument.
124    #
125    # At the end of the evaluation, any function that returned FALSE
126    # is discarded.
127        function(expr, value, ok, visible)
128        {
129            if(suspended)
130                return(TRUE)
131            discard <- character()
132            for(i in names(handlers)) {
133                h <- handlers[[i]]
134                if(length(h) > 1L) {
135                    val <- h[["f"]](expr, value, ok, visible, h[["data"]])
136                } else {
137                    val <- h[["f"]](expr, value, ok, visible)
138                }
139                if(!val) {
140                    discard <- c(discard, i)
141                }
142            }
143            if(length(discard)) {
144                if(.verbose)
145                    cat(gettextf("Removing %s", paste(discard, collapse=", ")), "\n")
146                idx <- is.na(match(names(handlers), discard))
147                if(length(idx))
148                    handlers <<- handlers[idx]
149                else
150                    handlers <<- list()
151            }
152            return(TRUE)
153        }
154
155    suspend <-
156        function(status = TRUE) {
157            suspended <<- status
158        }
159
160    register <-
161        function(name = "R-taskCallbackManager", verbose = .verbose)
162        {
163            if(verbose)
164                cat(gettext("Registering 'evaluate' as low-level callback\n"))
165            id <- addTaskCallback(evaluate, name = name)
166            registered <<- TRUE
167            id
168        }
169
170    list(add = add,
171         evaluate = evaluate,
172         remove = remove,
173         register = register,
174         suspend = suspend,
175         callbacks = function()
176         handlers
177         )
178}
179