X-Git-Url: http://git.hcoop.net/bpt/emacs.git/blobdiff_plain/8c983bf2575825fdaef0caa7b2cd5a9561969629..8d2ff84085aae9ad5701ebf13dc451e649d1d112:/src/process.c diff --git a/src/process.c b/src/process.c index 9fe2c5af94..2f2017dbea 100644 --- a/src/process.c +++ b/src/process.c @@ -1,6 +1,6 @@ /* Asynchronous subprocess control for GNU Emacs. - Copyright (C) 1985, 86, 87, 88, 93, 94, 95, 96, 98, 1999 - Free Software Foundation, Inc. + Copyright (C) 1985, 86, 87, 88, 93, 94, 95, 96, 98, 1999, + 2001, 2002 Free Software Foundation, Inc. This file is part of GNU Emacs. @@ -44,7 +44,7 @@ Boston, MA 02111-1307, USA. */ #include #endif -#ifdef WINDOWSNT +#if defined(WINDOWSNT) || defined(UNIX98_PTYS) #include #include #endif /* not WINDOWSNT */ @@ -57,6 +57,17 @@ Boston, MA 02111-1307, USA. */ #ifdef NEED_NET_ERRNO_H #include #endif /* NEED_NET_ERRNO_H */ + +/* Are local (unix) sockets supported? */ +#if defined (HAVE_SYS_UN_H) && !defined (NO_SOCKETS_IN_FILE_SYSTEM) +#if !defined (AF_LOCAL) && defined (AF_UNIX) +#define AF_LOCAL AF_UNIX +#endif +#ifdef AF_LOCAL +#define HAVE_LOCAL_SOCKETS +#include +#endif +#endif #endif /* HAVE_SOCKETS */ /* TERM is a poor-man's SLIP, used on GNU/Linux. */ @@ -91,6 +102,10 @@ Boston, MA 02111-1307, USA. */ #ifdef IRIS #include /* for "minor" */ #endif /* not IRIS */ + +#ifdef HAVE_SYS_WAIT +#include +#endif #include "systime.h" #include "systty.h" @@ -104,27 +119,42 @@ Boston, MA 02111-1307, USA. */ #include "termhooks.h" #include "termopts.h" #include "commands.h" +#include "keyboard.h" #include "frame.h" #include "blockinput.h" -#include "keyboard.h" #include "dispextern.h" #include "composite.h" #include "atimer.h" -#define max(a, b) ((a) > (b) ? (a) : (b)) - Lisp_Object Qprocessp; -Lisp_Object Qrun, Qstop, Qsignal, Qopen, Qclosed; +Lisp_Object Qrun, Qstop, Qsignal; +Lisp_Object Qopen, Qclosed, Qconnect, Qfailed, Qlisten; +Lisp_Object Qlocal, Qdatagram; +Lisp_Object QCname, QCbuffer, QChost, QCservice, QCtype; +Lisp_Object QClocal, QCremote, QCcoding; +Lisp_Object QCserver, QCnowait, QCnoquery, QCstop; +Lisp_Object QCsentinel, QClog, QCoptions; Lisp_Object Qlast_nonmenu_event; +/* QCfamily is declared and initialized in xfaces.c, + QCfilter in keyboard.c. */ +extern Lisp_Object QCfamily, QCfilter; + /* Qexit is declared and initialized in eval.c. */ +/* QCfamily is defined in xfaces.c. */ +extern Lisp_Object QCfamily; +/* QCfilter is defined in keyboard.c. */ +extern Lisp_Object QCfilter; + /* a process object is a network connection when its childp field is neither Qt nor Qnil but is instead a cons cell (HOSTNAME PORTNUM). */ #ifdef HAVE_SOCKETS #define NETCONN_P(p) (GC_CONSP (XPROCESS (p)->childp)) +#define NETCONN1_P(p) (GC_CONSP ((p)->childp)) #else #define NETCONN_P(p) 0 +#define NETCONN1_P(p) 0 #endif /* HAVE_SOCKETS */ /* Define first descriptor number available for subprocesses. */ @@ -147,7 +177,9 @@ Lisp_Object Qlast_nonmenu_event; extern void set_waiting_for_input P_ ((EMACS_TIME *)); +#ifndef USE_CRT_DLL extern int errno; +#endif #ifdef VMS extern char *sys_errlist[]; #endif @@ -173,6 +205,51 @@ int process_tick; /* Number of events for which the user or sentinel has been notified. */ int update_tick; +/* Define NON_BLOCKING_CONNECT if we can support non-blocking connects. */ + +#ifdef BROKEN_NON_BLOCKING_CONNECT +#undef NON_BLOCKING_CONNECT +#else +#ifndef NON_BLOCKING_CONNECT +#ifdef HAVE_SOCKETS +#ifdef HAVE_SELECT +#if defined (HAVE_GETPEERNAME) || defined (GNU_LINUX) +#if defined (O_NONBLOCK) || defined (O_NDELAY) +#if defined (EWOULDBLOCK) || defined (EINPROGRESS) +#define NON_BLOCKING_CONNECT +#endif /* EWOULDBLOCK || EINPROGRESS */ +#endif /* O_NONBLOCK || O_NDELAY */ +#endif /* HAVE_GETPEERNAME || GNU_LINUX */ +#endif /* HAVE_SELECT */ +#endif /* HAVE_SOCKETS */ +#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. */ + +#ifdef BROKEN_DATAGRAM_SOCKETS +#undef DATAGRAM_SOCKETS +#else +#ifndef DATAGRAM_SOCKETS +#ifdef HAVE_SOCKETS +#if defined (HAVE_SELECT) || defined (FIONREAD) +#if defined (HAVE_SENDTO) && defined (HAVE_RECVFROM) && defined (EMSGSIZE) +#define DATAGRAM_SOCKETS +#endif /* HAVE_SENDTO && HAVE_RECVFROM && EMSGSIZE */ +#endif /* HAVE_SELECT || FIONREAD */ +#endif /* HAVE_SOCKETS */ +#endif /* DATAGRAM_SOCKETS */ +#endif /* BROKEN_DATAGRAM_SOCKETS */ + +#ifdef TERM +#undef NON_BLOCKING_CONNECT +#undef DATAGRAM_SOCKETS +#endif + + #include "sysselect.h" extern int keyboard_bit_set P_ ((SELECT_TYPE *)); @@ -195,6 +272,15 @@ static SELECT_TYPE non_keyboard_wait_mask; static SELECT_TYPE non_process_wait_mask; +/* 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 SELECT_TYPE connect_wait_mask; + +/* Number of bits set in connect_wait_mask. */ +static int num_pending_connects; + /* The largest descriptor currently in use for a process object. */ static int max_process_desc; @@ -223,7 +309,21 @@ int proc_buffered_char[MAXDESC]; static struct coding_system *proc_decode_coding_system[MAXDESC]; static struct coding_system *proc_encode_coding_system[MAXDESC]; +#ifdef DATAGRAM_SOCKETS +/* Table of `partner address' for datagram sockets. */ +struct sockaddr_and_len { + struct sockaddr *sa; + int len; +} datagram_address[MAXDESC]; +#define DATAGRAM_CHAN_P(chan) (datagram_address[chan].sa != 0) +#define DATAGRAM_CONN_P(proc) (PROCESSP (proc) && datagram_address[XINT (XPROCESS (proc)->infd)].sa != 0) +#else +#define DATAGRAM_CHAN_P(chan) (0) +#define DATAGRAM_CONN_P(proc) (0) +#endif + static Lisp_Object get_process (); +static void exec_sentinel (); extern EMACS_TIME timer_check (); extern int timers_run; @@ -234,6 +334,9 @@ static int pty_max_bytes; extern Lisp_Object Vfile_name_coding_system, Vdefault_file_name_coding_system; #ifdef HAVE_PTYS +#ifdef HAVE_PTY_H +#include +#endif /* The file name of the pty opened by allocate_pty. */ static char pty_name[24]; @@ -323,7 +426,7 @@ status_message (status) signame = "unknown"; string = build_string (signame); string2 = build_string (coredump ? " (core dumped)\n" : "\n"); - XSTRING (string)->data[0] = DOWNCASE (XSTRING (string)->data[0]); + SSET (string, 0, DOWNCASE (SREF (string, 0))); return concat2 (string, string2); } else if (EQ (symbol, Qexit)) @@ -332,8 +435,15 @@ status_message (status) return build_string ("finished\n"); string = Fnumber_to_string (make_number (code)); string2 = build_string (coredump ? " (core dumped)\n" : "\n"); - return concat2 (build_string ("exited abnormally with code "), - concat2 (string, string2)); + 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)); @@ -432,17 +542,12 @@ Lisp_Object make_process (name) Lisp_Object name; { - struct Lisp_Vector *vec; register Lisp_Object val, tem, name1; register struct Lisp_Process *p; char suffix[10]; register int i; - vec = allocate_vectorlike ((EMACS_INT) VECSIZE (struct Lisp_Process)); - for (i = 0; i < VECSIZE (struct Lisp_Process); i++) - vec->contents[i] = Qnil; - vec->size = VECSIZE (struct Lisp_Process); - p = (struct Lisp_Process *)vec; + p = allocate_process (); XSETINT (p->infd, -1); XSETINT (p->outfd, -1); @@ -484,28 +589,28 @@ remove_process (proc) } DEFUN ("processp", Fprocessp, Sprocessp, 1, 1, 0, - "Return t if OBJECT is a process.") - (object) + doc: /* Return t if OBJECT is a process. */) + (object) Lisp_Object object; { return PROCESSP (object) ? Qt : Qnil; } DEFUN ("get-process", Fget_process, Sget_process, 1, 1, 0, - "Return the process named NAME, or nil if there is none.") - (name) + doc: /* Return the process named NAME, or nil if there is none. */) + (name) register Lisp_Object name; { if (PROCESSP (name)) return name; - CHECK_STRING (name, 0); + CHECK_STRING (name); return Fcdr (Fassoc (name, Vprocess_alist)); } DEFUN ("get-buffer-process", Fget_buffer_process, Sget_buffer_process, 1, 1, 0, - "Return the (or a) process associated with BUFFER.\n\ -BUFFER may be a buffer or the name of one.") - (buffer) + doc: /* Return the (or a) process associated with BUFFER. +BUFFER may be a buffer or the name of one. */) + (buffer) register Lisp_Object buffer; { register Lisp_Object buf, tail, proc; @@ -539,7 +644,7 @@ get_process (name) if (NILP (obj)) obj = Fget_buffer (name); if (NILP (obj)) - error ("Process %s does not exist", XSTRING (name)->data); + error ("Process %s does not exist", SDATA (name)); } else if (NILP (name)) obj = Fcurrent_buffer (); @@ -552,21 +657,21 @@ get_process (name) { proc = Fget_buffer_process (obj); if (NILP (proc)) - error ("Buffer %s has no process", XSTRING (XBUFFER (obj)->name)->data); + error ("Buffer %s has no process", SDATA (XBUFFER (obj)->name)); } else { - CHECK_PROCESS (obj, 0); + CHECK_PROCESS (obj); proc = obj; } return proc; } DEFUN ("delete-process", Fdelete_process, Sdelete_process, 1, 1, 0, - "Delete PROCESS: kill it and forget about it immediately.\n\ -PROCESS may be a process, a buffer, the name of a process or buffer, or\n\ -nil, indicating the current buffer's process.") - (process) + 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. */) + (process) register Lisp_Object process; { process = get_process (process); @@ -591,18 +696,21 @@ nil, indicating the current buffer's process.") } DEFUN ("process-status", Fprocess_status, Sprocess_status, 1, 1, 0, - "Return the status of PROCESS.\n\ -The returned value is one of the following symbols:\n\ -run -- for a process that is running.\n\ -stop -- for a process stopped but continuable.\n\ -exit -- for a process that has exited.\n\ -signal -- for a process that has got a fatal signal.\n\ -open -- for a network stream connection that is open.\n\ -closed -- for a network stream connection that is closed.\n\ -nil -- if arg is a process name and no such process exists.\n\ -PROCESS may be a process, a buffer, the name of a process, or\n\ -nil, indicating the current buffer's process.") - (process) + 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. */) + (process) register Lisp_Object process; { register struct Lisp_Process *p; @@ -622,24 +730,26 @@ nil, indicating the current buffer's process.") status = p->status; if (CONSP (status)) status = XCAR (status); - if (NETCONN_P (process)) + if (NETCONN1_P (p)) { - if (EQ (status, Qrun)) - status = Qopen; - else if (EQ (status, Qexit)) + 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, - "Return the exit status of PROCESS or the signal number that killed it.\n\ -If PROCESS has not yet exited or died, return 0.") - (process) + doc: /* Return the exit status of PROCESS or the signal number that killed it. +If PROCESS has not yet exited or died, return 0. */) + (process) register Lisp_Object process; { - CHECK_PROCESS (process, 0); + CHECK_PROCESS (process); if (!NILP (XPROCESS (process)->raw_status_low)) update_status (XPROCESS (process)); if (CONSP (XPROCESS (process)->status)) @@ -648,248 +758,397 @@ If PROCESS has not yet exited or died, return 0.") } DEFUN ("process-id", Fprocess_id, Sprocess_id, 1, 1, 0, - "Return the process id of PROCESS.\n\ -This is the pid of the Unix process which PROCESS uses or talks to.\n\ -For a network connection, this value is nil.") - (process) + doc: /* Return the process id of PROCESS. +This is the pid of the Unix process which PROCESS uses or talks to. +For a network connection, this value is nil. */) + (process) register Lisp_Object process; { - CHECK_PROCESS (process, 0); + CHECK_PROCESS (process); return XPROCESS (process)->pid; } DEFUN ("process-name", Fprocess_name, Sprocess_name, 1, 1, 0, - "Return the name of PROCESS, as a string.\n\ -This is the name of the program invoked in PROCESS,\n\ -possibly modified to make it unique among process names.") - (process) + doc: /* Return the name of PROCESS, as a string. +This is the name of the program invoked in PROCESS, +possibly modified to make it unique among process names. */) + (process) register Lisp_Object process; { - CHECK_PROCESS (process, 0); + CHECK_PROCESS (process); return XPROCESS (process)->name; } DEFUN ("process-command", Fprocess_command, Sprocess_command, 1, 1, 0, - "Return the command that was executed to start PROCESS.\n\ -This is a list of strings, the first string being the program executed\n\ -and the rest of the strings being the arguments given to it.\n\ -For a non-child channel, this is nil.") - (process) + doc: /* Return the command that was executed to start PROCESS. +This is a list of strings, the first string being the program executed +and the rest of the strings being the arguments given to it. +For a non-child channel, this is nil. */) + (process) register Lisp_Object process; { - CHECK_PROCESS (process, 0); + CHECK_PROCESS (process); return XPROCESS (process)->command; } DEFUN ("process-tty-name", Fprocess_tty_name, Sprocess_tty_name, 1, 1, 0, - "Return the name of the terminal PROCESS uses, or nil if none.\n\ -This is the terminal that the process itself reads and writes on,\n\ -not the name of the pty that Emacs uses to talk with that terminal.") - (process) + doc: /* Return the name of the terminal PROCESS uses, or nil if none. +This is the terminal that the process itself reads and writes on, +not the name of the pty that Emacs uses to talk with that terminal. */) + (process) register Lisp_Object process; { - CHECK_PROCESS (process, 0); + CHECK_PROCESS (process); return XPROCESS (process)->tty_name; } DEFUN ("set-process-buffer", Fset_process_buffer, Sset_process_buffer, - 2, 2, 0, - "Set buffer associated with PROCESS to BUFFER (a buffer, or nil).") - (process, buffer) + 2, 2, 0, + doc: /* Set buffer associated with PROCESS to BUFFER (a buffer, or nil). */) + (process, buffer) register Lisp_Object process, buffer; { - CHECK_PROCESS (process, 0); + struct Lisp_Process *p; + + CHECK_PROCESS (process); if (!NILP (buffer)) - CHECK_BUFFER (buffer, 1); - XPROCESS (process)->buffer = buffer; + CHECK_BUFFER (buffer); + p = XPROCESS (process); + p->buffer = buffer; + if (NETCONN1_P (p)) + p->childp = Fplist_put (p->childp, QCbuffer, buffer); return buffer; } DEFUN ("process-buffer", Fprocess_buffer, Sprocess_buffer, - 1, 1, 0, - "Return the buffer PROCESS is associated with.\n\ -Output from PROCESS is inserted in this buffer unless PROCESS has a filter.") - (process) + 1, 1, 0, + doc: /* Return the buffer PROCESS is associated with. +Output from PROCESS is inserted in this buffer unless PROCESS has a filter. */) + (process) register Lisp_Object process; { - CHECK_PROCESS (process, 0); + CHECK_PROCESS (process); return XPROCESS (process)->buffer; } DEFUN ("process-mark", Fprocess_mark, Sprocess_mark, - 1, 1, 0, - "Return the marker for the end of the last output from PROCESS.") - (process) + 1, 1, 0, + doc: /* Return the marker for the end of the last output from PROCESS. */) + (process) register Lisp_Object process; { - CHECK_PROCESS (process, 0); + CHECK_PROCESS (process); return XPROCESS (process)->mark; } DEFUN ("set-process-filter", Fset_process_filter, Sset_process_filter, - 2, 2, 0, - "Give PROCESS the filter function FILTER; nil means no filter.\n\ -t means stop accepting output from the process.\n\ -When a process has a filter, each time it does output\n\ -the entire string of output is passed to the filter.\n\ -The filter gets two arguments: the process and the string of output.\n\ -If the process has a filter, its buffer is not used for output.") - (process, filter) + 2, 2, 0, + doc: /* Give PROCESS the filter function FILTER; nil means no filter. +t means stop accepting output from the process. +When a process has a filter, each time it does output +the entire string of output is passed to the filter. +The filter gets two arguments: the process and the string of output. +If the process has a filter, its buffer is not used for output. */) + (process, filter) register Lisp_Object process, filter; { - CHECK_PROCESS (process, 0); - if (EQ (filter, Qt)) - { - FD_CLR (XINT (XPROCESS (process)->infd), &input_wait_mask); - FD_CLR (XINT (XPROCESS (process)->infd), &non_keyboard_wait_mask); - } - else if (EQ (XPROCESS (process)->filter, Qt)) + struct Lisp_Process *p; + + CHECK_PROCESS (process); + p = XPROCESS (process); + + /* Don't signal an error if the process' input file descriptor + is closed. This could make debugging Lisp more difficult, + for example when doing something like + + (setq process (start-process ...)) + (debug) + (set-process-filter process ...) */ + + if (XINT (p->infd) >= 0) { - FD_SET (XINT (XPROCESS (process)->infd), &input_wait_mask); - FD_SET (XINT (XPROCESS (process)->infd), &non_keyboard_wait_mask); + if (EQ (filter, Qt) && !EQ (p->status, Qlisten)) + { + FD_CLR (XINT (p->infd), &input_wait_mask); + FD_CLR (XINT (p->infd), &non_keyboard_wait_mask); + } + else if (EQ (p->filter, Qt) + && !EQ (p->command, Qt)) /* Network process not stopped. */ + { + FD_SET (XINT (p->infd), &input_wait_mask); + FD_SET (XINT (p->infd), &non_keyboard_wait_mask); + } } - XPROCESS (process)->filter = filter; + + p->filter = filter; + if (NETCONN1_P (p)) + p->childp = Fplist_put (p->childp, QCfilter, filter); return filter; } DEFUN ("process-filter", Fprocess_filter, Sprocess_filter, - 1, 1, 0, - "Returns the filter function of PROCESS; nil if none.\n\ -See `set-process-filter' for more info on filter functions.") - (process) + 1, 1, 0, + doc: /* Returns the filter function of PROCESS; nil if none. +See `set-process-filter' for more info on filter functions. */) + (process) register Lisp_Object process; { - CHECK_PROCESS (process, 0); + CHECK_PROCESS (process); return XPROCESS (process)->filter; } DEFUN ("set-process-sentinel", Fset_process_sentinel, Sset_process_sentinel, - 2, 2, 0, - "Give PROCESS the sentinel SENTINEL; nil for none.\n\ -The sentinel is called as a function when the process changes state.\n\ -It gets two arguments: the process, and a string describing the change.") - (process, sentinel) + 2, 2, 0, + doc: /* Give PROCESS the sentinel SENTINEL; nil for none. +The sentinel is called as a function when the process changes state. +It gets two arguments: the process, and a string describing the change. */) + (process, sentinel) register Lisp_Object process, sentinel; { - CHECK_PROCESS (process, 0); + CHECK_PROCESS (process); XPROCESS (process)->sentinel = sentinel; return sentinel; } DEFUN ("process-sentinel", Fprocess_sentinel, Sprocess_sentinel, - 1, 1, 0, - "Return the sentinel of PROCESS; nil if none.\n\ -See `set-process-sentinel' for more info on sentinels.") - (process) + 1, 1, 0, + doc: /* Return the sentinel of PROCESS; nil if none. +See `set-process-sentinel' for more info on sentinels. */) + (process) register Lisp_Object process; { - CHECK_PROCESS (process, 0); + CHECK_PROCESS (process); return XPROCESS (process)->sentinel; } DEFUN ("set-process-window-size", Fset_process_window_size, - Sset_process_window_size, 3, 3, 0, - "Tell PROCESS that it has logical window size HEIGHT and WIDTH.") - (process, height, width) + Sset_process_window_size, 3, 3, 0, + doc: /* Tell PROCESS that it has logical window size HEIGHT and WIDTH. */) + (process, height, width) register Lisp_Object process, height, width; { - CHECK_PROCESS (process, 0); - CHECK_NATNUM (height, 0); - CHECK_NATNUM (width, 0); - if (set_window_size (XINT (XPROCESS (process)->infd), - XINT (height), XINT (width)) <= 0) + CHECK_PROCESS (process); + CHECK_NATNUM (height); + CHECK_NATNUM (width); + + if (XINT (XPROCESS (process)->infd) < 0 + || set_window_size (XINT (XPROCESS (process)->infd), + XINT (height), XINT (width)) <= 0) return Qnil; else return Qt; } DEFUN ("set-process-inherit-coding-system-flag", - Fset_process_inherit_coding_system_flag, - Sset_process_inherit_coding_system_flag, 2, 2, 0, - "Determine whether buffer of PROCESS will inherit coding-system.\n\ -If the second argument FLAG is non-nil, then the variable\n\ -`buffer-file-coding-system' of the buffer associated with PROCESS\n\ -will be bound to the value of the coding system used to decode\n\ -the process output.\n\ -\n\ -This is useful when the coding system specified for the process buffer\n\ -leaves either the character code conversion or the end-of-line conversion\n\ -unspecified, or if the coding system used to decode the process output\n\ -is more appropriate for saving the process buffer.\n\ -\n\ -Binding the variable `inherit-process-coding-system' to non-nil before\n\ -starting the process is an alternative way of setting the inherit flag\n\ -for the process which will run.") - (process, flag) + Fset_process_inherit_coding_system_flag, + Sset_process_inherit_coding_system_flag, 2, 2, 0, + doc: /* Determine whether buffer of PROCESS will inherit coding-system. +If the second argument FLAG is non-nil, then the variable +`buffer-file-coding-system' of the buffer associated with PROCESS +will be bound to the value of the coding system used to decode +the process output. + +This is useful when the coding system specified for the process buffer +leaves either the character code conversion or the end-of-line conversion +unspecified, or if the coding system used to decode the process output +is more appropriate for saving the process buffer. + +Binding the variable `inherit-process-coding-system' to non-nil before +starting the process is an alternative way of setting the inherit flag +for the process which will run. */) + (process, flag) register Lisp_Object process, flag; { - CHECK_PROCESS (process, 0); + CHECK_PROCESS (process); XPROCESS (process)->inherit_coding_system_flag = flag; return flag; } DEFUN ("process-inherit-coding-system-flag", - Fprocess_inherit_coding_system_flag, Sprocess_inherit_coding_system_flag, - 1, 1, 0, - "Return the value of inherit-coding-system flag for PROCESS.\n\ -If this flag is t, `buffer-file-coding-system' of the buffer\n\ -associated with PROCESS will inherit the coding system used to decode\n\ -the process output.") - (process) + Fprocess_inherit_coding_system_flag, Sprocess_inherit_coding_system_flag, + 1, 1, 0, + doc: /* Return the value of inherit-coding-system flag for PROCESS. +If this flag is t, `buffer-file-coding-system' of the buffer +associated with PROCESS will inherit the coding system used to decode +the process output. */) + (process) register Lisp_Object process; { - CHECK_PROCESS (process, 0); + CHECK_PROCESS (process); return XPROCESS (process)->inherit_coding_system_flag; } -DEFUN ("process-kill-without-query", Fprocess_kill_without_query, - Sprocess_kill_without_query, 1, 2, 0, - "Say no query needed if PROCESS is running when Emacs is exited.\n\ -Optional second argument if non-nil says to require a query.\n\ -Value is t if a query was formerly required.") - (process, value) - register Lisp_Object process, value; +DEFUN ("set-process-query-on-exit-flag", + Fset_process_query_on_exit_flag, Sset_process_query_on_exit_flag, + 2, 2, 0, + doc: /* Specify if query is needed for PROCESS when Emacs is exited. +If the second argument FLAG is non-nil, emacs will query the user before +exiting if PROCESS is running. */) + (process, flag) + register Lisp_Object process, flag; { - Lisp_Object tem; - - CHECK_PROCESS (process, 0); - tem = XPROCESS (process)->kill_without_query; - XPROCESS (process)->kill_without_query = Fnull (value); + CHECK_PROCESS (process); + XPROCESS (process)->kill_without_query = Fnull (flag); + return flag; +} - return Fnull (tem); +DEFUN ("process-query-on-exit-flag", + Fprocess_query_on_exit_flag, Sprocess_query_on_exit_flag, + 1, 1, 0, + doc: /* Return the current value of query on exit flag for PROCESS. */) + (process) + register Lisp_Object process; +{ + CHECK_PROCESS (process); + return Fnull (XPROCESS (process)->kill_without_query); } +#ifdef DATAGRAM_SOCKETS +Lisp_Object Fprocess_datagram_address (); +#endif + DEFUN ("process-contact", Fprocess_contact, Sprocess_contact, - 1, 1, 0, - "Return the contact info of PROCESS; t for a real child.\n\ -For a net connection, the value is a cons cell of the form (HOST SERVICE).") - (process) - register Lisp_Object process; + 1, 2, 0, + doc: /* Return the contact info of PROCESS; t for a real child. +For a net connection, the value depends on the optional KEY arg. +If KEY is nil, value is a cons cell of the form (HOST SERVICE), +if KEY is t, the complete contact information for the connection is +returned, else the specific value for the keyword KEY is returned. +See `make-network-process' for a list of keywords. */) + (process, key) + register Lisp_Object process, key; { - CHECK_PROCESS (process, 0); - return XPROCESS (process)->childp; + Lisp_Object contact; + + CHECK_PROCESS (process); + contact = XPROCESS (process)->childp; + +#ifdef DATAGRAM_SOCKETS + if (DATAGRAM_CONN_P (process) + && (EQ (key, Qt) || EQ (key, QCremote))) + contact = Fplist_put (contact, QCremote, + Fprocess_datagram_address (process)); +#endif + + if (!NETCONN_P (process) || EQ (key, Qt)) + return contact; + if (NILP (key)) + return Fcons (Fplist_get (contact, QChost), + Fcons (Fplist_get (contact, QCservice), Qnil)); + return Fplist_get (contact, key); } #if 0 /* Turned off because we don't currently record this info in the process. Perhaps add it. */ DEFUN ("process-connection", Fprocess_connection, Sprocess_connection, 1, 1, 0, - "Return the connection type of PROCESS.\n\ -The value is nil for a pipe, t or `pty' for a pty, or `stream' for\n\ -a socket connection.") - (process) + doc: /* Return the connection type of PROCESS. +The value is nil for a pipe, t or `pty' for a pty, or `stream' for +a socket connection. */) + (process) Lisp_Object process; { return XPROCESS (process)->type; } #endif + +#ifdef HAVE_SOCKETS +DEFUN ("format-network-address", Fformat_network_address, Sformat_network_address, + 1, 1, 0, + doc: /* Convert network ADDRESS from internal format to a string. +Returns nil if format of ADDRESS is invalid. */) + (address) + Lisp_Object address; +{ + register struct Lisp_Vector *p; + register unsigned char *cp; + register int i; + + if (NILP (address)) + return Qnil; + + if (STRINGP (address)) /* AF_LOCAL */ + return address; + + if (VECTORP (address)) /* AF_INET */ + { + register struct Lisp_Vector *p = XVECTOR (address); + Lisp_Object args[6]; + + if (p->size != 5) + return Qnil; + + args[0] = build_string ("%d.%d.%d.%d:%d"); + args[1] = p->contents[0]; + args[2] = p->contents[1]; + args[3] = p->contents[2]; + args[4] = p->contents[3]; + args[5] = p->contents[4]; + return Fformat (6, args); + } + + if (CONSP (address)) + { + Lisp_Object args[2]; + args[0] = build_string (""); + args[1] = Fcar (address); + return Fformat (2, args); + + } + + return Qnil; +} +#endif Lisp_Object -list_processes_1 () +list_processes_1 (query_only) + Lisp_Object query_only; { register Lisp_Object tail, tem; Lisp_Object proc, minspace, tem1; register struct Lisp_Process *p; - char tembuf[80]; + char tembuf[300]; + int w_proc, w_buffer, w_tty; + Lisp_Object i_status, i_buffer, i_tty, i_command; + + w_proc = 4; /* Proc */ + w_buffer = 6; /* Buffer */ + w_tty = 0; /* Omit if no ttys */ + + for (tail = Vprocess_alist; !NILP (tail); tail = Fcdr (tail)) + { + int i; + + proc = Fcdr (Fcar (tail)); + p = XPROCESS (proc); + if (NILP (p->childp)) + continue; + if (!NILP (query_only) && !NILP (p->kill_without_query)) + continue; + if (STRINGP (p->name) + && ( i = SCHARS (p->name), (i > w_proc))) + w_proc = i; + if (!NILP (p->buffer)) + { + if (NILP (XBUFFER (p->buffer)->name) && w_buffer < 8) + w_buffer = 8; /* (Killed) */ + else if ((i = SCHARS (XBUFFER (p->buffer)->name), (i > w_buffer))) + w_buffer = i; + } + if (STRINGP (p->tty_name) + && (i = SCHARS (p->tty_name), (i > w_tty))) + w_tty = i; + } + + XSETFASTINT (i_status, w_proc + 1); + XSETFASTINT (i_buffer, XFASTINT (i_status) + 9); + if (w_tty) + { + XSETFASTINT (i_tty, XFASTINT (i_buffer) + w_buffer + 1); + XSETFASTINT (i_command, XFASTINT (i_buffer) + w_tty + 1); + } else { + i_tty = Qnil; + XSETFASTINT (i_command, XFASTINT (i_buffer) + w_buffer + 1); + } XSETFASTINT (minspace, 1); @@ -898,9 +1157,25 @@ list_processes_1 () current_buffer->truncate_lines = Qt; - write_string ("\ -Proc Status Buffer Tty Command\n\ ----- ------ ------ --- -------\n", -1); + write_string ("Proc", -1); + Findent_to (i_status, minspace); write_string ("Status", -1); + Findent_to (i_buffer, minspace); write_string ("Buffer", -1); + if (!NILP (i_tty)) + { + Findent_to (i_tty, minspace); write_string ("Tty", -1); + } + Findent_to (i_command, minspace); write_string ("Command", -1); + write_string ("\n", -1); + + write_string ("----", -1); + Findent_to (i_status, minspace); write_string ("------", -1); + Findent_to (i_buffer, minspace); write_string ("------", -1); + if (!NILP (i_tty)) + { + Findent_to (i_tty, minspace); write_string ("---", -1); + } + Findent_to (i_command, minspace); write_string ("-------", -1); + write_string ("\n", -1); for (tail = Vprocess_alist; !NILP (tail); tail = Fcdr (tail)) { @@ -910,9 +1185,11 @@ Proc Status Buffer Tty Command\n\ p = XPROCESS (proc); if (NILP (p->childp)) continue; + if (!NILP (query_only) && !NILP (p->kill_without_query)) + continue; Finsert (1, &p->name); - Findent_to (make_number (13), minspace); + Findent_to (i_status, minspace); if (!NILP (p->raw_status_low)) update_status (p); @@ -932,12 +1209,14 @@ Proc Status Buffer Tty Command\n\ #endif Fprinc (symbol, Qnil); } - else if (NETCONN_P (proc)) + else if (NETCONN1_P (p)) { - if (EQ (symbol, Qrun)) - write_string ("open", -1); - else if (EQ (symbol, Qexit)) + if (EQ (symbol, Qexit)) write_string ("closed", -1); + else if (EQ (p->command, Qt)) + write_string ("stopped", -1); + else if (EQ (symbol, Qrun)) + write_string ("open", -1); else Fprinc (symbol, Qnil); } @@ -958,7 +1237,7 @@ Proc Status Buffer Tty Command\n\ if (EQ (symbol, Qsignal) || EQ (symbol, Qexit)) remove_process (proc); - Findent_to (make_number (22), minspace); + Findent_to (i_buffer, minspace); if (NILP (p->buffer)) insert_string ("(none)"); else if (NILP (XBUFFER (p->buffer)->name)) @@ -966,19 +1245,43 @@ Proc Status Buffer Tty Command\n\ else Finsert (1, &XBUFFER (p->buffer)->name); - Findent_to (make_number (37), minspace); - - if (STRINGP (p->tty_name)) - Finsert (1, &p->tty_name); - else - insert_string ("(none)"); + if (!NILP (i_tty)) + { + Findent_to (i_tty, minspace); + if (STRINGP (p->tty_name)) + Finsert (1, &p->tty_name); + } - Findent_to (make_number (49), minspace); + Findent_to (i_command, minspace); - if (NETCONN_P (proc)) + if (EQ (p->status, Qlisten)) + { + Lisp_Object port = Fplist_get (p->childp, QCservice); + if (INTEGERP (port)) + port = Fnumber_to_string (port); + if (NILP (port)) + port = Fformat_network_address (Fplist_get (p->childp, QClocal)); + sprintf (tembuf, "(network %s server on %s)\n", + (DATAGRAM_CHAN_P (XINT (p->infd)) ? "datagram" : "stream"), + (STRINGP (port) ? (char *)SDATA (port) : "?")); + insert_string (tembuf); + } + else if (NETCONN1_P (p)) { - sprintf (tembuf, "(network stream connection to %s)\n", - XSTRING (XCAR (p->childp))->data); + /* For a local socket, there is no host name, + so display service instead. */ + Lisp_Object host = Fplist_get (p->childp, QChost); + if (!STRINGP (host)) + { + host = Fplist_get (p->childp, QCservice); + if (INTEGERP (host)) + host = Fnumber_to_string (host); + } + if (NILP (host)) + host = Fformat_network_address (Fplist_get (p->childp, QCremote)); + sprintf (tembuf, "(network %s connection to %s)\n", + (DATAGRAM_CHAN_P (XINT (p->infd)) ? "datagram" : "stream"), + (STRINGP (host) ? (char *)SDATA (host) : "?")); insert_string (tembuf); } else @@ -999,20 +1302,23 @@ Proc Status Buffer Tty Command\n\ return Qnil; } -DEFUN ("list-processes", Flist_processes, Slist_processes, 0, 0, "", - "Display a list of all processes.\n\ -Any process listed as exited or signaled is actually eliminated\n\ -after the listing is made.") - () +DEFUN ("list-processes", Flist_processes, Slist_processes, 0, 1, "P", + doc: /* Display a list of all processes. +If optional argument QUERY-ONLY is non-nil, only processes with +the query-on-exit flag set will be listed. +Any process listed as exited or signaled is actually eliminated +after the listing is made. */) + (query_only) + Lisp_Object query_only; { internal_with_output_to_temp_buffer ("*Process List*", - list_processes_1, Qnil); + list_processes_1, query_only); return Qnil; } DEFUN ("process-list", Fprocess_list, Sprocess_list, 0, 0, 0, - "Return a list of all processes.") - () + doc: /* Return a list of all processes. */) + () { return Fmapcar (Qcdr, Vprocess_alist); } @@ -1022,16 +1328,18 @@ DEFUN ("process-list", Fprocess_list, Sprocess_list, 0, 0, 0, static Lisp_Object start_process_unwind (); DEFUN ("start-process", Fstart_process, Sstart_process, 3, MANY, 0, - "Start a program in a subprocess. Return the process object for it.\n\ -NAME is name for process. It is modified if necessary to make it unique.\n\ -BUFFER is the buffer or (buffer-name) to associate with the process.\n\ - Process output goes at end of that buffer, unless you specify\n\ - an output stream or filter function to handle the output.\n\ - BUFFER may be also nil, meaning that this process is not associated\n\ - with any buffer.\n\ -Third arg is program file name. It is searched for in PATH.\n\ -Remaining arguments are strings to give program as arguments.") - (nargs, args) + doc: /* Start a program in a subprocess. Return the process object for it. +NAME is name for process. It is modified if necessary to make it unique. +BUFFER is the buffer or (buffer-name) to associate with the process. + Process output goes at end of that buffer, unless you specify + an output stream or filter function to handle the output. + BUFFER may be also nil, meaning that this process is not associated + with any buffer. +Third arg is program file name. It is searched for in PATH. +Remaining arguments are strings to give program as arguments. + +usage: (start-process NAME BUFFER PROGRAM &rest PROGRAM-ARGS) */) + (nargs, args) int nargs; register Lisp_Object *args; { @@ -1043,7 +1351,7 @@ Remaining arguments are strings to give program as arguments.") register unsigned char **new_argv; #endif register int i; - int count = specpdl_ptr - specpdl; + int count = SPECPDL_INDEX (); buffer = args[1]; if (!NILP (buffer)) @@ -1076,68 +1384,11 @@ Remaining arguments are strings to give program as arguments.") } name = args[0]; - CHECK_STRING (name, 0); + CHECK_STRING (name); program = args[2]; - CHECK_STRING (program, 2); - -#ifdef VMS - /* Make a one member argv with all args concatenated - together separated by a blank. */ - len = STRING_BYTES (XSTRING (program)) + 2; - for (i = 3; i < nargs; i++) - { - tem = args[i]; - CHECK_STRING (tem, i); - len += STRING_BYTES (XSTRING (tem)) + 1; /* count the blank */ - } - new_argv = (unsigned char *) alloca (len); - strcpy (new_argv, XSTRING (program)->data); - for (i = 3; i < nargs; i++) - { - tem = args[i]; - CHECK_STRING (tem, i); - strcat (new_argv, " "); - strcat (new_argv, XSTRING (tem)->data); - } - /* Need to add code here to check for program existence on VMS */ - -#else /* not VMS */ - new_argv = (unsigned char **) alloca ((nargs - 1) * sizeof (char *)); - - /* If program file name is not absolute, search our path for it */ - if (!IS_DIRECTORY_SEP (XSTRING (program)->data[0]) - && !(XSTRING (program)->size > 1 - && IS_DEVICE_SEP (XSTRING (program)->data[1]))) - { - struct gcpro gcpro1, gcpro2, gcpro3, gcpro4; - - tem = Qnil; - GCPRO4 (name, program, buffer, current_dir); - openp (Vexec_path, program, EXEC_SUFFIXES, &tem, 1); - UNGCPRO; - if (NILP (tem)) - report_file_error ("Searching for program", Fcons (program, Qnil)); - tem = Fexpand_file_name (tem, Qnil); - new_argv[0] = XSTRING (tem)->data; - } - else - { - if (!NILP (Ffile_directory_p (program))) - error ("Specified program for new process is a directory"); - - new_argv[0] = XSTRING (program)->data; - } - - for (i = 3; i < nargs; i++) - { - tem = args[i]; - CHECK_STRING (tem, i); - new_argv[i - 2] = XSTRING (tem)->data; - } - new_argv[i - 2] = 0; -#endif /* not VMS */ + CHECK_STRING (program); proc = make_process (name); /* If an error occurs and we can't start the process, we want to @@ -1167,7 +1418,7 @@ Remaining arguments are strings to give program as arguments.") /* Qt denotes we have not yet called Ffind_operation_coding_system. */ Lisp_Object coding_systems = Qt; Lisp_Object val, *args2; - struct gcpro gcpro1; + struct gcpro gcpro1, gcpro2; val = Vcoding_system_for_read; if (NILP (val)) @@ -1175,7 +1426,7 @@ Remaining arguments are strings to give program as arguments.") args2 = (Lisp_Object *) alloca ((nargs + 1) * sizeof *args2); args2[0] = Qstart_process; for (i = 0; i < nargs; i++) args2[i + 1] = args[i]; - GCPRO1 (proc); + GCPRO2 (proc, current_dir); coding_systems = Ffind_operation_coding_system (nargs + 1, args2); UNGCPRO; if (CONSP (coding_systems)) @@ -1193,7 +1444,7 @@ Remaining arguments are strings to give program as arguments.") args2 = (Lisp_Object *) alloca ((nargs + 1) * sizeof args2); args2[0] = Qstart_process; for (i = 0; i < nargs; i++) args2[i + 1] = args[i]; - GCPRO1 (proc); + GCPRO2 (proc, current_dir); coding_systems = Ffind_operation_coding_system (nargs + 1, args2); UNGCPRO; } @@ -1205,6 +1456,81 @@ Remaining arguments are strings to give program as arguments.") XPROCESS (proc)->encode_coding_system = val; } +#ifdef VMS + /* Make a one member argv with all args concatenated + together separated by a blank. */ + len = SBYTES (program) + 2; + for (i = 3; i < nargs; i++) + { + tem = args[i]; + CHECK_STRING (tem); + len += SBYTES (tem) + 1; /* count the blank */ + } + new_argv = (unsigned char *) alloca (len); + strcpy (new_argv, SDATA (program)); + for (i = 3; i < nargs; i++) + { + tem = args[i]; + CHECK_STRING (tem); + strcat (new_argv, " "); + strcat (new_argv, SDATA (tem)); + } + /* Need to add code here to check for program existence on VMS */ + +#else /* not VMS */ + new_argv = (unsigned char **) alloca ((nargs - 1) * sizeof (char *)); + + /* If program file name is not absolute, search our path for it. + Put the name we will really use in TEM. */ + if (!IS_DIRECTORY_SEP (SREF (program, 0)) + && !(SCHARS (program) > 1 + && IS_DEVICE_SEP (SREF (program, 1)))) + { + struct gcpro gcpro1, gcpro2, gcpro3, gcpro4; + + tem = Qnil; + GCPRO4 (name, program, buffer, current_dir); + openp (Vexec_path, program, Vexec_suffixes, &tem, make_number (X_OK)); + UNGCPRO; + if (NILP (tem)) + report_file_error ("Searching for program", Fcons (program, Qnil)); + tem = Fexpand_file_name (tem, Qnil); + } + else + { + if (!NILP (Ffile_directory_p (program))) + error ("Specified program for new process is a directory"); + tem = program; + } + + /* If program file name starts with /: for quoting a magic name, + discard that. */ + if (SBYTES (tem) > 2 && SREF (tem, 0) == '/' + && SREF (tem, 1) == ':') + tem = Fsubstring (tem, make_number (2), Qnil); + + /* Encode the file name and put it in NEW_ARGV. + That's where the child will use it to execute the program. */ + tem = ENCODE_FILE (tem); + new_argv[0] = SDATA (tem); + + /* Here we encode arguments by the coding system used for sending + data to the process. We don't support using different coding + systems for encoding arguments and for encoding data sent to the + process. */ + + for (i = 3; i < nargs; i++) + { + tem = args[i]; + CHECK_STRING (tem); + if (STRING_MULTIBYTE (tem)) + tem = (code_convert_string_norecord + (tem, XPROCESS (proc)->encode_coding_system, 1)); + new_argv[i - 2] = SDATA (tem); + } + new_argv[i - 2] = 0; +#endif /* not VMS */ + XPROCESS (proc)->decoding_buf = make_uninit_string (0); XPROCESS (proc)->decoding_carryover = make_number (0); XPROCESS (proc)->encoding_buf = make_uninit_string (0); @@ -1291,8 +1617,9 @@ create_process (process, new_argv, current_dir) /* Use volatile to protect variables from being clobbered by longjmp. */ volatile int forkin, forkout; volatile int pty_flag = 0; +#ifndef USE_CRT_DLL extern char **environ; - Lisp_Object buffer = XPROCESS (process)->buffer; +#endif inchannel = outchannel = -1; @@ -1302,9 +1629,9 @@ create_process (process, new_argv, current_dir) if (inchannel >= 0) { -#ifndef USG - /* On USG systems it does not work to open the pty's tty here - and then close and reopen it in the child. */ +#if ! defined (USG) || defined (USG_SUBTTY_WORKS) + /* On most USG systems it does not work to open the pty's tty here, + then close it and reopen it in the child. */ #ifdef O_NOCTTY /* Don't let this terminal become our controlling terminal (in case we don't have one). */ @@ -1316,7 +1643,7 @@ create_process (process, new_argv, current_dir) report_file_error ("Opening pty", Qnil); #else forkin = forkout = -1; -#endif /* not USG */ +#endif /* not USG, or USG_SUBTTY_WORKS */ pty_flag = 1; } else @@ -1396,46 +1723,6 @@ create_process (process, new_argv, current_dir) setup_coding_system (XPROCESS (process)->encode_coding_system, proc_encode_coding_system[outchannel]); - if ((!NILP (buffer) && NILP (XBUFFER (buffer)->enable_multibyte_characters)) - || (NILP (buffer) && NILP (buffer_defaults.enable_multibyte_characters))) - { - /* In unibyte mode, character code conversion should not take - place but EOL conversion should. So, setup raw-text or one - of the subsidiary according to the information just setup. */ - if (!NILP (XPROCESS (process)->decode_coding_system)) - setup_raw_text_coding_system (proc_decode_coding_system[inchannel]); - if (!NILP (XPROCESS (process)->encode_coding_system)) - setup_raw_text_coding_system (proc_encode_coding_system[outchannel]); - } - - if (CODING_REQUIRE_ENCODING (proc_encode_coding_system[outchannel])) - { - /* Here we encode arguments by the coding system used for - sending data to the process. We don't support using - different coding systems for encoding arguments and for - encoding data sent to the process. */ - struct gcpro gcpro1; - int i = 1; - struct coding_system *coding = proc_encode_coding_system[outchannel]; - - coding->mode |= CODING_MODE_LAST_BLOCK; - GCPRO1 (process); - while (new_argv[i] != 0) - { - int len = strlen (new_argv[i]); - int size = encoding_buffer_size (coding, len); - unsigned char *buf = (unsigned char *) alloca (size); - - encode_coding (coding, (unsigned char *)new_argv[i], buf, len, size); - buf[coding->produced] = 0; - /* We don't have to free new_argv[i] because it points to a - Lisp string given as an argument to `start-process'. */ - new_argv[i++] = (char *) buf; - } - UNGCPRO; - coding->mode &= ~CODING_MODE_LAST_BLOCK; - } - /* Delay interrupts until we have a chance to store the new fork's pid in its process structure */ #ifdef POSIX_SIGNALS @@ -1443,7 +1730,7 @@ create_process (process, new_argv, current_dir) #ifdef SIGCHLD sigaddset (&blocked, SIGCHLD); #endif -#ifdef HAVE_VFORK +#ifdef HAVE_WORKING_VFORK /* On many hosts (e.g. Solaris 2.4), if a vforked child calls `signal', this sets the parent's signal handlers as well as the child's. So delay all interrupts whose handlers the child might munge, @@ -1453,7 +1740,7 @@ create_process (process, new_argv, current_dir) #ifdef AIX sigaddset (&blocked, SIGHUP ); sigaction (SIGHUP , 0, &sighup_action ); #endif -#endif /* HAVE_VFORK */ +#endif /* HAVE_WORKING_VFORK */ sigprocmask (SIG_BLOCK, &blocked, &procmask); #else /* !POSIX_SIGNALS */ #ifdef SIGCHLD @@ -1711,14 +1998,14 @@ create_process (process, new_argv, current_dir) /* Restore the signal state whether vfork succeeded or not. (We will signal an error, below, if it failed.) */ #ifdef POSIX_SIGNALS -#ifdef HAVE_VFORK +#ifdef HAVE_WORKING_VFORK /* Restore the parent's signal handlers. */ sigaction (SIGINT, &sigint_action, 0); sigaction (SIGQUIT, &sigquit_action, 0); #ifdef AIX sigaction (SIGHUP, &sighup_action, 0); #endif -#endif /* HAVE_VFORK */ +#endif /* HAVE_WORKING_VFORK */ /* Stop blocking signals in the parent. */ sigprocmask (SIG_SETMASK, &procmask, 0); #else /* !POSIX_SIGNALS */ @@ -1747,278 +2034,1079 @@ create_process (process, new_argv, current_dir) } #endif /* not VMS */ + #ifdef HAVE_SOCKETS -/* open a TCP network connection to a given HOST/SERVICE. Treated - exactly like a normal process when reading and writing. Only - differences are in status display and process deletion. A network - connection has no PID; you cannot signal it. All you can do is - deactivate and close it via delete-process */ - -DEFUN ("open-network-stream", Fopen_network_stream, Sopen_network_stream, - 4, 4, 0, - "Open a TCP connection for a service to a host.\n\ -Returns a subprocess-object to represent the connection.\n\ -Input and output work as for subprocesses; `delete-process' closes it.\n\ -Args are NAME BUFFER HOST SERVICE.\n\ -NAME is name for process. It is modified if necessary to make it unique.\n\ -BUFFER is the buffer (or buffer-name) to associate with the process.\n\ - Process output goes at end of that buffer, unless you specify\n\ - an output stream or filter function to handle the output.\n\ - BUFFER may be also nil, meaning that this process is not associated\n\ - with any buffer\n\ -Third arg is name of the host to connect to, or its IP address.\n\ -Fourth arg SERVICE is name of the service desired, or an integer\n\ - specifying a port number to connect to.") - (name, buffer, host, service) - Lisp_Object name, buffer, host, service; -{ - Lisp_Object proc; -#ifndef HAVE_GETADDRINFO - struct sockaddr_in address; - struct servent *svc_info; - struct hostent *host_info_ptr, host_info; - char *(addr_list[2]); - IN_ADDR numeric_addr; - int port; -#else /* HAVE_GETADDRINFO */ - struct addrinfo hints, *res, *lres; - int ret = 0; - int xerrno = 0; - char *portstring, portbuf[128]; -#endif /* HAVE_GETADDRINFO */ - int s = -1, outch, inch; - struct gcpro gcpro1, gcpro2, gcpro3, gcpro4; - int retry = 0; - int count = specpdl_ptr - specpdl; - int count1; - -#ifdef WINDOWSNT - /* Ensure socket support is loaded if available. */ - init_winsock (TRUE); -#endif +/* Convert an internal struct sockaddr to a lisp object (vector or string). + The address family of sa is not included in the result. */ - GCPRO4 (name, buffer, host, service); - CHECK_STRING (name, 0); - CHECK_STRING (host, 0); +static Lisp_Object +conv_sockaddr_to_lisp (sa, len) + struct sockaddr *sa; + int len; +{ + Lisp_Object address; + int i; + unsigned char *cp; + register struct Lisp_Vector *p; -#ifdef HAVE_GETADDRINFO - /* - * SERVICE can either be a string or int. - * Convert to a C string for later use by getaddrinfo. - */ - if (INTEGERP (service)) + switch (sa->sa_family) + { + case AF_INET: + { + struct sockaddr_in *sin = (struct sockaddr_in *) sa; + len = sizeof (sin->sin_addr) + 1; + address = Fmake_vector (make_number (len), Qnil); + p = XVECTOR (address); + p->contents[--len] = make_number (ntohs (sin->sin_port)); + cp = (unsigned char *)&sin->sin_addr; + break; + } +#ifdef HAVE_LOCAL_SOCKETS + case AF_LOCAL: + { + struct sockaddr_un *sockun = (struct sockaddr_un *) sa; + for (i = 0; i < sizeof (sockun->sun_path); i++) + if (sockun->sun_path[i] == 0) + break; + return make_unibyte_string (sockun->sun_path, i); + } +#endif + default: + len -= sizeof (sa->sa_family); + address = Fcons (make_number (sa->sa_family), + Fmake_vector (make_number (len), Qnil)); + p = XVECTOR (XCDR (address)); + cp = (unsigned char *) sa + sizeof (sa->sa_family); + break; + } + + i = 0; + while (i < len) + p->contents[i++] = make_number (*cp++); + + return address; +} + + +/* Get family and required size for sockaddr structure to hold ADDRESS. */ + +static int +get_lisp_to_sockaddr_size (address, familyp) + Lisp_Object address; + int *familyp; +{ + register struct Lisp_Vector *p; + + if (VECTORP (address)) + { + p = XVECTOR (address); + if (p->size == 5) + { + *familyp = AF_INET; + return sizeof (struct sockaddr_in); + } + } +#ifdef HAVE_LOCAL_SOCKETS + else if (STRINGP (address)) + { + *familyp = AF_LOCAL; + return sizeof (struct sockaddr_un); + } +#endif + else if (CONSP (address) && INTEGERP (XCAR (address)) && VECTORP (XCDR (address))) { - sprintf (portbuf, "%d", XINT (service)); - portstring = portbuf; + struct sockaddr *sa; + *familyp = XINT (XCAR (address)); + p = XVECTOR (XCDR (address)); + return p->size + sizeof (sa->sa_family); } + return 0; +} + +/* Convert an address object (vector or string) to an internal sockaddr. + Format of address has already been validated by size_lisp_to_sockaddr. */ + +static void +conv_lisp_to_sockaddr (family, address, sa, len) + int family; + Lisp_Object address; + struct sockaddr *sa; + int len; +{ + register struct Lisp_Vector *p; + register unsigned char *cp; + register int i; + + bzero (sa, len); + sa->sa_family = family; + + if (VECTORP (address)) + { + p = XVECTOR (address); + if (family == AF_INET) + { + struct sockaddr_in *sin = (struct sockaddr_in *) sa; + len = sizeof (sin->sin_addr) + 1; + i = XINT (p->contents[--len]); + sin->sin_port = htons (i); + cp = (unsigned char *)&sin->sin_addr; + } + } + else if (STRINGP (address)) + { +#ifdef HAVE_LOCAL_SOCKETS + if (family == AF_LOCAL) + { + struct sockaddr_un *sockun = (struct sockaddr_un *) sa; + cp = SDATA (address); + for (i = 0; i < sizeof (sockun->sun_path) && *cp; i++) + sockun->sun_path[i] = *cp++; + } +#endif + return; + } + else + { + p = XVECTOR (XCDR (address)); + cp = (unsigned char *)sa + sizeof (sa->sa_family); + } + + for (i = 0; i < len; i++) + if (INTEGERP (p->contents[i])) + *cp++ = XFASTINT (p->contents[i]) & 0xff; +} + +#ifdef DATAGRAM_SOCKETS +DEFUN ("process-datagram-address", Fprocess_datagram_address, Sprocess_datagram_address, + 1, 1, 0, + doc: /* Get the current datagram address associated with PROCESS. */) + (process) + Lisp_Object process; +{ + int channel; + + CHECK_PROCESS (process); + + if (!DATAGRAM_CONN_P (process)) + return Qnil; + + channel = XINT (XPROCESS (process)->infd); + return conv_sockaddr_to_lisp (datagram_address[channel].sa, + datagram_address[channel].len); +} + +DEFUN ("set-process-datagram-address", Fset_process_datagram_address, Sset_process_datagram_address, + 2, 2, 0, + doc: /* Set the datagram address for PROCESS to ADDRESS. +Returns nil upon error setting address, ADDRESS otherwise. */) + (process, address) + Lisp_Object process, address; +{ + int channel; + int family, len; + + CHECK_PROCESS (process); + + if (!DATAGRAM_CONN_P (process)) + return Qnil; + + channel = XINT (XPROCESS (process)->infd); + + len = get_lisp_to_sockaddr_size (address, &family); + if (datagram_address[channel].len != len) + return Qnil; + conv_lisp_to_sockaddr (family, address, datagram_address[channel].sa, len); + return address; +} +#endif + + +static struct socket_options { + /* The name of this option. Should be lowercase version of option + name without SO_ prefix. */ + char *name; + /* Length of name. */ + int nlen; + /* Option level SOL_... */ + int optlevel; + /* Option number SO_... */ + int optnum; + enum { SOPT_UNKNOWN, SOPT_BOOL, SOPT_INT, SOPT_STR, SOPT_LINGER } opttype; +} socket_options[] = + { +#ifdef SO_BINDTODEVICE + { "bindtodevice", 12, SOL_SOCKET, SO_BINDTODEVICE, SOPT_STR }, +#endif +#ifdef SO_BROADCAST + { "broadcast", 9, SOL_SOCKET, SO_BROADCAST, SOPT_BOOL }, +#endif +#ifdef SO_DONTROUTE + { "dontroute", 9, SOL_SOCKET, SO_DONTROUTE, SOPT_BOOL }, +#endif +#ifdef SO_KEEPALIVE + { "keepalive", 9, SOL_SOCKET, SO_KEEPALIVE, SOPT_BOOL }, +#endif +#ifdef SO_LINGER + { "linger", 6, SOL_SOCKET, SO_LINGER, SOPT_LINGER }, +#endif +#ifdef SO_OOBINLINE + { "oobinline", 9, SOL_SOCKET, SO_OOBINLINE, SOPT_BOOL }, +#endif +#ifdef SO_PRIORITY + { "priority", 8, SOL_SOCKET, SO_PRIORITY, SOPT_INT }, +#endif +#ifdef SO_REUSEADDR + { "reuseaddr", 9, SOL_SOCKET, SO_REUSEADDR, SOPT_BOOL }, +#endif + { 0, 0, 0, 0, SOPT_UNKNOWN } + }; + +/* Process list of socket options OPTS on socket S. + Only check if options are supported is S < 0. + If NO_ERROR is non-zero, continue silently if an option + cannot be set. + + Each element specifies one option. An element is either a string + "OPTION=VALUE" or a cons (OPTION . VALUE) where OPTION is a string + or a symbol. */ + +static int +set_socket_options (s, opts, no_error) + int s; + Lisp_Object opts; + int no_error; +{ + if (!CONSP (opts)) + opts = Fcons (opts, Qnil); + + while (CONSP (opts)) + { + Lisp_Object opt; + Lisp_Object val; + char *name, *arg; + struct socket_options *sopt; + int ret = 0; + + opt = XCAR (opts); + opts = XCDR (opts); + + name = 0; + val = Qt; + if (CONSP (opt)) + { + val = XCDR (opt); + opt = XCAR (opt); + } + if (STRINGP (opt)) + name = (char *) SDATA (opt); + else if (SYMBOLP (opt)) + name = (char *) SDATA (SYMBOL_NAME (opt)); + else { + error ("Mal-formed option list"); + return 0; + } + + if (strncmp (name, "no", 2) == 0) + { + val = Qnil; + name += 2; + } + + arg = 0; + for (sopt = socket_options; sopt->name; sopt++) + if (strncmp (name, sopt->name, sopt->nlen) == 0) + { + if (name[sopt->nlen] == 0) + break; + if (name[sopt->nlen] == '=') + { + arg = name + sopt->nlen + 1; + break; + } + } + + switch (sopt->opttype) + { + case SOPT_BOOL: + { + int optval; + if (s < 0) + return 1; + if (arg) + optval = (*arg == '0' || *arg == 'n') ? 0 : 1; + else if (INTEGERP (val)) + optval = XINT (val) == 0 ? 0 : 1; + else + optval = NILP (val) ? 0 : 1; + ret = setsockopt (s, sopt->optlevel, sopt->optnum, + &optval, sizeof (optval)); + break; + } + + case SOPT_INT: + { + int optval; + if (arg) + optval = atoi(arg); + else if (INTEGERP (val)) + optval = XINT (val); + else + error ("Bad option argument for %s", name); + if (s < 0) + return 1; + ret = setsockopt (s, sopt->optlevel, sopt->optnum, + &optval, sizeof (optval)); + break; + } + + case SOPT_STR: + { + if (!arg) + { + if (NILP (val)) + arg = ""; + else if (STRINGP (val)) + arg = (char *) SDATA (val); + else if (XSYMBOL (val)) + arg = (char *) SDATA (SYMBOL_NAME (val)); + else + error ("Invalid argument to %s option", name); + } + ret = setsockopt (s, sopt->optlevel, sopt->optnum, + arg, strlen (arg)); + } + +#ifdef SO_LINGER + case SOPT_LINGER: + { + struct linger linger; + + linger.l_onoff = 1; + linger.l_linger = 0; + + if (s < 0) + return 1; + + if (arg) + { + if (*arg == 'n' || *arg == 't' || *arg == 'y') + linger.l_onoff = (*arg == 'n') ? 0 : 1; + else + linger.l_linger = atoi(arg); + } + else if (INTEGERP (val)) + linger.l_linger = XINT (val); + else + linger.l_onoff = NILP (val) ? 0 : 1; + ret = setsockopt (s, sopt->optlevel, sopt->optnum, + &linger, sizeof (linger)); + break; + } +#endif + default: + if (s < 0) + return 0; + if (no_error) + continue; + error ("Unsupported option: %s", name); + } + if (ret < 0 && ! no_error) + report_file_error ("Cannot set network option: %s", opt); + } + return 1; +} + +DEFUN ("set-network-process-options", + Fset_network_process_options, Sset_network_process_options, + 1, MANY, 0, + doc: /* Set one or more options for network process PROCESS. +Each option is either a string "OPT=VALUE" or a cons (OPT . VALUE). +A boolean value is false if it either zero or nil, true otherwise. + +The following options are known. Consult the relevant system manual +pages for more information. + +bindtodevice=NAME -- bind to interface NAME, or remove binding if nil. +broadcast=BOOL -- Allow send and receive of datagram broadcasts. +dontroute=BOOL -- Only send to directly connected hosts. +keepalive=BOOL -- Send keep-alive messages on network stream. +linger=BOOL or TIMEOUT -- Send queued messages before closing. +oobinline=BOOL -- Place out-of-band data in receive data stream. +priority=INT -- Set protocol defined priority for sent packets. +reuseaddr=BOOL -- Allow reusing a recently used address. + +usage: (set-network-process-options PROCESS &rest OPTIONS) */) + (nargs, args) + int nargs; + Lisp_Object *args; +{ + Lisp_Object process; + Lisp_Object opts; + + process = args[0]; + CHECK_PROCESS (process); + if (nargs > 1 && XINT (XPROCESS (process)->infd) >= 0) + { + opts = Flist (nargs, args); + set_socket_options (XINT (XPROCESS (process)->infd), opts, 0); + } + return process; +} + +/* A version of request_sigio suitable for a record_unwind_protect. */ + +Lisp_Object +unwind_request_sigio (dummy) + Lisp_Object dummy; +{ + if (interrupt_input) + request_sigio (); + return Qnil; +} + +/* Create a network stream/datagram client/server process. Treated + exactly like a normal process when reading and writing. Primary + differences are in status display and process deletion. A network + connection has no PID; you cannot signal it. All you can do is + stop/continue it and deactivate/close it via delete-process */ + +DEFUN ("make-network-process", Fmake_network_process, Smake_network_process, + 0, MANY, 0, + doc: /* Create and return a network server or client process. + +In Emacs, network connections are represented by process objects, so +input and output work as for subprocesses and `delete-process' closes +a network connection. However, a network process has no process id, +it cannot be signalled, and the status codes are different from normal +processes. + +Arguments are specified as keyword/argument pairs. The following +arguments are defined: + +:name NAME -- NAME is name for process. It is modified if necessary +to make it unique. + +:buffer BUFFER -- BUFFER is the buffer (or buffer-name) to associate +with the process. Process output goes at end of that buffer, unless +you specify an output stream or filter function to handle the output. +BUFFER may be also nil, meaning that this process is not associated +with any buffer. + +:host HOST -- HOST is name of the host to connect to, or its IP +address. The symbol `local' specifies the local host. If specified +for a server process, it must be a valid name or address for the local +host, and only clients connecting to that address will be accepted. + +:service SERVICE -- SERVICE is name of the service desired, or an +integer specifying a port number to connect to. If SERVICE is t, +a random port number is selected for the server. + +:type TYPE -- TYPE is the type of connection. The default (nil) is a +stream type connection, `datagram' creates a datagram type connection. + +:family FAMILY -- FAMILY is the address (and protocol) family for the +service specified by HOST and SERVICE. The default address family is +Inet (or IPv4) for the host and port number specified by HOST and +SERVICE. Other address families supported are: + local -- for a local (i.e. UNIX) address specified by SERVICE. + +:local ADDRESS -- ADDRESS is the local address used for the connection. +This parameter is ignored when opening a client process. When specified +for a server process, the FAMILY, HOST and SERVICE args are ignored. + +:remote ADDRESS -- ADDRESS is the remote partner's address for the +connection. This parameter is ignored when opening a stream server +process. For a datagram server process, it specifies the initial +setting of the remote datagram address. When specified for a client +process, the FAMILY, HOST, and SERVICE args are ignored. + +The format of ADDRESS depends on the address family: +- An IPv4 address is represented as an vector of integers [A B C D P] +corresponding to numeric IP address A.B.C.D and port number P. +- A local address is represented as a string with the address in the +local address space. +- An "unsupported family" address is represented by a cons (F . AV) +where F is the family number and AV is a vector containing the socket +address data with one element per address data byte. Do not rely on +this format in portable code, as it may depend on implementation +defined constants, data sizes, and data structure alignment. + +:coding CODING -- CODING is coding system for this process. + +:options OPTIONS -- Set the specified options for the network process. +See `set-network-process-options' for details. + +:nowait BOOL -- If BOOL is non-nil for a stream type client process, +return without waiting for the connection to complete; instead, the +sentinel function will be called with second arg matching "open" (if +successful) or "failed" when the connect completes. Default is to use +a blocking connect (i.e. wait) for stream type connections. + +:noquery BOOL -- Query the user unless BOOL is non-nil, and process is +running when emacs is exited. + +:stop BOOL -- Start process in the `stopped' state if BOOL non-nil. +In the stopped state, a server process does not accept new +connections, and a client process does not handle incoming traffic. +The stopped state is cleared by `continue-process' and set by +`stop-process'. + +:filter FILTER -- Install FILTER as the process filter. + +:sentinel SENTINEL -- Install SENTINEL as the process sentinel. + +:log LOG -- Install LOG as the server process log function. This +function is called when the server accepts a network connection from a +client. The arguments are SERVER, CLIENT, and MESSAGE, where SERVER +is the server process, CLIENT is the new process for the connection, +and MESSAGE is a string. + +:server BOOL -- if BOOL is non-nil, create a server process for the +specified FAMILY, SERVICE, and connection type (stream or datagram). +Default is a client process. + +A server process will listen for and accept connections from +clients. When a client connection is accepted, a new network process +is created for the connection with the following parameters: +- The client's process name is constructed by concatenating the server +process' NAME and a client identification string. +- If the FILTER argument is non-nil, the client process will not get a +separate process buffer; otherwise, the client's process buffer is a newly +created buffer named after the server process' BUFFER name or process +NAME concatenated with the client identification string. +- The connection type and the process filter and sentinel parameters are +inherited from the server process' TYPE, FILTER and SENTINEL. +- The client process' contact info is set according to the client's +addressing information (typically an IP address and a port number). + +Notice that the FILTER and SENTINEL args are never used directly by +the server process. Also, the BUFFER argument is not used directly by +the server process, but via the optional :log function, accepted (and +failed) connections may be logged in the server process' buffer. + +usage: (make-network-process &rest ARGS) */) + (nargs, args) + int nargs; + Lisp_Object *args; +{ + Lisp_Object proc; + Lisp_Object contact; + struct Lisp_Process *p; +#ifdef HAVE_GETADDRINFO + struct addrinfo ai, *res, *lres; + struct addrinfo hints; + char *portstring, portbuf[128]; +#else /* HAVE_GETADDRINFO */ + struct _emacs_addrinfo + { + int ai_family; + int ai_socktype; + int ai_protocol; + int ai_addrlen; + struct sockaddr *ai_addr; + struct _emacs_addrinfo *ai_next; + } ai, *res, *lres; +#endif /* HAVE_GETADDRINFO */ + struct sockaddr_in address_in; +#ifdef HAVE_LOCAL_SOCKETS + struct sockaddr_un address_un; +#endif + int port; + int ret = 0; + int xerrno = 0; + int s = -1, outch, inch; + struct gcpro gcpro1; + int retry = 0; + int count = SPECPDL_INDEX (); + int count1; + Lisp_Object QCaddress; /* one of QClocal or QCremote */ + Lisp_Object tem; + Lisp_Object name, buffer, host, service, address; + Lisp_Object filter, sentinel; + int is_non_blocking_client = 0; + int is_server = 0; + int socktype; + int family = -1; + + if (nargs == 0) + return Qnil; + + /* Save arguments for process-contact and clone-process. */ + contact = Flist (nargs, args); + GCPRO1 (contact); + +#ifdef WINDOWSNT + /* Ensure socket support is loaded if available. */ + init_winsock (TRUE); +#endif + + /* :type TYPE (nil: stream, datagram */ + tem = Fplist_get (contact, QCtype); + if (NILP (tem)) + socktype = SOCK_STREAM; +#ifdef DATAGRAM_SOCKETS + else if (EQ (tem, Qdatagram)) + socktype = SOCK_DGRAM; +#endif else + error ("Unsupported connection type"); + + /* :server BOOL */ + tem = Fplist_get (contact, QCserver); + if (!NILP (tem)) { - CHECK_STRING (service, 0); - portstring = XSTRING (service)->data; + /* Don't support network sockets when non-blocking mode is + not available, since a blocked Emacs is not useful. */ +#if defined(TERM) || (!defined(O_NONBLOCK) && !defined(O_NDELAY)) + error ("Network servers not supported"); +#else + is_server = 1; +#endif } -#else /* ! HAVE_GETADDRINFO */ + + /* Make QCaddress an alias for :local (server) or :remote (client). */ + QCaddress = is_server ? QClocal : QCremote; + + /* :wait BOOL */ + if (!is_server && socktype == SOCK_STREAM + && (tem = Fplist_get (contact, QCnowait), !NILP (tem))) + { +#ifndef NON_BLOCKING_CONNECT + error ("Non-blocking connect not supported"); +#else + is_non_blocking_client = 1; +#endif + } + + name = Fplist_get (contact, QCname); + buffer = Fplist_get (contact, QCbuffer); + filter = Fplist_get (contact, QCfilter); + sentinel = Fplist_get (contact, QCsentinel); + + CHECK_STRING (name); + +#ifdef TERM + /* Let's handle TERM before things get complicated ... */ + host = Fplist_get (contact, QChost); + CHECK_STRING (host); + + service = Fplist_get (contact, QCservice); if (INTEGERP (service)) port = htons ((unsigned short) XINT (service)); else { - CHECK_STRING (service, 0); - svc_info = getservbyname (XSTRING (service)->data, "tcp"); + struct servent *svc_info; + CHECK_STRING (service); + svc_info = getservbyname (SDATA (service), "tcp"); if (svc_info == 0) - error ("Unknown service \"%s\"", XSTRING (service)->data); + error ("Unknown service: %s", SDATA (service)); port = svc_info->s_port; } -#endif /* ! HAVE_GETADDRINFO */ + s = connect_server (0); + if (s < 0) + report_file_error ("error creating socket", Fcons (name, Qnil)); + send_command (s, C_PORT, 0, "%s:%d", SDATA (host), ntohs (port)); + send_command (s, C_DUMB, 1, 0); + +#else /* not TERM */ + + /* Initialize addrinfo structure in case we don't use getaddrinfo. */ + ai.ai_socktype = socktype; + ai.ai_protocol = 0; + ai.ai_next = NULL; + res = &ai; + + /* :local ADDRESS or :remote ADDRESS */ + address = Fplist_get (contact, QCaddress); + if (!NILP (address)) + { + host = service = Qnil; + + if (!(ai.ai_addrlen = get_lisp_to_sockaddr_size (address, &family))) + error ("Malformed :address"); + ai.ai_family = family; + ai.ai_addr = alloca (ai.ai_addrlen); + conv_lisp_to_sockaddr (family, address, ai.ai_addr, ai.ai_addrlen); + goto open_socket; + } + + /* :family FAMILY -- nil (for Inet), local, or integer. */ + tem = Fplist_get (contact, QCfamily); + if (INTEGERP (tem)) + family = XINT (tem); + else + { + if (NILP (tem)) + family = AF_INET; +#ifdef HAVE_LOCAL_SOCKETS + else if (EQ (tem, Qlocal)) + family = AF_LOCAL; +#endif + } + if (family < 0) + error ("Unknown address family"); + ai.ai_family = family; + + /* :service SERVICE -- string, integer (port number), or t (random port). */ + service = Fplist_get (contact, QCservice); + +#ifdef HAVE_LOCAL_SOCKETS + if (family == AF_LOCAL) + { + /* Host is not used. */ + host = Qnil; + CHECK_STRING (service); + bzero (&address_un, sizeof address_un); + address_un.sun_family = AF_LOCAL; + strncpy (address_un.sun_path, SDATA (service), sizeof address_un.sun_path); + ai.ai_addr = (struct sockaddr *) &address_un; + ai.ai_addrlen = sizeof address_un; + goto open_socket; + } +#endif + + /* :host HOST -- hostname, ip address, or 'local for localhost. */ + host = Fplist_get (contact, QChost); + if (!NILP (host)) + { + if (EQ (host, Qlocal)) + host = build_string ("localhost"); + CHECK_STRING (host); + } /* Slow down polling to every ten seconds. Some kernels have a bug which causes retrying connect to fail after a connect. Polling can interfere with gethostbyname too. */ #ifdef POLL_FOR_INPUT - bind_polling_period (10); + if (socktype == SOCK_STREAM) + { + record_unwind_protect (unwind_stop_other_atimers, Qnil); + bind_polling_period (10); + } #endif -#ifndef TERM #ifdef HAVE_GETADDRINFO - { - immediate_quit = 1; - QUIT; - memset (&hints, 0, sizeof (hints)); - hints.ai_flags = 0; - hints.ai_family = AF_UNSPEC; - hints.ai_socktype = SOCK_STREAM; - hints.ai_protocol = 0; - ret = getaddrinfo (XSTRING (host)->data, portstring, &hints, &res); - if (ret) - { - error ("%s/%s %s", XSTRING (host)->data, portstring, - strerror (ret)); - } - immediate_quit = 0; - } + /* If we have a host, use getaddrinfo to resolve both host and service. + Otherwise, use getservbyname to lookup the service. */ + if (!NILP (host)) + { + + /* SERVICE can either be a string or int. + Convert to a C string for later use by getaddrinfo. */ + if (EQ (service, Qt)) + portstring = "0"; + else if (INTEGERP (service)) + { + sprintf (portbuf, "%ld", (long) XINT (service)); + portstring = portbuf; + } + else + { + CHECK_STRING (service); + portstring = SDATA (service); + } + + immediate_quit = 1; + QUIT; + memset (&hints, 0, sizeof (hints)); + hints.ai_flags = 0; + hints.ai_family = NILP (Fplist_member (contact, QCfamily)) ? AF_UNSPEC : family; + hints.ai_socktype = socktype; + hints.ai_protocol = 0; + ret = getaddrinfo (SDATA (host), portstring, &hints, &res); + if (ret) +#ifdef HAVE_GAI_STRERROR + error ("%s/%s %s", SDATA (host), portstring, gai_strerror(ret)); +#else + error ("%s/%s getaddrinfo error %d", SDATA (host), portstring, ret); +#endif + immediate_quit = 0; + + goto open_socket; + } +#endif /* HAVE_GETADDRINFO */ + + /* We end up here if getaddrinfo is not defined, or in case no hostname + has been specified (e.g. for a local server process). */ + + if (EQ (service, Qt)) + port = 0; + else if (INTEGERP (service)) + port = htons ((unsigned short) XINT (service)); + else + { + struct servent *svc_info; + CHECK_STRING (service); + svc_info = getservbyname (SDATA (service), + (socktype == SOCK_DGRAM ? "udp" : "tcp")); + if (svc_info == 0) + error ("Unknown service: %s", SDATA (service)); + port = svc_info->s_port; + } + + bzero (&address_in, sizeof address_in); + address_in.sin_family = family; + address_in.sin_addr.s_addr = INADDR_ANY; + address_in.sin_port = port; + +#ifndef HAVE_GETADDRINFO + if (!NILP (host)) + { + struct hostent *host_info_ptr; + + /* gethostbyname may fail with TRY_AGAIN, but we don't honour that, + as it may `hang' emacs for a very long time. */ + immediate_quit = 1; + QUIT; + host_info_ptr = gethostbyname (SDATA (host)); + immediate_quit = 0; + + if (host_info_ptr) + { + bcopy (host_info_ptr->h_addr, (char *) &address_in.sin_addr, + host_info_ptr->h_length); + family = host_info_ptr->h_addrtype; + address_in.sin_family = family; + } + else + /* Attempt to interpret host as numeric inet address */ + { + IN_ADDR numeric_addr; + numeric_addr = inet_addr ((char *) SDATA (host)); + if (NUMERIC_ADDR_ERROR) + error ("Unknown host \"%s\"", SDATA (host)); + + bcopy ((char *)&numeric_addr, (char *) &address_in.sin_addr, + sizeof (address_in.sin_addr)); + } + + } +#endif /* not HAVE_GETADDRINFO */ + ai.ai_family = family; + ai.ai_addr = (struct sockaddr *) &address_in; + ai.ai_addrlen = sizeof address_in; + + open_socket: + + /* Kernel bugs (on Ultrix at least) cause lossage (not just EINTR) + when connect is interrupted. So let's not let it get interrupted. + Note we do not turn off polling, because polling is only used + when not interrupt_input, and thus not normally used on the systems + which have this bug. On systems which use polling, there's no way + to quit if polling is turned off. */ + if (interrupt_input + && !is_server && socktype == SOCK_STREAM) + { + /* Comment from KFS: The original open-network-stream code + didn't unwind protect this, but it seems like the proper + thing to do. In any case, I don't see how it could harm to + do this -- and it makes cleanup (using unbind_to) easier. */ + record_unwind_protect (unwind_request_sigio, Qnil); + unrequest_sigio (); + } + + /* Do this in case we never enter the for-loop below. */ + count1 = SPECPDL_INDEX (); s = -1; - count1 = specpdl_ptr - specpdl; - record_unwind_protect (close_file_unwind, make_number (s)); for (lres = res; lres; lres = lres->ai_next) { s = socket (lres->ai_family, lres->ai_socktype, lres->ai_protocol); - if (s < 0) - continue; + if (s < 0) + { + xerrno = errno; + continue; + } + +#ifdef DATAGRAM_SOCKETS + if (!is_server && socktype == SOCK_DGRAM) + break; +#endif /* DATAGRAM_SOCKETS */ + +#ifdef NON_BLOCKING_CONNECT + if (is_non_blocking_client) + { +#ifdef O_NONBLOCK + ret = fcntl (s, F_SETFL, O_NONBLOCK); +#else + ret = fcntl (s, F_SETFL, O_NDELAY); +#endif + if (ret < 0) + { + xerrno = errno; + emacs_close (s); + s = -1; + continue; + } + } +#endif + + /* Make us close S if quit. */ + record_unwind_protect (close_file_unwind, make_number (s)); - /* Kernel bugs (on Ultrix at least) cause lossage (not just EINTR) - when connect is interrupted. So let's not let it get interrupted. - Note we do not turn off polling, because polling is only used - when not interrupt_input, and thus not normally used on the systems - which have this bug. On systems which use polling, there's no way - to quit if polling is turned off. */ - if (interrupt_input) - unrequest_sigio (); + if (is_server) + { + /* Configure as a server socket. */ +#ifdef HAVE_LOCAL_SOCKETS + if (family != AF_LOCAL) +#endif + { + int optval = 1; + if (setsockopt (s, SOL_SOCKET, SO_REUSEADDR, &optval, sizeof optval)) + report_file_error ("Cannot set reuse option on server socket.", Qnil); + } + + if (bind (s, lres->ai_addr, lres->ai_addrlen)) + report_file_error ("Cannot bind server socket", Qnil); - immediate_quit = 1; - QUIT; +#ifdef HAVE_GETSOCKNAME + if (EQ (service, Qt)) + { + struct sockaddr_in sa1; + int len1 = sizeof (sa1); + if (getsockname (s, (struct sockaddr *)&sa1, &len1) == 0) + { + ((struct sockaddr_in *)(lres->ai_addr))->sin_port = sa1.sin_port; + service = make_number (sa1.sin_port); + contact = Fplist_put (contact, QCservice, service); + } + } +#endif - ret = connect (s, lres->ai_addr, lres->ai_addrlen); - if (ret == 0) - break; - emacs_close (s); - s = -1; - } + if (socktype == SOCK_STREAM && listen (s, 5)) + report_file_error ("Cannot listen on server socket", Qnil); - freeaddrinfo (res); - if (s < 0) - { - if (interrupt_input) - request_sigio (); + break; + } - errno = xerrno; - report_file_error ("connection failed", - Fcons (host, Fcons (name, Qnil))); - } -#else /* ! HAVE_GETADDRINFO */ + retry_connect: - while (1) - { -#if 0 -#ifdef TRY_AGAIN - h_errno = 0; -#endif -#endif immediate_quit = 1; QUIT; - host_info_ptr = gethostbyname (XSTRING (host)->data); - immediate_quit = 0; -#if 0 -#ifdef TRY_AGAIN - if (! (host_info_ptr == 0 && h_errno == TRY_AGAIN)) -#endif -#endif - break; - Fsleep_for (make_number (1), Qnil); - } - if (host_info_ptr == 0) - /* Attempt to interpret host as numeric inet address */ - { - numeric_addr = inet_addr ((char *) XSTRING (host)->data); - if (NUMERIC_ADDR_ERROR) - error ("Unknown host \"%s\"", XSTRING (host)->data); - - host_info_ptr = &host_info; - host_info.h_name = 0; - host_info.h_aliases = 0; - host_info.h_addrtype = AF_INET; -#ifdef h_addr - /* Older machines have only one address slot called h_addr. - Newer machines have h_addr_list, but #define h_addr to - be its first element. */ - host_info.h_addr_list = &(addr_list[0]); -#endif - host_info.h_addr = (char*)(&numeric_addr); - addr_list[1] = 0; - /* numeric_addr isn't null-terminated; it has fixed length. */ - host_info.h_length = sizeof (numeric_addr); - } - bzero (&address, sizeof address); - bcopy (host_info_ptr->h_addr, (char *) &address.sin_addr, - host_info_ptr->h_length); - address.sin_family = host_info_ptr->h_addrtype; - address.sin_port = port; + /* This turns off all alarm-based interrupts; the + bind_polling_period call above doesn't always turn all the + short-interval ones off, especially if interrupt_input is + set. - s = socket (host_info_ptr->h_addrtype, SOCK_STREAM, 0); - if (s < 0) - report_file_error ("error creating socket", Fcons (name, Qnil)); + It'd be nice to be able to control the connect timeout + though. Would non-blocking connect calls be portable? - count1 = specpdl_ptr - specpdl; - record_unwind_protect (close_file_unwind, make_number (s)); + This used to be conditioned by HAVE_GETADDRINFO. Why? */ - /* Kernel bugs (on Ultrix at least) cause lossage (not just EINTR) - when connect is interrupted. So let's not let it get interrupted. - Note we do not turn off polling, because polling is only used - when not interrupt_input, and thus not normally used on the systems - which have this bug. On systems which use polling, there's no way - to quit if polling is turned off. */ - if (interrupt_input) - unrequest_sigio (); + turn_on_atimers (0); - loop: + ret = connect (s, lres->ai_addr, lres->ai_addrlen); + xerrno = errno; - immediate_quit = 1; - QUIT; + turn_on_atimers (1); - if (connect (s, (struct sockaddr *) &address, sizeof address) == -1 - && errno != EISCONN) - { - int xerrno = errno; + if (ret == 0 || xerrno == EISCONN) + { + /* The unwind-protect will be discarded afterwards. + Likewise for immediate_quit. */ + break; + } + +#ifdef NON_BLOCKING_CONNECT +#ifdef EINPROGRESS + if (is_non_blocking_client && xerrno == EINPROGRESS) + break; +#else +#ifdef EWOULDBLOCK + if (is_non_blocking_client && xerrno == EWOULDBLOCK) + break; +#endif +#endif +#endif immediate_quit = 0; - if (errno == EINTR) - goto loop; - if (errno == EADDRINUSE && retry < 20) + if (xerrno == EINTR) + goto retry_connect; + if (xerrno == EADDRINUSE && retry < 20) { /* A delay here is needed on some FreeBSD systems, and it is harmless, since this retrying takes time anyway and should be infrequent. */ Fsleep_for (make_number (1), Qnil); retry++; - goto loop; + goto retry_connect; } - /* Discard the unwind protect. */ + /* Discard the unwind protect closing S. */ specpdl_ptr = specpdl + count1; - emacs_close (s); + s = -1; + } - if (interrupt_input) - request_sigio (); - - errno = xerrno; - report_file_error ("connection failed", - Fcons (host, Fcons (name, Qnil))); + if (s >= 0) + { +#ifdef DATAGRAM_SOCKETS + if (socktype == SOCK_DGRAM) + { + if (datagram_address[s].sa) + abort (); + datagram_address[s].sa = (struct sockaddr *) xmalloc (lres->ai_addrlen); + datagram_address[s].len = lres->ai_addrlen; + if (is_server) + { + Lisp_Object remote; + bzero (datagram_address[s].sa, lres->ai_addrlen); + if (remote = Fplist_get (contact, QCremote), !NILP (remote)) + { + int rfamily, rlen; + rlen = get_lisp_to_sockaddr_size (remote, &rfamily); + if (rfamily == lres->ai_family && rlen == lres->ai_addrlen) + conv_lisp_to_sockaddr (rfamily, remote, + datagram_address[s].sa, rlen); + } + } + else + bcopy (lres->ai_addr, datagram_address[s].sa, lres->ai_addrlen); + } +#endif + contact = Fplist_put (contact, QCaddress, + conv_sockaddr_to_lisp (lres->ai_addr, lres->ai_addrlen)); } -#endif /* ! HAVE_GETADDRINFO */ + +#ifdef HAVE_GETADDRINFO + if (res != &ai) + freeaddrinfo (res); +#endif immediate_quit = 0; - /* Discard the unwind protect. */ + /* Discard the unwind protect for closing S, if any. */ specpdl_ptr = specpdl + count1; -#ifdef POLL_FOR_INPUT + /* Unwind bind_polling_period and request_sigio. */ unbind_to (count, Qnil); -#endif - - if (interrupt_input) - request_sigio (); -#else /* TERM */ - s = connect_server (0); if (s < 0) - report_file_error ("error creating socket", Fcons (name, Qnil)); - send_command (s, C_PORT, 0, "%s:%d", XSTRING (host)->data, ntohs (port)); - send_command (s, C_DUMB, 1, 0); -#endif /* TERM */ + { + /* If non-blocking got this far - and failed - assume non-blocking is + not supported after all. This is probably a wrong assumption, but + the normal blocking calls to open-network-stream handles this error + better. */ + if (is_non_blocking_client) + return Qnil; + + errno = xerrno; + if (is_server) + report_file_error ("make server process failed", contact); + else + report_file_error ("make client process failed", contact); + } + + tem = Fplist_get (contact, QCoptions); + if (!NILP (tem)) + set_socket_options (s, tem, 1); + +#endif /* not TERM */ inch = s; outch = s; @@ -2037,21 +3125,54 @@ Fourth arg SERVICE is name of the service desired, or an integer\n\ #endif #endif - XPROCESS (proc)->childp = Fcons (host, Fcons (service, Qnil)); - XPROCESS (proc)->command_channel_p = Qnil; - XPROCESS (proc)->buffer = buffer; - XPROCESS (proc)->sentinel = Qnil; - XPROCESS (proc)->filter = Qnil; - XPROCESS (proc)->command = Qnil; - XPROCESS (proc)->pid = Qnil; - XSETINT (XPROCESS (proc)->infd, inch); - XSETINT (XPROCESS (proc)->outfd, outch); - XPROCESS (proc)->status = Qrun; - FD_SET (inch, &input_wait_mask); - FD_SET (inch, &non_keyboard_wait_mask); + p = XPROCESS (proc); + + p->childp = contact; + p->buffer = buffer; + p->sentinel = sentinel; + p->filter = filter; + p->log = Fplist_get (contact, QClog); + if (tem = Fplist_get (contact, QCnoquery), !NILP (tem)) + p->kill_without_query = Qt; + if ((tem = Fplist_get (contact, QCstop), !NILP (tem))) + p->command = Qt; + p->pid = Qnil; + XSETINT (p->infd, inch); + XSETINT (p->outfd, outch); + if (is_server && socktype == SOCK_STREAM) + p->status = Qlisten; + +#ifdef NON_BLOCKING_CONNECT + if (is_non_blocking_client) + { + /* We may get here if connect did succeed immediately. However, + in that case, we still need to signal this like a non-blocking + connection. */ + p->status = Qconnect; + if (!FD_ISSET (inch, &connect_wait_mask)) + { + FD_SET (inch, &connect_wait_mask); + num_pending_connects++; + } + } + else +#endif + /* A server may have a client filter setting of Qt, but it must + still listen for incoming connects unless it is stopped. */ + if ((!EQ (p->filter, Qt) && !EQ (p->command, Qt)) + || (EQ (p->status, Qlisten) && NILP (p->command))) + { + FD_SET (inch, &input_wait_mask); + FD_SET (inch, &non_keyboard_wait_mask); + } + if (inch > max_process_desc) max_process_desc = inch; + tem = Fplist_member (contact, QCcoding); + if (!NILP (tem) && (!CONSP (tem) || !CONSP (XCDR (tem)))) + tem = Qnil; /* No error message (too late!). */ + { /* Setup coding systems for communicating with the network stream. */ struct gcpro gcpro1; @@ -2059,7 +3180,9 @@ Fourth arg SERVICE is name of the service desired, or an integer\n\ Lisp_Object coding_systems = Qt; Lisp_Object args[5], val; - if (!NILP (Vcoding_system_for_read)) + if (!NILP (tem)) + val = XCAR (XCDR (tem)); + else if (!NILP (Vcoding_system_for_read)) val = Vcoding_system_for_read; else if ((!NILP (buffer) && NILP (XBUFFER (buffer)->enable_multibyte_characters)) || (NILP (buffer) && NILP (buffer_defaults.enable_multibyte_characters))) @@ -2070,11 +3193,16 @@ Fourth arg SERVICE is name of the service desired, or an integer\n\ val = Qnil; else { - args[0] = Qopen_network_stream, args[1] = name, - args[2] = buffer, args[3] = host, args[4] = service; - GCPRO1 (proc); - coding_systems = Ffind_operation_coding_system (5, args); - UNGCPRO; + if (NILP (host) || NILP (service)) + coding_systems = Qnil; + else + { + args[0] = Qopen_network_stream, args[1] = name, + args[2] = buffer, args[3] = host, args[4] = service; + GCPRO1 (proc); + coding_systems = Ffind_operation_coding_system (5, args); + UNGCPRO; + } if (CONSP (coding_systems)) val = XCAR (coding_systems); else if (CONSP (Vdefault_process_coding_system)) @@ -2082,9 +3210,11 @@ Fourth arg SERVICE is name of the service desired, or an integer\n\ else val = Qnil; } - XPROCESS (proc)->decode_coding_system = val; + p->decode_coding_system = val; - if (!NILP (Vcoding_system_for_write)) + if (!NILP (tem)) + val = XCAR (XCDR (tem)); + else if (!NILP (Vcoding_system_for_write)) val = Vcoding_system_for_write; else if (NILP (current_buffer->enable_multibyte_characters)) val = Qnil; @@ -2092,11 +3222,16 @@ Fourth arg SERVICE is name of the service desired, or an integer\n\ { if (EQ (coding_systems, Qt)) { - args[0] = Qopen_network_stream, args[1] = name, - args[2] = buffer, args[3] = host, args[4] = service; - GCPRO1 (proc); - coding_systems = Ffind_operation_coding_system (5, args); - UNGCPRO; + if (NILP (host) || NILP (service)) + coding_systems = Qnil; + else + { + args[0] = Qopen_network_stream, args[1] = name, + args[2] = buffer, args[3] = host, args[4] = service; + GCPRO1 (proc); + coding_systems = Ffind_operation_coding_system (5, args); + UNGCPRO; + } } if (CONSP (coding_systems)) val = XCDR (coding_systems); @@ -2105,27 +3240,27 @@ Fourth arg SERVICE is name of the service desired, or an integer\n\ else val = Qnil; } - XPROCESS (proc)->encode_coding_system = val; + p->encode_coding_system = val; } if (!proc_decode_coding_system[inch]) proc_decode_coding_system[inch] = (struct coding_system *) xmalloc (sizeof (struct coding_system)); - setup_coding_system (XPROCESS (proc)->decode_coding_system, + setup_coding_system (p->decode_coding_system, proc_decode_coding_system[inch]); if (!proc_encode_coding_system[outch]) proc_encode_coding_system[outch] = (struct coding_system *) xmalloc (sizeof (struct coding_system)); - setup_coding_system (XPROCESS (proc)->encode_coding_system, + setup_coding_system (p->encode_coding_system, proc_encode_coding_system[outch]); - XPROCESS (proc)->decoding_buf = make_uninit_string (0); - XPROCESS (proc)->decoding_carryover = make_number (0); - XPROCESS (proc)->encoding_buf = make_uninit_string (0); - XPROCESS (proc)->encoding_carryover = make_number (0); + p->decoding_buf = make_uninit_string (0); + p->decoding_carryover = make_number (0); + p->encoding_buf = make_uninit_string (0); + p->encoding_carryover = make_number (0); - XPROCESS (proc)->inherit_coding_system_flag - = (NILP (buffer) || !inherit_process_coding_system + p->inherit_coding_system_flag + = (!NILP (tem) || NILP (buffer) || !inherit_process_coding_system ? Qnil : Qt); UNGCPRO; @@ -2163,9 +3298,23 @@ deactivate_process (proc) XSETINT (p->infd, -1); XSETINT (p->outfd, -1); +#ifdef DATAGRAM_SOCKETS + if (DATAGRAM_CHAN_P (inchannel)) + { + xfree (datagram_address[inchannel].sa); + datagram_address[inchannel].sa = 0; + datagram_address[inchannel].len = 0; + } +#endif chan_process[inchannel] = Qnil; FD_CLR (inchannel, &input_wait_mask); FD_CLR (inchannel, &non_keyboard_wait_mask); + if (FD_ISSET (inchannel, &connect_wait_mask)) + { + FD_CLR (inchannel, &connect_wait_mask); + if (--num_pending_connects < 0) + abort (); + } if (inchannel == max_process_desc) { int i; @@ -2206,27 +3355,27 @@ close_process_descs () } DEFUN ("accept-process-output", Faccept_process_output, Saccept_process_output, - 0, 3, 0, - "Allow any pending output from subprocesses to be read by Emacs.\n\ -It is read into the process' buffers or given to their filter functions.\n\ -Non-nil arg PROCESS means do not return until some output has been received\n\ -from PROCESS.\n\ -Non-nil second arg TIMEOUT and third arg TIMEOUT-MSECS are number of\n\ -seconds and microseconds to wait; return after that much time whether\n\ -or not there is input.\n\ -Return non-nil iff we received any output before the timeout expired.") - (process, timeout, timeout_msecs) + 0, 3, 0, + doc: /* Allow any pending output from subprocesses to be read by Emacs. +It is read into the process' buffers or given to their filter functions. +Non-nil arg PROCESS means do not return until some output has been received +from PROCESS. +Non-nil second arg TIMEOUT and third arg TIMEOUT-MSECS are number of +seconds and microseconds to wait; return after that much time whether +or not there is input. +Return non-nil iff we received any output before the timeout expired. */) + (process, timeout, timeout_msecs) register Lisp_Object process, timeout, timeout_msecs; { int seconds; int useconds; if (! NILP (process)) - CHECK_PROCESS (process, 0); + CHECK_PROCESS (process); if (! NILP (timeout_msecs)) { - CHECK_NUMBER (timeout_msecs, 2); + CHECK_NUMBER (timeout_msecs); useconds = XINT (timeout_msecs); if (!INTEGERP (timeout)) XSETINT (timeout, 0); @@ -2252,7 +3401,7 @@ Return non-nil iff we received any output before the timeout expired.") if (! NILP (timeout)) { - CHECK_NUMBER (timeout, 1); + CHECK_NUMBER (timeout); seconds = XINT (timeout); if (seconds < 0 || (seconds == 0 && useconds == 0)) seconds = -1; @@ -2273,6 +3422,202 @@ Return non-nil iff we received any output before the timeout expired.") ? Qt : Qnil); } +/* Accept a connection for server process SERVER on CHANNEL. */ + +static int connect_counter = 0; + +static void +server_accept_connection (server, channel) + Lisp_Object server; + int channel; +{ + Lisp_Object proc, caller, name, buffer; + Lisp_Object contact, host, service; + struct Lisp_Process *ps= XPROCESS (server); + struct Lisp_Process *p; + int s; + union u_sockaddr { + struct sockaddr sa; + struct sockaddr_in in; +#ifdef HAVE_LOCAL_SOCKETS + struct sockaddr_un un; +#endif + } saddr; + int len = sizeof saddr; + + s = accept (channel, &saddr.sa, &len); + + if (s < 0) + { + int code = errno; + + if (code == EAGAIN) + return; +#ifdef EWOULDBLOCK + if (code == EWOULDBLOCK) + return; +#endif + + if (!NILP (ps->log)) + call3 (ps->log, server, Qnil, + concat3 (build_string ("accept failed with code"), + Fnumber_to_string (make_number (code)), + build_string ("\n"))); + return; + } + + connect_counter++; + + /* Setup a new process to handle the connection. */ + + /* Generate a unique identification of the caller, and build contact + information for this process. */ + host = Qt; + service = Qnil; + switch (saddr.sa.sa_family) + { + case AF_INET: + { + Lisp_Object args[5]; + unsigned char *ip = (unsigned char *)&saddr.in.sin_addr.s_addr; + args[0] = build_string ("%d.%d.%d.%d"); + args[1] = make_number (*ip++); + args[2] = make_number (*ip++); + args[3] = make_number (*ip++); + args[4] = make_number (*ip++); + host = Fformat (5, args); + service = make_number (ntohs (saddr.in.sin_port)); + + args[0] = build_string (" <%s:%d>"); + args[1] = host; + args[2] = service; + caller = Fformat (3, args); + } + break; + +#ifdef HAVE_LOCAL_SOCKETS + case AF_LOCAL: +#endif + default: + caller = Fnumber_to_string (make_number (connect_counter)); + caller = concat3 (build_string (" <*"), caller, build_string ("*>")); + break; + } + + /* Create a new buffer name for this process if it doesn't have a + filter. The new buffer name is based on the buffer name or + process name of the server process concatenated with the caller + identification. */ + + if (!NILP (ps->filter) && !EQ (ps->filter, Qt)) + buffer = Qnil; + else + { + buffer = ps->buffer; + if (!NILP (buffer)) + buffer = Fbuffer_name (buffer); + else + buffer = ps->name; + if (!NILP (buffer)) + { + buffer = concat2 (buffer, caller); + buffer = Fget_buffer_create (buffer); + } + } + + /* Generate a unique name for the new server process. Combine the + server process name with the caller identification. */ + + name = concat2 (ps->name, caller); + proc = make_process (name); + + chan_process[s] = proc; + +#ifdef O_NONBLOCK + fcntl (s, F_SETFL, O_NONBLOCK); +#else +#ifdef O_NDELAY + fcntl (s, F_SETFL, O_NDELAY); +#endif +#endif + + p = XPROCESS (proc); + + /* Build new contact information for this setup. */ + contact = Fcopy_sequence (ps->childp); + contact = Fplist_put (contact, QCserver, Qnil); + contact = Fplist_put (contact, QChost, host); + if (!NILP (service)) + contact = Fplist_put (contact, QCservice, service); + contact = Fplist_put (contact, QCremote, + conv_sockaddr_to_lisp (&saddr.sa, len)); +#ifdef HAVE_GETSOCKNAME + len = sizeof saddr; + if (getsockname (channel, &saddr.sa, &len) == 0) + contact = Fplist_put (contact, QClocal, + conv_sockaddr_to_lisp (&saddr.sa, len)); +#endif + + p->childp = contact; + p->buffer = buffer; + p->sentinel = ps->sentinel; + p->filter = ps->filter; + p->command = Qnil; + p->pid = Qnil; + XSETINT (p->infd, s); + XSETINT (p->outfd, s); + p->status = Qrun; + + /* Client processes for accepted connections are not stopped initially. */ + if (!EQ (p->filter, Qt)) + { + FD_SET (s, &input_wait_mask); + FD_SET (s, &non_keyboard_wait_mask); + } + + if (s > max_process_desc) + max_process_desc = s; + + /* Setup coding system for new process based on server process. + This seems to be the proper thing to do, as the coding system + of the new process should reflect the settings at the time the + server socket was opened; not the current settings. */ + + p->decode_coding_system = ps->decode_coding_system; + p->encode_coding_system = ps->encode_coding_system; + + if (!proc_decode_coding_system[s]) + proc_decode_coding_system[s] + = (struct coding_system *) xmalloc (sizeof (struct coding_system)); + setup_coding_system (p->decode_coding_system, + proc_decode_coding_system[s]); + if (!proc_encode_coding_system[s]) + proc_encode_coding_system[s] + = (struct coding_system *) xmalloc (sizeof (struct coding_system)); + setup_coding_system (p->encode_coding_system, + proc_encode_coding_system[s]); + + p->decoding_buf = make_uninit_string (0); + p->decoding_carryover = make_number (0); + p->encoding_buf = make_uninit_string (0); + p->encoding_carryover = make_number (0); + + p->inherit_coding_system_flag + = (NILP (buffer) ? Qnil : ps->inherit_coding_system_flag); + + if (!NILP (ps->log)) + call3 (ps->log, server, proc, + concat3 (build_string ("accept from "), + (STRINGP (host) ? host : build_string ("-")), + build_string ("\n"))); + + if (!NILP (p->sentinel)) + exec_sentinel (proc, + concat3 (build_string ("open from "), + (STRINGP (host) ? host : build_string ("-")), + build_string ("\n"))); +} + /* This variable is different from waiting_for_input in keyboard.c. It is used to communicate to a lisp process-filter/sentinel (via the function Fwaiting_for_user_input_p below) whether emacs was waiting @@ -2330,16 +3675,20 @@ wait_reading_process_input (time_limit, microsecs, read_kbd, do_display) { register int channel, nfds; static SELECT_TYPE Available; + static SELECT_TYPE Connecting; + int check_connect, no_avail; int xerrno; Lisp_Object proc; EMACS_TIME timeout, end_time; - SELECT_TYPE Atemp; int wait_channel = -1; struct Lisp_Process *wait_proc = 0; int got_some_input = 0; - Lisp_Object *wait_for_cell = 0; + /* Either nil or a cons cell, the car of which is of interest and + may be changed outside of this routine. */ + Lisp_Object wait_for_cell = Qnil; FD_ZERO (&Available); + FD_ZERO (&Connecting); /* If read_kbd is a process to watch, set wait_proc and wait_channel accordingly. */ @@ -2353,7 +3702,7 @@ wait_reading_process_input (time_limit, microsecs, read_kbd, do_display) /* If waiting for non-nil in a cell, record where. */ if (CONSP (read_kbd)) { - wait_for_cell = &XCAR (read_kbd); + wait_for_cell = read_kbd; XSETFASTINT (read_kbd, 0); } @@ -2372,7 +3721,9 @@ wait_reading_process_input (time_limit, microsecs, read_kbd, do_display) HP-UX 10.10 seem to have problems with signals coming in Causes "poll: interrupted system call" messages when Emacs is run in an X window - Turn off periodic alarms (in case they are in use) */ + Turn off periodic alarms (in case they are in use), + and then turn off any other atimers. */ + stop_polling (); turn_on_atimers (0); #endif @@ -2380,11 +3731,6 @@ wait_reading_process_input (time_limit, microsecs, read_kbd, do_display) { int timeout_reduced_for_timers = 0; -#ifdef HAVE_X_WINDOWS - if (display_busy_cursor_p) - Fx_hide_busy_cursor (Qnil); -#endif - /* If calling from keyboard input, do not quit since we want to return C-g as an input character. Otherwise, do pending quit if requested. */ @@ -2392,7 +3738,7 @@ wait_reading_process_input (time_limit, microsecs, read_kbd, do_display) QUIT; /* Exit now if the cell we're waiting for became non-nil. */ - if (wait_for_cell && ! NILP (*wait_for_cell)) + if (! NILP (wait_for_cell) && ! NILP (XCAR (wait_for_cell))) break; /* Compute time from now till when time limit is up */ @@ -2421,21 +3767,32 @@ wait_reading_process_input (time_limit, microsecs, read_kbd, do_display) But not if wait_for_cell; in those cases, the wait is supposed to be short, and those callers cannot handle running arbitrary Lisp code here. */ - if (! wait_for_cell) + if (NILP (wait_for_cell)) { EMACS_TIME timer_delay; - int old_timers_run; - retry: - old_timers_run = timers_run; - timer_delay = timer_check (1); - if (timers_run != old_timers_run && do_display) + do { - redisplay_preserve_echo_area (); - /* We must retry, since a timer may have requeued itself - and that could alter the time_delay. */ - goto retry; + int old_timers_run = timers_run; + struct buffer *old_buffer = current_buffer; + + timer_delay = timer_check (1); + + /* If a timer has run, this might have changed buffers + an alike. Make read_key_sequence aware of that. */ + if (timers_run != old_timers_run + && old_buffer != current_buffer + && waiting_for_user_input_p == -1) + record_asynch_buffer_change (); + + if (timers_run != old_timers_run && do_display) + /* We must retry, since a timer may have requeued itself + and that could alter the time_delay. */ + redisplay_preserve_echo_area (9); + else + break; } + while (!detect_input_pending ()); /* If there is unread keyboard input, also return. */ if (XINT (read_kbd) != 0 @@ -2475,11 +3832,23 @@ wait_reading_process_input (time_limit, microsecs, read_kbd, do_display) timeout to get our attention. */ if (update_tick != process_tick && do_display) { + SELECT_TYPE Atemp, Ctemp; + Atemp = input_wait_mask; +#ifdef MAC_OSX + /* On Mac OS X, the SELECT system call always says input is + present (for reading) at stdin, even when none is. This + causes the call to SELECT below to return 1 and + status_notify not to be called. As a result output of + subprocesses are incorrectly discarded. */ + FD_CLR (0, &Atemp); +#endif + Ctemp = connect_wait_mask; EMACS_SET_SECS_USECS (timeout, 0, 0); if ((select (max (max_process_desc, max_keyboard_desc) + 1, - &Atemp, (SELECT_TYPE *)0, (SELECT_TYPE *)0, - &timeout) + &Atemp, + (num_pending_connects > 0 ? &Ctemp : (SELECT_TYPE *)0), + (SELECT_TYPE *)0, &timeout) <= 0)) { /* It's okay for us to do this and then continue with @@ -2489,11 +3858,13 @@ wait_reading_process_input (time_limit, microsecs, read_kbd, do_display) } } - /* Don't wait for output from a non-running process. */ + /* Don't wait for output from a non-running process. Just + read whatever data has already been received. */ if (wait_proc != 0 && !NILP (wait_proc->raw_status_low)) update_status (wait_proc); if (wait_proc != 0 - && ! EQ (wait_proc->status, Qrun)) + && ! EQ (wait_proc->status, Qrun) + && ! EQ (wait_proc->status, Qconnect)) { int nread, total_nread = 0; @@ -2524,19 +3895,26 @@ wait_reading_process_input (time_limit, microsecs, read_kbd, do_display) #endif } if (total_nread > 0 && do_display) - redisplay_preserve_echo_area (); + redisplay_preserve_echo_area (10); break; } /* Wait till there is something to do */ - if (wait_for_cell) - Available = non_process_wait_mask; - else if (! XINT (read_kbd)) - Available = non_keyboard_wait_mask; + if (!NILP (wait_for_cell)) + { + Available = non_process_wait_mask; + check_connect = 0; + } else - Available = input_wait_mask; + { + if (! XINT (read_kbd)) + Available = non_keyboard_wait_mask; + else + Available = input_wait_mask; + check_connect = (num_pending_connects > 0); + } /* If frame size has changed or the window is newly mapped, redisplay now, before we start to wait. There is a race @@ -2546,20 +3924,26 @@ wait_reading_process_input (time_limit, microsecs, read_kbd, do_display) if (frame_garbaged && do_display) { clear_waiting_for_input (); - redisplay_preserve_echo_area (); + redisplay_preserve_echo_area (11); if (XINT (read_kbd) < 0) set_waiting_for_input (&timeout); } + no_avail = 0; if (XINT (read_kbd) && detect_input_pending ()) { nfds = 0; - FD_ZERO (&Available); + no_avail = 1; } else - nfds = select (max (max_process_desc, max_keyboard_desc) + 1, - &Available, (SELECT_TYPE *)0, (SELECT_TYPE *)0, - &timeout); + { + if (check_connect) + Connecting = connect_wait_mask; + nfds = select (max (max_process_desc, max_keyboard_desc) + 1, + &Available, + (check_connect ? &Connecting : (SELECT_TYPE *)0), + (SELECT_TYPE *)0, &timeout); + } xerrno = errno; @@ -2575,7 +3959,7 @@ wait_reading_process_input (time_limit, microsecs, read_kbd, do_display) if (nfds < 0) { if (xerrno == EINTR) - FD_ZERO (&Available); + no_avail = 1; #ifdef ultrix /* Ultrix select seems to return ENOMEM when it is interrupted. Treat it just like EINTR. Bleah. Note @@ -2583,13 +3967,13 @@ wait_reading_process_input (time_limit, microsecs, read_kbd, do_display) "__ultrix__"; the latter is only defined under GCC, but not by DEC's bundled CC. -JimB */ else if (xerrno == ENOMEM) - FD_ZERO (&Available); + no_avail = 1; #endif #ifdef ALLIANT /* This happens for no known reason on ALLIANT. I am guessing that this is the right response. -- RMS. */ else if (xerrno == EFAULT) - FD_ZERO (&Available); + no_avail = 1; #endif else if (xerrno == EBADF) { @@ -2601,7 +3985,7 @@ wait_reading_process_input (time_limit, microsecs, read_kbd, do_display) So, SIGHUP is ignored (see def of PTY_TTY_NAME_SPRINTF in m/ibmrt-aix.h), and here we just ignore the select error. Cleanup occurs c/o status_notify after SIGCLD. */ - FD_ZERO (&Available); /* Cannot depend on values returned */ + no_avail = 1; /* Cannot depend on values returned */ #else abort (); #endif @@ -2609,9 +3993,16 @@ wait_reading_process_input (time_limit, microsecs, read_kbd, do_display) else error ("select error: %s", emacs_strerror (xerrno)); } + + if (no_avail) + { + FD_ZERO (&Available); + check_connect = 0; + } + #if defined(sun) && !defined(USG5_4) - else if (nfds > 0 && keyboard_bit_set (&Available) - && interrupt_input) + if (nfds > 0 && keyboard_bit_set (&Available) + && interrupt_input) /* System sometimes fails to deliver SIGIO. David J. Mackenzie says that Emacs doesn't compile under @@ -2641,14 +4032,30 @@ wait_reading_process_input (time_limit, microsecs, read_kbd, do_display) /* If there is any, return immediately to give it higher priority than subprocesses */ - if (XINT (read_kbd) != 0 - && detect_input_pending_run_timers (do_display)) + if (XINT (read_kbd) != 0) { - swallow_events (do_display); + int old_timers_run = timers_run; + struct buffer *old_buffer = current_buffer; + int leave = 0; + if (detect_input_pending_run_timers (do_display)) - break; - } + { + swallow_events (do_display); + if (detect_input_pending_run_timers (do_display)) + leave = 1; + } + + /* If a timer has run, this might have changed buffers + an alike. Make read_key_sequence aware of that. */ + if (timers_run != old_timers_run + && waiting_for_user_input_p == -1 + && old_buffer != current_buffer) + record_asynch_buffer_change (); + if (leave) + break; + } + /* If there is unread keyboard input, also return. */ if (XINT (read_kbd) != 0 && requeued_events_pending_p ()) @@ -2671,7 +4078,7 @@ wait_reading_process_input (time_limit, microsecs, read_kbd, do_display) } /* Exit now if the cell we're waiting for became non-nil. */ - if (wait_for_cell && ! NILP (*wait_for_cell)) + if (! NILP (wait_for_cell) && ! NILP (XCAR (wait_for_cell))) break; #ifdef SIGIO @@ -2690,10 +4097,13 @@ wait_reading_process_input (time_limit, microsecs, read_kbd, do_display) /* If checking input just got us a size-change event from X, obey it now if we should. */ - if (XINT (read_kbd) || wait_for_cell) + if (XINT (read_kbd) || ! NILP (wait_for_cell)) do_pending_window_change (0); /* Check for data from a process. */ + if (no_avail || nfds == 0) + continue; + /* Really FIRST_PROC_DESC should be 0 on Unix, but this is safer in the short run. */ for (channel = 0; channel <= max_process_desc; channel++) @@ -2716,6 +4126,13 @@ wait_reading_process_input (time_limit, microsecs, read_kbd, do_display) if (NILP (proc)) continue; + /* If this is a server stream socket, accept connection. */ + if (EQ (XPROCESS (proc)->status, Qlisten)) + { + server_accept_connection (proc, channel); + continue; + } + /* Read data from the process, starting with our buffered-ahead character if we have one. */ @@ -2729,7 +4146,7 @@ wait_reading_process_input (time_limit, microsecs, read_kbd, do_display) FD_ZERO (&Available); if (do_display) - redisplay_preserve_echo_area (); + redisplay_preserve_echo_area (12); } #ifdef EWOULDBLOCK else if (nread == -1 && errno == EWOULDBLOCK) @@ -2773,18 +4190,79 @@ wait_reading_process_input (time_limit, microsecs, read_kbd, do_display) else if (nread == 0 && !NETCONN_P (proc)) ; #endif - else + else + { + /* Preserve status of processes already terminated. */ + XSETINT (XPROCESS (proc)->tick, ++process_tick); + deactivate_process (proc); + if (!NILP (XPROCESS (proc)->raw_status_low)) + update_status (XPROCESS (proc)); + if (EQ (XPROCESS (proc)->status, Qrun)) + XPROCESS (proc)->status + = Fcons (Qexit, Fcons (make_number (256), Qnil)); + } + } +#ifdef NON_BLOCKING_CONNECT + if (check_connect && FD_ISSET (channel, &Connecting)) + { + struct Lisp_Process *p; + + FD_CLR (channel, &connect_wait_mask); + if (--num_pending_connects < 0) + abort (); + + proc = chan_process[channel]; + if (NILP (proc)) + continue; + + p = XPROCESS (proc); + +#ifdef GNU_LINUX + /* getsockopt(,,SO_ERROR,,) is said to hang on some systems. + So only use it on systems where it is known to work. */ + { + int xlen = sizeof(xerrno); + if (getsockopt(channel, SOL_SOCKET, SO_ERROR, &xerrno, &xlen)) + xerrno = errno; + } +#else + { + struct sockaddr pname; + int pnamelen = sizeof(pname); + + /* If connection failed, getpeername will fail. */ + xerrno = 0; + if (getpeername(channel, &pname, &pnamelen) < 0) + { + /* Obtain connect failure code through error slippage. */ + char dummy; + xerrno = errno; + if (errno == ENOTCONN && read(channel, &dummy, 1) < 0) + xerrno = errno; + } + } +#endif + if (xerrno) { - /* Preserve status of processes already terminated. */ - XSETINT (XPROCESS (proc)->tick, ++process_tick); + XSETINT (p->tick, ++process_tick); + p->status = Fcons (Qfailed, Fcons (make_number (xerrno), Qnil)); deactivate_process (proc); - if (!NILP (XPROCESS (proc)->raw_status_low)) - update_status (XPROCESS (proc)); - if (EQ (XPROCESS (proc)->status, Qrun)) - XPROCESS (proc)->status - = Fcons (Qexit, Fcons (make_number (256), Qnil)); + } + else + { + p->status = Qrun; + /* Execute the sentinel here. If we had relied on + status_notify to do it later, it will read input + from the process before calling the sentinel. */ + exec_sentinel (proc, build_string ("open\n")); + if (!EQ (p->filter, Qt) && !EQ (p->command, Qt)) + { + FD_SET (XINT (p->infd), &input_wait_mask); + FD_SET (XINT (p->infd), &non_keyboard_wait_mask); + } } } +#endif /* NON_BLOCKING_CONNECT */ } /* end for each file descriptor */ } /* end while exit conditions not met */ @@ -2808,12 +4286,6 @@ wait_reading_process_input (time_limit, microsecs, read_kbd, do_display) start_polling (); #endif -#ifdef HAVE_X_WINDOWS - if (display_busy_cursor_p) - if (!inhibit_busy_cursor) - Fx_show_busy_cursor (); -#endif - return got_some_input; } @@ -2855,19 +4327,13 @@ read_process_output (proc, channel) { register int nchars, nbytes; char *chars; -#ifdef VMS - int chars_allocated = 0; /* If 1, `chars' should be freed later. */ -#else - char buf[1024]; -#endif register Lisp_Object outstream; register struct buffer *old = current_buffer; register struct Lisp_Process *p = XPROCESS (proc); register int opoint; struct coding_system *coding = proc_decode_coding_system[channel]; - int chars_in_decoding_buf = 0; /* If 1, `chars' points - XSTRING (p->decoding_buf)->data. */ int carryover = XINT (p->decoding_carryover); + int readmax = 1024; #ifdef VMS VMS_PROC_STUFF *vs, *get_vms_process_pointer(); @@ -2894,42 +4360,54 @@ read_process_output (proc, channel) /* The data carried over in the previous decoding (which are at the tail of decoding buffer) should be prepended to the new data read to decode all together. */ - char *buf = (char *) xmalloc (nbytes + carryover); - - bcopy (XSTRING (p->decoding_buf)->data - + STRING_BYTES (XSTRING (p->decoding_buf)) - carryover, - buf, carryover); - bcopy (chars, buf + carryover, nbytes); - chars = buf; - chars_allocated = 1; + chars = (char *) alloca (nbytes + carryover); + bcopy (SDATA (p->decoding_buf), buf, carryover); + bcopy (vs->inputBuffer, chars + carryover, nbytes); } #else /* not VMS */ +#ifdef DATAGRAM_SOCKETS + /* A datagram is one packet; allow at least 1500+ bytes of data + corresponding to the typical Ethernet frame size. */ + if (DATAGRAM_CHAN_P (channel)) + { + /* carryover = 0; */ /* Does carryover make sense for datagrams? */ + readmax += 1024; + } +#endif + + chars = (char *) alloca (carryover + readmax); if (carryover) /* See the comment above. */ - bcopy (XSTRING (p->decoding_buf)->data - + STRING_BYTES (XSTRING (p->decoding_buf)) - carryover, - buf, carryover); + bcopy (SDATA (p->decoding_buf), chars, carryover); +#ifdef DATAGRAM_SOCKETS + /* We have a working select, so proc_buffered_char is always -1. */ + if (DATAGRAM_CHAN_P (channel)) + { + int len = datagram_address[channel].len; + nbytes = recvfrom (channel, chars + carryover, readmax - carryover, + 0, datagram_address[channel].sa, &len); + } + else +#endif if (proc_buffered_char[channel] < 0) - nbytes = emacs_read (channel, buf + carryover, (sizeof buf) - carryover); + nbytes = emacs_read (channel, chars + carryover, readmax - carryover); else { - buf[carryover] = proc_buffered_char[channel]; + chars[carryover] = proc_buffered_char[channel]; proc_buffered_char[channel] = -1; - nbytes = emacs_read (channel, buf + carryover + 1, - (sizeof buf) - carryover - 1); + nbytes = emacs_read (channel, chars + carryover + 1, readmax - 1 - carryover); if (nbytes < 0) nbytes = 1; else nbytes = nbytes + 1; } - chars = buf; #endif /* not VMS */ XSETINT (p->decoding_carryover, 0); - /* At this point, NBYTES holds number of characters just received + /* At this point, NBYTES holds number of bytes just received (including the one in proc_buffered_char[channel]). */ if (nbytes <= 0) { @@ -2940,109 +4418,6 @@ read_process_output (proc, channel) /* Now set NBYTES how many bytes we must decode. */ nbytes += carryover; - nchars = nbytes; - - if (CODING_MAY_REQUIRE_DECODING (coding)) - { - int require = decoding_buffer_size (coding, nbytes); - int result; - - if (STRING_BYTES (XSTRING (p->decoding_buf)) < require) - p->decoding_buf = make_uninit_string (require); - result = decode_coding (coding, chars, XSTRING (p->decoding_buf)->data, - nbytes, STRING_BYTES (XSTRING (p->decoding_buf))); - carryover = nbytes - coding->consumed; - if (carryover > 0) - { - /* Copy the carryover bytes to the end of p->decoding_buf, to - be processed on the next read. Since decoding_buffer_size - asks for an extra amount of space beyond the maximum - expected for the output, there should always be sufficient - space for the carryover (which is by definition a sequence - of bytes that was not long enough to be decoded, and thus - has a bounded length). */ - if (STRING_BYTES (XSTRING (p->decoding_buf)) - < coding->produced + carryover) - abort (); - bcopy (chars + coding->consumed, - XSTRING (p->decoding_buf)->data - + STRING_BYTES (XSTRING (p->decoding_buf)) - carryover, - carryover); - XSETINT (p->decoding_carryover, carryover); - } - - /* A new coding system might be found by `decode_coding'. */ - if (!EQ (p->decode_coding_system, coding->symbol)) - { - p->decode_coding_system = coding->symbol; - - /* Don't call setup_coding_system for - proc_decode_coding_system[channel] here. It is done in - detect_coding called via decode_coding above. */ - - /* If a coding system for encoding is not yet decided, we set - it as the same as coding-system for decoding. - - But, before doing that we must check if - proc_encode_coding_system[p->outfd] surely points to a - valid memory because p->outfd will be changed once EOF is - sent to the process. */ - if (NILP (p->encode_coding_system) - && proc_encode_coding_system[XINT (p->outfd)]) - { - p->encode_coding_system = coding->symbol; - setup_coding_system (coding->symbol, - proc_encode_coding_system[XINT (p->outfd)]); - } - } - -#ifdef VMS - /* Now we don't need the contents of `chars'. */ - if (chars_allocated) - free (chars); -#endif - if (coding->produced == 0) - return 0; - chars = (char *) XSTRING (p->decoding_buf)->data; - nbytes = coding->produced; - nchars = (coding->fake_multibyte - ? multibyte_chars_in_text (chars, nbytes) - : coding->produced_char); - chars_in_decoding_buf = 1; - } - else - { -#ifdef VMS - if (chars_allocated) - { - /* Although we don't have to decode the received data, we - must move it to an area which we don't have to free. */ - if (! STRINGP (p->decoding_buf) - || STRING_BYTES (XSTRING (p->decoding_buf)) < nbytes) - p->decoding_buf = make_uninit_string (nbytes); - bcopy (chars, XSTRING (p->decoding_buf)->data, nbytes); - free (chars); - chars = XSTRING (p->decoding_buf)->data; - chars_in_decoding_buf = 1; - } -#endif - nchars = multibyte_chars_in_text (chars, nbytes); - } - - Vlast_coding_system_used = coding->symbol; - - /* If the caller required, let the process associated buffer - inherit the coding-system used to decode the process output. */ - if (! NILP (p->inherit_coding_system_flag) - && !NILP (p->buffer) && !NILP (XBUFFER (p->buffer)->name)) - { - struct buffer *prev_buf = current_buffer; - - Fset_buffer (p->buffer); - call1 (intern ("after-insert-file-set-buffer-file-coding-system"), - make_number (nbytes)); - set_buffer_internal (prev_buf); - } /* Read and dispose of the process output. */ outstream = p->filter; @@ -3051,7 +4426,7 @@ read_process_output (proc, channel) /* We inhibit quit here instead of just catching it so that hitting ^G when a filter happens to be running won't screw it up. */ - int count = specpdl_ptr - specpdl; + int count = SPECPDL_INDEX (); Lisp_Object odeactivate; Lisp_Object obuffer, okeymap; Lisp_Object text; @@ -3084,19 +4459,50 @@ read_process_output (proc, channel) save the match data in a special nonrecursive fashion. */ running_asynch_code = 1; - /* The multibyteness of a string given to the filter is decided - by which coding system we used for decoding. */ - if (coding->type == coding_type_no_conversion - || coding->type == coding_type_raw_text) - text = make_unibyte_string (chars, nbytes); - else - text = make_multibyte_string (chars, nchars, nbytes); + text = decode_coding_string (make_unibyte_string (chars, nbytes), + coding, 0); + if (NILP (buffer_defaults.enable_multibyte_characters)) + /* We had better return unibyte string. */ + text = string_make_unibyte (text); + + Vlast_coding_system_used = coding->symbol; + /* A new coding system might be found. */ + if (!EQ (p->decode_coding_system, coding->symbol)) + { + p->decode_coding_system = coding->symbol; + + /* Don't call setup_coding_system for + proc_decode_coding_system[channel] here. It is done in + detect_coding called via decode_coding above. */ + + /* If a coding system for encoding is not yet decided, we set + it as the same as coding-system for decoding. + + But, before doing that we must check if + proc_encode_coding_system[p->outfd] surely points to a + valid memory because p->outfd will be changed once EOF is + sent to the process. */ + if (NILP (p->encode_coding_system) + && proc_encode_coding_system[XINT (p->outfd)]) + { + p->encode_coding_system = coding->symbol; + setup_coding_system (coding->symbol, + proc_encode_coding_system[XINT (p->outfd)]); + } + } - internal_condition_case_1 (read_process_output_call, - Fcons (outstream, - Fcons (proc, Fcons (text, Qnil))), - !NILP (Vdebug_on_error) ? Qnil : Qerror, - read_process_output_error_handler); + carryover = nbytes - coding->consumed; + bcopy (chars + coding->consumed, SDATA (p->decoding_buf), + carryover); + XSETINT (p->decoding_carryover, carryover); + nbytes = SBYTES (text); + nchars = SCHARS (text); + if (nbytes > 0) + internal_condition_case_1 (read_process_output_call, + Fcons (outstream, + Fcons (proc, Fcons (text, Qnil))), + !NILP (Vdebug_on_error) ? Qnil : Qerror, + read_process_output_error_handler); /* If we saved the match data nonrecursively, restore it now. */ restore_match_data (); @@ -3137,6 +4543,8 @@ read_process_output (proc, channel) Lisp_Object odeactivate; int before, before_byte; int opoint_byte; + Lisp_Object text; + struct buffer *b; odeactivate = Vdeactivate_mark; @@ -3168,28 +4576,46 @@ read_process_output (proc, channel) if (! (BEGV <= PT && PT <= ZV)) Fwiden (); - if (NILP (current_buffer->enable_multibyte_characters)) - nchars = nbytes; - - /* Insert before markers in case we are inserting where - the buffer's mark is, and the user's next command is Meta-y. */ - if (chars_in_decoding_buf) + text = decode_coding_string (make_unibyte_string (chars, nbytes), + coding, 0); + Vlast_coding_system_used = coding->symbol; + /* A new coding system might be found. See the comment in the + similar code in the previous `if' block. */ + if (!EQ (p->decode_coding_system, coding->symbol)) { - /* Since multibyteness of p->docoding_buf is corrupted, we - can't use insert_from_string_before_markers. */ - char *temp_buf; - - temp_buf = (char *) alloca (nbytes); - bcopy (XSTRING (p->decoding_buf)->data, temp_buf, nbytes); - insert_before_markers (temp_buf, nbytes); + p->decode_coding_system = coding->symbol; + if (NILP (p->encode_coding_system) + && proc_encode_coding_system[XINT (p->outfd)]) + { + p->encode_coding_system = coding->symbol; + setup_coding_system (coding->symbol, + proc_encode_coding_system[XINT (p->outfd)]); + } } + carryover = nbytes - coding->consumed; + bcopy (chars + coding->consumed, SDATA (p->decoding_buf), + carryover); + XSETINT (p->decoding_carryover, carryover); + /* Adjust the multibyteness of TEXT to that of the buffer. */ + if (NILP (current_buffer->enable_multibyte_characters) + != ! STRING_MULTIBYTE (text)) + text = (STRING_MULTIBYTE (text) + ? Fstring_as_unibyte (text) + : Fstring_as_multibyte (text)); + nbytes = SBYTES (text); + nchars = SCHARS (text); + /* Insert before markers in case we are inserting where + the buffer's mark is, and the user's next command is Meta-y. */ + insert_from_string_before_markers (text, 0, 0, nchars, nbytes, 0); + + /* Make sure the process marker's position is valid when the + process buffer is changed in the signal_after_change above. + W3 is known to do that. */ + if (BUFFERP (p->buffer) + && (b = XBUFFER (p->buffer), b != current_buffer)) + set_marker_both (p->mark, p->buffer, BUF_PT (b), BUF_PT_BYTE (b)); else - { - insert_1_both (chars, nchars, nbytes, 0, 1, 1); - signal_after_change (before, 0, PT - before); - update_compositions (before, PT, CHECK_BORDER); - } - set_marker_both (p->mark, p->buffer, PT, PT_BYTE); + set_marker_both (p->mark, p->buffer, PT, PT_BYTE); update_mode_lines++; @@ -3230,9 +4656,9 @@ read_process_output (proc, channel) DEFUN ("waiting-for-user-input-p", Fwaiting_for_user_input_p, Swaiting_for_user_input_p, 0, 0, 0, - "Returns non-nil if emacs is waiting for input from the user.\n\ -This is intended for use by asynchronous process output filters and sentinels.") - () + doc: /* Returns non-nil if emacs is waiting for input from the user. +This is intended for use by asynchronous process output filters and sentinels. */) + () { return (waiting_for_user_input_p ? Qt : Qnil); } @@ -3240,6 +4666,7 @@ This is intended for use by asynchronous process output filters and sentinels.") /* Sending data to subprocess */ jmp_buf send_process_frame; +Lisp_Object process_sent_to; SIGTYPE send_process_trap () @@ -3253,27 +4680,25 @@ send_process_trap () /* Send some data to process PROC. BUF is the beginning of the data; LEN is the number of characters. - OBJECT is the Lisp object that the data comes from. + OBJECT is the Lisp object that the data comes from. If OBJECT is + nil or t, it means that the data comes from C string. + + If OBJECT is not nil, the data is encoded by PROC's coding-system + for encoding before it is sent. - The data is encoded by PROC's coding-system for encoding before it - is sent. But if the data ends at the middle of multi-byte - representation, that incomplete sequence of bytes are sent without - being encoded. Should we store them in a buffer to prepend them to - the data send later? */ + This function can evaluate Lisp code and can garbage collect. */ void send_process (proc, buf, len, object) volatile Lisp_Object proc; - unsigned char *buf; - int len; - Lisp_Object object; + unsigned char *volatile buf; + volatile int len; + volatile Lisp_Object object; { /* Use volatile to protect variables from being clobbered by longjmp. */ int rv; - volatile unsigned char *procname = XSTRING (XPROCESS (proc)->name)->data; struct coding_system *coding; struct gcpro gcpro1; - int carryover = XINT (XPROCESS (proc)->encoding_carryover); GCPRO1 (object); @@ -3285,67 +4710,91 @@ send_process (proc, buf, len, object) if (! NILP (XPROCESS (proc)->raw_status_low)) update_status (XPROCESS (proc)); if (! EQ (XPROCESS (proc)->status, Qrun)) - error ("Process %s not running", procname); + error ("Process %s not running", + SDATA (XPROCESS (proc)->name)); if (XINT (XPROCESS (proc)->outfd) < 0) - error ("Output file descriptor of %s is closed", procname); + error ("Output file descriptor of %s is closed", + SDATA (XPROCESS (proc)->name)); coding = proc_encode_coding_system[XINT (XPROCESS (proc)->outfd)]; Vlast_coding_system_used = coding->symbol; + if ((STRINGP (object) && STRING_MULTIBYTE (object)) + || (BUFFERP (object) + && !NILP (XBUFFER (object)->enable_multibyte_characters)) + || EQ (object, Qt)) + { + if (!EQ (coding->symbol, XPROCESS (proc)->encode_coding_system)) + /* The coding system for encoding was changed to raw-text + because we sent a unibyte text previously. Now we are + sending a multibyte text, thus we must encode it by the + original coding system specified for the current + process. */ + setup_coding_system (XPROCESS (proc)->encode_coding_system, coding); + /* src_multibyte should be set to 1 _after_ a call to + setup_coding_system, since it resets src_multibyte to + zero. */ + coding->src_multibyte = 1; + } + else + { + /* For sending a unibyte text, character code conversion should + not take place but EOL conversion should. So, setup raw-text + or one of the subsidiary if we have not yet done it. */ + if (coding->type != coding_type_raw_text) + { + if (CODING_REQUIRE_FLUSHING (coding)) + { + /* But, before changing the coding, we must flush out data. */ + coding->mode |= CODING_MODE_LAST_BLOCK; + send_process (proc, "", 0, Qt); + } + coding->src_multibyte = 0; + setup_raw_text_coding_system (coding); + } + } + coding->dst_multibyte = 0; + if (CODING_REQUIRE_ENCODING (coding)) { int require = encoding_buffer_size (coding, len); - int offset; + int from_byte = -1, from = -1, to = -1; unsigned char *temp_buf = NULL; - /* Remember the offset of data because a string or a buffer may - be relocated. Setting OFFSET to -1 means we don't have to - care about relocation. */ - offset = (BUFFERP (object) - ? BUF_PTR_BYTE_POS (XBUFFER (object), buf) - : (STRINGP (object) - ? buf - XSTRING (object)->data - : -1)); - - if (carryover > 0) + if (BUFFERP (object)) { - temp_buf = (unsigned char *) xmalloc (len + carryover); - - if (offset >= 0) - { - if (BUFFERP (object)) - buf = BUF_BYTE_ADDRESS (XBUFFER (object), offset); - else if (STRINGP (object)) - buf = offset + XSTRING (object)->data; - /* Now we don't have to care about relocation. */ - offset = -1; - } - bcopy ((XSTRING (XPROCESS (proc)->encoding_buf)->data - + STRING_BYTES (XSTRING (XPROCESS (proc)->encoding_buf)) - - carryover), - temp_buf, - carryover); - bcopy (buf, temp_buf + carryover, len); - buf = temp_buf; + from_byte = BUF_PTR_BYTE_POS (XBUFFER (object), buf); + from = buf_bytepos_to_charpos (XBUFFER (object), from_byte); + to = buf_bytepos_to_charpos (XBUFFER (object), from_byte + len); } - - if (STRING_BYTES (XSTRING (XPROCESS (proc)->encoding_buf)) < require) + else if (STRINGP (object)) { - XPROCESS (proc)->encoding_buf = make_uninit_string (require); + from_byte = buf - SDATA (object); + from = string_byte_to_char (object, from_byte); + to = string_byte_to_char (object, from_byte + len); + } - if (offset >= 0) - { - if (BUFFERP (object)) - buf = BUF_BYTE_ADDRESS (XBUFFER (object), offset); - else if (STRINGP (object)) - buf = offset + XSTRING (object)->data; - } + if (coding->composing != COMPOSITION_DISABLED) + { + if (from_byte >= 0) + coding_save_composition (coding, from, to, object); + else + coding->composing = COMPOSITION_DISABLED; } + + if (SBYTES (XPROCESS (proc)->encoding_buf) < require) + XPROCESS (proc)->encoding_buf = make_uninit_string (require); + + if (from_byte >= 0) + buf = (BUFFERP (object) + ? BUF_BYTE_ADDRESS (XBUFFER (object), from_byte) + : SDATA (object) + from_byte); + object = XPROCESS (proc)->encoding_buf; - encode_coding (coding, buf, XSTRING (object)->data, - len, STRING_BYTES (XSTRING (object))); + encode_coding (coding, (char *) buf, SDATA (object), + len, SBYTES (object)); len = coding->produced; - buf = XSTRING (object)->data; + buf = SDATA (object); if (temp_buf) xfree (temp_buf); } @@ -3356,7 +4805,7 @@ send_process (proc, buf, len, object) error ("Could not find this process: %x", p->pid); else if (write_to_vms_process (vs, buf, len)) ; -#else +#else /* not VMS */ if (pty_max_bytes == 0) { @@ -3372,111 +4821,160 @@ send_process (proc, buf, len, object) pty_max_bytes--; } + /* 2000-09-21: Emacs 20.7, sparc-sun-solaris-2.6, GCC 2.95.2, + CFLAGS="-g -O": The value of the parameter `proc' is clobbered + when returning with longjmp despite being declared volatile. */ if (!setjmp (send_process_frame)) - while (len > 0) - { - int this = len; - SIGTYPE (*old_sigpipe)(); + { + process_sent_to = proc; + while (len > 0) + { + int this = len; + SIGTYPE (*old_sigpipe)(); - /* Decide how much data we can send in one batch. - Long lines need to be split into multiple batches. */ - if (!NILP (XPROCESS (proc)->pty_flag)) - { - /* Starting this at zero is always correct when not the first iteration - because the previous iteration ended by sending C-d. - It may not be correct for the first iteration - if a partial line was sent in a separate send_process call. - If that proves worth handling, we need to save linepos - in the process object. */ - int linepos = 0; - unsigned char *ptr = buf; - unsigned char *end = buf + len; - - /* Scan through this text for a line that is too long. */ - while (ptr != end && linepos < pty_max_bytes) - { - if (*ptr == '\n') - linepos = 0; - else - linepos++; - ptr++; - } - /* If we found one, break the line there - and put in a C-d to force the buffer through. */ - this = ptr - buf; - } + /* Decide how much data we can send in one batch. + Long lines need to be split into multiple batches. */ + if (!NILP (XPROCESS (proc)->pty_flag)) + { + /* Starting this at zero is always correct when not the first + iteration because the previous iteration ended by sending C-d. + It may not be correct for the first iteration + if a partial line was sent in a separate send_process call. + If that proves worth handling, we need to save linepos + in the process object. */ + int linepos = 0; + unsigned char *ptr = (unsigned char *) buf; + unsigned char *end = (unsigned char *) buf + len; + + /* Scan through this text for a line that is too long. */ + while (ptr != end && linepos < pty_max_bytes) + { + if (*ptr == '\n') + linepos = 0; + else + linepos++; + ptr++; + } + /* If we found one, break the line there + and put in a C-d to force the buffer through. */ + this = ptr - buf; + } - /* Send this batch, using one or more write calls. */ - while (this > 0) - { - old_sigpipe = (SIGTYPE (*) ()) signal (SIGPIPE, send_process_trap); - rv = emacs_write (XINT (XPROCESS (proc)->outfd), buf, this); - signal (SIGPIPE, old_sigpipe); + /* Send this batch, using one or more write calls. */ + while (this > 0) + { + int outfd = XINT (XPROCESS (proc)->outfd); + old_sigpipe = (SIGTYPE (*) ()) signal (SIGPIPE, send_process_trap); +#ifdef DATAGRAM_SOCKETS + if (DATAGRAM_CHAN_P (outfd)) + { + rv = sendto (outfd, (char *) buf, this, + 0, datagram_address[outfd].sa, + datagram_address[outfd].len); + if (rv < 0 && errno == EMSGSIZE) + report_file_error ("sending datagram", Fcons (proc, Qnil)); + } + else +#endif + rv = emacs_write (outfd, (char *) buf, this); + signal (SIGPIPE, old_sigpipe); - if (rv < 0) - { - if (0 + if (rv < 0) + { + if (0 #ifdef EWOULDBLOCK - || errno == EWOULDBLOCK + || errno == EWOULDBLOCK #endif #ifdef EAGAIN - || errno == EAGAIN + || errno == EAGAIN #endif - ) - /* Buffer is full. Wait, accepting input; - that may allow the program - to finish doing output and read more. */ - { - Lisp_Object zero; - int offset; - - /* Running filters might relocate buffers or strings. - Arrange to relocate BUF. */ - if (BUFFERP (object)) - offset = BUF_PTR_BYTE_POS (XBUFFER (object), buf); - else if (STRINGP (object)) - offset = buf - XSTRING (object)->data; - - XSETFASTINT (zero, 0); + ) + /* Buffer is full. Wait, accepting input; + that may allow the program + to finish doing output and read more. */ + { + Lisp_Object zero; + int offset = 0; + +#ifdef BROKEN_PTY_READ_AFTER_EAGAIN + /* A gross hack to work around a bug in FreeBSD. + In the following sequence, read(2) returns + bogus data: + + write(2) 1022 bytes + write(2) 954 bytes, get EAGAIN + read(2) 1024 bytes in process_read_output + read(2) 11 bytes in process_read_output + + That is, read(2) returns more bytes than have + ever been written successfully. The 1033 bytes + read are the 1022 bytes written successfully + after processing (for example with CRs added if + the terminal is set up that way which it is + here). The same bytes will be seen again in a + later read(2), without the CRs. */ + + if (errno == EAGAIN) + { + int flags = FWRITE; + ioctl (XINT (XPROCESS (proc)->outfd), TIOCFLUSH, + &flags); + } +#endif /* BROKEN_PTY_READ_AFTER_EAGAIN */ + + /* Running filters might relocate buffers or strings. + Arrange to relocate BUF. */ + if (BUFFERP (object)) + offset = BUF_PTR_BYTE_POS (XBUFFER (object), buf); + else if (STRINGP (object)) + offset = buf - SDATA (object); + + XSETFASTINT (zero, 0); #ifdef EMACS_HAS_USECS - wait_reading_process_input (0, 20000, zero, 0); + wait_reading_process_input (0, 20000, zero, 0); #else - wait_reading_process_input (1, 0, zero, 0); + wait_reading_process_input (1, 0, zero, 0); #endif - if (BUFFERP (object)) - buf = BUF_BYTE_ADDRESS (XBUFFER (object), offset); - else if (STRINGP (object)) - buf = offset + XSTRING (object)->data; + if (BUFFERP (object)) + buf = BUF_BYTE_ADDRESS (XBUFFER (object), offset); + else if (STRINGP (object)) + buf = offset + SDATA (object); - rv = 0; - } - else - /* This is a real error. */ - report_file_error ("writing to process", Fcons (proc, Qnil)); - } - buf += rv; - len -= rv; - this -= rv; - } + rv = 0; + } + else + /* This is a real error. */ + report_file_error ("writing to process", Fcons (proc, Qnil)); + } + buf += rv; + len -= rv; + this -= rv; + } - /* If we sent just part of the string, put in an EOF - to force it through, before we send the rest. */ - if (len > 0) - Fprocess_send_eof (proc); - } -#endif + /* If we sent just part of the string, put in an EOF + to force it through, before we send the rest. */ + if (len > 0) + Fprocess_send_eof (proc); + } + } +#endif /* not VMS */ else { +#ifndef VMS + proc = process_sent_to; +#endif XPROCESS (proc)->raw_status_low = Qnil; XPROCESS (proc)->raw_status_high = Qnil; XPROCESS (proc)->status = Fcons (Qexit, Fcons (make_number (256), Qnil)); XSETINT (XPROCESS (proc)->tick, ++process_tick); deactivate_process (proc); #ifdef VMS - error ("Error writing to process %s; closed it", procname); + error ("Error writing to process %s; closed it", + SDATA (XPROCESS (proc)->name)); #else - error ("SIGPIPE raised on process %s; closed it", procname); + error ("SIGPIPE raised on process %s; closed it", + SDATA (XPROCESS (proc)->name)); #endif } @@ -3484,15 +4982,15 @@ send_process (proc, buf, len, object) } DEFUN ("process-send-region", Fprocess_send_region, Sprocess_send_region, - 3, 3, 0, - "Send current contents of region as input to PROCESS.\n\ -PROCESS may be a process, a buffer, the name of a process or buffer, or\n\ -nil, indicating the current buffer's process.\n\ -Called from program, takes three arguments, PROCESS, START and END.\n\ -If the region is more than 500 characters long,\n\ -it is sent in several bunches. This may happen even for shorter regions.\n\ -Output from processes can arrive in between bunches.") - (process, start, end) + 3, 3, 0, + doc: /* Send current contents of region as input to PROCESS. +PROCESS may be a process, a buffer, the name of a process or buffer, or +nil, indicating the current buffer's process. +Called from program, takes three arguments, PROCESS, START and END. +If the region is more than 500 characters long, +it is sent in several bunches. This may happen even for shorter regions. +Output from processes can arrive in between bunches. */) + (process, start, end) Lisp_Object process, start, end; { Lisp_Object proc; @@ -3513,30 +5011,30 @@ Output from processes can arrive in between bunches.") } DEFUN ("process-send-string", Fprocess_send_string, Sprocess_send_string, - 2, 2, 0, - "Send PROCESS the contents of STRING as input.\n\ -PROCESS may be a process, a buffer, the name of a process or buffer, or\n\ -nil, indicating the current buffer's process.\n\ -If STRING is more than 500 characters long,\n\ -it is sent in several bunches. This may happen even for shorter strings.\n\ -Output from processes can arrive in between bunches.") - (process, string) + 2, 2, 0, + doc: /* Send PROCESS the contents of STRING as input. +PROCESS may be a process, a buffer, the name of a process or buffer, or +nil, indicating the current buffer's process. +If STRING is more than 500 characters long, +it is sent in several bunches. This may happen even for shorter strings. +Output from processes can arrive in between bunches. */) + (process, string) Lisp_Object process, string; { Lisp_Object proc; - CHECK_STRING (string, 1); + CHECK_STRING (string); proc = get_process (process); - send_process (proc, XSTRING (string)->data, - STRING_BYTES (XSTRING (string)), string); + send_process (proc, SDATA (string), + SBYTES (string), string); return Qnil; } DEFUN ("process-running-child-p", Fprocess_running_child_p, Sprocess_running_child_p, 0, 1, 0, - "Return t if PROCESS has given the terminal to a child.\n\ -If the operating system does not make it possible to find out,\n\ -return t unconditionally.") - (process) + doc: /* Return t if PROCESS has given the terminal to a child. +If the operating system does not make it possible to find out, +return t unconditionally. */) + (process) Lisp_Object process; { /* Initialize in case ioctl doesn't exist or gives an error, @@ -3550,10 +5048,10 @@ return t unconditionally.") if (!EQ (p->childp, Qt)) error ("Process %s is not a subprocess", - XSTRING (p->name)->data); + SDATA (p->name)); if (XINT (p->infd) < 0) error ("Process %s is not active", - XSTRING (p->name)->data); + SDATA (p->name)); #ifdef TIOCGPGRP if (!NILP (p->subtty)) @@ -3598,16 +5096,19 @@ process_send_signal (process, signo, current_group, nomsg) if (!EQ (p->childp, Qt)) error ("Process %s is not a subprocess", - XSTRING (p->name)->data); + SDATA (p->name)); if (XINT (p->infd) < 0) error ("Process %s is not active", - XSTRING (p->name)->data); + SDATA (p->name)); if (NILP (p->pty_flag)) current_group = Qnil; /* If we are using pgrps, get a pgrp number and make it negative. */ - if (!NILP (current_group)) + if (NILP (current_group)) + /* Send the signal to the shell's process group. */ + gid = XFASTINT (p->pid); + else { #ifdef SIGNALS_VIA_CHARACTERS /* If possible, send signals to the entire pgrp @@ -3697,10 +5198,12 @@ process_send_signal (process, signo, current_group, nomsg) #endif /* ! defined (TCGETA) */ #endif /* ! defined (TIOCGLTC) && defined (TIOCGETC) */ #endif /* ! defined HAVE_TERMIOS */ -#endif /* ! defined (SIGNALS_VIA_CHARACTERS) */ + abort (); + /* The code above always returns from the function. */ +#endif /* defined (SIGNALS_VIA_CHARACTERS) */ #ifdef TIOCGPGRP - /* Get the pgrp using the tty itself, if we have that. + /* Get the current pgrp using the tty itself, if we have that. Otherwise, use the pty to get the pgrp. On pfa systems, saka@pfu.fujitsu.co.JP writes: "TIOCGPGRP symbol defined in sys/ioctl.h at E50. @@ -3715,28 +5218,28 @@ process_send_signal (process, signo, current_group, nomsg) else err = ioctl (XINT (p->infd), TIOCGPGRP, &gid); -#ifdef pfa if (err == -1) - gid = - XFASTINT (p->pid); -#endif /* ! defined (pfa) */ + /* If we can't get the information, assume + the shell owns the tty. */ + gid = XFASTINT (p->pid); } + + /* It is not clear whether anything really can set GID to -1. + Perhaps on some system one of those ioctls can or could do so. + Or perhaps this is vestigial. */ if (gid == -1) no_pgrp = 1; - else - gid = - gid; #else /* ! defined (TIOCGPGRP ) */ /* Can't select pgrps on this system, so we know that the child itself heads the pgrp. */ - gid = - XFASTINT (p->pid); + gid = XFASTINT (p->pid); #endif /* ! defined (TIOCGPGRP ) */ /* If current_group is lambda, and the shell owns the terminal, don't send any signal. */ - if (EQ (current_group, Qlambda) && gid == - XFASTINT (p->pid)) + if (EQ (current_group, Qlambda) && gid == XFASTINT (p->pid)) return; } - else - gid = - XFASTINT (p->pid); switch (signo) { @@ -3788,23 +5291,23 @@ process_send_signal (process, signo, current_group, nomsg) kill (gid, signo); } #else /* ! defined (TIOCSIGSEND) */ - EMACS_KILLPG (-gid, signo); + EMACS_KILLPG (gid, signo); #endif /* ! defined (TIOCSIGSEND) */ } DEFUN ("interrupt-process", Finterrupt_process, Sinterrupt_process, 0, 2, 0, - "Interrupt process PROCESS.\n\ -PROCESS may be a process, a buffer, or the name of a process or buffer.\n\ -nil or no arg means current buffer's process.\n\ -Second arg CURRENT-GROUP non-nil means send signal to\n\ -the current process-group of the process's controlling terminal\n\ -rather than to the process's own process group.\n\ -If the process is a shell, this means interrupt current subjob\n\ -rather than the shell.\n\ -\n\ -If CURRENT-GROUP is `lambda', and if the shell owns the terminal,\n\ -don't send the signal.") - (process, current_group) + doc: /* Interrupt process PROCESS. +PROCESS may be a process, a buffer, or the name of a process or buffer. +nil or no arg means current buffer's process. +Second arg CURRENT-GROUP non-nil means send signal to +the current process-group of the process's controlling terminal +rather than to the process's own process group. +If the process is a shell, this means interrupt current subjob +rather than the shell. + +If CURRENT-GROUP is `lambda', and if the shell owns the terminal, +don't send the signal. */) + (process, current_group) Lisp_Object process, current_group; { process_send_signal (process, SIGINT, current_group, 0); @@ -3812,9 +5315,9 @@ don't send the signal.") } DEFUN ("kill-process", Fkill_process, Skill_process, 0, 2, 0, - "Kill process PROCESS. May be process or name of one.\n\ -See function `interrupt-process' for more details on usage.") - (process, current_group) + doc: /* Kill process PROCESS. May be process or name of one. +See function `interrupt-process' for more details on usage. */) + (process, current_group) Lisp_Object process, current_group; { process_send_signal (process, SIGKILL, current_group, 0); @@ -3822,9 +5325,9 @@ See function `interrupt-process' for more details on usage.") } DEFUN ("quit-process", Fquit_process, Squit_process, 0, 2, 0, - "Send QUIT signal to process PROCESS. May be process or name of one.\n\ -See function `interrupt-process' for more details on usage.") - (process, current_group) + doc: /* Send QUIT signal to process PROCESS. May be process or name of one. +See function `interrupt-process' for more details on usage. */) + (process, current_group) Lisp_Object process, current_group; { process_send_signal (process, SIGQUIT, current_group, 0); @@ -3832,11 +5335,28 @@ See function `interrupt-process' for more details on usage.") } DEFUN ("stop-process", Fstop_process, Sstop_process, 0, 2, 0, - "Stop process PROCESS. May be process or name of one.\n\ -See function `interrupt-process' for more details on usage.") - (process, current_group) + doc: /* Stop process PROCESS. May be process or name of one. +See function `interrupt-process' for more details on usage. +If PROCESS is a network process, inhibit handling of incoming traffic. */) + (process, current_group) Lisp_Object process, current_group; { +#ifdef HAVE_SOCKETS + if (PROCESSP (process) && NETCONN_P (process)) + { + struct Lisp_Process *p; + + p = XPROCESS (process); + if (NILP (p->command) + && XINT (p->infd) >= 0) + { + FD_CLR (XINT (p->infd), &input_wait_mask); + FD_CLR (XINT (p->infd), &non_keyboard_wait_mask); + } + p->command = Qt; + return process; + } +#endif #ifndef SIGTSTP error ("no SIGTSTP support"); #else @@ -3846,11 +5366,29 @@ See function `interrupt-process' for more details on usage.") } DEFUN ("continue-process", Fcontinue_process, Scontinue_process, 0, 2, 0, - "Continue process PROCESS. May be process or name of one.\n\ -See function `interrupt-process' for more details on usage.") - (process, current_group) + doc: /* Continue process PROCESS. May be process or name of one. +See function `interrupt-process' for more details on usage. +If PROCESS is a network process, resume handling of incoming traffic. */) + (process, current_group) Lisp_Object process, current_group; { +#ifdef HAVE_SOCKETS + if (PROCESSP (process) && NETCONN_P (process)) + { + struct Lisp_Process *p; + + p = XPROCESS (process); + if (EQ (p->command, Qt) + && XINT (p->infd) >= 0 + && (!EQ (p->filter, Qt) || EQ (p->status, Qlisten))) + { + FD_SET (XINT (p->infd), &input_wait_mask); + FD_SET (XINT (p->infd), &non_keyboard_wait_mask); + } + p->command = Qnil; + return process; + } +#endif #ifdef SIGCONT process_send_signal (process, SIGCONT, current_group, 0); #else @@ -3860,14 +5398,46 @@ See function `interrupt-process' for more details on usage.") } DEFUN ("signal-process", Fsignal_process, Ssignal_process, - 2, 2, "nProcess number: \nnSignal code: ", - "Send the process with process id PID the signal with code SIGCODE.\n\ -PID must be an integer. The process need not be a child of this Emacs.\n\ -SIGCODE may be an integer, or a symbol whose name is a signal name.") - (pid, sigcode) - Lisp_Object pid, sigcode; + 2, 2, "sProcess (name or number): \nnSignal code: ", + doc: /* Send PROCESS the signal with code SIGCODE. +PROCESS may also be an integer specifying the process id of the +process to signal; in this case, the process need not be a child of +this Emacs. +SIGCODE may be an integer, or a symbol whose name is a signal name. */) + (process, sigcode) + Lisp_Object process, sigcode; { - CHECK_NUMBER (pid, 0); + Lisp_Object pid; + + if (INTEGERP (process)) + { + pid = process; + goto got_it; + } + + if (STRINGP (process)) + { + Lisp_Object tem; + if (tem = Fget_process (process), NILP (tem)) + { + pid = Fstring_to_number (process, make_number (10)); + if (XINT (pid) != 0) + goto got_it; + } + process = tem; + } + else + process = get_process (process); + + if (NILP (process)) + return process; + + CHECK_PROCESS (process); + pid = XPROCESS (process)->pid; + if (!INTEGERP (pid) || XINT (pid) <= 0) + error ("Cannot signal process %s", SDATA (XPROCESS (process)->name)); + + got_it: #define handle_signal(NAME, VALUE) \ else if (!strcmp (name, NAME)) \ @@ -3879,8 +5449,8 @@ SIGCODE may be an integer, or a symbol whose name is a signal name.") { unsigned char *name; - CHECK_SYMBOL (sigcode, 1); - name = XSYMBOL (sigcode)->name->data; + CHECK_SYMBOL (sigcode); + name = SDATA (SYMBOL_NAME (sigcode)); if (0) ; @@ -3984,19 +5554,22 @@ SIGCODE may be an integer, or a symbol whose name is a signal name.") } DEFUN ("process-send-eof", Fprocess_send_eof, Sprocess_send_eof, 0, 1, 0, - "Make PROCESS see end-of-file in its input.\n\ -EOF comes after any text already sent to it.\n\ -PROCESS may be a process, a buffer, the name of a process or buffer, or\n\ -nil, indicating the current buffer's process.\n\ -If PROCESS is a network connection, or is a process communicating\n\ -through a pipe (as opposed to a pty), then you cannot send any more\n\ -text to PROCESS after you call this function.") - (process) + doc: /* Make PROCESS see end-of-file in its input. +EOF comes after any text already sent to it. +PROCESS may be a process, a buffer, the name of a process or buffer, or +nil, indicating the current buffer's process. +If PROCESS is a network connection, or is a process communicating +through a pipe (as opposed to a pty), then you cannot send any more +text to PROCESS after you call this function. */) + (process) Lisp_Object process; { Lisp_Object proc; struct coding_system *coding; + if (DATAGRAM_CONN_P (process)) + return process; + proc = get_process (process); coding = proc_encode_coding_system[XINT (XPROCESS (proc)->outfd)]; @@ -4004,7 +5577,7 @@ text to PROCESS after you call this function.") if (! NILP (XPROCESS (proc)->raw_status_low)) update_status (XPROCESS (proc)); if (! EQ (XPROCESS (proc)->status, Qrun)) - error ("Process %s not running", XSTRING (XPROCESS (proc)->name)->data); + error ("Process %s not running", SDATA (XPROCESS (proc)->name)); if (CODING_REQUIRE_FLUSHING (coding)) { @@ -4054,7 +5627,7 @@ text to PROCESS after you call this function.") } /* Kill all processes associated with `buffer'. - If `buffer' is nil, kill all processes */ + If `buffer' is nil, kill all processes */ void kill_buffer_processes (buffer) @@ -4076,26 +5649,27 @@ kill_buffer_processes (buffer) } } -/* On receipt of a signal that a child status has changed, - loop asking about children with changed statuses until - the system says there are no more. - All we do is change the status; - we do not run sentinels or print notifications. - That is saved for the next time keyboard input is done, - in order to avoid timing errors. */ - -/** WARNING: this can be called during garbage collection. - Therefore, it must not be fooled by the presence of mark bits in - Lisp objects. */ - -/** USG WARNING: Although it is not obvious from the documentation - in signal(2), on a USG system the SIGCLD handler MUST NOT call - signal() before executing at least one wait(), otherwise the handler - will be called again, resulting in an infinite loop. The relevant - portion of the documentation reads "SIGCLD signals will be queued - and the signal-catching function will be continually reentered until - the queue is empty". Invoking signal() causes the kernel to reexamine - the SIGCLD queue. Fred Fish, UniSoft Systems Inc. */ +/* On receipt of a signal that a child status has changed, loop asking + about children with changed statuses until the system says there + are no more. + + All we do is change the status; we do not run sentinels or print + notifications. That is saved for the next time keyboard input is + done, in order to avoid timing errors. + + ** WARNING: this can be called during garbage collection. + Therefore, it must not be fooled by the presence of mark bits in + Lisp objects. + + ** USG WARNING: Although it is not obvious from the documentation + in signal(2), on a USG system the SIGCLD handler MUST NOT call + signal() before executing at least one wait(), otherwise the + handler will be called again, resulting in an infinite loop. The + relevant portion of the documentation reads "SIGCLD signals will be + queued and the signal-catching function will be continually + reentered until the queue is empty". Invoking signal() causes the + kernel to reexamine the SIGCLD queue. Fred Fish, UniSoft Systems + Inc. */ SIGTYPE sigchld_handler (signo) @@ -4127,11 +5701,12 @@ sigchld_handler (signo) errno = 0; pid = wait3 (&w, WNOHANG | WUNTRACED, 0); } - while (pid <= 0 && errno == EINTR); + while (pid < 0 && errno == EINTR); if (pid <= 0) { - /* A real failure. We have done all our job, so return. */ + /* PID == 0 means no processes found, PID == -1 means a real + failure. We have done all our job, so return. */ /* USG systems forget handlers when they are used; must reestablish each time */ @@ -4152,11 +5727,11 @@ sigchld_handler (signo) /* Find the process that signaled us, and record its status. */ p = 0; - for (tail = Vprocess_alist; CONSP (tail); tail = XCDR (tail)) + for (tail = Vprocess_alist; GC_CONSP (tail); tail = XCDR (tail)) { proc = XCDR (XCAR (tail)); p = XPROCESS (proc); - if (EQ (p->childp, Qt) && XFASTINT (p->pid) == pid) + if (GC_EQ (p->childp, Qt) && XINT (p->pid) == pid) break; p = 0; } @@ -4164,11 +5739,11 @@ sigchld_handler (signo) /* Look for an asynchronous process whose pid hasn't been filled in yet. */ if (p == 0) - for (tail = Vprocess_alist; CONSP (tail); tail = XCDR (tail)) + for (tail = Vprocess_alist; GC_CONSP (tail); tail = XCDR (tail)) { proc = XCDR (XCAR (tail)); p = XPROCESS (proc); - if (INTEGERP (p->pid) && XINT (p->pid) == -1) + if (GC_INTEGERP (p->pid) && XINT (p->pid) == -1) break; p = 0; } @@ -4236,7 +5811,9 @@ sigchld_handler (signo) get another signal. Otherwise (on systems that have WNOHANG), loop around to use up all the processes that have something to tell us. */ -#if defined (USG) && ! (defined (HPUX) && defined (WNOHANG)) || defined (WINDOWSNT) +#if (defined WINDOWSNT \ + || (defined USG && !defined GNU_LINUX \ + && !(defined HPUX && defined WNOHANG))) #if defined (USG) && ! defined (POSIX_SIGNALS) signal (signo, sigchld_handler); #endif @@ -4272,7 +5849,7 @@ exec_sentinel (proc, reason) { Lisp_Object sentinel, obuffer, odeactivate, okeymap; register struct Lisp_Process *p = XPROCESS (proc); - int count = specpdl_ptr - specpdl; + int count = SPECPDL_INDEX (); int outer_running_asynch_code = running_asynch_code; int waiting = waiting_for_user_input_p; @@ -4341,7 +5918,8 @@ exec_sentinel (proc, reason) /* Report all recent events of a change in process status (either run the sentinel or output a message). - This is done while Emacs is waiting for keyboard input. */ + This is usually done while Emacs is waiting for keyboard input + but can be done at other times. */ void status_notify () @@ -4376,6 +5954,9 @@ status_notify () /* If process is still active, read any output that remains. */ while (! EQ (p->filter, Qt) + && ! EQ (p->status, Qconnect) + && ! EQ (p->status, Qlisten) + && ! EQ (p->command, Qt) /* Network process not stopped. */ && XINT (p->infd) >= 0 && read_process_output (proc, XINT (p->infd)) > 0); @@ -4459,7 +6040,7 @@ status_notify () } /* end for */ update_mode_lines++; /* in case buffers use %s in mode-line-format */ - redisplay_preserve_echo_area (); + redisplay_preserve_echo_area (13); UNGCPRO; } @@ -4467,20 +6048,20 @@ status_notify () DEFUN ("set-process-coding-system", Fset_process_coding_system, Sset_process_coding_system, 1, 3, 0, - "Set coding systems of PROCESS to DECODING and ENCODING.\n\ -DECODING will be used to decode subprocess output and ENCODING to\n\ -encode subprocess input.") - (proc, decoding, encoding) + doc: /* Set coding systems of PROCESS to DECODING and ENCODING. +DECODING will be used to decode subprocess output and ENCODING to +encode subprocess input. */) + (proc, decoding, encoding) register Lisp_Object proc, decoding, encoding; { register struct Lisp_Process *p; - CHECK_PROCESS (proc, 0); + CHECK_PROCESS (proc); p = XPROCESS (proc); if (XINT (p->infd) < 0) - error ("Input file descriptor of %s closed", XSTRING (p->name)->data); + error ("Input file descriptor of %s closed", SDATA (p->name)); if (XINT (p->outfd) < 0) - error ("Output file descriptor of %s closed", XSTRING (p->name)->data); + error ("Output file descriptor of %s closed", SDATA (p->name)); p->decode_coding_system = Fcheck_coding_system (decoding); p->encode_coding_system = Fcheck_coding_system (encoding); @@ -4494,11 +6075,11 @@ encode subprocess input.") DEFUN ("process-coding-system", Fprocess_coding_system, Sprocess_coding_system, 1, 1, 0, - "Return a cons of coding systems for decoding and encoding of PROCESS.") - (proc) + doc: /* Return a cons of coding systems for decoding and encoding of PROCESS. */) + (proc) register Lisp_Object proc; { - CHECK_PROCESS (proc, 0); + CHECK_PROCESS (proc); return Fcons (XPROCESS (proc)->decode_coding_system, XPROCESS (proc)->encode_coding_system); } @@ -4586,11 +6167,58 @@ init_process () } bzero (proc_decode_coding_system, sizeof proc_decode_coding_system); bzero (proc_encode_coding_system, sizeof proc_encode_coding_system); +#ifdef DATAGRAM_SOCKETS + bzero (datagram_address, sizeof datagram_address); +#endif + +#ifdef HAVE_SOCKETS + { + Lisp_Object subfeatures = Qnil; +#define ADD_SUBFEATURE(key, val) \ + subfeatures = Fcons (Fcons (key, Fcons (val, Qnil)), subfeatures) - Vdefault_process_coding_system - = (NILP (buffer_defaults.enable_multibyte_characters) - ? Fcons (Qraw_text, Qnil) - : Fcons (Qemacs_mule, Qnil)); +#ifdef NON_BLOCKING_CONNECT + ADD_SUBFEATURE (QCnowait, Qt); +#endif +#ifdef DATAGRAM_SOCKETS + ADD_SUBFEATURE (QCtype, Qdatagram); +#endif +#ifdef HAVE_LOCAL_SOCKETS + ADD_SUBFEATURE (QCfamily, Qlocal); +#endif +#ifdef HAVE_GETSOCKNAME + ADD_SUBFEATURE (QCservice, Qt); +#endif +#if !defined(TERM) && (defined(O_NONBLOCK) || defined(O_NDELAY)) + ADD_SUBFEATURE (QCserver, Qt); +#endif +#ifdef SO_BINDTODEVICE + ADD_SUBFEATURE (QCoptions, intern ("bindtodevice")); +#endif +#ifdef SO_BROADCAST + ADD_SUBFEATURE (QCoptions, intern ("broadcast")); +#endif +#ifdef SO_DONTROUTE + ADD_SUBFEATURE (QCoptions, intern ("dontroute")); +#endif +#ifdef SO_KEEPALIVE + ADD_SUBFEATURE (QCoptions, intern ("keepalive")); +#endif +#ifdef SO_LINGER + ADD_SUBFEATURE (QCoptions, intern ("linger")); +#endif +#ifdef SO_OOBINLINE + ADD_SUBFEATURE (QCoptions, intern ("oobinline")); +#endif +#ifdef SO_PRIORITY + ADD_SUBFEATURE (QCoptions, intern ("priority")); +#endif +#ifdef SO_REUSEADDR + ADD_SUBFEATURE (QCoptions, intern ("reuseaddr")); +#endif + Fprovide (intern ("make-network-process"), subfeatures); + } +#endif /* HAVE_SOCKETS */ } void @@ -4615,24 +6243,65 @@ syms_of_process () staticpro (&Qopen); Qclosed = intern ("closed"); staticpro (&Qclosed); - + Qconnect = intern ("connect"); + staticpro (&Qconnect); + Qfailed = intern ("failed"); + staticpro (&Qfailed); + Qlisten = intern ("listen"); + staticpro (&Qlisten); + Qlocal = intern ("local"); + staticpro (&Qlocal); + Qdatagram = intern ("datagram"); + staticpro (&Qdatagram); + + QCname = intern (":name"); + staticpro (&QCname); + QCbuffer = intern (":buffer"); + staticpro (&QCbuffer); + QChost = intern (":host"); + staticpro (&QChost); + QCservice = intern (":service"); + staticpro (&QCservice); + QCtype = intern (":type"); + staticpro (&QCtype); + QClocal = intern (":local"); + staticpro (&QClocal); + QCremote = intern (":remote"); + staticpro (&QCremote); + QCcoding = intern (":coding"); + staticpro (&QCcoding); + QCserver = intern (":server"); + staticpro (&QCserver); + QCnowait = intern (":nowait"); + staticpro (&QCnowait); + QCsentinel = intern (":sentinel"); + staticpro (&QCsentinel); + QClog = intern (":log"); + staticpro (&QClog); + QCnoquery = intern (":noquery"); + staticpro (&QCnoquery); + QCstop = intern (":stop"); + staticpro (&QCstop); + QCoptions = intern (":options"); + staticpro (&QCoptions); + Qlast_nonmenu_event = intern ("last-nonmenu-event"); staticpro (&Qlast_nonmenu_event); staticpro (&Vprocess_alist); DEFVAR_BOOL ("delete-exited-processes", &delete_exited_processes, - "*Non-nil means delete processes immediately when they exit.\n\ -nil means don't delete them until `list-processes' is run."); + doc: /* *Non-nil means delete processes immediately when they exit. +nil means don't delete them until `list-processes' is run. */); delete_exited_processes = 1; DEFVAR_LISP ("process-connection-type", &Vprocess_connection_type, - "Control type of device used to communicate with subprocesses.\n\ -Values are nil to use a pipe, or t or `pty' to use a pty.\n\ -The value has no effect if the system has no ptys or if all ptys are busy:\n\ -then a pipe is used in any case.\n\ -The value takes effect when `start-process' is called."); + doc: /* Control type of device used to communicate with subprocesses. +Values are nil to use a pipe, or t or `pty' to use a pty. +The value has no effect if the system has no ptys or if all ptys are busy: +then a pipe is used in any case. +The value takes effect when `start-process' is called. */); Vprocess_connection_type = Qt; defsubr (&Sprocessp); @@ -4655,14 +6324,21 @@ The value takes effect when `start-process' is called."); defsubr (&Sset_process_window_size); defsubr (&Sset_process_inherit_coding_system_flag); defsubr (&Sprocess_inherit_coding_system_flag); - defsubr (&Sprocess_kill_without_query); + defsubr (&Sset_process_query_on_exit_flag); + defsubr (&Sprocess_query_on_exit_flag); defsubr (&Sprocess_contact); defsubr (&Slist_processes); defsubr (&Sprocess_list); defsubr (&Sstart_process); #ifdef HAVE_SOCKETS - defsubr (&Sopen_network_stream); + defsubr (&Sset_network_process_options); + defsubr (&Smake_network_process); + defsubr (&Sformat_network_address); #endif /* HAVE_SOCKETS */ +#ifdef DATAGRAM_SOCKETS + defsubr (&Sprocess_datagram_address); + defsubr (&Sset_process_datagram_address); +#endif defsubr (&Saccept_process_output); defsubr (&Sprocess_send_region); defsubr (&Sprocess_send_string); @@ -4698,6 +6374,8 @@ extern int frame_garbaged; extern EMACS_TIME timer_check (); extern int timers_run; +Lisp_Object QCtype; + /* As described above, except assuming that there are no subprocesses: Wait for timeout to elapse and/or keyboard input to be available. @@ -4732,12 +6410,14 @@ wait_reading_process_input (time_limit, microsecs, read_kbd, do_display) EMACS_TIME end_time, timeout; SELECT_TYPE waitchannels; int xerrno; - Lisp_Object *wait_for_cell = 0; + /* Either nil or a cons cell, the car of which is of interest and + may be changed outside of this routine. */ + Lisp_Object wait_for_cell = Qnil; /* If waiting for non-nil in a cell, record where. */ if (CONSP (read_kbd)) { - wait_for_cell = &XCAR (read_kbd); + wait_for_cell = read_kbd; XSETFASTINT (read_kbd, 0); } @@ -4750,7 +6430,9 @@ wait_reading_process_input (time_limit, microsecs, read_kbd, do_display) } /* Turn off periodic alarms (in case they are in use) + and then turn off any other atimers, because the select emulator uses alarms. */ + stop_polling (); turn_on_atimers (0); while (1) @@ -4764,7 +6446,7 @@ wait_reading_process_input (time_limit, microsecs, read_kbd, do_display) QUIT; /* Exit now if the cell we're waiting for became non-nil. */ - if (wait_for_cell && ! NILP (*wait_for_cell)) + if (! NILP (wait_for_cell) && ! NILP (XCAR (wait_for_cell))) break; /* Compute time from now till when time limit is up */ @@ -4793,21 +6475,22 @@ wait_reading_process_input (time_limit, microsecs, read_kbd, do_display) run timer events directly. (Callers that will immediately read keyboard events call timer_delay on their own.) */ - if (! wait_for_cell) + if (NILP (wait_for_cell)) { EMACS_TIME timer_delay; - int old_timers_run; - retry: - old_timers_run = timers_run; - timer_delay = timer_check (1); - if (timers_run != old_timers_run && do_display) + do { - redisplay_preserve_echo_area (); - /* We must retry, since a timer may have requeued itself - and that could alter the time delay. */ - goto retry; + int old_timers_run = timers_run; + timer_delay = timer_check (1); + if (timers_run != old_timers_run && do_display) + /* We must retry, since a timer may have requeued itself + and that could alter the time delay. */ + redisplay_preserve_echo_area (14); + else + break; } + while (!detect_input_pending ()); /* If there is unread keyboard input, also return. */ if (XINT (read_kbd) != 0 @@ -4833,7 +6516,7 @@ wait_reading_process_input (time_limit, microsecs, read_kbd, do_display) /* Wait till there is something to do. */ - if (! XINT (read_kbd) && wait_for_cell == 0) + if (! XINT (read_kbd) && NILP (wait_for_cell)) FD_ZERO (&waitchannels); else FD_SET (0, &waitchannels); @@ -4843,7 +6526,7 @@ wait_reading_process_input (time_limit, microsecs, read_kbd, do_display) if (frame_garbaged && do_display) { clear_waiting_for_input (); - redisplay_preserve_echo_area (); + redisplay_preserve_echo_area (15); if (XINT (read_kbd) < 0) set_waiting_for_input (&timeout); } @@ -4909,7 +6592,7 @@ wait_reading_process_input (time_limit, microsecs, read_kbd, do_display) input at all when wait_for_cell, but the code has been this way since July 1994. Try changing this after version 19.31.) */ - if (wait_for_cell + if (! NILP (wait_for_cell) && detect_input_pending ()) { swallow_events (do_display); @@ -4918,7 +6601,7 @@ wait_reading_process_input (time_limit, microsecs, read_kbd, do_display) } /* Exit now if the cell we're waiting for became non-nil. */ - if (wait_for_cell && ! NILP (*wait_for_cell)) + if (! NILP (wait_for_cell) && ! NILP (XCAR (wait_for_cell))) break; } @@ -4928,23 +6611,23 @@ wait_reading_process_input (time_limit, microsecs, read_kbd, do_display) } +/* Don't confuse make-docfile by having two doc strings for this function. + make-docfile does not pay attention to #if, for good reason! */ DEFUN ("get-buffer-process", Fget_buffer_process, Sget_buffer_process, 1, 1, 0, - /* Don't confuse make-docfile by having two doc strings for this function. - make-docfile does not pay attention to #if, for good reason! */ - 0) - (name) + 0) + (name) register Lisp_Object name; { return Qnil; } -DEFUN ("process-inherit-coding-system-flag", - Fprocess_inherit_coding_system_flag, Sprocess_inherit_coding_system_flag, - 1, 1, 0, /* Don't confuse make-docfile by having two doc strings for this function. make-docfile does not pay attention to #if, for good reason! */ - 0) - (process) +DEFUN ("process-inherit-coding-system-flag", + Fprocess_inherit_coding_system_flag, Sprocess_inherit_coding_system_flag, + 1, 1, 0, + 0) + (process) register Lisp_Object process; { /* Ignore the argument and return the value of @@ -4970,6 +6653,9 @@ init_process () void syms_of_process () { + QCtype = intern (":type"); + staticpro (&QCtype); + defsubr (&Sget_buffer_process); defsubr (&Sprocess_inherit_coding_system_flag); }