--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/vmsproc.c	Mon Aug 13 08:45:50 2007 +0200
@@ -0,0 +1,784 @@
+/* Interfaces to subprocesses on VMS.
+   Copyright (C) 1988 Free Software Foundation, Inc.
+
+This file is part of XEmacs.
+
+XEmacs 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 2, or (at your option) any
+later version.
+
+XEmacs 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 XEmacs; see the file COPYING.  If not, write to
+the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+Boston, MA 02111-1307, USA.  */
+
+/* Synched up with: Not synched with FSF. */
+
+
+/*
+    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;
+     char **new_argv;
+     char **env;
+{
+  /* ??? I suspect that maybe this shouldn't be done on VMS.  */
+  /* Close Emacs's descriptors that this process should not have.  */
+  close_process_descs ();
+
+  if (STRINGP (current_buffer->directory))
+    chdir (string_data (XSTRING (current_buffer->directory)));
+}
+
+DEFUN ("call-process-internal", Fcall_process_internal,
+       Scall_process_internal, 1, MANY, 0 /*
+Call PROGRAM synchronously in a separate process.
+Program's input comes from file INFILE (nil means null device, `NLA0:').
+Insert output in BUFFER before point; t means current buffer;
+ nil for BUFFER means discard it; 0 means discard and don't wait.
+Fourth arg DISPLAY non-nil means redisplay buffer as output is inserted.
+Remaining arguments are strings passed as command arguments to PROGRAM.
+This function waits for PROGRAM to terminate, unless BUFFER is 0;
+if you quit, the process is killed.
+*/ )
+  (nargs, args)
+     int nargs;
+     Lisp_Object *args;
+{
+  /* This function can GC */
+  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;
+  int pid;
+  char buf[1024];
+  int speccount = specpdl_depth ();
+  unsigned char **new_argv;
+  struct buffer *old = current_buffer;
+
+  CHECK_STRING (args[0]);
+
+  if (nargs <= 1 || NILP (args[1]))
+    args[1] = build_string ("NLA0:");
+  else
+    args[1] = Fexpand_file_name (args[1],
+				 current_buffer->directory);
+
+  CHECK_STRING (args[1]);
+
+  {
+    Lisp_Object tem;
+    buffer = tem = args[2];
+    if (nargs <= 2)
+      buffer = Qnil;
+    else if (!(ZEROP (tem, Qnil) || EQ (tem, Qt) || EQ (tem))
+      {
+	buffer = Fget_buffer (tem);
+	CHECK_BUFFER (buffer);
+      }
+  }
+
+  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.
+    */
+    int i;
+    int arg0;
+    int firstArg;
+
+    if (strcmp (string_data (XSTRING (args[0])), "*dcl*") == 0)
+      {
+	arg0 = 5;
+	firstArg = 6;
+      }
+    else
+      {
+	arg0 = 0;
+	firstArg = 4;
+      }
+    len = string_length (XSTRING (args[arg0])) + 1;
+    for (i = firstArg; i < nargs; i++)
+      {
+	CHECK_STRING (args[i]);
+	len += string_length (XSTRING (args[i])) + 1;
+      }
+    new_argv = alloca (len);
+    strcpy (new_argv, string_data (XSTRING (args[arg0])));
+    for (i = firstArg; i < nargs; i++)
+      {
+	strcat (new_argv, " ");
+	strcat (new_argv, string_data (XSTRING (args[i])));
+      }
+    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 (INTP (buffer))
+      {
+	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 (string_data (XSTRING (args[1])), 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 = string_length (XSTRING (args[1]));
+  din.a = string_data (XSTRING (args[1]));
+
+  /*
+      Start a read on the process channel
+  */
+  if (!INTP (buffer))
+    {
+      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 (INTP (buffer))
+    {
+#if defined (NO_SUBPROCESSES)
+      wait_without_blocking ();
+#endif
+      return Qnil;
+    }
+
+  record_unwind_protect (call_process_cleanup,
+			 Fcons (make_int (fd[0]), make_int (pid)));
+
+
+  if (BUFFERP (buffer))
+    Fset_buffer (buffer);
+
+  while (1)
+    {
+      QUIT;
+
+      sys$waitfr (vs->eventFlag);
+      if (vs->iosb[0] & 1)
+	{
+	  if (!NILP (buffer))
+	    {
+	      vs->iosb[1] = clean_vms_buffer (vs->inputBuffer, vs->iosb[1]);
+	      InsCStr (vs->inputBuffer, vs->iosb[1]);
+	    }
+	  if (!NILP (display) && INTERACTIVE)
+	    redisplay ();
+	  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);
+
+  set_current_buffer (old);
+
+  return unbind_to (speccount, 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;
+  XPROCESS (process)->infd = make_int (inchannel);
+  XPROCESS (process)->outfd = make_int (outchannel);
+  XPROCESS (process)->flags = make_int (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));
+
+  XPROCESS (process)->pid = make_int (pid);
+  sys$setast (1);
+}
+
+child_sig (VMS_PROC_STUFF *vs)
+{
+  int pid;
+  Lisp_Object tail, proc;
+  struct Lisp_Process *p;
+  int old_errno = errno;
+
+  pid = vs->pid;
+  sys$setef (vs->eventFlag);
+
+  for (tail = Vprocess_alist; XSYMBOL (tail) != XSYMBOL (Qnil); tail = XCDR (tail))
+    {
+      proc = XCDR (XCAR (tail));
+      p = XPROCESS (proc);
+      if (EQ (p->childp, Qt) && XINT (p->pid) == pid)
+	break;
+    }
+
+  if (XSYMBOL (tail) == XSYMBOL (Qnil))
+    return;
+
+  child_changed++;
+  p->flags = make_int (EXITED | CHANGED);
+  /* Truncate the exit status to 24 bits so that it fits in a FASTINT */
+  p->reason = make_int ((vs->exitStatus) & 0xffffff);
+}
+
+void
+syms_of_vmsproc (void)
+{
+  defsubr (&Scall_process_internal);
+}
+
+void
+init_vmsproc (void)
+{
+  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 */
+}