Mercurial > emacs
annotate src/vmsproc.c @ 13054:b2df0396fae2
(rmail-file-p): Function moved to mail-utils.el
and renamed to mail-file-babyl-p.
(rmail-output, rmail-output-to-rmail-file): Use new name.
author | Richard M. Stallman <rms@gnu.org> |
---|---|
date | Thu, 21 Sep 1995 20:20:11 +0000 |
parents | ac7375e60931 |
children | 621a575db6f7 |
rev | line source |
---|---|
118 | 1 /* Interfaces to subprocesses on VMS. |
7307 | 2 Copyright (C) 1988, 1994 Free Software Foundation, Inc. |
118 | 3 |
4 This file is part of GNU Emacs. | |
5 | |
6 GNU Emacs is free software; you can redistribute it and/or modify | |
7 it under the terms of the GNU General Public License as published by | |
12244 | 8 the Free Software Foundation; either version 2, or (at your option) |
118 | 9 any later version. |
10 | |
11 GNU Emacs is distributed in the hope that it will be useful, | |
12 but WITHOUT ANY WARRANTY; without even the implied warranty of | |
13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
14 GNU General Public License for more details. | |
15 | |
16 You should have received a copy of the GNU General Public License | |
17 along with GNU Emacs; see the file COPYING. If not, write to | |
18 the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ | |
19 | |
20 | |
21 /* | |
22 Event flag and `select' emulation | |
23 | |
24 0 is never used | |
25 1 is the terminal | |
26 23 is the timer event flag | |
27 24-31 are reserved by VMS | |
28 */ | |
6212
7a86fbeb5c88
Include config.h, lisp.h, buffer.h, process.h, commands.h, errno.h and file.h.
Richard M. Stallman <rms@gnu.org>
parents:
5252
diff
changeset
|
29 #include <config.h> |
118 | 30 #include <ssdef.h> |
31 #include <iodef.h> | |
32 #include <dvidef.h> | |
33 #include <clidef.h> | |
34 #include "vmsproc.h" | |
6212
7a86fbeb5c88
Include config.h, lisp.h, buffer.h, process.h, commands.h, errno.h and file.h.
Richard M. Stallman <rms@gnu.org>
parents:
5252
diff
changeset
|
35 #include "lisp.h" |
7a86fbeb5c88
Include config.h, lisp.h, buffer.h, process.h, commands.h, errno.h and file.h.
Richard M. Stallman <rms@gnu.org>
parents:
5252
diff
changeset
|
36 #include "buffer.h" |
7a86fbeb5c88
Include config.h, lisp.h, buffer.h, process.h, commands.h, errno.h and file.h.
Richard M. Stallman <rms@gnu.org>
parents:
5252
diff
changeset
|
37 #include <file.h> |
7a86fbeb5c88
Include config.h, lisp.h, buffer.h, process.h, commands.h, errno.h and file.h.
Richard M. Stallman <rms@gnu.org>
parents:
5252
diff
changeset
|
38 #include "process.h" |
7a86fbeb5c88
Include config.h, lisp.h, buffer.h, process.h, commands.h, errno.h and file.h.
Richard M. Stallman <rms@gnu.org>
parents:
5252
diff
changeset
|
39 #include "commands.h" |
7a86fbeb5c88
Include config.h, lisp.h, buffer.h, process.h, commands.h, errno.h and file.h.
Richard M. Stallman <rms@gnu.org>
parents:
5252
diff
changeset
|
40 #include <errno.h> |
7a86fbeb5c88
Include config.h, lisp.h, buffer.h, process.h, commands.h, errno.h and file.h.
Richard M. Stallman <rms@gnu.org>
parents:
5252
diff
changeset
|
41 extern Lisp_Object call_process_cleanup (); |
7a86fbeb5c88
Include config.h, lisp.h, buffer.h, process.h, commands.h, errno.h and file.h.
Richard M. Stallman <rms@gnu.org>
parents:
5252
diff
changeset
|
42 |
118 | 43 |
44 #define KEYBOARD_EVENT_FLAG 1 | |
45 #define TIMER_EVENT_FLAG 23 | |
46 | |
47 static VMS_PROC_STUFF procList[MAX_EVENT_FLAGS+1]; | |
48 | |
49 get_kbd_event_flag () | |
50 { | |
51 /* | |
52 Return the first event flag for keyboard input. | |
53 */ | |
54 VMS_PROC_STUFF *vs = &procList[KEYBOARD_EVENT_FLAG]; | |
55 | |
56 vs->busy = 1; | |
57 vs->pid = 0; | |
58 return (vs->eventFlag); | |
59 } | |
60 | |
61 get_timer_event_flag () | |
62 { | |
63 /* | |
64 Return the last event flag for use by timeouts | |
65 */ | |
66 VMS_PROC_STUFF *vs = &procList[TIMER_EVENT_FLAG]; | |
67 | |
68 vs->busy = 1; | |
69 vs->pid = 0; | |
70 return (vs->eventFlag); | |
71 } | |
72 | |
73 VMS_PROC_STUFF * | |
74 get_vms_process_stuff () | |
75 { | |
76 /* | |
77 Return a process_stuff structure | |
78 | |
79 We use 1-23 as our event flags to simplify implementing | |
80 a VMS `select' call. | |
81 */ | |
82 int i; | |
83 VMS_PROC_STUFF *vs; | |
84 | |
85 for (i=1, vs = procList; i<MAX_EVENT_FLAGS; i++, vs++) | |
86 { | |
87 if (!vs->busy) | |
88 { | |
89 vs->busy = 1; | |
90 vs->inputChan = 0; | |
91 vs->pid = 0; | |
92 sys$clref (vs->eventFlag); | |
93 return (vs); | |
94 } | |
95 } | |
96 return ((VMS_PROC_STUFF *)0); | |
97 } | |
98 | |
99 give_back_vms_process_stuff (vs) | |
100 VMS_PROC_STUFF *vs; | |
101 { | |
102 /* | |
103 Return an event flag to our pool | |
104 */ | |
105 vs->busy = 0; | |
106 vs->inputChan = 0; | |
107 vs->pid = 0; | |
108 } | |
109 | |
110 VMS_PROC_STUFF * | |
111 get_vms_process_pointer (pid) | |
112 int pid; | |
113 { | |
114 /* | |
115 Given a pid, return the VMS_STUFF pointer | |
116 */ | |
117 int i; | |
118 VMS_PROC_STUFF *vs; | |
119 | |
120 /* Don't search the last one */ | |
121 for (i=0, vs=procList; i<MAX_EVENT_FLAGS; i++, vs++) | |
122 { | |
123 if (vs->busy && vs->pid == pid) | |
124 return (vs); | |
125 } | |
126 return ((VMS_PROC_STUFF *)0); | |
127 } | |
128 | |
129 start_vms_process_read (vs) | |
130 VMS_PROC_STUFF *vs; | |
131 { | |
132 /* | |
133 Start an asynchronous read on a VMS process | |
134 We will catch up with the output sooner or later | |
135 */ | |
136 int status; | |
137 int ProcAst (); | |
138 | |
139 status = sys$qio (vs->eventFlag, vs->outputChan, IO$_READVBLK, | |
140 vs->iosb, 0, vs, | |
141 vs->inputBuffer, sizeof (vs->inputBuffer), 0, 0, 0, 0); | |
142 if (status != SS$_NORMAL) | |
143 return (0); | |
144 else | |
145 return (1); | |
146 } | |
147 | |
148 extern int waiting_for_ast; /* in sysdep.c */ | |
149 extern int timer_ef; | |
150 extern int input_ef; | |
151 | |
152 select (nDesc, rdsc, wdsc, edsc, timeOut) | |
153 int nDesc; | |
154 int *rdsc; | |
155 int *wdsc; | |
156 int *edsc; | |
157 int *timeOut; | |
158 { | |
159 /* Emulate a select call | |
160 | |
161 We know that we only use event flags 1-23 | |
162 | |
163 timeout == 100000 & bit 0 set means wait on keyboard input until | |
164 something shows up. If timeout == 0, we just read the event | |
165 flags and return what we find. */ | |
166 | |
167 int nfds = 0; | |
168 int status; | |
169 int time[2]; | |
170 int delta = -10000000; | |
171 int zero = 0; | |
172 int timeout = *timeOut; | |
173 unsigned long mask, readMask, waitMask; | |
174 | |
175 if (rdsc) | |
176 readMask = *rdsc << 1; /* Unix mask is shifted over 1 */ | |
177 else | |
178 readMask = 0; /* Must be a wait call */ | |
179 | |
180 sys$clref (KEYBOARD_EVENT_FLAG); | |
181 sys$setast (0); /* Block interrupts */ | |
182 sys$readef (KEYBOARD_EVENT_FLAG, &mask); /* See what is set */ | |
183 mask &= readMask; /* Just examine what we need */ | |
184 if (mask == 0) | |
185 { /* Nothing set, we must wait */ | |
186 if (timeout != 0) | |
187 { /* Not just inspecting... */ | |
188 if (!(timeout == 100000 && | |
189 readMask == (1 << KEYBOARD_EVENT_FLAG))) | |
190 { | |
191 lib$emul (&timeout, &delta, &zero, time); | |
192 sys$setimr (TIMER_EVENT_FLAG, time, 0, 1); | |
193 waitMask = readMask | (1 << TIMER_EVENT_FLAG); | |
194 } | |
195 else | |
196 waitMask = readMask; | |
197 if (waitMask & (1 << KEYBOARD_EVENT_FLAG)) | |
198 { | |
199 sys$clref (KEYBOARD_EVENT_FLAG); | |
200 waiting_for_ast = 1; /* Only if reading from 0 */ | |
201 } | |
202 sys$setast (1); | |
203 sys$wflor (KEYBOARD_EVENT_FLAG, waitMask); | |
204 sys$cantim (1, 0); | |
205 sys$readef (KEYBOARD_EVENT_FLAG, &mask); | |
206 if (readMask & (1 << KEYBOARD_EVENT_FLAG)) | |
207 waiting_for_ast = 0; | |
208 } | |
209 } | |
210 sys$setast (1); | |
211 | |
212 /* | |
213 Count number of descriptors that are ready | |
214 */ | |
215 mask &= readMask; | |
216 if (rdsc) | |
217 *rdsc = (mask >> 1); /* Back to Unix format */ | |
218 for (nfds = 0; mask; mask >>= 1) | |
219 { | |
220 if (mask & 1) | |
221 nfds++; | |
222 } | |
223 return (nfds); | |
224 } | |
225 | |
226 #define MAX_BUFF 1024 | |
227 | |
228 write_to_vms_process (vs, buf, len) | |
229 VMS_PROC_STUFF *vs; | |
230 char *buf; | |
231 int len; | |
232 { | |
233 /* | |
234 Write something to a VMS process. | |
235 | |
236 We have to map newlines to carriage returns for VMS. | |
237 */ | |
238 char ourBuff[MAX_BUFF]; | |
239 short iosb[4]; | |
240 int status; | |
241 int in, out; | |
242 | |
243 while (len > 0) | |
244 { | |
245 out = map_nl_to_cr (buf, ourBuff, len, MAX_BUFF); | |
246 status = sys$qiow (0, vs->inputChan, IO$_WRITEVBLK|IO$M_NOFORMAT, | |
247 iosb, 0, 0, ourBuff, out, 0, 0, 0, 0); | |
248 if (status != SS$_NORMAL || (status = iosb[0]) != SS$_NORMAL) | |
249 { | |
250 error ("Could not write to subprocess: %x", status); | |
251 return (0); | |
252 } | |
6212
7a86fbeb5c88
Include config.h, lisp.h, buffer.h, process.h, commands.h, errno.h and file.h.
Richard M. Stallman <rms@gnu.org>
parents:
5252
diff
changeset
|
253 len -= out; |
118 | 254 } |
255 return (1); | |
256 } | |
257 | |
258 static | |
259 map_nl_to_cr (in, out, maxIn, maxOut) | |
260 char *in; | |
261 char *out; | |
262 int maxIn; | |
263 int maxOut; | |
264 { | |
265 /* | |
266 Copy `in' to `out' remapping `\n' to `\r' | |
267 */ | |
268 int c; | |
269 int o; | |
270 | |
271 for (o=0; maxIn-- > 0 && o < maxOut; o++) | |
272 { | |
273 c = *in++; | |
274 *out++ = (c == '\n') ? '\r' : c; | |
275 } | |
276 return (o); | |
277 } | |
278 | |
279 clean_vms_buffer (buf, len) | |
280 char *buf; | |
281 int len; | |
282 { | |
283 /* | |
284 Sanitize output from a VMS subprocess | |
285 Strip CR's and NULLs | |
286 */ | |
287 char *oBuf = buf; | |
288 char c; | |
289 int l = 0; | |
290 | |
291 while (len-- > 0) | |
292 { | |
293 c = *buf++; | |
294 if (c == '\r' || c == '\0') | |
295 ; | |
296 else | |
297 { | |
298 *oBuf++ = c; | |
299 l++; | |
300 } | |
301 } | |
302 return (l); | |
303 } | |
304 | |
305 /* | |
306 For the CMU PTY driver | |
307 */ | |
308 #define PTYNAME "PYA0:" | |
309 | |
310 get_pty_channel (inDevName, outDevName, inChannel, outChannel) | |
311 char *inDevName; | |
312 char *outDevName; | |
313 int *inChannel; | |
314 int *outChannel; | |
315 { | |
316 int PartnerUnitNumber; | |
317 int status; | |
318 struct { | |
319 int l; | |
320 char *a; | |
321 } d; | |
322 struct { | |
323 short BufLen; | |
324 short ItemCode; | |
325 int *BufAddress; | |
326 int *ItemLength; | |
327 } g[2]; | |
328 | |
329 d.l = strlen (PTYNAME); | |
330 d.a = PTYNAME; | |
331 *inChannel = 0; /* Should be `short' on VMS */ | |
332 *outChannel = 0; | |
333 *inDevName = *outDevName = '\0'; | |
334 status = sys$assign (&d, inChannel, 0, 0); | |
335 if (status == SS$_NORMAL) | |
336 { | |
337 *outChannel = *inChannel; | |
338 g[0].BufLen = sizeof (PartnerUnitNumber); | |
339 g[0].ItemCode = DVI$_UNIT; | |
340 g[0].BufAddress = &PartnerUnitNumber; | |
341 g[0].ItemLength = (int *)0; | |
342 g[1].BufLen = g[1].ItemCode = 0; | |
343 status = sys$getdviw (0, *inChannel, 0, &g, 0, 0, 0, 0); | |
344 if (status == SS$_NORMAL) | |
345 { | |
346 sprintf (inDevName, "_TPA%d:", PartnerUnitNumber); | |
347 strcpy (outDevName, inDevName); | |
348 } | |
349 } | |
350 return (status); | |
351 } | |
352 | |
353 VMSgetwd (buf) | |
354 char *buf; | |
355 { | |
356 /* | |
357 Return the current directory | |
358 */ | |
359 char curdir[256]; | |
360 char *getenv (); | |
361 char *s; | |
362 short len; | |
363 int status; | |
364 struct | |
365 { | |
366 int l; | |
367 char *a; | |
368 } d; | |
369 | |
370 s = getenv ("SYS$DISK"); | |
371 if (s) | |
372 strcpy (buf, s); | |
373 else | |
374 *buf = '\0'; | |
375 | |
376 d.l = 255; | |
377 d.a = curdir; | |
378 status = sys$setddir (0, &len, &d); | |
379 if (status & 1) | |
380 { | |
381 curdir[len] = '\0'; | |
382 strcat (buf, curdir); | |
383 } | |
384 } | |
385 | |
386 static | |
387 call_process_ast (vs) | |
388 VMS_PROC_STUFF *vs; | |
389 { | |
390 sys$setef (vs->eventFlag); | |
391 } | |
392 | |
393 void | |
394 child_setup (in, out, err, new_argv, env) | |
395 int in, out, err; | |
396 register char **new_argv; | |
397 char **env; | |
398 { | |
399 /* ??? I suspect that maybe this shouldn't be done on VMS. */ | |
400 #ifdef subprocesses | |
401 /* Close Emacs's descriptors that this process should not have. */ | |
402 close_process_descs (); | |
403 #endif | |
404 | |
9106
40a353de483c
(child_setup, Fcall_process): Use type test macros.
Karl Heuer <kwzh@gnu.org>
parents:
7307
diff
changeset
|
405 if (STRINGP (current_buffer->directory)) |
118 | 406 chdir (XSTRING (current_buffer->directory)->data); |
407 } | |
408 | |
409 DEFUN ("call-process", Fcall_process, Scall_process, 1, MANY, 0, | |
410 "Call PROGRAM synchronously in a separate process.\n\ | |
411 Program's input comes from file INFILE (nil means null device, `NLA0:').\n\ | |
412 Insert output in BUFFER before point; t means current buffer;\n\ | |
413 nil for BUFFER means discard it; 0 means discard and don't wait.\n\ | |
414 Fourth arg DISPLAY non-nil means redisplay buffer as output is inserted.\n\ | |
415 Remaining arguments are strings passed as command arguments to PROGRAM.\n\ | |
416 This function waits for PROGRAM to terminate, unless BUFFER is 0;\n\ | |
417 if you quit, the process is killed.") | |
418 (nargs, args) | |
419 int nargs; | |
420 register Lisp_Object *args; | |
421 { | |
422 Lisp_Object display, buffer, path; | |
423 char oldDir[512]; | |
424 int inchannel, outchannel; | |
425 int len; | |
426 int call_process_ast (); | |
427 struct | |
428 { | |
429 int l; | |
430 char *a; | |
431 } dcmd, din, dout; | |
432 char inDevName[65]; | |
433 char outDevName[65]; | |
434 short iosb[4]; | |
435 int status; | |
436 int SpawnFlags = CLI$M_NOWAIT; | |
437 VMS_PROC_STUFF *vs; | |
438 VMS_PROC_STUFF *get_vms_process_stuff (); | |
439 int fd[2]; | |
440 int filefd; | |
441 register int pid; | |
442 char buf[1024]; | |
443 int count = specpdl_ptr - specpdl; | |
444 register unsigned char **new_argv; | |
445 struct buffer *old = current_buffer; | |
446 | |
447 CHECK_STRING (args[0], 0); | |
448 | |
484 | 449 if (nargs <= 1 || NILP (args[1])) |
118 | 450 args[1] = build_string ("NLA0:"); |
451 else | |
452 args[1] = Fexpand_file_name (args[1], current_buffer->directory); | |
453 | |
454 CHECK_STRING (args[1], 1); | |
455 | |
456 { | |
457 register Lisp_Object tem; | |
458 buffer = tem = args[2]; | |
459 if (nargs <= 2) | |
460 buffer = Qnil; | |
461 else if (!(EQ (tem, Qnil) || EQ (tem, Qt) | |
462 || XFASTINT (tem) == 0)) | |
463 { | |
464 buffer = Fget_buffer (tem); | |
465 CHECK_BUFFER (buffer, 2); | |
466 } | |
467 } | |
468 | |
469 display = nargs >= 3 ? args[3] : Qnil; | |
470 | |
471 { | |
472 /* | |
473 if (args[0] == "*dcl*" then we need to skip pas the "-c", | |
474 else args[0] is the program to run. | |
475 */ | |
476 register int i; | |
477 int arg0; | |
478 int firstArg; | |
479 | |
480 if (strcmp (XSTRING (args[0])->data, "*dcl*") == 0) | |
481 { | |
482 arg0 = 5; | |
483 firstArg = 6; | |
484 } | |
485 else | |
486 { | |
487 arg0 = 0; | |
488 firstArg = 4; | |
489 } | |
490 len = XSTRING (args[arg0])->size + 1; | |
491 for (i = firstArg; i < nargs; i++) | |
492 { | |
493 CHECK_STRING (args[i], i); | |
494 len += XSTRING (args[i])->size + 1; | |
495 } | |
496 new_argv = alloca (len); | |
497 strcpy (new_argv, XSTRING (args[arg0])->data); | |
498 for (i = firstArg; i < nargs; i++) | |
499 { | |
500 strcat (new_argv, " "); | |
501 strcat (new_argv, XSTRING (args[i])->data); | |
502 } | |
503 dcmd.l = len-1; | |
504 dcmd.a = new_argv; | |
505 | |
506 status = get_pty_channel (inDevName, outDevName, &inchannel, &outchannel); | |
507 if (!(status & 1)) | |
508 error ("Error getting PTY channel: %x", status); | |
9106
40a353de483c
(child_setup, Fcall_process): Use type test macros.
Karl Heuer <kwzh@gnu.org>
parents:
7307
diff
changeset
|
509 if (INTEGERP (buffer)) |
118 | 510 { |
511 dout.l = strlen ("NLA0:"); | |
512 dout.a = "NLA0:"; | |
513 } | |
514 else | |
515 { | |
516 dout.l = strlen (outDevName); | |
517 dout.a = outDevName; | |
518 } | |
519 | |
520 vs = get_vms_process_stuff (); | |
521 if (!vs) | |
522 { | |
523 sys$dassgn (inchannel); | |
524 sys$dassgn (outchannel); | |
525 error ("Too many VMS processes"); | |
526 } | |
527 vs->inputChan = inchannel; | |
528 vs->outputChan = outchannel; | |
529 } | |
530 | |
531 filefd = open (XSTRING (args[1])->data, O_RDONLY, 0); | |
532 if (filefd < 0) | |
533 { | |
534 sys$dassgn (inchannel); | |
535 sys$dassgn (outchannel); | |
536 give_back_vms_process_stuff (vs); | |
537 report_file_error ("Opening process input file", Fcons (args[1], Qnil)); | |
538 } | |
539 else | |
540 close (filefd); | |
541 | |
542 din.l = XSTRING (args[1])->size; | |
543 din.a = XSTRING (args[1])->data; | |
544 | |
545 /* | |
546 Start a read on the process channel | |
547 */ | |
9106
40a353de483c
(child_setup, Fcall_process): Use type test macros.
Karl Heuer <kwzh@gnu.org>
parents:
7307
diff
changeset
|
548 if (!INTEGERP (buffer)) |
118 | 549 { |
550 start_vms_process_read (vs); | |
551 SpawnFlags = CLI$M_NOWAIT; | |
552 } | |
553 else | |
554 SpawnFlags = 0; | |
555 | |
556 /* | |
557 On VMS we need to change the current directory | |
558 of the parent process before forking so that | |
559 the child inherit that directory. We remember | |
560 where we were before changing. | |
561 */ | |
562 VMSgetwd (oldDir); | |
563 child_setup (0, 0, 0, 0, 0); | |
564 status = lib$spawn (&dcmd, &din, &dout, &SpawnFlags, 0, &vs->pid, | |
565 &vs->exitStatus, 0, call_process_ast, vs); | |
566 chdir (oldDir); | |
567 | |
568 if (status != SS$_NORMAL) | |
569 { | |
570 sys$dassgn (inchannel); | |
571 sys$dassgn (outchannel); | |
572 give_back_vms_process_stuff (vs); | |
573 error ("Error calling LIB$SPAWN: %x", status); | |
574 } | |
575 pid = vs->pid; | |
576 | |
9106
40a353de483c
(child_setup, Fcall_process): Use type test macros.
Karl Heuer <kwzh@gnu.org>
parents:
7307
diff
changeset
|
577 if (INTEGERP (buffer)) |
118 | 578 { |
579 #ifndef subprocesses | |
580 wait_without_blocking (); | |
581 #endif subprocesses | |
582 return Qnil; | |
583 } | |
584 | |
5252
3c213dd261d8
(Fcall_process): Call prepare_menu_bars.
Richard M. Stallman <rms@gnu.org>
parents:
484
diff
changeset
|
585 if (!NILP (display) && INTERACTIVE) |
3c213dd261d8
(Fcall_process): Call prepare_menu_bars.
Richard M. Stallman <rms@gnu.org>
parents:
484
diff
changeset
|
586 prepare_menu_bars (); |
3c213dd261d8
(Fcall_process): Call prepare_menu_bars.
Richard M. Stallman <rms@gnu.org>
parents:
484
diff
changeset
|
587 |
118 | 588 record_unwind_protect (call_process_cleanup, |
589 Fcons (make_number (fd[0]), make_number (pid))); | |
590 | |
591 | |
9106
40a353de483c
(child_setup, Fcall_process): Use type test macros.
Karl Heuer <kwzh@gnu.org>
parents:
7307
diff
changeset
|
592 if (BUFFERP (buffer)) |
118 | 593 Fset_buffer (buffer); |
594 | |
595 immediate_quit = 1; | |
596 QUIT; | |
597 | |
598 while (1) | |
599 { | |
600 sys$waitfr (vs->eventFlag); | |
601 if (vs->iosb[0] & 1) | |
602 { | |
603 immediate_quit = 0; | |
484 | 604 if (!NILP (buffer)) |
118 | 605 { |
606 vs->iosb[1] = clean_vms_buffer (vs->inputBuffer, vs->iosb[1]); | |
607 InsCStr (vs->inputBuffer, vs->iosb[1]); | |
608 } | |
484 | 609 if (!NILP (display) && INTERACTIVE) |
118 | 610 redisplay_preserve_echo_area (); |
611 immediate_quit = 1; | |
612 QUIT; | |
613 if (!start_vms_process_read (vs)) | |
614 break; /* The other side went away */ | |
615 } | |
616 else | |
617 break; | |
618 } | |
5252
3c213dd261d8
(Fcall_process): Call prepare_menu_bars.
Richard M. Stallman <rms@gnu.org>
parents:
484
diff
changeset
|
619 |
3c213dd261d8
(Fcall_process): Call prepare_menu_bars.
Richard M. Stallman <rms@gnu.org>
parents:
484
diff
changeset
|
620 sys$dassgn (inchannel); |
3c213dd261d8
(Fcall_process): Call prepare_menu_bars.
Richard M. Stallman <rms@gnu.org>
parents:
484
diff
changeset
|
621 sys$dassgn (outchannel); |
3c213dd261d8
(Fcall_process): Call prepare_menu_bars.
Richard M. Stallman <rms@gnu.org>
parents:
484
diff
changeset
|
622 give_back_vms_process_stuff (vs); |
118 | 623 |
624 /* Wait for it to terminate, unless it already has. */ | |
625 wait_for_termination (pid); | |
626 | |
627 immediate_quit = 0; | |
628 | |
629 set_current_buffer (old); | |
630 | |
152
50e816f7e0a5
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
118
diff
changeset
|
631 return unbind_to (count, Qnil); |
118 | 632 } |
633 | |
634 create_process (process, new_argv) | |
635 Lisp_Object process; | |
636 char *new_argv; | |
637 { | |
638 int pid, inchannel, outchannel, forkin, forkout; | |
639 char old_dir[512]; | |
640 char in_dev_name[65]; | |
641 char out_dev_name[65]; | |
642 short iosb[4]; | |
643 int status; | |
644 int spawn_flags = CLI$M_NOWAIT; | |
645 int child_sig (); | |
646 struct { | |
647 int l; | |
648 char *a; | |
649 } din, dout, dprompt, dcmd; | |
650 VMS_PROC_STUFF *vs; | |
651 VMS_PROC_STUFF *get_vms_process_stuff (); | |
652 | |
653 status = get_pty_channel (in_dev_name, out_dev_name, &inchannel, &outchannel); | |
654 if (!(status & 1)) | |
655 { | |
656 remove_process (process); | |
657 error ("Error getting PTY channel: %x", status); | |
658 } | |
659 dout.l = strlen (out_dev_name); | |
660 dout.a = out_dev_name; | |
661 dprompt.l = strlen (DCL_PROMPT); | |
662 dprompt.a = DCL_PROMPT; | |
663 | |
664 if (strcmp (new_argv, "*dcl*") == 0) | |
665 { | |
666 din.l = strlen (in_dev_name); | |
667 din.a = in_dev_name; | |
668 dcmd.l = 0; | |
669 dcmd.a = (char *)0; | |
670 } | |
671 else | |
672 { | |
673 din.l = strlen ("NLA0:"); | |
674 din.a = "NLA0:"; | |
675 dcmd.l = strlen (new_argv); | |
676 dcmd.a = new_argv; | |
677 } | |
678 | |
679 /* Delay interrupts until we have a chance to store | |
680 the new fork's pid in its process structure */ | |
681 sys$setast (0); | |
682 | |
683 vs = get_vms_process_stuff (); | |
684 if (vs == 0) | |
685 { | |
686 sys$setast (1); | |
687 remove_process (process); | |
688 error ("Too many VMS processes"); | |
689 } | |
690 vs->inputChan = inchannel; | |
691 vs->outputChan = outchannel; | |
692 | |
693 /* Start a read on the process channel */ | |
694 start_vms_process_read (vs); | |
695 | |
696 /* Switch current directory so that the child inherits it. */ | |
697 VMSgetwd (old_dir); | |
698 child_setup (0, 0, 0, 0, 0); | |
699 | |
700 status = lib$spawn (&dcmd, &din, &dout, &spawn_flags, 0, &vs->pid, | |
701 &vs->exitStatus, 0, child_sig, vs, &dprompt); | |
702 chdir (old_dir); | |
703 | |
704 if (status != SS$_NORMAL) | |
705 { | |
706 sys$setast (1); | |
707 remove_process (process); | |
708 error ("Error calling LIB$SPAWN: %x", status); | |
709 } | |
710 vs->pid &= 0xffff; /* It needs to fit in a FASTINT, | |
711 we don't need the rest of the bits */ | |
712 pid = vs->pid; | |
713 | |
714 /* | |
715 ON VMS process->infd holds the (event flag-1) | |
716 that we use for doing I/O on that process. | |
717 `input_wait_mask' is the cluster of event flags | |
718 we can wait on. | |
719 | |
720 Event flags returned start at 1 for the keyboard. | |
721 Since Unix expects descriptor 0 for the keyboard, | |
722 we substract one from the event flag. | |
723 */ | |
724 inchannel = vs->eventFlag-1; | |
725 | |
726 /* Record this as an active process, with its channels. | |
727 As a result, child_setup will close Emacs's side of the pipes. */ | |
728 chan_process[inchannel] = process; | |
9323
d428ab51a1bc
(create_process): Don't use XFASTINT as an lvalue.
Karl Heuer <kwzh@gnu.org>
parents:
9106
diff
changeset
|
729 XSETFASTINT (XPROCESS (process)->infd, inchannel); |
d428ab51a1bc
(create_process): Don't use XFASTINT as an lvalue.
Karl Heuer <kwzh@gnu.org>
parents:
9106
diff
changeset
|
730 XSETFASTINT (XPROCESS (process)->outfd, outchannel); |
6212
7a86fbeb5c88
Include config.h, lisp.h, buffer.h, process.h, commands.h, errno.h and file.h.
Richard M. Stallman <rms@gnu.org>
parents:
5252
diff
changeset
|
731 XPROCESS (process)->status = Qrun |
118 | 732 |
733 /* Delay interrupts until we have a chance to store | |
734 the new fork's pid in its process structure */ | |
735 | |
736 #define NO_ECHO "set term/noecho\r" | |
737 sys$setast (0); | |
738 /* | |
739 Send a command to the process to not echo input | |
740 | |
741 The CMU PTY driver does not support SETMODEs. | |
742 */ | |
743 write_to_vms_process (vs, NO_ECHO, strlen (NO_ECHO)); | |
744 | |
9323
d428ab51a1bc
(create_process): Don't use XFASTINT as an lvalue.
Karl Heuer <kwzh@gnu.org>
parents:
9106
diff
changeset
|
745 XSETFASTINT (XPROCESS (process)->pid, pid); |
118 | 746 sys$setast (1); |
747 } | |
748 | |
749 child_sig (vs) | |
750 VMS_PROC_STUFF *vs; | |
751 { | |
752 register int pid; | |
753 Lisp_Object tail, proc; | |
754 register struct Lisp_Process *p; | |
755 int old_errno = errno; | |
756 | |
757 pid = vs->pid; | |
758 sys$setef (vs->eventFlag); | |
759 | |
760 for (tail = Vprocess_alist; XSYMBOL (tail) != XSYMBOL (Qnil); tail = XCONS (tail)->cdr) | |
761 { | |
762 proc = XCONS (XCONS (tail)->car)->cdr; | |
763 p = XPROCESS (proc); | |
764 if (EQ (p->childp, Qt) && XFASTINT (p->pid) == pid) | |
765 break; | |
766 } | |
767 | |
768 if (XSYMBOL (tail) == XSYMBOL (Qnil)) | |
769 return; | |
770 | |
6212
7a86fbeb5c88
Include config.h, lisp.h, buffer.h, process.h, commands.h, errno.h and file.h.
Richard M. Stallman <rms@gnu.org>
parents:
5252
diff
changeset
|
771 p->status = Fcons (Qexit, Fcons (make_number (vs->exitStatus), Qnil)) |
118 | 772 } |
773 | |
774 syms_of_vmsproc () | |
775 { | |
776 defsubr (&Scall_process); | |
777 } | |
778 | |
779 init_vmsproc () | |
780 { | |
781 char *malloc (); | |
782 int i; | |
783 VMS_PROC_STUFF *vs; | |
784 | |
785 for (vs=procList, i=0; i<MAX_EVENT_FLAGS+1; i++, vs++) | |
786 { | |
787 vs->busy = 0; | |
788 vs->eventFlag = i; | |
789 sys$clref (i); | |
790 vs->inputChan = 0; | |
791 vs->pid = 0; | |
792 } | |
793 procList[0].busy = 1; /* Zero is reserved */ | |
794 } |