]> code.delx.au - gnu-emacs/blob - src/callproc.c
Merge from emacs-24 branch; up to 2012-05-01T18:47:23Z!rgm@gnu.org
[gnu-emacs] / src / callproc.c
1 /* Synchronous subprocess invocation for GNU Emacs.
2 Copyright (C) 1985-1988, 1993-1995, 1999-2012
3 Free Software Foundation, Inc.
4
5 This file is part of GNU Emacs.
6
7 GNU Emacs is free software: you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation, either version 3 of the License, or
10 (at your option) any later version.
11
12 GNU Emacs is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
16
17 You should have received a copy of the GNU General Public License
18 along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
19
20
21 #include <config.h>
22 #include <signal.h>
23 #include <errno.h>
24 #include <stdio.h>
25 #include <setjmp.h>
26 #include <sys/types.h>
27 #include <unistd.h>
28
29 #include <sys/file.h>
30 #include <fcntl.h>
31
32 #include "lisp.h"
33
34 #ifdef WINDOWSNT
35 #define NOMINMAX
36 #include <windows.h>
37 #include "w32.h"
38 #define _P_NOWAIT 1 /* from process.h */
39 #endif
40
41 #ifdef MSDOS /* Demacs 1.1.1 91/10/16 HIRANO Satoshi */
42 #include <sys/stat.h>
43 #include <sys/param.h>
44 #endif /* MSDOS */
45
46 #include "commands.h"
47 #include "character.h"
48 #include "buffer.h"
49 #include "ccl.h"
50 #include "coding.h"
51 #include "composite.h"
52 #include <epaths.h>
53 #include "process.h"
54 #include "syssignal.h"
55 #include "systty.h"
56 #include "blockinput.h"
57 #include "frame.h"
58 #include "termhooks.h"
59
60 #ifdef MSDOS
61 #include "msdos.h"
62 #endif
63
64 #ifdef HAVE_NS
65 #include "nsterm.h"
66 #endif
67
68 #ifndef USE_CRT_DLL
69 extern char **environ;
70 #endif
71
72 #ifdef HAVE_SETPGID
73 #if !defined (USG)
74 #undef setpgrp
75 #define setpgrp setpgid
76 #endif
77 #endif
78
79 /* Pattern used by call-process-region to make temp files. */
80 static Lisp_Object Vtemp_file_name_pattern;
81
82 /* True if we are about to fork off a synchronous process or if we
83 are waiting for it. */
84 int synch_process_alive;
85
86 /* Nonzero => this is a string explaining death of synchronous subprocess. */
87 const char *synch_process_death;
88
89 /* Nonzero => this is the signal number that terminated the subprocess. */
90 int synch_process_termsig;
91
92 /* If synch_process_death is zero,
93 this is exit code of synchronous subprocess. */
94 int synch_process_retcode;
95
96 \f
97 /* Clean up when exiting Fcall_process.
98 On MSDOS, delete the temporary file on any kind of termination.
99 On Unix, kill the process and any children on termination by signal. */
100
101 /* Nonzero if this is termination due to exit. */
102 static int call_process_exited;
103
104 static Lisp_Object
105 call_process_kill (Lisp_Object fdpid)
106 {
107 int fd;
108 pid_t pid;
109 CONS_TO_INTEGER (Fcar (fdpid), int, fd);
110 CONS_TO_INTEGER (Fcdr (fdpid), pid_t, pid);
111 emacs_close (fd);
112 EMACS_KILLPG (pid, SIGKILL);
113 synch_process_alive = 0;
114 return Qnil;
115 }
116
117 static Lisp_Object
118 call_process_cleanup (Lisp_Object arg)
119 {
120 Lisp_Object fdpid = Fcdr (arg);
121 int fd;
122 #if defined (MSDOS)
123 Lisp_Object file;
124 #else
125 pid_t pid;
126 #endif
127
128 Fset_buffer (Fcar (arg));
129 CONS_TO_INTEGER (Fcar (fdpid), int, fd);
130
131 #if defined (MSDOS)
132 /* for MSDOS fdpid is really (fd . tempfile) */
133 file = Fcdr (fdpid);
134 /* FD is -1 and FILE is "" when we didn't actually create a
135 temporary file in call-process. */
136 if (fd >= 0)
137 emacs_close (fd);
138 if (!(strcmp (SDATA (file), NULL_DEVICE) == 0 || SREF (file, 0) == '\0'))
139 unlink (SDATA (file));
140 #else /* not MSDOS */
141 CONS_TO_INTEGER (Fcdr (fdpid), pid_t, pid);
142
143 if (call_process_exited)
144 {
145 emacs_close (fd);
146 return Qnil;
147 }
148
149 if (EMACS_KILLPG (pid, SIGINT) == 0)
150 {
151 ptrdiff_t count = SPECPDL_INDEX ();
152 record_unwind_protect (call_process_kill, fdpid);
153 message1 ("Waiting for process to die...(type C-g again to kill it instantly)");
154 immediate_quit = 1;
155 QUIT;
156 wait_for_termination (pid);
157 immediate_quit = 0;
158 specpdl_ptr = specpdl + count; /* Discard the unwind protect. */
159 message1 ("Waiting for process to die...done");
160 }
161 synch_process_alive = 0;
162 emacs_close (fd);
163 #endif /* not MSDOS */
164 return Qnil;
165 }
166
167 DEFUN ("call-process", Fcall_process, Scall_process, 1, MANY, 0,
168 doc: /* Call PROGRAM synchronously in separate process.
169 The remaining arguments are optional.
170 The program's input comes from file INFILE (nil means `/dev/null').
171 Insert output in BUFFER before point; t means current buffer; nil for BUFFER
172 means discard it; 0 means discard and don't wait; and `(:file FILE)', where
173 FILE is a file name string, means that it should be written to that file
174 \(if the file already exists it is overwritten).
175 BUFFER can also have the form (REAL-BUFFER STDERR-FILE); in that case,
176 REAL-BUFFER says what to do with standard output, as above,
177 while STDERR-FILE says what to do with standard error in the child.
178 STDERR-FILE may be nil (discard standard error output),
179 t (mix it with ordinary output), or a file name string.
180
181 Fourth arg DISPLAY non-nil means redisplay buffer as output is inserted.
182 Remaining arguments are strings passed as command arguments to PROGRAM.
183
184 If executable PROGRAM can't be found as an executable, `call-process'
185 signals a Lisp error. `call-process' reports errors in execution of
186 the program only through its return and output.
187
188 If BUFFER is 0, `call-process' returns immediately with value nil.
189 Otherwise it waits for PROGRAM to terminate
190 and returns a numeric exit status or a signal description string.
191 If you quit, the process is killed with SIGINT, or SIGKILL if you quit again.
192
193 usage: (call-process PROGRAM &optional INFILE BUFFER DISPLAY &rest ARGS) */)
194 (ptrdiff_t nargs, Lisp_Object *args)
195 {
196 Lisp_Object infile, buffer, current_dir, path, cleanup_info_tail;
197 int display_p;
198 int fd[2];
199 int filefd;
200 #define CALLPROC_BUFFER_SIZE_MIN (16 * 1024)
201 #define CALLPROC_BUFFER_SIZE_MAX (4 * CALLPROC_BUFFER_SIZE_MIN)
202 char buf[CALLPROC_BUFFER_SIZE_MAX];
203 int bufsize = CALLPROC_BUFFER_SIZE_MIN;
204 ptrdiff_t count = SPECPDL_INDEX ();
205 USE_SAFE_ALLOCA;
206
207 register const unsigned char **new_argv;
208 /* File to use for stderr in the child.
209 t means use same as standard output. */
210 Lisp_Object error_file;
211 Lisp_Object output_file = Qnil;
212 #ifdef MSDOS /* Demacs 1.1.1 91/10/16 HIRANO Satoshi */
213 char *outf, *tempfile = NULL;
214 int outfilefd;
215 int pid;
216 #else
217 pid_t pid;
218 #endif
219 int fd_output = -1;
220 struct coding_system process_coding; /* coding-system of process output */
221 struct coding_system argument_coding; /* coding-system of arguments */
222 /* Set to the return value of Ffind_operation_coding_system. */
223 Lisp_Object coding_systems;
224 int output_to_buffer = 1;
225
226 /* Qt denotes that Ffind_operation_coding_system is not yet called. */
227 coding_systems = Qt;
228
229 CHECK_STRING (args[0]);
230
231 error_file = Qt;
232
233 #ifndef subprocesses
234 /* Without asynchronous processes we cannot have BUFFER == 0. */
235 if (nargs >= 3
236 && (INTEGERP (CONSP (args[2]) ? XCAR (args[2]) : args[2])))
237 error ("Operating system cannot handle asynchronous subprocesses");
238 #endif /* subprocesses */
239
240 /* Decide the coding-system for giving arguments. */
241 {
242 Lisp_Object val, *args2;
243 ptrdiff_t i;
244
245 /* If arguments are supplied, we may have to encode them. */
246 if (nargs >= 5)
247 {
248 int must_encode = 0;
249 Lisp_Object coding_attrs;
250
251 for (i = 4; i < nargs; i++)
252 CHECK_STRING (args[i]);
253
254 for (i = 4; i < nargs; i++)
255 if (STRING_MULTIBYTE (args[i]))
256 must_encode = 1;
257
258 if (!NILP (Vcoding_system_for_write))
259 val = Vcoding_system_for_write;
260 else if (! must_encode)
261 val = Qraw_text;
262 else
263 {
264 SAFE_NALLOCA (args2, 1, nargs + 1);
265 args2[0] = Qcall_process;
266 for (i = 0; i < nargs; i++) args2[i + 1] = args[i];
267 coding_systems = Ffind_operation_coding_system (nargs + 1, args2);
268 val = CONSP (coding_systems) ? XCDR (coding_systems) : Qnil;
269 }
270 val = complement_process_encoding_system (val);
271 setup_coding_system (Fcheck_coding_system (val), &argument_coding);
272 coding_attrs = CODING_ID_ATTRS (argument_coding.id);
273 if (NILP (CODING_ATTR_ASCII_COMPAT (coding_attrs)))
274 {
275 /* We should not use an ASCII incompatible coding system. */
276 val = raw_text_coding_system (val);
277 setup_coding_system (val, &argument_coding);
278 }
279 }
280 }
281
282 if (nargs >= 2 && ! NILP (args[1]))
283 {
284 infile = Fexpand_file_name (args[1], BVAR (current_buffer, directory));
285 CHECK_STRING (infile);
286 }
287 else
288 infile = build_string (NULL_DEVICE);
289
290 if (nargs >= 3)
291 {
292 buffer = args[2];
293
294 /* If BUFFER is a list, its meaning is (BUFFER-FOR-STDOUT
295 FILE-FOR-STDERR), unless the first element is :file, in which case see
296 the next paragraph. */
297 if (CONSP (buffer)
298 && (! SYMBOLP (XCAR (buffer))
299 || strcmp (SSDATA (SYMBOL_NAME (XCAR (buffer))), ":file")))
300 {
301 if (CONSP (XCDR (buffer)))
302 {
303 Lisp_Object stderr_file;
304 stderr_file = XCAR (XCDR (buffer));
305
306 if (NILP (stderr_file) || EQ (Qt, stderr_file))
307 error_file = stderr_file;
308 else
309 error_file = Fexpand_file_name (stderr_file, Qnil);
310 }
311
312 buffer = XCAR (buffer);
313 }
314
315 /* If the buffer is (still) a list, it might be a (:file "file") spec. */
316 if (CONSP (buffer)
317 && SYMBOLP (XCAR (buffer))
318 && ! strcmp (SSDATA (SYMBOL_NAME (XCAR (buffer))), ":file"))
319 {
320 output_file = Fexpand_file_name (XCAR (XCDR (buffer)),
321 BVAR (current_buffer, directory));
322 CHECK_STRING (output_file);
323 buffer = Qnil;
324 }
325
326 if (!(EQ (buffer, Qnil)
327 || EQ (buffer, Qt)
328 || INTEGERP (buffer)))
329 {
330 Lisp_Object spec_buffer;
331 spec_buffer = buffer;
332 buffer = Fget_buffer_create (buffer);
333 /* Mention the buffer name for a better error message. */
334 if (NILP (buffer))
335 CHECK_BUFFER (spec_buffer);
336 CHECK_BUFFER (buffer);
337 }
338 }
339 else
340 buffer = Qnil;
341
342 /* Make sure that the child will be able to chdir to the current
343 buffer's current directory, or its unhandled equivalent. We
344 can't just have the child check for an error when it does the
345 chdir, since it's in a vfork.
346
347 We have to GCPRO around this because Fexpand_file_name,
348 Funhandled_file_name_directory, and Ffile_accessible_directory_p
349 might call a file name handling function. The argument list is
350 protected by the caller, so all we really have to worry about is
351 buffer. */
352 {
353 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5;
354
355 current_dir = BVAR (current_buffer, directory);
356
357 GCPRO5 (infile, buffer, current_dir, error_file, output_file);
358
359 current_dir = Funhandled_file_name_directory (current_dir);
360 if (NILP (current_dir))
361 /* If the file name handler says that current_dir is unreachable, use
362 a sensible default. */
363 current_dir = build_string ("~/");
364 current_dir = expand_and_dir_to_file (current_dir, Qnil);
365 current_dir = Ffile_name_as_directory (current_dir);
366
367 if (NILP (Ffile_accessible_directory_p (current_dir)))
368 report_file_error ("Setting current directory",
369 Fcons (BVAR (current_buffer, directory), Qnil));
370
371 if (STRING_MULTIBYTE (infile))
372 infile = ENCODE_FILE (infile);
373 if (STRING_MULTIBYTE (current_dir))
374 current_dir = ENCODE_FILE (current_dir);
375 if (STRINGP (error_file) && STRING_MULTIBYTE (error_file))
376 error_file = ENCODE_FILE (error_file);
377 if (STRINGP (output_file) && STRING_MULTIBYTE (output_file))
378 output_file = ENCODE_FILE (output_file);
379 UNGCPRO;
380 }
381
382 display_p = INTERACTIVE && nargs >= 4 && !NILP (args[3]);
383
384 filefd = emacs_open (SSDATA (infile), O_RDONLY, 0);
385 if (filefd < 0)
386 {
387 infile = DECODE_FILE (infile);
388 report_file_error ("Opening process input file", Fcons (infile, Qnil));
389 }
390
391 if (STRINGP (output_file))
392 {
393 #ifdef DOS_NT
394 fd_output = emacs_open (SSDATA (output_file),
395 O_WRONLY | O_TRUNC | O_CREAT | O_TEXT,
396 S_IREAD | S_IWRITE);
397 #else /* not DOS_NT */
398 fd_output = creat (SSDATA (output_file), 0666);
399 #endif /* not DOS_NT */
400 if (fd_output < 0)
401 {
402 output_file = DECODE_FILE (output_file);
403 report_file_error ("Opening process output file",
404 Fcons (output_file, Qnil));
405 }
406 if (STRINGP (error_file) || NILP (error_file))
407 output_to_buffer = 0;
408 }
409
410 /* Search for program; barf if not found. */
411 {
412 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
413
414 GCPRO4 (infile, buffer, current_dir, error_file);
415 openp (Vexec_path, args[0], Vexec_suffixes, &path, make_number (X_OK));
416 UNGCPRO;
417 }
418 if (NILP (path))
419 {
420 emacs_close (filefd);
421 report_file_error ("Searching for program", Fcons (args[0], Qnil));
422 }
423
424 /* If program file name starts with /: for quoting a magic name,
425 discard that. */
426 if (SBYTES (path) > 2 && SREF (path, 0) == '/'
427 && SREF (path, 1) == ':')
428 path = Fsubstring (path, make_number (2), Qnil);
429
430 SAFE_ALLOCA (new_argv, const unsigned char **,
431 (nargs > 4 ? nargs - 2 : 2) * sizeof *new_argv);
432 if (nargs > 4)
433 {
434 ptrdiff_t i;
435 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5;
436
437 GCPRO5 (infile, buffer, current_dir, path, error_file);
438 argument_coding.dst_multibyte = 0;
439 for (i = 4; i < nargs; i++)
440 {
441 argument_coding.src_multibyte = STRING_MULTIBYTE (args[i]);
442 if (CODING_REQUIRE_ENCODING (&argument_coding))
443 /* We must encode this argument. */
444 args[i] = encode_coding_string (&argument_coding, args[i], 1);
445 }
446 UNGCPRO;
447 for (i = 4; i < nargs; i++)
448 new_argv[i - 3] = SDATA (args[i]);
449 new_argv[i - 3] = 0;
450 }
451 else
452 new_argv[1] = 0;
453 new_argv[0] = SDATA (path);
454
455 #ifdef MSDOS /* MW, July 1993 */
456
457 /* If we're redirecting STDOUT to a file, that file is already open
458 on fd_output. */
459 if (fd_output < 0)
460 {
461 if ((outf = egetenv ("TMPDIR")))
462 strcpy (tempfile = alloca (strlen (outf) + 20), outf);
463 else
464 {
465 tempfile = alloca (20);
466 *tempfile = '\0';
467 }
468 dostounix_filename (tempfile);
469 if (*tempfile == '\0' || tempfile[strlen (tempfile) - 1] != '/')
470 strcat (tempfile, "/");
471 strcat (tempfile, "detmp.XXX");
472 mktemp (tempfile);
473 outfilefd = creat (tempfile, S_IREAD | S_IWRITE);
474 if (outfilefd < 0) {
475 emacs_close (filefd);
476 report_file_error ("Opening process output file",
477 Fcons (build_string (tempfile), Qnil));
478 }
479 }
480 else
481 outfilefd = fd_output;
482 fd[0] = filefd;
483 fd[1] = outfilefd;
484 #endif /* MSDOS */
485
486 if (INTEGERP (buffer))
487 fd[1] = emacs_open (NULL_DEVICE, O_WRONLY, 0), fd[0] = -1;
488 else
489 {
490 #ifndef MSDOS
491 errno = 0;
492 if (pipe (fd) == -1)
493 {
494 emacs_close (filefd);
495 report_file_error ("Creating process pipe", Qnil);
496 }
497 #endif
498 }
499
500 {
501 /* child_setup must clobber environ in systems with true vfork.
502 Protect it from permanent change. */
503 register char **save_environ = environ;
504 register int fd1 = fd[1];
505 int fd_error = fd1;
506 #ifdef HAVE_WORKING_VFORK
507 sigset_t procmask;
508 sigset_t blocked;
509 struct sigaction sigpipe_action;
510 #endif
511
512 if (fd_output >= 0)
513 fd1 = fd_output;
514 #if 0 /* Some systems don't have sigblock. */
515 mask = sigblock (sigmask (SIGCHLD));
516 #endif
517
518 /* Record that we're about to create a synchronous process. */
519 synch_process_alive = 1;
520
521 /* These vars record information from process termination.
522 Clear them now before process can possibly terminate,
523 to avoid timing error if process terminates soon. */
524 synch_process_death = 0;
525 synch_process_retcode = 0;
526 synch_process_termsig = 0;
527
528 if (NILP (error_file))
529 fd_error = emacs_open (NULL_DEVICE, O_WRONLY, 0);
530 else if (STRINGP (error_file))
531 {
532 #ifdef DOS_NT
533 fd_error = emacs_open (SSDATA (error_file),
534 O_WRONLY | O_TRUNC | O_CREAT | O_TEXT,
535 S_IREAD | S_IWRITE);
536 #else /* not DOS_NT */
537 fd_error = creat (SSDATA (error_file), 0666);
538 #endif /* not DOS_NT */
539 }
540
541 if (fd_error < 0)
542 {
543 emacs_close (filefd);
544 if (fd[0] != filefd)
545 emacs_close (fd[0]);
546 if (fd1 >= 0)
547 emacs_close (fd1);
548 #ifdef MSDOS
549 unlink (tempfile);
550 #endif
551 if (NILP (error_file))
552 error_file = build_string (NULL_DEVICE);
553 else if (STRINGP (error_file))
554 error_file = DECODE_FILE (error_file);
555 report_file_error ("Cannot redirect stderr", Fcons (error_file, Qnil));
556 }
557
558 #ifdef MSDOS /* MW, July 1993 */
559 /* Note that on MSDOS `child_setup' actually returns the child process
560 exit status, not its PID, so we assign it to `synch_process_retcode'
561 below. */
562 pid = child_setup (filefd, outfilefd, fd_error, (char **) new_argv,
563 0, current_dir);
564
565 /* Record that the synchronous process exited and note its
566 termination status. */
567 synch_process_alive = 0;
568 synch_process_retcode = pid;
569 if (synch_process_retcode < 0) /* means it couldn't be exec'ed */
570 {
571 synchronize_system_messages_locale ();
572 synch_process_death = strerror (errno);
573 }
574
575 emacs_close (outfilefd);
576 if (fd_error != outfilefd)
577 emacs_close (fd_error);
578 fd1 = -1; /* No harm in closing that one! */
579 if (tempfile)
580 {
581 /* Since CRLF is converted to LF within `decode_coding', we
582 can always open a file with binary mode. */
583 fd[0] = emacs_open (tempfile, O_RDONLY | O_BINARY, 0);
584 if (fd[0] < 0)
585 {
586 unlink (tempfile);
587 emacs_close (filefd);
588 report_file_error ("Cannot re-open temporary file",
589 Fcons (build_string (tempfile), Qnil));
590 }
591 }
592 else
593 fd[0] = -1; /* We are not going to read from tempfile. */
594 #else /* not MSDOS */
595 #ifdef WINDOWSNT
596 pid = child_setup (filefd, fd1, fd_error, (char **) new_argv,
597 0, current_dir);
598 #else /* not WINDOWSNT */
599
600 #ifdef HAVE_WORKING_VFORK
601 /* On many hosts (e.g. Solaris 2.4), if a vforked child calls `signal',
602 this sets the parent's signal handlers as well as the child's.
603 So delay all interrupts whose handlers the child might munge,
604 and record the current handlers so they can be restored later. */
605 sigemptyset (&blocked);
606 sigaddset (&blocked, SIGPIPE);
607 sigaction (SIGPIPE, 0, &sigpipe_action);
608 pthread_sigmask (SIG_BLOCK, &blocked, &procmask);
609 #endif
610
611 BLOCK_INPUT;
612
613 /* vfork, and prevent local vars from being clobbered by the vfork. */
614 {
615 Lisp_Object volatile buffer_volatile = buffer;
616 Lisp_Object volatile coding_systems_volatile = coding_systems;
617 Lisp_Object volatile current_dir_volatile = current_dir;
618 int volatile display_p_volatile = display_p;
619 int volatile fd1_volatile = fd1;
620 int volatile fd_error_volatile = fd_error;
621 int volatile fd_output_volatile = fd_output;
622 int volatile output_to_buffer_volatile = output_to_buffer;
623 int volatile sa_must_free_volatile = sa_must_free;
624 ptrdiff_t volatile sa_count_volatile = sa_count;
625 unsigned char const **volatile new_argv_volatile = new_argv;
626
627 pid = vfork ();
628
629 buffer = buffer_volatile;
630 coding_systems = coding_systems_volatile;
631 current_dir = current_dir_volatile;
632 display_p = display_p_volatile;
633 fd1 = fd1_volatile;
634 fd_error = fd_error_volatile;
635 fd_output = fd_output_volatile;
636 output_to_buffer = output_to_buffer_volatile;
637 sa_must_free = sa_must_free_volatile;
638 sa_count = sa_count_volatile;
639 new_argv = new_argv_volatile;
640 }
641
642 if (pid == 0)
643 {
644 if (fd[0] >= 0)
645 emacs_close (fd[0]);
646 #ifdef HAVE_SETSID
647 setsid ();
648 #endif
649 #if defined (USG)
650 setpgrp ();
651 #else
652 setpgrp (pid, pid);
653 #endif /* USG */
654
655 /* GConf causes us to ignore SIGPIPE, make sure it is restored
656 in the child. */
657 signal (SIGPIPE, SIG_DFL);
658 #ifdef HAVE_WORKING_VFORK
659 pthread_sigmask (SIG_SETMASK, &procmask, 0);
660 #endif
661
662 child_setup (filefd, fd1, fd_error, (char **) new_argv,
663 0, current_dir);
664 }
665
666 UNBLOCK_INPUT;
667
668 #ifdef HAVE_WORKING_VFORK
669 /* Restore the signal state. */
670 sigaction (SIGPIPE, &sigpipe_action, 0);
671 pthread_sigmask (SIG_SETMASK, &procmask, 0);
672 #endif
673
674 #endif /* not WINDOWSNT */
675
676 /* The MSDOS case did this already. */
677 if (fd_error >= 0)
678 emacs_close (fd_error);
679 #endif /* not MSDOS */
680
681 environ = save_environ;
682
683 /* Close most of our fd's, but not fd[0]
684 since we will use that to read input from. */
685 emacs_close (filefd);
686 if (fd_output >= 0)
687 emacs_close (fd_output);
688 if (fd1 >= 0 && fd1 != fd_error)
689 emacs_close (fd1);
690 }
691
692 if (pid < 0)
693 {
694 if (fd[0] >= 0)
695 emacs_close (fd[0]);
696 report_file_error ("Doing vfork", Qnil);
697 }
698
699 if (INTEGERP (buffer))
700 {
701 if (fd[0] >= 0)
702 emacs_close (fd[0]);
703 return Qnil;
704 }
705
706 /* Enable sending signal if user quits below. */
707 call_process_exited = 0;
708
709 #if defined (MSDOS)
710 /* MSDOS needs different cleanup information. */
711 cleanup_info_tail = build_string (tempfile ? tempfile : "");
712 #else
713 cleanup_info_tail = INTEGER_TO_CONS (pid);
714 #endif /* not MSDOS */
715 record_unwind_protect (call_process_cleanup,
716 Fcons (Fcurrent_buffer (),
717 Fcons (INTEGER_TO_CONS (fd[0]),
718 cleanup_info_tail)));
719
720 if (BUFFERP (buffer))
721 Fset_buffer (buffer);
722
723 if (NILP (buffer))
724 {
725 /* If BUFFER is nil, we must read process output once and then
726 discard it, so setup coding system but with nil. */
727 setup_coding_system (Qnil, &process_coding);
728 process_coding.dst_multibyte = 0;
729 }
730 else
731 {
732 Lisp_Object val, *args2;
733
734 val = Qnil;
735 if (!NILP (Vcoding_system_for_read))
736 val = Vcoding_system_for_read;
737 else
738 {
739 if (EQ (coding_systems, Qt))
740 {
741 ptrdiff_t i;
742
743 SAFE_NALLOCA (args2, 1, nargs + 1);
744 args2[0] = Qcall_process;
745 for (i = 0; i < nargs; i++) args2[i + 1] = args[i];
746 coding_systems
747 = Ffind_operation_coding_system (nargs + 1, args2);
748 }
749 if (CONSP (coding_systems))
750 val = XCAR (coding_systems);
751 else if (CONSP (Vdefault_process_coding_system))
752 val = XCAR (Vdefault_process_coding_system);
753 else
754 val = Qnil;
755 }
756 Fcheck_coding_system (val);
757 /* In unibyte mode, character code conversion should not take
758 place but EOL conversion should. So, setup raw-text or one
759 of the subsidiary according to the information just setup. */
760 if (NILP (BVAR (current_buffer, enable_multibyte_characters))
761 && !NILP (val))
762 val = raw_text_coding_system (val);
763 setup_coding_system (val, &process_coding);
764 process_coding.dst_multibyte
765 = ! NILP (BVAR (current_buffer, enable_multibyte_characters));
766 }
767 process_coding.src_multibyte = 0;
768
769 immediate_quit = 1;
770 QUIT;
771
772 if (output_to_buffer)
773 {
774 register int nread;
775 int first = 1;
776 EMACS_INT total_read = 0;
777 int carryover = 0;
778 int display_on_the_fly = display_p;
779 struct coding_system saved_coding;
780
781 saved_coding = process_coding;
782 while (1)
783 {
784 /* Repeatedly read until we've filled as much as possible
785 of the buffer size we have. But don't read
786 less than 1024--save that for the next bufferful. */
787 nread = carryover;
788 while (nread < bufsize - 1024)
789 {
790 int this_read = emacs_read (fd[0], buf + nread,
791 bufsize - nread);
792
793 if (this_read < 0)
794 goto give_up;
795
796 if (this_read == 0)
797 {
798 process_coding.mode |= CODING_MODE_LAST_BLOCK;
799 break;
800 }
801
802 nread += this_read;
803 total_read += this_read;
804
805 if (display_on_the_fly)
806 break;
807 }
808
809 /* Now NREAD is the total amount of data in the buffer. */
810 immediate_quit = 0;
811
812 if (!NILP (buffer))
813 {
814 if (NILP (BVAR (current_buffer, enable_multibyte_characters))
815 && ! CODING_MAY_REQUIRE_DECODING (&process_coding))
816 insert_1_both (buf, nread, nread, 0, 1, 0);
817 else
818 { /* We have to decode the input. */
819 Lisp_Object curbuf;
820 ptrdiff_t count1 = SPECPDL_INDEX ();
821
822 XSETBUFFER (curbuf, current_buffer);
823 /* We cannot allow after-change-functions be run
824 during decoding, because that might modify the
825 buffer, while we rely on process_coding.produced to
826 faithfully reflect inserted text until we
827 TEMP_SET_PT_BOTH below. */
828 specbind (Qinhibit_modification_hooks, Qt);
829 decode_coding_c_string (&process_coding,
830 (unsigned char *) buf, nread, curbuf);
831 unbind_to (count1, Qnil);
832 if (display_on_the_fly
833 && CODING_REQUIRE_DETECTION (&saved_coding)
834 && ! CODING_REQUIRE_DETECTION (&process_coding))
835 {
836 /* We have detected some coding system. But,
837 there's a possibility that the detection was
838 done by insufficient data. So, we give up
839 displaying on the fly. */
840 if (process_coding.produced > 0)
841 del_range_2 (process_coding.dst_pos,
842 process_coding.dst_pos_byte,
843 process_coding.dst_pos
844 + process_coding.produced_char,
845 process_coding.dst_pos_byte
846 + process_coding.produced, 0);
847 display_on_the_fly = 0;
848 process_coding = saved_coding;
849 carryover = nread;
850 /* This is to make the above condition always
851 fails in the future. */
852 saved_coding.common_flags
853 &= ~CODING_REQUIRE_DETECTION_MASK;
854 continue;
855 }
856
857 TEMP_SET_PT_BOTH (PT + process_coding.produced_char,
858 PT_BYTE + process_coding.produced);
859 carryover = process_coding.carryover_bytes;
860 if (carryover > 0)
861 memcpy (buf, process_coding.carryover,
862 process_coding.carryover_bytes);
863 }
864 }
865
866 if (process_coding.mode & CODING_MODE_LAST_BLOCK)
867 break;
868
869 /* Make the buffer bigger as we continue to read more data,
870 but not past CALLPROC_BUFFER_SIZE_MAX. */
871 if (bufsize < CALLPROC_BUFFER_SIZE_MAX && total_read > 32 * bufsize)
872 if ((bufsize *= 2) > CALLPROC_BUFFER_SIZE_MAX)
873 bufsize = CALLPROC_BUFFER_SIZE_MAX;
874
875 if (display_p)
876 {
877 if (first)
878 prepare_menu_bars ();
879 first = 0;
880 redisplay_preserve_echo_area (1);
881 /* This variable might have been set to 0 for code
882 detection. In that case, we set it back to 1 because
883 we should have already detected a coding system. */
884 display_on_the_fly = 1;
885 }
886 immediate_quit = 1;
887 QUIT;
888 }
889 give_up: ;
890
891 Vlast_coding_system_used = CODING_ID_NAME (process_coding.id);
892 /* If the caller required, let the buffer inherit the
893 coding-system used to decode the process output. */
894 if (inherit_process_coding_system)
895 call1 (intern ("after-insert-file-set-buffer-file-coding-system"),
896 make_number (total_read));
897 }
898
899 #ifndef MSDOS
900 /* Wait for it to terminate, unless it already has. */
901 if (output_to_buffer)
902 wait_for_termination (pid);
903 else
904 interruptible_wait_for_termination (pid);
905 #endif
906
907 immediate_quit = 0;
908
909 /* Don't kill any children that the subprocess may have left behind
910 when exiting. */
911 call_process_exited = 1;
912
913 SAFE_FREE ();
914 unbind_to (count, Qnil);
915
916 if (synch_process_termsig)
917 {
918 const char *signame;
919
920 synchronize_system_messages_locale ();
921 signame = strsignal (synch_process_termsig);
922
923 if (signame == 0)
924 signame = "unknown";
925
926 synch_process_death = signame;
927 }
928
929 if (synch_process_death)
930 return code_convert_string_norecord (build_string (synch_process_death),
931 Vlocale_coding_system, 0);
932 return make_number (synch_process_retcode);
933 }
934 \f
935 static Lisp_Object
936 delete_temp_file (Lisp_Object name)
937 {
938 /* Suppress jka-compr handling, etc. */
939 ptrdiff_t count = SPECPDL_INDEX ();
940 specbind (intern ("file-name-handler-alist"), Qnil);
941 internal_delete_file (name);
942 unbind_to (count, Qnil);
943 return Qnil;
944 }
945
946 DEFUN ("call-process-region", Fcall_process_region, Scall_process_region,
947 3, MANY, 0,
948 doc: /* Send text from START to END to a synchronous process running PROGRAM.
949 The remaining arguments are optional.
950 Delete the text if fourth arg DELETE is non-nil.
951
952 Insert output in BUFFER before point; t means current buffer; nil for
953 BUFFER means discard it; 0 means discard and don't wait; and `(:file
954 FILE)', where FILE is a file name string, means that it should be
955 written to that file (if the file already exists it is overwritten).
956 BUFFER can also have the form (REAL-BUFFER STDERR-FILE); in that case,
957 REAL-BUFFER says what to do with standard output, as above,
958 while STDERR-FILE says what to do with standard error in the child.
959 STDERR-FILE may be nil (discard standard error output),
960 t (mix it with ordinary output), or a file name string.
961
962 Sixth arg DISPLAY non-nil means redisplay buffer as output is inserted.
963 Remaining args are passed to PROGRAM at startup as command args.
964
965 If BUFFER is 0, `call-process-region' returns immediately with value nil.
966 Otherwise it waits for PROGRAM to terminate
967 and returns a numeric exit status or a signal description string.
968 If you quit, the process is killed with SIGINT, or SIGKILL if you quit again.
969
970 usage: (call-process-region START END PROGRAM &optional DELETE BUFFER DISPLAY &rest ARGS) */)
971 (ptrdiff_t nargs, Lisp_Object *args)
972 {
973 struct gcpro gcpro1;
974 Lisp_Object filename_string;
975 register Lisp_Object start, end;
976 ptrdiff_t count = SPECPDL_INDEX ();
977 /* Qt denotes we have not yet called Ffind_operation_coding_system. */
978 Lisp_Object coding_systems;
979 Lisp_Object val, *args2;
980 ptrdiff_t i;
981 char *tempfile;
982 Lisp_Object tmpdir, pattern;
983
984 if (STRINGP (Vtemporary_file_directory))
985 tmpdir = Vtemporary_file_directory;
986 else
987 {
988 #ifndef DOS_NT
989 if (getenv ("TMPDIR"))
990 tmpdir = build_string (getenv ("TMPDIR"));
991 else
992 tmpdir = build_string ("/tmp/");
993 #else /* DOS_NT */
994 char *outf;
995 if ((outf = egetenv ("TMPDIR"))
996 || (outf = egetenv ("TMP"))
997 || (outf = egetenv ("TEMP")))
998 tmpdir = build_string (outf);
999 else
1000 tmpdir = Ffile_name_as_directory (build_string ("c:/temp"));
1001 #endif
1002 }
1003
1004 {
1005 USE_SAFE_ALLOCA;
1006 pattern = Fexpand_file_name (Vtemp_file_name_pattern, tmpdir);
1007 SAFE_ALLOCA (tempfile, char *, SBYTES (pattern) + 1);
1008 memcpy (tempfile, SDATA (pattern), SBYTES (pattern) + 1);
1009 coding_systems = Qt;
1010
1011 #ifdef HAVE_MKSTEMP
1012 {
1013 int fd;
1014
1015 BLOCK_INPUT;
1016 fd = mkstemp (tempfile);
1017 UNBLOCK_INPUT;
1018 if (fd == -1)
1019 report_file_error ("Failed to open temporary file",
1020 Fcons (build_string (tempfile), Qnil));
1021 else
1022 close (fd);
1023 }
1024 #else
1025 mktemp (tempfile);
1026 #endif
1027
1028 filename_string = build_string (tempfile);
1029 GCPRO1 (filename_string);
1030 SAFE_FREE ();
1031 }
1032
1033 start = args[0];
1034 end = args[1];
1035 /* Decide coding-system of the contents of the temporary file. */
1036 if (!NILP (Vcoding_system_for_write))
1037 val = Vcoding_system_for_write;
1038 else if (NILP (BVAR (current_buffer, enable_multibyte_characters)))
1039 val = Qraw_text;
1040 else
1041 {
1042 USE_SAFE_ALLOCA;
1043 SAFE_NALLOCA (args2, 1, nargs + 1);
1044 args2[0] = Qcall_process_region;
1045 for (i = 0; i < nargs; i++) args2[i + 1] = args[i];
1046 coding_systems = Ffind_operation_coding_system (nargs + 1, args2);
1047 val = CONSP (coding_systems) ? XCDR (coding_systems) : Qnil;
1048 SAFE_FREE ();
1049 }
1050 val = complement_process_encoding_system (val);
1051
1052 {
1053 ptrdiff_t count1 = SPECPDL_INDEX ();
1054
1055 specbind (intern ("coding-system-for-write"), val);
1056 /* POSIX lets mk[s]temp use "."; don't invoke jka-compr if we
1057 happen to get a ".Z" suffix. */
1058 specbind (intern ("file-name-handler-alist"), Qnil);
1059 Fwrite_region (start, end, filename_string, Qnil, Qlambda, Qnil, Qnil);
1060
1061 unbind_to (count1, Qnil);
1062 }
1063
1064 /* Note that Fcall_process takes care of binding
1065 coding-system-for-read. */
1066
1067 record_unwind_protect (delete_temp_file, filename_string);
1068
1069 if (nargs > 3 && !NILP (args[3]))
1070 Fdelete_region (start, end);
1071
1072 if (nargs > 3)
1073 {
1074 args += 2;
1075 nargs -= 2;
1076 }
1077 else
1078 {
1079 args[0] = args[2];
1080 nargs = 2;
1081 }
1082 args[1] = filename_string;
1083
1084 RETURN_UNGCPRO (unbind_to (count, Fcall_process (nargs, args)));
1085 }
1086 \f
1087 #ifndef WINDOWSNT
1088 static int relocate_fd (int fd, int minfd);
1089 #endif
1090
1091 static char **
1092 add_env (char **env, char **new_env, char *string)
1093 {
1094 char **ep;
1095 int ok = 1;
1096 if (string == NULL)
1097 return new_env;
1098
1099 /* See if this string duplicates any string already in the env.
1100 If so, don't put it in.
1101 When an env var has multiple definitions,
1102 we keep the definition that comes first in process-environment. */
1103 for (ep = env; ok && ep != new_env; ep++)
1104 {
1105 char *p = *ep, *q = string;
1106 while (ok)
1107 {
1108 if (*q != *p)
1109 break;
1110 if (*q == 0)
1111 /* The string is a lone variable name; keep it for now, we
1112 will remove it later. It is a placeholder for a
1113 variable that is not to be included in the environment. */
1114 break;
1115 if (*q == '=')
1116 ok = 0;
1117 p++, q++;
1118 }
1119 }
1120 if (ok)
1121 *new_env++ = string;
1122 return new_env;
1123 }
1124
1125 /* This is the last thing run in a newly forked inferior
1126 either synchronous or asynchronous.
1127 Copy descriptors IN, OUT and ERR as descriptors 0, 1 and 2.
1128 Initialize inferior's priority, pgrp, connected dir and environment.
1129 then exec another program based on new_argv.
1130
1131 This function may change environ for the superior process.
1132 Therefore, the superior process must save and restore the value
1133 of environ around the vfork and the call to this function.
1134
1135 SET_PGRP is nonzero if we should put the subprocess into a separate
1136 process group.
1137
1138 CURRENT_DIR is an elisp string giving the path of the current
1139 directory the subprocess should have. Since we can't really signal
1140 a decent error from within the child, this should be verified as an
1141 executable directory by the parent. */
1142
1143 int
1144 child_setup (int in, int out, int err, register char **new_argv, int set_pgrp, Lisp_Object current_dir)
1145 {
1146 char **env;
1147 char *pwd_var;
1148 #ifdef WINDOWSNT
1149 int cpid;
1150 HANDLE handles[3];
1151 #endif /* WINDOWSNT */
1152
1153 pid_t pid = getpid ();
1154
1155 /* Close Emacs's descriptors that this process should not have. */
1156 close_process_descs ();
1157
1158 /* DOS_NT isn't in a vfork, so if we are in the middle of load-file,
1159 we will lose if we call close_load_descs here. */
1160 #ifndef DOS_NT
1161 close_load_descs ();
1162 #endif
1163
1164 /* Note that use of alloca is always safe here. It's obvious for systems
1165 that do not have true vfork or that have true (stack) alloca.
1166 If using vfork and C_ALLOCA (when Emacs used to include
1167 src/alloca.c) it is safe because that changes the superior's
1168 static variables as if the superior had done alloca and will be
1169 cleaned up in the usual way. */
1170 {
1171 register char *temp;
1172 size_t i; /* size_t, because ptrdiff_t might overflow here! */
1173
1174 i = SBYTES (current_dir);
1175 #ifdef MSDOS
1176 /* MSDOS must have all environment variables malloc'ed, because
1177 low-level libc functions that launch subsidiary processes rely
1178 on that. */
1179 pwd_var = xmalloc (i + 6);
1180 #else
1181 pwd_var = alloca (i + 6);
1182 #endif
1183 temp = pwd_var + 4;
1184 memcpy (pwd_var, "PWD=", 4);
1185 memcpy (temp, SDATA (current_dir), i);
1186 if (!IS_DIRECTORY_SEP (temp[i - 1])) temp[i++] = DIRECTORY_SEP;
1187 temp[i] = 0;
1188
1189 #ifndef DOS_NT
1190 /* We can't signal an Elisp error here; we're in a vfork. Since
1191 the callers check the current directory before forking, this
1192 should only return an error if the directory's permissions
1193 are changed between the check and this chdir, but we should
1194 at least check. */
1195 if (chdir (temp) < 0)
1196 _exit (errno);
1197 #else /* DOS_NT */
1198 /* Get past the drive letter, so that d:/ is left alone. */
1199 if (i > 2 && IS_DEVICE_SEP (temp[1]) && IS_DIRECTORY_SEP (temp[2]))
1200 {
1201 temp += 2;
1202 i -= 2;
1203 }
1204 #endif /* DOS_NT */
1205
1206 /* Strip trailing slashes for PWD, but leave "/" and "//" alone. */
1207 while (i > 2 && IS_DIRECTORY_SEP (temp[i - 1]))
1208 temp[--i] = 0;
1209 }
1210
1211 /* Set `env' to a vector of the strings in the environment. */
1212 {
1213 register Lisp_Object tem;
1214 register char **new_env;
1215 char **p, **q;
1216 register int new_length;
1217 Lisp_Object display = Qnil;
1218
1219 new_length = 0;
1220
1221 for (tem = Vprocess_environment;
1222 CONSP (tem) && STRINGP (XCAR (tem));
1223 tem = XCDR (tem))
1224 {
1225 if (strncmp (SSDATA (XCAR (tem)), "DISPLAY", 7) == 0
1226 && (SDATA (XCAR (tem)) [7] == '\0'
1227 || SDATA (XCAR (tem)) [7] == '='))
1228 /* DISPLAY is specified in process-environment. */
1229 display = Qt;
1230 new_length++;
1231 }
1232
1233 /* If not provided yet, use the frame's DISPLAY. */
1234 if (NILP (display))
1235 {
1236 Lisp_Object tmp = Fframe_parameter (selected_frame, Qdisplay);
1237 if (!STRINGP (tmp) && CONSP (Vinitial_environment))
1238 /* If still not found, Look for DISPLAY in Vinitial_environment. */
1239 tmp = Fgetenv_internal (build_string ("DISPLAY"),
1240 Vinitial_environment);
1241 if (STRINGP (tmp))
1242 {
1243 display = tmp;
1244 new_length++;
1245 }
1246 }
1247
1248 /* new_length + 2 to include PWD and terminating 0. */
1249 env = new_env = alloca ((new_length + 2) * sizeof *env);
1250 /* If we have a PWD envvar, pass one down,
1251 but with corrected value. */
1252 if (egetenv ("PWD"))
1253 *new_env++ = pwd_var;
1254
1255 if (STRINGP (display))
1256 {
1257 char *vdata = alloca (sizeof "DISPLAY=" + SBYTES (display));
1258 strcpy (vdata, "DISPLAY=");
1259 strcat (vdata, SSDATA (display));
1260 new_env = add_env (env, new_env, vdata);
1261 }
1262
1263 /* Overrides. */
1264 for (tem = Vprocess_environment;
1265 CONSP (tem) && STRINGP (XCAR (tem));
1266 tem = XCDR (tem))
1267 new_env = add_env (env, new_env, SSDATA (XCAR (tem)));
1268
1269 *new_env = 0;
1270
1271 /* Remove variable names without values. */
1272 p = q = env;
1273 while (*p != 0)
1274 {
1275 while (*q != 0 && strchr (*q, '=') == NULL)
1276 q++;
1277 *p = *q++;
1278 if (*p != 0)
1279 p++;
1280 }
1281 }
1282
1283
1284 #ifdef WINDOWSNT
1285 prepare_standard_handles (in, out, err, handles);
1286 set_process_dir (SDATA (current_dir));
1287 /* Spawn the child. (See ntproc.c:Spawnve). */
1288 cpid = spawnve (_P_NOWAIT, new_argv[0], new_argv, env);
1289 reset_standard_handles (in, out, err, handles);
1290 if (cpid == -1)
1291 /* An error occurred while trying to spawn the process. */
1292 report_file_error ("Spawning child process", Qnil);
1293 return cpid;
1294
1295 #else /* not WINDOWSNT */
1296 /* Make sure that in, out, and err are not actually already in
1297 descriptors zero, one, or two; this could happen if Emacs is
1298 started with its standard in, out, or error closed, as might
1299 happen under X. */
1300 {
1301 int oin = in, oout = out;
1302
1303 /* We have to avoid relocating the same descriptor twice! */
1304
1305 in = relocate_fd (in, 3);
1306
1307 if (out == oin)
1308 out = in;
1309 else
1310 out = relocate_fd (out, 3);
1311
1312 if (err == oin)
1313 err = in;
1314 else if (err == oout)
1315 err = out;
1316 else
1317 err = relocate_fd (err, 3);
1318 }
1319
1320 #ifndef MSDOS
1321 emacs_close (0);
1322 emacs_close (1);
1323 emacs_close (2);
1324
1325 dup2 (in, 0);
1326 dup2 (out, 1);
1327 dup2 (err, 2);
1328 emacs_close (in);
1329 if (out != in)
1330 emacs_close (out);
1331 if (err != in && err != out)
1332 emacs_close (err);
1333
1334 #if defined (USG)
1335 #ifndef SETPGRP_RELEASES_CTTY
1336 setpgrp (); /* No arguments but equivalent in this case */
1337 #endif
1338 #else /* not USG */
1339 setpgrp (pid, pid);
1340 #endif /* not USG */
1341
1342 /* setpgrp_of_tty is incorrect here; it uses input_fd. */
1343 tcsetpgrp (0, pid);
1344
1345 /* execvp does not accept an environment arg so the only way
1346 to pass this environment is to set environ. Our caller
1347 is responsible for restoring the ambient value of environ. */
1348 environ = env;
1349 execvp (new_argv[0], new_argv);
1350
1351 emacs_write (1, "Can't exec program: ", 20);
1352 emacs_write (1, new_argv[0], strlen (new_argv[0]));
1353 emacs_write (1, "\n", 1);
1354 _exit (1);
1355
1356 #else /* MSDOS */
1357 pid = run_msdos_command (new_argv, pwd_var + 4, in, out, err, env);
1358 xfree (pwd_var);
1359 if (pid == -1)
1360 /* An error occurred while trying to run the subprocess. */
1361 report_file_error ("Spawning child process", Qnil);
1362 return pid;
1363 #endif /* MSDOS */
1364 #endif /* not WINDOWSNT */
1365 }
1366
1367 #ifndef WINDOWSNT
1368 /* Move the file descriptor FD so that its number is not less than MINFD.
1369 If the file descriptor is moved at all, the original is freed. */
1370 static int
1371 relocate_fd (int fd, int minfd)
1372 {
1373 if (fd >= minfd)
1374 return fd;
1375 else
1376 {
1377 int new;
1378 #ifdef F_DUPFD
1379 new = fcntl (fd, F_DUPFD, minfd);
1380 #else
1381 new = dup (fd);
1382 if (new != -1)
1383 /* Note that we hold the original FD open while we recurse,
1384 to guarantee we'll get a new FD if we need it. */
1385 new = relocate_fd (new, minfd);
1386 #endif
1387 if (new == -1)
1388 {
1389 const char *message_1 = "Error while setting up child: ";
1390 const char *errmessage = strerror (errno);
1391 const char *message_2 = "\n";
1392 emacs_write (2, message_1, strlen (message_1));
1393 emacs_write (2, errmessage, strlen (errmessage));
1394 emacs_write (2, message_2, strlen (message_2));
1395 _exit (1);
1396 }
1397 emacs_close (fd);
1398 return new;
1399 }
1400 }
1401 #endif /* not WINDOWSNT */
1402
1403 static int
1404 getenv_internal_1 (const char *var, ptrdiff_t varlen, char **value,
1405 ptrdiff_t *valuelen, Lisp_Object env)
1406 {
1407 for (; CONSP (env); env = XCDR (env))
1408 {
1409 Lisp_Object entry = XCAR (env);
1410 if (STRINGP (entry)
1411 && SBYTES (entry) >= varlen
1412 #ifdef WINDOWSNT
1413 /* NT environment variables are case insensitive. */
1414 && ! strnicmp (SDATA (entry), var, varlen)
1415 #else /* not WINDOWSNT */
1416 && ! memcmp (SDATA (entry), var, varlen)
1417 #endif /* not WINDOWSNT */
1418 )
1419 {
1420 if (SBYTES (entry) > varlen && SREF (entry, varlen) == '=')
1421 {
1422 *value = SSDATA (entry) + (varlen + 1);
1423 *valuelen = SBYTES (entry) - (varlen + 1);
1424 return 1;
1425 }
1426 else if (SBYTES (entry) == varlen)
1427 {
1428 /* Lone variable names in Vprocess_environment mean that
1429 variable should be removed from the environment. */
1430 *value = NULL;
1431 return 1;
1432 }
1433 }
1434 }
1435 return 0;
1436 }
1437
1438 static int
1439 getenv_internal (const char *var, ptrdiff_t varlen, char **value,
1440 ptrdiff_t *valuelen, Lisp_Object frame)
1441 {
1442 /* Try to find VAR in Vprocess_environment first. */
1443 if (getenv_internal_1 (var, varlen, value, valuelen,
1444 Vprocess_environment))
1445 return *value ? 1 : 0;
1446
1447 /* For DISPLAY try to get the values from the frame or the initial env. */
1448 if (strcmp (var, "DISPLAY") == 0)
1449 {
1450 Lisp_Object display
1451 = Fframe_parameter (NILP (frame) ? selected_frame : frame, Qdisplay);
1452 if (STRINGP (display))
1453 {
1454 *value = SSDATA (display);
1455 *valuelen = SBYTES (display);
1456 return 1;
1457 }
1458 /* If still not found, Look for DISPLAY in Vinitial_environment. */
1459 if (getenv_internal_1 (var, varlen, value, valuelen,
1460 Vinitial_environment))
1461 return *value ? 1 : 0;
1462 }
1463
1464 return 0;
1465 }
1466
1467 DEFUN ("getenv-internal", Fgetenv_internal, Sgetenv_internal, 1, 2, 0,
1468 doc: /* Get the value of environment variable VARIABLE.
1469 VARIABLE should be a string. Value is nil if VARIABLE is undefined in
1470 the environment. Otherwise, value is a string.
1471
1472 This function searches `process-environment' for VARIABLE.
1473
1474 If optional parameter ENV is a list, then search this list instead of
1475 `process-environment', and return t when encountering a negative entry
1476 \(an entry for a variable with no value). */)
1477 (Lisp_Object variable, Lisp_Object env)
1478 {
1479 char *value;
1480 ptrdiff_t valuelen;
1481
1482 CHECK_STRING (variable);
1483 if (CONSP (env))
1484 {
1485 if (getenv_internal_1 (SSDATA (variable), SBYTES (variable),
1486 &value, &valuelen, env))
1487 return value ? make_string (value, valuelen) : Qt;
1488 else
1489 return Qnil;
1490 }
1491 else if (getenv_internal (SSDATA (variable), SBYTES (variable),
1492 &value, &valuelen, env))
1493 return make_string (value, valuelen);
1494 else
1495 return Qnil;
1496 }
1497
1498 /* A version of getenv that consults the Lisp environment lists,
1499 easily callable from C. */
1500 char *
1501 egetenv (const char *var)
1502 {
1503 char *value;
1504 ptrdiff_t valuelen;
1505
1506 if (getenv_internal (var, strlen (var), &value, &valuelen, Qnil))
1507 return value;
1508 else
1509 return 0;
1510 }
1511
1512 \f
1513 /* This is run before init_cmdargs. */
1514
1515 void
1516 init_callproc_1 (void)
1517 {
1518 char *data_dir = egetenv ("EMACSDATA");
1519 char *doc_dir = egetenv ("EMACSDOC");
1520 #ifdef HAVE_NS
1521 const char *etc_dir = ns_etc_directory ();
1522 const char *path_exec = ns_exec_path ();
1523 #endif
1524
1525 Vdata_directory
1526 = Ffile_name_as_directory (build_string (data_dir ? data_dir
1527 #ifdef HAVE_NS
1528 : (etc_dir ? etc_dir : PATH_DATA)
1529 #else
1530 : PATH_DATA
1531 #endif
1532 ));
1533 Vdoc_directory
1534 = Ffile_name_as_directory (build_string (doc_dir ? doc_dir
1535 #ifdef HAVE_NS
1536 : (etc_dir ? etc_dir : PATH_DOC)
1537 #else
1538 : PATH_DOC
1539 #endif
1540 ));
1541
1542 /* Check the EMACSPATH environment variable, defaulting to the
1543 PATH_EXEC path from epaths.h. */
1544 Vexec_path = decode_env_path ("EMACSPATH",
1545 #ifdef HAVE_NS
1546 path_exec ? path_exec :
1547 #endif
1548 PATH_EXEC);
1549 Vexec_directory = Ffile_name_as_directory (Fcar (Vexec_path));
1550 /* FIXME? For ns, path_exec should go at the front? */
1551 Vexec_path = nconc2 (decode_env_path ("PATH", ""), Vexec_path);
1552 }
1553
1554 /* This is run after init_cmdargs, when Vinstallation_directory is valid. */
1555
1556 void
1557 init_callproc (void)
1558 {
1559 char *data_dir = egetenv ("EMACSDATA");
1560
1561 register char * sh;
1562 Lisp_Object tempdir;
1563 #ifdef HAVE_NS
1564 if (data_dir == 0)
1565 {
1566 const char *etc_dir = ns_etc_directory ();
1567 if (etc_dir)
1568 {
1569 data_dir = alloca (strlen (etc_dir) + 1);
1570 strcpy (data_dir, etc_dir);
1571 }
1572 }
1573 #endif
1574
1575 if (!NILP (Vinstallation_directory))
1576 {
1577 /* Add to the path the lib-src subdir of the installation dir. */
1578 Lisp_Object tem;
1579 tem = Fexpand_file_name (build_string ("lib-src"),
1580 Vinstallation_directory);
1581 #ifndef DOS_NT
1582 /* MSDOS uses wrapped binaries, so don't do this. */
1583 if (NILP (Fmember (tem, Vexec_path)))
1584 {
1585 #ifdef HAVE_NS
1586 const char *path_exec = ns_exec_path ();
1587 #endif
1588 Vexec_path = decode_env_path ("EMACSPATH",
1589 #ifdef HAVE_NS
1590 path_exec ? path_exec :
1591 #endif
1592 PATH_EXEC);
1593 Vexec_path = Fcons (tem, Vexec_path);
1594 Vexec_path = nconc2 (decode_env_path ("PATH", ""), Vexec_path);
1595 }
1596
1597 Vexec_directory = Ffile_name_as_directory (tem);
1598 #endif /* not DOS_NT */
1599
1600 /* Maybe use ../etc as well as ../lib-src. */
1601 if (data_dir == 0)
1602 {
1603 tem = Fexpand_file_name (build_string ("etc"),
1604 Vinstallation_directory);
1605 Vdoc_directory = Ffile_name_as_directory (tem);
1606 }
1607 }
1608
1609 /* Look for the files that should be in etc. We don't use
1610 Vinstallation_directory, because these files are never installed
1611 near the executable, and they are never in the build
1612 directory when that's different from the source directory.
1613
1614 Instead, if these files are not in the nominal place, we try the
1615 source directory. */
1616 if (data_dir == 0)
1617 {
1618 Lisp_Object tem, tem1, srcdir;
1619
1620 srcdir = Fexpand_file_name (build_string ("../src/"),
1621 build_string (PATH_DUMPLOADSEARCH));
1622 tem = Fexpand_file_name (build_string ("GNU"), Vdata_directory);
1623 tem1 = Ffile_exists_p (tem);
1624 if (!NILP (Fequal (srcdir, Vinvocation_directory)) || NILP (tem1))
1625 {
1626 Lisp_Object newdir;
1627 newdir = Fexpand_file_name (build_string ("../etc/"),
1628 build_string (PATH_DUMPLOADSEARCH));
1629 tem = Fexpand_file_name (build_string ("GNU"), newdir);
1630 tem1 = Ffile_exists_p (tem);
1631 if (!NILP (tem1))
1632 Vdata_directory = newdir;
1633 }
1634 }
1635
1636 #ifndef CANNOT_DUMP
1637 if (initialized)
1638 #endif
1639 {
1640 tempdir = Fdirectory_file_name (Vexec_directory);
1641 if (access (SSDATA (tempdir), 0) < 0)
1642 dir_warning ("Warning: arch-dependent data dir (%s) does not exist.\n",
1643 Vexec_directory);
1644 }
1645
1646 tempdir = Fdirectory_file_name (Vdata_directory);
1647 if (access (SSDATA (tempdir), 0) < 0)
1648 dir_warning ("Warning: arch-independent data dir (%s) does not exist.\n",
1649 Vdata_directory);
1650
1651 sh = (char *) getenv ("SHELL");
1652 Vshell_file_name = build_string (sh ? sh : "/bin/sh");
1653
1654 #ifdef DOS_NT
1655 Vshared_game_score_directory = Qnil;
1656 #else
1657 Vshared_game_score_directory = build_string (PATH_GAME);
1658 if (NILP (Ffile_directory_p (Vshared_game_score_directory)))
1659 Vshared_game_score_directory = Qnil;
1660 #endif
1661 }
1662
1663 void
1664 set_initial_environment (void)
1665 {
1666 char **envp;
1667 for (envp = environ; *envp; envp++)
1668 Vprocess_environment = Fcons (build_string (*envp),
1669 Vprocess_environment);
1670 /* Ideally, the `copy' shouldn't be necessary, but it seems it's frequent
1671 to use `delete' and friends on process-environment. */
1672 Vinitial_environment = Fcopy_sequence (Vprocess_environment);
1673 }
1674
1675 void
1676 syms_of_callproc (void)
1677 {
1678 #ifndef DOS_NT
1679 Vtemp_file_name_pattern = build_string ("emacsXXXXXX");
1680 #elif defined (WINDOWSNT)
1681 Vtemp_file_name_pattern = build_string ("emXXXXXX");
1682 #else
1683 Vtemp_file_name_pattern = build_string ("detmp.XXX");
1684 #endif
1685 staticpro (&Vtemp_file_name_pattern);
1686
1687 DEFVAR_LISP ("shell-file-name", Vshell_file_name,
1688 doc: /* File name to load inferior shells from.
1689 Initialized from the SHELL environment variable, or to a system-dependent
1690 default if SHELL is not set. */);
1691
1692 DEFVAR_LISP ("exec-path", Vexec_path,
1693 doc: /* List of directories to search programs to run in subprocesses.
1694 Each element is a string (directory name) or nil (try default directory). */);
1695
1696 DEFVAR_LISP ("exec-suffixes", Vexec_suffixes,
1697 doc: /* List of suffixes to try to find executable file names.
1698 Each element is a string. */);
1699 Vexec_suffixes = Qnil;
1700
1701 DEFVAR_LISP ("exec-directory", Vexec_directory,
1702 doc: /* Directory for executables for Emacs to invoke.
1703 More generally, this includes any architecture-dependent files
1704 that are built and installed from the Emacs distribution. */);
1705
1706 DEFVAR_LISP ("data-directory", Vdata_directory,
1707 doc: /* Directory of machine-independent files that come with GNU Emacs.
1708 These are files intended for Emacs to use while it runs. */);
1709
1710 DEFVAR_LISP ("doc-directory", Vdoc_directory,
1711 doc: /* Directory containing the DOC file that comes with GNU Emacs.
1712 This is usually the same as `data-directory'. */);
1713
1714 DEFVAR_LISP ("configure-info-directory", Vconfigure_info_directory,
1715 doc: /* For internal use by the build procedure only.
1716 This is the name of the directory in which the build procedure installed
1717 Emacs's info files; the default value for `Info-default-directory-list'
1718 includes this. */);
1719 Vconfigure_info_directory = build_string (PATH_INFO);
1720
1721 DEFVAR_LISP ("shared-game-score-directory", Vshared_game_score_directory,
1722 doc: /* Directory of score files for games which come with GNU Emacs.
1723 If this variable is nil, then Emacs is unable to use a shared directory. */);
1724 #ifdef DOS_NT
1725 Vshared_game_score_directory = Qnil;
1726 #else
1727 Vshared_game_score_directory = build_string (PATH_GAME);
1728 #endif
1729
1730 DEFVAR_LISP ("initial-environment", Vinitial_environment,
1731 doc: /* List of environment variables inherited from the parent process.
1732 Each element should be a string of the form ENVVARNAME=VALUE.
1733 The elements must normally be decoded (using `locale-coding-system') for use. */);
1734 Vinitial_environment = Qnil;
1735
1736 DEFVAR_LISP ("process-environment", Vprocess_environment,
1737 doc: /* List of overridden environment variables for subprocesses to inherit.
1738 Each element should be a string of the form ENVVARNAME=VALUE.
1739
1740 Entries in this list take precedence to those in the frame-local
1741 environments. Therefore, let-binding `process-environment' is an easy
1742 way to temporarily change the value of an environment variable,
1743 irrespective of where it comes from. To use `process-environment' to
1744 remove an environment variable, include only its name in the list,
1745 without "=VALUE".
1746
1747 This variable is set to nil when Emacs starts.
1748
1749 If multiple entries define the same variable, the first one always
1750 takes precedence.
1751
1752 Non-ASCII characters are encoded according to the initial value of
1753 `locale-coding-system', i.e. the elements must normally be decoded for
1754 use.
1755
1756 See `setenv' and `getenv'. */);
1757 Vprocess_environment = Qnil;
1758
1759 defsubr (&Scall_process);
1760 defsubr (&Sgetenv_internal);
1761 defsubr (&Scall_process_region);
1762 }