*** empty log message ***
[emacs.git] / src / vmsproc.c
blobf6e29f472a6a5f20b3491d6920c4edda5f28b4b4
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 <config.h>
30 #include <ssdef.h>
31 #include <iodef.h>
32 #include <dvidef.h>
33 #include <clidef.h>
34 #include "vmsproc.h"
35 #include "lisp.h"
36 #include "buffer.h"
37 #include <file.h>
38 #include "process.h"
39 #include "commands.h"
40 #include <errno.h>
41 extern Lisp_Object call_process_cleanup ();
44 #define KEYBOARD_EVENT_FLAG 1
45 #define TIMER_EVENT_FLAG 23
47 static VMS_PROC_STUFF procList[MAX_EVENT_FLAGS+1];
49 get_kbd_event_flag ()
52 Return the first event flag for keyboard input.
54 VMS_PROC_STUFF *vs = &procList[KEYBOARD_EVENT_FLAG];
56 vs->busy = 1;
57 vs->pid = 0;
58 return (vs->eventFlag);
61 get_timer_event_flag ()
64 Return the last event flag for use by timeouts
66 VMS_PROC_STUFF *vs = &procList[TIMER_EVENT_FLAG];
68 vs->busy = 1;
69 vs->pid = 0;
70 return (vs->eventFlag);
73 VMS_PROC_STUFF *
74 get_vms_process_stuff ()
77 Return a process_stuff structure
79 We use 1-23 as our event flags to simplify implementing
80 a VMS `select' call.
82 int i;
83 VMS_PROC_STUFF *vs;
85 for (i=1, vs = procList; i<MAX_EVENT_FLAGS; i++, vs++)
87 if (!vs->busy)
89 vs->busy = 1;
90 vs->inputChan = 0;
91 vs->pid = 0;
92 sys$clref (vs->eventFlag);
93 return (vs);
96 return ((VMS_PROC_STUFF *)0);
99 give_back_vms_process_stuff (vs)
100 VMS_PROC_STUFF *vs;
103 Return an event flag to our pool
105 vs->busy = 0;
106 vs->inputChan = 0;
107 vs->pid = 0;
110 VMS_PROC_STUFF *
111 get_vms_process_pointer (pid)
112 int pid;
115 Given a pid, return the VMS_STUFF pointer
117 int i;
118 VMS_PROC_STUFF *vs;
120 /* Don't search the last one */
121 for (i=0, vs=procList; i<MAX_EVENT_FLAGS; i++, vs++)
123 if (vs->busy && vs->pid == pid)
124 return (vs);
126 return ((VMS_PROC_STUFF *)0);
129 start_vms_process_read (vs)
130 VMS_PROC_STUFF *vs;
133 Start an asynchronous read on a VMS process
134 We will catch up with the output sooner or later
136 int status;
137 int ProcAst ();
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);
148 extern int waiting_for_ast; /* in sysdep.c */
149 extern int timer_ef;
150 extern int input_ef;
152 select (nDesc, rdsc, wdsc, edsc, timeOut)
153 int nDesc;
154 int *rdsc;
155 int *wdsc;
156 int *edsc;
157 int *timeOut;
159 /* Emulate a select call
161 We know that we only use event flags 1-23
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. */
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;
175 if (rdsc)
176 readMask = *rdsc << 1; /* Unix mask is shifted over 1 */
177 else
178 readMask = 0; /* Must be a wait call */
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)))
191 lib$emul (&timeout, &delta, &zero, time);
192 sys$setimr (TIMER_EVENT_FLAG, time, 0, 1);
193 waitMask = readMask | (1 << TIMER_EVENT_FLAG);
195 else
196 waitMask = readMask;
197 if (waitMask & (1 << KEYBOARD_EVENT_FLAG))
199 sys$clref (KEYBOARD_EVENT_FLAG);
200 waiting_for_ast = 1; /* Only if reading from 0 */
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;
210 sys$setast (1);
213 Count number of descriptors that are ready
215 mask &= readMask;
216 if (rdsc)
217 *rdsc = (mask >> 1); /* Back to Unix format */
218 for (nfds = 0; mask; mask >>= 1)
220 if (mask & 1)
221 nfds++;
223 return (nfds);
226 #define MAX_BUFF 1024
228 write_to_vms_process (vs, buf, len)
229 VMS_PROC_STUFF *vs;
230 char *buf;
231 int len;
234 Write something to a VMS process.
236 We have to map newlines to carriage returns for VMS.
238 char ourBuff[MAX_BUFF];
239 short iosb[4];
240 int status;
241 int in, out;
243 while (len > 0)
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)
250 error ("Could not write to subprocess: %x", status);
251 return (0);
253 len -= out;
255 return (1);
258 static
259 map_nl_to_cr (in, out, maxIn, maxOut)
260 char *in;
261 char *out;
262 int maxIn;
263 int maxOut;
266 Copy `in' to `out' remapping `\n' to `\r'
268 int c;
269 int o;
271 for (o=0; maxIn-- > 0 && o < maxOut; o++)
273 c = *in++;
274 *out++ = (c == '\n') ? '\r' : c;
276 return (o);
279 clean_vms_buffer (buf, len)
280 char *buf;
281 int len;
284 Sanitize output from a VMS subprocess
285 Strip CR's and NULLs
287 char *oBuf = buf;
288 char c;
289 int l = 0;
291 while (len-- > 0)
293 c = *buf++;
294 if (c == '\r' || c == '\0')
296 else
298 *oBuf++ = c;
299 l++;
302 return (l);
306 For the CMU PTY driver
308 #define PTYNAME "PYA0:"
310 get_pty_channel (inDevName, outDevName, inChannel, outChannel)
311 char *inDevName;
312 char *outDevName;
313 int *inChannel;
314 int *outChannel;
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];
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)
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)
346 sprintf (inDevName, "_TPA%d:", PartnerUnitNumber);
347 strcpy (outDevName, inDevName);
350 return (status);
353 VMSgetwd (buf)
354 char *buf;
357 Return the current directory
359 char curdir[256];
360 char *getenv ();
361 char *s;
362 short len;
363 int status;
364 struct
366 int l;
367 char *a;
368 } d;
370 s = getenv ("SYS$DISK");
371 if (s)
372 strcpy (buf, s);
373 else
374 *buf = '\0';
376 d.l = 255;
377 d.a = curdir;
378 status = sys$setddir (0, &len, &d);
379 if (status & 1)
381 curdir[len] = '\0';
382 strcat (buf, curdir);
386 static
387 call_process_ast (vs)
388 VMS_PROC_STUFF *vs;
390 sys$setef (vs->eventFlag);
393 void
394 child_setup (in, out, err, new_argv, env)
395 int in, out, err;
396 register char **new_argv;
397 char **env;
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
405 if (XTYPE (current_buffer->directory) == Lisp_String)
406 chdir (XSTRING (current_buffer->directory)->data);
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;
422 Lisp_Object display, buffer, path;
423 char oldDir[512];
424 int inchannel, outchannel;
425 int len;
426 int call_process_ast ();
427 struct
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;
447 CHECK_STRING (args[0], 0);
449 if (nargs <= 1 || NILP (args[1]))
450 args[1] = build_string ("NLA0:");
451 else
452 args[1] = Fexpand_file_name (args[1], current_buffer->directory);
454 CHECK_STRING (args[1], 1);
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))
464 buffer = Fget_buffer (tem);
465 CHECK_BUFFER (buffer, 2);
469 display = nargs >= 3 ? args[3] : Qnil;
473 if (args[0] == "*dcl*" then we need to skip pas the "-c",
474 else args[0] is the program to run.
476 register int i;
477 int arg0;
478 int firstArg;
480 if (strcmp (XSTRING (args[0])->data, "*dcl*") == 0)
482 arg0 = 5;
483 firstArg = 6;
485 else
487 arg0 = 0;
488 firstArg = 4;
490 len = XSTRING (args[arg0])->size + 1;
491 for (i = firstArg; i < nargs; i++)
493 CHECK_STRING (args[i], i);
494 len += XSTRING (args[i])->size + 1;
496 new_argv = alloca (len);
497 strcpy (new_argv, XSTRING (args[arg0])->data);
498 for (i = firstArg; i < nargs; i++)
500 strcat (new_argv, " ");
501 strcat (new_argv, XSTRING (args[i])->data);
503 dcmd.l = len-1;
504 dcmd.a = new_argv;
506 status = get_pty_channel (inDevName, outDevName, &inchannel, &outchannel);
507 if (!(status & 1))
508 error ("Error getting PTY channel: %x", status);
509 if (XTYPE (buffer) == Lisp_Int)
511 dout.l = strlen ("NLA0:");
512 dout.a = "NLA0:";
514 else
516 dout.l = strlen (outDevName);
517 dout.a = outDevName;
520 vs = get_vms_process_stuff ();
521 if (!vs)
523 sys$dassgn (inchannel);
524 sys$dassgn (outchannel);
525 error ("Too many VMS processes");
527 vs->inputChan = inchannel;
528 vs->outputChan = outchannel;
531 filefd = open (XSTRING (args[1])->data, O_RDONLY, 0);
532 if (filefd < 0)
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));
539 else
540 close (filefd);
542 din.l = XSTRING (args[1])->size;
543 din.a = XSTRING (args[1])->data;
546 Start a read on the process channel
548 if (XTYPE (buffer) != Lisp_Int)
550 start_vms_process_read (vs);
551 SpawnFlags = CLI$M_NOWAIT;
553 else
554 SpawnFlags = 0;
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.
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);
568 if (status != SS$_NORMAL)
570 sys$dassgn (inchannel);
571 sys$dassgn (outchannel);
572 give_back_vms_process_stuff (vs);
573 error ("Error calling LIB$SPAWN: %x", status);
575 pid = vs->pid;
577 if (XTYPE (buffer) == Lisp_Int)
579 #ifndef subprocesses
580 wait_without_blocking ();
581 #endif subprocesses
582 return Qnil;
585 if (!NILP (display) && INTERACTIVE)
586 prepare_menu_bars ();
588 record_unwind_protect (call_process_cleanup,
589 Fcons (make_number (fd[0]), make_number (pid)));
592 if (XTYPE (buffer) == Lisp_Buffer)
593 Fset_buffer (buffer);
595 immediate_quit = 1;
596 QUIT;
598 while (1)
600 sys$waitfr (vs->eventFlag);
601 if (vs->iosb[0] & 1)
603 immediate_quit = 0;
604 if (!NILP (buffer))
606 vs->iosb[1] = clean_vms_buffer (vs->inputBuffer, vs->iosb[1]);
607 InsCStr (vs->inputBuffer, vs->iosb[1]);
609 if (!NILP (display) && INTERACTIVE)
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 */
616 else
617 break;
620 sys$dassgn (inchannel);
621 sys$dassgn (outchannel);
622 give_back_vms_process_stuff (vs);
624 /* Wait for it to terminate, unless it already has. */
625 wait_for_termination (pid);
627 immediate_quit = 0;
629 set_current_buffer (old);
631 return unbind_to (count, Qnil);
634 create_process (process, new_argv)
635 Lisp_Object process;
636 char *new_argv;
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 ();
653 status = get_pty_channel (in_dev_name, out_dev_name, &inchannel, &outchannel);
654 if (!(status & 1))
656 remove_process (process);
657 error ("Error getting PTY channel: %x", status);
659 dout.l = strlen (out_dev_name);
660 dout.a = out_dev_name;
661 dprompt.l = strlen (DCL_PROMPT);
662 dprompt.a = DCL_PROMPT;
664 if (strcmp (new_argv, "*dcl*") == 0)
666 din.l = strlen (in_dev_name);
667 din.a = in_dev_name;
668 dcmd.l = 0;
669 dcmd.a = (char *)0;
671 else
673 din.l = strlen ("NLA0:");
674 din.a = "NLA0:";
675 dcmd.l = strlen (new_argv);
676 dcmd.a = new_argv;
679 /* Delay interrupts until we have a chance to store
680 the new fork's pid in its process structure */
681 sys$setast (0);
683 vs = get_vms_process_stuff ();
684 if (vs == 0)
686 sys$setast (1);
687 remove_process (process);
688 error ("Too many VMS processes");
690 vs->inputChan = inchannel;
691 vs->outputChan = outchannel;
693 /* Start a read on the process channel */
694 start_vms_process_read (vs);
696 /* Switch current directory so that the child inherits it. */
697 VMSgetwd (old_dir);
698 child_setup (0, 0, 0, 0, 0);
700 status = lib$spawn (&dcmd, &din, &dout, &spawn_flags, 0, &vs->pid,
701 &vs->exitStatus, 0, child_sig, vs, &dprompt);
702 chdir (old_dir);
704 if (status != SS$_NORMAL)
706 sys$setast (1);
707 remove_process (process);
708 error ("Error calling LIB$SPAWN: %x", status);
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;
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.
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.
724 inchannel = vs->eventFlag-1;
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;
729 XFASTINT (XPROCESS (process)->infd) = inchannel;
730 XFASTINT (XPROCESS (process)->outfd) = outchannel;
731 XPROCESS (process)->status = Qrun
733 /* Delay interrupts until we have a chance to store
734 the new fork's pid in its process structure */
736 #define NO_ECHO "set term/noecho\r"
737 sys$setast (0);
739 Send a command to the process to not echo input
741 The CMU PTY driver does not support SETMODEs.
743 write_to_vms_process (vs, NO_ECHO, strlen (NO_ECHO));
745 XFASTINT (XPROCESS (process)->pid) = pid;
746 sys$setast (1);
749 child_sig (vs)
750 VMS_PROC_STUFF *vs;
752 register int pid;
753 Lisp_Object tail, proc;
754 register struct Lisp_Process *p;
755 int old_errno = errno;
757 pid = vs->pid;
758 sys$setef (vs->eventFlag);
760 for (tail = Vprocess_alist; XSYMBOL (tail) != XSYMBOL (Qnil); tail = XCONS (tail)->cdr)
762 proc = XCONS (XCONS (tail)->car)->cdr;
763 p = XPROCESS (proc);
764 if (EQ (p->childp, Qt) && XFASTINT (p->pid) == pid)
765 break;
768 if (XSYMBOL (tail) == XSYMBOL (Qnil))
769 return;
771 p->status = Fcons (Qexit, Fcons (make_number (vs->exitStatus), Qnil))
774 syms_of_vmsproc ()
776 defsubr (&Scall_process);
779 init_vmsproc ()
781 char *malloc ();
782 int i;
783 VMS_PROC_STUFF *vs;
785 for (vs=procList, i=0; i<MAX_EVENT_FLAGS+1; i++, vs++)
787 vs->busy = 0;
788 vs->eventFlag = i;
789 sys$clref (i);
790 vs->inputChan = 0;
791 vs->pid = 0;
793 procList[0].busy = 1; /* Zero is reserved */