Re: Redirecting standard output

[Lars Magne Ingebrigtsen]

I added a interruptible_wait_for_termination function, which will
probably not work on NT, since I have no idea how to do that.

But otherwise, I think it's usable.  Comments and style tips are
welcome.  :-)  I'm cargo-culting somewhat when it comes to Emacs C
internals... 

=== modified file 'src/callproc.c'
*** src/callproc.c      2011-04-14 19:34:42 +0000
--- src/callproc.c      2011-04-21 15:41:49 +0000
***************
*** 96,101 ****
--- 96,103 ----
  /* Nonzero if this is termination due to exit.  */
  static int call_process_exited;
  
+ static Lisp_Object Qcallproc_file_symbol;
+ 
  static Lisp_Object Fgetenv_internal (Lisp_Object, Lisp_Object);
  
  static Lisp_Object
***************
*** 156,163 ****
         doc: /* Call PROGRAM synchronously in separate process.
  The remaining arguments are optional.
  The program's input comes from file INFILE (nil means `/dev/null').
! Insert output in BUFFER before point; t means current buffer;
!  nil for BUFFER means discard it; 0 means discard and don't wait.
  BUFFER can also have the form (REAL-BUFFER STDERR-FILE); in that case,
  REAL-BUFFER says what to do with standard output, as above,
  while STDERR-FILE says what to do with standard error in the child.
--- 158,166 ----
         doc: /* Call PROGRAM synchronously in separate process.
  The remaining arguments are optional.
  The program's input comes from file INFILE (nil means `/dev/null').
! Insert output in BUFFER before point; t means current buffer; nil for BUFFER
!  means discard it; 0 means discard and don't wait; and `(:file FILE)', where
!  FILE is a file name string, means that it should be written to that file.
  BUFFER can also have the form (REAL-BUFFER STDERR-FILE); in that case,
  REAL-BUFFER says what to do with standard output, as above,
  while STDERR-FILE says what to do with standard error in the child.
***************
*** 196,209 ****
--- 199,215 ----
    /* File to use for stderr in the child.
       t means use same as standard output.  */
    Lisp_Object error_file;
+   Lisp_Object output_file = Qnil;
  #ifdef MSDOS  /* Demacs 1.1.1 91/10/16 HIRANO Satoshi */
    char *outf, *tempfile;
    int outfilefd;
  #endif
+   int fd_output = -1;
    struct coding_system process_coding; /* coding-system of process output */
    struct coding_system argument_coding;       /* coding-system of arguments */
    /* Set to the return value of Ffind_operation_coding_system.  */
    Lisp_Object coding_systems;
+   int output_to_buffer = 1;
  
    /* Qt denotes that Ffind_operation_coding_system is not yet called.  */
    coding_systems = Qt;
