diff options
author | Jim Blandy <jimb@redhat.com> | 1990-11-12 20:20:45 +0000 |
---|---|---|
committer | Jim Blandy <jimb@redhat.com> | 1990-11-12 20:20:45 +0000 |
commit | 41fadddce715127a8b93cb96e8678455f910b1d7 (patch) | |
tree | 3a6b7b2c6601430f0e7a7e673b861d49ce65d3c1 /src/vmsproc.c | |
parent | 5d501ebcd604fe6e04b3e8b86628c07d582bd084 (diff) | |
download | emacs-41fadddce715127a8b93cb96e8678455f910b1d7.tar.gz |
Initial revision
Diffstat (limited to 'src/vmsproc.c')
-rw-r--r-- | src/vmsproc.c | 786 |
1 files changed, 786 insertions, 0 deletions
diff --git a/src/vmsproc.c b/src/vmsproc.c new file mode 100644 index 00000000000..35823b32fc1 --- /dev/null +++ b/src/vmsproc.c @@ -0,0 +1,786 @@ +/* Interfaces to subprocesses on VMS. + Copyright (C) 1988 Free Software Foundation, Inc. + +This file is part of GNU Emacs. + +GNU Emacs is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 1, or (at your option) +any later version. + +GNU Emacs is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Emacs; see the file COPYING. If not, write to +the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ + + +/* + Event flag and `select' emulation + + 0 is never used + 1 is the terminal + 23 is the timer event flag + 24-31 are reserved by VMS +*/ +#include <ssdef.h> +#include <iodef.h> +#include <dvidef.h> +#include <clidef.h> +#include "vmsproc.h" + +#define KEYBOARD_EVENT_FLAG 1 +#define TIMER_EVENT_FLAG 23 + +static VMS_PROC_STUFF procList[MAX_EVENT_FLAGS+1]; + +get_kbd_event_flag () +{ + /* + Return the first event flag for keyboard input. + */ + VMS_PROC_STUFF *vs = &procList[KEYBOARD_EVENT_FLAG]; + + vs->busy = 1; + vs->pid = 0; + return (vs->eventFlag); +} + +get_timer_event_flag () +{ + /* + Return the last event flag for use by timeouts + */ + VMS_PROC_STUFF *vs = &procList[TIMER_EVENT_FLAG]; + + vs->busy = 1; + vs->pid = 0; + return (vs->eventFlag); +} + +VMS_PROC_STUFF * +get_vms_process_stuff () +{ + /* + Return a process_stuff structure + + We use 1-23 as our event flags to simplify implementing + a VMS `select' call. + */ + int i; + VMS_PROC_STUFF *vs; + + for (i=1, vs = procList; i<MAX_EVENT_FLAGS; i++, vs++) + { + if (!vs->busy) + { + vs->busy = 1; + vs->inputChan = 0; + vs->pid = 0; + sys$clref (vs->eventFlag); + return (vs); + } + } + return ((VMS_PROC_STUFF *)0); +} + +give_back_vms_process_stuff (vs) + VMS_PROC_STUFF *vs; +{ + /* + Return an event flag to our pool + */ + vs->busy = 0; + vs->inputChan = 0; + vs->pid = 0; +} + +VMS_PROC_STUFF * +get_vms_process_pointer (pid) + int pid; +{ + /* + Given a pid, return the VMS_STUFF pointer + */ + int i; + VMS_PROC_STUFF *vs; + + /* Don't search the last one */ + for (i=0, vs=procList; i<MAX_EVENT_FLAGS; i++, vs++) + { + if (vs->busy && vs->pid == pid) + return (vs); + } + return ((VMS_PROC_STUFF *)0); +} + +start_vms_process_read (vs) + VMS_PROC_STUFF *vs; +{ + /* + Start an asynchronous read on a VMS process + We will catch up with the output sooner or later + */ + int status; + int ProcAst (); + + status = sys$qio (vs->eventFlag, vs->outputChan, IO$_READVBLK, + vs->iosb, 0, vs, + vs->inputBuffer, sizeof (vs->inputBuffer), 0, 0, 0, 0); + if (status != SS$_NORMAL) + return (0); + else + return (1); +} + +extern int waiting_for_ast; /* in sysdep.c */ +extern int timer_ef; +extern int input_ef; + +select (nDesc, rdsc, wdsc, edsc, timeOut) + int nDesc; + int *rdsc; + int *wdsc; + int *edsc; + int *timeOut; +{ + /* Emulate a select call + + We know that we only use event flags 1-23 + + timeout == 100000 & bit 0 set means wait on keyboard input until + something shows up. If timeout == 0, we just read the event + flags and return what we find. */ + + int nfds = 0; + int status; + int time[2]; + int delta = -10000000; + int zero = 0; + int timeout = *timeOut; + unsigned long mask, readMask, waitMask; + + if (rdsc) + readMask = *rdsc << 1; /* Unix mask is shifted over 1 */ + else + readMask = 0; /* Must be a wait call */ + + sys$clref (KEYBOARD_EVENT_FLAG); + sys$setast (0); /* Block interrupts */ + sys$readef (KEYBOARD_EVENT_FLAG, &mask); /* See what is set */ + mask &= readMask; /* Just examine what we need */ + if (mask == 0) + { /* Nothing set, we must wait */ + if (timeout != 0) + { /* Not just inspecting... */ + if (!(timeout == 100000 && + readMask == (1 << KEYBOARD_EVENT_FLAG))) + { + lib$emul (&timeout, &delta, &zero, time); + sys$setimr (TIMER_EVENT_FLAG, time, 0, 1); + waitMask = readMask | (1 << TIMER_EVENT_FLAG); + } + else + waitMask = readMask; + if (waitMask & (1 << KEYBOARD_EVENT_FLAG)) + { + sys$clref (KEYBOARD_EVENT_FLAG); + waiting_for_ast = 1; /* Only if reading from 0 */ + } + sys$setast (1); + sys$wflor (KEYBOARD_EVENT_FLAG, waitMask); + sys$cantim (1, 0); + sys$readef (KEYBOARD_EVENT_FLAG, &mask); + if (readMask & (1 << KEYBOARD_EVENT_FLAG)) + waiting_for_ast = 0; + } + } + sys$setast (1); + + /* + Count number of descriptors that are ready + */ + mask &= readMask; + if (rdsc) + *rdsc = (mask >> 1); /* Back to Unix format */ + for (nfds = 0; mask; mask >>= 1) + { + if (mask & 1) + nfds++; + } + return (nfds); +} + +#define MAX_BUFF 1024 + +write_to_vms_process (vs, buf, len) + VMS_PROC_STUFF *vs; + char *buf; + int len; +{ + /* + Write something to a VMS process. + + We have to map newlines to carriage returns for VMS. + */ + char ourBuff[MAX_BUFF]; + short iosb[4]; + int status; + int in, out; + + while (len > 0) + { + out = map_nl_to_cr (buf, ourBuff, len, MAX_BUFF); + status = sys$qiow (0, vs->inputChan, IO$_WRITEVBLK|IO$M_NOFORMAT, + iosb, 0, 0, ourBuff, out, 0, 0, 0, 0); + if (status != SS$_NORMAL || (status = iosb[0]) != SS$_NORMAL) + { + error ("Could not write to subprocess: %x", status); + return (0); + } + len =- out; + } + return (1); +} + +static +map_nl_to_cr (in, out, maxIn, maxOut) + char *in; + char *out; + int maxIn; + int maxOut; +{ + /* + Copy `in' to `out' remapping `\n' to `\r' + */ + int c; + int o; + + for (o=0; maxIn-- > 0 && o < maxOut; o++) + { + c = *in++; + *out++ = (c == '\n') ? '\r' : c; + } + return (o); +} + +clean_vms_buffer (buf, len) + char *buf; + int len; +{ + /* + Sanitize output from a VMS subprocess + Strip CR's and NULLs + */ + char *oBuf = buf; + char c; + int l = 0; + + while (len-- > 0) + { + c = *buf++; + if (c == '\r' || c == '\0') + ; + else + { + *oBuf++ = c; + l++; + } + } + return (l); +} + +/* + For the CMU PTY driver +*/ +#define PTYNAME "PYA0:" + +get_pty_channel (inDevName, outDevName, inChannel, outChannel) + char *inDevName; + char *outDevName; + int *inChannel; + int *outChannel; +{ + int PartnerUnitNumber; + int status; + struct { + int l; + char *a; + } d; + struct { + short BufLen; + short ItemCode; + int *BufAddress; + int *ItemLength; + } g[2]; + + d.l = strlen (PTYNAME); + d.a = PTYNAME; + *inChannel = 0; /* Should be `short' on VMS */ + *outChannel = 0; + *inDevName = *outDevName = '\0'; + status = sys$assign (&d, inChannel, 0, 0); + if (status == SS$_NORMAL) + { + *outChannel = *inChannel; + g[0].BufLen = sizeof (PartnerUnitNumber); + g[0].ItemCode = DVI$_UNIT; + g[0].BufAddress = &PartnerUnitNumber; + g[0].ItemLength = (int *)0; + g[1].BufLen = g[1].ItemCode = 0; + status = sys$getdviw (0, *inChannel, 0, &g, 0, 0, 0, 0); + if (status == SS$_NORMAL) + { + sprintf (inDevName, "_TPA%d:", PartnerUnitNumber); + strcpy (outDevName, inDevName); + } + } + return (status); +} + +VMSgetwd (buf) + char *buf; +{ + /* + Return the current directory + */ + char curdir[256]; + char *getenv (); + char *s; + short len; + int status; + struct + { + int l; + char *a; + } d; + + s = getenv ("SYS$DISK"); + if (s) + strcpy (buf, s); + else + *buf = '\0'; + + d.l = 255; + d.a = curdir; + status = sys$setddir (0, &len, &d); + if (status & 1) + { + curdir[len] = '\0'; + strcat (buf, curdir); + } +} + +static +call_process_ast (vs) + VMS_PROC_STUFF *vs; +{ + sys$setef (vs->eventFlag); +} + +void +child_setup (in, out, err, new_argv, env) + int in, out, err; + register char **new_argv; + char **env; +{ + /* ??? I suspect that maybe this shouldn't be done on VMS. */ +#ifdef subprocesses + /* Close Emacs's descriptors that this process should not have. */ + close_process_descs (); +#endif + + if (XTYPE (current_buffer->directory) == Lisp_String) + chdir (XSTRING (current_buffer->directory)->data); +} + +DEFUN ("call-process", Fcall_process, Scall_process, 1, MANY, 0, + "Call PROGRAM synchronously in a separate process.\n\ +Program's input comes from file INFILE (nil means null device, `NLA0:').\n\ +Insert output in BUFFER before point; t means current buffer;\n\ + nil for BUFFER means discard it; 0 means discard and don't wait.\n\ +Fourth arg DISPLAY non-nil means redisplay buffer as output is inserted.\n\ +Remaining arguments are strings passed as command arguments to PROGRAM.\n\ +This function waits for PROGRAM to terminate, unless BUFFER is 0;\n\ +if you quit, the process is killed.") + (nargs, args) + int nargs; + register Lisp_Object *args; +{ + Lisp_Object display, buffer, path; + char oldDir[512]; + int inchannel, outchannel; + int len; + int call_process_ast (); + struct + { + int l; + char *a; + } dcmd, din, dout; + char inDevName[65]; + char outDevName[65]; + short iosb[4]; + int status; + int SpawnFlags = CLI$M_NOWAIT; + VMS_PROC_STUFF *vs; + VMS_PROC_STUFF *get_vms_process_stuff (); + int fd[2]; + int filefd; + register int pid; + char buf[1024]; + int count = specpdl_ptr - specpdl; + register unsigned char **new_argv; + struct buffer *old = current_buffer; + + CHECK_STRING (args[0], 0); + + if (nargs <= 1 || NULL (args[1])) + args[1] = build_string ("NLA0:"); + else + args[1] = Fexpand_file_name (args[1], current_buffer->directory); + + CHECK_STRING (args[1], 1); + + { + register Lisp_Object tem; + buffer = tem = args[2]; + if (nargs <= 2) + buffer = Qnil; + else if (!(EQ (tem, Qnil) || EQ (tem, Qt) + || XFASTINT (tem) == 0)) + { + buffer = Fget_buffer (tem); + CHECK_BUFFER (buffer, 2); + } + } + + display = nargs >= 3 ? args[3] : Qnil; + + { + /* + if (args[0] == "*dcl*" then we need to skip pas the "-c", + else args[0] is the program to run. + */ + register int i; + int arg0; + int firstArg; + + if (strcmp (XSTRING (args[0])->data, "*dcl*") == 0) + { + arg0 = 5; + firstArg = 6; + } + else + { + arg0 = 0; + firstArg = 4; + } + len = XSTRING (args[arg0])->size + 1; + for (i = firstArg; i < nargs; i++) + { + CHECK_STRING (args[i], i); + len += XSTRING (args[i])->size + 1; + } + new_argv = alloca (len); + strcpy (new_argv, XSTRING (args[arg0])->data); + for (i = firstArg; i < nargs; i++) + { + strcat (new_argv, " "); + strcat (new_argv, XSTRING (args[i])->data); + } + dcmd.l = len-1; + dcmd.a = new_argv; + + status = get_pty_channel (inDevName, outDevName, &inchannel, &outchannel); + if (!(status & 1)) + error ("Error getting PTY channel: %x", status); + if (XTYPE (buffer) == Lisp_Int) + { + dout.l = strlen ("NLA0:"); + dout.a = "NLA0:"; + } + else + { + dout.l = strlen (outDevName); + dout.a = outDevName; + } + + vs = get_vms_process_stuff (); + if (!vs) + { + sys$dassgn (inchannel); + sys$dassgn (outchannel); + error ("Too many VMS processes"); + } + vs->inputChan = inchannel; + vs->outputChan = outchannel; + } + + filefd = open (XSTRING (args[1])->data, O_RDONLY, 0); + if (filefd < 0) + { + sys$dassgn (inchannel); + sys$dassgn (outchannel); + give_back_vms_process_stuff (vs); + report_file_error ("Opening process input file", Fcons (args[1], Qnil)); + } + else + close (filefd); + + din.l = XSTRING (args[1])->size; + din.a = XSTRING (args[1])->data; + + /* + Start a read on the process channel + */ + if (XTYPE (buffer) != Lisp_Int) + { + start_vms_process_read (vs); + SpawnFlags = CLI$M_NOWAIT; + } + else + SpawnFlags = 0; + + /* + On VMS we need to change the current directory + of the parent process before forking so that + the child inherit that directory. We remember + where we were before changing. + */ + VMSgetwd (oldDir); + child_setup (0, 0, 0, 0, 0); + status = lib$spawn (&dcmd, &din, &dout, &SpawnFlags, 0, &vs->pid, + &vs->exitStatus, 0, call_process_ast, vs); + chdir (oldDir); + + if (status != SS$_NORMAL) + { + sys$dassgn (inchannel); + sys$dassgn (outchannel); + give_back_vms_process_stuff (vs); + error ("Error calling LIB$SPAWN: %x", status); + } + pid = vs->pid; + + if (XTYPE (buffer) == Lisp_Int) + { +#ifndef subprocesses + wait_without_blocking (); +#endif subprocesses + return Qnil; + } + + record_unwind_protect (call_process_cleanup, + Fcons (make_number (fd[0]), make_number (pid))); + + + if (XTYPE (buffer) == Lisp_Buffer) + Fset_buffer (buffer); + + immediate_quit = 1; + QUIT; + + while (1) + { + sys$waitfr (vs->eventFlag); + if (vs->iosb[0] & 1) + { + immediate_quit = 0; + if (!NULL (buffer)) + { + vs->iosb[1] = clean_vms_buffer (vs->inputBuffer, vs->iosb[1]); + InsCStr (vs->inputBuffer, vs->iosb[1]); + } + if (!NULL (display) && INTERACTIVE) + redisplay_preserve_echo_area (); + immediate_quit = 1; + QUIT; + if (!start_vms_process_read (vs)) + break; /* The other side went away */ + } + else + break; + } + sys$dassgn (inchannel); + sys$dassgn (outchannel); + give_back_vms_process_stuff (vs); + + /* Wait for it to terminate, unless it already has. */ + wait_for_termination (pid); + + immediate_quit = 0; + + set_current_buffer (old); + + unbind_to (count); + + return Qnil; +} + +create_process (process, new_argv) + Lisp_Object process; + char *new_argv; +{ + int pid, inchannel, outchannel, forkin, forkout; + char old_dir[512]; + char in_dev_name[65]; + char out_dev_name[65]; + short iosb[4]; + int status; + int spawn_flags = CLI$M_NOWAIT; + int child_sig (); + struct { + int l; + char *a; + } din, dout, dprompt, dcmd; + VMS_PROC_STUFF *vs; + VMS_PROC_STUFF *get_vms_process_stuff (); + + status = get_pty_channel (in_dev_name, out_dev_name, &inchannel, &outchannel); + if (!(status & 1)) + { + remove_process (process); + error ("Error getting PTY channel: %x", status); + } + dout.l = strlen (out_dev_name); + dout.a = out_dev_name; + dprompt.l = strlen (DCL_PROMPT); + dprompt.a = DCL_PROMPT; + + if (strcmp (new_argv, "*dcl*") == 0) + { + din.l = strlen (in_dev_name); + din.a = in_dev_name; + dcmd.l = 0; + dcmd.a = (char *)0; + } + else + { + din.l = strlen ("NLA0:"); + din.a = "NLA0:"; + dcmd.l = strlen (new_argv); + dcmd.a = new_argv; + } + + /* Delay interrupts until we have a chance to store + the new fork's pid in its process structure */ + sys$setast (0); + + vs = get_vms_process_stuff (); + if (vs == 0) + { + sys$setast (1); + remove_process (process); + error ("Too many VMS processes"); + } + vs->inputChan = inchannel; + vs->outputChan = outchannel; + + /* Start a read on the process channel */ + start_vms_process_read (vs); + + /* Switch current directory so that the child inherits it. */ + VMSgetwd (old_dir); + child_setup (0, 0, 0, 0, 0); + + status = lib$spawn (&dcmd, &din, &dout, &spawn_flags, 0, &vs->pid, + &vs->exitStatus, 0, child_sig, vs, &dprompt); + chdir (old_dir); + + if (status != SS$_NORMAL) + { + sys$setast (1); + remove_process (process); + error ("Error calling LIB$SPAWN: %x", status); + } + vs->pid &= 0xffff; /* It needs to fit in a FASTINT, + we don't need the rest of the bits */ + pid = vs->pid; + + /* + ON VMS process->infd holds the (event flag-1) + that we use for doing I/O on that process. + `input_wait_mask' is the cluster of event flags + we can wait on. + + Event flags returned start at 1 for the keyboard. + Since Unix expects descriptor 0 for the keyboard, + we substract one from the event flag. + */ + inchannel = vs->eventFlag-1; + + /* Record this as an active process, with its channels. + As a result, child_setup will close Emacs's side of the pipes. */ + chan_process[inchannel] = process; + XFASTINT (XPROCESS (process)->infd) = inchannel; + XFASTINT (XPROCESS (process)->outfd) = outchannel; + XFASTINT (XPROCESS (process)->flags) = RUNNING; + + /* Delay interrupts until we have a chance to store + the new fork's pid in its process structure */ + +#define NO_ECHO "set term/noecho\r" + sys$setast (0); + /* + Send a command to the process to not echo input + + The CMU PTY driver does not support SETMODEs. + */ + write_to_vms_process (vs, NO_ECHO, strlen (NO_ECHO)); + + XFASTINT (XPROCESS (process)->pid) = pid; + sys$setast (1); +} + +child_sig (vs) + VMS_PROC_STUFF *vs; +{ + register int pid; + Lisp_Object tail, proc; + register struct Lisp_Process *p; + int old_errno = errno; + + pid = vs->pid; + sys$setef (vs->eventFlag); + + for (tail = Vprocess_alist; XSYMBOL (tail) != XSYMBOL (Qnil); tail = XCONS (tail)->cdr) + { + proc = XCONS (XCONS (tail)->car)->cdr; + p = XPROCESS (proc); + if (EQ (p->childp, Qt) && XFASTINT (p->pid) == pid) + break; + } + + if (XSYMBOL (tail) == XSYMBOL (Qnil)) + return; + + child_changed++; + XFASTINT (p->flags) = EXITED | CHANGED; + /* Truncate the exit status to 24 bits so that it fits in a FASTINT */ + XFASTINT (p->reason) = (vs->exitStatus) & 0xffffff; +} + +syms_of_vmsproc () +{ + defsubr (&Scall_process); +} + +init_vmsproc () +{ + char *malloc (); + int i; + VMS_PROC_STUFF *vs; + + for (vs=procList, i=0; i<MAX_EVENT_FLAGS+1; i++, vs++) + { + vs->busy = 0; + vs->eventFlag = i; + sys$clref (i); + vs->inputChan = 0; + vs->pid = 0; + } + procList[0].busy = 1; /* Zero is reserved */ +} |