In system/system2, allow to opt-in for console signals even with tasks

running with wait=FALSE.  Use this feature to allow interruption of
computations running using cluterApply() etc. via Ctrl+C, fixing a
regression introduced in 84413.



git-svn-id: https://svn.r-project.org/R/trunk@84676 00db46b3-68df-0310-9c12-caf00c1e9a41

src/gnuwin32/run.c

@@ -186,7 +186,7 @@ extern size_t Rf_utf8towcs(wchar_t *wc, const char *s, size_t n);
 static void pcreate(const char* cmd, cetype_t enc,
  int newconsole, int visible,
  HANDLE hIN, HANDLE hOUT, HANDLE hERR,
- pinfo *pi)
+ pinfo *pi, int consignals)
 {
  DWORD ret;
  STARTUPINFO si;
@@ -369,7 +369,7 @@ static void pcreate(const char* cmd, cetype_t enc,
  flags |= CREATE_SUSPENDED; /* assign to job before it runs */
  if (newconsole && (visible == 1))
  flags |= CREATE_NEW_CONSOLE;
- else if (newconsole)
+ else if (newconsole && !consignals)
  /* prevent interruption of background processes by Ctrl-C, PR#17764 */
  flags |= CREATE_NEW_PROCESS_GROUP;
  if (job && breakaway)
@@ -630,12 +630,12 @@ static int pwait2(pinfo *pi, DWORD timeoutMillis, int* timedout)
 int runcmd(const char *cmd, cetype_t enc, int wait, int visible,
  const char *fin, const char *fout, const char *ferr)
 {
- return runcmd_timeout(cmd, enc, wait, visible, fin, fout, ferr, 0, NULL);
+ return runcmd_timeout(cmd, enc, wait, visible, fin, fout, ferr, 0, NULL, 1);
 }
 
 int runcmd_timeout(const char *cmd, cetype_t enc, int wait, int visible,
  const char *fin, const char *fout, const char *ferr,
- int timeout, int *timedout)
+ int timeout, int *timedout, int consignals)
 {
  if (!wait && timeout)
  error("Timeout with background running processes is not supported.");
@@ -659,7 +659,7 @@ int runcmd_timeout(const char *cmd, cetype_t enc, int wait, int visible,
 
 
  memset(&(pi.pi), 0, sizeof(PROCESS_INFORMATION));
- pcreate(cmd, enc, !wait, visible, hIN, hOUT, hERR, &pi);
+ pcreate(cmd, enc, !wait, visible, hIN, hOUT, hERR, &pi, consignals);
  if (pi.pi.hProcess) {
  if (wait) {
  RCNTXT cntxt;
@@ -701,9 +701,9 @@ rpipe * rpipeOpen(const char *cmd, cetype_t enc, int visible,
  DWORD id;
  BOOL res;
  int close1 = 0, close2 = 0, close3 = 0;
- /* newconsole (~"!wait") means gnore Ctrl handler attibute
+ /* newconsole (~"!wait") means ignore Ctrl handler attribute
  is set for child. When also visible==1, an actual text
- console is created */
+ console is created. */
 
  if (!(r = (rpipe *) malloc(sizeof(struct structRPIPE)))) {
  strcpy(RunError, _("Insufficient memory (rpipeOpen)"));
@@ -754,7 +754,7 @@ rpipe * rpipeOpen(const char *cmd, cetype_t enc, int visible,
  if (hERR && ferr && ferr[0]) close3 = 1;
  }
 
- pcreate(cmd, enc, newconsole, visible, hIN, hOUT, hERR, &(r->pi));
+ pcreate(cmd, enc, newconsole, visible, hIN, hOUT, hERR, &(r->pi), 0);
 
  if (close1) CloseHandle(hIN);
  if (close2) CloseHandle(hOUT);

src/gnuwin32/run.h

@@ -48,7 +48,7 @@ int runcmd(const char *cmd, cetype_t enc, int wait, int visible,
 
 int runcmd_timeout(const char *cmd, cetype_t enc, int wait, int visible, 
  const char *fin, const char *fout, const char *ferr,
- int timeout, int *timedout);
+ int timeout, int *timedout, int consignals);
 
 rpipe *rpipeOpen(const char *cmd, cetype_t enc, int visible, 
  const char *finput, int io,

src/gnuwin32/sys-win32.c

@@ -254,7 +254,7 @@ SEXP do_system(SEXP call, SEXP op, SEXP args, SEXP rho)
  int vis = 0, flag = 2, i = 0, j, ll = 0;
  SEXP cmd, fin, Stdout, Stderr, tlist = R_NilValue, tchar, rval;
  PROTECT_INDEX ti;
- int timeout = 0, timedout = 0;
+ int timeout = 0, timedout = 0, consignals = 0;
 
  checkArity(op, args);
  cmd = CAR(args);
@@ -281,6 +281,10 @@ SEXP do_system(SEXP call, SEXP op, SEXP args, SEXP rho)
  errorcall(call, _("invalid '%s' argument"), "timeout");
  if (timeout && !flag)
  errorcall(call, "Timeout with background running processes is not supported.");
+ args = CDR(args);
+ consignals = asLogical(CAR(args));
+ if (consignals == NA_INTEGER)
+ errorcall(call, _("invalid '%s' argument"), "receive.console.signals");
 
  if (CharacterMode == RGui) {
  /* This is a rather conservative approach: if
@@ -305,7 +309,7 @@ SEXP do_system(SEXP call, SEXP op, SEXP args, SEXP rho)
  ll = runcmd_timeout(CHAR(STRING_ELT(cmd, 0)),
  getCharCE(STRING_ELT(cmd, 0)),
  flag, vis, CHAR(STRING_ELT(fin, 0)), fout, ferr,
- timeout, &timedout);
+ timeout, &timedout, consignals);
  if (ll == NOLAUNCH) warning(runerror());
  } else {
  /* read stdout +/- stderr from pipe */

src/library/base/R/unix/system.unix.R

@@ -1,7 +1,7 @@
 # File src/library/base/R/unix/system.unix.R
 # Part of the R package, https://www.R-project.org
 #
-# Copyright (C) 1995-2019 The R Core Team
+# Copyright (C) 1995-2023 The R Core Team
 #
 # This program is free software; you can redistribute it and/or modify
 # it under the terms of the GNU General Public License as published by
@@ -20,7 +20,7 @@ system <- function(command, intern = FALSE,
  ignore.stdout = FALSE, ignore.stderr = FALSE,
  wait = TRUE, input = NULL,
  show.output.on.console = TRUE, minimized = FALSE,
- invisible = TRUE, timeout = 0)
+ invisible = TRUE, timeout = 0, receive.console.signals = wait)
 {
  if(!missing(show.output.on.console) || !missing(minimized)
  || !missing(invisible))
@@ -34,6 +34,8 @@ system <- function(command, intern = FALSE,
  stop("'ignore.stderr' must be TRUE or FALSE")
  if(!is.logical(wait) || is.na(wait))
  stop("'wait' must be TRUE or FALSE")
+ if(!is.logical(receive.console.signals) || is.na(receive.console.signals))
+ stop("'receive.console.signals' must be TRUE or FALSE")
 
  if(ignore.stdout) command <- paste(command, ">/dev/null")
  if(ignore.stderr) command <- paste(command, "2>/dev/null")
@@ -48,21 +50,22 @@ system <- function(command, intern = FALSE,
  command <- paste("<", shQuote(f), command)
  }
  if(!wait && !intern) command <- paste(command, "&")
- .Internal(system(command, intern, timeout))
+ .Internal(system(command, intern, timeout, receive.console.signals))
 }
 
 system2 <- function(command, args = character(),
  stdout = "", stderr = "", stdin = "", input = NULL,
  env = character(),
  wait = TRUE, minimized = FALSE, invisible = TRUE,
- timeout = 0
+ timeout = 0, receive.console.signals = wait
 )
 {
  if(!missing(minimized) || !missing(invisible))
  message("arguments 'minimized' and 'invisible' are for Windows only")
  if(!is.logical(wait) || is.na(wait))
  stop("'wait' must be TRUE or FALSE")
-
+ if(!is.logical(receive.console.signals) || is.na(receive.console.signals))
+ stop("'receive.console.signals' must be TRUE or FALSE")
  intern <- FALSE
  command <- paste(c(env, shQuote(command), args), collapse = " ")
 
@@ -104,7 +107,7 @@ system2 <- function(command, args = character(),
  command <- paste(command, "<", shQuote(f))
  } else if (nzchar(stdin)) command <- paste(command, "<", shQuote(stdin))
  if(!wait && !intern) command <- paste(command, "&")
- .Internal(system(command, intern, timeout))
+ .Internal(system(command, intern, timeout, receive.console.signals))
 }
 
 ## Some people try to use this with NA inputs (PR#15147)

src/library/base/R/windows/system.R

@@ -1,7 +1,7 @@
 # File src/library/base/R/windows/system.R
 # Part of the R package, https://www.R-project.org
 #
-# Copyright (C) 1995-2019 The R Core Team
+# Copyright (C) 1995-2023 The R Core Team
 #
 # This program is free software; you can redistribute it and/or modify
 # it under the terms of the GNU General Public License as published by
@@ -41,7 +41,7 @@ system <- function(command, intern = FALSE,
  ignore.stdout = FALSE, ignore.stderr = FALSE,
  wait = TRUE, input = NULL,
  show.output.on.console = TRUE, minimized = FALSE,
- invisible = TRUE, timeout = 0)
+ invisible = TRUE, timeout = 0, receive.console.signals = wait)
 {
  if(!is.logical(intern) || is.na(intern))
  stop("'intern' must be TRUE or FALSE")
@@ -57,6 +57,8 @@ system <- function(command, intern = FALSE,
  stop("'minimized' must be TRUE or FALSE")
  if(!is.logical(invisible) || is.na(invisible))
  stop("'invisible' must be TRUE or FALSE")
+ if(!is.logical(receive.console.signals) || is.na(receive.console.signals))
+ stop("'receive.console.signals' must be TRUE or FALSE")
  stdout <- ifelse(ignore.stdout, FALSE, "")
  stderr <- ifelse(ignore.stderr, FALSE, "")
 
@@ -94,7 +96,8 @@ system <- function(command, intern = FALSE,
  on.exit(Sys.setenv(GFORTRAN_STDOUT_UNIT = "-1"), add = TRUE)
  if (.fixupGFortranStderr())
  on.exit(Sys.setenv(GFORTRAN_STDERR_UNIT = "-1"), add = TRUE)
- rval <- .Internal(system(command, as.integer(flag), f, stdout, stderr, timeout))
+ rval <- .Internal(system(command, as.integer(flag), f, stdout, stderr,
+ timeout, receive.console.signals))
  if (!internNothing)
  rval
  else {
@@ -114,14 +117,17 @@ system2 <- function(command, args = character(),
  stdout = "", stderr = "", stdin = "", input = NULL,
  env = character(),
  wait = TRUE, minimized = FALSE, invisible = TRUE,
- timeout = 0)
+ timeout = 0, receive.console.signals = wait)
 {
  if(!is.logical(wait) || is.na(wait))
  stop("'wait' must be TRUE or FALSE")
  if(!is.logical(minimized) || is.na(minimized))
  stop("'minimized' must be TRUE or FALSE")
  if(!is.logical(invisible) || is.na(invisible))
  stop("'invisible' must be TRUE or FALSE")
+ if(!is.logical(receive.console.signals) || is.na(receive.console.signals))
+ stop("'receive.console.signals' must be TRUE or FALSE")
+
  command <- paste(c(shQuote(command), env, args), collapse = " ")
 
  if(is.null(stdout)) stdout <- FALSE
@@ -164,7 +170,8 @@ system2 <- function(command, args = character(),
  on.exit(Sys.setenv(GFORTRAN_STDOUT_UNIT = "-1"), add = TRUE)
  if (.fixupGFortranStderr())
  on.exit(Sys.setenv(GFORTRAN_STDERR_UNIT = "-1"), add = TRUE) 
- rval <- .Internal(system(command, flag, f, stdout, stderr, timeout))
+ rval <- .Internal(system(command, flag, f, stdout, stderr, timeout,
+ receive.console.signals))
 
  if (is.null(rf)) {
  if (is.integer(rval))

src/library/base/man/system.Rd

@@ -1,6 +1,6 @@
 % File src/library/base/man/system.Rd
 % Part of the R package, https://www.R-project.org
-% Copyright 1995-2018 R Core Team
+% Copyright 1995-2023 R Core Team
 % Distributed under GPL 2 or later
 
 \name{system}
@@ -16,7 +16,8 @@
 system(command, intern = FALSE,
  ignore.stdout = FALSE, ignore.stderr = FALSE,
  wait = TRUE, input = NULL, show.output.on.console = TRUE,
- minimized = FALSE, invisible = TRUE, timeout = 0)
+ minimized = FALSE, invisible = TRUE, timeout = 0,
+ receive.console.signals = wait)
 }
 \arguments{
  \item{command}{the system command to be invoked, as a character string.}
@@ -37,6 +38,11 @@ system(command, intern = FALSE,
  \item{timeout}{timeout in seconds, ignored if 0. This is a limit for the
  elapsed time running \code{command} in a separate process. Fractions
  of seconds are ignored.}
+ \item{receive.console.signals}{a logical (not \code{NA}) indicating
+ whether the command should receive events from the terminal/console that
+ \R runs from, particularly whether it should be interrupted by
+ \kbd{Ctrl-C}. This will be ignored and events will always be received when
+ \code{intern = TRUE} or \code{wait = TRUE}.}
 #ifdef unix
  \item{show.output.on.console, minimized, invisible}{arguments
  that are accepted on Windows but ignored on this platform, with a
@@ -119,6 +125,10 @@ system(command, intern = FALSE,
 
  There are many pitfalls in using \code{system} to ascertain if a
  command can be run --- \code{\link{Sys.which}} is more suitable.
+
+ \code{receive.console.signals = TRUE} is useful when running asynchronous
+ processes (using \code{wait = FALSE}) to implement a synchronous operation.
+ In all other cases it is recommended to use the default.
 }
 
 \value{

src/library/base/man/system2.Rd

@@ -1,6 +1,6 @@
 % File src/library/base/man/system.Rd
 % Part of the R package, https://www.R-project.org
-% Copyright 1995-2018 R Core Team
+% Copyright 1995-2023 R Core Team
 % Distributed under GPL 2 or later
 
 \name{system2}
@@ -13,7 +13,8 @@
 system2(command, args = character(),
  stdout = "", stderr = "", stdin = "", input = NULL,
  env = character(), wait = TRUE,
- minimized = FALSE, invisible = TRUE, timeout = 0)
+ minimized = FALSE, invisible = TRUE, timeout = 0,
+ receive.console.signals = wait)
 }
 \arguments{
  \item{command}{the system command to be invoked, as a character string.}
@@ -40,6 +41,11 @@ system2(command, args = character(),
  \item{timeout}{timeout in seconds, ignored if 0. This is a limit for the
  elapsed time running \code{command} in a separate process. Fractions
  of seconds are ignored.}
+ \item{receive.console.signals}{a logical (not \code{NA}) indicating whether
+ the command should receive events from the terminal/console that \R runs
+ from, particularly whether it should be interrupted by \kbd{Ctrl-C}. This
+ will be ignored and events will always be received when
+ \code{intern = TRUE} or \code{wait = TRUE}.}
 #ifdef unix
  \item{minimized, invisible}{arguments that are accepted on Windows but
  ignored on this platform, with a warning.}
@@ -82,6 +88,10 @@ system2(command, args = character(),
  it usually is by default, the executed command may write to standard
  output and standard error.
 #endif
+
+ \code{receive.console.signals = TRUE} is useful when running asynchronous
+ processes (using \code{wait = FALSE}) to implement a synchronous operation.
+ In all other cases it is recommended to use the default.
 }
 %% We use popen, and that pipes stdout only
 

src/library/parallel/R/snowSOCK.R

@@ -1,7 +1,7 @@
 # File src/library/parallel/R/snowSOCK.R
 # Part of the R package, https://www.R-project.org
 #
-# Copyright (C) 1995-2020 The R Core Team
+# Copyright (C) 1995-2023 The R Core Team
 #
 # This program is free software; you can redistribute it and/or modify
 # it under the terms of the GNU General Public License as published by
@@ -109,12 +109,13 @@ newPSOCKnode <- function(machine = "localhost", ...,
  ## necessary.
  ##
  ## (Not clear if that is the current behaviour: works for me)
- system(cmd, wait = FALSE, input = "")
+ system(cmd, wait = FALSE, input = "",
+ receive.console.signals = TRUE)
  }
  else {
  ## If workers are running a different R version, avoid a WARNING
  cmd <- paste("R_HOME=", cmd)
- system(cmd, wait = FALSE)
+ system(cmd, wait = FALSE, receive.console.signals = TRUE)
  }
  }
 
@@ -174,11 +175,12 @@ makePSOCKcluster <- function(names, ...)
  if (.Platform$OS.type == "windows") {
  for(i in seq_along(cl))
  ## see newPSOCKnode for the input = ""
- system(cmd, wait = FALSE, input = "")
+ system(cmd, wait = FALSE, input = "",
+ receive.console.signals = TRUE)
  } else {
  ## Asynchronous lists are defined by POSIX
  cmd <- paste(rep(cmd, length(cl)), collapse = " & ")
- system(cmd, wait = FALSE)
+ system(cmd, wait = FALSE, receive.console.signals = TRUE)
  }
 
  ## Accept connections and send the first command as initial

src/library/utils/man/download.file.Rd

@@ -159,9 +159,9 @@ download.file(url, destfile, method, quiet = FALSE, mode = "w",
 
  On Windows, if \code{mode} is not supplied (\code{\link{missing}()})
  and \code{url} ends in one of \code{.gz}, \code{.bz2}, \code{.xz},
- \code{.tgz}, \code{.zip}, \code{.jar}, \code{.rda}, \code{.rds} or
- \code{.RData}, \code{mode = "wb"} is set so that a binary transfer
- is done to help unwary users.
+ \code{.tgz}, \code{.zip}, \code{.jar}, \code{.rda}, \code{.rds},
+ \code{.RData} or \code{.pdf}, \code{mode = "wb"} is set so that a binary
+ transfer is done to help unwary users.
 
  Code written to download binary files must use \code{mode = "wb"} (or
  \code{"ab"}), but the problems incurred by a text transfer will only

src/main/names.c

@@ -665,9 +665,9 @@ FUNTAB R_FunTab[] =
 {"internalsID", do_internalsID, 0, 11, 0, {PP_FUNCALL, PREC_FN, 0}},
 
 #ifdef Win32
-{"system", do_system, 0, 211, 6, {PP_FUNCALL, PREC_FN, 0}},
+{"system", do_system, 0, 211, 7, {PP_FUNCALL, PREC_FN, 0}},
 #else
-{"system", do_system, 0, 211, 3, {PP_FUNCALL, PREC_FN, 0}},
+{"system", do_system, 0, 211, 4, {PP_FUNCALL, PREC_FN, 0}},
 #endif
 
 #ifdef Win32