***************
*** 273,281 ****
      {
        buffer = args[2];
  
!       /* If BUFFER is a list, its meaning is
!        (BUFFER-FOR-STDOUT FILE-FOR-STDERR).  */
!       if (CONSP (buffer))
        {
          if (CONSP (XCDR (buffer)))
            {
--- 279,289 ----
      {
        buffer = args[2];
  
!       /* If BUFFER is a list, its meaning is (BUFFER-FOR-STDOUT
!        FILE-FOR-STDERR), unless the first element is :file, in which case see
!        the next paragraph. */
!       if (CONSP (buffer) &&
!         !EQ (Qcallproc_file_symbol, XCAR (buffer)))
        {
          if (CONSP (XCDR (buffer)))
            {
***************
*** 291,296 ****
--- 299,315 ----
          buffer = XCAR (buffer);
        }
  
+       /* If the buffer is (still) a list, it might be a (:file "file") spec. 
*/
+       if (CONSP (buffer) &&
+         CONSP (XCDR (buffer)) &&
+         EQ (Qcallproc_file_symbol, XCAR (buffer)))
+       {
+         output_file = Fexpand_file_name (XCAR (XCDR (buffer)),
+                                          BVAR (current_buffer, directory));
+         CHECK_STRING (output_file);
+         buffer = Qnil;
+       }
+ 
        if (!(EQ (buffer, Qnil)
            || EQ (buffer, Qt)
            || INTEGERP (buffer)))
***************
*** 318,328 ****
       protected by the caller, so all we really have to worry about is
       buffer.  */
    {
!     struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
  
      current_dir = BVAR (current_buffer, directory);
  
!     GCPRO4 (infile, buffer, current_dir, error_file);
  
      current_dir = Funhandled_file_name_directory (current_dir);
      if (NILP (current_dir))
--- 337,347 ----
       protected by the caller, so all we really have to worry about is
       buffer.  */
    {
!     struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5;
  
      current_dir = BVAR (current_buffer, directory);
  
!     GCPRO5 (infile, buffer, current_dir, error_file, output_file);
  
      current_dir = Funhandled_file_name_directory (current_dir);
      if (NILP (current_dir))
***************
*** 342,347 ****
--- 361,368 ----
        current_dir = ENCODE_FILE (current_dir);
      if (STRINGP (error_file) && STRING_MULTIBYTE (error_file))
        error_file = ENCODE_FILE (error_file);
+     if (STRINGP (output_file) && STRING_MULTIBYTE (output_file))
+       output_file = ENCODE_FILE (output_file);
      UNGCPRO;
    }
  
***************
*** 353,358 ****
--- 374,399 ----
        infile = DECODE_FILE (infile);
        report_file_error ("Opening process input file", Fcons (infile, Qnil));
      }
+ 
+   if (STRINGP (output_file))
+     {
+ #ifdef DOS_NT
+       fd_output = emacs_open (SSDATA (output_file),
+                             O_WRONLY | O_TRUNC | O_CREAT | O_TEXT,
+                             S_IREAD | S_IWRITE);
+ #else  /* not DOS_NT */
+       fd_output = creat (SSDATA (output_file), 0666);
+ #endif /* not DOS_NT */
+       if (fd_output < 0)
+       {
+         output_file = DECODE_FILE (output_file);
+         report_file_error ("Opening process output file",
+                            Fcons (output_file, Qnil));
+         }
+       if (STRINGP (error_file) || NILP (error_file))
+         output_to_buffer = 0;
+     }
+ 
    /* Search for program; barf if not found.  */
    {
      struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
***************
*** 413,429 ****
    strcat (tempfile, "detmp.XXX");
    mktemp (tempfile);
  
!   outfilefd = creat (tempfile, S_IREAD | S_IWRITE);
!   if (outfilefd < 0)
      {
!       emacs_close (filefd);
!       report_file_error ("Opening process output file",
!                        Fcons (build_string (tempfile), Qnil));
      }
    fd[0] = filefd;
    fd[1] = outfilefd;
  #endif /* MSDOS */
! 
    if (INTEGERP (buffer))
      fd[1] = emacs_open (NULL_DEVICE, O_WRONLY, 0), fd[0] = -1;
    else
--- 454,475 ----
    strcat (tempfile, "detmp.XXX");
    mktemp (tempfile);
  
!   /* If we're redirecting STDOUT to a file, this is already opened. */
!   if (fd_output < 0)
      {
!       outfilefd = creat (tempfile, S_IREAD | S_IWRITE);
!       if (outfilefd < 0) {
!       emacs_close (filefd);
!       report_file_error ("Opening process output file",
!                          Fcons (build_string (tempfile), Qnil));
!       }
      }
+   else
+     outfilefd = fd_output;
    fd[0] = filefd;
    fd[1] = outfilefd;
  #endif /* MSDOS */
!   
    if (INTEGERP (buffer))
      fd[1] = emacs_open (NULL_DEVICE, O_WRONLY, 0), fd[0] = -1;
    else
***************
*** 450,455 ****
--- 496,503 ----
      struct sigaction sigpipe_action;
  #endif
  
+     if (fd_output >= 0)
+       fd1 = fd_output;
  #if 0  /* Some systems don't have sigblock.  */
      mask = sigblock (sigmask (SIGCHLD));
  #endif
***************
*** 572,578 ****
        }
  
      UNBLOCK_INPUT;
! 
  #ifdef HAVE_WORKING_VFORK
      /* Restore the signal state.  */
      sigaction (SIGPIPE, &sigpipe_action, 0);
--- 620,626 ----
        }
  
      UNBLOCK_INPUT;
!     
  #ifdef HAVE_WORKING_VFORK
      /* Restore the signal state.  */
      sigaction (SIGPIPE, &sigpipe_action, 0);
***************
*** 591,596 ****
--- 639,646 ----
      /* Close most of our fd's, but not fd[0]
         since we will use that to read input from.  */
      emacs_close (filefd);
+     if (fd_output >= 0)
+       emacs_close (fd_output);
      if (fd1 >= 0 && fd1 != fd_error)
        emacs_close (fd1);
    }
***************
*** 673,678 ****
--- 723,729 ----
    immediate_quit = 1;
    QUIT;
  
+   if (output_to_buffer)
    {
      register EMACS_INT nread;
      int first = 1;
***************
*** 802,808 ****
  
  #ifndef MSDOS
    /* Wait for it to terminate, unless it already has.  */
!   wait_for_termination (pid);
  #endif
  
    immediate_quit = 0;
--- 853,862 ----
  
  #ifndef MSDOS
    /* Wait for it to terminate, unless it already has.  */
!   if (output_to_buffer)
!     wait_for_termination (pid);
!   else
!     interruptible_wait_for_termination (pid);
  #endif
  
    immediate_quit = 0;
***************
*** 1554,1559 ****
--- 1608,1616 ----
  #endif
    staticpro (&Vtemp_file_name_pattern);
  
+   Qcallproc_file_symbol = intern_c_string (":file");
+   staticpro (&Qcallproc_file_symbol);
+ 
    DEFVAR_LISP ("shell-file-name", Vshell_file_name,
               doc: /* *File name to load inferior shells from.
  Initialized from the SHELL environment variable, or to a system-dependent

=== modified file 'src/lisp.h'
*** src/lisp.h  2011-04-15 08:22:34 +0000
--- src/lisp.h  2011-04-21 15:36:57 +0000
***************
*** 3309,3314 ****
--- 3309,3315 ----
  extern void init_all_sys_modes (void);
  extern void reset_all_sys_modes (void);
  extern void wait_for_termination (int);
+ extern void interruptible_wait_for_termination (int);
  extern void flush_pending_output (int);
  extern void child_setup_tty (int);
  extern void setup_pty (int);

=== modified file 'src/sysdep.c'
*** src/sysdep.c        2011-04-16 21:26:33 +0000
--- src/sysdep.c        2011-04-21 15:35:27 +0000
***************
*** 302,307 ****
--- 302,320 ----
  void
  wait_for_termination (int pid)
  {
+   wait_for_termination_1 (pid, 0);
+ }
+ 
+ /* Like the above, but allow keyboard interruption. */
+ void
+ interruptible_wait_for_termination (int pid)
+ {
+   wait_for_termination_1 (pid, 1);
+ }
+ 
+ void
+ wait_for_termination_1 (int pid, int interruptible)
+ {
    while (1)
      {
  #if defined (BSD_SYSTEM) || defined (HPUX)
***************
*** 339,344 ****
--- 352,359 ----
        sigsuspend (&empty_mask);
  #endif /* not WINDOWSNT */
  #endif /* not BSD_SYSTEM, and not HPUX version >= 6 */
+       if (interruptible)
+       QUIT;
      }
  }
  

-- 
(domestic pets only, the antidote for overdose, milk.)
  bloggy blog http://lars.ingebrigtsen.no/