process.c

/* Asynchronous subprocess control for GNU Emacs.

Copyright (C) 1985-1988, 1993-1996, 1998-1999, 2001-2013 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 3 of the License, 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.  If not, see <http://www.gnu.org/licenses/>.  */


#include <config.h>

#include <stdio.h>
#include <errno.h>
#include <sys/types.h>		/* Some typedefs are used in sys/file.h.  */
#include <sys/file.h>
#include <sys/stat.h>
#include <unistd.h>
#include <fcntl.h>

#include "lisp.h"

/* Only MS-DOS does not define `subprocesses'.  */
#ifdef subprocesses

#include <sys/socket.h>
#include <netdb.h>
#include <netinet/in.h>
#include <arpa/inet.h>

/* Are local (unix) sockets supported?  */
#if defined (HAVE_SYS_UN_H)
#if !defined (AF_LOCAL) && defined (AF_UNIX)
#define AF_LOCAL AF_UNIX
#endif
#ifdef AF_LOCAL
#define HAVE_LOCAL_SOCKETS
#include <sys/un.h>
#endif
#endif

#include <sys/ioctl.h>
#if defined (HAVE_NET_IF_H)
#include <net/if.h>
#endif /* HAVE_NET_IF_H */

#if defined (HAVE_IFADDRS_H)
/* Must be after net/if.h */
#include <ifaddrs.h>

/* We only use structs from this header when we use getifaddrs.  */
#if defined (HAVE_NET_IF_DL_H)
#include <net/if_dl.h>
#endif

#endif

#ifdef NEED_BSDTTY
#include <bsdtty.h>
#endif

#ifdef USG5_4
# include <sys/stream.h>
# include <sys/stropts.h>
#endif

#ifdef HAVE_RES_INIT
#include <arpa/nameser.h>
#include <resolv.h>
#endif

#ifdef HAVE_UTIL_H
#include <util.h>
#endif

#ifdef HAVE_PTY_H
#include <pty.h>
#endif

#include <c-ctype.h>
#include <sig2str.h>
#include <verify.h>

#endif	/* subprocesses */

#include "systime.h"
#include "systty.h"

#include "window.h"
#include "character.h"
#include "buffer.h"
#include "coding.h"
#include "process.h"
#include "frame.h"
#include "termhooks.h"
#include "termopts.h"
#include "commands.h"
#include "keyboard.h"
#include "blockinput.h"
#include "dispextern.h"
#include "composite.h"
#include "atimer.h"
#include "sysselect.h"
#include "syssignal.h"
#include "syswait.h"
#ifdef HAVE_GNUTLS
#include "gnutls.h"
#endif

#ifdef HAVE_WINDOW_SYSTEM
#include TERM_HEADER
#endif /* HAVE_WINDOW_SYSTEM */

#ifdef HAVE_GLIB
#include "xgselect.h"
#ifndef WINDOWSNT
#include <glib.h>
#endif
#endif

#ifdef WINDOWSNT
extern int sys_select (int, fd_set *, fd_set *, fd_set *,
		       struct timespec *, void *);
#endif

#ifndef SOCK_CLOEXEC
# define SOCK_CLOEXEC 0
#endif

#ifndef HAVE_ACCEPT4

/* Emulate GNU/Linux accept4 and socket well enough for this module.  */

static int
close_on_exec (int fd)
{
  if (0 <= fd)
    fcntl (fd, F_SETFD, FD_CLOEXEC);
  return fd;
}

static int
accept4 (int sockfd, struct sockaddr *addr, socklen_t *addrlen, int flags)
{
  return close_on_exec (accept (sockfd, addr, addrlen));
}

static int
process_socket (int domain, int type, int protocol)
{
  return close_on_exec (socket (domain, type, protocol));
}
# undef socket
# define socket(domain, type, protocol) process_socket (domain, type, protocol)
#endif

/* Work around GCC 4.7.0 bug with strict overflow checking; see
   <http://gcc.gnu.org/bugzilla/show_bug.cgi?id=52904>.
   These lines can be removed once the GCC bug is fixed.  */
#if __GNUC__ > 4 || (__GNUC__ == 4 && __GNUC_MINOR__ >= 3)
# pragma GCC diagnostic ignored "-Wstrict-overflow"
#endif

