|
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))
|
|
82
|
398 chdir (XSTRING_DATA (current_buffer->directory));
|
|
0
|
399 }
|
|
|
400
|
|
70
|
401 DEFUN ("call-process-internal", Fcall_process_internal, 1, MANY, 0 /*
|
|
0
|
402 Call PROGRAM synchronously in a separate process.
|
|
|
403 Program's input comes from file INFILE (nil means null device, `NLA0:').
|
|
|
404 Insert output in BUFFER before point; t means current buffer;
|
|
|
405 nil for BUFFER means discard it; 0 means discard and don't wait.
|
|
|
406 Fourth arg DISPLAY non-nil means redisplay buffer as output is inserted.
|
|
|
407 Remaining arguments are strings passed as command arguments to PROGRAM.
|
|
|
408 This function waits for PROGRAM to terminate, unless BUFFER is 0;
|
|
|
409 if you quit, the process is killed.
|
|
70
|
410 */ )
|
|
|
411 (int nargs, Lisp_Object *args)
|
|
0
|
412 {
|
|
|
413 /* This function can GC */
|
|
|
414 Lisp_Object display, buffer, path;
|
|
|
415 char oldDir[512];
|
|
|
416 int inchannel, outchannel;
|
|
|
417 int len;
|
|
|
418 int call_process_ast ();
|
|
|
419 struct
|
|
|
420 {
|
|
|
421 int l;
|
|
|
422 char *a;
|
|
|
423 } dcmd, din, dout;
|
|
|
424 char inDevName[65];
|
|
|
425 char outDevName[65];
|
|
|
426 short iosb[4];
|
|
|
427 int status;
|
|
|
428 int SpawnFlags = CLI$M_NOWAIT;
|
|
|
429 VMS_PROC_STUFF *vs;
|
|
|
430 VMS_PROC_STUFF *get_vms_process_stuff ();
|
|
|
431 int fd[2];
|
|
|
432 int filefd;
|
|
|
433 int pid;
|
|
|
434 char buf[1024];
|
|
|
435 int speccount = specpdl_depth ();
|
|
|
436 unsigned char **new_argv;
|
|
|
437 struct buffer *old = current_buffer;
|
|
|
438
|
|
|
439 CHECK_STRING (args[0]);
|
|
|
440
|
|
|
441 if (nargs <= 1 || NILP (args[1]))
|
|
|
442 args[1] = build_string ("NLA0:");
|
|
|
443 else
|
|
|
444 args[1] = Fexpand_file_name (args[1],
|
|
|
445 current_buffer->directory);
|
|
|
446
|
|
|
447 CHECK_STRING (args[1]);
|
|
|
448
|
|
|
449 {
|
|
|
450 Lisp_Object tem;
|
|
|
451 buffer = tem = args[2];
|
|
|
452 if (nargs <= 2)
|
|
|
453 buffer = Qnil;
|
|
|
454 else if (!(ZEROP (tem, Qnil) || EQ (tem, Qt) || EQ (tem))
|
|
|
455 {
|
|
|
456 buffer = Fget_buffer (tem);
|
|
|
457 CHECK_BUFFER (buffer);
|
|
|
458 }
|
|
|
459 }
|
|
|
460
|
|
|
461 display = nargs >= 3 ? args[3] : Qnil;
|
|
|
462
|
|
|
463 {
|
|
|
464 /*
|
|
|
465 if (args[0] == "*dcl*" then we need to skip pas the "-c",
|
|
|
466 else args[0] is the program to run.
|
|
|
467 */
|
|
|
468 int i;
|
|
|
469 int arg0;
|
|
|
470 int firstArg;
|
|
|
471
|
|
82
|
472 if (strcmp (XSTRING_DATA (args[0]), "*dcl*") == 0)
|
|
0
|
473 {
|
|
|
474 arg0 = 5;
|
|
|
475 firstArg = 6;
|
|
|
476 }
|
|
|
477 else
|
|
|
478 {
|
|
|
479 arg0 = 0;
|
|
|
480 firstArg = 4;
|
|
|
481 }
|
|
82
|
482 len = XSTRING_LENGTH (args[arg0]) + 1;
|
|
0
|
483 for (i = firstArg; i < nargs; i++)
|
|
|
484 {
|
|
|
485 CHECK_STRING (args[i]);
|
|
82
|
486 len += XSTRING_LENGTH (args[i]) + 1;
|
|
0
|
487 }
|
|
|
488 new_argv = alloca (len);
|
|
82
|
489 strcpy (new_argv, XSTRING_DATA (args[arg0]));
|
|
0
|
490 for (i = firstArg; i < nargs; i++)
|
|
|
491 {
|
|
|
492 strcat (new_argv, " ");
|
|
82
|
493 strcat (new_argv, XSTRING_DATA (args[i]));
|
|
0
|
494 }
|
|
|
495 dcmd.l = len-1;
|
|
|
496 dcmd.a = new_argv;
|
|
|
497
|
|
|
498 status = get_pty_channel (inDevName, outDevName, &inchannel, &outchannel);
|
|
|
499 if (!(status & 1))
|
|
|
500 error ("Error getting PTY channel: %x", status);
|
|
|
501 if (INTP (buffer))
|
|
|
502 {
|
|
|
503 dout.l = strlen ("NLA0:");
|
|
|
504 dout.a = "NLA0:";
|
|
|
505 }
|
|
|
506 else
|
|
|
507 {
|
|
|
508 dout.l = strlen (outDevName);
|
|
|
509 dout.a = outDevName;
|
|
|
510 }
|
|
|
511
|
|
|
512 vs = get_vms_process_stuff ();
|
|
|
513 if (!vs)
|
|
|
514 {
|
|
|
515 sys$dassgn (inchannel);
|
|
|
516 sys$dassgn (outchannel);
|
|
|
517 error ("Too many VMS processes");
|
|
|
518 }
|
|
|
519 vs->inputChan = inchannel;
|
|
|
520 vs->outputChan = outchannel;
|
|
|
521 }
|
|
|
522
|
|
82
|
523 filefd = open (XSTRING_DATA (args[1]), O_RDONLY, 0);
|
|
0
|
524 if (filefd < 0)
|
|
|
525 {
|
|
|
526 sys$dassgn (inchannel);
|
|
|
527 sys$dassgn (outchannel);
|
|
|
528 give_back_vms_process_stuff (vs);
|
|
|
529 report_file_error ("Opening process input file", Fcons (args[1], Qnil));
|
|
|
530 }
|
|
|
531 else
|
|
|
532 close (filefd);
|
|
|
533
|
|
82
|
534 din.l = XSTRING_LENGTH (args[1]);
|
|
|
535 din.a = XSTRING_DATA (args[1]);
|
|
0
|
536
|
|
|
537 /*
|
|
|
538 Start a read on the process channel
|
|
|
539 */
|
|
|
540 if (!INTP (buffer))
|
|
|
541 {
|
|
|
542 start_vms_process_read (vs);
|
|
|
543 SpawnFlags = CLI$M_NOWAIT;
|
|
|
544 }
|
|
|
545 else
|
|
|
546 SpawnFlags = 0;
|
|
|
547
|
|
|
548 /*
|
|
|
549 On VMS we need to change the current directory
|
|
|
550 of the parent process before forking so that
|
|
|
551 the child inherit that directory. We remember
|
|
|
552 where we were before changing.
|
|
|
553 */
|
|
|
554 VMSgetwd (oldDir);
|
|
|
555 child_setup (0, 0, 0, 0, 0);
|
|
|
556 status = lib$spawn (&dcmd, &din, &dout, &SpawnFlags, 0, &vs->pid,
|
|
|
557 &vs->exitStatus, 0, call_process_ast, vs);
|
|
|
558 chdir (oldDir);
|
|
|
559
|
|
|
560 if (status != SS$_NORMAL)
|
|
|
561 {
|
|
|
562 sys$dassgn (inchannel);
|
|
|
563 sys$dassgn (outchannel);
|
|
|
564 give_back_vms_process_stuff (vs);
|
|
|
565 error ("Error calling LIB$SPAWN: %x", status);
|
|
|
566 }
|
|
|
567 pid = vs->pid;
|
|
|
568
|
|
|
569 if (INTP (buffer))
|
|
|
570 {
|
|
|
571 #if defined (NO_SUBPROCESSES)
|
|
|
572 wait_without_blocking ();
|
|
|
573 #endif
|
|
|
574 return Qnil;
|
|
|
575 }
|
|
|
576
|
|
|
577 record_unwind_protect (call_process_cleanup,
|
|
|
578 Fcons (make_int (fd[0]), make_int (pid)));
|
|
|
579
|
|
|
580
|
|
|
581 if (BUFFERP (buffer))
|
|
|
582 Fset_buffer (buffer);
|
|
|
583
|
|
|
584 while (1)
|
|
|
585 {
|
|
|
586 QUIT;
|
|
|
587
|
|
|
588 sys$waitfr (vs->eventFlag);
|
|
|
589 if (vs->iosb[0] & 1)
|
|
|
590 {
|
|
|
591 if (!NILP (buffer))
|
|
|
592 {
|
|
|
593 vs->iosb[1] = clean_vms_buffer (vs->inputBuffer, vs->iosb[1]);
|
|
|
594 InsCStr (vs->inputBuffer, vs->iosb[1]);
|
|
|
595 }
|
|
|
596 if (!NILP (display) && INTERACTIVE)
|
|
|
597 redisplay ();
|
|
|
598 QUIT;
|
|
|
599 if (!start_vms_process_read (vs))
|
|
|
600 break; /* The other side went away */
|
|
|
601 }
|
|
|
602 else
|
|
|
603 break;
|
|
|
604 }
|
|
|
605 sys$dassgn (inchannel);
|
|
|
606 sys$dassgn (outchannel);
|
|
|
607 give_back_vms_process_stuff (vs);
|
|
|
608
|
|
|
609 /* Wait for it to terminate, unless it already has. */
|
|
|
610 wait_for_termination (pid);
|
|
|
611
|
|
|
612 set_current_buffer (old);
|
|
|
613
|
|
|
614 return unbind_to (speccount, Qnil);
|
|
|
615 }
|
|
|
616
|
|
|
617 create_process (process, new_argv)
|
|
|
618 Lisp_Object process;
|
|
|
619 char *new_argv;
|
|
|
620 {
|
|
|
621 int pid, inchannel, outchannel, forkin, forkout;
|
|
|
622 char old_dir[512];
|
|
|
623 char in_dev_name[65];
|
|
|
624 char out_dev_name[65];
|
|
|
625 short iosb[4];
|
|
|
626 int status;
|
|
|
627 int spawn_flags = CLI$M_NOWAIT;
|
|
|
628 int child_sig ();
|
|
|
629 struct {
|
|
|
630 int l;
|
|
|
631 char *a;
|
|
|
632 } din, dout, dprompt, dcmd;
|
|
|
633 VMS_PROC_STUFF *vs;
|
|
|
634 VMS_PROC_STUFF *get_vms_process_stuff ();
|
|
|
635
|
|
|
636 status = get_pty_channel (in_dev_name, out_dev_name, &inchannel, &outchannel);
|
|
|
637 if (!(status & 1))
|
|
|
638 {
|
|
|
639 remove_process (process);
|
|
|
640 error ("Error getting PTY channel: %x", status);
|
|
|
641 }
|
|
|
642 dout.l = strlen (out_dev_name);
|
|
|
643 dout.a = out_dev_name;
|
|
|
644 dprompt.l = strlen (DCL_PROMPT);
|
|
|
645 dprompt.a = DCL_PROMPT;
|
|
|
646
|
|
|
647 if (strcmp (new_argv, "*dcl*") == 0)
|
|
|
648 {
|
|
|
649 din.l = strlen (in_dev_name);
|
|
|
650 din.a = in_dev_name;
|
|
|
651 dcmd.l = 0;
|
|
|
652 dcmd.a = (char *)0;
|
|
|
653 }
|
|
|
654 else
|
|
|
655 {
|
|
|
656 din.l = strlen ("NLA0:");
|
|
|
657 din.a = "NLA0:";
|
|
|
658 dcmd.l = strlen (new_argv);
|
|
|
659 dcmd.a = new_argv;
|
|
|
660 }
|
|
|
661
|
|
|
662 /* Delay interrupts until we have a chance to store
|
|
|
663 the new fork's pid in its process structure */
|
|
|
664 sys$setast (0);
|
|
|
665
|
|
|
666 vs = get_vms_process_stuff ();
|
|
|
667 if (vs == 0)
|
|
|
668 {
|
|
|
669 sys$setast (1);
|
|
|
670 remove_process (process);
|
|
|
671 error ("Too many VMS processes");
|
|
|
672 }
|
|
|
673 vs->inputChan = inchannel;
|
|
|
674 vs->outputChan = outchannel;
|
|
|
675
|
|
|
676 /* Start a read on the process channel */
|
|
|
677 start_vms_process_read (vs);
|
|
|
678
|
|
|
679 /* Switch current directory so that the child inherits it. */
|
|
|
680 VMSgetwd (old_dir);
|
|
|
681 child_setup (0, 0, 0, 0, 0);
|
|
|
682
|
|
|
683 status = lib$spawn (&dcmd, &din, &dout, &spawn_flags, 0, &vs->pid,
|
|
|
684 &vs->exitStatus, 0, child_sig, vs, &dprompt);
|
|
|
685 chdir (old_dir);
|
|
|
686
|
|
|
687 if (status != SS$_NORMAL)
|
|
|
688 {
|
|
|
689 sys$setast (1);
|
|
|
690 remove_process (process);
|
|
|
691 error ("Error calling LIB$SPAWN: %x", status);
|
|
|
692 }
|
|
|
693 vs->pid &= 0xffff; /* It needs to fit in a FASTINT,
|
|
|
694 we don't need the rest of the bits */
|
|
|
695 pid = vs->pid;
|
|
|
696
|
|
|
697 /*
|
|
|
698 ON VMS process->infd holds the (event flag-1)
|
|
|
699 that we use for doing I/O on that process.
|
|
|
700 `input_wait_mask' is the cluster of event flags
|
|
|
701 we can wait on.
|
|
|
702
|
|
|
703 Event flags returned start at 1 for the keyboard.
|
|
|
704 Since Unix expects descriptor 0 for the keyboard,
|
|
|
705 we substract one from the event flag.
|
|
|
706 */
|
|
|
707 inchannel = vs->eventFlag-1;
|
|
|
708
|
|
|
709 /* Record this as an active process, with its channels.
|
|
|
710 As a result, child_setup will close Emacs's side of the pipes. */
|
|
|
711 chan_process[inchannel] = process;
|
|
|
712 XPROCESS (process)->infd = make_int (inchannel);
|
|
|
713 XPROCESS (process)->outfd = make_int (outchannel);
|
|
|
714 XPROCESS (process)->flags = make_int (RUNNING);
|
|
|
715
|
|
|
716 /* Delay interrupts until we have a chance to store
|
|
|
717 the new fork's pid in its process structure */
|
|
|
718
|
|
|
719 #define NO_ECHO "set term/noecho\r"
|
|
|
720 sys$setast (0);
|
|
|
721 /*
|
|
|
722 Send a command to the process to not echo input
|
|
|
723
|
|
|
724 The CMU PTY driver does not support SETMODEs.
|
|
|
725 */
|
|
|
726 write_to_vms_process (vs, NO_ECHO, strlen (NO_ECHO));
|
|
|
727
|
|
|
728 XPROCESS (process)->pid = make_int (pid);
|
|
|
729 sys$setast (1);
|
|
|
730 }
|
|
|
731
|
|
|
732 child_sig (VMS_PROC_STUFF *vs)
|
|
|
733 {
|
|
|
734 int pid;
|
|
|
735 Lisp_Object tail, proc;
|
|
|
736 struct Lisp_Process *p;
|
|
|
737 int old_errno = errno;
|
|
|
738
|
|
|
739 pid = vs->pid;
|
|
|
740 sys$setef (vs->eventFlag);
|
|
|
741
|
|
|
742 for (tail = Vprocess_alist; XSYMBOL (tail) != XSYMBOL (Qnil); tail = XCDR (tail))
|
|
|
743 {
|
|
|
744 proc = XCDR (XCAR (tail));
|
|
|
745 p = XPROCESS (proc);
|
|
|
746 if (EQ (p->childp, Qt) && XINT (p->pid) == pid)
|
|
|
747 break;
|
|
|
748 }
|
|
|
749
|
|
|
750 if (XSYMBOL (tail) == XSYMBOL (Qnil))
|
|
|
751 return;
|
|
|
752
|
|
|
753 child_changed++;
|
|
|
754 p->flags = make_int (EXITED | CHANGED);
|
|
|
755 /* Truncate the exit status to 24 bits so that it fits in a FASTINT */
|
|
|
756 p->reason = make_int ((vs->exitStatus) & 0xffffff);
|
|
|
757 }
|
|
|
758
|
|
|
759 void
|
|
|
760 syms_of_vmsproc (void)
|
|
|
761 {
|
|
20
|
762 DEFSUBR (Fcall_process_internal);
|
|
0
|
763 }
|
|
|
764
|
|
|
765 void
|
|
|
766 init_vmsproc (void)
|
|
|
767 {
|
|
|
768 char *malloc ();
|
|
|
769 int i;
|
|
|
770 VMS_PROC_STUFF *vs;
|
|
|
771
|
|
|
772 for (vs=procList, i=0; i<MAX_EVENT_FLAGS+1; i++, vs++)
|
|
|
773 {
|
|
|
774 vs->busy = 0;
|
|
|
775 vs->eventFlag = i;
|
|
|
776 sys$clref (i);
|
|
|
777 vs->inputChan = 0;
|
|
|
778 vs->pid = 0;
|
|
|
779 }
|
|
|
780 procList[0].busy = 1; /* Zero is reserved */
|
|
|
781 }
|
