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