Lisp_Object Qeuid, Qegid, Qcomm, Qstate, Qppid, Qpgrp, Qsess, Qttname, Qtpgid;
Lisp_Object Qminflt, Qmajflt, Qcminflt, Qcmajflt, Qutime, Qstime, Qcstime;
Lisp_Object Qcutime, Qpri, Qnice, Qthcount, Qstart, Qvsize, Qrss, Qargs;
Lisp_Object Quser, Qgroup, Qetime, Qpcpu, Qpmem, Qtime, Qctime;
Lisp_Object QCname, QCtype;

/* True if keyboard input is on hold, zero otherwise.  */

static bool kbd_is_on_hold;

/* Nonzero means don't run process sentinels.  This is used
   when exiting.  */
bool inhibit_sentinels;

#ifdef subprocesses

Lisp_Object Qprocessp;
static Lisp_Object Qrun, Qstop, Qsignal;
static Lisp_Object Qopen, Qclosed, Qconnect, Qfailed, Qlisten;
Lisp_Object Qlocal;
static Lisp_Object Qipv4, Qdatagram, Qseqpacket;
static Lisp_Object Qreal, Qnetwork, Qserial;
#ifdef AF_INET6
static Lisp_Object Qipv6;
#endif
static Lisp_Object QCport, QCprocess;
Lisp_Object QCspeed;
Lisp_Object QCbytesize, QCstopbits, QCparity, Qodd, Qeven;
Lisp_Object QCflowcontrol, Qhw, Qsw, QCsummary;
static Lisp_Object QCbuffer, QChost, QCservice;
static Lisp_Object QClocal, QCremote, QCcoding;
static Lisp_Object QCserver, QCnowait, QCnoquery, QCstop;
static Lisp_Object QCsentinel, QClog, QCoptions, QCplist;
static Lisp_Object Qlast_nonmenu_event;
static Lisp_Object Qinternal_default_process_sentinel;
static Lisp_Object Qinternal_default_process_filter;

#define NETCONN_P(p) (EQ (XPROCESS (p)->type, Qnetwork))
#define NETCONN1_P(p) (EQ (p->type, Qnetwork))
#define SERIALCONN_P(p) (EQ (XPROCESS (p)->type, Qserial))
#define SERIALCONN1_P(p) (EQ (p->type, Qserial))

/* Number of events of change of status of a process.  */
static EMACS_INT process_tick;
/* Number of events for which the user or sentinel has been notified.  */
static EMACS_INT update_tick;

/* Define NON_BLOCKING_CONNECT if we can support non-blocking connects.  */

/* Only W32 has this, it really means that select can't take write mask.  */
#ifdef BROKEN_NON_BLOCKING_CONNECT
#undef NON_BLOCKING_CONNECT
#define SELECT_CANT_DO_WRITE_MASK
#else
#ifndef NON_BLOCKING_CONNECT
#ifdef HAVE_SELECT
#if defined (HAVE_GETPEERNAME) || defined (GNU_LINUX)
#if defined (EWOULDBLOCK) || defined (EINPROGRESS)
#define NON_BLOCKING_CONNECT
#endif /* EWOULDBLOCK || EINPROGRESS */
#endif /* HAVE_GETPEERNAME || GNU_LINUX */
#endif /* HAVE_SELECT */
#endif /* NON_BLOCKING_CONNECT */
#endif /* BROKEN_NON_BLOCKING_CONNECT */

/* Define DATAGRAM_SOCKETS if datagrams can be used safely on
   this system.  We need to read full packets, so we need a
   "non-destructive" select.  So we require either native select,
   or emulation of select using FIONREAD.  */

#ifndef BROKEN_DATAGRAM_SOCKETS
# if defined HAVE_SELECT || defined USABLE_FIONREAD
#  if defined HAVE_SENDTO && defined HAVE_RECVFROM && defined EMSGSIZE
#   define DATAGRAM_SOCKETS
#  endif
# endif
#endif

#if defined HAVE_LOCAL_SOCKETS && defined DATAGRAM_SOCKETS
# define HAVE_SEQPACKET
#endif

#if !defined (ADAPTIVE_READ_BUFFERING) && !defined (NO_ADAPTIVE_READ_BUFFERING)
#define ADAPTIVE_READ_BUFFERING
#endif

