annotate src/vmsproc.c @ 2875:cd410e9ac4ab

* xfaces.c (free_frame_faces): Don't free the resources from the first two faces.

/* 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 || NILP (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 (!NILP (buffer))
	    {
	      vs->iosb[1] = clean_vms_buffer (vs->inputBuffer, vs->iosb[1]);
	      InsCStr (vs->inputBuffer, vs->iosb[1]);
	    }
	  if (!NILP (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 */
}