1 /* Synchronous subprocess invocation for XEmacs.
2 Copyright (C) 1985, 86, 87, 88, 93, 94, 95 Free Software Foundation, Inc.
4 This file is part of XEmacs.
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
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
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. */
21 /* Synched up with: Mule 2.0, FSF 19.30. */
22 /* Partly sync'ed with 19.36.4 */
35 #include "file-coding.h"
40 #include "sysfile.h" /* Always include after sysproc.h */
41 #include "syssignal.h" /* Always include before systty.h */
45 #define _P_NOWAIT 1 /* from process.h */
51 /* When we are starting external processes we need to know whether they
52 take binary input (no conversion) or text input (\n is converted to
53 \r\n). Similarly for output: if newlines are written as \r\n then it's
54 text process output, otherwise it's binary. */
55 Lisp_Object Vbinary_process_input;
56 Lisp_Object Vbinary_process_output;
59 Lisp_Object Vshell_file_name;
61 /* The environment to pass to all subprocesses when they are started.
62 This is in the semi-bogus format of ("VAR=VAL" "VAR2=VAL2" ... )
64 Lisp_Object Vprocess_environment;
66 /* True iff we are about to fork off a synchronous process or if we
67 are waiting for it. */
68 volatile int synch_process_alive;
70 /* Nonzero => this is a string explaining death of synchronous subprocess. */
71 CONST char *synch_process_death;
73 /* If synch_process_death is zero,
74 this is exit code of synchronous subprocess. */
75 int synch_process_retcode;
77 /* Clean up when exiting Fcall_process_internal.
78 On MSDOS, delete the temporary file on any kind of termination.
79 On Unix, kill the process and any children on termination by signal. */
81 /* Nonzero if this is termination due to exit. */
82 static int call_process_exited;
86 call_process_kill (Lisp_Object fdpid)
88 Lisp_Object fd = Fcar (fdpid);
89 Lisp_Object pid = Fcdr (fdpid);
95 EMACS_KILLPG (XINT (pid), SIGKILL);
97 synch_process_alive = 0;
102 call_process_cleanup (Lisp_Object fdpid)
104 int fd = XINT (Fcar (fdpid));
105 int pid = XINT (Fcdr (fdpid));
107 if (!call_process_exited &&
108 EMACS_KILLPG (pid, SIGINT) == 0)
110 int speccount = specpdl_depth ();
112 record_unwind_protect (call_process_kill, fdpid);
113 /* #### "c-G" -- need non-consing Single-key-description */
114 message ("Waiting for process to die...(type C-g again to kill it instantly)");
116 wait_for_termination (pid);
118 /* "Discard" the unwind protect. */
121 unbind_to (speccount, Qnil);
123 message ("Waiting for process to die... done");
125 synch_process_alive = 0;
130 static Lisp_Object fork_error;
133 report_fork_error (char *string, Lisp_Object data)
135 Lisp_Object errstring = lisp_strerror (errno);
137 fork_error = Fcons (build_string (string), Fcons (errstring, data));
139 /* terminate this branch of the fork, without closing stdin/out/etc. */
144 DEFUN ("call-process-internal", Fcall_process_internal, 1, MANY, 0, /*
145 Call PROGRAM synchronously in separate process, with coding-system specified.
147 (PROGRAM &optional INFILE BUFFER DISPLAY &rest ARGS).
148 The program's input comes from file INFILE (nil means `/dev/null').
149 Insert output in BUFFER before point; t means current buffer;
150 nil for BUFFER means discard it; 0 means discard and don't wait.
151 BUFFER can also have the form (REAL-BUFFER STDERR-FILE); in that case,
152 REAL-BUFFER says what to do with standard output, as above,
153 while STDERR-FILE says what to do with standard error in the child.
154 STDERR-FILE may be nil (discard standard error output),
155 t (mix it with ordinary output), or a file name string.
157 Fourth arg DISPLAY non-nil means redisplay buffer as output is inserted.
158 Remaining arguments are strings passed as command arguments to PROGRAM.
160 If BUFFER is 0, `call-process' returns immediately with value nil.
161 Otherwise it waits for PROGRAM to terminate and returns a numeric exit status
162 or a signal description string.
163 If you quit, the process is killed with SIGINT, or SIGKILL if you
166 (int nargs, Lisp_Object *args))
168 /* This function can GC */
169 Lisp_Object infile, buffer, current_dir, display, path;
176 int speccount = specpdl_depth ();
177 struct gcpro gcpro1, gcpro2;
178 char **new_argv = alloca_array (char *, max (2, nargs - 2));
180 /* File to use for stderr in the child.
181 t means use same as standard output. */
182 Lisp_Object error_file;
184 CHECK_STRING (args[0]);
188 #if defined (NO_SUBPROCESSES)
189 /* Without asynchronous processes we cannot have BUFFER == 0. */
190 if (nargs >= 3 && !INTP (args[2]))
191 error ("Operating system cannot handle asynchronous subprocesses");
192 #endif /* NO_SUBPROCESSES */
194 /* Do this before building new_argv because GC in Lisp code
195 * called by various filename-hacking routines might relocate strings */
196 locate_file (Vexec_path, args[0], EXEC_SUFFIXES, &path, X_OK);
198 /* Make sure that the child will be able to chdir to the current
199 buffer's current directory, or its unhandled equivalent. We
200 can't just have the child check for an error when it does the
201 chdir, since it's in a vfork. */
203 struct gcpro ngcpro1, ngcpro2;
204 /* Do this test before building new_argv because GC in Lisp code
205 * called by various filename-hacking routines might relocate strings */
206 /* Make sure that the child will be able to chdir to the current
207 buffer's current directory. We can't just have the child check
208 for an error when it does the chdir, since it's in a vfork. */
210 NGCPRO2 (current_dir, path); /* Caller gcprotects args[] */
211 current_dir = current_buffer->directory;
212 current_dir = Funhandled_file_name_directory (current_dir);
213 current_dir = expand_and_dir_to_file (current_dir, Qnil);
215 /* This is in FSF, but it breaks everything in the presence of
216 ange-ftp-visited files, so away with it. */
217 if (NILP (Ffile_accessible_directory_p (current_dir)))
218 report_file_error ("Setting current directory",
219 Fcons (current_buffer->directory, Qnil));
224 GCPRO1 (current_dir);
226 if (nargs >= 2 && ! NILP (args[1]))
228 struct gcpro ngcpro1;
229 NGCPRO1 (current_buffer->directory);
230 infile = Fexpand_file_name (args[1], current_buffer->directory);
232 CHECK_STRING (infile);
235 infile = build_string (NULL_DEVICE);
239 GCPRO2 (infile, current_dir); /* Fexpand_file_name might trash it */
245 /* If BUFFER is a list, its meaning is
246 (BUFFER-FOR-STDOUT FILE-FOR-STDERR). */
249 if (CONSP (XCDR (buffer)))
251 Lisp_Object file_for_stderr = XCAR (XCDR (buffer));
253 if (NILP (file_for_stderr) || EQ (Qt, file_for_stderr))
254 error_file = file_for_stderr;
256 error_file = Fexpand_file_name (file_for_stderr, Qnil);
259 buffer = XCAR (buffer);
262 if (!(EQ (buffer, Qnil)
266 Lisp_Object spec_buffer = buffer;
267 buffer = Fget_buffer (buffer);
268 /* Mention the buffer name for a better error message. */
270 CHECK_BUFFER (spec_buffer);
271 CHECK_BUFFER (buffer);
279 display = ((nargs >= 4) ? args[3] : Qnil);
281 /* From here we assume we won't GC (unless an error is signaled). */
284 for (i = 4; i < nargs; i++)
286 CHECK_STRING (args[i]);
287 new_argv[i - 3] = (char *) XSTRING_DATA (args[i]);
289 new_argv[nargs - 3] = 0;
293 report_file_error ("Searching for program", Fcons (args[0], Qnil));
294 new_argv[0] = (char *) XSTRING_DATA (path);
296 filefd = open ((char *) XSTRING_DATA (infile), O_RDONLY | OPEN_BINARY, 0);
298 report_file_error ("Opening process input file", Fcons (infile, Qnil));
302 fd[1] = open (NULL_DEVICE, O_WRONLY | OPEN_BINARY, 0);
309 /* Replaced by close_process_descs */
310 set_exclusive_use (fd[0]);
315 /* child_setup must clobber environ in systems with true vfork.
316 Protect it from permanent change. */
317 REGISTER char **save_environ = environ;
318 REGISTER int fd1 = fd[1];
324 /* Record that we're about to create a synchronous process. */
325 synch_process_alive = 1;
327 /* These vars record information from process termination.
328 Clear them now before process can possibly terminate,
329 to avoid timing error if process terminates soon. */
330 synch_process_death = 0;
331 synch_process_retcode = 0;
333 if (NILP (error_file))
334 fd_error = open (NULL_DEVICE, O_WRONLY | OPEN_BINARY);
335 else if (STRINGP (error_file))
337 fd_error = open ((CONST char *) XSTRING_DATA (error_file),
339 O_WRONLY | O_TRUNC | O_CREAT | O_TEXT,
341 #else /* not DOS_NT */
342 O_WRONLY | O_TRUNC | O_CREAT | OPEN_BINARY,
344 #endif /* not DOS_NT */
354 report_file_error ("Cannot open", Fcons(error_file, Qnil));
359 pid = child_setup (filefd, fd1, fd_error, new_argv,
360 (char *) XSTRING_DATA (current_dir));
361 #else /* not WINDOWSNT */
368 /* This is necessary because some shells may attempt to
369 access the current controlling terminal and will hang
370 if they are run in the background, as will be the case
371 when XEmacs is started in the background. Martin
372 Buchholz observed this problem running a subprocess
373 that used zsh to call gzip to uncompress an info
375 disconnect_controlling_terminal ();
376 child_setup (filefd, fd1, fd_error, new_argv,
377 (char *) XSTRING_DATA (current_dir));
382 #endif /* not WINDOWSNT */
384 environ = save_environ;
386 /* Close most of our fd's, but not fd[0]
387 since we will use that to read input from. */
393 if (!NILP (fork_error))
394 signal_error (Qfile_error, fork_error);
400 report_file_error ("Doing fork", Qnil);
407 #if defined (NO_SUBPROCESSES)
408 /* If Emacs has been built with asynchronous subprocess support,
409 we don't need to do this, I think because it will then have
410 the facilities for handling SIGCHLD. */
411 wait_without_blocking ();
412 #endif /* NO_SUBPROCESSES */
420 Lisp_Object instream;
421 struct gcpro ngcpro1;
423 /* Enable sending signal if user quits below. */
424 call_process_exited = 0;
426 record_unwind_protect (call_process_cleanup,
427 Fcons (make_int (fd[0]), make_int (pid)));
429 /* FSFmacs calls Fset_buffer() here. We don't have to because
430 we can insert into buffers other than the current one. */
432 XSETBUFFER (buffer, current_buffer);
433 instream = make_filedesc_input_stream (fd[0], 0, -1, LSTR_ALLOW_QUIT);
436 make_decoding_input_stream
437 (XLSTREAM (instream),
438 Fget_coding_system (Vcoding_system_for_read));
439 Lstream_set_character_mode (XLSTREAM (instream));
445 /* Repeatedly read until we've filled as much as possible
446 of the buffer size we have. But don't read
447 less than 1024--save that for the next bufferfull. */
450 while (nread < bufsize - 1024)
453 = Lstream_read (XLSTREAM (instream), bufptr + nread,
467 /* Now NREAD is the total amount of data in the buffer. */
472 /* Until we pull out of MULE things like
473 make_decoding_input_stream(), we do the following which is
474 less elegant. --marcpa */
477 if (NILP (Vbinary_process_output)) {
478 nread = crlf_to_lf(nread, bufptr, &lf_count);
486 buffer_insert_raw_string (XBUFFER (buffer), (Bufbyte *) bufptr,
489 /* Make the buffer bigger as we continue to read more data,
491 if (bufsize < 64 * 1024 && total_read > 32 * bufsize)
494 bufptr = (char *) alloca (bufsize);
497 if (!NILP (display) && INTERACTIVE)
504 Lstream_close (XLSTREAM (instream));
508 /* Wait for it to terminate, unless it already has. */
509 wait_for_termination (pid);
511 /* Don't kill any children that the subprocess may have left behind
513 call_process_exited = 1;
514 unbind_to (speccount, Qnil);
516 if (synch_process_death)
517 return build_string (synch_process_death);
518 return make_int (synch_process_retcode);
524 /* Move the file descriptor FD so that its number is not less than MIN. *
525 The original file descriptor remains open. */
527 relocate_fd (int fd, int min)
533 int newfd = dup (fd);
536 stderr_out ("Error while setting up child: %s\n",
540 return relocate_fd (newfd, min);
544 /* This is the last thing run in a newly forked inferior
545 either synchronous or asynchronous.
546 Copy descriptors IN, OUT and ERR
547 as descriptors STDIN_FILENO, STDOUT_FILENO, and STDERR_FILENO.
548 Initialize inferior's priority, pgrp, connected dir and environment.
549 then exec another program based on new_argv.
551 This function may change environ for the superior process.
552 Therefore, the superior process must save and restore the value
553 of environ around the fork and the call to this function.
555 ENV is the environment for the subprocess.
557 XEmacs: We've removed the SET_PGRP argument because it's already
558 done by the callers of child_setup.
560 CURRENT_DIR is an elisp string giving the path of the current
561 directory the subprocess should have. Since we can't really signal
562 a decent error from within the child, this should be verified as an
563 executable directory by the parent. */
570 child_setup (int in, int out, int err, char **new_argv,
571 CONST char *current_dir)
578 #endif /* WINDOWSNT */
580 #ifdef SET_EMACS_PRIORITY
581 if (emacs_priority != 0)
582 nice (- emacs_priority);
585 #if !defined (NO_SUBPROCESSES) && !defined (WINDOWSNT)
586 /* Close Emacs's descriptors that this process should not have. */
587 close_process_descs ();
588 #endif /* not NO_SUBPROCESSES */
591 /* Note that use of alloca is always safe here. It's obvious for systems
592 that do not have true vfork or that have true (stack) alloca.
593 If using vfork and C_ALLOCA it is safe because that changes
594 the superior's static variables as if the superior had done alloca
595 and will be cleaned up in the usual way. */
599 i = strlen (current_dir);
600 pwd = alloca_array (char, i + 6);
601 memcpy (pwd, "PWD=", 4);
602 memcpy (pwd + 4, current_dir, i);
604 if (!IS_DIRECTORY_SEP (pwd[i - 1]))
605 pwd[i++] = DIRECTORY_SEP;
608 /* We can't signal an Elisp error here; we're in a vfork. Since
609 the callers check the current directory before forking, this
610 should only return an error if the directory's permissions
611 are changed between the check and this chdir, but we should
613 if (chdir (pwd + 4) < 0)
615 /* Don't report the chdir error, or ange-ftp.el doesn't work. */
616 /* (FSFmacs does _exit (errno) here.) */
621 /* Strip trailing "/". Cretinous *[]&@$#^%@#$% Un*x */
622 /* leave "//" (from FSF) */
623 while (i > 6 && IS_DIRECTORY_SEP (pwd[i - 1]))
628 /* Set `env' to a vector of the strings in Vprocess_environment. */
629 /* + 2 to include PWD and terminating 0. */
630 env = alloca_array (char *, XINT (Flength (Vprocess_environment)) + 2);
632 REGISTER Lisp_Object tail;
633 char **new_env = env;
635 /* If we have a PWD envvar and we know the real current directory,
636 pass one down, but with corrected value. */
637 if (pwd && getenv ("PWD"))
640 /* Copy the Vprocess_environment strings into new_env. */
641 for (tail = Vprocess_environment;
642 CONSP (tail) && STRINGP (XCAR (tail));
646 char *envvar_external;
647 Bufbyte *envvar_internal = XSTRING_DATA (XCAR (tail));
649 GET_C_CHARPTR_EXT_FILENAME_DATA_ALLOCA (envvar_internal, envvar_external);
651 /* See if envvar_external duplicates any string already in the env.
652 If so, don't put it in.
653 When an env var has multiple definitions,
654 we keep the definition that comes first in process-environment. */
655 for (; ep != new_env; ep++)
657 char *p = *ep, *q = envvar_external;
661 /* The string is malformed; might as well drop it. */
670 if (pwd && !strncmp ("PWD=", envvar_external, 4))
676 *new_env++ = envvar_external;
684 prepare_standard_handles (in, out, err, handles);
685 set_process_dir (current_dir);
686 #else /* not WINDOWSNT */
687 /* Make sure that in, out, and err are not actually already in
688 descriptors zero, one, or two; this could happen if Emacs is
689 started with its standard in, out, or error closed, as might
691 in = relocate_fd (in, 3);
692 out = relocate_fd (out, 3);
693 err = relocate_fd (err, 3);
695 /* Set the standard input/output channels of the new process. */
696 close (STDIN_FILENO);
697 close (STDOUT_FILENO);
698 close (STDERR_FILENO);
700 dup2 (in, STDIN_FILENO);
701 dup2 (out, STDOUT_FILENO);
702 dup2 (err, STDERR_FILENO);
708 /* I can't think of any reason why child processes need any more
709 than the standard 3 file descriptors. It would be cleaner to
710 close just the ones that need to be, but the following brute
711 force approach is certainly effective, and not too slow. */
714 for (fd=3; fd<=64; fd++)
717 #endif /* not WINDOWSNT */
720 something missing here;
724 /* Spawn the child. (See ntproc.c:Spawnve). */
725 cpid = spawnve (_P_NOWAIT, new_argv[0], new_argv, env);
727 /* An error occurred while trying to spawn the process. */
728 report_file_error ("Spawning child process", Qnil);
729 reset_standard_handles (in, out, err, handles);
731 #else /* not WINDOWSNT */
732 /* execvp does not accept an environment arg so the only way
733 to pass this environment is to set environ. Our caller
734 is responsible for restoring the ambient value of environ. */
736 execvp (new_argv[0], new_argv);
738 stdout_out ("Can't exec program %s\n", new_argv[0]);
740 #endif /* not WINDOWSNT */
744 getenv_internal (CONST Bufbyte *var,
751 for (scan = Vprocess_environment; CONSP (scan); scan = XCDR (scan))
753 Lisp_Object entry = XCAR (scan);
756 && XSTRING_LENGTH (entry) > varlen
757 && XSTRING_BYTE (entry, varlen) == '='
759 /* NT environment variables are case insensitive. */
760 && ! memicmp (XSTRING_DATA (entry), var, varlen)
761 #else /* not WINDOWSNT */
762 && ! memcmp (XSTRING_DATA (entry), var, varlen)
763 #endif /* not WINDOWSNT */
766 *value = XSTRING_DATA (entry) + (varlen + 1);
767 *valuelen = XSTRING_LENGTH (entry) - (varlen + 1);
775 DEFUN ("getenv", Fgetenv, 1, 2, "sEnvironment variable: \np", /*
776 Return the value of environment variable VAR, as a string.
777 VAR is a string, the name of the variable.
778 When invoked interactively, prints the value in the echo area.
784 Lisp_Object v = Qnil;
789 if (getenv_internal (XSTRING_DATA (var), XSTRING_LENGTH (var),
791 v = make_string (value, valuelen);
792 if (!NILP (interactivep))
795 message ("%s not defined in environment", XSTRING_DATA (var));
797 /* #### Should use Fprin1_to_string or Fprin1 to handle string
798 containing quotes correctly. */
799 message ("\"%s\"", value);
804 /* A version of getenv that consults process_environment, easily
807 egetenv (CONST char *var)
812 if (getenv_internal ((CONST Bufbyte *) var, strlen (var), &value, &valuelen))
813 return (char *) value;
822 /* This function can GC */
825 /* jwz: always initialize Vprocess_environment, so that egetenv()
828 Vprocess_environment = Qnil;
829 for (envp = environ; envp && *envp; envp++)
831 Vprocess_environment = Fcons (build_ext_string (*envp, FORMAT_OS),
832 Vprocess_environment);
837 /* Initialize shell-file-name from environment variables or best guess. */
839 CONST char *shell = egetenv ("COMSPEC");
840 if (!shell) shell = "\\WINNT\\system32\\cmd.exe";
841 #else /* not WINDOWSNT */
842 CONST char *shell = egetenv ("SHELL");
843 if (!shell) shell = "/bin/sh";
846 Vshell_file_name = build_string (shell);
852 set_process_environment (void)
854 REGISTER char **envp;
856 Vprocess_environment = Qnil;
860 for (envp = environ; *envp; envp++)
861 Vprocess_environment = Fcons (build_string (*envp),
862 Vprocess_environment);
867 syms_of_callproc (void)
869 DEFSUBR (Fcall_process_internal);
874 vars_of_callproc (void)
876 /* This function can GC */
878 DEFVAR_LISP ("binary-process-input", &Vbinary_process_input /*
879 *If non-nil then new subprocesses are assumed to take binary input.
881 Vbinary_process_input = Qnil;
883 DEFVAR_LISP ("binary-process-output", &Vbinary_process_output /*
884 *If non-nil then new subprocesses are assumed to produce binary output.
886 Vbinary_process_output = Qnil;
889 DEFVAR_LISP ("shell-file-name", &Vshell_file_name /*
890 *File name to load inferior shells from.
891 Initialized from the SHELL environment variable.
894 DEFVAR_LISP ("process-environment", &Vprocess_environment /*
895 List of environment variables for subprocesses to inherit.
896 Each element should be a string of the form ENVVARNAME=VALUE.
897 The environment which Emacs inherits is placed in this variable