#ifdef ADAPTIVE_READ_BUFFERING
#define READ_OUTPUT_DELAY_INCREMENT (TIMESPEC_RESOLUTION / 100)
#define READ_OUTPUT_DELAY_MAX       (READ_OUTPUT_DELAY_INCREMENT * 5)
#define READ_OUTPUT_DELAY_MAX_MAX   (READ_OUTPUT_DELAY_INCREMENT * 7)

/* Number of processes which have a non-zero read_output_delay,
   and therefore might be delayed for adaptive read buffering.  */

static int process_output_delay_count;

/* True if any process has non-nil read_output_skip.  */

static bool process_output_skip;

#else
#define process_output_delay_count 0
#endif

static void create_process (Lisp_Object, char **, Lisp_Object);
#ifdef USABLE_SIGIO
static bool keyboard_bit_set (fd_set *);
#endif
static void deactivate_process (Lisp_Object);
static void status_notify (struct Lisp_Process *);
static int read_process_output (Lisp_Object, int);
static void handle_child_signal (int);
static void create_pty (Lisp_Object);

/* If we support a window system, turn on the code to poll periodically
   to detect C-g.  It isn't actually used when doing interrupt input.  */
#ifdef HAVE_WINDOW_SYSTEM
#define POLL_FOR_INPUT
#endif

static Lisp_Object get_process (register Lisp_Object name);
static void exec_sentinel (Lisp_Object proc, Lisp_Object reason);

/* Mask of bits indicating the descriptors that we wait for input on.  */

static fd_set input_wait_mask;

/* Mask that excludes keyboard input descriptor(s).  */

static fd_set non_keyboard_wait_mask;

/* Mask that excludes process input descriptor(s).  */

static fd_set non_process_wait_mask;

/* Mask for selecting for write.  */

static fd_set write_mask;

#ifdef NON_BLOCKING_CONNECT
/* Mask of bits indicating the descriptors that we wait for connect to
   complete on.  Once they complete, they are removed from this mask
   and added to the input_wait_mask and non_keyboard_wait_mask.  */

static fd_set connect_wait_mask;

/* Number of bits set in connect_wait_mask.  */
static int num_pending_connects;
#endif	/* NON_BLOCKING_CONNECT */

/* The largest descriptor currently in use for a process object; -1 if none.  */
static int max_process_desc;

/* The largest descriptor currently in use for input; -1 if none.  */
static int max_input_desc;

/* Indexed by descriptor, gives the process (if any) for that descriptor */
static Lisp_Object chan_process[FD_SETSIZE];

/* Alist of elements (NAME . PROCESS) */
static Lisp_Object Vprocess_alist;

/* Buffered-ahead input char from process, indexed by channel.
   -1 means empty (no char is buffered).
   Used on sys V where the only way to tell if there is any
   output from the process is to read at least one char.
   Always -1 on systems that support FIONREAD.  */

static int proc_buffered_char[FD_SETSIZE];

/* Table of `struct coding-system' for each process.  */
static struct coding_system *proc_decode_coding_system[FD_SETSIZE];
static struct coding_system *proc_encode_coding_system[FD_SETSIZE];

#ifdef DATAGRAM_SOCKETS
/* Table of `partner address' for datagram sockets.  */
static struct sockaddr_and_len {
  struct sockaddr *sa;
  int len;
} datagram_address[FD_SETSIZE];
#define DATAGRAM_CHAN_P(chan)	(datagram_address[chan].sa != 0)
#define DATAGRAM_CONN_P(proc)	(PROCESSP (proc) && datagram_address[XPROCESS (proc)->infd].sa != 0)
#else
#define DATAGRAM_CHAN_P(chan)	(0)
#define DATAGRAM_CONN_P(proc)	(0)
#endif

/* FOR_EACH_PROCESS (LIST_VAR, PROC_VAR) followed by a statement is
   a `for' loop which iterates over processes from Vprocess_alist.  */

#define FOR_EACH_PROCESS(list_var, proc_var)			\
  FOR_EACH_ALIST_VALUE (Vprocess_alist, list_var, proc_var)

