src/callproc.c

   1 /* Old synchronous subprocess invocation for XEmacs.
   2    Copyright (C) 1985, 86, 87, 88, 93, 94, 95 Free Software Foundation, Inc.
   3
   4 This file is part of XEmacs.
   5
   6 XEmacs is free software; you can redistribute it and/or modify it
   7 under the terms of the GNU General Public License as published by the
   8 Free Software Foundation; either version 2, or (at your option) any
   9 later version.
  10
  11 XEmacs is distributed in the hope that it will be useful, but WITHOUT
  12 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  13 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  14 for more details.
  15
  16 You should have received a copy of the GNU General Public License
  17 along with XEmacs; see the file COPYING.  If not, write to
  18 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  19 Boston, MA 02111-1307, USA.  */
  20
  21 /* Synched up with: Mule 2.0, FSF 19.30. */
  22 /* Partly sync'ed with 19.36.4 */
  23
  24
  25 /* #### This ENTIRE file is only used in batch mode.
  26
  27    We only need two things to get rid of both this and ntproc.c:
  28
  29    -- my `stderr-proc' ws, which adds support for a separate stderr
  30       in asynch. subprocesses. (it's a feature in `old-call-process-internal'.)
  31    -- a noninteractive event loop that supports processes.
  32 */
  33
  34 #include <config.h>
  35 #include "lisp.h"
  36
  37 #include "buffer.h"
  38 #include "commands.h"
  39 #include "insdel.h"
  40 #include "lstream.h"
  41 #include "process.h"
  42 #include "sysdep.h"
  43 #include "window.h"
  44 #ifdef FILE_CODING
  45 #include "file-coding.h"
  46 #endif
  47
  48 #include "systime.h"
  49 #include "sysproc.h"
  50 #include "sysdir.h"
  51 #include "sysfile.h" /* Always include after sysproc.h */
  52 #include "sysdir.h"
  53 #include "syssignal.h" /* Always include before systty.h */
  54 #include "systty.h"
  55
  56 #ifdef WIN32_NATIVE
  57 #define _P_NOWAIT 1     /* from process.h */
  58 #include "nt.h"
  59 #endif
  60
  61 #ifdef WIN32_NATIVE
  62 /* When we are starting external processes we need to know whether they
  63    take binary input (no conversion) or text input (\n is converted to
  64    \r\n).  Similarly for output: if newlines are written as \r\n then it's
  65    text process output, otherwise it's binary.  */
  66 Lisp_Object Vbinary_process_input;
  67 Lisp_Object Vbinary_process_output;
  68 #endif /* WIN32_NATIVE */
  69
  70 Lisp_Object Vshell_file_name;
  71
  72 /* The environment to pass to all subprocesses when they are started.
  73    This is in the semi-bogus format of ("VAR=VAL" "VAR2=VAL2" ... )
  74  */
  75 Lisp_Object Vprocess_environment;
  76
  77 /* True iff we are about to fork off a synchronous process or if we
  78    are waiting for it.  */
  79 volatile int synch_process_alive;
  80
  81 /* Nonzero => this is a string explaining death of synchronous subprocess.  */
  82 const char *synch_process_death;
  83
  84 /* If synch_process_death is zero,
  85    this is exit code of synchronous subprocess.  */
  86 int synch_process_retcode;
  87 \f
  88 /* Clean up when exiting Fcall_process_internal.
  89    On Windows, delete the temporary file on any kind of termination.
  90    On Unix, kill the process and any children on termination by signal.  */
  91
  92 /* Nonzero if this is termination due to exit.  */
  93 static int call_process_exited;
  94
  95 Lisp_Object Vlisp_EXEC_SUFFIXES;
  96
  97 static Lisp_Object
  98 call_process_kill (Lisp_Object fdpid)
  99 {
 100   Lisp_Object fd = Fcar (fdpid);
 101   Lisp_Object pid = Fcdr (fdpid);
 102
 103   if (!NILP (fd))
 104     close (XINT (fd));
 105
 106   if (!NILP (pid))
 107     EMACS_KILLPG (XINT (pid), SIGKILL);
 108
 109   synch_process_alive = 0;
 110   return Qnil;
 111 }
 112
 113 static Lisp_Object
 114 call_process_cleanup (Lisp_Object fdpid)
 115 {
 116   int fd  = XINT (Fcar (fdpid));
 117   int pid = XINT (Fcdr (fdpid));
 118
 119   if (!call_process_exited &&
 120       EMACS_KILLPG (pid, SIGINT) == 0)
 121   {
 122     int speccount = specpdl_depth ();
 123
 124     record_unwind_protect (call_process_kill, fdpid);
 125     /* #### "c-G" -- need non-consing Single-key-description */
 126     message ("Waiting for process to die...(type C-g again to kill it instantly)");
 127
 128 #ifdef WIN32_NATIVE
 129     {
 130       HANDLE pHandle = OpenProcess (PROCESS_ALL_ACCESS, 0, pid);
 131       if (pHandle == NULL)
 132         warn_when_safe (Qprocess, Qwarning,
 133                         "cannot open process (PID %d) for cleanup", pid);
 134       else
 135         wait_for_termination (pHandle);
 136     }
 137 #else
 138     wait_for_termination (pid);
 139 #endif
 140
 141     /* "Discard" the unwind protect.  */
 142     XCAR (fdpid) = Qnil;
 143     XCDR (fdpid) = Qnil;
 144     unbind_to (speccount, Qnil);
 145
 146     message ("Waiting for process to die... done");
 147   }
 148   synch_process_alive = 0;
 149   close (fd);
 150   return Qnil;
 151 }
 152
 153 static Lisp_Object fork_error;
 154 #if 0 /* UNUSED */
 155 static void
 156 report_fork_error (char *string, Lisp_Object data)
 157 {
 158   Lisp_Object errstring = lisp_strerror (errno);
 159
 160   fork_error = Fcons (build_string (string), Fcons (errstring, data));
 161
 162   /* terminate this branch of the fork, without closing stdin/out/etc. */
 163   _exit (1);
 164 }
 165 #endif /* unused */
 166
 167 DEFUN ("old-call-process-internal", Fold_call_process_internal, 1, MANY, 0, /*
 168 Call PROGRAM synchronously in separate process, with coding-system specified.
 169 Arguments are
 170  (PROGRAM &optional INFILE BUFFER DISPLAY &rest ARGS).
 171 The program's input comes from file INFILE (nil means `/dev/null').
 172 Insert output in BUFFER before point; t means current buffer;
 173  nil for BUFFER means discard it; 0 means discard and don't wait.
 174 If BUFFER is a string, then find or create a buffer with that name,
 175 then insert the output in that buffer, before point.
 176 BUFFER can also have the form (REAL-BUFFER STDERR-FILE); in that case,
 177 REAL-BUFFER says what to do with standard output, as above,
 178 while STDERR-FILE says what to do with standard error in the child.
 179 STDERR-FILE may be nil (discard standard error output),
 180 t (mix it with ordinary output), or a file name string.
 181
 182 Fourth arg DISPLAY non-nil means redisplay buffer as output is inserted.
 183 Remaining arguments are strings passed as command arguments to PROGRAM.
 184
 185 If BUFFER is 0, `call-process' returns immediately with value nil.
 186 Otherwise it waits for PROGRAM to terminate and returns a numeric exit status
 187  or a signal description string.
 188 If you quit, the process is killed with SIGINT, or SIGKILL if you
 189  quit again.
 190 */
 191        (int nargs, Lisp_Object *args))
 192 {
 193   /* This function can GC */
 194   Lisp_Object infile, buffer, current_dir, display, path;
 195   int fd[2];
 196   int filefd;
 197 #ifdef WIN32_NATIVE
 198   HANDLE pHandle;
 199 #endif
 200   int pid;
 201   char buf[16384];
 202   char *bufptr = buf;
 203   int bufsize = 16384;
 204   int speccount = specpdl_depth ();
 205   struct gcpro gcpro1, gcpro2, gcpro3;
 206   char **new_argv = alloca_array (char *, max (2, nargs - 2));
 207
 208   /* File to use for stderr in the child.
 209      t means use same as standard output.  */
 210   Lisp_Object error_file;
 211
 212   CHECK_STRING (args[0]);
 213
 214   error_file = Qt;
 215
 216 #if defined (NO_SUBPROCESSES)
 217   /* Without asynchronous processes we cannot have BUFFER == 0.  */
 218   if (nargs >= 3 && !INTP (args[2]))
 219     error ("Operating system cannot handle asynchronous subprocesses");
 220 #endif /* NO_SUBPROCESSES */
 221
 222   /* Do this before building new_argv because GC in Lisp code
 223    *  called by various filename-hacking routines might relocate strings */
 224   locate_file (Vexec_path, args[0], Vlisp_EXEC_SUFFIXES, &path, X_OK);
 225
 226   /* Make sure that the child will be able to chdir to the current
 227      buffer's current directory, or its unhandled equivalent.  We
 228      can't just have the child check for an error when it does the
 229      chdir, since it's in a vfork. */
 230   {
 231     struct gcpro ngcpro1, ngcpro2;
 232     /* Do this test before building new_argv because GC in Lisp code
 233      *  called by various filename-hacking routines might relocate strings */
 234     /* Make sure that the child will be able to chdir to the current
 235        buffer's current directory.  We can't just have the child check
 236        for an error when it does the chdir, since it's in a vfork.  */
 237
 238     current_dir = current_buffer->directory;
 239     NGCPRO2 (current_dir, path);   /* Caller gcprotects args[] */
 240     current_dir = Funhandled_file_name_directory (current_dir);
 241     current_dir = expand_and_dir_to_file (current_dir, Qnil);
 242 #if 0
 243     /* This is in FSF, but it breaks everything in the presence of
 244        ange-ftp-visited files, so away with it.  */
 245     if (NILP (Ffile_accessible_directory_p (current_dir)))
 246       report_file_error ("Setting current directory",
 247                          Fcons (current_buffer->directory, Qnil));
 248 #endif /* 0 */
 249     NUNGCPRO;
 250   }
 251
 252   GCPRO2 (current_dir, path);
 253
 254   if (nargs >= 2 && ! NILP (args[1]))
 255     {
 256       struct gcpro ngcpro1;
 257       NGCPRO1 (current_buffer->directory);
 258       infile = Fexpand_file_name (args[1], current_buffer->directory);
 259       NUNGCPRO;
 260       CHECK_STRING (infile);
 261     }
 262   else
 263     infile = build_string (NULL_DEVICE);
 264
 265   UNGCPRO;
 266
 267   GCPRO3 (infile, current_dir, path);   /* Fexpand_file_name might trash it */
 268
 269   if (nargs >= 3)
 270     {
 271       buffer = args[2];
 272
 273       /* If BUFFER is a list, its meaning is
 274          (BUFFER-FOR-STDOUT FILE-FOR-STDERR).  */
 275       if (CONSP (buffer))
 276         {
 277           if (CONSP (XCDR (buffer)))
 278             {
 279               Lisp_Object file_for_stderr = XCAR (XCDR (buffer));
 280
 281               if (NILP (file_for_stderr) || EQ (Qt, file_for_stderr))
 282                 error_file = file_for_stderr;
 283               else
 284                 error_file = Fexpand_file_name (file_for_stderr, Qnil);
 285             }
 286
 287           buffer = XCAR (buffer);
 288         }
 289
 290       if (!(EQ (buffer, Qnil)
 291             || EQ (buffer, Qt)
 292             || ZEROP (buffer)))
 293         {
 294           Lisp_Object spec_buffer = buffer;
 295           buffer = Fget_buffer_create (buffer);
 296           /* Mention the buffer name for a better error message.  */
 297           if (NILP (buffer))
 298             CHECK_BUFFER (spec_buffer);
 299           CHECK_BUFFER (buffer);
 300         }
 301     }
 302   else
 303     buffer = Qnil;
 304
 305   UNGCPRO;
 306
 307   display = ((nargs >= 4) ? args[3] : Qnil);
 308
 309   /* From here we assume we won't GC (unless an error is signaled). */
 310   {
 311     REGISTER int i;
 312     for (i = 4; i < nargs; i++)
 313       {
 314         CHECK_STRING (args[i]);
 315         new_argv[i - 3] = (char *) XSTRING_DATA (args[i]);
 316       }
 317   }
 318   new_argv[max(nargs - 3,1)] = 0;
 319
 320   if (NILP (path))
 321     report_file_error ("Searching for program", Fcons (args[0], Qnil));
 322   new_argv[0] = (char *) XSTRING_DATA (path);
 323
 324   filefd = open ((char *) XSTRING_DATA (infile), O_RDONLY | OPEN_BINARY, 0);
 325   if (filefd < 0)
 326     report_file_error ("Opening process input file", Fcons (infile, Qnil));
 327
 328   if (INTP (buffer))
 329     {
 330       fd[1] = open (NULL_DEVICE, O_WRONLY | OPEN_BINARY, 0);
 331       fd[0] = -1;
 332     }
 333   else
 334     {
 335       pipe (fd);
 336 #if 0
 337       /* Replaced by close_process_descs */
 338       set_exclusive_use (fd[0]);
 339 #endif
 340     }
 341
 342   {
 343     /* child_setup must clobber environ in systems with true vfork.
 344        Protect it from permanent change.  */
 345     REGISTER char **save_environ = environ;
 346     REGISTER int fd1 = fd[1];
 347     int fd_error = fd1;
 348
 349     /* Record that we're about to create a synchronous process.  */
 350     synch_process_alive = 1;
 351
 352     /* These vars record information from process termination.
 353        Clear them now before process can possibly terminate,
 354        to avoid timing error if process terminates soon.  */
 355     synch_process_death = 0;
 356     synch_process_retcode = 0;
 357
 358     if (NILP (error_file))
 359       fd_error = open (NULL_DEVICE, O_WRONLY | OPEN_BINARY);
 360     else if (STRINGP (error_file))
 361       {
 362         fd_error = open ((const char *) XSTRING_DATA (error_file),
 363 #ifdef WIN32_NATIVE
 364                          O_WRONLY | O_TRUNC | O_CREAT | O_TEXT,
 365                          S_IREAD | S_IWRITE
 366 #else  /* not WIN32_NATIVE */
 367                          O_WRONLY | O_TRUNC | O_CREAT | OPEN_BINARY,
 368                          CREAT_MODE
 369 #endif /* not WIN32_NATIVE */
 370                          );
 371       }
 372
 373     if (fd_error < 0)
 374       {
 375         int save_errno = errno;
 376         close (filefd);
 377         close (fd[0]);
 378         if (fd1 >= 0)
 379           close (fd1);
 380         errno = save_errno;
 381         report_file_error ("Cannot open", Fcons(error_file, Qnil));
 382       }
 383
 384     fork_error = Qnil;
 385 #ifdef WIN32_NATIVE
 386     pid = child_setup (filefd, fd1, fd_error, new_argv,
 387                        (char *) XSTRING_DATA (current_dir));
 388     if (!INTP (buffer))
 389       {
 390         /* OpenProcess() as soon after child_setup as possible.  It's too
 391            late once the process terminated. */
 392         pHandle = OpenProcess(PROCESS_ALL_ACCESS, 0, pid);
 393 #if 0
 394         if (pHandle == NULL)
 395           {
 396             /* #### seems to cause crash in unbind_to(...) below. APA */
 397             warn_when_safe (Qprocess, Qwarning,
 398                             "cannot open process to wait for");
 399           }
 400 #endif
 401       }
 402 #else  /* not WIN32_NATIVE */
 403     pid = fork ();
 404
 405     if (pid == 0)
 406       {
 407         if (fd[0] >= 0)
 408           close (fd[0]);
 409         /* This is necessary because some shells may attempt to
 410            access the current controlling terminal and will hang
 411            if they are run in the background, as will be the case
 412            when XEmacs is started in the background.  Martin
 413            Buchholz observed this problem running a subprocess
 414            that used zsh to call gzip to uncompress an info
 415            file. */
 416         disconnect_controlling_terminal ();
 417         child_setup (filefd, fd1, fd_error, new_argv,
 418                      (char *) XSTRING_DATA (current_dir));
 419       }
 420 #endif /* not WIN32_NATIVE */
 421
 422     environ = save_environ;
 423
 424     /* Close STDERR into the parent process.  We no longer need it. */
 425     if (fd_error >= 0)
 426       close (fd_error);
 427
 428     /* Close most of our fd's, but not fd[0]
 429        since we will use that to read input from.  */
 430     close (filefd);
 431     if ((fd1 >= 0) && (fd1 != fd_error))
 432       close (fd1);
 433   }
 434
 435   if (!NILP (fork_error))
 436     signal_error (Qfile_error, fork_error);
 437
 438 #ifndef WIN32_NATIVE
 439   if (pid < 0)
 440     {
 441       int save_errno = errno;
 442       if (fd[0] >= 0)
 443         close (fd[0]);
 444       errno = save_errno;
 445       report_file_error ("Doing fork", Qnil);
 446     }
 447 #endif
 448
 449   if (INTP (buffer))
 450     {
 451       if (fd[0] >= 0)
 452         close (fd[0]);
 453 #if defined (NO_SUBPROCESSES)
 454       /* If Emacs has been built with asynchronous subprocess support,
 455          we don't need to do this, I think because it will then have
 456          the facilities for handling SIGCHLD.  */
 457       wait_without_blocking ();
 458 #endif /* NO_SUBPROCESSES */
 459       return Qnil;
 460     }
 461
 462   {
 463     int nread;
 464     int total_read = 0;
 465     Lisp_Object instream;
 466     struct gcpro ngcpro1;
 467
 468     /* Enable sending signal if user quits below.  */
 469     call_process_exited = 0;
 470
 471     record_unwind_protect (call_process_cleanup,
 472                            Fcons (make_int (fd[0]), make_int (pid)));
 473
 474     /* FSFmacs calls Fset_buffer() here.  We don't have to because
 475        we can insert into buffers other than the current one. */
 476     if (EQ (buffer, Qt))
 477       XSETBUFFER (buffer, current_buffer);
 478     instream = make_filedesc_input_stream (fd[0], 0, -1, LSTR_ALLOW_QUIT);
 479 #ifdef FILE_CODING
 480     instream =
 481       make_decoding_input_stream
 482         (XLSTREAM (instream),
 483          Fget_coding_system (Vcoding_system_for_read));
 484     Lstream_set_character_mode (XLSTREAM (instream));
 485 #endif
 486     NGCPRO1 (instream);
 487     while (1)
 488       {
 489         QUIT;
 490         /* Repeatedly read until we've filled as much as possible
 491            of the buffer size we have.  But don't read
 492            less than 1024--save that for the next bufferfull.  */
 493
 494         nread = 0;
 495         while (nread < bufsize - 1024)
 496           {
 497             Lstream_data_count this_read
 498               = Lstream_read (XLSTREAM (instream), bufptr + nread,
 499                               bufsize - nread);
 500
 501             if (this_read < 0)
 502               goto give_up;
 503
 504             if (this_read == 0)
 505               goto give_up_1;
 506
 507             nread += this_read;
 508           }
 509
 510       give_up_1:
 511
 512         /* Now NREAD is the total amount of data in the buffer.  */
 513         if (nread == 0)
 514           break;
 515
 516 #if 0
 517 #ifdef WIN32_NATIVE
 518        /* Until we pull out of MULE things like
 519           make_decoding_input_stream(), we do the following which is
 520           less elegant. --marcpa */
 521         /* We did. -- kkm */
 522        {
 523          int lf_count = 0;
 524          if (NILP (Vbinary_process_output)) {
 525            nread = crlf_to_lf(nread, bufptr, &lf_count);
 526          }
 527        }
 528 #endif
 529 #endif
 530
 531         total_read += nread;
 532
 533         if (!NILP (buffer))
 534           buffer_insert_raw_string (XBUFFER (buffer), (Bufbyte *) bufptr,
 535                                     nread);
 536
 537         /* Make the buffer bigger as we continue to read more data,
 538            but not past 64k.  */
 539         if (bufsize < 64 * 1024 && total_read > 32 * bufsize)
 540           {
 541             bufsize *= 2;
 542             bufptr = (char *) alloca (bufsize);
 543           }
 544
 545         if (!NILP (display) && INTERACTIVE)
 546           {
 547             redisplay ();
 548           }
 549       }
 550   give_up:
 551     Lstream_close (XLSTREAM (instream));
 552     NUNGCPRO;
 553
 554     QUIT;
 555     /* Wait for it to terminate, unless it already has.  */
 556 #ifdef WIN32_NATIVE
 557     wait_for_termination (pHandle);
 558 #else
 559     wait_for_termination (pid);
 560 #endif
 561
 562     /* Don't kill any children that the subprocess may have left behind
 563        when exiting.  */
 564     call_process_exited = 1;
 565     unbind_to (speccount, Qnil);
 566
 567     if (synch_process_death)
 568       return build_string (synch_process_death);
 569     return make_int (synch_process_retcode);
 570   }
 571 }
 572
 573 \f
 574
 575 /* Move the file descriptor FD so that its number is not less than MIN. *
 576    The original file descriptor remains open.  */
 577 static int
 578 relocate_fd (int fd, int min)
 579 {
 580   if (fd >= min)
 581     return fd;
 582   else
 583     {
 584       int newfd = dup (fd);
 585       if (newfd == -1)
 586         {
 587           stderr_out ("Error while setting up child: %s\n",
 588                       strerror (errno));
 589           _exit (1);
 590         }
 591       return relocate_fd (newfd, min);
 592     }
 593 }
 594
 595 /* This is the last thing run in a newly forked inferior
 596    either synchronous or asynchronous.
 597    Copy descriptors IN, OUT and ERR
 598    as descriptors STDIN_FILENO, STDOUT_FILENO, and STDERR_FILENO.
 599    Initialize inferior's priority, pgrp, connected dir and environment.
 600    then exec another program based on new_argv.
 601
 602    This function may change environ for the superior process.
 603    Therefore, the superior process must save and restore the value
 604    of environ around the fork and the call to this function.
 605
 606    ENV is the environment for the subprocess.
 607
 608    XEmacs: We've removed the SET_PGRP argument because it's already
 609    done by the callers of child_setup.
 610
 611    CURRENT_DIR is an elisp string giving the path of the current
 612    directory the subprocess should have.  Since we can't really signal
 613    a decent error from within the child, this should be verified as an
 614    executable directory by the parent.  */
 615
 616 #ifdef WIN32_NATIVE
 617 int
 618 #else
 619 void
 620 #endif
 621 child_setup (int in, int out, int err, char **new_argv,
 622              const char *current_dir)
 623 {
 624   char **env;
 625   char *pwd;
 626 #ifdef WIN32_NATIVE
 627   int cpid;
 628   HANDLE handles[4];
 629 #endif /* WIN32_NATIVE */
 630
 631 #ifdef SET_EMACS_PRIORITY
 632   if (emacs_priority != 0)
 633     nice (- emacs_priority);
 634 #endif
 635
 636   /* Under Windows, we are not in a child process at all, so we should
 637      not close handles inherited from the parent -- we are the parent
 638      and doing so will screw up all manner of things!  Similarly, most
 639      of the rest of the cleanup done in this function is not done
 640      under Windows.
 641
 642      #### This entire child_setup() function is an utter and complete
 643      piece of shit.  I would rewrite it, at the very least splitting
 644      out the Windows and non-Windows stuff into two completely
 645      different functions; but instead I'm trying to make it go away
 646      entirely, using the Lisp definition in process.el.  What's left
 647      is to fix up the routines in event-msw.c (and in event-Xt.c and
 648      event-tty.c) to allow for stream devices to be handled correctly.
 649      There isn't much to do, in fact, and I'll fix it shortly.  That
 650      way, the Lisp definition can be used non-interactively too. */
 651 #if !defined (NO_SUBPROCESSES) && !defined (WIN32_NATIVE)
 652   /* Close Emacs's descriptors that this process should not have.  */
 653   close_process_descs ();
 654 #endif /* not NO_SUBPROCESSES */
 655 #ifndef WIN32_NATIVE
 656   close_load_descs ();
 657 #endif
 658
 659   /* Note that use of alloca is always safe here.  It's obvious for systems
 660      that do not have true vfork or that have true (stack) alloca.
 661      If using vfork and C_ALLOCA it is safe because that changes
 662      the superior's static variables as if the superior had done alloca
 663      and will be cleaned up in the usual way.  */
 664   {
 665     REGISTER int i;
 666
 667     i = strlen (current_dir);
 668     pwd = alloca_array (char, i + 6);
 669     memcpy (pwd, "PWD=", 4);
 670     memcpy (pwd + 4, current_dir, i);
 671     i += 4;
 672     if (!IS_DIRECTORY_SEP (pwd[i - 1]))
 673       pwd[i++] = DIRECTORY_SEP;
 674     pwd[i] = 0;
 675
 676     /* We can't signal an Elisp error here; we're in a vfork.  Since
 677        the callers check the current directory before forking, this
 678        should only return an error if the directory's permissions
 679        are changed between the check and this chdir, but we should
 680        at least check.  */
 681     if (chdir (pwd + 4) < 0)
 682       {
 683         /* Don't report the chdir error, or ange-ftp.el doesn't work. */
 684         /* (FSFmacs does _exit (errno) here.) */
 685         pwd = 0;
 686       }
 687     else
 688       {
 689         /* Strip trailing "/".  Cretinous *[]&@$#^%@#$% Un*x */
 690         /* leave "//" (from FSF) */
 691         while (i > 6 && IS_DIRECTORY_SEP (pwd[i - 1]))
 692           pwd[--i] = 0;
 693       }
 694   }
 695
 696   /* Set `env' to a vector of the strings in Vprocess_environment.  */
 697   /* + 2 to include PWD and terminating 0.  */
 698   env = alloca_array (char *, XINT (Flength (Vprocess_environment)) + 2);
 699   {
 700     REGISTER Lisp_Object tail;
 701     char **new_env = env;
 702
 703     /* If we have a PWD envvar and we know the real current directory,
 704        pass one down, but with corrected value.  */
 705     if (pwd && getenv ("PWD"))
 706       *new_env++ = pwd;
 707
 708     /* Copy the Vprocess_environment strings into new_env.  */
 709     for (tail = Vprocess_environment;
 710          CONSP (tail) && STRINGP (XCAR (tail));
 711          tail = XCDR (tail))
 712     {
 713       char **ep = env;
 714       char *envvar_external;
 715
 716       TO_EXTERNAL_FORMAT (LISP_STRING, XCAR (tail),
 717                           C_STRING_ALLOCA, envvar_external,
 718                           Qfile_name);
 719
 720       /* See if envvar_external duplicates any string already in the env.
 721          If so, don't put it in.
 722          When an env var has multiple definitions,
 723          we keep the definition that comes first in process-environment.  */
 724       for (; ep != new_env; ep++)
 725         {
 726           char *p = *ep, *q = envvar_external;
 727           while (1)
 728             {
 729               if (*q == 0)
 730                 /* The string is malformed; might as well drop it.  */
 731                 goto duplicate;
 732               if (*q != *p)
 733                 break;
 734               if (*q == '=')
 735                 goto duplicate;
 736               p++, q++;
 737             }
 738         }
 739       if (pwd && !strncmp ("PWD=", envvar_external, 4))
 740         {
 741           *new_env++ = pwd;
 742           pwd = 0;
 743         }
 744       else
 745         *new_env++ = envvar_external;
 746
 747     duplicate: ;
 748     }
 749     *new_env = 0;
 750   }
 751
 752 #ifdef WIN32_NATIVE
 753   prepare_standard_handles (in, out, err, handles);
 754   set_process_dir (current_dir);
 755 #else  /* not WIN32_NATIVE */
 756   /* Make sure that in, out, and err are not actually already in
 757      descriptors zero, one, or two; this could happen if Emacs is
 758      started with its standard in, out, or error closed, as might
 759      happen under X.  */
 760   in  = relocate_fd (in,  3);
 761   out = relocate_fd (out, 3);
 762   err = relocate_fd (err, 3);
 763
 764   /* Set the standard input/output channels of the new process.  */
 765   close (STDIN_FILENO);
 766   close (STDOUT_FILENO);
 767   close (STDERR_FILENO);
 768
 769   dup2 (in,  STDIN_FILENO);
 770   dup2 (out, STDOUT_FILENO);
 771   dup2 (err, STDERR_FILENO);
 772
 773   close (in);
 774   close (out);
 775   close (err);
 776
 777   /* Close non-process-related file descriptors. It would be cleaner to
 778      close just the ones that need to be, but the following brute
 779      force approach is certainly effective, and not too slow. */
 780
 781   {
 782     int fd;
 783
 784     for (fd = 3; fd < MAXDESC; fd++)
 785       close (fd);
 786   }
 787 #endif /* not WIN32_NATIVE */
 788
 789 #ifdef vipc
 790   something missing here;
 791 #endif /* vipc */
 792
 793 #ifdef WIN32_NATIVE
 794   /* Spawn the child.  (See ntproc.c:Spawnve).  */
 795   cpid = spawnve (_P_NOWAIT, new_argv[0], (const char* const*)new_argv,
 796                   (const char* const*)env);
 797   if (cpid == -1)
 798     /* An error occurred while trying to spawn the process.  */
 799     report_file_error ("Spawning child process", Qnil);
 800   reset_standard_handles (in, out, err, handles);
 801   return cpid;
 802 #else /* not WIN32_NATIVE */
 803   /* execvp does not accept an environment arg so the only way
 804      to pass this environment is to set environ.  Our caller
 805      is responsible for restoring the ambient value of environ.  */
 806   environ = env;
 807   execvp (new_argv[0], new_argv);
 808
 809   stdout_out ("Can't exec program %s\n", new_argv[0]);
 810   _exit (1);
 811 #endif /* not WIN32_NATIVE */
 812 }
 813
 814 static int
 815 getenv_internal (const Bufbyte *var,
 816                  Bytecount varlen,
 817                  Bufbyte **value,
 818                  Bytecount *valuelen)
 819 {
 820   Lisp_Object scan;
 821
 822   for (scan = Vprocess_environment; CONSP (scan); scan = XCDR (scan))
 823     {
 824       Lisp_Object entry = XCAR (scan);
 825
 826       if (STRINGP (entry)
 827           && XSTRING_LENGTH (entry) > varlen
 828           && XSTRING_BYTE (entry, varlen) == '='
 829 #ifdef WIN32_NATIVE
 830           /* NT environment variables are case insensitive.  */
 831           && ! memicmp (XSTRING_DATA (entry), var, varlen)
 832 #else  /* not WIN32_NATIVE */
 833           && ! memcmp (XSTRING_DATA (entry), var, varlen)
 834 #endif /* not WIN32_NATIVE */
 835           )
 836         {
 837           *value    = XSTRING_DATA   (entry) + (varlen + 1);
 838           *valuelen = XSTRING_LENGTH (entry) - (varlen + 1);
 839           return 1;
 840         }
 841     }
 842
 843   return 0;
 844 }
 845
 846 DEFUN ("getenv", Fgetenv, 1, 2, "sEnvironment variable: \np", /*
 847 Return the value of environment variable VAR, as a string.
 848 VAR is a string, the name of the variable.
 849 When invoked interactively, prints the value in the echo area.
 850 */
 851        (var, interactivep))
 852 {
 853   Bufbyte *value;
 854   Bytecount valuelen;
 855   Lisp_Object v = Qnil;
 856   struct gcpro gcpro1;
 857
 858   CHECK_STRING (var);
 859   GCPRO1 (v);
 860   if (getenv_internal (XSTRING_DATA (var), XSTRING_LENGTH (var),
 861                        &value, &valuelen))
 862     v = make_string (value, valuelen);
 863   if (!NILP (interactivep))
 864     {
 865       if (NILP (v))
 866         message ("%s not defined in environment", XSTRING_DATA (var));
 867       else
 868         /* #### Should use Fprin1_to_string or Fprin1 to handle string
 869            containing quotes correctly.  */
 870         message ("\"%s\"", value);
 871     }
 872   RETURN_UNGCPRO (v);
 873 }
 874
 875 /* A version of getenv that consults process_environment, easily
 876    callable from C.  */
 877 char *
 878 egetenv (const char *var)
 879 {
 880   /* This cannot GC -- 7-28-00 ben */
 881   Bufbyte *value;
 882   Bytecount valuelen;
 883
 884   if (getenv_internal ((const Bufbyte *) var, strlen (var), &value, &valuelen))
 885     return (char *) value;
 886   else
 887     return 0;
 888 }
 889
 890 \f
 891 void
 892 init_callproc (void)
 893 {
 894   /* This function can GC */
 895
 896   {
 897     /* jwz: always initialize Vprocess_environment, so that egetenv()
 898        works in temacs. */
 899     char **envp;
 900     Vprocess_environment = Qnil;
 901     for (envp = environ; envp && *envp; envp++)
 902       Vprocess_environment =
 903         Fcons (build_ext_string (*envp, Qfile_name), Vprocess_environment);
 904   }
 905
 906   {
 907     /* Initialize shell-file-name from environment variables or best guess. */
 908 #ifdef WIN32_NATIVE
 909     const char *shell = egetenv ("SHELL");
 910     if (!shell) shell = egetenv ("COMSPEC");
 911     /* Should never happen! */
 912     if (!shell) shell = (GetVersion () & 0x80000000 ? "command" : "cmd");
 913 #else /* not WIN32_NATIVE */
 914     const char *shell = egetenv ("SHELL");
 915     if (!shell) shell = "/bin/sh";
 916 #endif
 917
 918 #if 0 /* defined (WIN32_NATIVE) */
 919     /* BAD BAD BAD.  We do not wanting to be passing an XEmacs-created
 920        SHELL var down to some inferior Cygwin process, which might get
 921        screwed up.
 922
 923        There are a few broken apps (eterm/term.el, eterm/tshell.el,
 924        os-utils/terminal.el, texinfo/tex-mode.el) where this will
 925        cause problems.  Those broken apps don't look at
 926        shell-file-name, instead just at explicit-shell-file-name,
 927        ESHELL and SHELL.  They are apparently attempting to borrow
 928        what `M-x shell' uses, but that latter also looks at
 929        shell-file-name.  What we want is for all of these apps to look
 930        at shell-file-name, so that the user can change the value of
 931        shell-file-name and everything will work out hunky-dorey.
 932        */
 933
 934     if (!egetenv ("SHELL"))
 935       {
 936         CBufbyte *faux_var = alloca_array (CBufbyte, 7 + strlen (shell));
 937         sprintf (faux_var, "SHELL=%s", shell);
 938         Vprocess_environment = Fcons (build_string (faux_var),
 939                                       Vprocess_environment);
 940       }
 941 #endif /* 0 */
 942
 943     Vshell_file_name = build_string (shell);
 944   }
 945 }
 946
 947 #if 0
 948 void
 949 set_process_environment (void)
 950 {
 951   REGISTER char **envp;
 952
 953   Vprocess_environment = Qnil;
 954 #ifndef CANNOT_DUMP
 955   if (initialized)
 956 #endif
 957     for (envp = environ; *envp; envp++)
 958       Vprocess_environment = Fcons (build_string (*envp),
 959                                     Vprocess_environment);
 960 }
 961 #endif /* unused */
 962
 963 void
 964 syms_of_callproc (void)
 965 {
 966   DEFSUBR (Fold_call_process_internal);
 967   DEFSUBR (Fgetenv);
 968 }
 969
 970 void
 971 vars_of_callproc (void)
 972 {
 973   /* This function can GC */
 974 #ifdef WIN32_NATIVE
 975   DEFVAR_LISP ("binary-process-input", &Vbinary_process_input /*
 976 *If non-nil then new subprocesses are assumed to take binary input.
 977 */ );
 978   Vbinary_process_input = Qnil;
 979
 980   DEFVAR_LISP ("binary-process-output", &Vbinary_process_output /*
 981 *If non-nil then new subprocesses are assumed to produce binary output.
 982 */ );
 983   Vbinary_process_output = Qnil;
 984 #endif /* WIN32_NATIVE */
 985
 986   DEFVAR_LISP ("shell-file-name", &Vshell_file_name /*
 987 *File name to load inferior shells from.
 988 Initialized from the SHELL environment variable.
 989 */ );
 990
 991   DEFVAR_LISP ("process-environment", &Vprocess_environment /*
 992 List of environment variables for subprocesses to inherit.
 993 Each element should be a string of the form ENVVARNAME=VALUE.
 994 The environment which Emacs inherits is placed in this variable
 995 when Emacs starts.
 996 */ );
 997
 998   Vlisp_EXEC_SUFFIXES = build_string (EXEC_SUFFIXES);
 999   staticpro (&Vlisp_EXEC_SUFFIXES);
1000 }