|
428
|
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 /* Partly sync'ed with 19.36.4 */
|
|
|
23
|
|
|
24 #include <config.h>
|
|
|
25 #include "lisp.h"
|
|
|
26
|
|
|
27 #include "buffer.h"
|
|
|
28 #include "commands.h"
|
|
|
29 #include "insdel.h"
|
|
|
30 #include "lstream.h"
|
|
|
31 #include "process.h"
|
|
|
32 #include "sysdep.h"
|
|
|
33 #include "window.h"
|
|
|
34 #ifdef FILE_CODING
|
|
|
35 #include "file-coding.h"
|
|
|
36 #endif
|
|
|
37
|
|
|
38 #include "systime.h"
|
|
|
39 #include "sysproc.h"
|
|
|
40 #include "sysfile.h" /* Always include after sysproc.h */
|
|
|
41 #include "syssignal.h" /* Always include before systty.h */
|
|
|
42 #include "systty.h"
|
|
|
43
|
|
442
|
44 #ifdef WIN32_NATIVE
|
|
428
|
45 #define _P_NOWAIT 1 /* from process.h */
|
|
|
46 #include "nt.h"
|
|
|
47 #endif
|
|
|
48
|
|
442
|
49 #ifdef WIN32_NATIVE
|
|
428
|
50 /* When we are starting external processes we need to know whether they
|
|
|
51 take binary input (no conversion) or text input (\n is converted to
|
|
|
52 \r\n). Similarly for output: if newlines are written as \r\n then it's
|
|
|
53 text process output, otherwise it's binary. */
|
|
|
54 Lisp_Object Vbinary_process_input;
|
|
|
55 Lisp_Object Vbinary_process_output;
|
|
442
|
56 #endif /* WIN32_NATIVE */
|
|
428
|
57
|
|
|
58 Lisp_Object Vshell_file_name;
|
|
|
59
|
|
|
60 /* The environment to pass to all subprocesses when they are started.
|
|
|
61 This is in the semi-bogus format of ("VAR=VAL" "VAR2=VAL2" ... )
|
|
|
62 */
|
|
|
63 Lisp_Object Vprocess_environment;
|
|
|
64
|
|
|
65 /* True iff we are about to fork off a synchronous process or if we
|
|
|
66 are waiting for it. */
|
|
|
67 volatile int synch_process_alive;
|
|
|
68
|
|
|
69 /* Nonzero => this is a string explaining death of synchronous subprocess. */
|
|
442
|
70 const char *synch_process_death;
|
|
428
|
71
|
|
|
72 /* If synch_process_death is zero,
|
|
|
73 this is exit code of synchronous subprocess. */
|
|
|
74 int synch_process_retcode;
|
|
|
75
|
|
|
76 /* Clean up when exiting Fcall_process_internal.
|
|
442
|
77 On Windows, delete the temporary file on any kind of termination.
|
|
428
|
78 On Unix, kill the process and any children on termination by signal. */
|
|
|
79
|
|
|
80 /* Nonzero if this is termination due to exit. */
|
|
|
81 static int call_process_exited;
|
|
|
82
|
|
|
83 Lisp_Object Vlisp_EXEC_SUFFIXES;
|
|
|
84
|
|
|
85 static Lisp_Object
|
|
|
86 call_process_kill (Lisp_Object fdpid)
|
|
|
87 {
|
|
|
88 Lisp_Object fd = Fcar (fdpid);
|
|
|
89 Lisp_Object pid = Fcdr (fdpid);
|
|
|
90
|
|
|
91 if (!NILP (fd))
|
|
|
92 close (XINT (fd));
|
|
|
93
|
|
|
94 if (!NILP (pid))
|
|
|
95 EMACS_KILLPG (XINT (pid), SIGKILL);
|
|
|
96
|
|
|
97 synch_process_alive = 0;
|
|
|
98 return Qnil;
|
|
|
99 }
|
|
|
100
|
|
|
101 static Lisp_Object
|
|
|
102 call_process_cleanup (Lisp_Object fdpid)
|
|
|
103 {
|
|
440
|
104 int fd = XINT (Fcar (fdpid));
|
|
428
|
105 int pid = XINT (Fcdr (fdpid));
|
|
|
106
|
|
|
107 if (!call_process_exited &&
|
|
|
108 EMACS_KILLPG (pid, SIGINT) == 0)
|
|
|
109 {
|
|
|
110 int speccount = specpdl_depth ();
|
|
|
111
|
|
|
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)");
|
|
|
115
|
|
442
|
116 #ifdef WIN32_NATIVE
|
|
440
|
117 {
|
|
|
118 HANDLE pHandle = OpenProcess (PROCESS_ALL_ACCESS, 0, pid);
|
|
|
119 if (pHandle == NULL)
|
|
432
|
120 warn_when_safe (Qprocess, Qwarning,
|
|
|
121 "cannot open process (PID %d) for cleanup", pid);
|
|
440
|
122 else
|
|
|
123 wait_for_termination (pHandle);
|
|
|
124 }
|
|
432
|
125 #else
|
|
428
|
126 wait_for_termination (pid);
|
|
432
|
127 #endif
|
|
428
|
128
|
|
|
129 /* "Discard" the unwind protect. */
|
|
|
130 XCAR (fdpid) = Qnil;
|
|
|
131 XCDR (fdpid) = Qnil;
|
|
|
132 unbind_to (speccount, Qnil);
|
|
|
133
|
|
|
134 message ("Waiting for process to die... done");
|
|
|
135 }
|
|
|
136 synch_process_alive = 0;
|
|
|
137 close (fd);
|
|
|
138 return Qnil;
|
|
|
139 }
|
|
|
140
|
|
|
141 static Lisp_Object fork_error;
|
|
|
142 #if 0 /* UNUSED */
|
|
|
143 static void
|
|
|
144 report_fork_error (char *string, Lisp_Object data)
|
|
|
145 {
|
|
|
146 Lisp_Object errstring = lisp_strerror (errno);
|
|
|
147
|
|
|
148 fork_error = Fcons (build_string (string), Fcons (errstring, data));
|
|
|
149
|
|
|
150 /* terminate this branch of the fork, without closing stdin/out/etc. */
|
|
|
151 _exit (1);
|
|
|
152 }
|
|
|
153 #endif /* unused */
|
|
|
154
|
|
442
|
155 DEFUN ("old-call-process-internal", Fold_call_process_internal, 1, MANY, 0, /*
|
|
428
|
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 (int nargs, Lisp_Object *args))
|
|
|
178 {
|
|
|
179 /* This function can GC */
|
|
|
180 Lisp_Object infile, buffer, current_dir, display, path;
|
|
|
181 int fd[2];
|
|
|
182 int filefd;
|
|
442
|
183 #ifdef WIN32_NATIVE
|
|
432
|
184 HANDLE pHandle;
|
|
|
185 #endif
|
|
428
|
186 int pid;
|
|
|
187 char buf[16384];
|
|
|
188 char *bufptr = buf;
|
|
|
189 int bufsize = 16384;
|
|
|
190 int speccount = specpdl_depth ();
|
|
442
|
191 struct gcpro gcpro1, gcpro2, gcpro3;
|
|
428
|
192 char **new_argv = alloca_array (char *, max (2, nargs - 2));
|
|
|
193
|
|
|
194 /* File to use for stderr in the child.
|
|
|
195 t means use same as standard output. */
|
|
|
196 Lisp_Object error_file;
|
|
|
197
|
|
|
198 CHECK_STRING (args[0]);
|
|
|
199
|
|
|
200 error_file = Qt;
|
|
|
201
|
|
|
202 #if defined (NO_SUBPROCESSES)
|
|
|
203 /* Without asynchronous processes we cannot have BUFFER == 0. */
|
|
|
204 if (nargs >= 3 && !INTP (args[2]))
|
|
|
205 error ("Operating system cannot handle asynchronous subprocesses");
|
|
|
206 #endif /* NO_SUBPROCESSES */
|
|
|
207
|
|
|
208 /* Do this before building new_argv because GC in Lisp code
|
|
|
209 * called by various filename-hacking routines might relocate strings */
|
|
|
210 locate_file (Vexec_path, args[0], Vlisp_EXEC_SUFFIXES, &path, X_OK);
|
|
|
211
|
|
|
212 /* Make sure that the child will be able to chdir to the current
|
|
|
213 buffer's current directory, or its unhandled equivalent. We
|
|
|
214 can't just have the child check for an error when it does the
|
|
|
215 chdir, since it's in a vfork. */
|
|
|
216 {
|
|
|
217 struct gcpro ngcpro1, ngcpro2;
|
|
|
218 /* Do this test before building new_argv because GC in Lisp code
|
|
|
219 * called by various filename-hacking routines might relocate strings */
|
|
|
220 /* Make sure that the child will be able to chdir to the current
|
|
|
221 buffer's current directory. We can't just have the child check
|
|
|
222 for an error when it does the chdir, since it's in a vfork. */
|
|
|
223
|
|
|
224 NGCPRO2 (current_dir, path); /* Caller gcprotects args[] */
|
|
|
225 current_dir = current_buffer->directory;
|
|
|
226 current_dir = Funhandled_file_name_directory (current_dir);
|
|
|
227 current_dir = expand_and_dir_to_file (current_dir, Qnil);
|
|
|
228 #if 0
|
|
|
229 /* This is in FSF, but it breaks everything in the presence of
|
|
|
230 ange-ftp-visited files, so away with it. */
|
|
|
231 if (NILP (Ffile_accessible_directory_p (current_dir)))
|
|
|
232 report_file_error ("Setting current directory",
|
|
|
233 Fcons (current_buffer->directory, Qnil));
|
|
|
234 #endif /* 0 */
|
|
|
235 NUNGCPRO;
|
|
|
236 }
|
|
|
237
|
|
442
|
238 GCPRO2 (current_dir, path);
|
|
428
|
239
|
|
|
240 if (nargs >= 2 && ! NILP (args[1]))
|
|
|
241 {
|
|
|
242 struct gcpro ngcpro1;
|
|
|
243 NGCPRO1 (current_buffer->directory);
|
|
|
244 infile = Fexpand_file_name (args[1], current_buffer->directory);
|
|
|
245 NUNGCPRO;
|
|
|
246 CHECK_STRING (infile);
|
|
|
247 }
|
|
|
248 else
|
|
|
249 infile = build_string (NULL_DEVICE);
|
|
|
250
|
|
|
251 UNGCPRO;
|
|
|
252
|
|
442
|
253 GCPRO3 (infile, current_dir, path); /* Fexpand_file_name might trash it */
|
|
428
|
254
|
|
|
255 if (nargs >= 3)
|
|
|
256 {
|
|
|
257 buffer = args[2];
|
|
|
258
|
|
|
259 /* If BUFFER is a list, its meaning is
|
|
|
260 (BUFFER-FOR-STDOUT FILE-FOR-STDERR). */
|
|
|
261 if (CONSP (buffer))
|
|
|
262 {
|
|
|
263 if (CONSP (XCDR (buffer)))
|
|
|
264 {
|
|
|
265 Lisp_Object file_for_stderr = XCAR (XCDR (buffer));
|
|
|
266
|
|
|
267 if (NILP (file_for_stderr) || EQ (Qt, file_for_stderr))
|
|
|
268 error_file = file_for_stderr;
|
|
|
269 else
|
|
|
270 error_file = Fexpand_file_name (file_for_stderr, Qnil);
|
|
|
271 }
|
|
|
272
|
|
|
273 buffer = XCAR (buffer);
|
|
|
274 }
|
|
|
275
|
|
|
276 if (!(EQ (buffer, Qnil)
|
|
|
277 || EQ (buffer, Qt)
|
|
|
278 || ZEROP (buffer)))
|
|
|
279 {
|
|
|
280 Lisp_Object spec_buffer = buffer;
|
|
|
281 buffer = Fget_buffer (buffer);
|
|
|
282 /* Mention the buffer name for a better error message. */
|
|
|
283 if (NILP (buffer))
|
|
|
284 CHECK_BUFFER (spec_buffer);
|
|
|
285 CHECK_BUFFER (buffer);
|
|
|
286 }
|
|
|
287 }
|
|
|
288 else
|
|
|
289 buffer = Qnil;
|
|
|
290
|
|
|
291 UNGCPRO;
|
|
|
292
|
|
|
293 display = ((nargs >= 4) ? args[3] : Qnil);
|
|
|
294
|
|
|
295 /* From here we assume we won't GC (unless an error is signaled). */
|
|
|
296 {
|
|
|
297 REGISTER int i;
|
|
|
298 for (i = 4; i < nargs; i++)
|
|
|
299 {
|
|
|
300 CHECK_STRING (args[i]);
|
|
|
301 new_argv[i - 3] = (char *) XSTRING_DATA (args[i]);
|
|
|
302 }
|
|
|
303 }
|
|
430
|
304 new_argv[max(nargs - 3,1)] = 0;
|
|
428
|
305
|
|
|
306 if (NILP (path))
|
|
|
307 report_file_error ("Searching for program", Fcons (args[0], Qnil));
|
|
|
308 new_argv[0] = (char *) XSTRING_DATA (path);
|
|
|
309
|
|
|
310 filefd = open ((char *) XSTRING_DATA (infile), O_RDONLY | OPEN_BINARY, 0);
|
|
|
311 if (filefd < 0)
|
|
|
312 report_file_error ("Opening process input file", Fcons (infile, Qnil));
|
|
|
313
|
|
|
314 if (INTP (buffer))
|
|
|
315 {
|
|
|
316 fd[1] = open (NULL_DEVICE, O_WRONLY | OPEN_BINARY, 0);
|
|
|
317 fd[0] = -1;
|
|
|
318 }
|
|
|
319 else
|
|
|
320 {
|
|
|
321 pipe (fd);
|
|
|
322 #if 0
|
|
|
323 /* Replaced by close_process_descs */
|
|
|
324 set_exclusive_use (fd[0]);
|
|
|
325 #endif
|
|
|
326 }
|
|
|
327
|
|
|
328 {
|
|
|
329 /* child_setup must clobber environ in systems with true vfork.
|
|
|
330 Protect it from permanent change. */
|
|
|
331 REGISTER char **save_environ = environ;
|
|
|
332 REGISTER int fd1 = fd[1];
|
|
|
333 int fd_error = fd1;
|
|
|
334 char **env;
|
|
|
335
|
|
|
336 env = environ;
|
|
|
337
|
|
|
338 /* Record that we're about to create a synchronous process. */
|
|
|
339 synch_process_alive = 1;
|
|
|
340
|
|
|
341 /* These vars record information from process termination.
|
|
|
342 Clear them now before process can possibly terminate,
|
|
|
343 to avoid timing error if process terminates soon. */
|
|
|
344 synch_process_death = 0;
|
|
|
345 synch_process_retcode = 0;
|
|
|
346
|
|
|
347 if (NILP (error_file))
|
|
|
348 fd_error = open (NULL_DEVICE, O_WRONLY | OPEN_BINARY);
|
|
|
349 else if (STRINGP (error_file))
|
|
|
350 {
|
|
442
|
351 fd_error = open ((const char *) XSTRING_DATA (error_file),
|
|
|
352 #ifdef WIN32_NATIVE
|
|
428
|
353 O_WRONLY | O_TRUNC | O_CREAT | O_TEXT,
|
|
|
354 S_IREAD | S_IWRITE
|
|
442
|
355 #else /* not WIN32_NATIVE */
|
|
428
|
356 O_WRONLY | O_TRUNC | O_CREAT | OPEN_BINARY,
|
|
|
357 CREAT_MODE
|
|
442
|
358 #endif /* not WIN32_NATIVE */
|
|
428
|
359 );
|
|
|
360 }
|
|
|
361
|
|
|
362 if (fd_error < 0)
|
|
|
363 {
|
|
442
|
364 int save_errno = errno;
|
|
428
|
365 close (filefd);
|
|
|
366 close (fd[0]);
|
|
|
367 if (fd1 >= 0)
|
|
|
368 close (fd1);
|
|
442
|
369 errno = save_errno;
|
|
428
|
370 report_file_error ("Cannot open", Fcons(error_file, Qnil));
|
|
|
371 }
|
|
|
372
|
|
|
373 fork_error = Qnil;
|
|
442
|
374 #ifdef WIN32_NATIVE
|
|
428
|
375 pid = child_setup (filefd, fd1, fd_error, new_argv,
|
|
|
376 (char *) XSTRING_DATA (current_dir));
|
|
432
|
377 if (!INTP (buffer))
|
|
|
378 {
|
|
|
379 /* OpenProcess() as soon after child_setup as possible. It's too
|
|
|
380 late once the process terminated. */
|
|
|
381 pHandle = OpenProcess(PROCESS_ALL_ACCESS, 0, pid);
|
|
|
382 #if 0
|
|
|
383 if (pHandle == NULL)
|
|
|
384 {
|
|
|
385 /* #### seems to cause crash in unbind_to(...) below. APA */
|
|
|
386 warn_when_safe (Qprocess, Qwarning,
|
|
|
387 "cannot open process to wait for");
|
|
|
388 }
|
|
|
389 #endif
|
|
|
390 }
|
|
|
391 /* Close STDERR into the parent process. We no longer need it. */
|
|
|
392 if (fd_error >= 0)
|
|
|
393 close (fd_error);
|
|
442
|
394 #else /* not WIN32_NATIVE */
|
|
428
|
395 pid = fork ();
|
|
|
396
|
|
|
397 if (pid == 0)
|
|
|
398 {
|
|
|
399 if (fd[0] >= 0)
|
|
|
400 close (fd[0]);
|
|
|
401 /* This is necessary because some shells may attempt to
|
|
|
402 access the current controlling terminal and will hang
|
|
|
403 if they are run in the background, as will be the case
|
|
|
404 when XEmacs is started in the background. Martin
|
|
|
405 Buchholz observed this problem running a subprocess
|
|
|
406 that used zsh to call gzip to uncompress an info
|
|
|
407 file. */
|
|
|
408 disconnect_controlling_terminal ();
|
|
|
409 child_setup (filefd, fd1, fd_error, new_argv,
|
|
|
410 (char *) XSTRING_DATA (current_dir));
|
|
|
411 }
|
|
|
412 if (fd_error >= 0)
|
|
|
413 close (fd_error);
|
|
|
414
|
|
442
|
415 #endif /* not WIN32_NATIVE */
|
|
428
|
416
|
|
|
417 environ = save_environ;
|
|
|
418
|
|
|
419 /* Close most of our fd's, but not fd[0]
|
|
|
420 since we will use that to read input from. */
|
|
|
421 close (filefd);
|
|
|
422 if (fd1 >= 0)
|
|
|
423 close (fd1);
|
|
|
424 }
|
|
|
425
|
|
|
426 if (!NILP (fork_error))
|
|
|
427 signal_error (Qfile_error, fork_error);
|
|
|
428
|
|
442
|
429 #ifndef WIN32_NATIVE
|
|
428
|
430 if (pid < 0)
|
|
|
431 {
|
|
442
|
432 int save_errno = errno;
|
|
428
|
433 if (fd[0] >= 0)
|
|
|
434 close (fd[0]);
|
|
442
|
435 errno = save_errno;
|
|
428
|
436 report_file_error ("Doing fork", Qnil);
|
|
|
437 }
|
|
432
|
438 #endif
|
|
428
|
439
|
|
|
440 if (INTP (buffer))
|
|
|
441 {
|
|
|
442 if (fd[0] >= 0)
|
|
|
443 close (fd[0]);
|
|
|
444 #if defined (NO_SUBPROCESSES)
|
|
|
445 /* If Emacs has been built with asynchronous subprocess support,
|
|
|
446 we don't need to do this, I think because it will then have
|
|
|
447 the facilities for handling SIGCHLD. */
|
|
|
448 wait_without_blocking ();
|
|
|
449 #endif /* NO_SUBPROCESSES */
|
|
|
450 return Qnil;
|
|
|
451 }
|
|
|
452
|
|
|
453 {
|
|
|
454 int nread;
|
|
|
455 int first = 1;
|
|
|
456 int total_read = 0;
|
|
|
457 Lisp_Object instream;
|
|
|
458 struct gcpro ngcpro1;
|
|
|
459
|
|
|
460 /* Enable sending signal if user quits below. */
|
|
|
461 call_process_exited = 0;
|
|
|
462
|
|
|
463 record_unwind_protect (call_process_cleanup,
|
|
|
464 Fcons (make_int (fd[0]), make_int (pid)));
|
|
|
465
|
|
|
466 /* FSFmacs calls Fset_buffer() here. We don't have to because
|
|
|
467 we can insert into buffers other than the current one. */
|
|
|
468 if (EQ (buffer, Qt))
|
|
|
469 XSETBUFFER (buffer, current_buffer);
|
|
|
470 instream = make_filedesc_input_stream (fd[0], 0, -1, LSTR_ALLOW_QUIT);
|
|
|
471 #ifdef FILE_CODING
|
|
|
472 instream =
|
|
|
473 make_decoding_input_stream
|
|
|
474 (XLSTREAM (instream),
|
|
|
475 Fget_coding_system (Vcoding_system_for_read));
|
|
|
476 Lstream_set_character_mode (XLSTREAM (instream));
|
|
|
477 #endif
|
|
|
478 NGCPRO1 (instream);
|
|
|
479 while (1)
|
|
|
480 {
|
|
|
481 QUIT;
|
|
|
482 /* Repeatedly read until we've filled as much as possible
|
|
|
483 of the buffer size we have. But don't read
|
|
|
484 less than 1024--save that for the next bufferfull. */
|
|
|
485
|
|
|
486 nread = 0;
|
|
|
487 while (nread < bufsize - 1024)
|
|
|
488 {
|
|
|
489 ssize_t this_read
|
|
|
490 = Lstream_read (XLSTREAM (instream), bufptr + nread,
|
|
|
491 bufsize - nread);
|
|
|
492
|
|
|
493 if (this_read < 0)
|
|
|
494 goto give_up;
|
|
|
495
|
|
|
496 if (this_read == 0)
|
|
|
497 goto give_up_1;
|
|
|
498
|
|
|
499 nread += this_read;
|
|
|
500 }
|
|
|
501
|
|
|
502 give_up_1:
|
|
|
503
|
|
|
504 /* Now NREAD is the total amount of data in the buffer. */
|
|
|
505 if (nread == 0)
|
|
|
506 break;
|
|
|
507
|
|
440
|
508 #if 0
|
|
442
|
509 #ifdef WIN32_NATIVE
|
|
428
|
510 /* Until we pull out of MULE things like
|
|
|
511 make_decoding_input_stream(), we do the following which is
|
|
|
512 less elegant. --marcpa */
|
|
440
|
513 /* We did. -- kkm */
|
|
428
|
514 {
|
|
|
515 int lf_count = 0;
|
|
|
516 if (NILP (Vbinary_process_output)) {
|
|
|
517 nread = crlf_to_lf(nread, bufptr, &lf_count);
|
|
|
518 }
|
|
|
519 }
|
|
|
520 #endif
|
|
440
|
521 #endif
|
|
428
|
522
|
|
|
523 total_read += nread;
|
|
|
524
|
|
|
525 if (!NILP (buffer))
|
|
|
526 buffer_insert_raw_string (XBUFFER (buffer), (Bufbyte *) bufptr,
|
|
|
527 nread);
|
|
|
528
|
|
|
529 /* Make the buffer bigger as we continue to read more data,
|
|
|
530 but not past 64k. */
|
|
|
531 if (bufsize < 64 * 1024 && total_read > 32 * bufsize)
|
|
|
532 {
|
|
|
533 bufsize *= 2;
|
|
|
534 bufptr = (char *) alloca (bufsize);
|
|
|
535 }
|
|
|
536
|
|
|
537 if (!NILP (display) && INTERACTIVE)
|
|
|
538 {
|
|
|
539 first = 0;
|
|
|
540 redisplay ();
|
|
|
541 }
|
|
|
542 }
|
|
|
543 give_up:
|
|
|
544 Lstream_close (XLSTREAM (instream));
|
|
|
545 NUNGCPRO;
|
|
|
546
|
|
|
547 QUIT;
|
|
|
548 /* Wait for it to terminate, unless it already has. */
|
|
442
|
549 #ifdef WIN32_NATIVE
|
|
432
|
550 wait_for_termination (pHandle);
|
|
|
551 #else
|
|
428
|
552 wait_for_termination (pid);
|
|
432
|
553 #endif
|
|
428
|
554
|
|
|
555 /* Don't kill any children that the subprocess may have left behind
|
|
|
556 when exiting. */
|
|
|
557 call_process_exited = 1;
|
|
|
558 unbind_to (speccount, Qnil);
|
|
|
559
|
|
|
560 if (synch_process_death)
|
|
|
561 return build_string (synch_process_death);
|
|
|
562 return make_int (synch_process_retcode);
|
|
|
563 }
|
|
|
564 }
|
|
|
565
|
|
|
566
|
|
|
567
|
|
|
568 /* Move the file descriptor FD so that its number is not less than MIN. *
|
|
|
569 The original file descriptor remains open. */
|
|
|
570 static int
|
|
|
571 relocate_fd (int fd, int min)
|
|
|
572 {
|
|
|
573 if (fd >= min)
|
|
|
574 return fd;
|
|
|
575 else
|
|
|
576 {
|
|
|
577 int newfd = dup (fd);
|
|
|
578 if (newfd == -1)
|
|
|
579 {
|
|
|
580 stderr_out ("Error while setting up child: %s\n",
|
|
|
581 strerror (errno));
|
|
|
582 _exit (1);
|
|
|
583 }
|
|
|
584 return relocate_fd (newfd, min);
|
|
|
585 }
|
|
|
586 }
|
|
|
587
|
|
|
588 /* This is the last thing run in a newly forked inferior
|
|
|
589 either synchronous or asynchronous.
|
|
|
590 Copy descriptors IN, OUT and ERR
|
|
|
591 as descriptors STDIN_FILENO, STDOUT_FILENO, and STDERR_FILENO.
|
|
|
592 Initialize inferior's priority, pgrp, connected dir and environment.
|
|
|
593 then exec another program based on new_argv.
|
|
|
594
|
|
|
595 This function may change environ for the superior process.
|
|
|
596 Therefore, the superior process must save and restore the value
|
|
|
597 of environ around the fork and the call to this function.
|
|
|
598
|
|
|
599 ENV is the environment for the subprocess.
|
|
|
600
|
|
|
601 XEmacs: We've removed the SET_PGRP argument because it's already
|
|
|
602 done by the callers of child_setup.
|
|
|
603
|
|
|
604 CURRENT_DIR is an elisp string giving the path of the current
|
|
|
605 directory the subprocess should have. Since we can't really signal
|
|
|
606 a decent error from within the child, this should be verified as an
|
|
|
607 executable directory by the parent. */
|
|
|
608
|
|
442
|
609 #ifdef WIN32_NATIVE
|
|
428
|
610 int
|
|
|
611 #else
|
|
|
612 void
|
|
|
613 #endif
|
|
|
614 child_setup (int in, int out, int err, char **new_argv,
|
|
442
|
615 const char *current_dir)
|
|
428
|
616 {
|
|
|
617 char **env;
|
|
|
618 char *pwd;
|
|
442
|
619 #ifdef WIN32_NATIVE
|
|
428
|
620 int cpid;
|
|
|
621 HANDLE handles[4];
|
|
442
|
622 #endif /* WIN32_NATIVE */
|
|
428
|
623
|
|
|
624 #ifdef SET_EMACS_PRIORITY
|
|
|
625 if (emacs_priority != 0)
|
|
|
626 nice (- emacs_priority);
|
|
|
627 #endif
|
|
|
628
|
|
442
|
629 /* Under Windows, we are not in a child process at all, so we should
|
|
|
630 not close handles inherited from the parent -- we are the parent
|
|
|
631 and doing so will screw up all manner of things! Similarly, most
|
|
|
632 of the rest of the cleanup done in this function is not done
|
|
|
633 under Windows.
|
|
|
634
|
|
|
635 #### This entire child_setup() function is an utter and complete
|
|
|
636 piece of shit. I would rewrite it, at the very least splitting
|
|
|
637 out the Windows and non-Windows stuff into two completely
|
|
|
638 different functions; but instead I'm trying to make it go away
|
|
|
639 entirely, using the Lisp definition in process.el. What's left
|
|
|
640 is to fix up the routines in event-msw.c (and in event-Xt.c and
|
|
|
641 event-tty.c) to allow for stream devices to be handled correctly.
|
|
|
642 There isn't much to do, in fact, and I'll fix it shortly. That
|
|
|
643 way, the Lisp definition can be used non-interactively too. */
|
|
|
644 #if !defined (NO_SUBPROCESSES) && !defined (WIN32_NATIVE)
|
|
428
|
645 /* Close Emacs's descriptors that this process should not have. */
|
|
|
646 close_process_descs ();
|
|
|
647 #endif /* not NO_SUBPROCESSES */
|
|
442
|
648 #ifndef WIN32_NATIVE
|
|
428
|
649 close_load_descs ();
|
|
442
|
650 #endif
|
|
428
|
651
|
|
|
652 /* Note that use of alloca is always safe here. It's obvious for systems
|
|
|
653 that do not have true vfork or that have true (stack) alloca.
|
|
|
654 If using vfork and C_ALLOCA it is safe because that changes
|
|
|
655 the superior's static variables as if the superior had done alloca
|
|
|
656 and will be cleaned up in the usual way. */
|
|
|
657 {
|
|
|
658 REGISTER int i;
|
|
|
659
|
|
|
660 i = strlen (current_dir);
|
|
|
661 pwd = alloca_array (char, i + 6);
|
|
|
662 memcpy (pwd, "PWD=", 4);
|
|
|
663 memcpy (pwd + 4, current_dir, i);
|
|
|
664 i += 4;
|
|
|
665 if (!IS_DIRECTORY_SEP (pwd[i - 1]))
|
|
|
666 pwd[i++] = DIRECTORY_SEP;
|
|
|
667 pwd[i] = 0;
|
|
|
668
|
|
|
669 /* We can't signal an Elisp error here; we're in a vfork. Since
|
|
|
670 the callers check the current directory before forking, this
|
|
|
671 should only return an error if the directory's permissions
|
|
|
672 are changed between the check and this chdir, but we should
|
|
|
673 at least check. */
|
|
|
674 if (chdir (pwd + 4) < 0)
|
|
|
675 {
|
|
|
676 /* Don't report the chdir error, or ange-ftp.el doesn't work. */
|
|
|
677 /* (FSFmacs does _exit (errno) here.) */
|
|
|
678 pwd = 0;
|
|
|
679 }
|
|
|
680 else
|
|
|
681 {
|
|
|
682 /* Strip trailing "/". Cretinous *[]&@$#^%@#$% Un*x */
|
|
|
683 /* leave "//" (from FSF) */
|
|
|
684 while (i > 6 && IS_DIRECTORY_SEP (pwd[i - 1]))
|
|
|
685 pwd[--i] = 0;
|
|
|
686 }
|
|
|
687 }
|
|
|
688
|
|
|
689 /* Set `env' to a vector of the strings in Vprocess_environment. */
|
|
|
690 /* + 2 to include PWD and terminating 0. */
|
|
|
691 env = alloca_array (char *, XINT (Flength (Vprocess_environment)) + 2);
|
|
|
692 {
|
|
|
693 REGISTER Lisp_Object tail;
|
|
|
694 char **new_env = env;
|
|
|
695
|
|
|
696 /* If we have a PWD envvar and we know the real current directory,
|
|
|
697 pass one down, but with corrected value. */
|
|
|
698 if (pwd && getenv ("PWD"))
|
|
|
699 *new_env++ = pwd;
|
|
|
700
|
|
|
701 /* Copy the Vprocess_environment strings into new_env. */
|
|
|
702 for (tail = Vprocess_environment;
|
|
|
703 CONSP (tail) && STRINGP (XCAR (tail));
|
|
|
704 tail = XCDR (tail))
|
|
|
705 {
|
|
|
706 char **ep = env;
|
|
|
707 char *envvar_external;
|
|
|
708
|
|
440
|
709 TO_EXTERNAL_FORMAT (LISP_STRING, XCAR (tail),
|
|
|
710 C_STRING_ALLOCA, envvar_external,
|
|
|
711 Qfile_name);
|
|
428
|
712
|
|
|
713 /* See if envvar_external duplicates any string already in the env.
|
|
|
714 If so, don't put it in.
|
|
|
715 When an env var has multiple definitions,
|
|
|
716 we keep the definition that comes first in process-environment. */
|
|
|
717 for (; ep != new_env; ep++)
|
|
|
718 {
|
|
|
719 char *p = *ep, *q = envvar_external;
|
|
|
720 while (1)
|
|
|
721 {
|
|
|
722 if (*q == 0)
|
|
|
723 /* The string is malformed; might as well drop it. */
|
|
|
724 goto duplicate;
|
|
|
725 if (*q != *p)
|
|
|
726 break;
|
|
|
727 if (*q == '=')
|
|
|
728 goto duplicate;
|
|
|
729 p++, q++;
|
|
|
730 }
|
|
|
731 }
|
|
|
732 if (pwd && !strncmp ("PWD=", envvar_external, 4))
|
|
|
733 {
|
|
|
734 *new_env++ = pwd;
|
|
|
735 pwd = 0;
|
|
|
736 }
|
|
|
737 else
|
|
|
738 *new_env++ = envvar_external;
|
|
|
739
|
|
|
740 duplicate: ;
|
|
|
741 }
|
|
|
742 *new_env = 0;
|
|
|
743 }
|
|
|
744
|
|
442
|
745 #ifdef WIN32_NATIVE
|
|
428
|
746 prepare_standard_handles (in, out, err, handles);
|
|
|
747 set_process_dir (current_dir);
|
|
442
|
748 #else /* not WIN32_NATIVE */
|
|
428
|
749 /* Make sure that in, out, and err are not actually already in
|
|
|
750 descriptors zero, one, or two; this could happen if Emacs is
|
|
|
751 started with its standard in, out, or error closed, as might
|
|
|
752 happen under X. */
|
|
|
753 in = relocate_fd (in, 3);
|
|
|
754 out = relocate_fd (out, 3);
|
|
|
755 err = relocate_fd (err, 3);
|
|
|
756
|
|
|
757 /* Set the standard input/output channels of the new process. */
|
|
|
758 close (STDIN_FILENO);
|
|
|
759 close (STDOUT_FILENO);
|
|
|
760 close (STDERR_FILENO);
|
|
|
761
|
|
|
762 dup2 (in, STDIN_FILENO);
|
|
|
763 dup2 (out, STDOUT_FILENO);
|
|
|
764 dup2 (err, STDERR_FILENO);
|
|
|
765
|
|
|
766 close (in);
|
|
|
767 close (out);
|
|
|
768 close (err);
|
|
|
769
|
|
|
770 /* I can't think of any reason why child processes need any more
|
|
|
771 than the standard 3 file descriptors. It would be cleaner to
|
|
|
772 close just the ones that need to be, but the following brute
|
|
|
773 force approach is certainly effective, and not too slow. */
|
|
|
774 {
|
|
|
775 int fd;
|
|
|
776 for (fd=3; fd<=64; fd++)
|
|
|
777 close (fd);
|
|
|
778 }
|
|
442
|
779 #endif /* not WIN32_NATIVE */
|
|
428
|
780
|
|
|
781 #ifdef vipc
|
|
|
782 something missing here;
|
|
|
783 #endif /* vipc */
|
|
|
784
|
|
442
|
785 #ifdef WIN32_NATIVE
|
|
428
|
786 /* Spawn the child. (See ntproc.c:Spawnve). */
|
|
442
|
787 cpid = spawnve (_P_NOWAIT, new_argv[0], (const char* const*)new_argv,
|
|
|
788 (const char* const*)env);
|
|
428
|
789 if (cpid == -1)
|
|
|
790 /* An error occurred while trying to spawn the process. */
|
|
|
791 report_file_error ("Spawning child process", Qnil);
|
|
|
792 reset_standard_handles (in, out, err, handles);
|
|
|
793 return cpid;
|
|
442
|
794 #else /* not WIN32_NATIVE */
|
|
428
|
795 /* execvp does not accept an environment arg so the only way
|
|
|
796 to pass this environment is to set environ. Our caller
|
|
|
797 is responsible for restoring the ambient value of environ. */
|
|
|
798 environ = env;
|
|
|
799 execvp (new_argv[0], new_argv);
|
|
|
800
|
|
|
801 stdout_out ("Can't exec program %s\n", new_argv[0]);
|
|
|
802 _exit (1);
|
|
442
|
803 #endif /* not WIN32_NATIVE */
|
|
428
|
804 }
|
|
|
805
|
|
|
806 static int
|
|
442
|
807 getenv_internal (const Bufbyte *var,
|
|
428
|
808 Bytecount varlen,
|
|
|
809 Bufbyte **value,
|
|
|
810 Bytecount *valuelen)
|
|
|
811 {
|
|
|
812 Lisp_Object scan;
|
|
|
813
|
|
|
814 for (scan = Vprocess_environment; CONSP (scan); scan = XCDR (scan))
|
|
|
815 {
|
|
|
816 Lisp_Object entry = XCAR (scan);
|
|
|
817
|
|
|
818 if (STRINGP (entry)
|
|
|
819 && XSTRING_LENGTH (entry) > varlen
|
|
|
820 && XSTRING_BYTE (entry, varlen) == '='
|
|
442
|
821 #ifdef WIN32_NATIVE
|
|
428
|
822 /* NT environment variables are case insensitive. */
|
|
|
823 && ! memicmp (XSTRING_DATA (entry), var, varlen)
|
|
442
|
824 #else /* not WIN32_NATIVE */
|
|
428
|
825 && ! memcmp (XSTRING_DATA (entry), var, varlen)
|
|
442
|
826 #endif /* not WIN32_NATIVE */
|
|
428
|
827 )
|
|
|
828 {
|
|
|
829 *value = XSTRING_DATA (entry) + (varlen + 1);
|
|
|
830 *valuelen = XSTRING_LENGTH (entry) - (varlen + 1);
|
|
|
831 return 1;
|
|
|
832 }
|
|
|
833 }
|
|
|
834
|
|
|
835 return 0;
|
|
|
836 }
|
|
|
837
|
|
|
838 DEFUN ("getenv", Fgetenv, 1, 2, "sEnvironment variable: \np", /*
|
|
|
839 Return the value of environment variable VAR, as a string.
|
|
|
840 VAR is a string, the name of the variable.
|
|
|
841 When invoked interactively, prints the value in the echo area.
|
|
|
842 */
|
|
|
843 (var, interactivep))
|
|
|
844 {
|
|
|
845 Bufbyte *value;
|
|
|
846 Bytecount valuelen;
|
|
|
847 Lisp_Object v = Qnil;
|
|
|
848 struct gcpro gcpro1;
|
|
|
849
|
|
|
850 CHECK_STRING (var);
|
|
|
851 GCPRO1 (v);
|
|
|
852 if (getenv_internal (XSTRING_DATA (var), XSTRING_LENGTH (var),
|
|
|
853 &value, &valuelen))
|
|
|
854 v = make_string (value, valuelen);
|
|
|
855 if (!NILP (interactivep))
|
|
|
856 {
|
|
|
857 if (NILP (v))
|
|
|
858 message ("%s not defined in environment", XSTRING_DATA (var));
|
|
|
859 else
|
|
|
860 /* #### Should use Fprin1_to_string or Fprin1 to handle string
|
|
|
861 containing quotes correctly. */
|
|
|
862 message ("\"%s\"", value);
|
|
|
863 }
|
|
|
864 RETURN_UNGCPRO (v);
|
|
|
865 }
|
|
|
866
|
|
|
867 /* A version of getenv that consults process_environment, easily
|
|
|
868 callable from C. */
|
|
|
869 char *
|
|
442
|
870 egetenv (const char *var)
|
|
428
|
871 {
|
|
442
|
872 /* This cannot GC -- 7-28-00 ben */
|
|
428
|
873 Bufbyte *value;
|
|
|
874 Bytecount valuelen;
|
|
|
875
|
|
442
|
876 if (getenv_internal ((const Bufbyte *) var, strlen (var), &value, &valuelen))
|
|
428
|
877 return (char *) value;
|
|
|
878 else
|
|
|
879 return 0;
|
|
|
880 }
|
|
|
881
|
|
|
882
|
|
|
883 void
|
|
|
884 init_callproc (void)
|
|
|
885 {
|
|
|
886 /* This function can GC */
|
|
|
887
|
|
|
888 {
|
|
|
889 /* jwz: always initialize Vprocess_environment, so that egetenv()
|
|
|
890 works in temacs. */
|
|
|
891 char **envp;
|
|
|
892 Vprocess_environment = Qnil;
|
|
|
893 for (envp = environ; envp && *envp; envp++)
|
|
440
|
894 Vprocess_environment =
|
|
|
895 Fcons (build_ext_string (*envp, Qfile_name), Vprocess_environment);
|
|
428
|
896 }
|
|
|
897
|
|
|
898 {
|
|
|
899 /* Initialize shell-file-name from environment variables or best guess. */
|
|
442
|
900 #ifdef WIN32_NATIVE
|
|
|
901 const char *shell = egetenv ("COMSPEC");
|
|
428
|
902 if (!shell) shell = "\\WINNT\\system32\\cmd.exe";
|
|
442
|
903 #else /* not WIN32_NATIVE */
|
|
|
904 const char *shell = egetenv ("SHELL");
|
|
428
|
905 if (!shell) shell = "/bin/sh";
|
|
|
906 #endif
|
|
|
907
|
|
|
908 Vshell_file_name = build_string (shell);
|
|
|
909 }
|
|
|
910 }
|
|
|
911
|
|
|
912 #if 0
|
|
|
913 void
|
|
|
914 set_process_environment (void)
|
|
|
915 {
|
|
|
916 REGISTER char **envp;
|
|
|
917
|
|
|
918 Vprocess_environment = Qnil;
|
|
|
919 #ifndef CANNOT_DUMP
|
|
|
920 if (initialized)
|
|
|
921 #endif
|
|
|
922 for (envp = environ; *envp; envp++)
|
|
|
923 Vprocess_environment = Fcons (build_string (*envp),
|
|
|
924 Vprocess_environment);
|
|
|
925 }
|
|
|
926 #endif /* unused */
|
|
|
927
|
|
|
928 void
|
|
|
929 syms_of_callproc (void)
|
|
|
930 {
|
|
442
|
931 DEFSUBR (Fold_call_process_internal);
|
|
428
|
932 DEFSUBR (Fgetenv);
|
|
|
933 }
|
|
|
934
|
|
|
935 void
|
|
|
936 vars_of_callproc (void)
|
|
|
937 {
|
|
|
938 /* This function can GC */
|
|
442
|
939 #ifdef WIN32_NATIVE
|
|
428
|
940 DEFVAR_LISP ("binary-process-input", &Vbinary_process_input /*
|
|
|
941 *If non-nil then new subprocesses are assumed to take binary input.
|
|
|
942 */ );
|
|
|
943 Vbinary_process_input = Qnil;
|
|
|
944
|
|
|
945 DEFVAR_LISP ("binary-process-output", &Vbinary_process_output /*
|
|
|
946 *If non-nil then new subprocesses are assumed to produce binary output.
|
|
|
947 */ );
|
|
|
948 Vbinary_process_output = Qnil;
|
|
442
|
949 #endif /* WIN32_NATIVE */
|
|
428
|
950
|
|
|
951 DEFVAR_LISP ("shell-file-name", &Vshell_file_name /*
|
|
|
952 *File name to load inferior shells from.
|
|
|
953 Initialized from the SHELL environment variable.
|
|
|
954 */ );
|
|
|
955
|
|
|
956 DEFVAR_LISP ("process-environment", &Vprocess_environment /*
|
|
|
957 List of environment variables for subprocesses to inherit.
|
|
|
958 Each element should be a string of the form ENVVARNAME=VALUE.
|
|
|
959 The environment which Emacs inherits is placed in this variable
|
|
|
960 when Emacs starts.
|
|
|
961 */ );
|
|
|
962
|
|
|
963 Vlisp_EXEC_SUFFIXES = build_string (EXEC_SUFFIXES);
|
|
|
964 staticpro (&Vlisp_EXEC_SUFFIXES);
|
|
|
965 }
|