/* These setters are used only in this file, so they can be private.  */
static void
pset_buffer (struct Lisp_Process *p, Lisp_Object val)
{
  p->buffer = val;
}
static void
pset_command (struct Lisp_Process *p, Lisp_Object val)
{
  p->command = val;
}
static void
pset_decode_coding_system (struct Lisp_Process *p, Lisp_Object val)
{
  p->decode_coding_system = val;
}
static void
pset_decoding_buf (struct Lisp_Process *p, Lisp_Object val)
{
  p->decoding_buf = val;
}
static void
pset_encode_coding_system (struct Lisp_Process *p, Lisp_Object val)
{
  p->encode_coding_system = val;
}
static void
pset_encoding_buf (struct Lisp_Process *p, Lisp_Object val)
{
  p->encoding_buf = val;
}
static void
pset_filter (struct Lisp_Process *p, Lisp_Object val)
{
  p->filter = NILP (val) ? Qinternal_default_process_filter : val;
}
static void
pset_log (struct Lisp_Process *p, Lisp_Object val)
{
  p->log = val;
}
static void
pset_mark (struct Lisp_Process *p, Lisp_Object val)
{
  p->mark = val;
}
static void
pset_name (struct Lisp_Process *p, Lisp_Object val)
{
  p->name = val;
}
static void
pset_plist (struct Lisp_Process *p, Lisp_Object val)
{
  p->plist = val;
}
static void
pset_sentinel (struct Lisp_Process *p, Lisp_Object val)
{
  p->sentinel = NILP (val) ? Qinternal_default_process_sentinel : val;
}
static void
pset_status (struct Lisp_Process *p, Lisp_Object val)
{
  p->status = val;
}
static void
pset_tty_name (struct Lisp_Process *p, Lisp_Object val)
{
  p->tty_name = val;
}
static void
pset_type (struct Lisp_Process *p, Lisp_Object val)
{
  p->type = val;
}
static void
pset_write_queue (struct Lisp_Process *p, Lisp_Object val)
{
  p->write_queue = val;
}



static struct fd_callback_data
{
  fd_callback func;
  void *data;
#define FOR_READ  1
#define FOR_WRITE 2
  int condition; /* mask of the defines above.  */
} fd_callback_info[FD_SETSIZE];


/* Add a file descriptor FD to be monitored for when read is possible.
   When read is possible, call FUNC with argument DATA.  */

void
add_read_fd (int fd, fd_callback func, void *data)
{
  eassert (fd < FD_SETSIZE);
  add_keyboard_wait_descriptor (fd);

  fd_callback_info[fd].func = func;
  fd_callback_info[fd].data = data;
  fd_callback_info[fd].condition |= FOR_READ;
}

/* Stop monitoring file descriptor FD for when read is possible.  */

void
delete_read_fd (int fd)
{
  eassert (fd < FD_SETSIZE);
  delete_keyboard_wait_descriptor (fd);

  fd_callback_info[fd].condition &= ~FOR_READ;
  if (fd_callback_info[fd].condition == 0)
    {
      fd_callback_info[fd].func = 0;
      fd_callback_info[fd].data = 0;
    }
}

/* Add a file descriptor FD to be monitored for when write is possible.
   When write is possible, call FUNC with argument DATA.  */

void
add_write_fd (int fd, fd_callback func, void *data)
{
  eassert (fd < FD_SETSIZE);
  FD_SET (fd, &write_mask);
  if (fd > max_input_desc)
    max_input_desc = fd;

  fd_callback_info[fd].func = func;
  fd_callback_info[fd].data = data;
  fd_callback_info[fd].condition |= FOR_WRITE;
}

/* FD is no longer an input descriptor; update max_input_desc accordingly.  */

static void
delete_input_desc (int fd)
{
  if (fd == max_input_desc)
    {
      do
	fd--;
      while (0 <= fd && ! (FD_ISSET (fd, &input_wait_mask)
			   || FD_ISSET (fd, &write_mask)));

      max_input_desc = fd;
    }
}

/* Stop monitoring file descriptor FD for when write is possible.  */

void
delete_write_fd (int fd)
{
  eassert (fd < FD_SETSIZE);
  FD_CLR (fd, &write_mask);
  fd_callback_info[fd].condition &= ~FOR_WRITE;
  if (fd_callback_info[fd].condition == 0)
    {
      fd_callback_info[fd].func = 0;
      fd_callback_info[fd].data = 0;
      delete_input_desc (fd);
    }
}


/* Compute the Lisp form of the process status, p->status, from
   the numeric status that was returned by `wait'.  */

