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