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