static Lisp_Object status_convert (int);

static void
update_status (struct Lisp_Process *p)
{
  eassert (p->raw_status_new);
  pset_status (p, status_convert (p->raw_status));
  p->raw_status_new = 0;
}

/*  Convert a process status word in Unix format to
    the list that we use internally.  */

static Lisp_Object
status_convert (int w)
{
  if (WIFSTOPPED (w))
    return Fcons (Qstop, Fcons (make_number (WSTOPSIG (w)), Qnil));
  else if (WIFEXITED (w))
    return Fcons (Qexit, Fcons (make_number (WEXITSTATUS (w)),
				WCOREDUMP (w) ? Qt : Qnil));
  else if (WIFSIGNALED (w))
    return Fcons (Qsignal, Fcons (make_number (WTERMSIG (w)),
				  WCOREDUMP (w) ? Qt : Qnil));
  else
    return Qrun;
}

/* Given a status-list, extract the three pieces of information
   and store them individually through the three pointers.  */

static void
decode_status (Lisp_Object l, Lisp_Object *symbol, int *code, bool *coredump)
{
  Lisp_Object tem;

  if (SYMBOLP (l))
    {
      *symbol = l;
      *code = 0;
      *coredump = 0;
    }
  else
    {
      *symbol = XCAR (l);
      tem = XCDR (l);
      *code = XFASTINT (XCAR (tem));
      tem = XCDR (tem);
      *coredump = !NILP (tem);
    }
}

/* Return a string describing a process status list.  */

static Lisp_Object
status_message (struct Lisp_Process *p)
{
  Lisp_Object status = p->status;
  Lisp_Object symbol;
  int code;
  bool coredump;
  Lisp_Object string, string2;

  decode_status (status, &symbol, &code, &coredump);

  if (EQ (symbol, Qsignal) || EQ (symbol, Qstop))
    {
      char const *signame;
      synchronize_system_messages_locale ();
      signame = strsignal (code);
      if (signame == 0)
	string = build_string ("unknown");
      else
	{
	  int c1, c2;

	  string = build_unibyte_string (signame);
	  if (! NILP (Vlocale_coding_system))
	    string = (code_convert_string_norecord
		      (string, Vlocale_coding_system, 0));
	  c1 = STRING_CHAR (SDATA (string));
	  c2 = downcase (c1);
	  if (c1 != c2)
	    Faset (string, make_number (0), make_number (c2));
	}
      string2 = build_string (coredump ? " (core dumped)\n" : "\n");
      return concat2 (string, string2);
    }
  else if (EQ (symbol, Qexit))
    {
      if (NETCONN1_P (p))
	return build_string (code == 0 ? "deleted\n" : "connection broken by remote peer\n");
      if (code == 0)
	return build_string ("finished\n");
      string = Fnumber_to_string (make_number (code));
      string2 = build_string (coredump ? " (core dumped)\n" : "\n");
      return concat3 (build_string ("exited abnormally with code "),
		      string, string2);
    }
  else if (EQ (symbol, Qfailed))
    {
      string = Fnumber_to_string (make_number (code));
      string2 = build_string ("\n");
      return concat3 (build_string ("failed with code "),
		      string, string2);
    }
  else
    return Fcopy_sequence (Fsymbol_name (symbol));
}

enum { PTY_NAME_SIZE = 24 };

/* Open an available pty, returning a file descriptor.
   Store into PTY_NAME the file name of the terminal corresponding to the pty.
   Return -1 on failure.  */

