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