Mercurial > hg > xemacs-beta

comparison src/callproc.c @ 0:376386a54a3c r19-14

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-14
author cvs
date Mon, 13 Aug 2007 08:45:50 +0200
parents
children 9ee227acff29
comparison
equal deleted inserted replaced
-1:000000000000 0:376386a54a3c
1 /* 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
23 #include <config.h>
24 #include "lisp.h"
25
26 #include "buffer.h"
27 #include "commands.h"
28 #include "insdel.h"
29 #include "lstream.h"
30 #include "paths.h"
31 #include "process.h"
32 #include "sysdep.h"
33 #include "window.h"
34
35 #include "sysfile.h"
36 #include "systime.h"
37 #include "sysproc.h"
38 #include "syssignal.h" /* Always include before systty.h */
39 #include "systty.h"
40
41
42 #ifdef DOS_NT
43 /* When we are starting external processes we need to know whether they
44 take binary input (no conversion) or text input (\n is converted to
45 \r\n). Similar for output: if newlines are written as \r\n then it's
46 text process output, otherwise it's binary. */
47 Lisp_Object Vbinary_process_input;
48 Lisp_Object Vbinary_process_output;
49 #endif /* DOS_NT */
50
51 Lisp_Object Vexec_path, Vexec_directory, Vdata_directory, Vdoc_directory;
52 Lisp_Object Vconfigure_info_directory;
53
54 /* The default base directory XEmacs is installed under. */
55 Lisp_Object Vprefix_directory;
56
57 Lisp_Object Vshell_file_name;
58
59 /* The environment to pass to all subprocesses when they are started.
60 This is in the semi-bogus format of ("VAR=VAL" "VAR2=VAL2" ... )
61 */
62 Lisp_Object Vprocess_environment;
63
64 /* True iff we are about to fork off a synchronous process or if we
65 are waiting for it. */
66 volatile int synch_process_alive;
67
68 /* Nonzero => this is a string explaining death of synchronous subprocess. */
69 CONST char *synch_process_death;
70
71 /* If synch_process_death is zero,
72 this is exit code of synchronous subprocess. */
73 int synch_process_retcode;
74
75 /* Clean up when exiting Fcall_process_internal.
76 On MSDOS, delete the temporary file on any kind of termination.
77 On Unix, kill the process and any children on termination by signal. */
78
79 /* Nonzero if this is termination due to exit. */
80 static int call_process_exited;
81
82 #ifndef VMS /* VMS version is in vmsproc.c. */
83
84 static Lisp_Object
85 call_process_kill (Lisp_Object fdpid)
86 {
87 Lisp_Object fd = Fcar (fdpid);
88 Lisp_Object pid = Fcdr (fdpid);
89
90 if (!NILP (fd))
91 close (XINT (fd));
92
93 if (!NILP (pid))
94 EMACS_KILLPG (XINT (pid), SIGKILL);
95
96 synch_process_alive = 0;
97 return Qnil;
98 }
99
100 static Lisp_Object
101 call_process_cleanup (Lisp_Object fdpid)
102 {
103 #ifdef MSDOS
104 /* for MSDOS fdpid is really (fd . tempfile) */
105 Lisp_Object file = Fcdr (fdpid);
106 close (XINT (Fcar (fdpid)));
107 if (strcmp (string_data (XSTRING (file)), NULL_DEVICE) != 0)
108 unlink (string_data (XSTRING (file)));
109 #else /* not MSDOS */
110 int fd = XINT (Fcar (fdpid));
111 int pid = XINT (Fcdr (fdpid));
112
113 if (!call_process_exited &&
114 EMACS_KILLPG (pid, SIGINT) == 0)
115 {
116 int speccount = specpdl_depth ();
117
118 record_unwind_protect (call_process_kill, fdpid);
119 /* #### "c-G" -- need non-consing Single-key-description */
120 message ("Waiting for process to die...(type C-g again to kill it instantly)");
121
122 /* "Discard" the unwind protect. */
123 XCAR (fdpid) = Qnil;
124 XCDR (fdpid) = Qnil;
125 unbind_to (speccount, Qnil);
126
127 message ("Waiting for process to die... done");
128 }
129 synch_process_alive = 0;
130 close (fd);
131 #endif /* not MSDOS */
132 return Qnil;
133 }
134
135 static Lisp_Object fork_error;
136 #if 0 /* UNUSED */
137 static void
138 report_fork_error (char *string, Lisp_Object data)
139 {
140 Lisp_Object errstring = build_string (strerror (errno));
141
142 /* System error messages are capitalized. Downcase the initial. */
143 set_string_char (XSTRING (errstring), 0,
144 DOWNCASE (current_buffer,
145 string_char (XSTRING (errstring), 0)));
146
147 fork_error = Fcons (build_string (string), Fcons (errstring, data));
148
149 /* terminate this branch of the fork, without closing stdin/out/etc. */
150 _exit (1);
151 }
152 #endif /* unused */
153
154 DEFUN ("call-process-internal", Fcall_process_internal,
155 Scall_process_internal, 1, MANY, 0 /*
156 Call PROGRAM synchronously in separate process, with coding-system specified.
157 Arguments are
158 (PROGRAM &optional INFILE BUFFER DISPLAY &rest ARGS).
159 The program's input comes from file INFILE (nil means `/dev/null').
160 Insert output in BUFFER before point; t means current buffer;
161 nil for BUFFER means discard it; 0 means discard and don't wait.
162 BUFFER can also have the form (REAL-BUFFER STDERR-FILE); in that case,
163 REAL-BUFFER says what to do with standard output, as above,
164 while STDERR-FILE says what to do with standard error in the child.
165 STDERR-FILE may be nil (discard standard error output),
166 t (mix it with ordinary output), or a file name string.
167
168 Fourth arg DISPLAY non-nil means redisplay buffer as output is inserted.
169 Remaining arguments are strings passed as command arguments to PROGRAM.
170
171 If BUFFER is 0, `call-process' returns immediately with value nil.
172 Otherwise it waits for PROGRAM to terminate and returns a numeric exit status
173 or a signal description string.
174 If you quit, the process is killed with SIGINT, or SIGKILL if you
175 quit again.
176 */ )
177 (nargs, args)
178 int nargs;
179 Lisp_Object *args;
180 {
181 /* This function can GC */
182 Lisp_Object infile, buffer, current_dir, display, path;
183 int fd[2];
184 int filefd;
185 int pid;
186 char buf[16384];
187 char *bufptr = buf;
188 int bufsize = 16384;
189 int speccount = specpdl_depth ();
190 char **new_argv
191 = (char **) alloca ((max (2, nargs - 2)) * sizeof (char *));
192
193 /* File to use for stderr in the child.
194 t means use same as standard output. */
195 Lisp_Object error_file;
196 #ifdef MSDOS
197 char *outf, *tempfile;
198 int outfilefd;
199 #endif
200
201 CHECK_STRING (args[0]);
202
203 error_file = Qt;
204
205 #if defined (NO_SUBPROCESSES)
206 /* Without asynchronous processes we cannot have BUFFER == 0. */
207 if (nargs >= 3 && !INTP (args[2]))
208 error ("Operating system cannot handle asynchronous subprocesses");
209 #endif
210
211 /* Do this before building new_argv because GC in Lisp code
212 * called by various filename-hacking routines might relocate strings */
213 locate_file (Vexec_path, args[0], EXEC_SUFFIXES, &path, X_OK);
214
215 /* Make sure that the child will be able to chdir to the current
216 buffer's current directory, or its unhandled equivalent. We
217 can't just have the child check for an error when it does the
218 chdir, since it's in a vfork. */
219 {
220 struct gcpro gcpro1, gcpro2;
221 /* Do this test before building new_argv because GC in Lisp code
222 * called by various filename-hacking routines might relocate strings */
223 /* Make sure that the child will be able to chdir to the current
224 buffer's current directory. We can't just have the child check
225 for an error when it does the chdir, since it's in a vfork. */
226
227 GCPRO2 (current_dir, path); /* Caller gcprotects args[] */
228 current_dir = current_buffer->directory;
229 current_dir = expand_and_dir_to_file
230 (Funhandled_file_name_directory (current_dir), Qnil);
231 #if 0
232 /* I don't know how RMS intends this crock of shit to work, but it
233 breaks everything in the presence of ange-ftp-visited files, so
234 fuck it. */
235 if (NILP (Ffile_accessible_directory_p (current_dir)))
236 report_file_error ("Setting current directory",
237 Fcons (current_buffer->directory, Qnil));
238 #endif /* 0 */
239 UNGCPRO;
240 }
241
242 if (nargs >= 2 && ! NILP (args[1]))
243 {
244 infile = Fexpand_file_name (args[1],
245 current_buffer->directory);
246 CHECK_STRING (infile);
247 }
248 else
249 infile = build_string (NULL_DEVICE);
250
251 if (nargs >= 3)
252 {
253 buffer = args[2];
254
255 /* If BUFFER is a list, its meaning is
256 (BUFFER-FOR-STDOUT FILE-FOR-STDERR). */
257 if (CONSP (buffer))
258 {
259 if (CONSP (XCDR (buffer)))
260 {
261 Lisp_Object file_for_stderr = XCAR (XCDR (buffer));
262
263 if (NILP (file_for_stderr) || EQ (Qt, file_for_stderr))
264 error_file = file_for_stderr;
265 else
266 error_file = Fexpand_file_name (file_for_stderr, Qnil);
267 }
268
269 buffer = XCAR (buffer);
270 }
271
272 if (!(EQ (buffer, Qnil)
273 || EQ (buffer, Qt)
274 || ZEROP (buffer)))
275 {
276 Lisp_Object spec_buffer;
277 spec_buffer = buffer;
278 buffer = Fget_buffer (buffer);
279 /* Mention the buffer name for a better error message. */
280 if (NILP (buffer))
281 CHECK_BUFFER (spec_buffer);
282 CHECK_BUFFER (buffer);
283 }
284 }
285 else
286 buffer = Qnil;
287
288 display = ((nargs >= 4) ? args[3] : Qnil);
289
290 /* From here we assume we won't GC (unless an error is signalled). */
291 {
292 REGISTER int i;
293 for (i = 4; i < nargs; i++)
294 {
295 CHECK_STRING (args[i]);
296 new_argv[i - 3] = (char *) string_data (XSTRING (args[i]));
297 }
298 /* Program name is first command arg */
299 new_argv[0] = (char *) string_data (XSTRING (args[0]));
300 new_argv[i - 3] = 0;
301 }
302
303 filefd = open ((char *) string_data (XSTRING (infile)), O_RDONLY, 0);
304 if (filefd < 0)
305 {
306 report_file_error ("Opening process input file",
307 Fcons (infile, Qnil));
308 }
309
310 if (NILP (path))
311 {
312 close (filefd);
313 report_file_error ("Searching for program",
314 Fcons (args[0], Qnil));
315 }
316 new_argv[0] = (char *) string_data (XSTRING (path));
317
318 #ifdef MSDOS
319 /* These vars record information from process termination.
320 Clear them now before process can possibly terminate,
321 to avoid timing error if process terminates soon. */
322 synch_process_death = 0;
323 synch_process_retcode = 0;
324
325 if ((outf = egetenv ("TMP")) || (outf = egetenv ("TEMP")))
326 strcpy (tempfile = alloca (strlen (outf) + 20), outf);
327 else
328 {
329 tempfile = alloca (20);
330 *tempfile = '\0';
331 }
332 dostounix_filename (tempfile);
333 if (*tempfile == '\0' || tempfile[strlen (tempfile) - 1] != '/')
334 strcat (tempfile, "/");
335 strcat (tempfile, "detmp.XXX");
336 mktemp (tempfile);
337
338 outfilefd = creat (tempfile, S_IREAD | S_IWRITE);
339 if (outfilefd < 0)
340 {
341 close (filefd);
342 report_file_error ("Opening process output file",
343 Fcons (tempfile, Qnil));
344 }
345 #endif
346
347 #ifndef MSDOS
348 if (INTP (buffer))
349 {
350 fd[1] = open (NULL_DEVICE, O_WRONLY, 0);
351 fd[0] = -1;
352 }
353 else
354 {
355 #ifdef WINDOWSNT
356 pipe_with_inherited_out (fd);
357 #else /* not WINDOWSNT */
358 pipe (fd);
359 #endif /* not WINDOWSNT */
360 #if 0
361 /* Replaced by close_process_descs */
362 set_exclusive_use (fd[0]);
363 #endif
364 }
365 #else /* MSDOS */
366 {
367 char *outf;
368
369 if (INTP (buffer))
370 outf = NULL_DEVICE;
371 else
372 {
373 /* DOS can't create pipe for interprocess communication,
374 so redirect child process's standard output to temporary file
375 and later read the file. */
376
377 if ((outf = egetenv ("TMP")) || (outf = egetenv ("TEMP")))
378 {
379 strcpy (tempfile, outf);
380 dostounix_filename (tempfile);
381 }
382 else
383 *tempfile = '\0';
384 if (strlen (tempfile) == 0 || tempfile[strlen (tempfile) - 1] != '/')
385 strcat (tempfile, "/");
386 strcat (tempfile, "demacs.XXX");
387 mktemp (tempfile);
388 outf = tempfile;
389 }
390
391 if ((fd[1] = creat (outf, S_IREAD | S_IWRITE)) < 0)
392 report_file_error ("Can't open temporary file", Qnil);
393 fd[0] = -1;
394 }
395 #endif /* MSDOS */
396
397 {
398 /* child_setup must clobber environ in systems with true vfork.
399 Protect it from permanent change. */
400 REGISTER char **save_environ = environ;
401 REGISTER int fd1 = fd[1];
402 int fd_error = fd1;
403 char **env;
404
405 #ifdef EMACS_BTL
406 /* when performance monitoring is on, turn it off before the vfork(),
407 as the child has no handler for the signal -- when back in the
408 parent process, turn it back on if it was really on when you "turned
409 it off" */
410 int logging_on = cadillac_stop_logging ();
411 #endif
412
413 env = environ;
414
415 /* Record that we're about to create a synchronous process. */
416 synch_process_alive = 1;
417
418 /* These vars record information from process termination.
419 Clear them now before process can possibly terminate,
420 to avoid timing error if process terminates soon. */
421 synch_process_death = 0;
422 synch_process_retcode = 0;
423
424 #ifdef MSDOS
425 /* ??? Someone who knows MSDOG needs to check whether this properly
426 closes all descriptors that it opens. */
427 pid = run_msdos_command (new_argv, current_dir, filefd, outfilefd);
428 close (outfilefd);
429 fd1 = -1; /* No harm in closing that one! */
430 fd[0] = open (tempfile, NILP (Vbinary_process_output) ? O_TEXT :
431 O_BINARY);
432 if (fd[0] < 0)
433 {
434 unlink (tempfile);
435 close (filefd);
436 report_file_error ("Cannot re-open temporary file", Qnil);
437 }
438 #else /* not MSDOS */
439 if (NILP (error_file))
440 fd_error = open (NULL_DEVICE, O_WRONLY);
441 else if (STRINGP (error_file))
442 {
443 #ifdef DOS_NT
444 fd_error = open (string_data (XSTRING (error_file)),
445 O_WRONLY | O_TRUNC | O_CREAT | O_TEXT,
446 S_IREAD | S_IWRITE);
447 #else /* not DOS_NT */
448 fd_error =
449 creat ((CONST char *) string_data (XSTRING (error_file)), 0666);
450 #endif /* not DOS_NT */
451 }
452
453 if (fd_error < 0)
454 {
455 close (filefd);
456 close (fd[0]);
457 if (fd1 >= 0)
458 close (fd1);
459 report_file_error ("Cannot open", error_file);
460 }
461
462 fork_error = Qnil;
463 #ifdef WINDOWSNT
464 pid = child_setup (filefd, fd1, fd_error, new_argv, current_dir);
465 #else /* not WINDOWSNT */
466 pid = vfork ();
467
468 if (pid == 0)
469 {
470 if (fd[0] >= 0)
471 close (fd[0]);
472 /* This is necessary because some shells may attempt to
473 access the current controlling terminal and will hang
474 if they are run in the background, as will be the case
475 when XEmacs is started in the background. Martin
476 Buchholz observed this problem running a subprocess
477 that used zsh to call gzip to uncompress an info
478 file. */
479 disconnect_controlling_terminal ();
480 child_setup (filefd, fd1, fd_error, new_argv,
481 (char *) string_data (XSTRING (current_dir)));
482 }
483 #ifdef EMACS_BTL
484 else if (logging_on)
485 cadillac_start_logging ();
486 #endif
487
488 #endif /* not MSDOS */
489 #endif /* not WINDOWSNT */
490
491 environ = save_environ;
492
493 /* Close most of our fd's, but not fd[0]
494 since we will use that to read input from. */
495 close (filefd);
496 if (fd1 >= 0)
497 close (fd1);
498 }
499
500 if (!NILP (fork_error))
501 signal_error (Qfile_error, fork_error);
502
503 if (pid < 0)
504 {
505 if (fd[0] >= 0)
506 close (fd[0]);
507 report_file_error ("Doing vfork", Qnil);
508 }
509
510 if (INTP (buffer))
511 {
512 if (fd[0] >= 0)
513 close (fd[0]);
514 #if defined (NO_SUBPROCESSES)
515 /* If Emacs has been built with asynchronous subprocess support,
516 we don't need to do this, I think because it will then have
517 the facilities for handling SIGCHLD. */
518 wait_without_blocking ();
519 #endif
520 return Qnil;
521 }
522
523 {
524 int nread;
525 int first = 1;
526 int total_read = 0;
527 Lisp_Object instream;
528 struct gcpro gcpro1;
529
530 /* Enable sending signal if user quits below. */
531 call_process_exited = 0;
532
533 #ifdef MSDOS
534 /* MSDOS needs different cleanup information. */
535 record_unwind_protect (call_process_cleanup,
536 Fcons (make_int (fd[0]),
537 build_string (tempfile)));
538 #else
539 record_unwind_protect (call_process_cleanup,
540 Fcons (make_int (fd[0]), make_int (pid)));
541 #endif /* not MSDOS */
542
543 /* FSFmacs calls Fset_buffer() here. We don't have to because
544 we can insert into buffers other than the current one. */
545 if (EQ (buffer, Qt))
546 XSETBUFFER (buffer, current_buffer);
547 instream = make_filedesc_input_stream (fd[0], 0, -1, LSTR_ALLOW_QUIT);
548 GCPRO1 (instream);
549 while (1)
550 {
551 QUIT;
552 /* Repeatedly read until we've filled as much as possible
553 of the buffer size we have. But don't read
554 less than 1024--save that for the next bufferfull. */
555
556 nread = 0;
557 while (nread < bufsize - 1024)
558 {
559 int this_read
560 = Lstream_read (XLSTREAM (instream), bufptr + nread,
561 bufsize - nread);
562
563 if (this_read < 0)
564 goto give_up;
565
566 if (this_read == 0)
567 goto give_up_1;
568
569 nread += this_read;
570 }
571
572 give_up_1:
573
574 /* Now NREAD is the total amount of data in the buffer. */
575 if (nread == 0)
576 break;
577
578 total_read += nread;
579
580 if (!NILP (buffer))
581 buffer_insert_raw_string (XBUFFER (buffer), (Bufbyte *) bufptr,
582 nread);
583
584 /* Make the buffer bigger as we continue to read more data,
585 but not past 64k. */
586 if (bufsize < 64 * 1024 && total_read > 32 * bufsize)
587 {
588 bufsize *= 2;
589 bufptr = (char *) alloca (bufsize);
590 }
591
592 if (!NILP (display) && INTERACTIVE)
593 {
594 first = 0;
595 redisplay ();
596 }
597 }
598 give_up:
599 Lstream_close (XLSTREAM (instream));
600 UNGCPRO;
601
602 QUIT;
603 #ifndef MSDOS
604 /* Wait for it to terminate, unless it already has. */
605 wait_for_termination (pid);
606 #endif
607
608 /* Don't kill any children that the subprocess may have left behind
609 when exiting. */
610 call_process_exited = 1;
611 unbind_to (speccount, Qnil);
612
613 if (synch_process_death)
614 return build_string (synch_process_death);
615 return make_int (synch_process_retcode);
616 }
617 }
618
619 #endif /* VMS */
620
621 #ifndef VMS /* VMS version is in vmsproc.c. */
622
623 /* This is the last thing run in a newly forked inferior
624 either synchronous or asynchronous.
625 Copy descriptors IN, OUT and ERR as descriptors 0, 1 and 2.
626 Initialize inferior's priority, pgrp, connected dir and environment.
627 then exec another program based on new_argv.
628
629 This function may change environ for the superior process.
630 Therefore, the superior process must save and restore the value
631 of environ around the vfork and the call to this function.
632
633 ENV is the environment for the subprocess.
634
635 XEmacs: We've removed the SET_PGRP argument because it's already
636 done by the callers of child_setup.
637
638 CURRENT_DIR is an elisp string giving the path of the current
639 directory the subprocess should have. Since we can't really signal
640 a decent error from within the child, this should be verified as an
641 executable directory by the parent. */
642
643 static int relocate_fd (int fd, int min);
644
645 void
646 child_setup (int in, int out, int err, char **new_argv,
647 CONST char *current_dir)
648 {
649 #ifdef MSDOS
650 /* The MSDOS port of gcc cannot fork, vfork, ... so we must call system
651 instead. */
652 #else /* not MSDOS */
653 char **env;
654 char *pwd;
655 #ifdef WINDOWSNT
656 int cpid;
657 HANDLE handles[4];
658 #endif /* WINDOWSNT */
659
660 #ifdef SET_EMACS_PRIORITY
661 if (emacs_priority != 0)
662 nice (- emacs_priority);
663 #endif
664
665 #if !defined (NO_SUBPROCESSES)
666 /* Close Emacs's descriptors that this process should not have. */
667 close_process_descs ();
668 #endif
669 close_load_descs ();
670
671 /* Note that use of alloca is always safe here. It's obvious for systems
672 that do not have true vfork or that have true (stack) alloca.
673 If using vfork and C_ALLOCA it is safe because that changes
674 the superior's static variables as if the superior had done alloca
675 and will be cleaned up in the usual way. */
676 {
677 REGISTER int i;
678
679 i = strlen (current_dir);
680 pwd = (char *) alloca (i + 6);
681 memcpy (pwd, "PWD=", 4);
682 memcpy (pwd + 4, current_dir, i);
683 i += 4;
684 if (!IS_DIRECTORY_SEP (pwd[i - 1]))
685 pwd[i++] = DIRECTORY_SEP;
686 pwd[i] = 0;
687
688 /* We can't signal an Elisp error here; we're in a vfork. Since
689 the callers check the current directory before forking, this
690 should only return an error if the directory's permissions
691 are changed between the check and this chdir, but we should
692 at least check. */
693 if (chdir (pwd + 4) < 0)
694 {
695 /* Don't report the chdir error, or ange-ftp.el doesn't work. */
696 /* (FSFmacs does _exit (errno) here.) */
697 pwd = 0;
698 }
699 else
700 {
701 /* Strip trailing "/". Cretinous *[]&@$#^%@#$% Un*x */
702 /* leave "//" (from FSF) */
703 while (i > 6 && IS_DIRECTORY_SEP (pwd[i - 1]))
704 pwd[--i] = 0;
705 }
706 }
707
708 /* Set `env' to a vector of the strings in Vprocess_environment. */
709 {
710 REGISTER Lisp_Object tem;
711 REGISTER char **new_env;
712 REGISTER int new_length;
713
714 new_length = 0;
715 for (tem = Vprocess_environment;
716 (CONSP (tem)
717 && STRINGP (XCAR (tem)));
718 tem = XCDR (tem))
719 new_length++;
720
721 /* new_length + 2 to include PWD and terminating 0. */
722 env = new_env = (char **) alloca ((new_length + 2) * sizeof (char *));
723
724 /* If we have a PWD envvar and we know the real current directory,
725 pass one down, but with corrected value. */
726 if (pwd && getenv ("PWD"))
727 *new_env++ = pwd;
728
729 /* Copy the Vprocess_environment strings into new_env. */
730 for (tem = Vprocess_environment;
731 (CONSP (tem)
732 && STRINGP (XCAR (tem)));
733 tem = XCDR (tem))
734 {
735 char **ep = env;
736 char *string = (char *) string_data (XSTRING (XCAR (tem)));
737 /* See if this string duplicates any string already in the env.
738 If so, don't put it in.
739 When an env var has multiple definitions,
740 we keep the definition that comes first in process-environment. */
741 for (; ep != new_env; ep++)
742 {
743 char *p = *ep, *q = string;
744 while (1)
745 {
746 if (*q == 0)
747 /* The string is malformed; might as well drop it. */
748 goto duplicate;
749 if (*q != *p)
750 break;
751 if (*q == '=')
752 goto duplicate;
753 p++, q++;
754 }
755 }
756 if (pwd && !strncmp ("PWD=", string, 4))
757 {
758 *new_env++ = pwd;
759 pwd = 0;
760 }
761 else
762 *new_env++ = string;
763 duplicate: ;
764 }
765 *new_env = 0;
766 }
767 #ifdef WINDOWSNT
768 prepare_standard_handles (in, out, err, handles);
769 #else /* not WINDOWSNT */
770 /* Make sure that in, out, and err are not actually already in
771 descriptors zero, one, or two; this could happen if Emacs is
772 started with its standard in, out, or error closed, as might
773 happen under X. */
774 {
775 int oin = in, oout = out;
776
777 /* We have to avoid relocating the same descriptor twice! */
778
779 in = relocate_fd (in, 3);
780
781 if (out == oin) out = in;
782 else out = relocate_fd (out, 3);
783
784 if (err == oin) err = in;
785 else if (err == oout) err = out;
786 else err = relocate_fd (err, 3);
787 }
788
789 close (0);
790 close (1);
791 close (2);
792
793 dup2 (in, 0);
794 dup2 (out, 1);
795 dup2 (err, 2);
796
797 close (in);
798 close (out);
799 close (err);
800
801 /* I can't think of any reason why child processes need any more
802 than the standard 3 file descriptors. It would be cleaner to
803 close just the ones that need to be, but the following brute
804 force approach is certainly effective, and not too slow. */
805 {
806 int fd;
807 for (fd=3; fd<=64; fd++)
808 {
809 close(fd);
810 }
811 }
812 #endif /* not WINDOWSNT */
813
814 #ifdef vipc
815 something missing here;
816 #endif /* vipc */
817
818 #ifdef WINDOWSNT
819 /* Spawn the child. (See ntproc.c:Spawnve). */
820 cpid = spawnve (_P_NOWAIT, new_argv[0], new_argv, env);
821 if (cpid == -1)
822 /* An error occurred while trying to spawn the process. */
823 report_file_error ("Spawning child process", Qnil);
824 reset_standard_handles (in, out, err, handles);
825 return cpid;
826 #else /* not WINDOWSNT */
827 /* execvp does not accept an environment arg so the only way
828 to pass this environment is to set environ. Our caller
829 is responsible for restoring the ambient value of environ. */
830 environ = env;
831 execvp (new_argv[0], new_argv);
832
833 stdout_out ("Cant't exec program %s\n", new_argv[0]);
834 _exit (1);
835 #endif /* not WINDOWSNT */
836 #endif /* not MSDOS */
837 }
838
839 /* Move the file descriptor FD so that its number is not less than MIN.
840 If the file descriptor is moved at all, the original is freed. */
841 static int
842 relocate_fd (int fd, int min)
843 {
844 if (fd >= min)
845 return fd;
846 else
847 {
848 int new = dup (fd);
849 if (new == -1)
850 {
851 stderr_out ("Error while setting up child: %s\n",
852 strerror (errno));
853 _exit (1);
854 }
855 /* Note that we hold the original FD open while we recurse,
856 to guarantee we'll get a new FD if we need it. */
857 new = relocate_fd (new, min);
858 close (fd);
859 return new;
860 }
861 }
862
863 static int
864 getenv_internal (CONST Bufbyte *var,
865 Bytecount varlen,
866 Bufbyte **value,
867 Bytecount *valuelen)
868 {
869 Lisp_Object scan;
870
871 for (scan = Vprocess_environment; CONSP (scan); scan = XCDR (scan))
872 {
873 Lisp_Object entry = XCAR (scan);
874
875 if (STRINGP (entry)
876 && string_length (XSTRING (entry)) > varlen
877 && string_byte (XSTRING (entry), varlen) == '='
878 #ifdef WINDOWSNT
879 /* NT environment variables are case insensitive. */
880 && ! memicmp (string_data (XSTRING (entry)), var, varlen)
881 #else /* not WINDOWSNT */
882 && ! memcmp (string_data (XSTRING (entry)), var, varlen)
883 #endif /* not WINDOWSNT */
884 )
885 {
886 *value = string_data (XSTRING (entry)) + (varlen + 1);
887 *valuelen = string_length (XSTRING (entry)) - (varlen + 1);
888 return 1;
889 }
890 }
891
892 return 0;
893 }
894
895 DEFUN ("getenv", Fgetenv, Sgetenv, 1, 2, "sEnvironment variable: \np" /*
896 Return the value of environment variable VAR, as a string.
897 VAR is a string, the name of the variable.
898 When invoked interactively, prints the value in the echo area.
899 */ )
900 (var, interactivep)
901 Lisp_Object var, interactivep;
902 {
903 Bufbyte *value;
904 Bytecount valuelen;
905 Lisp_Object v = Qnil;
906 struct gcpro gcpro1;
907
908 CHECK_STRING (var);
909 GCPRO1 (v);
910 if (getenv_internal (string_data (XSTRING (var)),
911 string_length (XSTRING (var)),
912 &value, &valuelen))
913 v = make_string (value, valuelen);
914 if (!NILP (interactivep))
915 {
916 if (NILP (v))
917 message ("%s not defined in environment",
918 string_data (XSTRING (var)));
919 else
920 message ("\"%s\"", value);
921 }
922 RETURN_UNGCPRO (v);
923 }
924
925 /* A version of getenv that consults process_environment, easily
926 callable from C. */
927 char *
928 egetenv (CONST char *var)
929 {
930 Bufbyte *value;
931 Bytecount valuelen;
932
933 if (getenv_internal ((CONST Bufbyte *) var, strlen (var), &value, &valuelen))
934 return (char *) value;
935 else
936 return 0;
937 }
938 #endif /* not VMS */
939
940
941 void
942 init_callproc (void)
943 {
944 /* This function can GC */
945 REGISTER char *sh;
946 Lisp_Object tempdir;
947
948 Vprocess_environment = Qnil;
949 /* jwz: always initialize Vprocess_environment, so that egetenv() works
950 in temacs. */
951 {
952 char **envp;
953 for (envp = environ; envp && *envp; envp++)
954 Vprocess_environment = Fcons (build_ext_string (*envp, FORMAT_OS),
955 Vprocess_environment);
956 }
957
958 /* jwz: don't do these things when in temacs (this used to be the case by
959 virtue of egetenv() always returning 0, but that has been changed).
960 */
961 #ifndef CANNOT_DUMP
962 if (!initialized)
963 {
964 Vdata_directory = Qnil;
965 Vdoc_directory = Qnil;
966 Vexec_path = Qnil;
967 }
968 else
969 #endif
970 {
971 char *data_dir = egetenv ("EMACSDATA");
972 char *doc_dir = egetenv ("EMACSDOC");
973
974 #ifdef PATH_DATA
975 if (!data_dir)
976 data_dir = (char *) PATH_DATA;
977 #endif
978 #ifdef PATH_DOC
979 if (!doc_dir)
980 doc_dir = (char *) PATH_DOC;
981 #endif
982
983 if (data_dir)
984 Vdata_directory = Ffile_name_as_directory
985 (build_string (data_dir));
986 else
987 Vdata_directory = Qnil;
988 if (doc_dir)
989 Vdoc_directory = Ffile_name_as_directory
990 (build_string (doc_dir));
991 else
992 Vdoc_directory = Qnil;
993
994 /* Check the EMACSPATH environment variable, defaulting to the
995 PATH_EXEC path from paths.h. */
996 Vexec_path = decode_env_path ("EMACSPATH",
997 #ifdef PATH_EXEC
998 PATH_EXEC
999 #else
1000 0
1001 #endif
1002 );
1003 }
1004
1005 if (NILP (Vexec_path))
1006 Vexec_directory = Qnil;
1007 else
1008 Vexec_directory = Ffile_name_as_directory
1009 (Fcar (Vexec_path));
1010
1011 if (initialized)
1012 Vexec_path = nconc2 (decode_env_path ("PATH", 0),
1013 Vexec_path);
1014
1015 if (!NILP (Vexec_directory))
1016 {
1017 tempdir = Fdirectory_file_name (Vexec_directory);
1018 if (access ((char *) string_data (XSTRING (tempdir)), 0) < 0)
1019 {
1020 /* If the hard-coded path is bogus, fail silently.
1021 This will allow the normal heuristics to make an attempt. */
1022 #if 0
1023 warn_when_safe
1024 (Qpath, Qwarning,
1025 "Warning: machine-dependent data dir (%s) does not exist.\n",
1026 string_data (XSTRING (Vexec_directory)));
1027 #else
1028 Vexec_directory = Qnil;
1029 #endif
1030 }
1031 }
1032
1033 if (!NILP (Vdata_directory))
1034 {
1035 tempdir = Fdirectory_file_name (Vdata_directory);
1036 if (access ((char *) string_data (XSTRING (tempdir)), 0) < 0)
1037 {
1038 /* If the hard-coded path is bogus, fail silently.
1039 This will allow the normal heuristics to make an attempt. */
1040 #if 0
1041 warn_when_safe
1042 (Qpath, Qwarning,
1043 "Warning: machine-independent data dir (%s) does not exist.\n",
1044 string_data (XSTRING (Vdata_directory)));
1045 #else
1046 Vdata_directory = Qnil;
1047 #endif
1048 }
1049 }
1050
1051 #ifdef PATH_PREFIX
1052 Vprefix_directory = build_string ((char *) PATH_PREFIX);
1053 #else
1054 Vprefix_directory = Qnil;
1055 #endif
1056
1057 #ifdef VMS
1058 Vshell_file_name = build_string ("*dcl*");
1059 #else /* not VMS */
1060 sh = (char *) egetenv ("SHELL");
1061 #ifdef DOS_NT
1062 if (!sh) sh = egetenv ("COMSPEC");
1063 {
1064 char *tem;
1065 if (sh)
1066 {
1067 tem = (char *) alloca (strlen (sh) + 1);
1068 sh = dostounix_filename (strcpy (tem, sh));
1069 }
1070 }
1071 Vshell_file_name = build_string (sh ? sh : "/command.com");
1072 #else /* not DOS_NT */
1073 Vshell_file_name = build_string (sh ? sh : "/bin/sh");
1074 #endif /* not DOS_NT */
1075 #endif /* not VMS */
1076 }
1077
1078 #if 0
1079 void
1080 set_process_environment (void)
1081 {
1082 REGISTER char **envp;
1083
1084 Vprocess_environment = Qnil;
1085 #ifndef CANNOT_DUMP
1086 if (initialized)
1087 #endif
1088 for (envp = environ; *envp; envp++)
1089 Vprocess_environment = Fcons (build_string (*envp),
1090 Vprocess_environment);
1091 }
1092 #endif /* unused */
1093
1094 void
1095 syms_of_callproc (void)
1096 {
1097 #ifndef VMS
1098 defsubr (&Scall_process_internal);
1099 defsubr (&Sgetenv);
1100 #endif
1101 }
1102
1103 void
1104 vars_of_callproc (void)
1105 {
1106 /* This function can GC */
1107 #ifdef DOS_NT
1108 DEFVAR_LISP ("binary-process-input", &Vbinary_process_input /*
1109 *If non-nil then new subprocesses are assumed to take binary input.
1110 */ );
1111 Vbinary_process_input = Qnil;
1112
1113 DEFVAR_LISP ("binary-process-output", &Vbinary_process_output /*
1114 *If non-nil then new subprocesses are assumed to produce binary output.
1115 */ );
1116 Vbinary_process_output = Qnil;
1117 #endif /* DOS_NT */
1118
1119 DEFVAR_LISP ("shell-file-name", &Vshell_file_name /*
1120 *File name to load inferior shells from.
1121 Initialized from the SHELL environment variable.
1122 */ );
1123
1124 DEFVAR_LISP ("exec-path", &Vexec_path /*
1125 *List of directories to search programs to run in subprocesses.
1126 Each element is a string (directory name) or nil (try default directory).
1127 */ );
1128
1129 DEFVAR_LISP ("exec-directory", &Vexec_directory /*
1130 Directory of architecture-dependent files that come with XEmacs,
1131 especially executable programs intended for Emacs to invoke.
1132 */ );
1133
1134 DEFVAR_LISP ("data-directory", &Vdata_directory /*
1135 Directory of architecture-independent files that come with XEmacs,
1136 intended for Emacs to use.
1137 */ );
1138
1139 /* FSF puts the DOC file into data-directory. They do a bunch of
1140 contortions to attempt to put everything into the DOC file
1141 whether the support is there or not. */
1142 DEFVAR_LISP ("doc-directory", &Vdoc_directory /*
1143 Directory containing the DOC file that comes with XEmacs.
1144 This is usually the same as exec-directory.
1145 */ );
1146
1147 DEFVAR_LISP ("prefix-directory", &Vprefix_directory /*
1148 The default directory under which XEmacs is installed.
1149 */ );
1150
1151 DEFVAR_LISP ("process-environment", &Vprocess_environment /*
1152 List of environment variables for subprocesses to inherit.
1153 Each element should be a string of the form ENVVARNAME=VALUE.
1154 The environment which Emacs inherits is placed in this variable
1155 when Emacs starts.
1156 */ );
1157 }
1158
1159 void
1160 complex_vars_of_callproc (void)
1161 {
1162 DEFVAR_LISP ("configure-info-directory", &Vconfigure_info_directory /*
1163 For internal use by the build procedure only.
1164 This is the name of the directory in which the build procedure installed
1165 Emacs's info files; the default value for Info-default-directory-list
1166 includes this.
1167 */ );
1168 #ifdef PATH_INFO
1169 Vconfigure_info_directory =
1170 Ffile_name_as_directory (build_string (PATH_INFO));
1171 #else
1172 Vconfigure_info_directory = Qnil;
1173 #endif
1174 }