static int
allocate_pty (char pty_name[PTY_NAME_SIZE])
{
#ifdef HAVE_PTYS
  int fd;

#ifdef PTY_ITERATION
  PTY_ITERATION
#else
  register int c, i;
  for (c = FIRST_PTY_LETTER; c <= 'z'; c++)
    for (i = 0; i < 16; i++)
#endif
      {
#ifdef PTY_NAME_SPRINTF
	PTY_NAME_SPRINTF
#else
	sprintf (pty_name, "/dev/pty%c%x", c, i);
#endif /* no PTY_NAME_SPRINTF */

#ifdef PTY_OPEN
	PTY_OPEN;
#else /* no PTY_OPEN */
	fd = emacs_open (pty_name, O_RDWR | O_NONBLOCK, 0);
#endif /* no PTY_OPEN */

	if (fd >= 0)
	  {
#ifdef PTY_OPEN
	    /* Set FD's close-on-exec flag.  This is needed even if
	       PT_OPEN calls posix_openpt with O_CLOEXEC, since POSIX
	       doesn't require support for that combination.
	       Multithreaded platforms where posix_openpt ignores
	       O_CLOEXEC (or where PTY_OPEN doesn't call posix_openpt)
	       have a race condition between the PTY_OPEN and here.  */
	    fcntl (fd, F_SETFD, FD_CLOEXEC);
#endif
	    /* check to make certain that both sides are available
	       this avoids a nasty yet stupid bug in rlogins */
#ifdef PTY_TTY_NAME_SPRINTF
	    PTY_TTY_NAME_SPRINTF
#else
	    sprintf (pty_name, "/dev/tty%c%x", c, i);
#endif /* no PTY_TTY_NAME_SPRINTF */
	    if (faccessat (AT_FDCWD, pty_name, R_OK | W_OK, AT_EACCESS) != 0)
	      {
		emacs_close (fd);
# ifndef __sgi
		continue;
# else
		return -1;
# endif /* __sgi */
	      }
	    setup_pty (fd);
	    return fd;
	  }
      }
#endif /* HAVE_PTYS */
  return -1;
}

static Lisp_Object
make_process (Lisp_Object name)
{
  register Lisp_Object val, tem, name1;
  register struct Lisp_Process *p;
  char suffix[sizeof "<>" + INT_STRLEN_BOUND (printmax_t)];
  printmax_t i;

  p = allocate_process ();
  /* Initialize Lisp data.  Note that allocate_process initializes all
     Lisp data to nil, so do it only for slots which should not be nil.  */
  pset_status (p, Qrun);
  pset_mark (p, Fmake_marker ());

  /* Initialize non-Lisp data.  Note that allocate_process zeroes out all
     non-Lisp data, so do it only for slots which should not be zero.  */
  p->infd = -1;
  p->outfd = -1;
  for (i = 0; i < PROCESS_OPEN_FDS; i++)
    p->open_fd[i] = -1;

#ifdef HAVE_GNUTLS
  p->gnutls_initstage = GNUTLS_STAGE_EMPTY;
#endif

  /* If name is already in use, modify it until it is unused.  */

  name1 = name;
  for (i = 1; ; i++)
    {
      tem = Fget_process (name1);
      if (NILP (tem)) break;
      name1 = concat2 (name, make_formatted_string (suffix, "<%"pMd">", i));
    }
  name = name1;
  pset_name (p, name);
  pset_sentinel (p, Qinternal_default_process_sentinel);
  pset_filter (p, Qinternal_default_process_filter);
  XSETPROCESS (val, p);
  Vprocess_alist = Fcons (Fcons (name, val), Vprocess_alist);
  return val;
}

static void
remove_process (register Lisp_Object proc)
{
  register Lisp_Object pair;

  pair = Frassq (proc, Vprocess_alist);
  Vprocess_alist = Fdelq (pair, Vprocess_alist);

  deactivate_process (proc);
}


DEFUN ("processp", Fprocessp, Sprocessp, 1, 1, 0,
       doc: /* Return t if OBJECT is a process.  */)
  (Lisp_Object object)
{
  return PROCESSP (object) ? Qt : Qnil;
}

DEFUN ("get-process", Fget_process, Sget_process, 1, 1, 0,
       doc: /* Return the process named NAME, or nil if there is none.  */)
  (register Lisp_Object name)
{
  if (PROCESSP (name))
    return name;
  CHECK_STRING (name);
  return Fcdr (Fassoc (name, Vprocess_alist));
}

/* This is how commands for the user decode process arguments.  It
   accepts a process, a process name, a buffer, a buffer name, or nil.
   Buffers denote the first process in the buffer, and nil denotes the
   current buffer.  */

static Lisp_Object
get_process (register Lisp_Object name)
{
  register Lisp_Object proc, obj;
  if (STRINGP (name))
    {
      obj = Fget_process (name);
      if (NILP (obj))
	obj = Fget_buffer (name);
      if (NILP (obj))
	error ("Process %s does not exist", SDATA (name));
    }
  else if (NILP (name))
    obj = Fcurrent_buffer ();
  else
    obj = name;

  /* Now obj should be either a buffer object or a process object.
   */
  if (BUFFERP (obj))
    {
      proc = Fget_buffer_process (obj);
      if (NILP (proc))
	error ("Buffer %s has no process", SDATA (BVAR (XBUFFER (obj), name)));
    }
  else
    {
      CHECK_PROCESS (obj);
      proc = obj;
    }
  return proc;
}


