*** empty log message ***
[emacs.git] / src / vmsproc.c
blobec9678f78a44e11f57cbcca05caf1a56c97329d2
1 /* Interfaces to subprocesses on VMS.
2 Copyright (C) 1988 Free Software Foundation, Inc.
4 This file is part of GNU Emacs.
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
8 the Free Software Foundation; either version 1, or (at your option)
9 any later version.
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.
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. */
22 Event flag and `select' emulation
24 0 is never used
25 1 is the terminal
26 23 is the timer event flag
27 24-31 are reserved by VMS
29 #include <ssdef.h>
30 #include <iodef.h>
31 #include <dvidef.h>
32 #include <clidef.h>
33 #include "vmsproc.h"
35 #define KEYBOARD_EVENT_FLAG 1
36 #define TIMER_EVENT_FLAG 23
38 static VMS_PROC_STUFF procList[MAX_EVENT_FLAGS+1];
40 get_kbd_event_flag ()
43 Return the first event flag for keyboard input.
45 VMS_PROC_STUFF *vs = &procList[KEYBOARD_EVENT_FLAG];
47 vs->busy = 1;
48 vs->pid = 0;
49 return (vs->eventFlag);
52 get_timer_event_flag ()
55 Return the last event flag for use by timeouts
57 VMS_PROC_STUFF *vs = &procList[TIMER_EVENT_FLAG];
59 vs->busy = 1;
60 vs->pid = 0;
61 return (vs->eventFlag);
64 VMS_PROC_STUFF *
65 get_vms_process_stuff ()
68 Return a process_stuff structure
70 We use 1-23 as our event flags to simplify implementing
71 a VMS `select' call.
73 int i;
74 VMS_PROC_STUFF *vs;
76 for (i=1, vs = procList; i<MAX_EVENT_FLAGS; i++, vs++)
78 if (!vs->busy)
80 vs->busy = 1;
81 vs->inputChan = 0;
82 vs->pid = 0;
83 sys$clref (vs->eventFlag);
84 return (vs);
87 return ((VMS_PROC_STUFF *)0);
90 give_back_vms_process_stuff (vs)
91 VMS_PROC_STUFF *vs;
94 Return an event flag to our pool
96 vs->busy = 0;
97 vs->inputChan = 0;
98 vs->pid = 0;
101 VMS_PROC_STUFF *
102 get_vms_process_pointer (pid)
103 int pid;
106 Given a pid, return the VMS_STUFF pointer
108 int i;
109 VMS_PROC_STUFF *vs;
111 /* Don't search the last one */
112 for (i=0, vs=procList; i<MAX_EVENT_FLAGS; i++, vs++)
114 if (vs->busy && vs->pid == pid)
115 return (vs);
117 return ((VMS_PROC_STUFF *)0);
120 start_vms_process_read (vs)
121 VMS_PROC_STUFF *vs;
124 Start an asynchronous read on a VMS process
125 We will catch up with the output sooner or later
127 int status;
128 int ProcAst ();
130 status = sys$qio (vs->eventFlag, vs->outputChan, IO$_READVBLK,
131 vs->iosb, 0, vs,
132 vs->inputBuffer, sizeof (vs->inputBuffer), 0, 0, 0, 0);
133 if (status != SS$_NORMAL)
134 return (0);
135 else
136 return (1);
139 extern int waiting_for_ast; /* in sysdep.c */
140 extern int timer_ef;
141 extern int input_ef;
143 select (nDesc, rdsc, wdsc, edsc, timeOut)
144 int nDesc;
145 int *rdsc;
146 int *wdsc;
147 int *edsc;
148 int *timeOut;
150 /* Emulate a select call
152 We know that we only use event flags 1-23
154 timeout == 100000 & bit 0 set means wait on keyboard input until
155 something shows up. If timeout == 0, we just read the event
156 flags and return what we find. */
158 int nfds = 0;
159 int status;
160 int time[2];
161 int delta = -10000000;
162 int zero = 0;
163 int timeout = *timeOut;
164 unsigned long mask, readMask, waitMask;
166 if (rdsc)
167 readMask = *rdsc << 1; /* Unix mask is shifted over 1 */
168 else
169 readMask = 0; /* Must be a wait call */
171 sys$clref (KEYBOARD_EVENT_FLAG);
172 sys$setast (0); /* Block interrupts */
173 sys$readef (KEYBOARD_EVENT_FLAG, &mask); /* See what is set */
174 mask &= readMask; /* Just examine what we need */
175 if (mask == 0)
176 { /* Nothing set, we must wait */
177 if (timeout != 0)
178 { /* Not just inspecting... */
179 if (!(timeout == 100000 &&
180 readMask == (1 << KEYBOARD_EVENT_FLAG)))
182 lib$emul (&timeout, &delta, &zero, time);
183 sys$setimr (TIMER_EVENT_FLAG, time, 0, 1);
184 waitMask = readMask | (1 << TIMER_EVENT_FLAG);
186 else
187 waitMask = readMask;
188 if (waitMask & (1 << KEYBOARD_EVENT_FLAG))
190 sys$clref (KEYBOARD_EVENT_FLAG);
191 waiting_for_ast = 1; /* Only if reading from 0 */
193 sys$setast (1);
194 sys$wflor (KEYBOARD_EVENT_FLAG, waitMask);
195 sys$cantim (1, 0);
196 sys$readef (KEYBOARD_EVENT_FLAG, &mask);
197 if (readMask & (1 << KEYBOARD_EVENT_FLAG))
198 waiting_for_ast = 0;
201 sys$setast (1);
204 Count number of descriptors that are ready
206 mask &= readMask;
207 if (rdsc)
208 *rdsc = (mask >> 1); /* Back to Unix format */
209 for (nfds = 0; mask; mask >>= 1)
211 if (mask & 1)
212 nfds++;
214 return (nfds);
217 #define MAX_BUFF 1024
219 write_to_vms_process (vs, buf, len)
220 VMS_PROC_STUFF *vs;
221 char *buf;
222 int len;
225 Write something to a VMS process.
227 We have to map newlines to carriage returns for VMS.
229 char ourBuff[MAX_BUFF];
230 short iosb[4];
231 int status;
232 int in, out;
234 while (len > 0)
236 out = map_nl_to_cr (buf, ourBuff, len, MAX_BUFF);
237 status = sys$qiow (0, vs->inputChan, IO$_WRITEVBLK|IO$M_NOFORMAT,
238 iosb, 0, 0, ourBuff, out, 0, 0, 0, 0);
239 if (status != SS$_NORMAL || (status = iosb[0]) != SS$_NORMAL)
241 error ("Could not write to subprocess: %x", status);
242 return (0);
244 len =- out;
246 return (1);
249 static
250 map_nl_to_cr (in, out, maxIn, maxOut)
251 char *in;
252 char *out;
253 int maxIn;
254 int maxOut;
257 Copy `in' to `out' remapping `\n' to `\r'
259 int c;
260 int o;
262 for (o=0; maxIn-- > 0 && o < maxOut; o++)
264 c = *in++;
265 *out++ = (c == '\n') ? '\r' : c;
267 return (o);
270 clean_vms_buffer (buf, len)
271 char *buf;
272 int len;
275 Sanitize output from a VMS subprocess
276 Strip CR's and NULLs
278 char *oBuf = buf;
279 char c;
280 int l = 0;
282 while (len-- > 0)
284 c = *buf++;
285 if (c == '\r' || c == '\0')
287 else
289 *oBuf++ = c;
290 l++;
293 return (l);
297 For the CMU PTY driver
299 #define PTYNAME "PYA0:"
301 get_pty_channel (inDevName, outDevName, inChannel, outChannel)
302 char *inDevName;
303 char *outDevName;
304 int *inChannel;
305 int *outChannel;
307 int PartnerUnitNumber;
308 int status;
309 struct {
310 int l;
311 char *a;
312 } d;
313 struct {
314 short BufLen;
315 short ItemCode;
316 int *BufAddress;
317 int *ItemLength;
318 } g[2];
320 d.l = strlen (PTYNAME);
321 d.a = PTYNAME;
322 *inChannel = 0; /* Should be `short' on VMS */
323 *outChannel = 0;
324 *inDevName = *outDevName = '\0';
325 status = sys$assign (&d, inChannel, 0, 0);
326 if (status == SS$_NORMAL)
328 *outChannel = *inChannel;
329 g[0].BufLen = sizeof (PartnerUnitNumber);
330 g[0].ItemCode = DVI$_UNIT;
331 g[0].BufAddress = &PartnerUnitNumber;
332 g[0].ItemLength = (int *)0;
333 g[1].BufLen = g[1].ItemCode = 0;
334 status = sys$getdviw (0, *inChannel, 0, &g, 0, 0, 0, 0);
335 if (status == SS$_NORMAL)
337 sprintf (inDevName, "_TPA%d:", PartnerUnitNumber);
338 strcpy (outDevName, inDevName);
341 return (status);
344 VMSgetwd (buf)
345 char *buf;
348 Return the current directory
350 char curdir[256];
351 char *getenv ();
352 char *s;
353 short len;
354 int status;
355 struct
357 int l;
358 char *a;
359 } d;
361 s = getenv ("SYS$DISK");
362 if (s)
363 strcpy (buf, s);
364 else
365 *buf = '\0';
367 d.l = 255;
368 d.a = curdir;
369 status = sys$setddir (0, &len, &d);
370 if (status & 1)
372 curdir[len] = '\0';
373 strcat (buf, curdir);
377 static
378 call_process_ast (vs)
379 VMS_PROC_STUFF *vs;
381 sys$setef (vs->eventFlag);
384 void
385 child_setup (in, out, err, new_argv, env)
386 int in, out, err;
387 register char **new_argv;
388 char **env;
390 /* ??? I suspect that maybe this shouldn't be done on VMS. */
391 #ifdef subprocesses
392 /* Close Emacs's descriptors that this process should not have. */
393 close_process_descs ();
394 #endif
396 if (XTYPE (current_buffer->directory) == Lisp_String)
397 chdir (XSTRING (current_buffer->directory)->data);
400 DEFUN ("call-process", Fcall_process, Scall_process, 1, MANY, 0,
401 "Call PROGRAM synchronously in a separate process.\n\
402 Program's input comes from file INFILE (nil means null device, `NLA0:').\n\
403 Insert output in BUFFER before point; t means current buffer;\n\
404 nil for BUFFER means discard it; 0 means discard and don't wait.\n\
405 Fourth arg DISPLAY non-nil means redisplay buffer as output is inserted.\n\
406 Remaining arguments are strings passed as command arguments to PROGRAM.\n\
407 This function waits for PROGRAM to terminate, unless BUFFER is 0;\n\
408 if you quit, the process is killed.")
409 (nargs, args)
410 int nargs;
411 register Lisp_Object *args;
413 Lisp_Object display, buffer, path;
414 char oldDir[512];
415 int inchannel, outchannel;
416 int len;
417 int call_process_ast ();
418 struct
420 int l;
421 char *a;
422 } dcmd, din, dout;
423 char inDevName[65];
424 char outDevName[65];
425 short iosb[4];
426 int status;
427 int SpawnFlags = CLI$M_NOWAIT;
428 VMS_PROC_STUFF *vs;
429 VMS_PROC_STUFF *get_vms_process_stuff ();
430 int fd[2];
431 int filefd;
432 register int pid;
433 char buf[1024];
434 int count = specpdl_ptr - specpdl;
435 register unsigned char **new_argv;
436 struct buffer *old = current_buffer;
438 CHECK_STRING (args[0], 0);
440 if (nargs <= 1 || NULL (args[1]))
441 args[1] = build_string ("NLA0:");
442 else
443 args[1] = Fexpand_file_name (args[1], current_buffer->directory);
445 CHECK_STRING (args[1], 1);
448 register Lisp_Object tem;
449 buffer = tem = args[2];
450 if (nargs <= 2)
451 buffer = Qnil;
452 else if (!(EQ (tem, Qnil) || EQ (tem, Qt)
453 || XFASTINT (tem) == 0))
455 buffer = Fget_buffer (tem);
456 CHECK_BUFFER (buffer, 2);
460 display = nargs >= 3 ? args[3] : Qnil;
464 if (args[0] == "*dcl*" then we need to skip pas the "-c",
465 else args[0] is the program to run.
467 register int i;
468 int arg0;
469 int firstArg;
471 if (strcmp (XSTRING (args[0])->data, "*dcl*") == 0)
473 arg0 = 5;
474 firstArg = 6;
476 else
478 arg0 = 0;
479 firstArg = 4;
481 len = XSTRING (args[arg0])->size + 1;
482 for (i = firstArg; i < nargs; i++)
484 CHECK_STRING (args[i], i);
485 len += XSTRING (args[i])->size + 1;
487 new_argv = alloca (len);
488 strcpy (new_argv, XSTRING (args[arg0])->data);
489 for (i = firstArg; i < nargs; i++)
491 strcat (new_argv, " ");
492 strcat (new_argv, XSTRING (args[i])->data);
494 dcmd.l = len-1;
495 dcmd.a = new_argv;
497 status = get_pty_channel (inDevName, outDevName, &inchannel, &outchannel);
498 if (!(status & 1))
499 error ("Error getting PTY channel: %x", status);
500 if (XTYPE (buffer) == Lisp_Int)
502 dout.l = strlen ("NLA0:");
503 dout.a = "NLA0:";
505 else
507 dout.l = strlen (outDevName);
508 dout.a = outDevName;
511 vs = get_vms_process_stuff ();
512 if (!vs)
514 sys$dassgn (inchannel);
515 sys$dassgn (outchannel);
516 error ("Too many VMS processes");
518 vs->inputChan = inchannel;
519 vs->outputChan = outchannel;
522 filefd = open (XSTRING (args[1])->data, O_RDONLY, 0);
523 if (filefd < 0)
525 sys$dassgn (inchannel);
526 sys$dassgn (outchannel);
527 give_back_vms_process_stuff (vs);
528 report_file_error ("Opening process input file", Fcons (args[1], Qnil));
530 else
531 close (filefd);
533 din.l = XSTRING (args[1])->size;
534 din.a = XSTRING (args[1])->data;
537 Start a read on the process channel
539 if (XTYPE (buffer) != Lisp_Int)
541 start_vms_process_read (vs);
542 SpawnFlags = CLI$M_NOWAIT;
544 else
545 SpawnFlags = 0;
548 On VMS we need to change the current directory
549 of the parent process before forking so that
550 the child inherit that directory. We remember
551 where we were before changing.
553 VMSgetwd (oldDir);
554 child_setup (0, 0, 0, 0, 0);
555 status = lib$spawn (&dcmd, &din, &dout, &SpawnFlags, 0, &vs->pid,
556 &vs->exitStatus, 0, call_process_ast, vs);
557 chdir (oldDir);
559 if (status != SS$_NORMAL)
561 sys$dassgn (inchannel);
562 sys$dassgn (outchannel);
563 give_back_vms_process_stuff (vs);
564 error ("Error calling LIB$SPAWN: %x", status);
566 pid = vs->pid;
568 if (XTYPE (buffer) == Lisp_Int)
570 #ifndef subprocesses
571 wait_without_blocking ();
572 #endif subprocesses
573 return Qnil;
576 record_unwind_protect (call_process_cleanup,
577 Fcons (make_number (fd[0]), make_number (pid)));
580 if (XTYPE (buffer) == Lisp_Buffer)
581 Fset_buffer (buffer);
583 immediate_quit = 1;
584 QUIT;
586 while (1)
588 sys$waitfr (vs->eventFlag);
589 if (vs->iosb[0] & 1)
591 immediate_quit = 0;
592 if (!NULL (buffer))
594 vs->iosb[1] = clean_vms_buffer (vs->inputBuffer, vs->iosb[1]);
595 InsCStr (vs->inputBuffer, vs->iosb[1]);
597 if (!NULL (display) && INTERACTIVE)
598 redisplay_preserve_echo_area ();
599 immediate_quit = 1;
600 QUIT;
601 if (!start_vms_process_read (vs))
602 break; /* The other side went away */
604 else
605 break;
607 sys$dassgn (inchannel);
608 sys$dassgn (outchannel);
609 give_back_vms_process_stuff (vs);
611 /* Wait for it to terminate, unless it already has. */
612 wait_for_termination (pid);
614 immediate_quit = 0;
616 set_current_buffer (old);
618 return unbind_to (count, Qnil);
621 create_process (process, new_argv)
622 Lisp_Object process;
623 char *new_argv;
625 int pid, inchannel, outchannel, forkin, forkout;
626 char old_dir[512];
627 char in_dev_name[65];
628 char out_dev_name[65];
629 short iosb[4];
630 int status;
631 int spawn_flags = CLI$M_NOWAIT;
632 int child_sig ();
633 struct {
634 int l;
635 char *a;
636 } din, dout, dprompt, dcmd;
637 VMS_PROC_STUFF *vs;
638 VMS_PROC_STUFF *get_vms_process_stuff ();
640 status = get_pty_channel (in_dev_name, out_dev_name, &inchannel, &outchannel);
641 if (!(status & 1))
643 remove_process (process);
644 error ("Error getting PTY channel: %x", status);
646 dout.l = strlen (out_dev_name);
647 dout.a = out_dev_name;
648 dprompt.l = strlen (DCL_PROMPT);
649 dprompt.a = DCL_PROMPT;
651 if (strcmp (new_argv, "*dcl*") == 0)
653 din.l = strlen (in_dev_name);
654 din.a = in_dev_name;
655 dcmd.l = 0;
656 dcmd.a = (char *)0;
658 else
660 din.l = strlen ("NLA0:");
661 din.a = "NLA0:";
662 dcmd.l = strlen (new_argv);
663 dcmd.a = new_argv;
666 /* Delay interrupts until we have a chance to store
667 the new fork's pid in its process structure */
668 sys$setast (0);
670 vs = get_vms_process_stuff ();
671 if (vs == 0)
673 sys$setast (1);
674 remove_process (process);
675 error ("Too many VMS processes");
677 vs->inputChan = inchannel;
678 vs->outputChan = outchannel;
680 /* Start a read on the process channel */
681 start_vms_process_read (vs);
683 /* Switch current directory so that the child inherits it. */
684 VMSgetwd (old_dir);
685 child_setup (0, 0, 0, 0, 0);
687 status = lib$spawn (&dcmd, &din, &dout, &spawn_flags, 0, &vs->pid,
688 &vs->exitStatus, 0, child_sig, vs, &dprompt);
689 chdir (old_dir);
691 if (status != SS$_NORMAL)
693 sys$setast (1);
694 remove_process (process);
695 error ("Error calling LIB$SPAWN: %x", status);
697 vs->pid &= 0xffff; /* It needs to fit in a FASTINT,
698 we don't need the rest of the bits */
699 pid = vs->pid;
702 ON VMS process->infd holds the (event flag-1)
703 that we use for doing I/O on that process.
704 `input_wait_mask' is the cluster of event flags
705 we can wait on.
707 Event flags returned start at 1 for the keyboard.
708 Since Unix expects descriptor 0 for the keyboard,
709 we substract one from the event flag.
711 inchannel = vs->eventFlag-1;
713 /* Record this as an active process, with its channels.
714 As a result, child_setup will close Emacs's side of the pipes. */
715 chan_process[inchannel] = process;
716 XFASTINT (XPROCESS (process)->infd) = inchannel;
717 XFASTINT (XPROCESS (process)->outfd) = outchannel;
718 XFASTINT (XPROCESS (process)->flags) = RUNNING;
720 /* Delay interrupts until we have a chance to store
721 the new fork's pid in its process structure */
723 #define NO_ECHO "set term/noecho\r"
724 sys$setast (0);
726 Send a command to the process to not echo input
728 The CMU PTY driver does not support SETMODEs.
730 write_to_vms_process (vs, NO_ECHO, strlen (NO_ECHO));
732 XFASTINT (XPROCESS (process)->pid) = pid;
733 sys$setast (1);
736 child_sig (vs)
737 VMS_PROC_STUFF *vs;
739 register int pid;
740 Lisp_Object tail, proc;
741 register struct Lisp_Process *p;
742 int old_errno = errno;
744 pid = vs->pid;
745 sys$setef (vs->eventFlag);
747 for (tail = Vprocess_alist; XSYMBOL (tail) != XSYMBOL (Qnil); tail = XCONS (tail)->cdr)
749 proc = XCONS (XCONS (tail)->car)->cdr;
750 p = XPROCESS (proc);
751 if (EQ (p->childp, Qt) && XFASTINT (p->pid) == pid)
752 break;
755 if (XSYMBOL (tail) == XSYMBOL (Qnil))
756 return;
758 child_changed++;
759 XFASTINT (p->flags) = EXITED | CHANGED;
760 /* Truncate the exit status to 24 bits so that it fits in a FASTINT */
761 XFASTINT (p->reason) = (vs->exitStatus) & 0xffffff;
764 syms_of_vmsproc ()
766 defsubr (&Scall_process);
769 init_vmsproc ()
771 char *malloc ();
772 int i;
773 VMS_PROC_STUFF *vs;
775 for (vs=procList, i=0; i<MAX_EVENT_FLAGS+1; i++, vs++)
777 vs->busy = 0;
778 vs->eventFlag = i;
779 sys$clref (i);
780 vs->inputChan = 0;
781 vs->pid = 0;
783 procList[0].busy = 1; /* Zero is reserved */