|
611
|
1 /* Old synchronous subprocess invocation for XEmacs.
|
|
428
|
2 Copyright (C) 1985, 86, 87, 88, 93, 94, 95 Free Software Foundation, Inc.
|
|
793
|
3 Copyright (C) 2000, 2001, 2002 Ben Wing.
|
|
428
|
4
|
|
|
5 This file is part of XEmacs.
|
|
|
6
|
|
|
7 XEmacs is free software; you can redistribute it and/or modify it
|
|
|
8 under the terms of the GNU General Public License as published by the
|
|
|
9 Free Software Foundation; either version 2, or (at your option) any
|
|
|
10 later version.
|
|
|
11
|
|
|
12 XEmacs is distributed in the hope that it will be useful, but WITHOUT
|
|
|
13 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
|
|
|
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
|
|
|
15 for more details.
|
|
|
16
|
|
|
17 You should have received a copy of the GNU General Public License
|
|
|
18 along with XEmacs; see the file COPYING. If not, write to
|
|
|
19 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
|
|
20 Boston, MA 02111-1307, USA. */
|
|
|
21
|
|
|
22 /* Synched up with: Mule 2.0, FSF 19.30. */
|
|
|
23 /* Partly sync'ed with 19.36.4 */
|
|
|
24
|
|
611
|
25
|
|
814
|
26 /* #### Everything in this file should go. As soon as I merge my
|
|
|
27 stderr-proc WS, it will.
|
|
611
|
28 */
|
|
|
29
|
|
428
|
30 #include <config.h>
|
|
|
31 #include "lisp.h"
|
|
|
32
|
|
|
33 #include "buffer.h"
|
|
|
34 #include "commands.h"
|
|
814
|
35 #include "file-coding.h"
|
|
428
|
36 #include "insdel.h"
|
|
|
37 #include "lstream.h"
|
|
|
38 #include "process.h"
|
|
|
39 #include "sysdep.h"
|
|
|
40 #include "window.h"
|
|
|
41
|
|
771
|
42 #include "sysdir.h"
|
|
814
|
43 #include "sysfile.h"
|
|
|
44 #include "sysproc.h"
|
|
|
45 #include "syssignal.h"
|
|
|
46 #include "systime.h"
|
|
|
47 #include "systty.h"
|
|
428
|
48
|
|
|
49 /* True iff we are about to fork off a synchronous process or if we
|
|
|
50 are waiting for it. */
|
|
|
51 volatile int synch_process_alive;
|
|
|
52
|
|
|
53 /* Nonzero => this is a string explaining death of synchronous subprocess. */
|
|
442
|
54 const char *synch_process_death;
|
|
428
|
55
|
|
|
56 /* If synch_process_death is zero,
|
|
|
57 this is exit code of synchronous subprocess. */
|
|
|
58 int synch_process_retcode;
|
|
|
59
|
|
|
60 /* Clean up when exiting Fcall_process_internal.
|
|
442
|
61 On Windows, delete the temporary file on any kind of termination.
|
|
428
|
62 On Unix, kill the process and any children on termination by signal. */
|
|
|
63
|
|
|
64 /* Nonzero if this is termination due to exit. */
|
|
|
65 static int call_process_exited;
|
|
|
66
|
|
|
67 static Lisp_Object
|
|
|
68 call_process_kill (Lisp_Object fdpid)
|
|
|
69 {
|
|
|
70 Lisp_Object fd = Fcar (fdpid);
|
|
|
71 Lisp_Object pid = Fcdr (fdpid);
|
|
|
72
|
|
|
73 if (!NILP (fd))
|
|
771
|
74 retry_close (XINT (fd));
|
|
428
|
75
|
|
|
76 if (!NILP (pid))
|
|
|
77 EMACS_KILLPG (XINT (pid), SIGKILL);
|
|
|
78
|
|
|
79 synch_process_alive = 0;
|
|
|
80 return Qnil;
|
|
|
81 }
|
|
|
82
|
|
|
83 static Lisp_Object
|
|
|
84 call_process_cleanup (Lisp_Object fdpid)
|
|
|
85 {
|
|
440
|
86 int fd = XINT (Fcar (fdpid));
|
|
428
|
87 int pid = XINT (Fcdr (fdpid));
|
|
|
88
|
|
|
89 if (!call_process_exited &&
|
|
|
90 EMACS_KILLPG (pid, SIGINT) == 0)
|
|
|
91 {
|
|
|
92 int speccount = specpdl_depth ();
|
|
|
93
|
|
|
94 record_unwind_protect (call_process_kill, fdpid);
|
|
|
95 /* #### "c-G" -- need non-consing Single-key-description */
|
|
|
96 message ("Waiting for process to die...(type C-g again to kill it instantly)");
|
|
|
97
|
|
|
98 wait_for_termination (pid);
|
|
|
99
|
|
|
100 /* "Discard" the unwind protect. */
|
|
|
101 XCAR (fdpid) = Qnil;
|
|
|
102 XCDR (fdpid) = Qnil;
|
|
771
|
103 unbind_to (speccount);
|
|
428
|
104
|
|
|
105 message ("Waiting for process to die... done");
|
|
|
106 }
|
|
|
107 synch_process_alive = 0;
|
|
771
|
108 retry_close (fd);
|
|
428
|
109 return Qnil;
|
|
|
110 }
|
|
|
111
|
|
442
|
112 DEFUN ("old-call-process-internal", Fold_call_process_internal, 1, MANY, 0, /*
|
|
428
|
113 Call PROGRAM synchronously in separate process, with coding-system specified.
|
|
|
114 Arguments are
|
|
|
115 (PROGRAM &optional INFILE BUFFER DISPLAY &rest ARGS).
|
|
|
116 The program's input comes from file INFILE (nil means `/dev/null').
|
|
|
117 Insert output in BUFFER before point; t means current buffer;
|
|
|
118 nil for BUFFER means discard it; 0 means discard and don't wait.
|
|
837
|
119 If BUFFER is a string, then find or create a buffer with that name,
|
|
|
120 then insert the output in that buffer, before point.
|
|
428
|
121 BUFFER can also have the form (REAL-BUFFER STDERR-FILE); in that case,
|
|
|
122 REAL-BUFFER says what to do with standard output, as above,
|
|
|
123 while STDERR-FILE says what to do with standard error in the child.
|
|
|
124 STDERR-FILE may be nil (discard standard error output),
|
|
|
125 t (mix it with ordinary output), or a file name string.
|
|
|
126
|
|
|
127 Fourth arg DISPLAY non-nil means redisplay buffer as output is inserted.
|
|
|
128 Remaining arguments are strings passed as command arguments to PROGRAM.
|
|
|
129
|
|
|
130 If BUFFER is 0, `call-process' returns immediately with value nil.
|
|
|
131 Otherwise it waits for PROGRAM to terminate and returns a numeric exit status
|
|
|
132 or a signal description string.
|
|
|
133 If you quit, the process is killed with SIGINT, or SIGKILL if you
|
|
|
134 quit again.
|
|
|
135 */
|
|
|
136 (int nargs, Lisp_Object *args))
|
|
|
137 {
|
|
|
138 /* This function can GC */
|
|
|
139 Lisp_Object infile, buffer, current_dir, display, path;
|
|
|
140 int fd[2];
|
|
|
141 int filefd;
|
|
|
142 int pid;
|
|
|
143 char buf[16384];
|
|
|
144 char *bufptr = buf;
|
|
|
145 int bufsize = 16384;
|
|
|
146 int speccount = specpdl_depth ();
|
|
442
|
147 struct gcpro gcpro1, gcpro2, gcpro3;
|
|
771
|
148 Intbyte **new_argv = alloca_array (Intbyte *, max (2, nargs - 2));
|
|
428
|
149
|
|
|
150 /* File to use for stderr in the child.
|
|
|
151 t means use same as standard output. */
|
|
|
152 Lisp_Object error_file;
|
|
|
153
|
|
|
154 CHECK_STRING (args[0]);
|
|
|
155
|
|
|
156 error_file = Qt;
|
|
|
157
|
|
|
158 #if defined (NO_SUBPROCESSES)
|
|
|
159 /* Without asynchronous processes we cannot have BUFFER == 0. */
|
|
|
160 if (nargs >= 3 && !INTP (args[2]))
|
|
563
|
161 signal_error (Qunimplemented, "Operating system cannot handle asynchronous subprocesses", Qunbound);
|
|
428
|
162 #endif /* NO_SUBPROCESSES */
|
|
|
163
|
|
502
|
164 /* Do all filename munging before building new_argv because GC in
|
|
|
165 * Lisp code called by various filename-hacking routines might
|
|
|
166 * relocate strings */
|
|
428
|
167 locate_file (Vexec_path, args[0], Vlisp_EXEC_SUFFIXES, &path, X_OK);
|
|
|
168
|
|
|
169 /* Make sure that the child will be able to chdir to the current
|
|
502
|
170 buffer's current directory, or its unhandled equivalent. [[ We
|
|
428
|
171 can't just have the child check for an error when it does the
|
|
502
|
172 chdir, since it's in a vfork. ]] -- not any more, we don't use
|
|
|
173 vfork. -ben
|
|
|
174
|
|
|
175 Note: These calls are spread out to insure that the return values
|
|
|
176 of the calls (which may be newly-created strings) are properly
|
|
|
177 GC-protected. */
|
|
428
|
178 {
|
|
|
179 struct gcpro ngcpro1, ngcpro2;
|
|
502
|
180 NGCPRO2 (current_dir, path); /* Caller gcprotects args[] */
|
|
446
|
181 current_dir = current_buffer->directory;
|
|
502
|
182 /* If the current dir has no terminating slash, we'll get undesirable
|
|
|
183 results, so put the slash back. */
|
|
|
184 current_dir = Ffile_name_as_directory (current_dir);
|
|
428
|
185 current_dir = Funhandled_file_name_directory (current_dir);
|
|
|
186 current_dir = expand_and_dir_to_file (current_dir, Qnil);
|
|
502
|
187
|
|
428
|
188 #if 0
|
|
|
189 /* This is in FSF, but it breaks everything in the presence of
|
|
|
190 ange-ftp-visited files, so away with it. */
|
|
|
191 if (NILP (Ffile_accessible_directory_p (current_dir)))
|
|
563
|
192 signal_error (Qprocess_error, "Setting current directory",
|
|
|
193 current_buffer->directory);
|
|
428
|
194 #endif /* 0 */
|
|
|
195 NUNGCPRO;
|
|
|
196 }
|
|
|
197
|
|
442
|
198 GCPRO2 (current_dir, path);
|
|
428
|
199
|
|
|
200 if (nargs >= 2 && ! NILP (args[1]))
|
|
|
201 {
|
|
|
202 struct gcpro ngcpro1;
|
|
|
203 NGCPRO1 (current_buffer->directory);
|
|
|
204 infile = Fexpand_file_name (args[1], current_buffer->directory);
|
|
|
205 NUNGCPRO;
|
|
|
206 CHECK_STRING (infile);
|
|
|
207 }
|
|
|
208 else
|
|
|
209 infile = build_string (NULL_DEVICE);
|
|
|
210
|
|
|
211 UNGCPRO;
|
|
|
212
|
|
442
|
213 GCPRO3 (infile, current_dir, path); /* Fexpand_file_name might trash it */
|
|
428
|
214
|
|
|
215 if (nargs >= 3)
|
|
|
216 {
|
|
|
217 buffer = args[2];
|
|
|
218
|
|
|
219 /* If BUFFER is a list, its meaning is
|
|
|
220 (BUFFER-FOR-STDOUT FILE-FOR-STDERR). */
|
|
|
221 if (CONSP (buffer))
|
|
|
222 {
|
|
|
223 if (CONSP (XCDR (buffer)))
|
|
|
224 {
|
|
|
225 Lisp_Object file_for_stderr = XCAR (XCDR (buffer));
|
|
|
226
|
|
|
227 if (NILP (file_for_stderr) || EQ (Qt, file_for_stderr))
|
|
|
228 error_file = file_for_stderr;
|
|
|
229 else
|
|
|
230 error_file = Fexpand_file_name (file_for_stderr, Qnil);
|
|
|
231 }
|
|
|
232
|
|
|
233 buffer = XCAR (buffer);
|
|
|
234 }
|
|
|
235
|
|
|
236 if (!(EQ (buffer, Qnil)
|
|
|
237 || EQ (buffer, Qt)
|
|
|
238 || ZEROP (buffer)))
|
|
|
239 {
|
|
|
240 Lisp_Object spec_buffer = buffer;
|
|
|
241 buffer = Fget_buffer (buffer);
|
|
|
242 /* Mention the buffer name for a better error message. */
|
|
|
243 if (NILP (buffer))
|
|
|
244 CHECK_BUFFER (spec_buffer);
|
|
|
245 CHECK_BUFFER (buffer);
|
|
|
246 }
|
|
|
247 }
|
|
|
248 else
|
|
|
249 buffer = Qnil;
|
|
|
250
|
|
|
251 UNGCPRO;
|
|
|
252
|
|
|
253 display = ((nargs >= 4) ? args[3] : Qnil);
|
|
|
254
|
|
|
255 /* From here we assume we won't GC (unless an error is signaled). */
|
|
|
256 {
|
|
|
257 REGISTER int i;
|
|
|
258 for (i = 4; i < nargs; i++)
|
|
|
259 {
|
|
|
260 CHECK_STRING (args[i]);
|
|
771
|
261 new_argv[i - 3] = XSTRING_DATA (args[i]);
|
|
428
|
262 }
|
|
|
263 }
|
|
430
|
264 new_argv[max(nargs - 3,1)] = 0;
|
|
428
|
265
|
|
|
266 if (NILP (path))
|
|
771
|
267 signal_error (Qprocess_error, "Searching for program",
|
|
|
268 Fcons (args[0], Qnil));
|
|
|
269 new_argv[0] = XSTRING_DATA (path);
|
|
428
|
270
|
|
771
|
271 filefd = qxe_open (XSTRING_DATA (infile), O_RDONLY | OPEN_BINARY, 0);
|
|
428
|
272 if (filefd < 0)
|
|
563
|
273 report_process_error ("Opening process input file", infile);
|
|
428
|
274
|
|
|
275 if (INTP (buffer))
|
|
|
276 {
|
|
771
|
277 fd[1] = qxe_open ((Intbyte *) NULL_DEVICE, O_WRONLY | OPEN_BINARY, 0);
|
|
428
|
278 fd[0] = -1;
|
|
|
279 }
|
|
|
280 else
|
|
|
281 {
|
|
|
282 pipe (fd);
|
|
|
283 #if 0
|
|
|
284 /* Replaced by close_process_descs */
|
|
|
285 set_exclusive_use (fd[0]);
|
|
|
286 #endif
|
|
|
287 }
|
|
|
288
|
|
|
289 {
|
|
|
290 REGISTER int fd1 = fd[1];
|
|
|
291 int fd_error = fd1;
|
|
|
292
|
|
|
293 /* Record that we're about to create a synchronous process. */
|
|
|
294 synch_process_alive = 1;
|
|
|
295
|
|
|
296 /* These vars record information from process termination.
|
|
|
297 Clear them now before process can possibly terminate,
|
|
|
298 to avoid timing error if process terminates soon. */
|
|
|
299 synch_process_death = 0;
|
|
|
300 synch_process_retcode = 0;
|
|
|
301
|
|
|
302 if (NILP (error_file))
|
|
771
|
303 fd_error = qxe_open ((Intbyte *) NULL_DEVICE, O_WRONLY | OPEN_BINARY);
|
|
428
|
304 else if (STRINGP (error_file))
|
|
|
305 {
|
|
771
|
306 fd_error = qxe_open (XSTRING_DATA (error_file),
|
|
|
307 O_WRONLY | O_TRUNC | O_CREAT | OPEN_BINARY,
|
|
814
|
308 CREAT_MODE);
|
|
428
|
309 }
|
|
|
310
|
|
|
311 if (fd_error < 0)
|
|
|
312 {
|
|
442
|
313 int save_errno = errno;
|
|
771
|
314 retry_close (filefd);
|
|
|
315 retry_close (fd[0]);
|
|
428
|
316 if (fd1 >= 0)
|
|
771
|
317 retry_close (fd1);
|
|
442
|
318 errno = save_errno;
|
|
771
|
319 report_process_error ("Cannot open", Fcons (error_file, Qnil));
|
|
428
|
320 }
|
|
|
321
|
|
|
322 pid = fork ();
|
|
|
323
|
|
|
324 if (pid == 0)
|
|
|
325 {
|
|
|
326 if (fd[0] >= 0)
|
|
771
|
327 retry_close (fd[0]);
|
|
428
|
328 /* This is necessary because some shells may attempt to
|
|
|
329 access the current controlling terminal and will hang
|
|
|
330 if they are run in the background, as will be the case
|
|
|
331 when XEmacs is started in the background. Martin
|
|
|
332 Buchholz observed this problem running a subprocess
|
|
|
333 that used zsh to call gzip to uncompress an info
|
|
|
334 file. */
|
|
|
335 disconnect_controlling_terminal ();
|
|
771
|
336 child_setup (filefd, fd1, fd_error, new_argv, current_dir);
|
|
428
|
337 }
|
|
|
338 if (fd_error >= 0)
|
|
771
|
339 retry_close (fd_error);
|
|
428
|
340
|
|
|
341 /* Close most of our fd's, but not fd[0]
|
|
|
342 since we will use that to read input from. */
|
|
771
|
343 retry_close (filefd);
|
|
428
|
344 if (fd1 >= 0)
|
|
771
|
345 retry_close (fd1);
|
|
428
|
346 }
|
|
|
347
|
|
|
348 if (pid < 0)
|
|
|
349 {
|
|
442
|
350 int save_errno = errno;
|
|
428
|
351 if (fd[0] >= 0)
|
|
771
|
352 retry_close (fd[0]);
|
|
442
|
353 errno = save_errno;
|
|
563
|
354 report_process_error ("Doing fork", Qunbound);
|
|
428
|
355 }
|
|
|
356
|
|
|
357 if (INTP (buffer))
|
|
|
358 {
|
|
|
359 if (fd[0] >= 0)
|
|
771
|
360 retry_close (fd[0]);
|
|
428
|
361 #if defined (NO_SUBPROCESSES)
|
|
|
362 /* If Emacs has been built with asynchronous subprocess support,
|
|
|
363 we don't need to do this, I think because it will then have
|
|
|
364 the facilities for handling SIGCHLD. */
|
|
|
365 wait_without_blocking ();
|
|
|
366 #endif /* NO_SUBPROCESSES */
|
|
|
367 return Qnil;
|
|
|
368 }
|
|
|
369
|
|
|
370 {
|
|
|
371 int nread;
|
|
|
372 int total_read = 0;
|
|
|
373 Lisp_Object instream;
|
|
|
374 struct gcpro ngcpro1;
|
|
|
375
|
|
|
376 /* Enable sending signal if user quits below. */
|
|
|
377 call_process_exited = 0;
|
|
|
378
|
|
|
379 record_unwind_protect (call_process_cleanup,
|
|
|
380 Fcons (make_int (fd[0]), make_int (pid)));
|
|
|
381
|
|
|
382 /* FSFmacs calls Fset_buffer() here. We don't have to because
|
|
|
383 we can insert into buffers other than the current one. */
|
|
|
384 if (EQ (buffer, Qt))
|
|
793
|
385 buffer = wrap_buffer (current_buffer);
|
|
428
|
386 instream = make_filedesc_input_stream (fd[0], 0, -1, LSTR_ALLOW_QUIT);
|
|
|
387 instream =
|
|
771
|
388 make_coding_input_stream
|
|
428
|
389 (XLSTREAM (instream),
|
|
771
|
390 get_coding_system_for_text_file (Vcoding_system_for_read, 1),
|
|
800
|
391 CODING_DECODE, 0);
|
|
428
|
392 NGCPRO1 (instream);
|
|
|
393 while (1)
|
|
|
394 {
|
|
|
395 QUIT;
|
|
|
396 /* Repeatedly read until we've filled as much as possible
|
|
|
397 of the buffer size we have. But don't read
|
|
|
398 less than 1024--save that for the next bufferfull. */
|
|
|
399
|
|
|
400 nread = 0;
|
|
|
401 while (nread < bufsize - 1024)
|
|
|
402 {
|
|
665
|
403 Bytecount this_read
|
|
428
|
404 = Lstream_read (XLSTREAM (instream), bufptr + nread,
|
|
|
405 bufsize - nread);
|
|
|
406
|
|
|
407 if (this_read < 0)
|
|
|
408 goto give_up;
|
|
|
409
|
|
|
410 if (this_read == 0)
|
|
|
411 goto give_up_1;
|
|
|
412
|
|
|
413 nread += this_read;
|
|
|
414 }
|
|
|
415
|
|
|
416 give_up_1:
|
|
|
417
|
|
|
418 /* Now NREAD is the total amount of data in the buffer. */
|
|
|
419 if (nread == 0)
|
|
|
420 break;
|
|
|
421
|
|
440
|
422 #if 0
|
|
771
|
423 /* [[check Vbinary_process_output]] */
|
|
440
|
424 #endif
|
|
428
|
425
|
|
|
426 total_read += nread;
|
|
|
427
|
|
|
428 if (!NILP (buffer))
|
|
665
|
429 buffer_insert_raw_string (XBUFFER (buffer), (Intbyte *) bufptr,
|
|
428
|
430 nread);
|
|
|
431
|
|
|
432 /* Make the buffer bigger as we continue to read more data,
|
|
|
433 but not past 64k. */
|
|
|
434 if (bufsize < 64 * 1024 && total_read > 32 * bufsize)
|
|
|
435 {
|
|
|
436 bufsize *= 2;
|
|
|
437 bufptr = (char *) alloca (bufsize);
|
|
|
438 }
|
|
|
439
|
|
|
440 if (!NILP (display) && INTERACTIVE)
|
|
|
441 {
|
|
|
442 redisplay ();
|
|
|
443 }
|
|
|
444 }
|
|
|
445 give_up:
|
|
|
446 Lstream_close (XLSTREAM (instream));
|
|
|
447 NUNGCPRO;
|
|
|
448
|
|
|
449 QUIT;
|
|
|
450 /* Wait for it to terminate, unless it already has. */
|
|
|
451 wait_for_termination (pid);
|
|
|
452
|
|
|
453 /* Don't kill any children that the subprocess may have left behind
|
|
|
454 when exiting. */
|
|
|
455 call_process_exited = 1;
|
|
771
|
456 unbind_to (speccount);
|
|
428
|
457
|
|
|
458 if (synch_process_death)
|
|
771
|
459 return build_msg_string (synch_process_death);
|
|
428
|
460 return make_int (synch_process_retcode);
|
|
|
461 }
|
|
|
462 }
|
|
|
463
|
|
|
464
|
|
|
465
|
|
|
466 /* Move the file descriptor FD so that its number is not less than MIN. *
|
|
|
467 The original file descriptor remains open. */
|
|
|
468 static int
|
|
|
469 relocate_fd (int fd, int min)
|
|
|
470 {
|
|
|
471 if (fd >= min)
|
|
|
472 return fd;
|
|
|
473 else
|
|
|
474 {
|
|
|
475 int newfd = dup (fd);
|
|
|
476 if (newfd == -1)
|
|
|
477 {
|
|
771
|
478 Intbyte *errmess;
|
|
|
479 GET_STRERROR (errmess, errno);
|
|
|
480 stderr_out ("Error while setting up child: %s\n", errmess);
|
|
428
|
481 _exit (1);
|
|
|
482 }
|
|
|
483 return relocate_fd (newfd, min);
|
|
|
484 }
|
|
|
485 }
|
|
|
486
|
|
|
487 /* This is the last thing run in a newly forked inferior
|
|
|
488 either synchronous or asynchronous.
|
|
|
489 Copy descriptors IN, OUT and ERR
|
|
|
490 as descriptors STDIN_FILENO, STDOUT_FILENO, and STDERR_FILENO.
|
|
|
491 Initialize inferior's priority, pgrp, connected dir and environment.
|
|
|
492 then exec another program based on new_argv.
|
|
|
493
|
|
|
494 XEmacs: We've removed the SET_PGRP argument because it's already
|
|
|
495 done by the callers of child_setup.
|
|
|
496
|
|
|
497 CURRENT_DIR is an elisp string giving the path of the current
|
|
|
498 directory the subprocess should have. Since we can't really signal
|
|
771
|
499 a decent error from within the child (not quite correct in
|
|
|
500 XEmacs?), this should be verified as an executable directory by the
|
|
|
501 parent. */
|
|
428
|
502
|
|
|
503 void
|
|
771
|
504 child_setup (int in, int out, int err, Intbyte **new_argv,
|
|
|
505 Lisp_Object current_dir)
|
|
428
|
506 {
|
|
771
|
507 Intbyte **env;
|
|
|
508 Intbyte *pwd;
|
|
428
|
509
|
|
|
510 #ifdef SET_EMACS_PRIORITY
|
|
|
511 if (emacs_priority != 0)
|
|
|
512 nice (- emacs_priority);
|
|
|
513 #endif
|
|
|
514
|
|
442
|
515 /* Under Windows, we are not in a child process at all, so we should
|
|
|
516 not close handles inherited from the parent -- we are the parent
|
|
|
517 and doing so will screw up all manner of things! Similarly, most
|
|
|
518 of the rest of the cleanup done in this function is not done
|
|
|
519 under Windows.
|
|
|
520
|
|
|
521 #### This entire child_setup() function is an utter and complete
|
|
|
522 piece of shit. I would rewrite it, at the very least splitting
|
|
|
523 out the Windows and non-Windows stuff into two completely
|
|
|
524 different functions; but instead I'm trying to make it go away
|
|
|
525 entirely, using the Lisp definition in process.el. What's left
|
|
|
526 is to fix up the routines in event-msw.c (and in event-Xt.c and
|
|
|
527 event-tty.c) to allow for stream devices to be handled correctly.
|
|
|
528 There isn't much to do, in fact, and I'll fix it shortly. That
|
|
|
529 way, the Lisp definition can be used non-interactively too. */
|
|
814
|
530 #if !defined (NO_SUBPROCESSES)
|
|
428
|
531 /* Close Emacs's descriptors that this process should not have. */
|
|
|
532 close_process_descs ();
|
|
|
533 #endif /* not NO_SUBPROCESSES */
|
|
|
534 close_load_descs ();
|
|
|
535
|
|
771
|
536 /* [[Note that use of alloca is always safe here. It's obvious for systems
|
|
428
|
537 that do not have true vfork or that have true (stack) alloca.
|
|
|
538 If using vfork and C_ALLOCA it is safe because that changes
|
|
|
539 the superior's static variables as if the superior had done alloca
|
|
771
|
540 and will be cleaned up in the usual way.]] -- irrelevant because
|
|
|
541 XEmacs does not use vfork. */
|
|
428
|
542 {
|
|
771
|
543 REGISTER Bytecount i;
|
|
428
|
544
|
|
771
|
545 i = XSTRING_LENGTH (current_dir);
|
|
|
546 pwd = alloca_array (Intbyte, i + 6);
|
|
428
|
547 memcpy (pwd, "PWD=", 4);
|
|
771
|
548 memcpy (pwd + 4, XSTRING_DATA (current_dir), i);
|
|
428
|
549 i += 4;
|
|
|
550 if (!IS_DIRECTORY_SEP (pwd[i - 1]))
|
|
|
551 pwd[i++] = DIRECTORY_SEP;
|
|
|
552 pwd[i] = 0;
|
|
|
553
|
|
771
|
554 /* [[We can't signal an Elisp error here; we're in a vfork. Since
|
|
428
|
555 the callers check the current directory before forking, this
|
|
|
556 should only return an error if the directory's permissions
|
|
|
557 are changed between the check and this chdir, but we should
|
|
771
|
558 at least check.]] -- irrelevant because XEmacs does not use vfork. */
|
|
|
559 if (qxe_chdir (pwd + 4) < 0)
|
|
428
|
560 {
|
|
|
561 /* Don't report the chdir error, or ange-ftp.el doesn't work. */
|
|
|
562 /* (FSFmacs does _exit (errno) here.) */
|
|
|
563 pwd = 0;
|
|
|
564 }
|
|
|
565 else
|
|
|
566 {
|
|
|
567 /* Strip trailing "/". Cretinous *[]&@$#^%@#$% Un*x */
|
|
|
568 /* leave "//" (from FSF) */
|
|
|
569 while (i > 6 && IS_DIRECTORY_SEP (pwd[i - 1]))
|
|
|
570 pwd[--i] = 0;
|
|
|
571 }
|
|
|
572 }
|
|
|
573
|
|
|
574 /* Set `env' to a vector of the strings in Vprocess_environment. */
|
|
|
575 /* + 2 to include PWD and terminating 0. */
|
|
771
|
576 env = alloca_array (Intbyte *, XINT (Flength (Vprocess_environment)) + 2);
|
|
428
|
577 {
|
|
|
578 REGISTER Lisp_Object tail;
|
|
771
|
579 Intbyte **new_env = env;
|
|
428
|
580
|
|
|
581 /* If we have a PWD envvar and we know the real current directory,
|
|
|
582 pass one down, but with corrected value. */
|
|
771
|
583 if (pwd && egetenv ("PWD"))
|
|
428
|
584 *new_env++ = pwd;
|
|
|
585
|
|
|
586 /* Copy the Vprocess_environment strings into new_env. */
|
|
|
587 for (tail = Vprocess_environment;
|
|
|
588 CONSP (tail) && STRINGP (XCAR (tail));
|
|
|
589 tail = XCDR (tail))
|
|
771
|
590 {
|
|
|
591 Intbyte **ep = env;
|
|
|
592 Intbyte *envvar = XSTRING_DATA (XCAR (tail));
|
|
428
|
593
|
|
771
|
594 /* See if envvar duplicates any string already in the env.
|
|
428
|
595 If so, don't put it in.
|
|
|
596 When an env var has multiple definitions,
|
|
|
597 we keep the definition that comes first in process-environment. */
|
|
|
598 for (; ep != new_env; ep++)
|
|
|
599 {
|
|
771
|
600 Intbyte *p = *ep, *q = envvar;
|
|
428
|
601 while (1)
|
|
|
602 {
|
|
|
603 if (*q == 0)
|
|
|
604 /* The string is malformed; might as well drop it. */
|
|
|
605 goto duplicate;
|
|
|
606 if (*q != *p)
|
|
|
607 break;
|
|
|
608 if (*q == '=')
|
|
|
609 goto duplicate;
|
|
|
610 p++, q++;
|
|
|
611 }
|
|
|
612 }
|
|
771
|
613 if (pwd && !qxestrncmp ((Intbyte *) "PWD=", envvar, 4))
|
|
428
|
614 {
|
|
|
615 *new_env++ = pwd;
|
|
|
616 pwd = 0;
|
|
|
617 }
|
|
|
618 else
|
|
771
|
619 *new_env++ = envvar;
|
|
428
|
620
|
|
|
621 duplicate: ;
|
|
|
622 }
|
|
771
|
623
|
|
428
|
624 *new_env = 0;
|
|
|
625 }
|
|
|
626
|
|
|
627 /* Make sure that in, out, and err are not actually already in
|
|
|
628 descriptors zero, one, or two; this could happen if Emacs is
|
|
|
629 started with its standard in, out, or error closed, as might
|
|
|
630 happen under X. */
|
|
|
631 in = relocate_fd (in, 3);
|
|
|
632 out = relocate_fd (out, 3);
|
|
|
633 err = relocate_fd (err, 3);
|
|
|
634
|
|
|
635 /* Set the standard input/output channels of the new process. */
|
|
771
|
636 retry_close (STDIN_FILENO);
|
|
|
637 retry_close (STDOUT_FILENO);
|
|
|
638 retry_close (STDERR_FILENO);
|
|
428
|
639
|
|
|
640 dup2 (in, STDIN_FILENO);
|
|
|
641 dup2 (out, STDOUT_FILENO);
|
|
|
642 dup2 (err, STDERR_FILENO);
|
|
|
643
|
|
771
|
644 retry_close (in);
|
|
|
645 retry_close (out);
|
|
|
646 retry_close (err);
|
|
428
|
647
|
|
|
648 /* I can't think of any reason why child processes need any more
|
|
|
649 than the standard 3 file descriptors. It would be cleaner to
|
|
|
650 close just the ones that need to be, but the following brute
|
|
|
651 force approach is certainly effective, and not too slow. */
|
|
|
652 {
|
|
|
653 int fd;
|
|
|
654 for (fd=3; fd<=64; fd++)
|
|
771
|
655 retry_close (fd);
|
|
428
|
656 }
|
|
|
657
|
|
|
658 #ifdef vipc
|
|
|
659 something missing here;
|
|
|
660 #endif /* vipc */
|
|
|
661
|
|
771
|
662 /* we've wrapped execve; it translates its arguments */
|
|
|
663 qxe_execve (new_argv[0], new_argv, env);
|
|
428
|
664
|
|
|
665 stdout_out ("Can't exec program %s\n", new_argv[0]);
|
|
|
666 _exit (1);
|
|
|
667 }
|
|
|
668
|
|
|
669 void
|
|
|
670 syms_of_callproc (void)
|
|
|
671 {
|
|
442
|
672 DEFSUBR (Fold_call_process_internal);
|
|
428
|
673 }
|