/* Fdelete_process promises to immediately forget about the process, but in
   reality, Emacs needs to remember those processes until they have been
   treated by the SIGCHLD handler and waitpid has been invoked on them;
   otherwise they might fill up the kernel's process table.

   Some processes created by call-process are also put onto this list.

   Members of this list are (process-ID . filename) pairs.  The
   process-ID is a number; the filename, if a string, is a file that
   needs to be removed after the process exits.  */
static Lisp_Object deleted_pid_list;

void
record_deleted_pid (pid_t pid, Lisp_Object filename)
{
  deleted_pid_list = Fcons (Fcons (make_fixnum_or_float (pid), filename),
			    /* GC treated elements set to nil.  */
			    Fdelq (Qnil, deleted_pid_list));

}

DEFUN ("delete-process", Fdelete_process, Sdelete_process, 1, 1, 0,
       doc: /* Delete PROCESS: kill it and forget about it immediately.
PROCESS may be a process, a buffer, the name of a process or buffer, or
nil, indicating the current buffer's process.  */)
  (register Lisp_Object process)
{
  register struct Lisp_Process *p;

  process = get_process (process);
  p = XPROCESS (process);

  p->raw_status_new = 0;
  if (NETCONN1_P (p) || SERIALCONN1_P (p))
    {
      pset_status (p, list2 (Qexit, make_number (0)));
      p->tick = ++process_tick;
      status_notify (p);
      redisplay_preserve_echo_area (13);
    }
  else
    {
      if (p->alive)
	record_kill_process (p, Qnil);

      if (p->infd >= 0)
	{
	  /* Update P's status, since record_kill_process will make the
	     SIGCHLD handler update deleted_pid_list, not *P.  */
	  Lisp_Object symbol;
	  if (p->raw_status_new)
	    update_status (p);
	  symbol = CONSP (p->status) ? XCAR (p->status) : p->status;
	  if (! (EQ (symbol, Qsignal) || EQ (symbol, Qexit)))
	    pset_status (p, list2 (Qsignal, make_number (SIGKILL)));

	  p->tick = ++process_tick;
	  status_notify (p);
	  redisplay_preserve_echo_area (13);
	}
    }
  remove_process (process);
  return Qnil;
}

DEFUN ("process-status", Fprocess_status, Sprocess_status, 1, 1, 0,
       doc: /* Return the status of PROCESS.
The returned value is one of the following symbols:
run  -- for a process that is running.
stop -- for a process stopped but continuable.
exit -- for a process that has exited.
signal -- for a process that has got a fatal signal.
open -- for a network stream connection that is open.
listen -- for a network stream server that is listening.
closed -- for a network stream connection that is closed.
connect -- when waiting for a non-blocking connection to complete.
failed -- when a non-blocking connection has failed.
nil -- if arg is a process name and no such process exists.
PROCESS may be a process, a buffer, the name of a process, or
nil, indicating the current buffer's process.  */)
  (register Lisp_Object process)
{
  register struct Lisp_Process *p;
  register Lisp_Object status;

  if (STRINGP (process))
    process = Fget_process (process);
  else
    process = get_process (process);

  if (NILP (process))
    return process;

  p = XPROCESS (process);
  if (p->raw_status_new)
    update_status (p);
  status = p->status;
  if (CONSP (status))
    status = XCAR (status);
  if (NETCONN1_P (p) || SERIALCONN1_P (p))
    {
      if (EQ (status, Qexit))
	status = Qclosed;
      else if (EQ (p->command, Qt))
	status = Qstop;
      else if (EQ (status, Qrun))
	status = Qopen;
    }
  return status;
}

DEFUN ("process-exit-status", Fprocess_exit_status, Sprocess_exit_status,
       1, 1, 0,
       doc: /* Return the exit status of PROCESS or the signal number that killed it.
If PROCESS has not yet exited or died, return 0.  */)
  (register Lisp_Object process)
{
  CHECK_PROCESS (process);