diff options
Diffstat (limited to 'src/vmsproc.c')
| -rw-r--r-- | src/vmsproc.c | 784 |
1 files changed, 0 insertions, 784 deletions
diff --git a/src/vmsproc.c b/src/vmsproc.c deleted file mode 100644 index ec9678f78a4..00000000000 --- a/src/vmsproc.c +++ /dev/null @@ -1,784 +0,0 @@ -/* 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); - - return unbind_to (count, 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 */ -} |