(U-0002011D): Use `ideographic-radical@{ucs|cns}' and
[chise/xemacs-chise.git.1] / 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 }