update.
[chise/xemacs-chise.git-] / 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     /* Close STDERR into the parent process.  We no longer need it. */
403     if (fd_error >= 0)
404       close (fd_error);
405 #else  /* not WIN32_NATIVE */
406     pid = fork ();
407
408     if (pid == 0)
409       {
410         if (fd[0] >= 0)
411           close (fd[0]);
412         /* This is necessary because some shells may attempt to
413            access the current controlling terminal and will hang
414            if they are run in the background, as will be the case
415            when XEmacs is started in the background.  Martin
416            Buchholz observed this problem running a subprocess
417            that used zsh to call gzip to uncompress an info
418            file. */
419         disconnect_controlling_terminal ();
420         child_setup (filefd, fd1, fd_error, new_argv,
421                      (char *) XSTRING_DATA (current_dir));
422       }
423     if (fd_error >= 0)
424       close (fd_error);
425
426 #endif /* not WIN32_NATIVE */
427
428     environ = save_environ;
429
430     /* Close most of our fd's, but not fd[0]
431        since we will use that to read input from.  */
432     close (filefd);
433     if (fd1 >= 0)
434       close (fd1);
435   }
436
437   if (!NILP (fork_error))
438     signal_error (Qfile_error, fork_error);
439
440 #ifndef WIN32_NATIVE
441   if (pid < 0)
442     {
443       int save_errno = errno;
444       if (fd[0] >= 0)
445         close (fd[0]);
446       errno = save_errno;
447       report_file_error ("Doing fork", Qnil);
448     }
449 #endif
450
451   if (INTP (buffer))
452     {
453       if (fd[0] >= 0)
454         close (fd[0]);
455 #if defined (NO_SUBPROCESSES)
456       /* If Emacs has been built with asynchronous subprocess support,
457          we don't need to do this, I think because it will then have
458          the facilities for handling SIGCHLD.  */
459       wait_without_blocking ();
460 #endif /* NO_SUBPROCESSES */
461       return Qnil;
462     }
463
464   {
465     int nread;
466     int total_read = 0;
467     Lisp_Object instream;
468     struct gcpro ngcpro1;
469
470     /* Enable sending signal if user quits below.  */
471     call_process_exited = 0;
472
473     record_unwind_protect (call_process_cleanup,
474                            Fcons (make_int (fd[0]), make_int (pid)));
475
476     /* FSFmacs calls Fset_buffer() here.  We don't have to because
477        we can insert into buffers other than the current one. */
478     if (EQ (buffer, Qt))
479       XSETBUFFER (buffer, current_buffer);
480     instream = make_filedesc_input_stream (fd[0], 0, -1, LSTR_ALLOW_QUIT);
481 #ifdef FILE_CODING
482     instream =
483       make_decoding_input_stream
484         (XLSTREAM (instream),
485          Fget_coding_system (Vcoding_system_for_read));
486     Lstream_set_character_mode (XLSTREAM (instream));
487 #endif
488     NGCPRO1 (instream);
489     while (1)
490       {
491         QUIT;
492         /* Repeatedly read until we've filled as much as possible
493            of the buffer size we have.  But don't read
494            less than 1024--save that for the next bufferfull.  */
495
496         nread = 0;
497         while (nread < bufsize - 1024)
498           {
499             Lstream_data_count this_read
500               = Lstream_read (XLSTREAM (instream), bufptr + nread,
501                               bufsize - nread);
502
503             if (this_read < 0)
504               goto give_up;
505
506             if (this_read == 0)
507               goto give_up_1;
508
509             nread += this_read;
510           }
511
512       give_up_1:
513
514         /* Now NREAD is the total amount of data in the buffer.  */
515         if (nread == 0)
516           break;
517
518 #if 0
519 #ifdef WIN32_NATIVE
520        /* Until we pull out of MULE things like
521           make_decoding_input_stream(), we do the following which is
522           less elegant. --marcpa */
523         /* We did. -- kkm */
524        {
525          int lf_count = 0;
526          if (NILP (Vbinary_process_output)) {
527            nread = crlf_to_lf(nread, bufptr, &lf_count);
528          }
529        }
530 #endif
531 #endif
532
533         total_read += nread;
534
535         if (!NILP (buffer))
536           buffer_insert_raw_string (XBUFFER (buffer), (Bufbyte *) bufptr,
537                                     nread);
538
539         /* Make the buffer bigger as we continue to read more data,
540            but not past 64k.  */
541         if (bufsize < 64 * 1024 && total_read > 32 * bufsize)
542           {
543             bufsize *= 2;
544             bufptr = (char *) alloca (bufsize);
545           }
546
547         if (!NILP (display) && INTERACTIVE)
548           {
549             redisplay ();
550           }
551       }
552   give_up:
553     Lstream_close (XLSTREAM (instream));
554     NUNGCPRO;
555
556     QUIT;
557     /* Wait for it to terminate, unless it already has.  */
558 #ifdef WIN32_NATIVE
559     wait_for_termination (pHandle);
560 #else
561     wait_for_termination (pid);
562 #endif
563
564     /* Don't kill any children that the subprocess may have left behind
565        when exiting.  */
566     call_process_exited = 1;
567     unbind_to (speccount, Qnil);
568
569     if (synch_process_death)
570       return build_string (synch_process_death);
571     return make_int (synch_process_retcode);
572   }
573 }
574
575 \f
576
577 /* Move the file descriptor FD so that its number is not less than MIN. *
578    The original file descriptor remains open.  */
579 static int
580 relocate_fd (int fd, int min)
581 {
582   if (fd >= min)
583     return fd;
584   else
585     {
586       int newfd = dup (fd);
587       if (newfd == -1)
588         {
589           stderr_out ("Error while setting up child: %s\n",
590                       strerror (errno));
591           _exit (1);
592         }
593       return relocate_fd (newfd, min);
594     }
595 }
596
597 /* This is the last thing run in a newly forked inferior
598    either synchronous or asynchronous.
599    Copy descriptors IN, OUT and ERR
600    as descriptors STDIN_FILENO, STDOUT_FILENO, and STDERR_FILENO.
601    Initialize inferior's priority, pgrp, connected dir and environment.
602    then exec another program based on new_argv.
603
604    This function may change environ for the superior process.
605    Therefore, the superior process must save and restore the value
606    of environ around the fork and the call to this function.
607
608    ENV is the environment for the subprocess.
609
610    XEmacs: We've removed the SET_PGRP argument because it's already
611    done by the callers of child_setup.
612
613    CURRENT_DIR is an elisp string giving the path of the current
614    directory the subprocess should have.  Since we can't really signal
615    a decent error from within the child, this should be verified as an
616    executable directory by the parent.  */
617
618 #ifdef WIN32_NATIVE
619 int
620 #else
621 void
622 #endif
623 child_setup (int in, int out, int err, char **new_argv,
624              const char *current_dir)
625 {
626   char **env;
627   char *pwd;
628 #ifdef WIN32_NATIVE
629   int cpid;
630   HANDLE handles[4];
631 #endif /* WIN32_NATIVE */
632
633 #ifdef SET_EMACS_PRIORITY
634   if (emacs_priority != 0)
635     nice (- emacs_priority);
636 #endif
637
638   /* Under Windows, we are not in a child process at all, so we should
639      not close handles inherited from the parent -- we are the parent
640      and doing so will screw up all manner of things!  Similarly, most
641      of the rest of the cleanup done in this function is not done
642      under Windows.
643
644      #### This entire child_setup() function is an utter and complete
645      piece of shit.  I would rewrite it, at the very least splitting
646      out the Windows and non-Windows stuff into two completely
647      different functions; but instead I'm trying to make it go away
648      entirely, using the Lisp definition in process.el.  What's left
649      is to fix up the routines in event-msw.c (and in event-Xt.c and
650      event-tty.c) to allow for stream devices to be handled correctly.
651      There isn't much to do, in fact, and I'll fix it shortly.  That
652      way, the Lisp definition can be used non-interactively too. */
653 #if !defined (NO_SUBPROCESSES) && !defined (WIN32_NATIVE)
654   /* Close Emacs's descriptors that this process should not have.  */
655   close_process_descs ();
656 #endif /* not NO_SUBPROCESSES */
657 #ifndef WIN32_NATIVE
658   close_load_descs ();
659 #endif
660
661   /* Note that use of alloca is always safe here.  It's obvious for systems
662      that do not have true vfork or that have true (stack) alloca.
663      If using vfork and C_ALLOCA it is safe because that changes
664      the superior's static variables as if the superior had done alloca
665      and will be cleaned up in the usual way.  */
666   {
667     REGISTER int i;
668
669     i = strlen (current_dir);
670     pwd = alloca_array (char, i + 6);
671     memcpy (pwd, "PWD=", 4);
672     memcpy (pwd + 4, current_dir, i);
673     i += 4;
674     if (!IS_DIRECTORY_SEP (pwd[i - 1]))
675       pwd[i++] = DIRECTORY_SEP;
676     pwd[i] = 0;
677
678     /* We can't signal an Elisp error here; we're in a vfork.  Since
679        the callers check the current directory before forking, this
680        should only return an error if the directory's permissions
681        are changed between the check and this chdir, but we should
682        at least check.  */
683     if (chdir (pwd + 4) < 0)
684       {
685         /* Don't report the chdir error, or ange-ftp.el doesn't work. */
686         /* (FSFmacs does _exit (errno) here.) */
687         pwd = 0;
688       }
689     else
690       {
691         /* Strip trailing "/".  Cretinous *[]&@$#^%@#$% Un*x */
692         /* leave "//" (from FSF) */
693         while (i > 6 && IS_DIRECTORY_SEP (pwd[i - 1]))
694           pwd[--i] = 0;
695       }
696   }
697
698   /* Set `env' to a vector of the strings in Vprocess_environment.  */
699   /* + 2 to include PWD and terminating 0.  */
700   env = alloca_array (char *, XINT (Flength (Vprocess_environment)) + 2);
701   {
702     REGISTER Lisp_Object tail;
703     char **new_env = env;
704
705     /* If we have a PWD envvar and we know the real current directory,
706        pass one down, but with corrected value.  */
707     if (pwd && getenv ("PWD"))
708       *new_env++ = pwd;
709
710     /* Copy the Vprocess_environment strings into new_env.  */
711     for (tail = Vprocess_environment;
712          CONSP (tail) && STRINGP (XCAR (tail));
713          tail = XCDR (tail))
714     {
715       char **ep = env;
716       char *envvar_external;
717
718       TO_EXTERNAL_FORMAT (LISP_STRING, XCAR (tail),
719                           C_STRING_ALLOCA, envvar_external,
720                           Qfile_name);
721
722       /* See if envvar_external duplicates any string already in the env.
723          If so, don't put it in.
724          When an env var has multiple definitions,
725          we keep the definition that comes first in process-environment.  */
726       for (; ep != new_env; ep++)
727         {
728           char *p = *ep, *q = envvar_external;
729           while (1)
730             {
731               if (*q == 0)
732                 /* The string is malformed; might as well drop it.  */
733                 goto duplicate;
734               if (*q != *p)
735                 break;
736               if (*q == '=')
737                 goto duplicate;
738               p++, q++;
739             }
740         }
741       if (pwd && !strncmp ("PWD=", envvar_external, 4))
742         {
743           *new_env++ = pwd;
744           pwd = 0;
745         }
746       else
747         *new_env++ = envvar_external;
748
749     duplicate: ;
750     }
751     *new_env = 0;
752   }
753
754 #ifdef WIN32_NATIVE
755   prepare_standard_handles (in, out, err, handles);
756   set_process_dir (current_dir);
757 #else  /* not WIN32_NATIVE */
758   /* Make sure that in, out, and err are not actually already in
759      descriptors zero, one, or two; this could happen if Emacs is
760      started with its standard in, out, or error closed, as might
761      happen under X.  */
762   in  = relocate_fd (in,  3);
763   out = relocate_fd (out, 3);
764   err = relocate_fd (err, 3);
765
766   /* Set the standard input/output channels of the new process.  */
767   close (STDIN_FILENO);
768   close (STDOUT_FILENO);
769   close (STDERR_FILENO);
770
771   dup2 (in,  STDIN_FILENO);
772   dup2 (out, STDOUT_FILENO);
773   dup2 (err, STDERR_FILENO);
774
775   close (in);
776   close (out);
777   close (err);
778
779   /* Close non-process-related file descriptors. It would be cleaner to
780      close just the ones that need to be, but the following brute
781      force approach is certainly effective, and not too slow. */
782
783   {
784     int fd;
785
786     for (fd = 3; fd < MAXDESC; fd++)
787       close (fd);
788   }
789 #endif /* not WIN32_NATIVE */
790
791 #ifdef vipc
792   something missing here;
793 #endif /* vipc */
794
795 #ifdef WIN32_NATIVE
796   /* Spawn the child.  (See ntproc.c:Spawnve).  */
797   cpid = spawnve (_P_NOWAIT, new_argv[0], (const char* const*)new_argv,
798                   (const char* const*)env);
799   if (cpid == -1)
800     /* An error occurred while trying to spawn the process.  */
801     report_file_error ("Spawning child process", Qnil);
802   reset_standard_handles (in, out, err, handles);
803   return cpid;
804 #else /* not WIN32_NATIVE */
805   /* execvp does not accept an environment arg so the only way
806      to pass this environment is to set environ.  Our caller
807      is responsible for restoring the ambient value of environ.  */
808   environ = env;
809   execvp (new_argv[0], new_argv);
810
811   stdout_out ("Can't exec program %s\n", new_argv[0]);
812   _exit (1);
813 #endif /* not WIN32_NATIVE */
814 }
815
816 static int
817 getenv_internal (const Bufbyte *var,
818                  Bytecount varlen,
819                  Bufbyte **value,
820                  Bytecount *valuelen)
821 {
822   Lisp_Object scan;
823
824   for (scan = Vprocess_environment; CONSP (scan); scan = XCDR (scan))
825     {
826       Lisp_Object entry = XCAR (scan);
827
828       if (STRINGP (entry)
829           && XSTRING_LENGTH (entry) > varlen
830           && XSTRING_BYTE (entry, varlen) == '='
831 #ifdef WIN32_NATIVE
832           /* NT environment variables are case insensitive.  */
833           && ! memicmp (XSTRING_DATA (entry), var, varlen)
834 #else  /* not WIN32_NATIVE */
835           && ! memcmp (XSTRING_DATA (entry), var, varlen)
836 #endif /* not WIN32_NATIVE */
837           )
838         {
839           *value    = XSTRING_DATA   (entry) + (varlen + 1);
840           *valuelen = XSTRING_LENGTH (entry) - (varlen + 1);
841           return 1;
842         }
843     }
844
845   return 0;
846 }
847
848 DEFUN ("getenv", Fgetenv, 1, 2, "sEnvironment variable: \np", /*
849 Return the value of environment variable VAR, as a string.
850 VAR is a string, the name of the variable.
851 When invoked interactively, prints the value in the echo area.
852 */
853        (var, interactivep))
854 {
855   Bufbyte *value;
856   Bytecount valuelen;
857   Lisp_Object v = Qnil;
858   struct gcpro gcpro1;
859
860   CHECK_STRING (var);
861   GCPRO1 (v);
862   if (getenv_internal (XSTRING_DATA (var), XSTRING_LENGTH (var),
863                        &value, &valuelen))
864     v = make_string (value, valuelen);
865   if (!NILP (interactivep))
866     {
867       if (NILP (v))
868         message ("%s not defined in environment", XSTRING_DATA (var));
869       else
870         /* #### Should use Fprin1_to_string or Fprin1 to handle string
871            containing quotes correctly.  */
872         message ("\"%s\"", value);
873     }
874   RETURN_UNGCPRO (v);
875 }
876
877 /* A version of getenv that consults process_environment, easily
878    callable from C.  */
879 char *
880 egetenv (const char *var)
881 {
882   /* This cannot GC -- 7-28-00 ben */
883   Bufbyte *value;
884   Bytecount valuelen;
885
886   if (getenv_internal ((const Bufbyte *) var, strlen (var), &value, &valuelen))
887     return (char *) value;
888   else
889     return 0;
890 }
891
892 \f
893 void
894 init_callproc (void)
895 {
896   /* This function can GC */
897
898   {
899     /* jwz: always initialize Vprocess_environment, so that egetenv()
900        works in temacs. */
901     char **envp;
902     Vprocess_environment = Qnil;
903     for (envp = environ; envp && *envp; envp++)
904       Vprocess_environment =
905         Fcons (build_ext_string (*envp, Qfile_name), Vprocess_environment);
906   }
907
908   {
909     /* Initialize shell-file-name from environment variables or best guess. */
910 #ifdef WIN32_NATIVE
911     const char *shell = egetenv ("SHELL");
912     if (!shell) shell = egetenv ("COMSPEC");
913     /* Should never happen! */
914     if (!shell) shell = (GetVersion () & 0x80000000 ? "command" : "cmd");
915 #else /* not WIN32_NATIVE */
916     const char *shell = egetenv ("SHELL");
917     if (!shell) shell = "/bin/sh";
918 #endif
919
920 #if 0 /* defined (WIN32_NATIVE) */
921     /* BAD BAD BAD.  We do not wanting to be passing an XEmacs-created
922        SHELL var down to some inferior Cygwin process, which might get
923        screwed up.
924          
925        There are a few broken apps (eterm/term.el, eterm/tshell.el,
926        os-utils/terminal.el, texinfo/tex-mode.el) where this will
927        cause problems.  Those broken apps don't look at
928        shell-file-name, instead just at explicit-shell-file-name,
929        ESHELL and SHELL.  They are apparently attempting to borrow
930        what `M-x shell' uses, but that latter also looks at
931        shell-file-name.  What we want is for all of these apps to look
932        at shell-file-name, so that the user can change the value of
933        shell-file-name and everything will work out hunky-dorey.
934        */
935     
936     if (!egetenv ("SHELL"))
937       {
938         CBufbyte *faux_var = alloca_array (CBufbyte, 7 + strlen (shell));
939         sprintf (faux_var, "SHELL=%s", shell);
940         Vprocess_environment = Fcons (build_string (faux_var),
941                                       Vprocess_environment);
942       }
943 #endif /* 0 */
944
945     Vshell_file_name = build_string (shell);
946   }
947 }
948
949 #if 0
950 void
951 set_process_environment (void)
952 {
953   REGISTER char **envp;
954
955   Vprocess_environment = Qnil;
956 #ifndef CANNOT_DUMP
957   if (initialized)
958 #endif
959     for (envp = environ; *envp; envp++)
960       Vprocess_environment = Fcons (build_string (*envp),
961                                     Vprocess_environment);
962 }
963 #endif /* unused */
964
965 void
966 syms_of_callproc (void)
967 {
968   DEFSUBR (Fold_call_process_internal);
969   DEFSUBR (Fgetenv);
970 }
971
972 void
973 vars_of_callproc (void)
974 {
975   /* This function can GC */
976 #ifdef WIN32_NATIVE
977   DEFVAR_LISP ("binary-process-input", &Vbinary_process_input /*
978 *If non-nil then new subprocesses are assumed to take binary input.
979 */ );
980   Vbinary_process_input = Qnil;
981
982   DEFVAR_LISP ("binary-process-output", &Vbinary_process_output /*
983 *If non-nil then new subprocesses are assumed to produce binary output.
984 */ );
985   Vbinary_process_output = Qnil;
986 #endif /* WIN32_NATIVE */
987
988   DEFVAR_LISP ("shell-file-name", &Vshell_file_name /*
989 *File name to load inferior shells from.
990 Initialized from the SHELL environment variable.
991 */ );
992
993   DEFVAR_LISP ("process-environment", &Vprocess_environment /*
994 List of environment variables for subprocesses to inherit.
995 Each element should be a string of the form ENVVARNAME=VALUE.
996 The environment which Emacs inherits is placed in this variable
997 when Emacs starts.
998 */ );
999
1000   Vlisp_EXEC_SUFFIXES = build_string (EXEC_SUFFIXES);
1001   staticpro (&Vlisp_EXEC_SUFFIXES);
1002 }