https://github.com/cran/multicore
Tip revision: 3ea66bd3ecb5f9467b3db36480ee97c06fc001e4 authored by Simon Urbanek on 08 August 1977, 00:00:00 UTC
version 0.1-7
version 0.1-7
Tip revision: 3ea66bd
fork.R
# --- multicore --- low-level functions ---
# selected signals
SIGHUP <- 1L
SIGINT <- 2L
SIGQUIT <- 3L
SIGKILL <- 9L
SIGTERM <- 15L
SIGALRM <- 14L
SIGSTOP <- 17L
SIGCHLD <- 20L
SIGINFO <- 29L
SIGUSR1 <- 30L
SIGUSR2 <- 31L
fork <- function() {
r <- .Call(mc_fork)
structure(list(pid=r[1], fd=r[2:3]), class=c(ifelse(r[1]!=0L,"childProcess","masterProcess"),"process"))
}
readChildren <- function(timeout=0)
.Call(read_children, as.double(timeout))
readChild <- function(child) {
if (inherits(child, "process")) child <- processID(child)
if (!is.numeric(child)) stop("invalid child argument")
.Call(read_child, as.integer(child))
}
selectChildren <- function(children=NULL, timeout=0) {
if (!length(children)) children <- integer(0)
if (inherits(children, "process")) children <- processID(children)
if (is.list(children)) children <- unlist(lapply(children, function(x) if (inherits(x, "process")) x$pid else stop("children must be a list of processes or a single process")))
if (!is.numeric(children)) stop("children must be a list of processes or a single process")
.Call(select_children, as.double(timeout), as.integer(children))
}
rmChild <- function(child) {
if (inherits(child, "process")) child <- processID(child)
if (!is.numeric(child)) stop("invalid child argument")
.Call(rm_child, as.integer(child))
}
kill <- function(process, signal=SIGINT) {
process <- processID(process)
unlist(lapply(process, function(p) .Call(mc_kill, as.integer(p), as.integer(signal))))
}
sendMaster <- function(what) {
if (!is.raw(what)) what <- serialize(what, NULL, FALSE)
.Call(send_master, what)
}
processID <- function(process)
if (inherits(process, "process")) process$pid else if (is.list(process)) unlist(lapply(process, processID)) else stop("process must be of the class `process'")
sendChildStdin <- function(child, what) {
if (inherits(child, "process") || is.list(child)) child <- processID(child)
if (!is.numeric(child) || !length(child)) stop("child must be a valid child process")
child <- as.integer(child)
if (is.character(what)) what <- charToRaw(paste(what, collapse='\n'))
if (!is.raw(what)) stop("what must be a character or raw vector")
unlist(lapply(child, function(p) .Call(send_child_stdin, p, what)))
}
exit <- function(exit.code=0L, send=NULL) {
if (!is.null(send)) try(sendMaster(send), silent=TRUE)
.Call(mc_exit, as.integer(exit.code))
}
children <- function(select) {
p <- .Call(mc_children)
if (!missing(select)) p <- p[p %in% processID(select)]
lapply(p, function(x) structure(list(pid=x), class=c("childProcess", "process")))
}
childrenDescriptors <- function(index=0L)
.Call(mc_fds, as.integer(index))
masterDescriptor <- function() .Call(mc_master_fd)
isChild <- function() .Call(mc_is_child)
# those could be really written as closeFD(1L) and closeFD(2L), but historically ...
closeStdout <- function() .Call(close_stdout)
closeStderr <- function() .Call(close_stderr)
closeFD <- function(fds) .Call(close_fds, as.integer(fds))
closeAll <- function(includeStd=FALSE) {
if (!isChild()) { warning("closeAll() is a no-op in the master process"); return(invisible(FALSE)) }
fds <- masterDescriptor()
if (identical(fds, -1L)) fds <- integer(0)
if (includeStd) fds <- c(1L, 2L, fds)
mf <- max(fds) + 16L # take a few more ...
# close all but those that we actually use
closeFD((1:mf)[-fds])
}