src/callproc.c

   1 /* Synchronous subprocess invocation for GNU Emacs.
   2    Copyright (C) 1985, 1986, 1987, 1988, 1992 Free Software Foundation, Inc.
   3
   4 This file is part of GNU Emacs.
   5
   6 GNU Emacs 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 1, or (at your option)
   9 any later version.
  10
  11 GNU Emacs 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 You should have received a copy of the GNU General Public License
  17 along with GNU Emacs; see the file COPYING.  If not, write to
  18 the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.  */
  19
  20
  21 #include <signal.h>
  22 #include <errno.h>
  23
  24 #include "config.h"
  25
  26 extern int errno;
  27 #ifndef VMS
  28 extern char *sys_errlist[];
  29 #endif
  30
  31 /* Define SIGCHLD as an alias for SIGCLD.  */
  32
  33 #if !defined (SIGCHLD) && defined (SIGCLD)
  34 #define SIGCHLD SIGCLD
  35 #endif /* SIGCLD */
  36
  37 #include <sys/types.h>
  38 #define PRIO_PROCESS 0
  39 #include <sys/file.h>
  40 #ifdef USG5
  41 #include <fcntl.h>
  42 #endif
  43
  44 #ifndef O_RDONLY
  45 #define O_RDONLY 0
  46 #endif
  47
  48 #ifndef O_WRONLY
  49 #define O_WRONLY 1
  50 #endif
  51
  52 #include "lisp.h"
  53 #include "commands.h"
  54 #include "buffer.h"
  55 #include "paths.h"
  56 #include "process.h"
  57 #include "syssignal.h"
  58
  59 #ifdef VMS
  60 extern noshare char **environ;
  61 #else
  62 extern char **environ;
  63 #endif
  64
  65 #define max(a, b) ((a) > (b) ? (a) : (b))
  66
  67 Lisp_Object Vexec_path, Vexec_directory, Vdata_directory;
  68
  69 Lisp_Object Vshell_file_name;
  70
  71 Lisp_Object Vprocess_environment;
  72
  73 /* True iff we are about to fork off a synchronous process or if we
  74    are waiting for it.  */
  75 int synch_process_alive;
  76
  77 /* Nonzero => this is a string explaining death of synchronous subprocess.  */
  78 char *synch_process_death;
  79
  80 /* If synch_process_death is zero,
  81    this is exit code of synchronous subprocess.  */
  82 int synch_process_retcode;
  83 \f
  84 #ifndef VMS  /* VMS version is in vmsproc.c.  */
  85
  86 static Lisp_Object
  87 call_process_kill (fdpid)
  88      Lisp_Object fdpid;
  89 {
  90   close (XFASTINT (Fcar (fdpid)));
  91   EMACS_KILLPG (XFASTINT (Fcdr (fdpid)), SIGKILL);
  92   synch_process_alive = 0;
  93   return Qnil;
  94 }
  95
  96 Lisp_Object
  97 call_process_cleanup (fdpid)
  98      Lisp_Object fdpid;
  99 {
 100   register int pid = XFASTINT (Fcdr (fdpid));
 101
 102   if (EMACS_KILLPG (pid, SIGINT) == 0)
 103     {
 104       int count = specpdl_ptr - specpdl;
 105       record_unwind_protect (call_process_kill, fdpid);
 106       message1 ("Waiting for process to die...(type C-g again to kill it instantly)");
 107       immediate_quit = 1;
 108       QUIT;
 109       wait_for_termination (pid);
 110       immediate_quit = 0;
 111       specpdl_ptr = specpdl + count; /* Discard the unwind protect.  */
 112       message1 ("Waiting for process to die...done");
 113     }
 114   synch_process_alive = 0;
 115   close (XFASTINT (Fcar (fdpid)));
 116   return Qnil;
 117 }
 118
 119 DEFUN ("call-process", Fcall_process, Scall_process, 1, MANY, 0,
 120   "Call PROGRAM synchronously in separate process.\n\
 121 The program's input comes from file INFILE (nil means `/dev/null').\n\
 122 Insert output in BUFFER before point; t means current buffer;\n\
 123  nil for BUFFER means discard it; 0 means discard and don't wait.\n\
 124 Fourth arg DISPLAY non-nil means redisplay buffer as output is inserted.\n\
 125 Remaining arguments are strings passed as command arguments to PROGRAM.\n\
 126 If BUFFER is 0, returns immediately with value nil.\n\
 127 Otherwise waits for PROGRAM to terminate\n\
 128 and returns a numeric exit status or a signal description string.\n\
 129 If you quit, the process is killed with SIGINT, or SIGKILL if you quit again.")
 130   (nargs, args)
 131      int nargs;
 132      register Lisp_Object *args;
 133 {
 134   Lisp_Object infile, buffer, current_dir, display, path;
 135   int fd[2];
 136   int filefd;
 137   register int pid;
 138   char buf[1024];
 139   int count = specpdl_ptr - specpdl;
 140   register unsigned char **new_argv
 141     = (unsigned char **) alloca ((max (2, nargs - 2)) * sizeof (char *));
 142   struct buffer *old = current_buffer;
 143 #if 0
 144   int mask;
 145 #endif
 146   CHECK_STRING (args[0], 0);
 147
 148   if (nargs >= 2 && ! NILP (args[1]))
 149     {
 150       infile = Fexpand_file_name (args[1], current_buffer->directory);
 151       CHECK_STRING (infile, 1);
 152     }
 153   else
 154     infile = build_string (NULL_DEVICE);
 155
 156   if (nargs >= 3)
 157     {
 158       register Lisp_Object tem;
 159
 160       buffer = tem = args[2];
 161       if (!(EQ (tem, Qnil)
 162             || EQ (tem, Qt)
 163             || XFASTINT (tem) == 0))
 164         {
 165           buffer = Fget_buffer (tem);
 166           CHECK_BUFFER (buffer, 2);
 167         }
 168     }
 169   else
 170     buffer = Qnil;
 171
 172   /* Make sure that the child will be able to chdir to the current
 173      buffer's current directory, or its unhandled equivalent.  We
 174      can't just have the child check for an error when it does the
 175      chdir, since it's in a vfork.
 176
 177      We have to GCPRO around this because Fexpand_file_name,
 178      Funhandled_file_name_directory, and Ffile_accessible_directory_p
 179      might call a file name handling function.  The argument list is
 180      protected by the caller, so all we really have to worry about is
 181      buffer.  */
 182   {
 183     struct gcpro gcpro1, gcpro2, gcpro3;
 184
 185     current_dir = current_buffer->directory;
 186
 187     GCPRO3 (infile, buffer, current_dir);
 188
 189     current_dir =
 190       expand_and_dir_to_file
 191         (Funhandled_file_name_directory (current_dir), Qnil);
 192     if (NILP (Ffile_accessible_directory_p (current_dir)))
 193       report_file_error ("Setting current directory",
 194                          Fcons (current_buffer->directory, Qnil));
 195
 196     UNGCPRO;
 197   }
 198
 199   display = nargs >= 4 ? args[3] : Qnil;
 200
 201   {
 202     register int i;
 203     for (i = 4; i < nargs; i++)
 204       {
 205         CHECK_STRING (args[i], i);
 206         new_argv[i - 3] = XSTRING (args[i])->data;
 207       }
 208     /* Program name is first command arg */
 209     new_argv[0] = XSTRING (args[0])->data;
 210     new_argv[i - 3] = 0;
 211   }
 212
 213   filefd = open (XSTRING (infile)->data, O_RDONLY, 0);
 214   if (filefd < 0)
 215     {
 216       report_file_error ("Opening process input file", Fcons (infile, Qnil));
 217     }
 218   /* Search for program; barf if not found.  */
 219   openp (Vexec_path, args[0], EXEC_SUFFIXES, &path, 1);
 220   if (NILP (path))
 221     {
 222       close (filefd);
 223       report_file_error ("Searching for program", Fcons (args[0], Qnil));
 224     }
 225   new_argv[0] = XSTRING (path)->data;
 226
 227   if (XTYPE (buffer) == Lisp_Int)
 228     fd[1] = open (NULL_DEVICE, O_WRONLY), fd[0] = -1;
 229   else
 230     {
 231       pipe (fd);
 232 #if 0
 233       /* Replaced by close_process_descs */
 234       set_exclusive_use (fd[0]);
 235 #endif
 236     }
 237
 238   {
 239     /* child_setup must clobber environ in systems with true vfork.
 240        Protect it from permanent change.  */
 241     register char **save_environ = environ;
 242     register int fd1 = fd[1];
 243
 244 #if 0  /* Some systems don't have sigblock.  */
 245     mask = sigblock (sigmask (SIGCHLD));
 246 #endif
 247
 248     /* Record that we're about to create a synchronous process.  */
 249     synch_process_alive = 1;
 250
 251     pid = vfork ();
 252
 253     if (pid == 0)
 254       {
 255         if (fd[0] >= 0)
 256           close (fd[0]);
 257 #ifdef USG
 258         setpgrp ();
 259 #else
 260         setpgrp (pid, pid);
 261 #endif /* USG */
 262         child_setup (filefd, fd1, fd1, new_argv, 0, current_dir);
 263       }
 264
 265 #if 0
 266     /* Tell SIGCHLD handler to look for this pid.  */
 267     synch_process_pid = pid;
 268     /* Now let SIGCHLD come through.  */
 269     sigsetmask (mask);
 270 #endif
 271
 272     environ = save_environ;
 273
 274     close (filefd);
 275     close (fd1);
 276   }
 277
 278   if (pid < 0)
 279     {
 280       close (fd[0]);
 281       report_file_error ("Doing vfork", Qnil);
 282     }
 283
 284   if (XTYPE (buffer) == Lisp_Int)
 285     {
 286 #ifndef subprocesses
 287       /* If Emacs has been built with asynchronous subprocess support,
 288          we don't need to do this, I think because it will then have
 289          the facilities for handling SIGCHLD.  */
 290       wait_without_blocking ();
 291 #endif /* subprocesses */
 292       return Qnil;
 293     }
 294
 295   synch_process_death = 0;
 296   synch_process_retcode = 0;
 297
 298   record_unwind_protect (call_process_cleanup,
 299                          Fcons (make_number (fd[0]), make_number (pid)));
 300
 301
 302   if (XTYPE (buffer) == Lisp_Buffer)
 303     Fset_buffer (buffer);
 304
 305   immediate_quit = 1;
 306   QUIT;
 307
 308   {
 309     register int nread;
 310
 311     while ((nread = read (fd[0], buf, sizeof buf)) > 0)
 312       {
 313         immediate_quit = 0;
 314         if (!NILP (buffer))
 315           insert (buf, nread);
 316         if (!NILP (display) && INTERACTIVE)
 317           redisplay_preserve_echo_area ();
 318         immediate_quit = 1;
 319         QUIT;
 320       }
 321   }
 322
 323   /* Wait for it to terminate, unless it already has.  */
 324   wait_for_termination (pid);
 325
 326   immediate_quit = 0;
 327
 328   set_buffer_internal (old);
 329
 330   unbind_to (count, Qnil);
 331
 332   if (synch_process_death)
 333     return build_string (synch_process_death);
 334   return make_number (synch_process_retcode);
 335 }
 336 #endif
 337 \f
 338 static Lisp_Object
 339 delete_temp_file (name)
 340      Lisp_Object name;
 341 {
 342   unlink (XSTRING (name)->data);
 343 }
 344
 345 DEFUN ("call-process-region", Fcall_process_region, Scall_process_region,
 346   3, MANY, 0,
 347   "Send text from START to END to a synchronous process running PROGRAM.\n\
 348 Delete the text if fourth arg DELETE is non-nil.\n\
 349 Insert output in BUFFER before point; t means current buffer;\n\
 350  nil for BUFFER means discard it; 0 means discard and don't wait.\n\
 351 Sixth arg DISPLAY non-nil means redisplay buffer as output is inserted.\n\
 352 Remaining args are passed to PROGRAM at startup as command args.\n\
 353 If BUFFER is nil, returns immediately with value nil.\n\
 354 Otherwise waits for PROGRAM to terminate\n\
 355 and returns a numeric exit status or a signal description string.\n\
 356 If you quit, the process is killed with SIGINT, or SIGKILL if you quit again.")
 357   (nargs, args)
 358      int nargs;
 359      register Lisp_Object *args;
 360 {
 361   register Lisp_Object filename_string, start, end;
 362   char tempfile[20];
 363   int count = specpdl_ptr - specpdl;
 364
 365 #ifdef VMS
 366   strcpy (tempfile, "tmp:emacsXXXXXX.");
 367 #else
 368   strcpy (tempfile, "/tmp/emacsXXXXXX");
 369 #endif
 370   mktemp (tempfile);
 371
 372   filename_string = build_string (tempfile);
 373   start = args[0];
 374   end = args[1];
 375   Fwrite_region (start, end, filename_string, Qnil, Qlambda);
 376   record_unwind_protect (delete_temp_file, filename_string);
 377
 378   if (!NILP (args[3]))
 379     Fdelete_region (start, end);
 380
 381   args[3] = filename_string;
 382
 383   return unbind_to (count, Fcall_process (nargs - 2, args + 2));
 384 }
 385 \f
 386 #ifndef VMS /* VMS version is in vmsproc.c.  */
 387
 388 /* This is the last thing run in a newly forked inferior
 389    either synchronous or asynchronous.
 390    Copy descriptors IN, OUT and ERR as descriptors 0, 1 and 2.
 391    Initialize inferior's priority, pgrp, connected dir and environment.
 392    then exec another program based on new_argv.
 393
 394    This function may change environ for the superior process.
 395    Therefore, the superior process must save and restore the value
 396    of environ around the vfork and the call to this function.
 397
 398    ENV is the environment for the subprocess.
 399
 400    SET_PGRP is nonzero if we should put the subprocess into a separate
 401    process group.
 402
 403    CURRENT_DIR is an elisp string giving the path of the current
 404    directory the subprocess should have.  Since we can't really signal
 405    a decent error from within the child, this should be verified as an
 406    executable directory by the parent.  */
 407
 408 child_setup (in, out, err, new_argv, set_pgrp, current_dir)
 409      int in, out, err;
 410      register char **new_argv;
 411      int set_pgrp;
 412      Lisp_Object current_dir;
 413 {
 414   char **env;
 415
 416   register int pid = getpid();
 417
 418   {
 419     extern int emacs_priority;
 420
 421     nice (- emacs_priority);
 422   }
 423
 424 #ifdef subprocesses
 425   /* Close Emacs's descriptors that this process should not have.  */
 426   close_process_descs ();
 427 #endif
 428
 429   /* Note that use of alloca is always safe here.  It's obvious for systems
 430      that do not have true vfork or that have true (stack) alloca.
 431      If using vfork and C_ALLOCA it is safe because that changes
 432      the superior's static variables as if the superior had done alloca
 433      and will be cleaned up in the usual way.  */
 434   {
 435     register unsigned char *temp;
 436     register int i;
 437
 438     i = XSTRING (current_dir)->size;
 439     temp = (unsigned char *) alloca (i + 2);
 440     bcopy (XSTRING (current_dir)->data, temp, i);
 441     if (temp[i - 1] != '/') temp[i++] = '/';
 442     temp[i] = 0;
 443
 444     /* We can't signal an Elisp error here; we're in a vfork.  Since
 445        the callers check the current directory before forking, this
 446        should only return an error if the directory's permissions
 447        are changed between the check and this chdir, but we should
 448        at least check.  */
 449     if (chdir (temp) < 0)
 450       exit (errno);
 451   }
 452
 453   /* Set `env' to a vector of the strings in Vprocess_environment.  */
 454   {
 455     register Lisp_Object tem;
 456     register char **new_env;
 457     register int new_length;
 458
 459     new_length = 0;
 460     for (tem = Vprocess_environment;
 461          (XTYPE (tem) == Lisp_Cons
 462           && XTYPE (XCONS (tem)->car) == Lisp_String);
 463          tem = XCONS (tem)->cdr)
 464       new_length++;
 465
 466     /* new_length + 1 to include terminating 0 */
 467     env = new_env = (char **) alloca ((new_length + 1) * sizeof (char *));
 468
 469     /* Copy the Vprocess_alist strings into new_env.  */
 470     for (tem = Vprocess_environment;
 471          (XTYPE (tem) == Lisp_Cons
 472           && XTYPE (XCONS (tem)->car) == Lisp_String);
 473          tem = XCONS (tem)->cdr)
 474       *new_env++ = (char *) XSTRING (XCONS (tem)->car)->data;
 475     *new_env = 0;
 476   }
 477
 478   /* Make sure that in, out, and err are not actually already in
 479      descriptors zero, one, or two; this could happen if Emacs is
 480      started with its standard in, our, or error closed, as might
 481      happen under X.  */
 482   in = relocate_fd (in, 3);
 483   out = relocate_fd (out, 3);
 484   err = relocate_fd (err, 3);
 485
 486   close (0);
 487   close (1);
 488   close (2);
 489
 490   dup2 (in, 0);
 491   dup2 (out, 1);
 492   dup2 (err, 2);
 493   close (in);
 494   close (out);
 495   close (err);
 496
 497 #ifdef USG
 498   setpgrp ();                   /* No arguments but equivalent in this case */
 499 #else
 500   setpgrp (pid, pid);
 501 #endif /* USG */
 502   setpgrp_of_tty (pid);
 503
 504 #ifdef vipc
 505   something missing here;
 506 #endif /* vipc */
 507
 508   /* execvp does not accept an environment arg so the only way
 509      to pass this environment is to set environ.  Our caller
 510      is responsible for restoring the ambient value of environ.  */
 511   environ = env;
 512   execvp (new_argv[0], new_argv);
 513
 514   write (1, "Couldn't exec the program ", 26);
 515   write (1, new_argv[0], strlen (new_argv[0]));
 516   _exit (1);
 517 }
 518
 519 /* Move the file descriptor FD so that its number is not less than MIN.
 520    If the file descriptor is moved at all, the original is freed.  */
 521 int
 522 relocate_fd (fd, min)
 523      int fd, min;
 524 {
 525   if (fd >= min)
 526     return fd;
 527   else
 528     {
 529       int new = dup (fd);
 530       if (new == -1)
 531         {
 532           char *message1 = "Error while setting up child: ";
 533           char *message2 = "\n";
 534           write (2, message1, strlen (message1));
 535           write (2, sys_errlist[errno], strlen (sys_errlist[errno]));
 536           write (2, message2, strlen (message2));
 537           _exit (1);
 538         }
 539       /* Note that we hold the original FD open while we recurse,
 540          to guarantee we'll get a new FD if we need it.  */
 541       new = relocate_fd (new, min);
 542       close (fd);
 543       return new;
 544     }
 545 }
 546
 547 static int
 548 getenv_internal (var, varlen, value, valuelen)
 549      char *var;
 550      int varlen;
 551      char **value;
 552      int *valuelen;
 553 {
 554   Lisp_Object scan;
 555
 556   for (scan = Vprocess_environment; CONSP (scan); scan = XCONS (scan)->cdr)
 557     {
 558       Lisp_Object entry = XCONS (scan)->car;
 559
 560       if (XTYPE (entry) == Lisp_String
 561           && XSTRING (entry)->size > varlen
 562           && XSTRING (entry)->data[varlen] == '='
 563           && ! bcmp (XSTRING (entry)->data, var, varlen))
 564         {
 565           *value    = (char *) XSTRING (entry)->data + (varlen + 1);
 566           *valuelen = XSTRING (entry)->size - (varlen + 1);
 567           return 1;
 568         }
 569     }
 570
 571   return 0;
 572 }
 573
 574 DEFUN ("getenv", Fgetenv, Sgetenv, 1, 2, 0,
 575   "Return the value of environment variable VAR, as a string.\n\
 576 VAR should be a string.  Value is nil if VAR is undefined in the environment.\n\
 577 This function consults the variable ``process-environment'' for its value.")
 578   (var)
 579      Lisp_Object var;
 580 {
 581   char *value;
 582   int valuelen;
 583
 584   CHECK_STRING (var, 0);
 585   if (getenv_internal (XSTRING (var)->data, XSTRING (var)->size,
 586                        &value, &valuelen))
 587     return make_string (value, valuelen);
 588   else
 589     return Qnil;
 590 }
 591
 592 /* A version of getenv that consults process_environment, easily
 593    callable from C.  */
 594 char *
 595 egetenv (var)
 596      char *var;
 597 {
 598   char *value;
 599   int valuelen;
 600
 601   if (getenv_internal (var, strlen (var), &value, &valuelen))
 602     return value;
 603   else
 604     return 0;
 605 }
 606
 607 #endif /* not VMS */
 608 \f
 609 init_callproc ()
 610 {
 611   register char * sh;
 612   Lisp_Object tempdir;
 613
 614   {
 615     char *data_dir = egetenv ("EMACSDATA");
 616
 617     Vdata_directory =
 618       Ffile_name_as_directory
 619         (build_string (data_dir ? data_dir : PATH_DATA));
 620   }
 621
 622   /* Check the EMACSPATH environment variable, defaulting to the
 623      PATH_EXEC path from paths.h.  */
 624   Vexec_path = decode_env_path ("EMACSPATH", PATH_EXEC);
 625   Vexec_directory = Ffile_name_as_directory (Fcar (Vexec_path));
 626   Vexec_path = nconc2 (decode_env_path ("PATH", ""), Vexec_path);
 627
 628   tempdir = Fdirectory_file_name (Vexec_directory);
 629   if (access (XSTRING (tempdir)->data, 0) < 0)
 630     {
 631       printf ("Warning: arch-dependent data dir (%s) does not exist.\n",
 632               XSTRING (Vexec_directory)->data);
 633       sleep (2);
 634     }
 635
 636   tempdir = Fdirectory_file_name (Vdata_directory);
 637   if (access (XSTRING (tempdir)->data, 0) < 0)
 638     {
 639       printf ("Warning: arch-independent data dir (%s) does not exist.\n",
 640               XSTRING (Vdata_directory)->data);
 641       sleep (2);
 642     }
 643
 644 #ifdef VMS
 645   Vshell_file_name = build_string ("*dcl*");
 646 #else
 647   sh = (char *) getenv ("SHELL");
 648   Vshell_file_name = build_string (sh ? sh : "/bin/sh");
 649 #endif
 650 }
 651
 652 set_process_environment ()
 653 {
 654   register char **envp;
 655
 656   Vprocess_environment = Qnil;
 657 #ifndef CANNOT_DUMP
 658   if (initialized)
 659 #endif
 660     for (envp = environ; *envp; envp++)
 661       Vprocess_environment = Fcons (build_string (*envp),
 662                                     Vprocess_environment);
 663 }
 664
 665 syms_of_callproc ()
 666 {
 667   DEFVAR_LISP ("shell-file-name", &Vshell_file_name,
 668     "*File name to load inferior shells from.\n\
 669 Initialized from the SHELL environment variable.");
 670
 671   DEFVAR_LISP ("exec-path", &Vexec_path,
 672     "*List of directories to search programs to run in subprocesses.\n\
 673 Each element is a string (directory name) or nil (try default directory).");
 674
 675   DEFVAR_LISP ("exec-directory", &Vexec_directory,
 676     "Directory of architecture-dependent files that come with GNU Emacs,\n\
 677 especially executable programs intended for Emacs to invoke.");
 678
 679   DEFVAR_LISP ("data-directory", &Vdata_directory,
 680     "Directory of architecture-independent files that come with GNU Emacs,\n\
 681 intended for Emacs to use.");
 682
 683   DEFVAR_LISP ("process-environment", &Vprocess_environment,
 684     "List of environment variables for subprocesses to inherit.\n\
 685 Each element should be a string of the form ENVVARNAME=VALUE.\n\
 686 The environment which Emacs inherits is placed in this variable\n\
 687 when Emacs starts.");
 688
 689 #ifndef VMS
 690   defsubr (&Scall_process);
 691   defsubr (&Sgetenv);
 692 #endif
 693   defsubr (&Scall_process_region);
 694 }