*** empty log message ***
[emacs.git] / src / vmsproc.c
blob15e2c9d5e61e762602098fc94cdcce9a15080a1a
1 /* Interfaces to subprocesses on VMS.
2 Copyright (C) 1988, 1994 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 2, 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, Inc., 59 Temple Place - Suite 330,
19 Boston, MA 02111-1307, USA. */
23 Event flag and `select' emulation
25 0 is never used
26 1 is the terminal
27 23 is the timer event flag
28 24-31 are reserved by VMS
30 #include <config.h>
31 #include <ssdef.h>
32 #include <iodef.h>
33 #include <dvidef.h>
34 #include <clidef.h>
35 #include "vmsproc.h"
36 #include "lisp.h"
37 #include "buffer.h"
38 #include <file.h>
39 #include "process.h"
40 #include "commands.h"
41 #include <errno.h>
42 extern Lisp_Object call_process_cleanup ();
45 #define KEYBOARD_EVENT_FLAG 1
46 #define TIMER_EVENT_FLAG 23
48 static VMS_PROC_STUFF procList[MAX_EVENT_FLAGS+1];
50 get_kbd_event_flag ()
53 Return the first event flag for keyboard input.
55 VMS_PROC_STUFF *vs = &procList[KEYBOARD_EVENT_FLAG];
57 vs->busy = 1;
58 vs->pid = 0;
59 return (vs->eventFlag);
62 get_timer_event_flag ()
65 Return the last event flag for use by timeouts
67 VMS_PROC_STUFF *vs = &procList[TIMER_EVENT_FLAG];
69 vs->busy = 1;
70 vs->pid = 0;
71 return (vs->eventFlag);
74 VMS_PROC_STUFF *
75 get_vms_process_stuff ()
78 Return a process_stuff structure
80 We use 1-23 as our event flags to simplify implementing
81 a VMS `select' call.
83 int i;
84 VMS_PROC_STUFF *vs;
86 for (i=1, vs = procList; i<MAX_EVENT_FLAGS; i++, vs++)
88 if (!vs->busy)
90 vs->busy = 1;
91 vs->inputChan = 0;
92 vs->pid = 0;
93 sys$clref (vs->eventFlag);
94 return (vs);
97 return ((VMS_PROC_STUFF *)0);
100 give_back_vms_process_stuff (vs)
101 VMS_PROC_STUFF *vs;
104 Return an event flag to our pool
106 vs->busy = 0;
107 vs->inputChan = 0;
108 vs->pid = 0;
111 VMS_PROC_STUFF *
112 get_vms_process_pointer (pid)
113 int pid;
116 Given a pid, return the VMS_STUFF pointer
118 int i;
119 VMS_PROC_STUFF *vs;
121 /* Don't search the last one */
122 for (i=0, vs=procList; i<MAX_EVENT_FLAGS; i++, vs++)
124 if (vs->busy && vs->pid == pid)
125 return (vs);
127 return ((VMS_PROC_STUFF *)0);
130 start_vms_process_read (vs)
131 VMS_PROC_STUFF *vs;
134 Start an asynchronous read on a VMS process
135 We will catch up with the output sooner or later
137 int status;
138 int ProcAst ();
140 status = sys$qio (vs->eventFlag, vs->outputChan, IO$_READVBLK,
141 vs->iosb, 0, vs,
142 vs->inputBuffer, sizeof (vs->inputBuffer), 0, 0, 0, 0);
143 if (status != SS$_NORMAL)
144 return (0);
145 else
146 return (1);
149 extern int waiting_for_ast; /* in sysdep.c */
150 extern int timer_ef;
151 extern int input_ef;
153 select (nDesc, rdsc, wdsc, edsc, timeOut)
154 int nDesc;
155 int *rdsc;
156 int *wdsc;
157 int *edsc;
158 int *timeOut;
160 /* Emulate a select call
162 We know that we only use event flags 1-23
164 timeout == 100000 & bit 0 set means wait on keyboard input until
165 something shows up. If timeout == 0, we just read the event
166 flags and return what we find. */
168 int nfds = 0;
169 int status;
170 int time[2];
171 int delta = -10000000;
172 int zero = 0;
173 int timeout = *timeOut;
174 unsigned long mask, readMask, waitMask;
176 if (rdsc)
177 readMask = *rdsc << 1; /* Unix mask is shifted over 1 */
178 else
179 readMask = 0; /* Must be a wait call */
181 sys$clref (KEYBOARD_EVENT_FLAG);
182 sys$setast (0); /* Block interrupts */
183 sys$readef (KEYBOARD_EVENT_FLAG, &mask); /* See what is set */
184 mask &= readMask; /* Just examine what we need */
185 if (mask == 0)
186 { /* Nothing set, we must wait */
187 if (timeout != 0)
188 { /* Not just inspecting... */
189 if (!(timeout == 100000 &&
190 readMask == (1 << KEYBOARD_EVENT_FLAG)))
192 lib$emul (&timeout, &delta, &zero, time);
193 sys$setimr (TIMER_EVENT_FLAG, time, 0, 1);
194 waitMask = readMask | (1 << TIMER_EVENT_FLAG);
196 else
197 waitMask = readMask;
198 if (waitMask & (1 << KEYBOARD_EVENT_FLAG))
200 sys$clref (KEYBOARD_EVENT_FLAG);
201 waiting_for_ast = 1; /* Only if reading from 0 */
203 sys$setast (1);
204 sys$wflor (KEYBOARD_EVENT_FLAG, waitMask);
205 sys$cantim (1, 0);
206 sys$readef (KEYBOARD_EVENT_FLAG, &mask);
207 if (readMask & (1 << KEYBOARD_EVENT_FLAG))
208 waiting_for_ast = 0;
211 sys$setast (1);
214 Count number of descriptors that are ready
216 mask &= readMask;
217 if (rdsc)
218 *rdsc = (mask >> 1); /* Back to Unix format */
219 for (nfds = 0; mask; mask >>= 1)
221 if (mask & 1)
222 nfds++;
224 return (nfds);
227 #define MAX_BUFF 1024
229 write_to_vms_process (vs, buf, len)
230 VMS_PROC_STUFF *vs;
231 char *buf;
232 int len;
235 Write something to a VMS process.
237 We have to map newlines to carriage returns for VMS.
239 char ourBuff[MAX_BUFF];
240 short iosb[4];
241 int status;
242 int in, out;
244 while (len > 0)
246 out = map_nl_to_cr (buf, ourBuff, len, MAX_BUFF);
247 status = sys$qiow (0, vs->inputChan, IO$_WRITEVBLK|IO$M_NOFORMAT,
248 iosb, 0, 0, ourBuff, out, 0, 0, 0, 0);
249 if (status != SS$_NORMAL || (status = iosb[0]) != SS$_NORMAL)
251 error ("Could not write to subprocess: %x", status);
252 return (0);
254 len -= out;
256 return (1);
259 static
260 map_nl_to_cr (in, out, maxIn, maxOut)
261 char *in;
262 char *out;
263 int maxIn;
264 int maxOut;
267 Copy `in' to `out' remapping `\n' to `\r'
269 int c;
270 int o;
272 for (o=0; maxIn-- > 0 && o < maxOut; o++)
274 c = *in++;
275 *out++ = (c == '\n') ? '\r' : c;
277 return (o);
280 clean_vms_buffer (buf, len)
281 char *buf;
282 int len;
285 Sanitize output from a VMS subprocess
286 Strip CR's and NULLs
288 char *oBuf = buf;
289 char c;
290 int l = 0;
292 while (len-- > 0)
294 c = *buf++;
295 if (c == '\r' || c == '\0')
297 else
299 *oBuf++ = c;
300 l++;
303 return (l);
307 For the CMU PTY driver
309 #define PTYNAME "PYA0:"
311 get_pty_channel (inDevName, outDevName, inChannel, outChannel)
312 char *inDevName;
313 char *outDevName;
314 int *inChannel;
315 int *outChannel;
317 int PartnerUnitNumber;
318 int status;
319 struct {
320 int l;
321 char *a;
322 } d;
323 struct {
324 short BufLen;
325 short ItemCode;
326 int *BufAddress;
327 int *ItemLength;
328 } g[2];
330 d.l = strlen (PTYNAME);
331 d.a = PTYNAME;
332 *inChannel = 0; /* Should be `short' on VMS */
333 *outChannel = 0;
334 *inDevName = *outDevName = '\0';
335 status = sys$assign (&d, inChannel, 0, 0);
336 if (status == SS$_NORMAL)
338 *outChannel = *inChannel;
339 g[0].BufLen = sizeof (PartnerUnitNumber);
340 g[0].ItemCode = DVI$_UNIT;
341 g[0].BufAddress = &PartnerUnitNumber;
342 g[0].ItemLength = (int *)0;
343 g[1].BufLen = g[1].ItemCode = 0;
344 status = sys$getdviw (0, *inChannel, 0, &g, 0, 0, 0, 0);
345 if (status == SS$_NORMAL)
347 sprintf (inDevName, "_TPA%d:", PartnerUnitNumber);
348 strcpy (outDevName, inDevName);
351 return (status);
354 VMSgetwd (buf)
355 char *buf;
358 Return the current directory
360 char curdir[256];
361 char *getenv ();
362 char *s;
363 short len;
364 int status;
365 struct
367 int l;
368 char *a;
369 } d;
371 s = getenv ("SYS$DISK");
372 if (s)
373 strcpy (buf, s);
374 else
375 *buf = '\0';
377 d.l = 255;
378 d.a = curdir;
379 status = sys$setddir (0, &len, &d);
380 if (status & 1)
382 curdir[len] = '\0';
383 strcat (buf, curdir);
387 static
388 call_process_ast (vs)
389 VMS_PROC_STUFF *vs;
391 sys$setef (vs->eventFlag);
394 void
395 child_setup (in, out, err, new_argv, env)
396 int in, out, err;
397 register char **new_argv;
398 char **env;
400 /* ??? I suspect that maybe this shouldn't be done on VMS. */
401 #ifdef subprocesses
402 /* Close Emacs's descriptors that this process should not have. */
403 close_process_descs ();
404 #endif
406 if (STRINGP (current_buffer->directory))
407 chdir (XSTRING (current_buffer->directory)->data);
410 DEFUN ("call-process", Fcall_process, Scall_process, 1, MANY, 0,
411 "Call PROGRAM synchronously in a separate process.\n\
412 Program's input comes from file INFILE (nil means null device, `NLA0:').\n\
413 Insert output in BUFFER before point; t means current buffer;\n\
414 nil for BUFFER means discard it; 0 means discard and don't wait.\n\
415 Fourth arg DISPLAY non-nil means redisplay buffer as output is inserted.\n\
416 Remaining arguments are strings passed as command arguments to PROGRAM.\n\
417 This function waits for PROGRAM to terminate, unless BUFFER is 0;\n\
418 if you quit, the process is killed.")
419 (nargs, args)
420 int nargs;
421 register Lisp_Object *args;
423 Lisp_Object display, buffer, path;
424 char oldDir[512];
425 int inchannel, outchannel;
426 int len;
427 int call_process_ast ();
428 struct
430 int l;
431 char *a;
432 } dcmd, din, dout;
433 char inDevName[65];
434 char outDevName[65];
435 short iosb[4];
436 int status;
437 int SpawnFlags = CLI$M_NOWAIT;
438 VMS_PROC_STUFF *vs;
439 VMS_PROC_STUFF *get_vms_process_stuff ();
440 int fd[2];
441 int filefd;
442 register int pid;
443 char buf[1024];
444 int count = specpdl_ptr - specpdl;
445 register unsigned char **new_argv;
446 struct buffer *old = current_buffer;
448 CHECK_STRING (args[0], 0);
450 if (nargs <= 1 || NILP (args[1]))
451 args[1] = build_string ("NLA0:");
452 else
453 args[1] = Fexpand_file_name (args[1], current_buffer->directory);
455 CHECK_STRING (args[1], 1);
458 register Lisp_Object tem;
459 buffer = tem = args[2];
460 if (nargs <= 2)
461 buffer = Qnil;
462 else if (!(EQ (tem, Qnil) || EQ (tem, Qt)
463 || XFASTINT (tem) == 0))
465 buffer = Fget_buffer (tem);
466 CHECK_BUFFER (buffer, 2);
470 display = nargs >= 3 ? args[3] : Qnil;
474 if (args[0] == "*dcl*" then we need to skip pas the "-c",
475 else args[0] is the program to run.
477 register int i;
478 int arg0;
479 int firstArg;
481 if (strcmp (XSTRING (args[0])->data, "*dcl*") == 0)
483 arg0 = 5;
484 firstArg = 6;
486 else
488 arg0 = 0;
489 firstArg = 4;
491 len = XSTRING (args[arg0])->size + 1;
492 for (i = firstArg; i < nargs; i++)
494 CHECK_STRING (args[i], i);
495 len += XSTRING (args[i])->size + 1;
497 new_argv = alloca (len);
498 strcpy (new_argv, XSTRING (args[arg0])->data);
499 for (i = firstArg; i < nargs; i++)
501 strcat (new_argv, " ");
502 strcat (new_argv, XSTRING (args[i])->data);
504 dcmd.l = len-1;
505 dcmd.a = new_argv;
507 status = get_pty_channel (inDevName, outDevName, &inchannel, &outchannel);
508 if (!(status & 1))
509 error ("Error getting PTY channel: %x", status);
510 if (INTEGERP (buffer))
512 dout.l = strlen ("NLA0:");
513 dout.a = "NLA0:";
515 else
517 dout.l = strlen (outDevName);
518 dout.a = outDevName;
521 vs = get_vms_process_stuff ();
522 if (!vs)
524 sys$dassgn (inchannel);
525 sys$dassgn (outchannel);
526 error ("Too many VMS processes");
528 vs->inputChan = inchannel;
529 vs->outputChan = outchannel;
532 filefd = open (XSTRING (args[1])->data, O_RDONLY, 0);
533 if (filefd < 0)
535 sys$dassgn (inchannel);
536 sys$dassgn (outchannel);
537 give_back_vms_process_stuff (vs);
538 report_file_error ("Opening process input file", Fcons (args[1], Qnil));
540 else
541 close (filefd);
543 din.l = XSTRING (args[1])->size;
544 din.a = XSTRING (args[1])->data;
547 Start a read on the process channel
549 if (!INTEGERP (buffer))
551 start_vms_process_read (vs);
552 SpawnFlags = CLI$M_NOWAIT;
554 else
555 SpawnFlags = 0;
558 On VMS we need to change the current directory
559 of the parent process before forking so that
560 the child inherit that directory. We remember
561 where we were before changing.
563 VMSgetwd (oldDir);
564 child_setup (0, 0, 0, 0, 0);
565 status = lib$spawn (&dcmd, &din, &dout, &SpawnFlags, 0, &vs->pid,
566 &vs->exitStatus, 0, call_process_ast, vs);
567 chdir (oldDir);
569 if (status != SS$_NORMAL)
571 sys$dassgn (inchannel);
572 sys$dassgn (outchannel);
573 give_back_vms_process_stuff (vs);
574 error ("Error calling LIB$SPAWN: %x", status);
576 pid = vs->pid;
578 if (INTEGERP (buffer))
580 #ifndef subprocesses
581 wait_without_blocking ();
582 #endif subprocesses
583 return Qnil;
586 if (!NILP (display) && INTERACTIVE)
587 prepare_menu_bars ();
589 record_unwind_protect (call_process_cleanup,
590 Fcons (make_number (fd[0]), make_number (pid)));
593 if (BUFFERP (buffer))
594 Fset_buffer (buffer);
596 immediate_quit = 1;
597 QUIT;
599 while (1)
601 sys$waitfr (vs->eventFlag);
602 if (vs->iosb[0] & 1)
604 immediate_quit = 0;
605 if (!NILP (buffer))
607 vs->iosb[1] = clean_vms_buffer (vs->inputBuffer, vs->iosb[1]);
608 InsCStr (vs->inputBuffer, vs->iosb[1]);
610 if (!NILP (display) && INTERACTIVE)
611 redisplay_preserve_echo_area ();
612 immediate_quit = 1;
613 QUIT;
614 if (!start_vms_process_read (vs))
615 break; /* The other side went away */
617 else
618 break;
621 sys$dassgn (inchannel);
622 sys$dassgn (outchannel);
623 give_back_vms_process_stuff (vs);
625 /* Wait for it to terminate, unless it already has. */
626 wait_for_termination (pid);
628 immediate_quit = 0;
630 set_current_buffer (old);
632 return unbind_to (count, Qnil);
635 create_process (process, new_argv)
636 Lisp_Object process;
637 char *new_argv;
639 int pid, inchannel, outchannel, forkin, forkout;
640 char old_dir[512];
641 char in_dev_name[65];
642 char out_dev_name[65];
643 short iosb[4];
644 int status;
645 int spawn_flags = CLI$M_NOWAIT;
646 int child_sig ();
647 struct {
648 int l;
649 char *a;
650 } din, dout, dprompt, dcmd;
651 VMS_PROC_STUFF *vs;
652 VMS_PROC_STUFF *get_vms_process_stuff ();
654 status = get_pty_channel (in_dev_name, out_dev_name, &inchannel, &outchannel);
655 if (!(status & 1))
657 remove_process (process);
658 error ("Error getting PTY channel: %x", status);
660 dout.l = strlen (out_dev_name);
661 dout.a = out_dev_name;
662 dprompt.l = strlen (DCL_PROMPT);
663 dprompt.a = DCL_PROMPT;
665 if (strcmp (new_argv, "*dcl*") == 0)
667 din.l = strlen (in_dev_name);
668 din.a = in_dev_name;
669 dcmd.l = 0;
670 dcmd.a = (char *)0;
672 else
674 din.l = strlen ("NLA0:");
675 din.a = "NLA0:";
676 dcmd.l = strlen (new_argv);
677 dcmd.a = new_argv;
680 /* Delay interrupts until we have a chance to store
681 the new fork's pid in its process structure */
682 sys$setast (0);
684 vs = get_vms_process_stuff ();
685 if (vs == 0)
687 sys$setast (1);
688 remove_process (process);
689 error ("Too many VMS processes");
691 vs->inputChan = inchannel;
692 vs->outputChan = outchannel;
694 /* Start a read on the process channel */
695 start_vms_process_read (vs);
697 /* Switch current directory so that the child inherits it. */
698 VMSgetwd (old_dir);
699 child_setup (0, 0, 0, 0, 0);
701 status = lib$spawn (&dcmd, &din, &dout, &spawn_flags, 0, &vs->pid,
702 &vs->exitStatus, 0, child_sig, vs, &dprompt);
703 chdir (old_dir);
705 if (status != SS$_NORMAL)
707 sys$setast (1);
708 remove_process (process);
709 error ("Error calling LIB$SPAWN: %x", status);
711 vs->pid &= 0xffff; /* It needs to fit in a FASTINT,
712 we don't need the rest of the bits */
713 pid = vs->pid;
716 ON VMS process->infd holds the (event flag-1)
717 that we use for doing I/O on that process.
718 `input_wait_mask' is the cluster of event flags
719 we can wait on.
721 Event flags returned start at 1 for the keyboard.
722 Since Unix expects descriptor 0 for the keyboard,
723 we subtract one from the event flag.
725 inchannel = vs->eventFlag-1;
727 /* Record this as an active process, with its channels.
728 As a result, child_setup will close Emacs's side of the pipes. */
729 chan_process[inchannel] = process;
730 XSETFASTINT (XPROCESS (process)->infd, inchannel);
731 XSETFASTINT (XPROCESS (process)->outfd, outchannel);
732 XPROCESS (process)->status = Qrun
734 /* Delay interrupts until we have a chance to store
735 the new fork's pid in its process structure */
737 #define NO_ECHO "set term/noecho\r"
738 sys$setast (0);
740 Send a command to the process to not echo input
742 The CMU PTY driver does not support SETMODEs.
744 write_to_vms_process (vs, NO_ECHO, strlen (NO_ECHO));
746 XSETFASTINT (XPROCESS (process)->pid, pid);
747 sys$setast (1);
750 child_sig (vs)
751 VMS_PROC_STUFF *vs;
753 register int pid;
754 Lisp_Object tail, proc;
755 register struct Lisp_Process *p;
756 int old_errno = errno;
758 pid = vs->pid;
759 sys$setef (vs->eventFlag);
761 for (tail = Vprocess_alist; ! NILP (tail); tail = XCDR (tail))
763 proc = XCDR (XCAR (tail));
764 p = XPROCESS (proc);
765 if (EQ (p->childp, Qt) && XFASTINT (p->pid) == pid)
766 break;
769 if (NILP (tail))
770 return;
772 p->status = Fcons (Qexit, Fcons (make_number (vs->exitStatus), Qnil))
775 syms_of_vmsproc ()
777 defsubr (&Scall_process);
780 init_vmsproc ()
782 char *malloc ();
783 int i;
784 VMS_PROC_STUFF *vs;
786 for (vs=procList, i=0; i<MAX_EVENT_FLAGS+1; i++, vs++)
788 vs->busy = 0;
789 vs->eventFlag = i;
790 sys$clref (i);
791 vs->inputChan = 0;
792 vs->pid = 0;
794 procList[0].busy = 1; /* Zero is reserved */