Merge from emacs-24; up to 2012-04-26T03:04:36Z!cyd@gnu.org
[bpt/emacs.git] / src / process.c
1 /* Asynchronous subprocess control for GNU Emacs.
2
3 Copyright (C) 1985-1988, 1993-1996, 1998-1999, 2001-2012
4 Free Software Foundation, Inc.
5
6 This file is part of GNU Emacs.
7
8 GNU Emacs is free software: you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation, either version 3 of the License, or
11 (at your option) any later version.
12
13 GNU Emacs is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
17
18 You should have received a copy of the GNU General Public License
19 along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
20
21
22 #include <config.h>
23 #include <signal.h>
24 #include <stdio.h>
25 #include <errno.h>
26 #include <setjmp.h>
27 #include <sys/types.h> /* Some typedefs are used in sys/file.h. */
28 #include <sys/file.h>
29 #include <sys/stat.h>
30 #include <setjmp.h>
31
32 #include <unistd.h>
33 #include <fcntl.h>
34
35 #include "lisp.h"
36
37 /* Only MS-DOS does not define `subprocesses'. */
38 #ifdef subprocesses
39
40 #include <sys/socket.h>
41 #include <netdb.h>
42 #include <netinet/in.h>
43 #include <arpa/inet.h>
44
45 /* Are local (unix) sockets supported? */
46 #if defined (HAVE_SYS_UN_H)
47 #if !defined (AF_LOCAL) && defined (AF_UNIX)
48 #define AF_LOCAL AF_UNIX
49 #endif
50 #ifdef AF_LOCAL
51 #define HAVE_LOCAL_SOCKETS
52 #include <sys/un.h>
53 #endif
54 #endif
55
56 #include <sys/ioctl.h>
57 #if defined (HAVE_NET_IF_H)
58 #include <net/if.h>
59 #endif /* HAVE_NET_IF_H */
60
61 #if defined (HAVE_IFADDRS_H)
62 /* Must be after net/if.h */
63 #include <ifaddrs.h>
64
65 /* We only use structs from this header when we use getifaddrs. */
66 #if defined (HAVE_NET_IF_DL_H)
67 #include <net/if_dl.h>
68 #endif
69
70 #endif
71
72 #ifdef NEED_BSDTTY
73 #include <bsdtty.h>
74 #endif
75
76 #ifdef HAVE_RES_INIT
77 #include <netinet/in.h>
78 #include <arpa/nameser.h>
79 #include <resolv.h>
80 #endif
81
82 #ifdef HAVE_UTIL_H
83 #include <util.h>
84 #endif
85
86 #ifdef HAVE_PTY_H
87 #include <pty.h>
88 #endif
89
90 #endif /* subprocesses */
91
92 #include "systime.h"
93 #include "systty.h"
94
95 #include "window.h"
96 #include "character.h"
97 #include "buffer.h"
98 #include "coding.h"
99 #include "process.h"
100 #include "frame.h"
101 #include "termhooks.h"
102 #include "termopts.h"
103 #include "commands.h"
104 #include "keyboard.h"
105 #include "blockinput.h"
106 #include "dispextern.h"
107 #include "composite.h"
108 #include "atimer.h"
109 #include "sysselect.h"
110 #include "syssignal.h"
111 #include "syswait.h"
112 #ifdef HAVE_GNUTLS
113 #include "gnutls.h"
114 #endif
115
116 #if defined (USE_GTK) || defined (HAVE_GCONF) || defined (HAVE_GSETTINGS)
117 #include "xgselect.h"
118 #endif
119 #ifdef HAVE_NS
120 #include "nsterm.h"
121 #endif
122
123 /* Work around GCC 4.7.0 bug with strict overflow checking; see
124 <http://gcc.gnu.org/bugzilla/show_bug.cgi?id=52904>.
125 These lines can be removed once the GCC bug is fixed. */
126 #if (__GNUC__ == 4 && 3 <= __GNUC_MINOR__) || 4 < __GNUC__
127 # pragma GCC diagnostic ignored "-Wstrict-overflow"
128 #endif
129
130 Lisp_Object Qeuid, Qegid, Qcomm, Qstate, Qppid, Qpgrp, Qsess, Qttname, Qtpgid;
131 Lisp_Object Qminflt, Qmajflt, Qcminflt, Qcmajflt, Qutime, Qstime, Qcstime;
132 Lisp_Object Qcutime, Qpri, Qnice, Qthcount, Qstart, Qvsize, Qrss, Qargs;
133 Lisp_Object Quser, Qgroup, Qetime, Qpcpu, Qpmem, Qtime, Qctime;
134 Lisp_Object QCname, QCtype;
135 \f
136 /* Non-zero if keyboard input is on hold, zero otherwise. */
137
138 static int kbd_is_on_hold;
139
140 /* Nonzero means don't run process sentinels. This is used
141 when exiting. */
142 int inhibit_sentinels;
143
144 #ifdef subprocesses
145
146 Lisp_Object Qprocessp;
147 static Lisp_Object Qrun, Qstop, Qsignal;
148 static Lisp_Object Qopen, Qclosed, Qconnect, Qfailed, Qlisten;
149 Lisp_Object Qlocal;
150 static Lisp_Object Qipv4, Qdatagram, Qseqpacket;
151 static Lisp_Object Qreal, Qnetwork, Qserial;
152 #ifdef AF_INET6
153 static Lisp_Object Qipv6;
154 #endif
155 static Lisp_Object QCport, QCprocess;
156 Lisp_Object QCspeed;
157 Lisp_Object QCbytesize, QCstopbits, QCparity, Qodd, Qeven;
158 Lisp_Object QCflowcontrol, Qhw, Qsw, QCsummary;
159 static Lisp_Object QCbuffer, QChost, QCservice;
160 static Lisp_Object QClocal, QCremote, QCcoding;
161 static Lisp_Object QCserver, QCnowait, QCnoquery, QCstop;
162 static Lisp_Object QCsentinel, QClog, QCoptions, QCplist;
163 static Lisp_Object Qlast_nonmenu_event;
164 /* QCfamily is declared and initialized in xfaces.c,
165 QCfilter in keyboard.c. */
166 extern Lisp_Object QCfamily, QCfilter;
167
168 /* Qexit is declared and initialized in eval.c. */
169
170 /* QCfamily is defined in xfaces.c. */
171 extern Lisp_Object QCfamily;
172 /* QCfilter is defined in keyboard.c. */
173 extern Lisp_Object QCfilter;
174
175 #define NETCONN_P(p) (EQ (XPROCESS (p)->type, Qnetwork))
176 #define NETCONN1_P(p) (EQ ((p)->type, Qnetwork))
177 #define SERIALCONN_P(p) (EQ (XPROCESS (p)->type, Qserial))
178 #define SERIALCONN1_P(p) (EQ ((p)->type, Qserial))
179
180 #ifndef HAVE_H_ERRNO
181 extern int h_errno;
182 #endif
183
184 /* Number of events of change of status of a process. */
185 static EMACS_INT process_tick;
186 /* Number of events for which the user or sentinel has been notified. */
187 static EMACS_INT update_tick;
188
189 /* Define NON_BLOCKING_CONNECT if we can support non-blocking connects. */
190
191 /* Only W32 has this, it really means that select can't take write mask. */
192 #ifdef BROKEN_NON_BLOCKING_CONNECT
193 #undef NON_BLOCKING_CONNECT
194 #define SELECT_CANT_DO_WRITE_MASK
195 #else
196 #ifndef NON_BLOCKING_CONNECT
197 #ifdef HAVE_SELECT
198 #if defined (HAVE_GETPEERNAME) || defined (GNU_LINUX)
199 #if defined (O_NONBLOCK) || defined (O_NDELAY)
200 #if defined (EWOULDBLOCK) || defined (EINPROGRESS)
201 #define NON_BLOCKING_CONNECT
202 #endif /* EWOULDBLOCK || EINPROGRESS */
203 #endif /* O_NONBLOCK || O_NDELAY */
204 #endif /* HAVE_GETPEERNAME || GNU_LINUX */
205 #endif /* HAVE_SELECT */
206 #endif /* NON_BLOCKING_CONNECT */
207 #endif /* BROKEN_NON_BLOCKING_CONNECT */
208
209 /* Define DATAGRAM_SOCKETS if datagrams can be used safely on
210 this system. We need to read full packets, so we need a
211 "non-destructive" select. So we require either native select,
212 or emulation of select using FIONREAD. */
213
214 #ifdef BROKEN_DATAGRAM_SOCKETS
215 #undef DATAGRAM_SOCKETS
216 #else
217 #ifndef DATAGRAM_SOCKETS
218 #if defined (HAVE_SELECT) || defined (FIONREAD)
219 #if defined (HAVE_SENDTO) && defined (HAVE_RECVFROM) && defined (EMSGSIZE)
220 #define DATAGRAM_SOCKETS
221 #endif /* HAVE_SENDTO && HAVE_RECVFROM && EMSGSIZE */
222 #endif /* HAVE_SELECT || FIONREAD */
223 #endif /* DATAGRAM_SOCKETS */
224 #endif /* BROKEN_DATAGRAM_SOCKETS */
225
226 #if defined HAVE_LOCAL_SOCKETS && defined DATAGRAM_SOCKETS
227 # define HAVE_SEQPACKET
228 #endif
229
230 #if !defined (ADAPTIVE_READ_BUFFERING) && !defined (NO_ADAPTIVE_READ_BUFFERING)
231 #ifdef EMACS_HAS_USECS
232 #define ADAPTIVE_READ_BUFFERING
233 #endif
234 #endif
235
236 #ifdef ADAPTIVE_READ_BUFFERING
237 #define READ_OUTPUT_DELAY_INCREMENT 10000
238 #define READ_OUTPUT_DELAY_MAX (READ_OUTPUT_DELAY_INCREMENT * 5)
239 #define READ_OUTPUT_DELAY_MAX_MAX (READ_OUTPUT_DELAY_INCREMENT * 7)
240
241 /* Number of processes which have a non-zero read_output_delay,
242 and therefore might be delayed for adaptive read buffering. */
243
244 static int process_output_delay_count;
245
246 /* Non-zero if any process has non-nil read_output_skip. */
247
248 static int process_output_skip;
249
250 #else
251 #define process_output_delay_count 0
252 #endif
253
254 static Lisp_Object Fget_process (Lisp_Object);
255 static void create_process (Lisp_Object, char **, Lisp_Object);
256 #ifdef SIGIO
257 static int keyboard_bit_set (SELECT_TYPE *);
258 #endif
259 static void deactivate_process (Lisp_Object);
260 static void status_notify (struct Lisp_Process *);
261 static int read_process_output (Lisp_Object, int);
262 static void create_pty (Lisp_Object);
263
264 /* If we support a window system, turn on the code to poll periodically
265 to detect C-g. It isn't actually used when doing interrupt input. */
266 #if defined (HAVE_WINDOW_SYSTEM) && !defined (USE_ASYNC_EVENTS)
267 #define POLL_FOR_INPUT
268 #endif
269
270 static Lisp_Object get_process (register Lisp_Object name);
271 static void exec_sentinel (Lisp_Object proc, Lisp_Object reason);
272
273 /* Mask of bits indicating the descriptors that we wait for input on. */
274
275 static SELECT_TYPE input_wait_mask;
276
277 /* Mask that excludes keyboard input descriptor(s). */
278
279 static SELECT_TYPE non_keyboard_wait_mask;
280
281 /* Mask that excludes process input descriptor(s). */
282
283 static SELECT_TYPE non_process_wait_mask;
284
285 /* Mask for selecting for write. */
286
287 static SELECT_TYPE write_mask;
288
289 #ifdef NON_BLOCKING_CONNECT
290 /* Mask of bits indicating the descriptors that we wait for connect to
291 complete on. Once they complete, they are removed from this mask
292 and added to the input_wait_mask and non_keyboard_wait_mask. */
293
294 static SELECT_TYPE connect_wait_mask;
295
296 /* Number of bits set in connect_wait_mask. */
297 static int num_pending_connects;
298 #endif /* NON_BLOCKING_CONNECT */
299
300 /* The largest descriptor currently in use for a process object. */
301 static int max_process_desc;
302
303 /* The largest descriptor currently in use for input. */
304 static int max_input_desc;
305
306 /* Indexed by descriptor, gives the process (if any) for that descriptor */
307 static Lisp_Object chan_process[MAXDESC];
308
309 /* Alist of elements (NAME . PROCESS) */
310 static Lisp_Object Vprocess_alist;
311
312 /* Buffered-ahead input char from process, indexed by channel.
313 -1 means empty (no char is buffered).
314 Used on sys V where the only way to tell if there is any
315 output from the process is to read at least one char.
316 Always -1 on systems that support FIONREAD. */
317
318 static int proc_buffered_char[MAXDESC];
319
320 /* Table of `struct coding-system' for each process. */
321 static struct coding_system *proc_decode_coding_system[MAXDESC];
322 static struct coding_system *proc_encode_coding_system[MAXDESC];
323
324 #ifdef DATAGRAM_SOCKETS
325 /* Table of `partner address' for datagram sockets. */
326 static struct sockaddr_and_len {
327 struct sockaddr *sa;
328 int len;
329 } datagram_address[MAXDESC];
330 #define DATAGRAM_CHAN_P(chan) (datagram_address[chan].sa != 0)
331 #define DATAGRAM_CONN_P(proc) (PROCESSP (proc) && datagram_address[XPROCESS (proc)->infd].sa != 0)
332 #else
333 #define DATAGRAM_CHAN_P(chan) (0)
334 #define DATAGRAM_CONN_P(proc) (0)
335 #endif
336
337 /* Maximum number of bytes to send to a pty without an eof. */
338 static int pty_max_bytes;
339
340 \f
341
342 static struct fd_callback_data
343 {
344 fd_callback func;
345 void *data;
346 #define FOR_READ 1
347 #define FOR_WRITE 2
348 int condition; /* mask of the defines above. */
349 } fd_callback_info[MAXDESC];
350
351
352 /* Add a file descriptor FD to be monitored for when read is possible.
353 When read is possible, call FUNC with argument DATA. */
354
355 void
356 add_read_fd (int fd, fd_callback func, void *data)
357 {
358 xassert (fd < MAXDESC);
359 add_keyboard_wait_descriptor (fd);
360
361 fd_callback_info[fd].func = func;
362 fd_callback_info[fd].data = data;
363 fd_callback_info[fd].condition |= FOR_READ;
364 }
365
366 /* Stop monitoring file descriptor FD for when read is possible. */
367
368 void
369 delete_read_fd (int fd)
370 {
371 xassert (fd < MAXDESC);
372 delete_keyboard_wait_descriptor (fd);
373
374 fd_callback_info[fd].condition &= ~FOR_READ;
375 if (fd_callback_info[fd].condition == 0)
376 {
377 fd_callback_info[fd].func = 0;
378 fd_callback_info[fd].data = 0;
379 }
380 }
381
382 /* Add a file descriptor FD to be monitored for when write is possible.
383 When write is possible, call FUNC with argument DATA. */
384
385 void
386 add_write_fd (int fd, fd_callback func, void *data)
387 {
388 xassert (fd < MAXDESC);
389 FD_SET (fd, &write_mask);
390 if (fd > max_input_desc)
391 max_input_desc = fd;
392
393 fd_callback_info[fd].func = func;
394 fd_callback_info[fd].data = data;
395 fd_callback_info[fd].condition |= FOR_WRITE;
396 }
397
398 /* Stop monitoring file descriptor FD for when write is possible. */
399
400 void
401 delete_write_fd (int fd)
402 {
403 int lim = max_input_desc;
404
405 xassert (fd < MAXDESC);
406 FD_CLR (fd, &write_mask);
407 fd_callback_info[fd].condition &= ~FOR_WRITE;
408 if (fd_callback_info[fd].condition == 0)
409 {
410 fd_callback_info[fd].func = 0;
411 fd_callback_info[fd].data = 0;
412
413 if (fd == max_input_desc)
414 for (fd = lim; fd >= 0; fd--)
415 if (FD_ISSET (fd, &input_wait_mask) || FD_ISSET (fd, &write_mask))
416 {
417 max_input_desc = fd;
418 break;
419 }
420
421 }
422 }
423
424 \f
425 /* Compute the Lisp form of the process status, p->status, from
426 the numeric status that was returned by `wait'. */
427
428 static Lisp_Object status_convert (int);
429
430 static void
431 update_status (struct Lisp_Process *p)
432 {
433 eassert (p->raw_status_new);
434 p->status = status_convert (p->raw_status);
435 p->raw_status_new = 0;
436 }
437
438 /* Convert a process status word in Unix format to
439 the list that we use internally. */
440
441 static Lisp_Object
442 status_convert (int w)
443 {
444 if (WIFSTOPPED (w))
445 return Fcons (Qstop, Fcons (make_number (WSTOPSIG (w)), Qnil));
446 else if (WIFEXITED (w))
447 return Fcons (Qexit, Fcons (make_number (WRETCODE (w)),
448 WCOREDUMP (w) ? Qt : Qnil));
449 else if (WIFSIGNALED (w))
450 return Fcons (Qsignal, Fcons (make_number (WTERMSIG (w)),
451 WCOREDUMP (w) ? Qt : Qnil));
452 else
453 return Qrun;
454 }
455
456 /* Given a status-list, extract the three pieces of information
457 and store them individually through the three pointers. */
458
459 static void
460 decode_status (Lisp_Object l, Lisp_Object *symbol, int *code, int *coredump)
461 {
462 Lisp_Object tem;
463
464 if (SYMBOLP (l))
465 {
466 *symbol = l;
467 *code = 0;
468 *coredump = 0;
469 }
470 else
471 {
472 *symbol = XCAR (l);
473 tem = XCDR (l);
474 *code = XFASTINT (XCAR (tem));
475 tem = XCDR (tem);
476 *coredump = !NILP (tem);
477 }
478 }
479
480 /* Return a string describing a process status list. */
481
482 static Lisp_Object
483 status_message (struct Lisp_Process *p)
484 {
485 Lisp_Object status = p->status;
486 Lisp_Object symbol;
487 int code, coredump;
488 Lisp_Object string, string2;
489
490 decode_status (status, &symbol, &code, &coredump);
491
492 if (EQ (symbol, Qsignal) || EQ (symbol, Qstop))
493 {
494 char *signame;
495 synchronize_system_messages_locale ();
496 signame = strsignal (code);
497 if (signame == 0)
498 string = build_string ("unknown");
499 else
500 {
501 int c1, c2;
502
503 string = make_unibyte_string (signame, strlen (signame));
504 if (! NILP (Vlocale_coding_system))
505 string = (code_convert_string_norecord
506 (string, Vlocale_coding_system, 0));
507 c1 = STRING_CHAR (SDATA (string));
508 c2 = downcase (c1);
509 if (c1 != c2)
510 Faset (string, make_number (0), make_number (c2));
511 }
512 string2 = build_string (coredump ? " (core dumped)\n" : "\n");
513 return concat2 (string, string2);
514 }
515 else if (EQ (symbol, Qexit))
516 {
517 if (NETCONN1_P (p))
518 return build_string (code == 0 ? "deleted\n" : "connection broken by remote peer\n");
519 if (code == 0)
520 return build_string ("finished\n");
521 string = Fnumber_to_string (make_number (code));
522 string2 = build_string (coredump ? " (core dumped)\n" : "\n");
523 return concat3 (build_string ("exited abnormally with code "),
524 string, string2);
525 }
526 else if (EQ (symbol, Qfailed))
527 {
528 string = Fnumber_to_string (make_number (code));
529 string2 = build_string ("\n");
530 return concat3 (build_string ("failed with code "),
531 string, string2);
532 }
533 else
534 return Fcopy_sequence (Fsymbol_name (symbol));
535 }
536 \f
537 #ifdef HAVE_PTYS
538
539 /* The file name of the pty opened by allocate_pty. */
540 static char pty_name[24];
541
542 /* Open an available pty, returning a file descriptor.
543 Return -1 on failure.
544 The file name of the terminal corresponding to the pty
545 is left in the variable pty_name. */
546
547 static int
548 allocate_pty (void)
549 {
550 int fd;
551
552 #ifdef PTY_ITERATION
553 PTY_ITERATION
554 #else
555 register int c, i;
556 for (c = FIRST_PTY_LETTER; c <= 'z'; c++)
557 for (i = 0; i < 16; i++)
558 #endif
559 {
560 #ifdef PTY_NAME_SPRINTF
561 PTY_NAME_SPRINTF
562 #else
563 sprintf (pty_name, "/dev/pty%c%x", c, i);
564 #endif /* no PTY_NAME_SPRINTF */
565
566 #ifdef PTY_OPEN
567 PTY_OPEN;
568 #else /* no PTY_OPEN */
569 {
570 { /* Some systems name their pseudoterminals so that there are gaps in
571 the usual sequence - for example, on HP9000/S700 systems, there
572 are no pseudoterminals with names ending in 'f'. So we wait for
573 three failures in a row before deciding that we've reached the
574 end of the ptys. */
575 int failed_count = 0;
576 struct stat stb;
577
578 if (stat (pty_name, &stb) < 0)
579 {
580 failed_count++;
581 if (failed_count >= 3)
582 return -1;
583 }
584 else
585 failed_count = 0;
586 }
587 # ifdef O_NONBLOCK
588 fd = emacs_open (pty_name, O_RDWR | O_NONBLOCK, 0);
589 # else
590 fd = emacs_open (pty_name, O_RDWR | O_NDELAY, 0);
591 # endif
592 }
593 #endif /* no PTY_OPEN */
594
595 if (fd >= 0)
596 {
597 /* check to make certain that both sides are available
598 this avoids a nasty yet stupid bug in rlogins */
599 #ifdef PTY_TTY_NAME_SPRINTF
600 PTY_TTY_NAME_SPRINTF
601 #else
602 sprintf (pty_name, "/dev/tty%c%x", c, i);
603 #endif /* no PTY_TTY_NAME_SPRINTF */
604 if (access (pty_name, 6) != 0)
605 {
606 emacs_close (fd);
607 # ifndef __sgi
608 continue;
609 # else
610 return -1;
611 # endif /* __sgi */
612 }
613 setup_pty (fd);
614 return fd;
615 }
616 }
617 return -1;
618 }
619 #endif /* HAVE_PTYS */
620 \f
621 static Lisp_Object
622 make_process (Lisp_Object name)
623 {
624 register Lisp_Object val, tem, name1;
625 register struct Lisp_Process *p;
626 char suffix[sizeof "<>" + INT_STRLEN_BOUND (printmax_t)];
627 printmax_t i;
628
629 p = allocate_process ();
630
631 p->infd = -1;
632 p->outfd = -1;
633 p->tick = 0;
634 p->update_tick = 0;
635 p->pid = 0;
636 p->pty_flag = 0;
637 p->raw_status_new = 0;
638 p->status = Qrun;
639 p->mark = Fmake_marker ();
640 p->kill_without_query = 0;
641 p->write_queue = Qnil;
642
643 #ifdef ADAPTIVE_READ_BUFFERING
644 p->adaptive_read_buffering = 0;
645 p->read_output_delay = 0;
646 p->read_output_skip = 0;
647 #endif
648
649 #ifdef HAVE_GNUTLS
650 p->gnutls_initstage = GNUTLS_STAGE_EMPTY;
651 /* Default log level. */
652 p->gnutls_log_level = 0;
653 /* GnuTLS handshakes attempted for this connection. */
654 p->gnutls_handshakes_tried = 0;
655 p->gnutls_p = 0;
656 p->gnutls_state = NULL;
657 p->gnutls_x509_cred = NULL;
658 p->gnutls_anon_cred = NULL;
659 #endif
660
661 /* If name is already in use, modify it until it is unused. */
662
663 name1 = name;
664 for (i = 1; ; i++)
665 {
666 tem = Fget_process (name1);
667 if (NILP (tem)) break;
668 sprintf (suffix, "<%"pMd">", i);
669 name1 = concat2 (name, build_string (suffix));
670 }
671 name = name1;
672 p->name = name;
673 XSETPROCESS (val, p);
674 Vprocess_alist = Fcons (Fcons (name, val), Vprocess_alist);
675 return val;
676 }
677
678 static void
679 remove_process (register Lisp_Object proc)
680 {
681 register Lisp_Object pair;
682
683 pair = Frassq (proc, Vprocess_alist);
684 Vprocess_alist = Fdelq (pair, Vprocess_alist);
685
686 deactivate_process (proc);
687 }
688
689 \f
690 DEFUN ("processp", Fprocessp, Sprocessp, 1, 1, 0,
691 doc: /* Return t if OBJECT is a process. */)
692 (Lisp_Object object)
693 {
694 return PROCESSP (object) ? Qt : Qnil;
695 }
696
697 DEFUN ("get-process", Fget_process, Sget_process, 1, 1, 0,
698 doc: /* Return the process named NAME, or nil if there is none. */)
699 (register Lisp_Object name)
700 {
701 if (PROCESSP (name))
702 return name;
703 CHECK_STRING (name);
704 return Fcdr (Fassoc (name, Vprocess_alist));
705 }
706
707 /* This is how commands for the user decode process arguments. It
708 accepts a process, a process name, a buffer, a buffer name, or nil.
709 Buffers denote the first process in the buffer, and nil denotes the
710 current buffer. */
711
712 static Lisp_Object
713 get_process (register Lisp_Object name)
714 {
715 register Lisp_Object proc, obj;
716 if (STRINGP (name))
717 {
718 obj = Fget_process (name);
719 if (NILP (obj))
720 obj = Fget_buffer (name);
721 if (NILP (obj))
722 error ("Process %s does not exist", SDATA (name));
723 }
724 else if (NILP (name))
725 obj = Fcurrent_buffer ();
726 else
727 obj = name;
728
729 /* Now obj should be either a buffer object or a process object.
730 */
731 if (BUFFERP (obj))
732 {
733 proc = Fget_buffer_process (obj);
734 if (NILP (proc))
735 error ("Buffer %s has no process", SDATA (BVAR (XBUFFER (obj), name)));
736 }
737 else
738 {
739 CHECK_PROCESS (obj);
740 proc = obj;
741 }
742 return proc;
743 }
744
745
746 #ifdef SIGCHLD
747 /* Fdelete_process promises to immediately forget about the process, but in
748 reality, Emacs needs to remember those processes until they have been
749 treated by sigchld_handler; otherwise this handler would consider the
750 process as being synchronous and say that the synchronous process is
751 dead. */
752 static Lisp_Object deleted_pid_list;
753 #endif
754
755 DEFUN ("delete-process", Fdelete_process, Sdelete_process, 1, 1, 0,
756 doc: /* Delete PROCESS: kill it and forget about it immediately.
757 PROCESS may be a process, a buffer, the name of a process or buffer, or
758 nil, indicating the current buffer's process. */)
759 (register Lisp_Object process)
760 {
761 register struct Lisp_Process *p;
762
763 process = get_process (process);
764 p = XPROCESS (process);
765
766 p->raw_status_new = 0;
767 if (NETCONN1_P (p) || SERIALCONN1_P (p))
768 {
769 p->status = Fcons (Qexit, Fcons (make_number (0), Qnil));
770 p->tick = ++process_tick;
771 status_notify (p);
772 redisplay_preserve_echo_area (13);
773 }
774 else if (p->infd >= 0)
775 {
776 #ifdef SIGCHLD
777 Lisp_Object symbol;
778 pid_t pid = p->pid;
779
780 /* No problem storing the pid here, as it is still in Vprocess_alist. */
781 deleted_pid_list = Fcons (make_fixnum_or_float (pid),
782 /* GC treated elements set to nil. */
783 Fdelq (Qnil, deleted_pid_list));
784 /* If the process has already signaled, remove it from the list. */
785 if (p->raw_status_new)
786 update_status (p);
787 symbol = p->status;
788 if (CONSP (p->status))
789 symbol = XCAR (p->status);
790 if (EQ (symbol, Qsignal) || EQ (symbol, Qexit))
791 deleted_pid_list
792 = Fdelete (make_fixnum_or_float (pid), deleted_pid_list);
793 else
794 #endif
795 {
796 Fkill_process (process, Qnil);
797 /* Do this now, since remove_process will make sigchld_handler do nothing. */
798 p->status
799 = Fcons (Qsignal, Fcons (make_number (SIGKILL), Qnil));
800 p->tick = ++process_tick;
801 status_notify (p);
802 redisplay_preserve_echo_area (13);
803 }
804 }
805 remove_process (process);
806 return Qnil;
807 }
808 \f
809 DEFUN ("process-status", Fprocess_status, Sprocess_status, 1, 1, 0,
810 doc: /* Return the status of PROCESS.
811 The returned value is one of the following symbols:
812 run -- for a process that is running.
813 stop -- for a process stopped but continuable.
814 exit -- for a process that has exited.
815 signal -- for a process that has got a fatal signal.
816 open -- for a network stream connection that is open.
817 listen -- for a network stream server that is listening.
818 closed -- for a network stream connection that is closed.
819 connect -- when waiting for a non-blocking connection to complete.
820 failed -- when a non-blocking connection has failed.
821 nil -- if arg is a process name and no such process exists.
822 PROCESS may be a process, a buffer, the name of a process, or
823 nil, indicating the current buffer's process. */)
824 (register Lisp_Object process)
825 {
826 register struct Lisp_Process *p;
827 register Lisp_Object status;
828
829 if (STRINGP (process))
830 process = Fget_process (process);
831 else
832 process = get_process (process);
833
834 if (NILP (process))
835 return process;
836
837 p = XPROCESS (process);
838 if (p->raw_status_new)
839 update_status (p);
840 status = p->status;
841 if (CONSP (status))
842 status = XCAR (status);
843 if (NETCONN1_P (p) || SERIALCONN1_P (p))
844 {
845 if (EQ (status, Qexit))
846 status = Qclosed;
847 else if (EQ (p->command, Qt))
848 status = Qstop;
849 else if (EQ (status, Qrun))
850 status = Qopen;
851 }
852 return status;
853 }
854
855 DEFUN ("process-exit-status", Fprocess_exit_status, Sprocess_exit_status,
856 1, 1, 0,
857 doc: /* Return the exit status of PROCESS or the signal number that killed it.
858 If PROCESS has not yet exited or died, return 0. */)
859 (register Lisp_Object process)
860 {
861 CHECK_PROCESS (process);
862 if (XPROCESS (process)->raw_status_new)
863 update_status (XPROCESS (process));
864 if (CONSP (XPROCESS (process)->status))
865 return XCAR (XCDR (XPROCESS (process)->status));
866 return make_number (0);
867 }
868
869 DEFUN ("process-id", Fprocess_id, Sprocess_id, 1, 1, 0,
870 doc: /* Return the process id of PROCESS.
871 This is the pid of the external process which PROCESS uses or talks to.
872 For a network connection, this value is nil. */)
873 (register Lisp_Object process)
874 {
875 pid_t pid;
876
877 CHECK_PROCESS (process);
878 pid = XPROCESS (process)->pid;
879 return (pid ? make_fixnum_or_float (pid) : Qnil);
880 }
881
882 DEFUN ("process-name", Fprocess_name, Sprocess_name, 1, 1, 0,
883 doc: /* Return the name of PROCESS, as a string.
884 This is the name of the program invoked in PROCESS,
885 possibly modified to make it unique among process names. */)
886 (register Lisp_Object process)
887 {
888 CHECK_PROCESS (process);
889 return XPROCESS (process)->name;
890 }
891
892 DEFUN ("process-command", Fprocess_command, Sprocess_command, 1, 1, 0,
893 doc: /* Return the command that was executed to start PROCESS.
894 This is a list of strings, the first string being the program executed
895 and the rest of the strings being the arguments given to it.
896 For a network or serial process, this is nil (process is running) or t
897 \(process is stopped). */)
898 (register Lisp_Object process)
899 {
900 CHECK_PROCESS (process);
901 return XPROCESS (process)->command;
902 }
903
904 DEFUN ("process-tty-name", Fprocess_tty_name, Sprocess_tty_name, 1, 1, 0,
905 doc: /* Return the name of the terminal PROCESS uses, or nil if none.
906 This is the terminal that the process itself reads and writes on,
907 not the name of the pty that Emacs uses to talk with that terminal. */)
908 (register Lisp_Object process)
909 {
910 CHECK_PROCESS (process);
911 return XPROCESS (process)->tty_name;
912 }
913
914 DEFUN ("set-process-buffer", Fset_process_buffer, Sset_process_buffer,
915 2, 2, 0,
916 doc: /* Set buffer associated with PROCESS to BUFFER (a buffer, or nil).
917 Return BUFFER. */)
918 (register Lisp_Object process, Lisp_Object buffer)
919 {
920 struct Lisp_Process *p;
921
922 CHECK_PROCESS (process);
923 if (!NILP (buffer))
924 CHECK_BUFFER (buffer);
925 p = XPROCESS (process);
926 p->buffer = buffer;
927 if (NETCONN1_P (p) || SERIALCONN1_P (p))
928 p->childp = Fplist_put (p->childp, QCbuffer, buffer);
929 setup_process_coding_systems (process);
930 return buffer;
931 }
932
933 DEFUN ("process-buffer", Fprocess_buffer, Sprocess_buffer,
934 1, 1, 0,
935 doc: /* Return the buffer PROCESS is associated with.
936 Output from PROCESS is inserted in this buffer unless PROCESS has a filter. */)
937 (register Lisp_Object process)
938 {
939 CHECK_PROCESS (process);
940 return XPROCESS (process)->buffer;
941 }
942
943 DEFUN ("process-mark", Fprocess_mark, Sprocess_mark,
944 1, 1, 0,
945 doc: /* Return the marker for the end of the last output from PROCESS. */)
946 (register Lisp_Object process)
947 {
948 CHECK_PROCESS (process);
949 return XPROCESS (process)->mark;
950 }
951
952 DEFUN ("set-process-filter", Fset_process_filter, Sset_process_filter,
953 2, 2, 0,
954 doc: /* Give PROCESS the filter function FILTER; nil means no filter.
955 A value of t means stop accepting output from the process.
956
957 When a process has a filter, its buffer is not used for output.
958 Instead, each time it does output, the entire string of output is
959 passed to the filter.
960
961 The filter gets two arguments: the process and the string of output.
962 The string argument is normally a multibyte string, except:
963 - if the process' input coding system is no-conversion or raw-text,
964 it is a unibyte string (the non-converted input), or else
965 - if `default-enable-multibyte-characters' is nil, it is a unibyte
966 string (the result of converting the decoded input multibyte
967 string to unibyte with `string-make-unibyte'). */)
968 (register Lisp_Object process, Lisp_Object filter)
969 {
970 struct Lisp_Process *p;
971
972 CHECK_PROCESS (process);
973 p = XPROCESS (process);
974
975 /* Don't signal an error if the process' input file descriptor
976 is closed. This could make debugging Lisp more difficult,
977 for example when doing something like
978
979 (setq process (start-process ...))
980 (debug)
981 (set-process-filter process ...) */
982
983 if (p->infd >= 0)
984 {
985 if (EQ (filter, Qt) && !EQ (p->status, Qlisten))
986 {
987 FD_CLR (p->infd, &input_wait_mask);
988 FD_CLR (p->infd, &non_keyboard_wait_mask);
989 }
990 else if (EQ (p->filter, Qt)
991 /* Network or serial process not stopped: */
992 && !EQ (p->command, Qt))
993 {
994 FD_SET (p->infd, &input_wait_mask);
995 FD_SET (p->infd, &non_keyboard_wait_mask);
996 }
997 }
998
999 p->filter = filter;
1000 if (NETCONN1_P (p) || SERIALCONN1_P (p))
1001 p->childp = Fplist_put (p->childp, QCfilter, filter);
1002 setup_process_coding_systems (process);
1003 return filter;
1004 }
1005
1006 DEFUN ("process-filter", Fprocess_filter, Sprocess_filter,
1007 1, 1, 0,
1008 doc: /* Returns the filter function of PROCESS; nil if none.
1009 See `set-process-filter' for more info on filter functions. */)
1010 (register Lisp_Object process)
1011 {
1012 CHECK_PROCESS (process);
1013 return XPROCESS (process)->filter;
1014 }
1015
1016 DEFUN ("set-process-sentinel", Fset_process_sentinel, Sset_process_sentinel,
1017 2, 2, 0,
1018 doc: /* Give PROCESS the sentinel SENTINEL; nil for none.
1019 The sentinel is called as a function when the process changes state.
1020 It gets two arguments: the process, and a string describing the change. */)
1021 (register Lisp_Object process, Lisp_Object sentinel)
1022 {
1023 struct Lisp_Process *p;
1024
1025 CHECK_PROCESS (process);
1026 p = XPROCESS (process);
1027
1028 p->sentinel = sentinel;
1029 if (NETCONN1_P (p) || SERIALCONN1_P (p))
1030 p->childp = Fplist_put (p->childp, QCsentinel, sentinel);
1031 return sentinel;
1032 }
1033
1034 DEFUN ("process-sentinel", Fprocess_sentinel, Sprocess_sentinel,
1035 1, 1, 0,
1036 doc: /* Return the sentinel of PROCESS; nil if none.
1037 See `set-process-sentinel' for more info on sentinels. */)
1038 (register Lisp_Object process)
1039 {
1040 CHECK_PROCESS (process);
1041 return XPROCESS (process)->sentinel;
1042 }
1043
1044 DEFUN ("set-process-window-size", Fset_process_window_size,
1045 Sset_process_window_size, 3, 3, 0,
1046 doc: /* Tell PROCESS that it has logical window size HEIGHT and WIDTH. */)
1047 (register Lisp_Object process, Lisp_Object height, Lisp_Object width)
1048 {
1049 CHECK_PROCESS (process);
1050 CHECK_RANGED_INTEGER (0, height, INT_MAX);
1051 CHECK_RANGED_INTEGER (0, width, INT_MAX);
1052
1053 if (XPROCESS (process)->infd < 0
1054 || set_window_size (XPROCESS (process)->infd,
1055 XINT (height), XINT (width)) <= 0)
1056 return Qnil;
1057 else
1058 return Qt;
1059 }
1060
1061 DEFUN ("set-process-inherit-coding-system-flag",
1062 Fset_process_inherit_coding_system_flag,
1063 Sset_process_inherit_coding_system_flag, 2, 2, 0,
1064 doc: /* Determine whether buffer of PROCESS will inherit coding-system.
1065 If the second argument FLAG is non-nil, then the variable
1066 `buffer-file-coding-system' of the buffer associated with PROCESS
1067 will be bound to the value of the coding system used to decode
1068 the process output.
1069
1070 This is useful when the coding system specified for the process buffer
1071 leaves either the character code conversion or the end-of-line conversion
1072 unspecified, or if the coding system used to decode the process output
1073 is more appropriate for saving the process buffer.
1074
1075 Binding the variable `inherit-process-coding-system' to non-nil before
1076 starting the process is an alternative way of setting the inherit flag
1077 for the process which will run.
1078
1079 This function returns FLAG. */)
1080 (register Lisp_Object process, Lisp_Object flag)
1081 {
1082 CHECK_PROCESS (process);
1083 XPROCESS (process)->inherit_coding_system_flag = !NILP (flag);
1084 return flag;
1085 }
1086
1087 DEFUN ("set-process-query-on-exit-flag",
1088 Fset_process_query_on_exit_flag, Sset_process_query_on_exit_flag,
1089 2, 2, 0,
1090 doc: /* Specify if query is needed for PROCESS when Emacs is exited.
1091 If the second argument FLAG is non-nil, Emacs will query the user before
1092 exiting or killing a buffer if PROCESS is running. This function
1093 returns FLAG. */)
1094 (register Lisp_Object process, Lisp_Object flag)
1095 {
1096 CHECK_PROCESS (process);
1097 XPROCESS (process)->kill_without_query = NILP (flag);
1098 return flag;
1099 }
1100
1101 DEFUN ("process-query-on-exit-flag",
1102 Fprocess_query_on_exit_flag, Sprocess_query_on_exit_flag,
1103 1, 1, 0,
1104 doc: /* Return the current value of query-on-exit flag for PROCESS. */)
1105 (register Lisp_Object process)
1106 {
1107 CHECK_PROCESS (process);
1108 return (XPROCESS (process)->kill_without_query ? Qnil : Qt);
1109 }
1110
1111 #ifdef DATAGRAM_SOCKETS
1112 static Lisp_Object Fprocess_datagram_address (Lisp_Object);
1113 #endif
1114
1115 DEFUN ("process-contact", Fprocess_contact, Sprocess_contact,
1116 1, 2, 0,
1117 doc: /* Return the contact info of PROCESS; t for a real child.
1118 For a network or serial connection, the value depends on the optional
1119 KEY arg. If KEY is nil, value is a cons cell of the form (HOST
1120 SERVICE) for a network connection or (PORT SPEED) for a serial
1121 connection. If KEY is t, the complete contact information for the
1122 connection is returned, else the specific value for the keyword KEY is
1123 returned. See `make-network-process' or `make-serial-process' for a
1124 list of keywords. */)
1125 (register Lisp_Object process, Lisp_Object key)
1126 {
1127 Lisp_Object contact;
1128
1129 CHECK_PROCESS (process);
1130 contact = XPROCESS (process)->childp;
1131
1132 #ifdef DATAGRAM_SOCKETS
1133 if (DATAGRAM_CONN_P (process)
1134 && (EQ (key, Qt) || EQ (key, QCremote)))
1135 contact = Fplist_put (contact, QCremote,
1136 Fprocess_datagram_address (process));
1137 #endif
1138
1139 if ((!NETCONN_P (process) && !SERIALCONN_P (process)) || EQ (key, Qt))
1140 return contact;
1141 if (NILP (key) && NETCONN_P (process))
1142 return Fcons (Fplist_get (contact, QChost),
1143 Fcons (Fplist_get (contact, QCservice), Qnil));
1144 if (NILP (key) && SERIALCONN_P (process))
1145 return Fcons (Fplist_get (contact, QCport),
1146 Fcons (Fplist_get (contact, QCspeed), Qnil));
1147 return Fplist_get (contact, key);
1148 }
1149
1150 DEFUN ("process-plist", Fprocess_plist, Sprocess_plist,
1151 1, 1, 0,
1152 doc: /* Return the plist of PROCESS. */)
1153 (register Lisp_Object process)
1154 {
1155 CHECK_PROCESS (process);
1156 return XPROCESS (process)->plist;
1157 }
1158
1159 DEFUN ("set-process-plist", Fset_process_plist, Sset_process_plist,
1160 2, 2, 0,
1161 doc: /* Replace the plist of PROCESS with PLIST. Returns PLIST. */)
1162 (register Lisp_Object process, Lisp_Object plist)
1163 {
1164 CHECK_PROCESS (process);
1165 CHECK_LIST (plist);
1166
1167 XPROCESS (process)->plist = plist;
1168 return plist;
1169 }
1170
1171 #if 0 /* Turned off because we don't currently record this info
1172 in the process. Perhaps add it. */
1173 DEFUN ("process-connection", Fprocess_connection, Sprocess_connection, 1, 1, 0,
1174 doc: /* Return the connection type of PROCESS.
1175 The value is nil for a pipe, t or `pty' for a pty, or `stream' for
1176 a socket connection. */)
1177 (Lisp_Object process)
1178 {
1179 return XPROCESS (process)->type;
1180 }
1181 #endif
1182
1183 DEFUN ("process-type", Fprocess_type, Sprocess_type, 1, 1, 0,
1184 doc: /* Return the connection type of PROCESS.
1185 The value is either the symbol `real', `network', or `serial'.
1186 PROCESS may be a process, a buffer, the name of a process or buffer, or
1187 nil, indicating the current buffer's process. */)
1188 (Lisp_Object process)
1189 {
1190 Lisp_Object proc;
1191 proc = get_process (process);
1192 return XPROCESS (proc)->type;
1193 }
1194
1195 DEFUN ("format-network-address", Fformat_network_address, Sformat_network_address,
1196 1, 2, 0,
1197 doc: /* Convert network ADDRESS from internal format to a string.
1198 A 4 or 5 element vector represents an IPv4 address (with port number).
1199 An 8 or 9 element vector represents an IPv6 address (with port number).
1200 If optional second argument OMIT-PORT is non-nil, don't include a port
1201 number in the string, even when present in ADDRESS.
1202 Returns nil if format of ADDRESS is invalid. */)
1203 (Lisp_Object address, Lisp_Object omit_port)
1204 {
1205 if (NILP (address))
1206 return Qnil;
1207
1208 if (STRINGP (address)) /* AF_LOCAL */
1209 return address;
1210
1211 if (VECTORP (address)) /* AF_INET or AF_INET6 */
1212 {
1213 register struct Lisp_Vector *p = XVECTOR (address);
1214 ptrdiff_t size = p->header.size;
1215 Lisp_Object args[10];
1216 int nargs, i;
1217
1218 if (size == 4 || (size == 5 && !NILP (omit_port)))
1219 {
1220 args[0] = build_string ("%d.%d.%d.%d");
1221 nargs = 4;
1222 }
1223 else if (size == 5)
1224 {
1225 args[0] = build_string ("%d.%d.%d.%d:%d");
1226 nargs = 5;
1227 }
1228 else if (size == 8 || (size == 9 && !NILP (omit_port)))
1229 {
1230 args[0] = build_string ("%x:%x:%x:%x:%x:%x:%x:%x");
1231 nargs = 8;
1232 }
1233 else if (size == 9)
1234 {
1235 args[0] = build_string ("[%x:%x:%x:%x:%x:%x:%x:%x]:%d");
1236 nargs = 9;
1237 }
1238 else
1239 return Qnil;
1240
1241 for (i = 0; i < nargs; i++)
1242 {
1243 if (! RANGED_INTEGERP (0, p->contents[i], 65535))
1244 return Qnil;
1245
1246 if (nargs <= 5 /* IPv4 */
1247 && i < 4 /* host, not port */
1248 && XINT (p->contents[i]) > 255)
1249 return Qnil;
1250
1251 args[i+1] = p->contents[i];
1252 }
1253
1254 return Fformat (nargs+1, args);
1255 }
1256
1257 if (CONSP (address))
1258 {
1259 Lisp_Object args[2];
1260 args[0] = build_string ("<Family %d>");
1261 args[1] = Fcar (address);
1262 return Fformat (2, args);
1263 }
1264
1265 return Qnil;
1266 }
1267
1268 DEFUN ("process-list", Fprocess_list, Sprocess_list, 0, 0, 0,
1269 doc: /* Return a list of all processes. */)
1270 (void)
1271 {
1272 return Fmapcar (Qcdr, Vprocess_alist);
1273 }
1274 \f
1275 /* Starting asynchronous inferior processes. */
1276
1277 static Lisp_Object start_process_unwind (Lisp_Object proc);
1278
1279 DEFUN ("start-process", Fstart_process, Sstart_process, 3, MANY, 0,
1280 doc: /* Start a program in a subprocess. Return the process object for it.
1281 NAME is name for process. It is modified if necessary to make it unique.
1282 BUFFER is the buffer (or buffer name) to associate with the process.
1283
1284 Process output (both standard output and standard error streams) goes
1285 at end of BUFFER, unless you specify an output stream or filter
1286 function to handle the output. BUFFER may also be nil, meaning that
1287 this process is not associated with any buffer.
1288
1289 PROGRAM is the program file name. It is searched for in `exec-path'
1290 (which see). If nil, just associate a pty with the buffer. Remaining
1291 arguments are strings to give program as arguments.
1292
1293 If you want to separate standard output from standard error, invoke
1294 the command through a shell and redirect one of them using the shell
1295 syntax.
1296
1297 usage: (start-process NAME BUFFER PROGRAM &rest PROGRAM-ARGS) */)
1298 (ptrdiff_t nargs, Lisp_Object *args)
1299 {
1300 Lisp_Object buffer, name, program, proc, current_dir, tem;
1301 register unsigned char **new_argv;
1302 ptrdiff_t i;
1303 ptrdiff_t count = SPECPDL_INDEX ();
1304
1305 buffer = args[1];
1306 if (!NILP (buffer))
1307 buffer = Fget_buffer_create (buffer);
1308
1309 /* Make sure that the child will be able to chdir to the current
1310 buffer's current directory, or its unhandled equivalent. We
1311 can't just have the child check for an error when it does the
1312 chdir, since it's in a vfork.
1313
1314 We have to GCPRO around this because Fexpand_file_name and
1315 Funhandled_file_name_directory might call a file name handling
1316 function. The argument list is protected by the caller, so all
1317 we really have to worry about is buffer. */
1318 {
1319 struct gcpro gcpro1, gcpro2;
1320
1321 current_dir = BVAR (current_buffer, directory);
1322
1323 GCPRO2 (buffer, current_dir);
1324
1325 current_dir = Funhandled_file_name_directory (current_dir);
1326 if (NILP (current_dir))
1327 /* If the file name handler says that current_dir is unreachable, use
1328 a sensible default. */
1329 current_dir = build_string ("~/");
1330 current_dir = expand_and_dir_to_file (current_dir, Qnil);
1331 if (NILP (Ffile_accessible_directory_p (current_dir)))
1332 report_file_error ("Setting current directory",
1333 Fcons (BVAR (current_buffer, directory), Qnil));
1334
1335 UNGCPRO;
1336 }
1337
1338 name = args[0];
1339 CHECK_STRING (name);
1340
1341 program = args[2];
1342
1343 if (!NILP (program))
1344 CHECK_STRING (program);
1345
1346 proc = make_process (name);
1347 /* If an error occurs and we can't start the process, we want to
1348 remove it from the process list. This means that each error
1349 check in create_process doesn't need to call remove_process
1350 itself; it's all taken care of here. */
1351 record_unwind_protect (start_process_unwind, proc);
1352
1353 XPROCESS (proc)->childp = Qt;
1354 XPROCESS (proc)->plist = Qnil;
1355 XPROCESS (proc)->type = Qreal;
1356 XPROCESS (proc)->buffer = buffer;
1357 XPROCESS (proc)->sentinel = Qnil;
1358 XPROCESS (proc)->filter = Qnil;
1359 XPROCESS (proc)->command = Flist (nargs - 2, args + 2);
1360
1361 #ifdef HAVE_GNUTLS
1362 /* AKA GNUTLS_INITSTAGE(proc). */
1363 XPROCESS (proc)->gnutls_initstage = GNUTLS_STAGE_EMPTY;
1364 XPROCESS (proc)->gnutls_cred_type = Qnil;
1365 #endif
1366
1367 #ifdef ADAPTIVE_READ_BUFFERING
1368 XPROCESS (proc)->adaptive_read_buffering
1369 = (NILP (Vprocess_adaptive_read_buffering) ? 0
1370 : EQ (Vprocess_adaptive_read_buffering, Qt) ? 1 : 2);
1371 #endif
1372
1373 /* Make the process marker point into the process buffer (if any). */
1374 if (BUFFERP (buffer))
1375 set_marker_both (XPROCESS (proc)->mark, buffer,
1376 BUF_ZV (XBUFFER (buffer)),
1377 BUF_ZV_BYTE (XBUFFER (buffer)));
1378
1379 {
1380 /* Decide coding systems for communicating with the process. Here
1381 we don't setup the structure coding_system nor pay attention to
1382 unibyte mode. They are done in create_process. */
1383
1384 /* Qt denotes we have not yet called Ffind_operation_coding_system. */
1385 Lisp_Object coding_systems = Qt;
1386 Lisp_Object val, *args2;
1387 struct gcpro gcpro1, gcpro2;
1388
1389 val = Vcoding_system_for_read;
1390 if (NILP (val))
1391 {
1392 args2 = (Lisp_Object *) alloca ((nargs + 1) * sizeof *args2);
1393 args2[0] = Qstart_process;
1394 for (i = 0; i < nargs; i++) args2[i + 1] = args[i];
1395 GCPRO2 (proc, current_dir);
1396 if (!NILP (program))
1397 coding_systems = Ffind_operation_coding_system (nargs + 1, args2);
1398 UNGCPRO;
1399 if (CONSP (coding_systems))
1400 val = XCAR (coding_systems);
1401 else if (CONSP (Vdefault_process_coding_system))
1402 val = XCAR (Vdefault_process_coding_system);
1403 }
1404 XPROCESS (proc)->decode_coding_system = val;
1405
1406 val = Vcoding_system_for_write;
1407 if (NILP (val))
1408 {
1409 if (EQ (coding_systems, Qt))
1410 {
1411 args2 = (Lisp_Object *) alloca ((nargs + 1) * sizeof *args2);
1412 args2[0] = Qstart_process;
1413 for (i = 0; i < nargs; i++) args2[i + 1] = args[i];
1414 GCPRO2 (proc, current_dir);
1415 if (!NILP (program))
1416 coding_systems = Ffind_operation_coding_system (nargs + 1, args2);
1417 UNGCPRO;
1418 }
1419 if (CONSP (coding_systems))
1420 val = XCDR (coding_systems);
1421 else if (CONSP (Vdefault_process_coding_system))
1422 val = XCDR (Vdefault_process_coding_system);
1423 }
1424 XPROCESS (proc)->encode_coding_system = val;
1425 /* Note: At this moment, the above coding system may leave
1426 text-conversion or eol-conversion unspecified. They will be
1427 decided after we read output from the process and decode it by
1428 some coding system, or just before we actually send a text to
1429 the process. */
1430 }
1431
1432
1433 XPROCESS (proc)->decoding_buf = empty_unibyte_string;
1434 XPROCESS (proc)->decoding_carryover = 0;
1435 XPROCESS (proc)->encoding_buf = empty_unibyte_string;
1436
1437 XPROCESS (proc)->inherit_coding_system_flag
1438 = !(NILP (buffer) || !inherit_process_coding_system);
1439
1440 if (!NILP (program))
1441 {
1442 /* If program file name is not absolute, search our path for it.
1443 Put the name we will really use in TEM. */
1444 if (!IS_DIRECTORY_SEP (SREF (program, 0))
1445 && !(SCHARS (program) > 1
1446 && IS_DEVICE_SEP (SREF (program, 1))))
1447 {
1448 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
1449
1450 tem = Qnil;
1451 GCPRO4 (name, program, buffer, current_dir);
1452 openp (Vexec_path, program, Vexec_suffixes, &tem, make_number (X_OK));
1453 UNGCPRO;
1454 if (NILP (tem))
1455 report_file_error ("Searching for program", Fcons (program, Qnil));
1456 tem = Fexpand_file_name (tem, Qnil);
1457 }
1458 else
1459 {
1460 if (!NILP (Ffile_directory_p (program)))
1461 error ("Specified program for new process is a directory");
1462 tem = program;
1463 }
1464
1465 /* If program file name starts with /: for quoting a magic name,
1466 discard that. */
1467 if (SBYTES (tem) > 2 && SREF (tem, 0) == '/'
1468 && SREF (tem, 1) == ':')
1469 tem = Fsubstring (tem, make_number (2), Qnil);
1470
1471 {
1472 Lisp_Object arg_encoding = Qnil;
1473 struct gcpro gcpro1;
1474 GCPRO1 (tem);
1475
1476 /* Encode the file name and put it in NEW_ARGV.
1477 That's where the child will use it to execute the program. */
1478 tem = Fcons (ENCODE_FILE (tem), Qnil);
1479
1480 /* Here we encode arguments by the coding system used for sending
1481 data to the process. We don't support using different coding
1482 systems for encoding arguments and for encoding data sent to the
1483 process. */
1484
1485 for (i = 3; i < nargs; i++)
1486 {
1487 tem = Fcons (args[i], tem);
1488 CHECK_STRING (XCAR (tem));
1489 if (STRING_MULTIBYTE (XCAR (tem)))
1490 {
1491 if (NILP (arg_encoding))
1492 arg_encoding = (complement_process_encoding_system
1493 (XPROCESS (proc)->encode_coding_system));
1494 XSETCAR (tem,
1495 code_convert_string_norecord
1496 (XCAR (tem), arg_encoding, 1));
1497 }
1498 }
1499
1500 UNGCPRO;
1501 }
1502
1503 /* Now that everything is encoded we can collect the strings into
1504 NEW_ARGV. */
1505 new_argv = (unsigned char **) alloca ((nargs - 1) * sizeof (char *));
1506 new_argv[nargs - 2] = 0;
1507
1508 for (i = nargs - 2; i-- != 0; )
1509 {
1510 new_argv[i] = SDATA (XCAR (tem));
1511 tem = XCDR (tem);
1512 }
1513
1514 create_process (proc, (char **) new_argv, current_dir);
1515 }
1516 else
1517 create_pty (proc);
1518
1519 return unbind_to (count, proc);
1520 }
1521
1522 /* This function is the unwind_protect form for Fstart_process. If
1523 PROC doesn't have its pid set, then we know someone has signaled
1524 an error and the process wasn't started successfully, so we should
1525 remove it from the process list. */
1526 static Lisp_Object
1527 start_process_unwind (Lisp_Object proc)
1528 {
1529 if (!PROCESSP (proc))
1530 abort ();
1531
1532 /* Was PROC started successfully?
1533 -2 is used for a pty with no process, eg for gdb. */
1534 if (XPROCESS (proc)->pid <= 0 && XPROCESS (proc)->pid != -2)
1535 remove_process (proc);
1536
1537 return Qnil;
1538 }
1539
1540 static void
1541 create_process_1 (struct atimer *timer)
1542 {
1543 /* Nothing to do. */
1544 }
1545
1546
1547 static void
1548 create_process (Lisp_Object process, char **new_argv, Lisp_Object current_dir)
1549 {
1550 int inchannel, outchannel;
1551 pid_t pid;
1552 int sv[2];
1553 #if !defined (WINDOWSNT) && defined (FD_CLOEXEC)
1554 int wait_child_setup[2];
1555 #endif
1556 sigset_t procmask;
1557 sigset_t blocked;
1558 struct sigaction sigint_action;
1559 struct sigaction sigquit_action;
1560 struct sigaction sigpipe_action;
1561 #ifdef AIX
1562 struct sigaction sighup_action;
1563 #endif
1564 /* Use volatile to protect variables from being clobbered by longjmp. */
1565 volatile int forkin, forkout;
1566 volatile int pty_flag = 0;
1567 #ifndef USE_CRT_DLL
1568 extern char **environ;
1569 #endif
1570
1571 inchannel = outchannel = -1;
1572
1573 #ifdef HAVE_PTYS
1574 if (!NILP (Vprocess_connection_type))
1575 outchannel = inchannel = allocate_pty ();
1576
1577 if (inchannel >= 0)
1578 {
1579 #if ! defined (USG) || defined (USG_SUBTTY_WORKS)
1580 /* On most USG systems it does not work to open the pty's tty here,
1581 then close it and reopen it in the child. */
1582 #ifdef O_NOCTTY
1583 /* Don't let this terminal become our controlling terminal
1584 (in case we don't have one). */
1585 forkout = forkin = emacs_open (pty_name, O_RDWR | O_NOCTTY, 0);
1586 #else
1587 forkout = forkin = emacs_open (pty_name, O_RDWR, 0);
1588 #endif
1589 if (forkin < 0)
1590 report_file_error ("Opening pty", Qnil);
1591 #else
1592 forkin = forkout = -1;
1593 #endif /* not USG, or USG_SUBTTY_WORKS */
1594 pty_flag = 1;
1595 }
1596 else
1597 #endif /* HAVE_PTYS */
1598 {
1599 int tem;
1600 tem = pipe (sv);
1601 if (tem < 0)
1602 report_file_error ("Creating pipe", Qnil);
1603 inchannel = sv[0];
1604 forkout = sv[1];
1605 tem = pipe (sv);
1606 if (tem < 0)
1607 {
1608 emacs_close (inchannel);
1609 emacs_close (forkout);
1610 report_file_error ("Creating pipe", Qnil);
1611 }
1612 outchannel = sv[1];
1613 forkin = sv[0];
1614 }
1615
1616 #if !defined (WINDOWSNT) && defined (FD_CLOEXEC)
1617 {
1618 int tem;
1619
1620 tem = pipe (wait_child_setup);
1621 if (tem < 0)
1622 report_file_error ("Creating pipe", Qnil);
1623 tem = fcntl (wait_child_setup[1], F_GETFD, 0);
1624 if (tem >= 0)
1625 tem = fcntl (wait_child_setup[1], F_SETFD, tem | FD_CLOEXEC);
1626 if (tem < 0)
1627 {
1628 emacs_close (wait_child_setup[0]);
1629 emacs_close (wait_child_setup[1]);
1630 report_file_error ("Setting file descriptor flags", Qnil);
1631 }
1632 }
1633 #endif
1634
1635 #ifdef O_NONBLOCK
1636 fcntl (inchannel, F_SETFL, O_NONBLOCK);
1637 fcntl (outchannel, F_SETFL, O_NONBLOCK);
1638 #else
1639 #ifdef O_NDELAY
1640 fcntl (inchannel, F_SETFL, O_NDELAY);
1641 fcntl (outchannel, F_SETFL, O_NDELAY);
1642 #endif
1643 #endif
1644
1645 /* Record this as an active process, with its channels.
1646 As a result, child_setup will close Emacs's side of the pipes. */
1647 chan_process[inchannel] = process;
1648 XPROCESS (process)->infd = inchannel;
1649 XPROCESS (process)->outfd = outchannel;
1650
1651 /* Previously we recorded the tty descriptor used in the subprocess.
1652 It was only used for getting the foreground tty process, so now
1653 we just reopen the device (see emacs_get_tty_pgrp) as this is
1654 more portable (see USG_SUBTTY_WORKS above). */
1655
1656 XPROCESS (process)->pty_flag = pty_flag;
1657 XPROCESS (process)->status = Qrun;
1658
1659 /* Delay interrupts until we have a chance to store
1660 the new fork's pid in its process structure */
1661 sigemptyset (&blocked);
1662 #ifdef SIGCHLD
1663 sigaddset (&blocked, SIGCHLD);
1664 #endif
1665 #ifdef HAVE_WORKING_VFORK
1666 /* On many hosts (e.g. Solaris 2.4), if a vforked child calls `signal',
1667 this sets the parent's signal handlers as well as the child's.
1668 So delay all interrupts whose handlers the child might munge,
1669 and record the current handlers so they can be restored later. */
1670 sigaddset (&blocked, SIGINT ); sigaction (SIGINT , 0, &sigint_action );
1671 sigaddset (&blocked, SIGQUIT); sigaction (SIGQUIT, 0, &sigquit_action);
1672 sigaddset (&blocked, SIGPIPE); sigaction (SIGPIPE, 0, &sigpipe_action);
1673 #ifdef AIX
1674 sigaddset (&blocked, SIGHUP ); sigaction (SIGHUP , 0, &sighup_action );
1675 #endif
1676 #endif /* HAVE_WORKING_VFORK */
1677 pthread_sigmask (SIG_BLOCK, &blocked, &procmask);
1678
1679 FD_SET (inchannel, &input_wait_mask);
1680 FD_SET (inchannel, &non_keyboard_wait_mask);
1681 if (inchannel > max_process_desc)
1682 max_process_desc = inchannel;
1683
1684 /* Until we store the proper pid, enable sigchld_handler
1685 to recognize an unknown pid as standing for this process.
1686 It is very important not to let this `marker' value stay
1687 in the table after this function has returned; if it does
1688 it might cause call-process to hang and subsequent asynchronous
1689 processes to get their return values scrambled. */
1690 XPROCESS (process)->pid = -1;
1691
1692 /* This must be called after the above line because it may signal an
1693 error. */
1694 setup_process_coding_systems (process);
1695
1696 BLOCK_INPUT;
1697
1698 {
1699 /* child_setup must clobber environ on systems with true vfork.
1700 Protect it from permanent change. */
1701 char **save_environ = environ;
1702 volatile Lisp_Object encoded_current_dir = ENCODE_FILE (current_dir);
1703
1704 #ifndef WINDOWSNT
1705 pid = vfork ();
1706 if (pid == 0)
1707 #endif /* not WINDOWSNT */
1708 {
1709 int xforkin = forkin;
1710 int xforkout = forkout;
1711
1712 #if 0 /* This was probably a mistake--it duplicates code later on,
1713 but fails to handle all the cases. */
1714 /* Make sure SIGCHLD is not blocked in the child. */
1715 sigsetmask (SIGEMPTYMASK);
1716 #endif
1717
1718 /* Make the pty be the controlling terminal of the process. */
1719 #ifdef HAVE_PTYS
1720 /* First, disconnect its current controlling terminal. */
1721 #ifdef HAVE_SETSID
1722 /* We tried doing setsid only if pty_flag, but it caused
1723 process_set_signal to fail on SGI when using a pipe. */
1724 setsid ();
1725 /* Make the pty's terminal the controlling terminal. */
1726 if (pty_flag && xforkin >= 0)
1727 {
1728 #ifdef TIOCSCTTY
1729 /* We ignore the return value
1730 because faith@cs.unc.edu says that is necessary on Linux. */
1731 ioctl (xforkin, TIOCSCTTY, 0);
1732 #endif
1733 }
1734 #else /* not HAVE_SETSID */
1735 #ifdef USG
1736 /* It's very important to call setpgrp here and no time
1737 afterwards. Otherwise, we lose our controlling tty which
1738 is set when we open the pty. */
1739 setpgrp ();
1740 #endif /* USG */
1741 #endif /* not HAVE_SETSID */
1742 #if defined (LDISC1)
1743 if (pty_flag && xforkin >= 0)
1744 {
1745 struct termios t;
1746 tcgetattr (xforkin, &t);
1747 t.c_lflag = LDISC1;
1748 if (tcsetattr (xforkin, TCSANOW, &t) < 0)
1749 emacs_write (1, "create_process/tcsetattr LDISC1 failed\n", 39);
1750 }
1751 #else
1752 #if defined (NTTYDISC) && defined (TIOCSETD)
1753 if (pty_flag && xforkin >= 0)
1754 {
1755 /* Use new line discipline. */
1756 int ldisc = NTTYDISC;
1757 ioctl (xforkin, TIOCSETD, &ldisc);
1758 }
1759 #endif
1760 #endif
1761 #ifdef TIOCNOTTY
1762 /* In 4.3BSD, the TIOCSPGRP bug has been fixed, and now you
1763 can do TIOCSPGRP only to the process's controlling tty. */
1764 if (pty_flag)
1765 {
1766 /* I wonder: would just ioctl (0, TIOCNOTTY, 0) work here?
1767 I can't test it since I don't have 4.3. */
1768 int j = emacs_open ("/dev/tty", O_RDWR, 0);
1769 if (j >= 0)
1770 {
1771 ioctl (j, TIOCNOTTY, 0);
1772 emacs_close (j);
1773 }
1774 #ifndef USG
1775 /* In order to get a controlling terminal on some versions
1776 of BSD, it is necessary to put the process in pgrp 0
1777 before it opens the terminal. */
1778 #ifdef HAVE_SETPGID
1779 setpgid (0, 0);
1780 #else
1781 setpgrp (0, 0);
1782 #endif
1783 #endif
1784 }
1785 #endif /* TIOCNOTTY */
1786
1787 #if !defined (DONT_REOPEN_PTY)
1788 /*** There is a suggestion that this ought to be a
1789 conditional on TIOCSPGRP,
1790 or !(defined (HAVE_SETSID) && defined (TIOCSCTTY)).
1791 Trying the latter gave the wrong results on Debian GNU/Linux 1.1;
1792 that system does seem to need this code, even though
1793 both HAVE_SETSID and TIOCSCTTY are defined. */
1794 /* Now close the pty (if we had it open) and reopen it.
1795 This makes the pty the controlling terminal of the subprocess. */
1796 if (pty_flag)
1797 {
1798
1799 /* I wonder if emacs_close (emacs_open (pty_name, ...))
1800 would work? */
1801 if (xforkin >= 0)
1802 emacs_close (xforkin);
1803 xforkout = xforkin = emacs_open (pty_name, O_RDWR, 0);
1804
1805 if (xforkin < 0)
1806 {
1807 emacs_write (1, "Couldn't open the pty terminal ", 31);
1808 emacs_write (1, pty_name, strlen (pty_name));
1809 emacs_write (1, "\n", 1);
1810 _exit (1);
1811 }
1812
1813 }
1814 #endif /* not DONT_REOPEN_PTY */
1815
1816 #ifdef SETUP_SLAVE_PTY
1817 if (pty_flag)
1818 {
1819 SETUP_SLAVE_PTY;
1820 }
1821 #endif /* SETUP_SLAVE_PTY */
1822 #ifdef AIX
1823 /* On AIX, we've disabled SIGHUP above once we start a child on a pty.
1824 Now reenable it in the child, so it will die when we want it to. */
1825 if (pty_flag)
1826 signal (SIGHUP, SIG_DFL);
1827 #endif
1828 #endif /* HAVE_PTYS */
1829
1830 signal (SIGINT, SIG_DFL);
1831 signal (SIGQUIT, SIG_DFL);
1832 /* GConf causes us to ignore SIGPIPE, make sure it is restored
1833 in the child. */
1834 signal (SIGPIPE, SIG_DFL);
1835
1836 /* Stop blocking signals in the child. */
1837 pthread_sigmask (SIG_SETMASK, &procmask, 0);
1838
1839 if (pty_flag)
1840 child_setup_tty (xforkout);
1841 #ifdef WINDOWSNT
1842 pid = child_setup (xforkin, xforkout, xforkout,
1843 new_argv, 1, encoded_current_dir);
1844 #else /* not WINDOWSNT */
1845 #ifdef FD_CLOEXEC
1846 emacs_close (wait_child_setup[0]);
1847 #endif
1848 child_setup (xforkin, xforkout, xforkout,
1849 new_argv, 1, encoded_current_dir);
1850 #endif /* not WINDOWSNT */
1851 }
1852 environ = save_environ;
1853 }
1854
1855 UNBLOCK_INPUT;
1856
1857 /* This runs in the Emacs process. */
1858 if (pid < 0)
1859 {
1860 if (forkin >= 0)
1861 emacs_close (forkin);
1862 if (forkin != forkout && forkout >= 0)
1863 emacs_close (forkout);
1864 }
1865 else
1866 {
1867 /* vfork succeeded. */
1868 XPROCESS (process)->pid = pid;
1869
1870 #ifdef WINDOWSNT
1871 register_child (pid, inchannel);
1872 #endif /* WINDOWSNT */
1873
1874 /* If the subfork execv fails, and it exits,
1875 this close hangs. I don't know why.
1876 So have an interrupt jar it loose. */
1877 {
1878 struct atimer *timer;
1879 EMACS_TIME offset;
1880
1881 stop_polling ();
1882 EMACS_SET_SECS_USECS (offset, 1, 0);
1883 timer = start_atimer (ATIMER_RELATIVE, offset, create_process_1, 0);
1884
1885 if (forkin >= 0)
1886 emacs_close (forkin);
1887
1888 cancel_atimer (timer);
1889 start_polling ();
1890 }
1891
1892 if (forkin != forkout && forkout >= 0)
1893 emacs_close (forkout);
1894
1895 #ifdef HAVE_PTYS
1896 if (pty_flag)
1897 XPROCESS (process)->tty_name = build_string (pty_name);
1898 else
1899 #endif
1900 XPROCESS (process)->tty_name = Qnil;
1901
1902 #if !defined (WINDOWSNT) && defined (FD_CLOEXEC)
1903 /* Wait for child_setup to complete in case that vfork is
1904 actually defined as fork. The descriptor wait_child_setup[1]
1905 of a pipe is closed at the child side either by close-on-exec
1906 on successful execvp or the _exit call in child_setup. */
1907 {
1908 char dummy;
1909
1910 emacs_close (wait_child_setup[1]);
1911 emacs_read (wait_child_setup[0], &dummy, 1);
1912 emacs_close (wait_child_setup[0]);
1913 }
1914 #endif
1915 }
1916
1917 /* Restore the signal state whether vfork succeeded or not.
1918 (We will signal an error, below, if it failed.) */
1919 #ifdef HAVE_WORKING_VFORK
1920 /* Restore the parent's signal handlers. */
1921 sigaction (SIGINT, &sigint_action, 0);
1922 sigaction (SIGQUIT, &sigquit_action, 0);
1923 sigaction (SIGPIPE, &sigpipe_action, 0);
1924 #ifdef AIX
1925 sigaction (SIGHUP, &sighup_action, 0);
1926 #endif
1927 #endif /* HAVE_WORKING_VFORK */
1928 /* Stop blocking signals in the parent. */
1929 pthread_sigmask (SIG_SETMASK, &procmask, 0);
1930
1931 /* Now generate the error if vfork failed. */
1932 if (pid < 0)
1933 report_file_error ("Doing vfork", Qnil);
1934 }
1935
1936 void
1937 create_pty (Lisp_Object process)
1938 {
1939 int inchannel, outchannel;
1940 int pty_flag = 0;
1941
1942 inchannel = outchannel = -1;
1943
1944 #ifdef HAVE_PTYS
1945 if (!NILP (Vprocess_connection_type))
1946 outchannel = inchannel = allocate_pty ();
1947
1948 if (inchannel >= 0)
1949 {
1950 #if ! defined (USG) || defined (USG_SUBTTY_WORKS)
1951 /* On most USG systems it does not work to open the pty's tty here,
1952 then close it and reopen it in the child. */
1953 #ifdef O_NOCTTY
1954 /* Don't let this terminal become our controlling terminal
1955 (in case we don't have one). */
1956 int forkout = emacs_open (pty_name, O_RDWR | O_NOCTTY, 0);
1957 #else
1958 int forkout = emacs_open (pty_name, O_RDWR, 0);
1959 #endif
1960 if (forkout < 0)
1961 report_file_error ("Opening pty", Qnil);
1962 #if defined (DONT_REOPEN_PTY)
1963 /* In the case that vfork is defined as fork, the parent process
1964 (Emacs) may send some data before the child process completes
1965 tty options setup. So we setup tty before forking. */
1966 child_setup_tty (forkout);
1967 #endif /* DONT_REOPEN_PTY */
1968 #endif /* not USG, or USG_SUBTTY_WORKS */
1969 pty_flag = 1;
1970 }
1971 #endif /* HAVE_PTYS */
1972
1973 #ifdef O_NONBLOCK
1974 fcntl (inchannel, F_SETFL, O_NONBLOCK);
1975 fcntl (outchannel, F_SETFL, O_NONBLOCK);
1976 #else
1977 #ifdef O_NDELAY
1978 fcntl (inchannel, F_SETFL, O_NDELAY);
1979 fcntl (outchannel, F_SETFL, O_NDELAY);
1980 #endif
1981 #endif
1982
1983 /* Record this as an active process, with its channels.
1984 As a result, child_setup will close Emacs's side of the pipes. */
1985 chan_process[inchannel] = process;
1986 XPROCESS (process)->infd = inchannel;
1987 XPROCESS (process)->outfd = outchannel;
1988
1989 /* Previously we recorded the tty descriptor used in the subprocess.
1990 It was only used for getting the foreground tty process, so now
1991 we just reopen the device (see emacs_get_tty_pgrp) as this is
1992 more portable (see USG_SUBTTY_WORKS above). */
1993
1994 XPROCESS (process)->pty_flag = pty_flag;
1995 XPROCESS (process)->status = Qrun;
1996 setup_process_coding_systems (process);
1997
1998 FD_SET (inchannel, &input_wait_mask);
1999 FD_SET (inchannel, &non_keyboard_wait_mask);
2000 if (inchannel > max_process_desc)
2001 max_process_desc = inchannel;
2002
2003 XPROCESS (process)->pid = -2;
2004 #ifdef HAVE_PTYS
2005 if (pty_flag)
2006 XPROCESS (process)->tty_name = build_string (pty_name);
2007 else
2008 #endif
2009 XPROCESS (process)->tty_name = Qnil;
2010 }
2011
2012 \f
2013 /* Convert an internal struct sockaddr to a lisp object (vector or string).
2014 The address family of sa is not included in the result. */
2015
2016 static Lisp_Object
2017 conv_sockaddr_to_lisp (struct sockaddr *sa, int len)
2018 {
2019 Lisp_Object address;
2020 int i;
2021 unsigned char *cp;
2022 register struct Lisp_Vector *p;
2023
2024 /* Workaround for a bug in getsockname on BSD: Names bound to
2025 sockets in the UNIX domain are inaccessible; getsockname returns
2026 a zero length name. */
2027 if (len < offsetof (struct sockaddr, sa_family) + sizeof (sa->sa_family))
2028 return empty_unibyte_string;
2029
2030 switch (sa->sa_family)
2031 {
2032 case AF_INET:
2033 {
2034 struct sockaddr_in *sin = (struct sockaddr_in *) sa;
2035 len = sizeof (sin->sin_addr) + 1;
2036 address = Fmake_vector (make_number (len), Qnil);
2037 p = XVECTOR (address);
2038 p->contents[--len] = make_number (ntohs (sin->sin_port));
2039 cp = (unsigned char *) &sin->sin_addr;
2040 break;
2041 }
2042 #ifdef AF_INET6
2043 case AF_INET6:
2044 {
2045 struct sockaddr_in6 *sin6 = (struct sockaddr_in6 *) sa;
2046 uint16_t *ip6 = (uint16_t *) &sin6->sin6_addr;
2047 len = sizeof (sin6->sin6_addr)/2 + 1;
2048 address = Fmake_vector (make_number (len), Qnil);
2049 p = XVECTOR (address);
2050 p->contents[--len] = make_number (ntohs (sin6->sin6_port));
2051 for (i = 0; i < len; i++)
2052 p->contents[i] = make_number (ntohs (ip6[i]));
2053 return address;
2054 }
2055 #endif
2056 #ifdef HAVE_LOCAL_SOCKETS
2057 case AF_LOCAL:
2058 {
2059 struct sockaddr_un *sockun = (struct sockaddr_un *) sa;
2060 for (i = 0; i < sizeof (sockun->sun_path); i++)
2061 if (sockun->sun_path[i] == 0)
2062 break;
2063 return make_unibyte_string (sockun->sun_path, i);
2064 }
2065 #endif
2066 default:
2067 len -= offsetof (struct sockaddr, sa_family) + sizeof (sa->sa_family);
2068 address = Fcons (make_number (sa->sa_family),
2069 Fmake_vector (make_number (len), Qnil));
2070 p = XVECTOR (XCDR (address));
2071 cp = (unsigned char *) &sa->sa_family + sizeof (sa->sa_family);
2072 break;
2073 }
2074
2075 i = 0;
2076 while (i < len)
2077 p->contents[i++] = make_number (*cp++);
2078
2079 return address;
2080 }
2081
2082
2083 /* Get family and required size for sockaddr structure to hold ADDRESS. */
2084
2085 static int
2086 get_lisp_to_sockaddr_size (Lisp_Object address, int *familyp)
2087 {
2088 register struct Lisp_Vector *p;
2089
2090 if (VECTORP (address))
2091 {
2092 p = XVECTOR (address);
2093 if (p->header.size == 5)
2094 {
2095 *familyp = AF_INET;
2096 return sizeof (struct sockaddr_in);
2097 }
2098 #ifdef AF_INET6
2099 else if (p->header.size == 9)
2100 {
2101 *familyp = AF_INET6;
2102 return sizeof (struct sockaddr_in6);
2103 }
2104 #endif
2105 }
2106 #ifdef HAVE_LOCAL_SOCKETS
2107 else if (STRINGP (address))
2108 {
2109 *familyp = AF_LOCAL;
2110 return sizeof (struct sockaddr_un);
2111 }
2112 #endif
2113 else if (CONSP (address) && TYPE_RANGED_INTEGERP (int, XCAR (address))
2114 && VECTORP (XCDR (address)))
2115 {
2116 struct sockaddr *sa;
2117 *familyp = XINT (XCAR (address));
2118 p = XVECTOR (XCDR (address));
2119 return p->header.size + sizeof (sa->sa_family);
2120 }
2121 return 0;
2122 }
2123
2124 /* Convert an address object (vector or string) to an internal sockaddr.
2125
2126 The address format has been basically validated by
2127 get_lisp_to_sockaddr_size, but this does not mean FAMILY is valid;
2128 it could have come from user data. So if FAMILY is not valid,
2129 we return after zeroing *SA. */
2130
2131 static void
2132 conv_lisp_to_sockaddr (int family, Lisp_Object address, struct sockaddr *sa, int len)
2133 {
2134 register struct Lisp_Vector *p;
2135 register unsigned char *cp = NULL;
2136 register int i;
2137 EMACS_INT hostport;
2138
2139 memset (sa, 0, len);
2140
2141 if (VECTORP (address))
2142 {
2143 p = XVECTOR (address);
2144 if (family == AF_INET)
2145 {
2146 struct sockaddr_in *sin = (struct sockaddr_in *) sa;
2147 len = sizeof (sin->sin_addr) + 1;
2148 hostport = XINT (p->contents[--len]);
2149 sin->sin_port = htons (hostport);
2150 cp = (unsigned char *)&sin->sin_addr;
2151 sa->sa_family = family;
2152 }
2153 #ifdef AF_INET6
2154 else if (family == AF_INET6)
2155 {
2156 struct sockaddr_in6 *sin6 = (struct sockaddr_in6 *) sa;
2157 uint16_t *ip6 = (uint16_t *)&sin6->sin6_addr;
2158 len = sizeof (sin6->sin6_addr) + 1;
2159 hostport = XINT (p->contents[--len]);
2160 sin6->sin6_port = htons (hostport);
2161 for (i = 0; i < len; i++)
2162 if (INTEGERP (p->contents[i]))
2163 {
2164 int j = XFASTINT (p->contents[i]) & 0xffff;
2165 ip6[i] = ntohs (j);
2166 }
2167 sa->sa_family = family;
2168 return;
2169 }
2170 #endif
2171 else
2172 return;
2173 }
2174 else if (STRINGP (address))
2175 {
2176 #ifdef HAVE_LOCAL_SOCKETS
2177 if (family == AF_LOCAL)
2178 {
2179 struct sockaddr_un *sockun = (struct sockaddr_un *) sa;
2180 cp = SDATA (address);
2181 for (i = 0; i < sizeof (sockun->sun_path) && *cp; i++)
2182 sockun->sun_path[i] = *cp++;
2183 sa->sa_family = family;
2184 }
2185 #endif
2186 return;
2187 }
2188 else
2189 {
2190 p = XVECTOR (XCDR (address));
2191 cp = (unsigned char *)sa + sizeof (sa->sa_family);
2192 }
2193
2194 for (i = 0; i < len; i++)
2195 if (INTEGERP (p->contents[i]))
2196 *cp++ = XFASTINT (p->contents[i]) & 0xff;
2197 }
2198
2199 #ifdef DATAGRAM_SOCKETS
2200 DEFUN ("process-datagram-address", Fprocess_datagram_address, Sprocess_datagram_address,
2201 1, 1, 0,
2202 doc: /* Get the current datagram address associated with PROCESS. */)
2203 (Lisp_Object process)
2204 {
2205 int channel;
2206
2207 CHECK_PROCESS (process);
2208
2209 if (!DATAGRAM_CONN_P (process))
2210 return Qnil;
2211
2212 channel = XPROCESS (process)->infd;
2213 return conv_sockaddr_to_lisp (datagram_address[channel].sa,
2214 datagram_address[channel].len);
2215 }
2216
2217 DEFUN ("set-process-datagram-address", Fset_process_datagram_address, Sset_process_datagram_address,
2218 2, 2, 0,
2219 doc: /* Set the datagram address for PROCESS to ADDRESS.
2220 Returns nil upon error setting address, ADDRESS otherwise. */)
2221 (Lisp_Object process, Lisp_Object address)
2222 {
2223 int channel;
2224 int family, len;
2225
2226 CHECK_PROCESS (process);
2227
2228 if (!DATAGRAM_CONN_P (process))
2229 return Qnil;
2230
2231 channel = XPROCESS (process)->infd;
2232
2233 len = get_lisp_to_sockaddr_size (address, &family);
2234 if (datagram_address[channel].len != len)
2235 return Qnil;
2236 conv_lisp_to_sockaddr (family, address, datagram_address[channel].sa, len);
2237 return address;
2238 }
2239 #endif
2240 \f
2241
2242 static const struct socket_options {
2243 /* The name of this option. Should be lowercase version of option
2244 name without SO_ prefix. */
2245 const char *name;
2246 /* Option level SOL_... */
2247 int optlevel;
2248 /* Option number SO_... */
2249 int optnum;
2250 enum { SOPT_UNKNOWN, SOPT_BOOL, SOPT_INT, SOPT_IFNAME, SOPT_LINGER } opttype;
2251 enum { OPIX_NONE=0, OPIX_MISC=1, OPIX_REUSEADDR=2 } optbit;
2252 } socket_options[] =
2253 {
2254 #ifdef SO_BINDTODEVICE
2255 { ":bindtodevice", SOL_SOCKET, SO_BINDTODEVICE, SOPT_IFNAME, OPIX_MISC },
2256 #endif
2257 #ifdef SO_BROADCAST
2258 { ":broadcast", SOL_SOCKET, SO_BROADCAST, SOPT_BOOL, OPIX_MISC },
2259 #endif
2260 #ifdef SO_DONTROUTE
2261 { ":dontroute", SOL_SOCKET, SO_DONTROUTE, SOPT_BOOL, OPIX_MISC },
2262 #endif
2263 #ifdef SO_KEEPALIVE
2264 { ":keepalive", SOL_SOCKET, SO_KEEPALIVE, SOPT_BOOL, OPIX_MISC },
2265 #endif
2266 #ifdef SO_LINGER
2267 { ":linger", SOL_SOCKET, SO_LINGER, SOPT_LINGER, OPIX_MISC },
2268 #endif
2269 #ifdef SO_OOBINLINE
2270 { ":oobinline", SOL_SOCKET, SO_OOBINLINE, SOPT_BOOL, OPIX_MISC },
2271 #endif
2272 #ifdef SO_PRIORITY
2273 { ":priority", SOL_SOCKET, SO_PRIORITY, SOPT_INT, OPIX_MISC },
2274 #endif
2275 #ifdef SO_REUSEADDR
2276 { ":reuseaddr", SOL_SOCKET, SO_REUSEADDR, SOPT_BOOL, OPIX_REUSEADDR },
2277 #endif
2278 { 0, 0, 0, SOPT_UNKNOWN, OPIX_NONE }
2279 };
2280
2281 /* Set option OPT to value VAL on socket S.
2282
2283 Returns (1<<socket_options[OPT].optbit) if option is known, 0 otherwise.
2284 Signals an error if setting a known option fails.
2285 */
2286
2287 static int
2288 set_socket_option (int s, Lisp_Object opt, Lisp_Object val)
2289 {
2290 char *name;
2291 const struct socket_options *sopt;
2292 int ret = 0;
2293
2294 CHECK_SYMBOL (opt);
2295
2296 name = SSDATA (SYMBOL_NAME (opt));
2297 for (sopt = socket_options; sopt->name; sopt++)
2298 if (strcmp (name, sopt->name) == 0)
2299 break;
2300
2301 switch (sopt->opttype)
2302 {
2303 case SOPT_BOOL:
2304 {
2305 int optval;
2306 optval = NILP (val) ? 0 : 1;
2307 ret = setsockopt (s, sopt->optlevel, sopt->optnum,
2308 &optval, sizeof (optval));
2309 break;
2310 }
2311
2312 case SOPT_INT:
2313 {
2314 int optval;
2315 if (TYPE_RANGED_INTEGERP (int, val))
2316 optval = XINT (val);
2317 else
2318 error ("Bad option value for %s", name);
2319 ret = setsockopt (s, sopt->optlevel, sopt->optnum,
2320 &optval, sizeof (optval));
2321 break;
2322 }
2323
2324 #ifdef SO_BINDTODEVICE
2325 case SOPT_IFNAME:
2326 {
2327 char devname[IFNAMSIZ+1];
2328
2329 /* This is broken, at least in the Linux 2.4 kernel.
2330 To unbind, the arg must be a zero integer, not the empty string.
2331 This should work on all systems. KFS. 2003-09-23. */
2332 memset (devname, 0, sizeof devname);
2333 if (STRINGP (val))
2334 {
2335 char *arg = SSDATA (val);
2336 int len = min (strlen (arg), IFNAMSIZ);
2337 memcpy (devname, arg, len);
2338 }
2339 else if (!NILP (val))
2340 error ("Bad option value for %s", name);
2341 ret = setsockopt (s, sopt->optlevel, sopt->optnum,
2342 devname, IFNAMSIZ);
2343 break;
2344 }
2345 #endif
2346
2347 #ifdef SO_LINGER
2348 case SOPT_LINGER:
2349 {
2350 struct linger linger;
2351
2352 linger.l_onoff = 1;
2353 linger.l_linger = 0;
2354 if (TYPE_RANGED_INTEGERP (int, val))
2355 linger.l_linger = XINT (val);
2356 else
2357 linger.l_onoff = NILP (val) ? 0 : 1;
2358 ret = setsockopt (s, sopt->optlevel, sopt->optnum,
2359 &linger, sizeof (linger));
2360 break;
2361 }
2362 #endif
2363
2364 default:
2365 return 0;
2366 }
2367
2368 if (ret < 0)
2369 report_file_error ("Cannot set network option",
2370 Fcons (opt, Fcons (val, Qnil)));
2371 return (1 << sopt->optbit);
2372 }
2373
2374
2375 DEFUN ("set-network-process-option",
2376 Fset_network_process_option, Sset_network_process_option,
2377 3, 4, 0,
2378 doc: /* For network process PROCESS set option OPTION to value VALUE.
2379 See `make-network-process' for a list of options and values.
2380 If optional fourth arg NO-ERROR is non-nil, don't signal an error if
2381 OPTION is not a supported option, return nil instead; otherwise return t. */)
2382 (Lisp_Object process, Lisp_Object option, Lisp_Object value, Lisp_Object no_error)
2383 {
2384 int s;
2385 struct Lisp_Process *p;
2386
2387 CHECK_PROCESS (process);
2388 p = XPROCESS (process);
2389 if (!NETCONN1_P (p))
2390 error ("Process is not a network process");
2391
2392 s = p->infd;
2393 if (s < 0)
2394 error ("Process is not running");
2395
2396 if (set_socket_option (s, option, value))
2397 {
2398 p->childp = Fplist_put (p->childp, option, value);
2399 return Qt;
2400 }
2401
2402 if (NILP (no_error))
2403 error ("Unknown or unsupported option");
2404
2405 return Qnil;
2406 }
2407
2408 \f
2409 DEFUN ("serial-process-configure",
2410 Fserial_process_configure,
2411 Sserial_process_configure,
2412 0, MANY, 0,
2413 doc: /* Configure speed, bytesize, etc. of a serial process.
2414
2415 Arguments are specified as keyword/argument pairs. Attributes that
2416 are not given are re-initialized from the process's current
2417 configuration (available via the function `process-contact') or set to
2418 reasonable default values. The following arguments are defined:
2419
2420 :process PROCESS
2421 :name NAME
2422 :buffer BUFFER
2423 :port PORT
2424 -- Any of these arguments can be given to identify the process that is
2425 to be configured. If none of these arguments is given, the current
2426 buffer's process is used.
2427
2428 :speed SPEED -- SPEED is the speed of the serial port in bits per
2429 second, also called baud rate. Any value can be given for SPEED, but
2430 most serial ports work only at a few defined values between 1200 and
2431 115200, with 9600 being the most common value. If SPEED is nil, the
2432 serial port is not configured any further, i.e., all other arguments
2433 are ignored. This may be useful for special serial ports such as
2434 Bluetooth-to-serial converters which can only be configured through AT
2435 commands. A value of nil for SPEED can be used only when passed
2436 through `make-serial-process' or `serial-term'.
2437
2438 :bytesize BYTESIZE -- BYTESIZE is the number of bits per byte, which
2439 can be 7 or 8. If BYTESIZE is not given or nil, a value of 8 is used.
2440
2441 :parity PARITY -- PARITY can be nil (don't use parity), the symbol
2442 `odd' (use odd parity), or the symbol `even' (use even parity). If
2443 PARITY is not given, no parity is used.
2444
2445 :stopbits STOPBITS -- STOPBITS is the number of stopbits used to
2446 terminate a byte transmission. STOPBITS can be 1 or 2. If STOPBITS
2447 is not given or nil, 1 stopbit is used.
2448
2449 :flowcontrol FLOWCONTROL -- FLOWCONTROL determines the type of
2450 flowcontrol to be used, which is either nil (don't use flowcontrol),
2451 the symbol `hw' (use RTS/CTS hardware flowcontrol), or the symbol `sw'
2452 \(use XON/XOFF software flowcontrol). If FLOWCONTROL is not given, no
2453 flowcontrol is used.
2454
2455 `serial-process-configure' is called by `make-serial-process' for the
2456 initial configuration of the serial port.
2457
2458 Examples:
2459
2460 \(serial-process-configure :process "/dev/ttyS0" :speed 1200)
2461
2462 \(serial-process-configure
2463 :buffer "COM1" :stopbits 1 :parity 'odd :flowcontrol 'hw)
2464
2465 \(serial-process-configure :port "\\\\.\\COM13" :bytesize 7)
2466
2467 usage: (serial-process-configure &rest ARGS) */)
2468 (ptrdiff_t nargs, Lisp_Object *args)
2469 {
2470 struct Lisp_Process *p;
2471 Lisp_Object contact = Qnil;
2472 Lisp_Object proc = Qnil;
2473 struct gcpro gcpro1;
2474
2475 contact = Flist (nargs, args);
2476 GCPRO1 (contact);
2477
2478 proc = Fplist_get (contact, QCprocess);
2479 if (NILP (proc))
2480 proc = Fplist_get (contact, QCname);
2481 if (NILP (proc))
2482 proc = Fplist_get (contact, QCbuffer);
2483 if (NILP (proc))
2484 proc = Fplist_get (contact, QCport);
2485 proc = get_process (proc);
2486 p = XPROCESS (proc);
2487 if (!EQ (p->type, Qserial))
2488 error ("Not a serial process");
2489
2490 if (NILP (Fplist_get (p->childp, QCspeed)))
2491 {
2492 UNGCPRO;
2493 return Qnil;
2494 }
2495
2496 serial_configure (p, contact);
2497
2498 UNGCPRO;
2499 return Qnil;
2500 }
2501
2502 /* Used by make-serial-process to recover from errors. */
2503 static Lisp_Object
2504 make_serial_process_unwind (Lisp_Object proc)
2505 {
2506 if (!PROCESSP (proc))
2507 abort ();
2508 remove_process (proc);
2509 return Qnil;
2510 }
2511
2512 DEFUN ("make-serial-process", Fmake_serial_process, Smake_serial_process,
2513 0, MANY, 0,
2514 doc: /* Create and return a serial port process.
2515
2516 In Emacs, serial port connections are represented by process objects,
2517 so input and output work as for subprocesses, and `delete-process'
2518 closes a serial port connection. However, a serial process has no
2519 process id, it cannot be signaled, and the status codes are different
2520 from normal processes.
2521
2522 `make-serial-process' creates a process and a buffer, on which you
2523 probably want to use `process-send-string'. Try \\[serial-term] for
2524 an interactive terminal. See below for examples.
2525
2526 Arguments are specified as keyword/argument pairs. The following
2527 arguments are defined:
2528
2529 :port PORT -- (mandatory) PORT is the path or name of the serial port.
2530 For example, this could be "/dev/ttyS0" on Unix. On Windows, this
2531 could be "COM1", or "\\\\.\\COM10" for ports higher than COM9 (double
2532 the backslashes in strings).
2533
2534 :speed SPEED -- (mandatory) is handled by `serial-process-configure',
2535 which this function calls.
2536
2537 :name NAME -- NAME is the name of the process. If NAME is not given,
2538 the value of PORT is used.
2539
2540 :buffer BUFFER -- BUFFER is the buffer (or buffer-name) to associate
2541 with the process. Process output goes at the end of that buffer,
2542 unless you specify an output stream or filter function to handle the
2543 output. If BUFFER is not given, the value of NAME is used.
2544
2545 :coding CODING -- If CODING is a symbol, it specifies the coding
2546 system used for both reading and writing for this process. If CODING
2547 is a cons (DECODING . ENCODING), DECODING is used for reading, and
2548 ENCODING is used for writing.
2549
2550 :noquery BOOL -- When exiting Emacs, query the user if BOOL is nil and
2551 the process is running. If BOOL is not given, query before exiting.
2552
2553 :stop BOOL -- Start process in the `stopped' state if BOOL is non-nil.
2554 In the stopped state, a serial process does not accept incoming data,
2555 but you can send outgoing data. The stopped state is cleared by
2556 `continue-process' and set by `stop-process'.
2557
2558 :filter FILTER -- Install FILTER as the process filter.
2559
2560 :sentinel SENTINEL -- Install SENTINEL as the process sentinel.
2561
2562 :plist PLIST -- Install PLIST as the initial plist of the process.
2563
2564 :bytesize
2565 :parity
2566 :stopbits
2567 :flowcontrol
2568 -- This function calls `serial-process-configure' to handle these
2569 arguments.
2570
2571 The original argument list, possibly modified by later configuration,
2572 is available via the function `process-contact'.
2573
2574 Examples:
2575
2576 \(make-serial-process :port "/dev/ttyS0" :speed 9600)
2577
2578 \(make-serial-process :port "COM1" :speed 115200 :stopbits 2)
2579
2580 \(make-serial-process :port "\\\\.\\COM13" :speed 1200 :bytesize 7 :parity 'odd)
2581
2582 \(make-serial-process :port "/dev/tty.BlueConsole-SPP-1" :speed nil)
2583
2584 usage: (make-serial-process &rest ARGS) */)
2585 (ptrdiff_t nargs, Lisp_Object *args)
2586 {
2587 int fd = -1;
2588 Lisp_Object proc, contact, port;
2589 struct Lisp_Process *p;
2590 struct gcpro gcpro1;
2591 Lisp_Object name, buffer;
2592 Lisp_Object tem, val;
2593 ptrdiff_t specpdl_count = -1;
2594
2595 if (nargs == 0)
2596 return Qnil;
2597
2598 contact = Flist (nargs, args);
2599 GCPRO1 (contact);
2600
2601 port = Fplist_get (contact, QCport);
2602 if (NILP (port))
2603 error ("No port specified");
2604 CHECK_STRING (port);
2605
2606 if (NILP (Fplist_member (contact, QCspeed)))
2607 error (":speed not specified");
2608 if (!NILP (Fplist_get (contact, QCspeed)))
2609 CHECK_NUMBER (Fplist_get (contact, QCspeed));
2610
2611 name = Fplist_get (contact, QCname);
2612 if (NILP (name))
2613 name = port;
2614 CHECK_STRING (name);
2615 proc = make_process (name);
2616 specpdl_count = SPECPDL_INDEX ();
2617 record_unwind_protect (make_serial_process_unwind, proc);
2618 p = XPROCESS (proc);
2619
2620 fd = serial_open (SSDATA (port));
2621 p->infd = fd;
2622 p->outfd = fd;
2623 if (fd > max_process_desc)
2624 max_process_desc = fd;
2625 chan_process[fd] = proc;
2626
2627 buffer = Fplist_get (contact, QCbuffer);
2628 if (NILP (buffer))
2629 buffer = name;
2630 buffer = Fget_buffer_create (buffer);
2631 p->buffer = buffer;
2632
2633 p->childp = contact;
2634 p->plist = Fcopy_sequence (Fplist_get (contact, QCplist));
2635 p->type = Qserial;
2636 p->sentinel = Fplist_get (contact, QCsentinel);
2637 p->filter = Fplist_get (contact, QCfilter);
2638 p->log = Qnil;
2639 if (tem = Fplist_get (contact, QCnoquery), !NILP (tem))
2640 p->kill_without_query = 1;
2641 if (tem = Fplist_get (contact, QCstop), !NILP (tem))
2642 p->command = Qt;
2643 p->pty_flag = 0;
2644
2645 if (!EQ (p->command, Qt))
2646 {
2647 FD_SET (fd, &input_wait_mask);
2648 FD_SET (fd, &non_keyboard_wait_mask);
2649 }
2650
2651 if (BUFFERP (buffer))
2652 {
2653 set_marker_both (p->mark, buffer,
2654 BUF_ZV (XBUFFER (buffer)),
2655 BUF_ZV_BYTE (XBUFFER (buffer)));
2656 }
2657
2658 tem = Fplist_member (contact, QCcoding);
2659 if (!NILP (tem) && (!CONSP (tem) || !CONSP (XCDR (tem))))
2660 tem = Qnil;
2661
2662 val = Qnil;
2663 if (!NILP (tem))
2664 {
2665 val = XCAR (XCDR (tem));
2666 if (CONSP (val))
2667 val = XCAR (val);
2668 }
2669 else if (!NILP (Vcoding_system_for_read))
2670 val = Vcoding_system_for_read;
2671 else if ((!NILP (buffer) && NILP (BVAR (XBUFFER (buffer), enable_multibyte_characters)))
2672 || (NILP (buffer) && NILP (BVAR (&buffer_defaults, enable_multibyte_characters))))
2673 val = Qnil;
2674 p->decode_coding_system = val;
2675
2676 val = Qnil;
2677 if (!NILP (tem))
2678 {
2679 val = XCAR (XCDR (tem));
2680 if (CONSP (val))
2681 val = XCDR (val);
2682 }
2683 else if (!NILP (Vcoding_system_for_write))
2684 val = Vcoding_system_for_write;
2685 else if ((!NILP (buffer) && NILP (BVAR (XBUFFER (buffer), enable_multibyte_characters)))
2686 || (NILP (buffer) && NILP (BVAR (&buffer_defaults, enable_multibyte_characters))))
2687 val = Qnil;
2688 p->encode_coding_system = val;
2689
2690 setup_process_coding_systems (proc);
2691 p->decoding_buf = empty_unibyte_string;
2692 p->decoding_carryover = 0;
2693 p->encoding_buf = empty_unibyte_string;
2694 p->inherit_coding_system_flag
2695 = !(!NILP (tem) || NILP (buffer) || !inherit_process_coding_system);
2696
2697 Fserial_process_configure (nargs, args);
2698
2699 specpdl_ptr = specpdl + specpdl_count;
2700
2701 UNGCPRO;
2702 return proc;
2703 }
2704
2705 /* Create a network stream/datagram client/server process. Treated
2706 exactly like a normal process when reading and writing. Primary
2707 differences are in status display and process deletion. A network
2708 connection has no PID; you cannot signal it. All you can do is
2709 stop/continue it and deactivate/close it via delete-process */
2710
2711 DEFUN ("make-network-process", Fmake_network_process, Smake_network_process,
2712 0, MANY, 0,
2713 doc: /* Create and return a network server or client process.
2714
2715 In Emacs, network connections are represented by process objects, so
2716 input and output work as for subprocesses and `delete-process' closes
2717 a network connection. However, a network process has no process id,
2718 it cannot be signaled, and the status codes are different from normal
2719 processes.
2720
2721 Arguments are specified as keyword/argument pairs. The following
2722 arguments are defined:
2723
2724 :name NAME -- NAME is name for process. It is modified if necessary
2725 to make it unique.
2726
2727 :buffer BUFFER -- BUFFER is the buffer (or buffer-name) to associate
2728 with the process. Process output goes at end of that buffer, unless
2729 you specify an output stream or filter function to handle the output.
2730 BUFFER may be also nil, meaning that this process is not associated
2731 with any buffer.
2732
2733 :host HOST -- HOST is name of the host to connect to, or its IP
2734 address. The symbol `local' specifies the local host. If specified
2735 for a server process, it must be a valid name or address for the local
2736 host, and only clients connecting to that address will be accepted.
2737
2738 :service SERVICE -- SERVICE is name of the service desired, or an
2739 integer specifying a port number to connect to. If SERVICE is t,
2740 a random port number is selected for the server. (If Emacs was
2741 compiled with getaddrinfo, a port number can also be specified as a
2742 string, e.g. "80", as well as an integer. This is not portable.)
2743
2744 :type TYPE -- TYPE is the type of connection. The default (nil) is a
2745 stream type connection, `datagram' creates a datagram type connection,
2746 `seqpacket' creates a reliable datagram connection.
2747
2748 :family FAMILY -- FAMILY is the address (and protocol) family for the
2749 service specified by HOST and SERVICE. The default (nil) is to use
2750 whatever address family (IPv4 or IPv6) that is defined for the host
2751 and port number specified by HOST and SERVICE. Other address families
2752 supported are:
2753 local -- for a local (i.e. UNIX) address specified by SERVICE.
2754 ipv4 -- use IPv4 address family only.
2755 ipv6 -- use IPv6 address family only.
2756
2757 :local ADDRESS -- ADDRESS is the local address used for the connection.
2758 This parameter is ignored when opening a client process. When specified
2759 for a server process, the FAMILY, HOST and SERVICE args are ignored.
2760
2761 :remote ADDRESS -- ADDRESS is the remote partner's address for the
2762 connection. This parameter is ignored when opening a stream server
2763 process. For a datagram server process, it specifies the initial
2764 setting of the remote datagram address. When specified for a client
2765 process, the FAMILY, HOST, and SERVICE args are ignored.
2766
2767 The format of ADDRESS depends on the address family:
2768 - An IPv4 address is represented as an vector of integers [A B C D P]
2769 corresponding to numeric IP address A.B.C.D and port number P.
2770 - A local address is represented as a string with the address in the
2771 local address space.
2772 - An "unsupported family" address is represented by a cons (F . AV)
2773 where F is the family number and AV is a vector containing the socket
2774 address data with one element per address data byte. Do not rely on
2775 this format in portable code, as it may depend on implementation
2776 defined constants, data sizes, and data structure alignment.
2777
2778 :coding CODING -- If CODING is a symbol, it specifies the coding
2779 system used for both reading and writing for this process. If CODING
2780 is a cons (DECODING . ENCODING), DECODING is used for reading, and
2781 ENCODING is used for writing.
2782
2783 :nowait BOOL -- If BOOL is non-nil for a stream type client process,
2784 return without waiting for the connection to complete; instead, the
2785 sentinel function will be called with second arg matching "open" (if
2786 successful) or "failed" when the connect completes. Default is to use
2787 a blocking connect (i.e. wait) for stream type connections.
2788
2789 :noquery BOOL -- Query the user unless BOOL is non-nil, and process is
2790 running when Emacs is exited.
2791
2792 :stop BOOL -- Start process in the `stopped' state if BOOL non-nil.
2793 In the stopped state, a server process does not accept new
2794 connections, and a client process does not handle incoming traffic.
2795 The stopped state is cleared by `continue-process' and set by
2796 `stop-process'.
2797
2798 :filter FILTER -- Install FILTER as the process filter.
2799
2800 :filter-multibyte BOOL -- If BOOL is non-nil, strings given to the
2801 process filter are multibyte, otherwise they are unibyte.
2802 If this keyword is not specified, the strings are multibyte if
2803 the default value of `enable-multibyte-characters' is non-nil.
2804
2805 :sentinel SENTINEL -- Install SENTINEL as the process sentinel.
2806
2807 :log LOG -- Install LOG as the server process log function. This
2808 function is called when the server accepts a network connection from a
2809 client. The arguments are SERVER, CLIENT, and MESSAGE, where SERVER
2810 is the server process, CLIENT is the new process for the connection,
2811 and MESSAGE is a string.
2812
2813 :plist PLIST -- Install PLIST as the new process' initial plist.
2814
2815 :server QLEN -- if QLEN is non-nil, create a server process for the
2816 specified FAMILY, SERVICE, and connection type (stream or datagram).
2817 If QLEN is an integer, it is used as the max. length of the server's
2818 pending connection queue (also known as the backlog); the default
2819 queue length is 5. Default is to create a client process.
2820
2821 The following network options can be specified for this connection:
2822
2823 :broadcast BOOL -- Allow send and receive of datagram broadcasts.
2824 :dontroute BOOL -- Only send to directly connected hosts.
2825 :keepalive BOOL -- Send keep-alive messages on network stream.
2826 :linger BOOL or TIMEOUT -- Send queued messages before closing.
2827 :oobinline BOOL -- Place out-of-band data in receive data stream.
2828 :priority INT -- Set protocol defined priority for sent packets.
2829 :reuseaddr BOOL -- Allow reusing a recently used local address
2830 (this is allowed by default for a server process).
2831 :bindtodevice NAME -- bind to interface NAME. Using this may require
2832 special privileges on some systems.
2833
2834 Consult the relevant system programmer's manual pages for more
2835 information on using these options.
2836
2837
2838 A server process will listen for and accept connections from clients.
2839 When a client connection is accepted, a new network process is created
2840 for the connection with the following parameters:
2841
2842 - The client's process name is constructed by concatenating the server
2843 process' NAME and a client identification string.
2844 - If the FILTER argument is non-nil, the client process will not get a
2845 separate process buffer; otherwise, the client's process buffer is a newly
2846 created buffer named after the server process' BUFFER name or process
2847 NAME concatenated with the client identification string.
2848 - The connection type and the process filter and sentinel parameters are
2849 inherited from the server process' TYPE, FILTER and SENTINEL.
2850 - The client process' contact info is set according to the client's
2851 addressing information (typically an IP address and a port number).
2852 - The client process' plist is initialized from the server's plist.
2853
2854 Notice that the FILTER and SENTINEL args are never used directly by
2855 the server process. Also, the BUFFER argument is not used directly by
2856 the server process, but via the optional :log function, accepted (and
2857 failed) connections may be logged in the server process' buffer.
2858
2859 The original argument list, modified with the actual connection
2860 information, is available via the `process-contact' function.
2861
2862 usage: (make-network-process &rest ARGS) */)
2863 (ptrdiff_t nargs, Lisp_Object *args)
2864 {
2865 Lisp_Object proc;
2866 Lisp_Object contact;
2867 struct Lisp_Process *p;
2868 #ifdef HAVE_GETADDRINFO
2869 struct addrinfo ai, *res, *lres;
2870 struct addrinfo hints;
2871 const char *portstring;
2872 char portbuf[128];
2873 #else /* HAVE_GETADDRINFO */
2874 struct _emacs_addrinfo
2875 {
2876 int ai_family;
2877 int ai_socktype;
2878 int ai_protocol;
2879 int ai_addrlen;
2880 struct sockaddr *ai_addr;
2881 struct _emacs_addrinfo *ai_next;
2882 } ai, *res, *lres;
2883 #endif /* HAVE_GETADDRINFO */
2884 struct sockaddr_in address_in;
2885 #ifdef HAVE_LOCAL_SOCKETS
2886 struct sockaddr_un address_un;
2887 #endif
2888 int port;
2889 int ret = 0;
2890 int xerrno = 0;
2891 int s = -1, outch, inch;
2892 struct gcpro gcpro1;
2893 ptrdiff_t count = SPECPDL_INDEX ();
2894 ptrdiff_t count1;
2895 Lisp_Object QCaddress; /* one of QClocal or QCremote */
2896 Lisp_Object tem;
2897 Lisp_Object name, buffer, host, service, address;
2898 Lisp_Object filter, sentinel;
2899 int is_non_blocking_client = 0;
2900 int is_server = 0, backlog = 5;
2901 int socktype;
2902 int family = -1;
2903
2904 if (nargs == 0)
2905 return Qnil;
2906
2907 /* Save arguments for process-contact and clone-process. */
2908 contact = Flist (nargs, args);
2909 GCPRO1 (contact);
2910
2911 #ifdef WINDOWSNT
2912 /* Ensure socket support is loaded if available. */
2913 init_winsock (TRUE);
2914 #endif
2915
2916 /* :type TYPE (nil: stream, datagram */
2917 tem = Fplist_get (contact, QCtype);
2918 if (NILP (tem))
2919 socktype = SOCK_STREAM;
2920 #ifdef DATAGRAM_SOCKETS
2921 else if (EQ (tem, Qdatagram))
2922 socktype = SOCK_DGRAM;
2923 #endif
2924 #ifdef HAVE_SEQPACKET
2925 else if (EQ (tem, Qseqpacket))
2926 socktype = SOCK_SEQPACKET;
2927 #endif
2928 else
2929 error ("Unsupported connection type");
2930
2931 /* :server BOOL */
2932 tem = Fplist_get (contact, QCserver);
2933 if (!NILP (tem))
2934 {
2935 /* Don't support network sockets when non-blocking mode is
2936 not available, since a blocked Emacs is not useful. */
2937 #if !defined (O_NONBLOCK) && !defined (O_NDELAY)
2938 error ("Network servers not supported");
2939 #else
2940 is_server = 1;
2941 if (TYPE_RANGED_INTEGERP (int, tem))
2942 backlog = XINT (tem);
2943 #endif
2944 }
2945
2946 /* Make QCaddress an alias for :local (server) or :remote (client). */
2947 QCaddress = is_server ? QClocal : QCremote;
2948
2949 /* :nowait BOOL */
2950 if (!is_server && socktype != SOCK_DGRAM
2951 && (tem = Fplist_get (contact, QCnowait), !NILP (tem)))
2952 {
2953 #ifndef NON_BLOCKING_CONNECT
2954 error ("Non-blocking connect not supported");
2955 #else
2956 is_non_blocking_client = 1;
2957 #endif
2958 }
2959
2960 name = Fplist_get (contact, QCname);
2961 buffer = Fplist_get (contact, QCbuffer);
2962 filter = Fplist_get (contact, QCfilter);
2963 sentinel = Fplist_get (contact, QCsentinel);
2964
2965 CHECK_STRING (name);
2966
2967 /* Initialize addrinfo structure in case we don't use getaddrinfo. */
2968 ai.ai_socktype = socktype;
2969 ai.ai_protocol = 0;
2970 ai.ai_next = NULL;
2971 res = &ai;
2972
2973 /* :local ADDRESS or :remote ADDRESS */
2974 address = Fplist_get (contact, QCaddress);
2975 if (!NILP (address))
2976 {
2977 host = service = Qnil;
2978
2979 if (!(ai.ai_addrlen = get_lisp_to_sockaddr_size (address, &family)))
2980 error ("Malformed :address");
2981 ai.ai_family = family;
2982 ai.ai_addr = alloca (ai.ai_addrlen);
2983 conv_lisp_to_sockaddr (family, address, ai.ai_addr, ai.ai_addrlen);
2984 goto open_socket;
2985 }
2986
2987 /* :family FAMILY -- nil (for Inet), local, or integer. */
2988 tem = Fplist_get (contact, QCfamily);
2989 if (NILP (tem))
2990 {
2991 #if defined (HAVE_GETADDRINFO) && defined (AF_INET6)
2992 family = AF_UNSPEC;
2993 #else
2994 family = AF_INET;
2995 #endif
2996 }
2997 #ifdef HAVE_LOCAL_SOCKETS
2998 else if (EQ (tem, Qlocal))
2999 family = AF_LOCAL;
3000 #endif
3001 #ifdef AF_INET6
3002 else if (EQ (tem, Qipv6))
3003 family = AF_INET6;
3004 #endif
3005 else if (EQ (tem, Qipv4))
3006 family = AF_INET;
3007 else if (TYPE_RANGED_INTEGERP (int, tem))
3008 family = XINT (tem);
3009 else
3010 error ("Unknown address family");
3011
3012 ai.ai_family = family;
3013
3014 /* :service SERVICE -- string, integer (port number), or t (random port). */
3015 service = Fplist_get (contact, QCservice);
3016
3017 /* :host HOST -- hostname, ip address, or 'local for localhost. */
3018 host = Fplist_get (contact, QChost);
3019 if (!NILP (host))
3020 {
3021 if (EQ (host, Qlocal))
3022 /* Depending on setup, "localhost" may map to different IPv4 and/or
3023 IPv6 addresses, so it's better to be explicit. (Bug#6781) */
3024 host = build_string ("127.0.0.1");
3025 CHECK_STRING (host);
3026 }
3027
3028 #ifdef HAVE_LOCAL_SOCKETS
3029 if (family == AF_LOCAL)
3030 {
3031 if (!NILP (host))
3032 {
3033 message (":family local ignores the :host \"%s\" property",
3034 SDATA (host));
3035 contact = Fplist_put (contact, QChost, Qnil);
3036 host = Qnil;
3037 }
3038 CHECK_STRING (service);
3039 memset (&address_un, 0, sizeof address_un);
3040 address_un.sun_family = AF_LOCAL;
3041 strncpy (address_un.sun_path, SSDATA (service), sizeof address_un.sun_path);
3042 ai.ai_addr = (struct sockaddr *) &address_un;
3043 ai.ai_addrlen = sizeof address_un;
3044 goto open_socket;
3045 }
3046 #endif
3047
3048 /* Slow down polling to every ten seconds.
3049 Some kernels have a bug which causes retrying connect to fail
3050 after a connect. Polling can interfere with gethostbyname too. */
3051 #ifdef POLL_FOR_INPUT
3052 if (socktype != SOCK_DGRAM)
3053 {
3054 record_unwind_protect (unwind_stop_other_atimers, Qnil);
3055 bind_polling_period (10);
3056 }
3057 #endif
3058
3059 #ifdef HAVE_GETADDRINFO
3060 /* If we have a host, use getaddrinfo to resolve both host and service.
3061 Otherwise, use getservbyname to lookup the service. */
3062 if (!NILP (host))
3063 {
3064
3065 /* SERVICE can either be a string or int.
3066 Convert to a C string for later use by getaddrinfo. */
3067 if (EQ (service, Qt))
3068 portstring = "0";
3069 else if (INTEGERP (service))
3070 {
3071 sprintf (portbuf, "%"pI"d", XINT (service));
3072 portstring = portbuf;
3073 }
3074 else
3075 {
3076 CHECK_STRING (service);
3077 portstring = SSDATA (service);
3078 }
3079
3080 immediate_quit = 1;
3081 QUIT;
3082 memset (&hints, 0, sizeof (hints));
3083 hints.ai_flags = 0;
3084 hints.ai_family = family;
3085 hints.ai_socktype = socktype;
3086 hints.ai_protocol = 0;
3087
3088 #ifdef HAVE_RES_INIT
3089 res_init ();
3090 #endif
3091
3092 ret = getaddrinfo (SSDATA (host), portstring, &hints, &res);
3093 if (ret)
3094 #ifdef HAVE_GAI_STRERROR
3095 error ("%s/%s %s", SSDATA (host), portstring, gai_strerror (ret));
3096 #else
3097 error ("%s/%s getaddrinfo error %d", SSDATA (host), portstring, ret);
3098 #endif
3099 immediate_quit = 0;
3100
3101 goto open_socket;
3102 }
3103 #endif /* HAVE_GETADDRINFO */
3104
3105 /* We end up here if getaddrinfo is not defined, or in case no hostname
3106 has been specified (e.g. for a local server process). */
3107
3108 if (EQ (service, Qt))
3109 port = 0;
3110 else if (INTEGERP (service))
3111 port = htons ((unsigned short) XINT (service));
3112 else
3113 {
3114 struct servent *svc_info;
3115 CHECK_STRING (service);
3116 svc_info = getservbyname (SSDATA (service),
3117 (socktype == SOCK_DGRAM ? "udp" : "tcp"));
3118 if (svc_info == 0)
3119 error ("Unknown service: %s", SDATA (service));
3120 port = svc_info->s_port;
3121 }
3122
3123 memset (&address_in, 0, sizeof address_in);
3124 address_in.sin_family = family;
3125 address_in.sin_addr.s_addr = INADDR_ANY;
3126 address_in.sin_port = port;
3127
3128 #ifndef HAVE_GETADDRINFO
3129 if (!NILP (host))
3130 {
3131 struct hostent *host_info_ptr;
3132
3133 /* gethostbyname may fail with TRY_AGAIN, but we don't honor that,
3134 as it may `hang' Emacs for a very long time. */
3135 immediate_quit = 1;
3136 QUIT;
3137
3138 #ifdef HAVE_RES_INIT
3139 res_init ();
3140 #endif
3141
3142 host_info_ptr = gethostbyname (SDATA (host));
3143 immediate_quit = 0;
3144
3145 if (host_info_ptr)
3146 {
3147 memcpy (&address_in.sin_addr, host_info_ptr->h_addr,
3148 host_info_ptr->h_length);
3149 family = host_info_ptr->h_addrtype;
3150 address_in.sin_family = family;
3151 }
3152 else
3153 /* Attempt to interpret host as numeric inet address */
3154 {
3155 unsigned long numeric_addr;
3156 numeric_addr = inet_addr (SSDATA (host));
3157 if (numeric_addr == -1)
3158 error ("Unknown host \"%s\"", SDATA (host));
3159
3160 memcpy (&address_in.sin_addr, &numeric_addr,
3161 sizeof (address_in.sin_addr));
3162 }
3163
3164 }
3165 #endif /* not HAVE_GETADDRINFO */
3166
3167 ai.ai_family = family;
3168 ai.ai_addr = (struct sockaddr *) &address_in;
3169 ai.ai_addrlen = sizeof address_in;
3170
3171 open_socket:
3172
3173 /* Do this in case we never enter the for-loop below. */
3174 count1 = SPECPDL_INDEX ();
3175 s = -1;
3176
3177 for (lres = res; lres; lres = lres->ai_next)
3178 {
3179 ptrdiff_t optn;
3180 int optbits;
3181
3182 #ifdef WINDOWSNT
3183 retry_connect:
3184 #endif
3185
3186 s = socket (lres->ai_family, lres->ai_socktype, lres->ai_protocol);
3187 if (s < 0)
3188 {
3189 xerrno = errno;
3190 continue;
3191 }
3192
3193 #ifdef DATAGRAM_SOCKETS
3194 if (!is_server && socktype == SOCK_DGRAM)
3195 break;
3196 #endif /* DATAGRAM_SOCKETS */
3197
3198 #ifdef NON_BLOCKING_CONNECT
3199 if (is_non_blocking_client)
3200 {
3201 #ifdef O_NONBLOCK
3202 ret = fcntl (s, F_SETFL, O_NONBLOCK);
3203 #else
3204 ret = fcntl (s, F_SETFL, O_NDELAY);
3205 #endif
3206 if (ret < 0)
3207 {
3208 xerrno = errno;
3209 emacs_close (s);
3210 s = -1;
3211 continue;
3212 }
3213 }
3214 #endif
3215
3216 /* Make us close S if quit. */
3217 record_unwind_protect (close_file_unwind, make_number (s));
3218
3219 /* Parse network options in the arg list.
3220 We simply ignore anything which isn't a known option (including other keywords).
3221 An error is signaled if setting a known option fails. */
3222 for (optn = optbits = 0; optn < nargs-1; optn += 2)
3223 optbits |= set_socket_option (s, args[optn], args[optn+1]);
3224
3225 if (is_server)
3226 {
3227 /* Configure as a server socket. */
3228
3229 /* SO_REUSEADDR = 1 is default for server sockets; must specify
3230 explicit :reuseaddr key to override this. */
3231 #ifdef HAVE_LOCAL_SOCKETS
3232 if (family != AF_LOCAL)
3233 #endif
3234 if (!(optbits & (1 << OPIX_REUSEADDR)))
3235 {
3236 int optval = 1;
3237 if (setsockopt (s, SOL_SOCKET, SO_REUSEADDR, &optval, sizeof optval))
3238 report_file_error ("Cannot set reuse option on server socket", Qnil);
3239 }
3240
3241 if (bind (s, lres->ai_addr, lres->ai_addrlen))
3242 report_file_error ("Cannot bind server socket", Qnil);
3243
3244 #ifdef HAVE_GETSOCKNAME
3245 if (EQ (service, Qt))
3246 {
3247 struct sockaddr_in sa1;
3248 socklen_t len1 = sizeof (sa1);
3249 if (getsockname (s, (struct sockaddr *)&sa1, &len1) == 0)
3250 {
3251 ((struct sockaddr_in *)(lres->ai_addr))->sin_port = sa1.sin_port;
3252 service = make_number (ntohs (sa1.sin_port));
3253 contact = Fplist_put (contact, QCservice, service);
3254 }
3255 }
3256 #endif
3257
3258 if (socktype != SOCK_DGRAM && listen (s, backlog))
3259 report_file_error ("Cannot listen on server socket", Qnil);
3260
3261 break;
3262 }
3263
3264 immediate_quit = 1;
3265 QUIT;
3266
3267 ret = connect (s, lres->ai_addr, lres->ai_addrlen);
3268 xerrno = errno;
3269
3270 if (ret == 0 || xerrno == EISCONN)
3271 {
3272 /* The unwind-protect will be discarded afterwards.
3273 Likewise for immediate_quit. */
3274 break;
3275 }
3276
3277 #ifdef NON_BLOCKING_CONNECT
3278 #ifdef EINPROGRESS
3279 if (is_non_blocking_client && xerrno == EINPROGRESS)
3280 break;
3281 #else
3282 #ifdef EWOULDBLOCK
3283 if (is_non_blocking_client && xerrno == EWOULDBLOCK)
3284 break;
3285 #endif
3286 #endif
3287 #endif
3288
3289 #ifndef WINDOWSNT
3290 if (xerrno == EINTR)
3291 {
3292 /* Unlike most other syscalls connect() cannot be called
3293 again. (That would return EALREADY.) The proper way to
3294 wait for completion is select(). */
3295 int sc;
3296 socklen_t len;
3297 SELECT_TYPE fdset;
3298 retry_select:
3299 FD_ZERO (&fdset);
3300 FD_SET (s, &fdset);
3301 QUIT;
3302 sc = select (s + 1, (SELECT_TYPE *)0, &fdset, (SELECT_TYPE *)0,
3303 (EMACS_TIME *)0);
3304 if (sc == -1)
3305 {
3306 if (errno == EINTR)
3307 goto retry_select;
3308 else
3309 report_file_error ("select failed", Qnil);
3310 }
3311 eassert (sc > 0);
3312
3313 len = sizeof xerrno;
3314 eassert (FD_ISSET (s, &fdset));
3315 if (getsockopt (s, SOL_SOCKET, SO_ERROR, &xerrno, &len) == -1)
3316 report_file_error ("getsockopt failed", Qnil);
3317 if (xerrno)
3318 errno = xerrno, report_file_error ("error during connect", Qnil);
3319 else
3320 break;
3321 }
3322 #endif /* !WINDOWSNT */
3323
3324 immediate_quit = 0;
3325
3326 /* Discard the unwind protect closing S. */
3327 specpdl_ptr = specpdl + count1;
3328 emacs_close (s);
3329 s = -1;
3330
3331 #ifdef WINDOWSNT
3332 if (xerrno == EINTR)
3333 goto retry_connect;
3334 #endif
3335 }
3336
3337 if (s >= 0)
3338 {
3339 #ifdef DATAGRAM_SOCKETS
3340 if (socktype == SOCK_DGRAM)
3341 {
3342 if (datagram_address[s].sa)
3343 abort ();
3344 datagram_address[s].sa = (struct sockaddr *) xmalloc (lres->ai_addrlen);
3345 datagram_address[s].len = lres->ai_addrlen;
3346 if (is_server)
3347 {
3348 Lisp_Object remote;
3349 memset (datagram_address[s].sa, 0, lres->ai_addrlen);
3350 if (remote = Fplist_get (contact, QCremote), !NILP (remote))
3351 {
3352 int rfamily, rlen;
3353 rlen = get_lisp_to_sockaddr_size (remote, &rfamily);
3354 if (rfamily == lres->ai_family && rlen == lres->ai_addrlen)
3355 conv_lisp_to_sockaddr (rfamily, remote,
3356 datagram_address[s].sa, rlen);
3357 }
3358 }
3359 else
3360 memcpy (datagram_address[s].sa, lres->ai_addr, lres->ai_addrlen);
3361 }
3362 #endif
3363 contact = Fplist_put (contact, QCaddress,
3364 conv_sockaddr_to_lisp (lres->ai_addr, lres->ai_addrlen));
3365 #ifdef HAVE_GETSOCKNAME
3366 if (!is_server)
3367 {
3368 struct sockaddr_in sa1;
3369 socklen_t len1 = sizeof (sa1);
3370 if (getsockname (s, (struct sockaddr *)&sa1, &len1) == 0)
3371 contact = Fplist_put (contact, QClocal,
3372 conv_sockaddr_to_lisp ((struct sockaddr *)&sa1, len1));
3373 }
3374 #endif
3375 }
3376
3377 immediate_quit = 0;
3378
3379 #ifdef HAVE_GETADDRINFO
3380 if (res != &ai)
3381 {
3382 BLOCK_INPUT;
3383 freeaddrinfo (res);
3384 UNBLOCK_INPUT;
3385 }
3386 #endif
3387
3388 /* Discard the unwind protect for closing S, if any. */
3389 specpdl_ptr = specpdl + count1;
3390
3391 /* Unwind bind_polling_period and request_sigio. */
3392 unbind_to (count, Qnil);
3393
3394 if (s < 0)
3395 {
3396 /* If non-blocking got this far - and failed - assume non-blocking is
3397 not supported after all. This is probably a wrong assumption, but
3398 the normal blocking calls to open-network-stream handles this error
3399 better. */
3400 if (is_non_blocking_client)
3401 return Qnil;
3402
3403 errno = xerrno;
3404 if (is_server)
3405 report_file_error ("make server process failed", contact);
3406 else
3407 report_file_error ("make client process failed", contact);
3408 }
3409
3410 inch = s;
3411 outch = s;
3412
3413 if (!NILP (buffer))
3414 buffer = Fget_buffer_create (buffer);
3415 proc = make_process (name);
3416
3417 chan_process[inch] = proc;
3418
3419 #ifdef O_NONBLOCK
3420 fcntl (inch, F_SETFL, O_NONBLOCK);
3421 #else
3422 #ifdef O_NDELAY
3423 fcntl (inch, F_SETFL, O_NDELAY);
3424 #endif
3425 #endif
3426
3427 p = XPROCESS (proc);
3428
3429 p->childp = contact;
3430 p->plist = Fcopy_sequence (Fplist_get (contact, QCplist));
3431 p->type = Qnetwork;
3432
3433 p->buffer = buffer;
3434 p->sentinel = sentinel;
3435 p->filter = filter;
3436 p->log = Fplist_get (contact, QClog);
3437 if (tem = Fplist_get (contact, QCnoquery), !NILP (tem))
3438 p->kill_without_query = 1;
3439 if ((tem = Fplist_get (contact, QCstop), !NILP (tem)))
3440 p->command = Qt;
3441 p->pid = 0;
3442 p->infd = inch;
3443 p->outfd = outch;
3444 if (is_server && socktype != SOCK_DGRAM)
3445 p->status = Qlisten;
3446
3447 /* Make the process marker point into the process buffer (if any). */
3448 if (BUFFERP (buffer))
3449 set_marker_both (p->mark, buffer,
3450 BUF_ZV (XBUFFER (buffer)),
3451 BUF_ZV_BYTE (XBUFFER (buffer)));
3452
3453 #ifdef NON_BLOCKING_CONNECT
3454 if (is_non_blocking_client)
3455 {
3456 /* We may get here if connect did succeed immediately. However,
3457 in that case, we still need to signal this like a non-blocking
3458 connection. */
3459 p->status = Qconnect;
3460 if (!FD_ISSET (inch, &connect_wait_mask))
3461 {
3462 FD_SET (inch, &connect_wait_mask);
3463 FD_SET (inch, &write_mask);
3464 num_pending_connects++;
3465 }
3466 }
3467 else
3468 #endif
3469 /* A server may have a client filter setting of Qt, but it must
3470 still listen for incoming connects unless it is stopped. */
3471 if ((!EQ (p->filter, Qt) && !EQ (p->command, Qt))
3472 || (EQ (p->status, Qlisten) && NILP (p->command)))
3473 {
3474 FD_SET (inch, &input_wait_mask);
3475 FD_SET (inch, &non_keyboard_wait_mask);
3476 }
3477
3478 if (inch > max_process_desc)
3479 max_process_desc = inch;
3480
3481 tem = Fplist_member (contact, QCcoding);
3482 if (!NILP (tem) && (!CONSP (tem) || !CONSP (XCDR (tem))))
3483 tem = Qnil; /* No error message (too late!). */
3484
3485 {
3486 /* Setup coding systems for communicating with the network stream. */
3487 struct gcpro gcpro1;
3488 /* Qt denotes we have not yet called Ffind_operation_coding_system. */
3489 Lisp_Object coding_systems = Qt;
3490 Lisp_Object fargs[5], val;
3491
3492 if (!NILP (tem))
3493 {
3494 val = XCAR (XCDR (tem));
3495 if (CONSP (val))
3496 val = XCAR (val);
3497 }
3498 else if (!NILP (Vcoding_system_for_read))
3499 val = Vcoding_system_for_read;
3500 else if ((!NILP (buffer) && NILP (BVAR (XBUFFER (buffer), enable_multibyte_characters)))
3501 || (NILP (buffer) && NILP (BVAR (&buffer_defaults, enable_multibyte_characters))))
3502 /* We dare not decode end-of-line format by setting VAL to
3503 Qraw_text, because the existing Emacs Lisp libraries
3504 assume that they receive bare code including a sequence of
3505 CR LF. */
3506 val = Qnil;
3507 else
3508 {
3509 if (NILP (host) || NILP (service))
3510 coding_systems = Qnil;
3511 else
3512 {
3513 fargs[0] = Qopen_network_stream, fargs[1] = name,
3514 fargs[2] = buffer, fargs[3] = host, fargs[4] = service;
3515 GCPRO1 (proc);
3516 coding_systems = Ffind_operation_coding_system (5, fargs);
3517 UNGCPRO;
3518 }
3519 if (CONSP (coding_systems))
3520 val = XCAR (coding_systems);
3521 else if (CONSP (Vdefault_process_coding_system))
3522 val = XCAR (Vdefault_process_coding_system);
3523 else
3524 val = Qnil;
3525 }
3526 p->decode_coding_system = val;
3527
3528 if (!NILP (tem))
3529 {
3530 val = XCAR (XCDR (tem));
3531 if (CONSP (val))
3532 val = XCDR (val);
3533 }
3534 else if (!NILP (Vcoding_system_for_write))
3535 val = Vcoding_system_for_write;
3536 else if (NILP (BVAR (current_buffer, enable_multibyte_characters)))
3537 val = Qnil;
3538 else
3539 {
3540 if (EQ (coding_systems, Qt))
3541 {
3542 if (NILP (host) || NILP (service))
3543 coding_systems = Qnil;
3544 else
3545 {
3546 fargs[0] = Qopen_network_stream, fargs[1] = name,
3547 fargs[2] = buffer, fargs[3] = host, fargs[4] = service;
3548 GCPRO1 (proc);
3549 coding_systems = Ffind_operation_coding_system (5, fargs);
3550 UNGCPRO;
3551 }
3552 }
3553 if (CONSP (coding_systems))
3554 val = XCDR (coding_systems);
3555 else if (CONSP (Vdefault_process_coding_system))
3556 val = XCDR (Vdefault_process_coding_system);
3557 else
3558 val = Qnil;
3559 }
3560 p->encode_coding_system = val;
3561 }
3562 setup_process_coding_systems (proc);
3563
3564 p->decoding_buf = empty_unibyte_string;
3565 p->decoding_carryover = 0;
3566 p->encoding_buf = empty_unibyte_string;
3567
3568 p->inherit_coding_system_flag
3569 = !(!NILP (tem) || NILP (buffer) || !inherit_process_coding_system);
3570
3571 UNGCPRO;
3572 return proc;
3573 }
3574
3575 \f
3576 #if defined (HAVE_NET_IF_H)
3577
3578 #ifdef SIOCGIFCONF
3579 DEFUN ("network-interface-list", Fnetwork_interface_list, Snetwork_interface_list, 0, 0, 0,
3580 doc: /* Return an alist of all network interfaces and their network address.
3581 Each element is a cons, the car of which is a string containing the
3582 interface name, and the cdr is the network address in internal
3583 format; see the description of ADDRESS in `make-network-process'. */)
3584 (void)
3585 {
3586 struct ifconf ifconf;
3587 struct ifreq *ifreq;
3588 void *buf = NULL;
3589 ptrdiff_t buf_size = 512;
3590 int s, i;
3591 Lisp_Object res;
3592
3593 s = socket (AF_INET, SOCK_STREAM, 0);
3594 if (s < 0)
3595 return Qnil;
3596
3597 do
3598 {
3599 buf = xpalloc (buf, &buf_size, 1, INT_MAX, 1);
3600 ifconf.ifc_buf = buf;
3601 ifconf.ifc_len = buf_size;
3602 if (ioctl (s, SIOCGIFCONF, &ifconf))
3603 {
3604 close (s);
3605 xfree (buf);
3606 return Qnil;
3607 }
3608 }
3609 while (ifconf.ifc_len == buf_size);
3610
3611 close (s);
3612
3613 res = Qnil;
3614 ifreq = ifconf.ifc_req;
3615 while ((char *) ifreq < (char *) ifconf.ifc_req + ifconf.ifc_len)
3616 {
3617 struct ifreq *ifq = ifreq;
3618 #ifdef HAVE_STRUCT_IFREQ_IFR_ADDR_SA_LEN
3619 #define SIZEOF_IFREQ(sif) \
3620 ((sif)->ifr_addr.sa_len < sizeof (struct sockaddr) \
3621 ? sizeof (*(sif)) : sizeof ((sif)->ifr_name) + (sif)->ifr_addr.sa_len)
3622
3623 int len = SIZEOF_IFREQ (ifq);
3624 #else
3625 int len = sizeof (*ifreq);
3626 #endif
3627 char namebuf[sizeof (ifq->ifr_name) + 1];
3628 i += len;
3629 ifreq = (struct ifreq *) ((char *) ifreq + len);
3630
3631 if (ifq->ifr_addr.sa_family != AF_INET)
3632 continue;
3633
3634 memcpy (namebuf, ifq->ifr_name, sizeof (ifq->ifr_name));
3635 namebuf[sizeof (ifq->ifr_name)] = 0;
3636 res = Fcons (Fcons (build_string (namebuf),
3637 conv_sockaddr_to_lisp (&ifq->ifr_addr,
3638 sizeof (struct sockaddr))),
3639 res);
3640 }
3641
3642 xfree (buf);
3643 return res;
3644 }
3645 #endif /* SIOCGIFCONF */
3646
3647 #if defined (SIOCGIFADDR) || defined (SIOCGIFHWADDR) || defined (SIOCGIFFLAGS)
3648
3649 struct ifflag_def {
3650 int flag_bit;
3651 const char *flag_sym;
3652 };
3653
3654 static const struct ifflag_def ifflag_table[] = {
3655 #ifdef IFF_UP
3656 { IFF_UP, "up" },
3657 #endif
3658 #ifdef IFF_BROADCAST
3659 { IFF_BROADCAST, "broadcast" },
3660 #endif
3661 #ifdef IFF_DEBUG
3662 { IFF_DEBUG, "debug" },
3663 #endif
3664 #ifdef IFF_LOOPBACK
3665 { IFF_LOOPBACK, "loopback" },
3666 #endif
3667 #ifdef IFF_POINTOPOINT
3668 { IFF_POINTOPOINT, "pointopoint" },
3669 #endif
3670 #ifdef IFF_RUNNING
3671 { IFF_RUNNING, "running" },
3672 #endif
3673 #ifdef IFF_NOARP
3674 { IFF_NOARP, "noarp" },
3675 #endif
3676 #ifdef IFF_PROMISC
3677 { IFF_PROMISC, "promisc" },
3678 #endif
3679 #ifdef IFF_NOTRAILERS
3680 #ifdef NS_IMPL_COCOA
3681 /* Really means smart, notrailers is obsolete */
3682 { IFF_NOTRAILERS, "smart" },
3683 #else
3684 { IFF_NOTRAILERS, "notrailers" },
3685 #endif
3686 #endif
3687 #ifdef IFF_ALLMULTI
3688 { IFF_ALLMULTI, "allmulti" },
3689 #endif
3690 #ifdef IFF_MASTER
3691 { IFF_MASTER, "master" },
3692 #endif
3693 #ifdef IFF_SLAVE
3694 { IFF_SLAVE, "slave" },
3695 #endif
3696 #ifdef IFF_MULTICAST
3697 { IFF_MULTICAST, "multicast" },
3698 #endif
3699 #ifdef IFF_PORTSEL
3700 { IFF_PORTSEL, "portsel" },
3701 #endif
3702 #ifdef IFF_AUTOMEDIA
3703 { IFF_AUTOMEDIA, "automedia" },
3704 #endif
3705 #ifdef IFF_DYNAMIC
3706 { IFF_DYNAMIC, "dynamic" },
3707 #endif
3708 #ifdef IFF_OACTIVE
3709 { IFF_OACTIVE, "oactive" }, /* OpenBSD: transmission in progress */
3710 #endif
3711 #ifdef IFF_SIMPLEX
3712 { IFF_SIMPLEX, "simplex" }, /* OpenBSD: can't hear own transmissions */
3713 #endif
3714 #ifdef IFF_LINK0
3715 { IFF_LINK0, "link0" }, /* OpenBSD: per link layer defined bit */
3716 #endif
3717 #ifdef IFF_LINK1
3718 { IFF_LINK1, "link1" }, /* OpenBSD: per link layer defined bit */
3719 #endif
3720 #ifdef IFF_LINK2
3721 { IFF_LINK2, "link2" }, /* OpenBSD: per link layer defined bit */
3722 #endif
3723 { 0, 0 }
3724 };
3725
3726 DEFUN ("network-interface-info", Fnetwork_interface_info, Snetwork_interface_info, 1, 1, 0,
3727 doc: /* Return information about network interface named IFNAME.
3728 The return value is a list (ADDR BCAST NETMASK HWADDR FLAGS),
3729 where ADDR is the layer 3 address, BCAST is the layer 3 broadcast address,
3730 NETMASK is the layer 3 network mask, HWADDR is the layer 2 address, and
3731 FLAGS is the current flags of the interface. */)
3732 (Lisp_Object ifname)
3733 {
3734 struct ifreq rq;
3735 Lisp_Object res = Qnil;
3736 Lisp_Object elt;
3737 int s;
3738 int any = 0;
3739 #if (! (defined SIOCGIFHWADDR && defined HAVE_STRUCT_IFREQ_IFR_HWADDR) \
3740 && defined HAVE_GETIFADDRS && defined LLADDR)
3741 struct ifaddrs *ifap;
3742 #endif
3743
3744 CHECK_STRING (ifname);
3745
3746 memset (rq.ifr_name, 0, sizeof rq.ifr_name);
3747 strncpy (rq.ifr_name, SSDATA (ifname), sizeof (rq.ifr_name));
3748
3749 s = socket (AF_INET, SOCK_STREAM, 0);
3750 if (s < 0)
3751 return Qnil;
3752
3753 elt = Qnil;
3754 #if defined (SIOCGIFFLAGS) && defined (HAVE_STRUCT_IFREQ_IFR_FLAGS)
3755 if (ioctl (s, SIOCGIFFLAGS, &rq) == 0)
3756 {
3757 int flags = rq.ifr_flags;
3758 const struct ifflag_def *fp;
3759 int fnum;
3760
3761 /* If flags is smaller than int (i.e. short) it may have the high bit set
3762 due to IFF_MULTICAST. In that case, sign extending it into
3763 an int is wrong. */
3764 if (flags < 0 && sizeof (rq.ifr_flags) < sizeof (flags))
3765 flags = (unsigned short) rq.ifr_flags;
3766
3767 any = 1;
3768 for (fp = ifflag_table; flags != 0 && fp->flag_sym; fp++)
3769 {
3770 if (flags & fp->flag_bit)
3771 {
3772 elt = Fcons (intern (fp->flag_sym), elt);
3773 flags -= fp->flag_bit;
3774 }
3775 }
3776 for (fnum = 0; flags && fnum < 32; flags >>= 1, fnum++)
3777 {
3778 if (flags & 1)
3779 {
3780 elt = Fcons (make_number (fnum), elt);
3781 }
3782 }
3783 }
3784 #endif
3785 res = Fcons (elt, res);
3786
3787 elt = Qnil;
3788 #if defined (SIOCGIFHWADDR) && defined (HAVE_STRUCT_IFREQ_IFR_HWADDR)
3789 if (ioctl (s, SIOCGIFHWADDR, &rq) == 0)
3790 {
3791 Lisp_Object hwaddr = Fmake_vector (make_number (6), Qnil);
3792 register struct Lisp_Vector *p = XVECTOR (hwaddr);
3793 int n;
3794
3795 any = 1;
3796 for (n = 0; n < 6; n++)
3797 p->contents[n] = make_number (((unsigned char *)&rq.ifr_hwaddr.sa_data[0])[n]);
3798 elt = Fcons (make_number (rq.ifr_hwaddr.sa_family), hwaddr);
3799 }
3800 #elif defined (HAVE_GETIFADDRS) && defined (LLADDR)
3801 if (getifaddrs (&ifap) != -1)
3802 {
3803 Lisp_Object hwaddr = Fmake_vector (make_number (6), Qnil);
3804 register struct Lisp_Vector *p = XVECTOR (hwaddr);
3805 struct ifaddrs *it;
3806
3807 for (it = ifap; it != NULL; it = it->ifa_next)
3808 {
3809 struct sockaddr_dl *sdl = (struct sockaddr_dl*) it->ifa_addr;
3810 unsigned char linkaddr[6];
3811 int n;
3812
3813 if (it->ifa_addr->sa_family != AF_LINK
3814 || strcmp (it->ifa_name, SSDATA (ifname)) != 0
3815 || sdl->sdl_alen != 6)
3816 continue;
3817
3818 memcpy (linkaddr, LLADDR (sdl), sdl->sdl_alen);
3819 for (n = 0; n < 6; n++)
3820 p->contents[n] = make_number (linkaddr[n]);
3821
3822 elt = Fcons (make_number (it->ifa_addr->sa_family), hwaddr);
3823 break;
3824 }
3825 }
3826 #ifdef HAVE_FREEIFADDRS
3827 freeifaddrs (ifap);
3828 #endif
3829
3830 #endif /* HAVE_GETIFADDRS && LLADDR */
3831
3832 res = Fcons (elt, res);
3833
3834 elt = Qnil;
3835 #if defined (SIOCGIFNETMASK) && (defined (HAVE_STRUCT_IFREQ_IFR_NETMASK) || defined (HAVE_STRUCT_IFREQ_IFR_ADDR))
3836 if (ioctl (s, SIOCGIFNETMASK, &rq) == 0)
3837 {
3838 any = 1;
3839 #ifdef HAVE_STRUCT_IFREQ_IFR_NETMASK
3840 elt = conv_sockaddr_to_lisp (&rq.ifr_netmask, sizeof (rq.ifr_netmask));
3841 #else
3842 elt = conv_sockaddr_to_lisp (&rq.ifr_addr, sizeof (rq.ifr_addr));
3843 #endif
3844 }
3845 #endif
3846 res = Fcons (elt, res);
3847
3848 elt = Qnil;
3849 #if defined (SIOCGIFBRDADDR) && defined (HAVE_STRUCT_IFREQ_IFR_BROADADDR)
3850 if (ioctl (s, SIOCGIFBRDADDR, &rq) == 0)
3851 {
3852 any = 1;
3853 elt = conv_sockaddr_to_lisp (&rq.ifr_broadaddr, sizeof (rq.ifr_broadaddr));
3854 }
3855 #endif
3856 res = Fcons (elt, res);
3857
3858 elt = Qnil;
3859 #if defined (SIOCGIFADDR) && defined (HAVE_STRUCT_IFREQ_IFR_ADDR)
3860 if (ioctl (s, SIOCGIFADDR, &rq) == 0)
3861 {
3862 any = 1;
3863 elt = conv_sockaddr_to_lisp (&rq.ifr_addr, sizeof (rq.ifr_addr));
3864 }
3865 #endif
3866 res = Fcons (elt, res);
3867
3868 close (s);
3869
3870 return any ? res : Qnil;
3871 }
3872 #endif
3873 #endif /* defined (HAVE_NET_IF_H) */
3874
3875 /* Turn off input and output for process PROC. */
3876
3877 static void
3878 deactivate_process (Lisp_Object proc)
3879 {
3880 register int inchannel, outchannel;
3881 register struct Lisp_Process *p = XPROCESS (proc);
3882
3883 #ifdef HAVE_GNUTLS
3884 /* Delete GnuTLS structures in PROC, if any. */
3885 emacs_gnutls_deinit (proc);
3886 #endif /* HAVE_GNUTLS */
3887
3888 inchannel = p->infd;
3889 outchannel = p->outfd;
3890
3891 #ifdef ADAPTIVE_READ_BUFFERING
3892 if (p->read_output_delay > 0)
3893 {
3894 if (--process_output_delay_count < 0)
3895 process_output_delay_count = 0;
3896 p->read_output_delay = 0;
3897 p->read_output_skip = 0;
3898 }
3899 #endif
3900
3901 if (inchannel >= 0)
3902 {
3903 /* Beware SIGCHLD hereabouts. */
3904 flush_pending_output (inchannel);
3905 emacs_close (inchannel);
3906 if (outchannel >= 0 && outchannel != inchannel)
3907 emacs_close (outchannel);
3908
3909 p->infd = -1;
3910 p->outfd = -1;
3911 #ifdef DATAGRAM_SOCKETS
3912 if (DATAGRAM_CHAN_P (inchannel))
3913 {
3914 xfree (datagram_address[inchannel].sa);
3915 datagram_address[inchannel].sa = 0;
3916 datagram_address[inchannel].len = 0;
3917 }
3918 #endif
3919 chan_process[inchannel] = Qnil;
3920 FD_CLR (inchannel, &input_wait_mask);
3921 FD_CLR (inchannel, &non_keyboard_wait_mask);
3922 #ifdef NON_BLOCKING_CONNECT
3923 if (FD_ISSET (inchannel, &connect_wait_mask))
3924 {
3925 FD_CLR (inchannel, &connect_wait_mask);
3926 FD_CLR (inchannel, &write_mask);
3927 if (--num_pending_connects < 0)
3928 abort ();
3929 }
3930 #endif
3931 if (inchannel == max_process_desc)
3932 {
3933 int i;
3934 /* We just closed the highest-numbered process input descriptor,
3935 so recompute the highest-numbered one now. */
3936 max_process_desc = 0;
3937 for (i = 0; i < MAXDESC; i++)
3938 if (!NILP (chan_process[i]))
3939 max_process_desc = i;
3940 }
3941 }
3942 }
3943
3944 \f
3945 DEFUN ("accept-process-output", Faccept_process_output, Saccept_process_output,
3946 0, 4, 0,
3947 doc: /* Allow any pending output from subprocesses to be read by Emacs.
3948 It is read into the process' buffers or given to their filter functions.
3949 Non-nil arg PROCESS means do not return until some output has been received
3950 from PROCESS.
3951
3952 Non-nil second arg SECONDS and third arg MILLISEC are number of seconds
3953 and milliseconds to wait; return after that much time whether or not
3954 there is any subprocess output. If SECONDS is a floating point number,
3955 it specifies a fractional number of seconds to wait.
3956 The MILLISEC argument is obsolete and should be avoided.
3957
3958 If optional fourth arg JUST-THIS-ONE is non-nil, only accept output
3959 from PROCESS, suspending reading output from other processes.
3960 If JUST-THIS-ONE is an integer, don't run any timers either.
3961 Return non-nil if we received any output before the timeout expired. */)
3962 (register Lisp_Object process, Lisp_Object seconds, Lisp_Object millisec, Lisp_Object just_this_one)
3963 {
3964 int secs = -1, usecs = 0;
3965
3966 if (! NILP (process))
3967 CHECK_PROCESS (process);
3968 else
3969 just_this_one = Qnil;
3970
3971 if (!NILP (millisec))
3972 { /* Obsolete calling convention using integers rather than floats. */
3973 CHECK_NUMBER (millisec);
3974 if (NILP (seconds))
3975 seconds = make_float (XINT (millisec) / 1000.0);
3976 else
3977 {
3978 CHECK_NUMBER (seconds);
3979 seconds = make_float (XINT (millisec) / 1000.0 + XINT (seconds));
3980 }
3981 }
3982
3983 if (!NILP (seconds))
3984 {
3985 double duration = extract_float (seconds);
3986 if (0 < duration)
3987 duration_to_sec_usec (duration, &secs, &usecs);
3988 }
3989 else if (!NILP (process))
3990 secs = 0;
3991
3992 return
3993 (wait_reading_process_output (secs, usecs, 0, 0,
3994 Qnil,
3995 !NILP (process) ? XPROCESS (process) : NULL,
3996 NILP (just_this_one) ? 0 :
3997 !INTEGERP (just_this_one) ? 1 : -1)
3998 ? Qt : Qnil);
3999 }
4000
4001 /* Accept a connection for server process SERVER on CHANNEL. */
4002
4003 static int connect_counter = 0;
4004
4005 static void
4006 server_accept_connection (Lisp_Object server, int channel)
4007 {
4008 Lisp_Object proc, caller, name, buffer;
4009 Lisp_Object contact, host, service;
4010 struct Lisp_Process *ps= XPROCESS (server);
4011 struct Lisp_Process *p;
4012 int s;
4013 union u_sockaddr {
4014 struct sockaddr sa;
4015 struct sockaddr_in in;
4016 #ifdef AF_INET6
4017 struct sockaddr_in6 in6;
4018 #endif
4019 #ifdef HAVE_LOCAL_SOCKETS
4020 struct sockaddr_un un;
4021 #endif
4022 } saddr;
4023 socklen_t len = sizeof saddr;
4024
4025 s = accept (channel, &saddr.sa, &len);
4026
4027 if (s < 0)
4028 {
4029 int code = errno;
4030
4031 if (code == EAGAIN)
4032 return;
4033 #ifdef EWOULDBLOCK
4034 if (code == EWOULDBLOCK)
4035 return;
4036 #endif
4037
4038 if (!NILP (ps->log))
4039 call3 (ps->log, server, Qnil,
4040 concat3 (build_string ("accept failed with code"),
4041 Fnumber_to_string (make_number (code)),
4042 build_string ("\n")));
4043 return;
4044 }
4045
4046 connect_counter++;
4047
4048 /* Setup a new process to handle the connection. */
4049
4050 /* Generate a unique identification of the caller, and build contact
4051 information for this process. */
4052 host = Qt;
4053 service = Qnil;
4054 switch (saddr.sa.sa_family)
4055 {
4056 case AF_INET:
4057 {
4058 Lisp_Object args[5];
4059 unsigned char *ip = (unsigned char *)&saddr.in.sin_addr.s_addr;
4060 args[0] = build_string ("%d.%d.%d.%d");
4061 args[1] = make_number (*ip++);
4062 args[2] = make_number (*ip++);
4063 args[3] = make_number (*ip++);
4064 args[4] = make_number (*ip++);
4065 host = Fformat (5, args);
4066 service = make_number (ntohs (saddr.in.sin_port));
4067
4068 args[0] = build_string (" <%s:%d>");
4069 args[1] = host;
4070 args[2] = service;
4071 caller = Fformat (3, args);
4072 }
4073 break;
4074
4075 #ifdef AF_INET6
4076 case AF_INET6:
4077 {
4078 Lisp_Object args[9];
4079 uint16_t *ip6 = (uint16_t *)&saddr.in6.sin6_addr;
4080 int i;
4081 args[0] = build_string ("%x:%x:%x:%x:%x:%x:%x:%x");
4082 for (i = 0; i < 8; i++)
4083 args[i+1] = make_number (ntohs (ip6[i]));
4084 host = Fformat (9, args);
4085 service = make_number (ntohs (saddr.in.sin_port));
4086
4087 args[0] = build_string (" <[%s]:%d>");
4088 args[1] = host;
4089 args[2] = service;
4090 caller = Fformat (3, args);
4091 }
4092 break;
4093 #endif
4094
4095 #ifdef HAVE_LOCAL_SOCKETS
4096 case AF_LOCAL:
4097 #endif
4098 default:
4099 caller = Fnumber_to_string (make_number (connect_counter));
4100 caller = concat3 (build_string (" <"), caller, build_string (">"));
4101 break;
4102 }
4103
4104 /* Create a new buffer name for this process if it doesn't have a
4105 filter. The new buffer name is based on the buffer name or
4106 process name of the server process concatenated with the caller
4107 identification. */
4108
4109 if (!NILP (ps->filter) && !EQ (ps->filter, Qt))
4110 buffer = Qnil;
4111 else
4112 {
4113 buffer = ps->buffer;
4114 if (!NILP (buffer))
4115 buffer = Fbuffer_name (buffer);
4116 else
4117 buffer = ps->name;
4118 if (!NILP (buffer))
4119 {
4120 buffer = concat2 (buffer, caller);
4121 buffer = Fget_buffer_create (buffer);
4122 }
4123 }
4124
4125 /* Generate a unique name for the new server process. Combine the
4126 server process name with the caller identification. */
4127
4128 name = concat2 (ps->name, caller);
4129 proc = make_process (name);
4130
4131 chan_process[s] = proc;
4132
4133 #ifdef O_NONBLOCK
4134 fcntl (s, F_SETFL, O_NONBLOCK);
4135 #else
4136 #ifdef O_NDELAY
4137 fcntl (s, F_SETFL, O_NDELAY);
4138 #endif
4139 #endif
4140
4141 p = XPROCESS (proc);
4142
4143 /* Build new contact information for this setup. */
4144 contact = Fcopy_sequence (ps->childp);
4145 contact = Fplist_put (contact, QCserver, Qnil);
4146 contact = Fplist_put (contact, QChost, host);
4147 if (!NILP (service))
4148 contact = Fplist_put (contact, QCservice, service);
4149 contact = Fplist_put (contact, QCremote,
4150 conv_sockaddr_to_lisp (&saddr.sa, len));
4151 #ifdef HAVE_GETSOCKNAME
4152 len = sizeof saddr;
4153 if (getsockname (s, &saddr.sa, &len) == 0)
4154 contact = Fplist_put (contact, QClocal,
4155 conv_sockaddr_to_lisp (&saddr.sa, len));
4156 #endif
4157
4158 p->childp = contact;
4159 p->plist = Fcopy_sequence (ps->plist);
4160 p->type = Qnetwork;
4161
4162 p->buffer = buffer;
4163 p->sentinel = ps->sentinel;
4164 p->filter = ps->filter;
4165 p->command = Qnil;
4166 p->pid = 0;
4167 p->infd = s;
4168 p->outfd = s;
4169 p->status = Qrun;
4170
4171 /* Client processes for accepted connections are not stopped initially. */
4172 if (!EQ (p->filter, Qt))
4173 {
4174 FD_SET (s, &input_wait_mask);
4175 FD_SET (s, &non_keyboard_wait_mask);
4176 }
4177
4178 if (s > max_process_desc)
4179 max_process_desc = s;
4180
4181 /* Setup coding system for new process based on server process.
4182 This seems to be the proper thing to do, as the coding system
4183 of the new process should reflect the settings at the time the
4184 server socket was opened; not the current settings. */
4185
4186 p->decode_coding_system = ps->decode_coding_system;
4187 p->encode_coding_system = ps->encode_coding_system;
4188 setup_process_coding_systems (proc);
4189
4190 p->decoding_buf = empty_unibyte_string;
4191 p->decoding_carryover = 0;
4192 p->encoding_buf = empty_unibyte_string;
4193
4194 p->inherit_coding_system_flag
4195 = (NILP (buffer) ? 0 : ps->inherit_coding_system_flag);
4196
4197 if (!NILP (ps->log))
4198 call3 (ps->log, server, proc,
4199 concat3 (build_string ("accept from "),
4200 (STRINGP (host) ? host : build_string ("-")),
4201 build_string ("\n")));
4202
4203 if (!NILP (p->sentinel))
4204 exec_sentinel (proc,
4205 concat3 (build_string ("open from "),
4206 (STRINGP (host) ? host : build_string ("-")),
4207 build_string ("\n")));
4208 }
4209
4210 /* This variable is different from waiting_for_input in keyboard.c.
4211 It is used to communicate to a lisp process-filter/sentinel (via the
4212 function Fwaiting_for_user_input_p below) whether Emacs was waiting
4213 for user-input when that process-filter was called.
4214 waiting_for_input cannot be used as that is by definition 0 when
4215 lisp code is being evalled.
4216 This is also used in record_asynch_buffer_change.
4217 For that purpose, this must be 0
4218 when not inside wait_reading_process_output. */
4219 static int waiting_for_user_input_p;
4220
4221 static Lisp_Object
4222 wait_reading_process_output_unwind (Lisp_Object data)
4223 {
4224 waiting_for_user_input_p = XINT (data);
4225 return Qnil;
4226 }
4227
4228 /* This is here so breakpoints can be put on it. */
4229 static void
4230 wait_reading_process_output_1 (void)
4231 {
4232 }
4233
4234 /* Use a wrapper around select to work around a bug in gdb 5.3.
4235 Normally, the wrapper is optimized away by inlining.
4236
4237 If emacs is stopped inside select, the gdb backtrace doesn't
4238 show the function which called select, so it is practically
4239 impossible to step through wait_reading_process_output. */
4240
4241 #ifndef select
4242 static inline int
4243 select_wrapper (int n, fd_set *rfd, fd_set *wfd, fd_set *xfd, struct timeval *tmo)
4244 {
4245 return select (n, rfd, wfd, xfd, tmo);
4246 }
4247 #define select select_wrapper
4248 #endif
4249
4250 /* Read and dispose of subprocess output while waiting for timeout to
4251 elapse and/or keyboard input to be available.
4252
4253 TIME_LIMIT is:
4254 timeout in seconds, or
4255 zero for no limit, or
4256 -1 means gobble data immediately available but don't wait for any.
4257
4258 MICROSECS is:
4259 an additional duration to wait, measured in microseconds.
4260 If this is nonzero and time_limit is 0, then the timeout
4261 consists of MICROSECS only.
4262
4263 READ_KBD is a lisp value:
4264 0 to ignore keyboard input, or
4265 1 to return when input is available, or
4266 -1 meaning caller will actually read the input, so don't throw to
4267 the quit handler, or
4268
4269 DO_DISPLAY != 0 means redisplay should be done to show subprocess
4270 output that arrives.
4271
4272 If WAIT_FOR_CELL is a cons cell, wait until its car is non-nil
4273 (and gobble terminal input into the buffer if any arrives).
4274
4275 If WAIT_PROC is specified, wait until something arrives from that
4276 process. The return value is true if we read some input from
4277 that process.
4278
4279 If JUST_WAIT_PROC is non-nil, handle only output from WAIT_PROC
4280 (suspending output from other processes). A negative value
4281 means don't run any timers either.
4282
4283 If WAIT_PROC is specified, then the function returns true if we
4284 received input from that process before the timeout elapsed.
4285 Otherwise, return true if we received input from any process. */
4286
4287 int
4288 wait_reading_process_output (int time_limit, int microsecs, int read_kbd,
4289 int do_display,
4290 Lisp_Object wait_for_cell,
4291 struct Lisp_Process *wait_proc, int just_wait_proc)
4292 {
4293 register int channel, nfds;
4294 SELECT_TYPE Available;
4295 SELECT_TYPE Writeok;
4296 int check_write;
4297 int check_delay, no_avail;
4298 int xerrno;
4299 Lisp_Object proc;
4300 EMACS_TIME timeout, end_time;
4301 int wait_channel = -1;
4302 int got_some_input = 0;
4303 ptrdiff_t count = SPECPDL_INDEX ();
4304
4305 FD_ZERO (&Available);
4306 FD_ZERO (&Writeok);
4307
4308 if (time_limit == 0 && microsecs == 0 && wait_proc && !NILP (Vinhibit_quit)
4309 && !(CONSP (wait_proc->status) && EQ (XCAR (wait_proc->status), Qexit)))
4310 message ("Blocking call to accept-process-output with quit inhibited!!");
4311
4312 /* If wait_proc is a process to watch, set wait_channel accordingly. */
4313 if (wait_proc != NULL)
4314 wait_channel = wait_proc->infd;
4315
4316 record_unwind_protect (wait_reading_process_output_unwind,
4317 make_number (waiting_for_user_input_p));
4318 waiting_for_user_input_p = read_kbd;
4319
4320 /* Since we may need to wait several times,
4321 compute the absolute time to return at. */
4322 if (time_limit || microsecs)
4323 {
4324 EMACS_GET_TIME (end_time);
4325 EMACS_SET_SECS_USECS (timeout, time_limit, microsecs);
4326 EMACS_ADD_TIME (end_time, end_time, timeout);
4327 }
4328
4329 while (1)
4330 {
4331 int timeout_reduced_for_timers = 0;
4332
4333 /* If calling from keyboard input, do not quit
4334 since we want to return C-g as an input character.
4335 Otherwise, do pending quit if requested. */
4336 if (read_kbd >= 0)
4337 QUIT;
4338 #ifdef SYNC_INPUT
4339 else
4340 process_pending_signals ();
4341 #endif
4342
4343 /* Exit now if the cell we're waiting for became non-nil. */
4344 if (! NILP (wait_for_cell) && ! NILP (XCAR (wait_for_cell)))
4345 break;
4346
4347 /* Compute time from now till when time limit is up */
4348 /* Exit if already run out */
4349 if (time_limit == -1)
4350 {
4351 /* -1 specified for timeout means
4352 gobble output available now
4353 but don't wait at all. */
4354
4355 EMACS_SET_SECS_USECS (timeout, 0, 0);
4356 }
4357 else if (time_limit || microsecs)
4358 {
4359 EMACS_GET_TIME (timeout);
4360 EMACS_SUB_TIME (timeout, end_time, timeout);
4361 if (EMACS_TIME_NEG_P (timeout))
4362 break;
4363 }
4364 else
4365 {
4366 EMACS_SET_SECS_USECS (timeout, 100000, 0);
4367 }
4368
4369 /* Normally we run timers here.
4370 But not if wait_for_cell; in those cases,
4371 the wait is supposed to be short,
4372 and those callers cannot handle running arbitrary Lisp code here. */
4373 if (NILP (wait_for_cell)
4374 && just_wait_proc >= 0)
4375 {
4376 EMACS_TIME timer_delay;
4377
4378 do
4379 {
4380 int old_timers_run = timers_run;
4381 struct buffer *old_buffer = current_buffer;
4382 Lisp_Object old_window = selected_window;
4383
4384 timer_delay = timer_check ();
4385
4386 /* If a timer has run, this might have changed buffers
4387 an alike. Make read_key_sequence aware of that. */
4388 if (timers_run != old_timers_run
4389 && (old_buffer != current_buffer
4390 || !EQ (old_window, selected_window))
4391 && waiting_for_user_input_p == -1)
4392 record_asynch_buffer_change ();
4393
4394 if (timers_run != old_timers_run && do_display)
4395 /* We must retry, since a timer may have requeued itself
4396 and that could alter the time_delay. */
4397 redisplay_preserve_echo_area (9);
4398 else
4399 break;
4400 }
4401 while (!detect_input_pending ());
4402
4403 /* If there is unread keyboard input, also return. */
4404 if (read_kbd != 0
4405 && requeued_events_pending_p ())
4406 break;
4407
4408 if (! EMACS_TIME_NEG_P (timer_delay) && time_limit != -1)
4409 {
4410 EMACS_TIME difference;
4411 EMACS_SUB_TIME (difference, timer_delay, timeout);
4412 if (EMACS_TIME_NEG_P (difference))
4413 {
4414 timeout = timer_delay;
4415 timeout_reduced_for_timers = 1;
4416 }
4417 }
4418 /* If time_limit is -1, we are not going to wait at all. */
4419 else if (time_limit != -1)
4420 {
4421 /* This is so a breakpoint can be put here. */
4422 wait_reading_process_output_1 ();
4423 }
4424 }
4425
4426 /* Cause C-g and alarm signals to take immediate action,
4427 and cause input available signals to zero out timeout.
4428
4429 It is important that we do this before checking for process
4430 activity. If we get a SIGCHLD after the explicit checks for
4431 process activity, timeout is the only way we will know. */
4432 if (read_kbd < 0)
4433 set_waiting_for_input (&timeout);
4434
4435 /* If status of something has changed, and no input is
4436 available, notify the user of the change right away. After
4437 this explicit check, we'll let the SIGCHLD handler zap
4438 timeout to get our attention. */
4439 if (update_tick != process_tick)
4440 {
4441 SELECT_TYPE Atemp;
4442 SELECT_TYPE Ctemp;
4443
4444 if (kbd_on_hold_p ())
4445 FD_ZERO (&Atemp);
4446 else
4447 Atemp = input_wait_mask;
4448 Ctemp = write_mask;
4449
4450 EMACS_SET_SECS_USECS (timeout, 0, 0);
4451 if ((select (max (max_process_desc, max_input_desc) + 1,
4452 &Atemp,
4453 #ifdef NON_BLOCKING_CONNECT
4454 (num_pending_connects > 0 ? &Ctemp : (SELECT_TYPE *)0),
4455 #else
4456 (SELECT_TYPE *)0,
4457 #endif
4458 (SELECT_TYPE *)0, &timeout)
4459 <= 0))
4460 {
4461 /* It's okay for us to do this and then continue with
4462 the loop, since timeout has already been zeroed out. */
4463 clear_waiting_for_input ();
4464 status_notify (NULL);
4465 if (do_display) redisplay_preserve_echo_area (13);
4466 }
4467 }
4468
4469 /* Don't wait for output from a non-running process. Just
4470 read whatever data has already been received. */
4471 if (wait_proc && wait_proc->raw_status_new)
4472 update_status (wait_proc);
4473 if (wait_proc
4474 && ! EQ (wait_proc->status, Qrun)
4475 && ! EQ (wait_proc->status, Qconnect))
4476 {
4477 int nread, total_nread = 0;
4478
4479 clear_waiting_for_input ();
4480 XSETPROCESS (proc, wait_proc);
4481
4482 /* Read data from the process, until we exhaust it. */
4483 while (wait_proc->infd >= 0)
4484 {
4485 nread = read_process_output (proc, wait_proc->infd);
4486
4487 if (nread == 0)
4488 break;
4489
4490 if (0 < nread)
4491 {
4492 total_nread += nread;
4493 got_some_input = 1;
4494 }
4495 #ifdef EIO
4496 else if (nread == -1 && EIO == errno)
4497 break;
4498 #endif
4499 #ifdef EAGAIN
4500 else if (nread == -1 && EAGAIN == errno)
4501 break;
4502 #endif
4503 #ifdef EWOULDBLOCK
4504 else if (nread == -1 && EWOULDBLOCK == errno)
4505 break;
4506 #endif
4507 }
4508 if (total_nread > 0 && do_display)
4509 redisplay_preserve_echo_area (10);
4510
4511 break;
4512 }
4513
4514 /* Wait till there is something to do */
4515
4516 if (wait_proc && just_wait_proc)
4517 {
4518 if (wait_proc->infd < 0) /* Terminated */
4519 break;
4520 FD_SET (wait_proc->infd, &Available);
4521 check_delay = 0;
4522 check_write = 0;
4523 }
4524 else if (!NILP (wait_for_cell))
4525 {
4526 Available = non_process_wait_mask;
4527 check_delay = 0;
4528 check_write = 0;
4529 }
4530 else
4531 {
4532 if (! read_kbd)
4533 Available = non_keyboard_wait_mask;
4534 else
4535 Available = input_wait_mask;
4536 Writeok = write_mask;
4537 #ifdef SELECT_CANT_DO_WRITE_MASK
4538 check_write = 0;
4539 #else
4540 check_write = 1;
4541 #endif
4542 check_delay = wait_channel >= 0 ? 0 : process_output_delay_count;
4543 }
4544
4545 /* If frame size has changed or the window is newly mapped,
4546 redisplay now, before we start to wait. There is a race
4547 condition here; if a SIGIO arrives between now and the select
4548 and indicates that a frame is trashed, the select may block
4549 displaying a trashed screen. */
4550 if (frame_garbaged && do_display)
4551 {
4552 clear_waiting_for_input ();
4553 redisplay_preserve_echo_area (11);
4554 if (read_kbd < 0)
4555 set_waiting_for_input (&timeout);
4556 }
4557
4558 /* Skip the `select' call if input is available and we're
4559 waiting for keyboard input or a cell change (which can be
4560 triggered by processing X events). In the latter case, set
4561 nfds to 1 to avoid breaking the loop. */
4562 no_avail = 0;
4563 if ((read_kbd || !NILP (wait_for_cell))
4564 && detect_input_pending ())
4565 {
4566 nfds = read_kbd ? 0 : 1;
4567 no_avail = 1;
4568 }
4569
4570 if (!no_avail)
4571 {
4572
4573 #ifdef ADAPTIVE_READ_BUFFERING
4574 /* Set the timeout for adaptive read buffering if any
4575 process has non-zero read_output_skip and non-zero
4576 read_output_delay, and we are not reading output for a
4577 specific wait_channel. It is not executed if
4578 Vprocess_adaptive_read_buffering is nil. */
4579 if (process_output_skip && check_delay > 0)
4580 {
4581 int usecs = EMACS_USECS (timeout);
4582 if (EMACS_SECS (timeout) > 0 || usecs > READ_OUTPUT_DELAY_MAX)
4583 usecs = READ_OUTPUT_DELAY_MAX;
4584 for (channel = 0; check_delay > 0 && channel <= max_process_desc; channel++)
4585 {
4586 proc = chan_process[channel];
4587 if (NILP (proc))
4588 continue;
4589 /* Find minimum non-zero read_output_delay among the
4590 processes with non-zero read_output_skip. */
4591 if (XPROCESS (proc)->read_output_delay > 0)
4592 {
4593 check_delay--;
4594 if (!XPROCESS (proc)->read_output_skip)
4595 continue;
4596 FD_CLR (channel, &Available);
4597 XPROCESS (proc)->read_output_skip = 0;
4598 if (XPROCESS (proc)->read_output_delay < usecs)
4599 usecs = XPROCESS (proc)->read_output_delay;
4600 }
4601 }
4602 EMACS_SET_SECS_USECS (timeout, 0, usecs);
4603 process_output_skip = 0;
4604 }
4605 #endif
4606 #if defined (USE_GTK) || defined (HAVE_GCONF) || defined (HAVE_GSETTINGS)
4607 nfds = xg_select
4608 #elif defined (HAVE_NS)
4609 nfds = ns_select
4610 #else
4611 nfds = select
4612 #endif
4613 (max (max_process_desc, max_input_desc) + 1,
4614 &Available,
4615 (check_write ? &Writeok : (SELECT_TYPE *)0),
4616 (SELECT_TYPE *)0, &timeout);
4617
4618 #ifdef HAVE_GNUTLS
4619 /* GnuTLS buffers data internally. In lowat mode it leaves
4620 some data in the TCP buffers so that select works, but
4621 with custom pull/push functions we need to check if some
4622 data is available in the buffers manually. */
4623 if (nfds == 0)
4624 {
4625 if (! wait_proc)
4626 {
4627 /* We're not waiting on a specific process, so loop
4628 through all the channels and check for data.
4629 This is a workaround needed for some versions of
4630 the gnutls library -- 2.12.14 has been confirmed
4631 to need it. See
4632 http://comments.gmane.org/gmane.emacs.devel/145074 */
4633 for (channel = 0; channel < MAXDESC; ++channel)
4634 if (! NILP (chan_process[channel]))
4635 {
4636 struct Lisp_Process *p =
4637 XPROCESS (chan_process[channel]);
4638 if (p && p->gnutls_p && p->infd
4639 && ((emacs_gnutls_record_check_pending
4640 (p->gnutls_state))
4641 > 0))
4642 {
4643 nfds++;
4644 FD_SET (p->infd, &Available);
4645 }
4646 }
4647 }
4648 else
4649 {
4650 /* Check this specific channel. */
4651 if (wait_proc->gnutls_p /* Check for valid process. */
4652 /* Do we have pending data? */
4653 && ((emacs_gnutls_record_check_pending
4654 (wait_proc->gnutls_state))
4655 > 0))
4656 {
4657 nfds = 1;
4658 /* Set to Available. */
4659 FD_SET (wait_proc->infd, &Available);
4660 }
4661 }
4662 }
4663 #endif
4664 }
4665
4666 xerrno = errno;
4667
4668 /* Make C-g and alarm signals set flags again */
4669 clear_waiting_for_input ();
4670
4671 /* If we woke up due to SIGWINCH, actually change size now. */
4672 do_pending_window_change (0);
4673
4674 if (time_limit && nfds == 0 && ! timeout_reduced_for_timers)
4675 /* We wanted the full specified time, so return now. */
4676 break;
4677 if (nfds < 0)
4678 {
4679 if (xerrno == EINTR)
4680 no_avail = 1;
4681 else if (xerrno == EBADF)
4682 {
4683 #ifdef AIX
4684 /* AIX doesn't handle PTY closure the same way BSD does. On AIX,
4685 the child's closure of the pts gives the parent a SIGHUP, and
4686 the ptc file descriptor is automatically closed,
4687 yielding EBADF here or at select() call above.
4688 So, SIGHUP is ignored (see def of PTY_TTY_NAME_SPRINTF
4689 in m/ibmrt-aix.h), and here we just ignore the select error.
4690 Cleanup occurs c/o status_notify after SIGCLD. */
4691 no_avail = 1; /* Cannot depend on values returned */
4692 #else
4693 abort ();
4694 #endif
4695 }
4696 else
4697 error ("select error: %s", emacs_strerror (xerrno));
4698 }
4699
4700 if (no_avail)
4701 {
4702 FD_ZERO (&Available);
4703 check_write = 0;
4704 }
4705
4706 #if 0 /* When polling is used, interrupt_input is 0,
4707 so get_input_pending should read the input.
4708 So this should not be needed. */
4709 /* If we are using polling for input,
4710 and we see input available, make it get read now.
4711 Otherwise it might not actually get read for a second.
4712 And on hpux, since we turn off polling in wait_reading_process_output,
4713 it might never get read at all if we don't spend much time
4714 outside of wait_reading_process_output. */
4715 if (read_kbd && interrupt_input
4716 && keyboard_bit_set (&Available)
4717 && input_polling_used ())
4718 kill (getpid (), SIGALRM);
4719 #endif
4720
4721 /* Check for keyboard input */
4722 /* If there is any, return immediately
4723 to give it higher priority than subprocesses */
4724
4725 if (read_kbd != 0)
4726 {
4727 int old_timers_run = timers_run;
4728 struct buffer *old_buffer = current_buffer;
4729 Lisp_Object old_window = selected_window;
4730 int leave = 0;
4731
4732 if (detect_input_pending_run_timers (do_display))
4733 {
4734 swallow_events (do_display);
4735 if (detect_input_pending_run_timers (do_display))
4736 leave = 1;
4737 }
4738
4739 /* If a timer has run, this might have changed buffers
4740 an alike. Make read_key_sequence aware of that. */
4741 if (timers_run != old_timers_run
4742 && waiting_for_user_input_p == -1
4743 && (old_buffer != current_buffer
4744 || !EQ (old_window, selected_window)))
4745 record_asynch_buffer_change ();
4746
4747 if (leave)
4748 break;
4749 }
4750
4751 /* If there is unread keyboard input, also return. */
4752 if (read_kbd != 0
4753 && requeued_events_pending_p ())
4754 break;
4755
4756 /* If we are not checking for keyboard input now,
4757 do process events (but don't run any timers).
4758 This is so that X events will be processed.
4759 Otherwise they may have to wait until polling takes place.
4760 That would causes delays in pasting selections, for example.
4761
4762 (We used to do this only if wait_for_cell.) */
4763 if (read_kbd == 0 && detect_input_pending ())
4764 {
4765 swallow_events (do_display);
4766 #if 0 /* Exiting when read_kbd doesn't request that seems wrong, though. */
4767 if (detect_input_pending ())
4768 break;
4769 #endif
4770 }
4771
4772 /* Exit now if the cell we're waiting for became non-nil. */
4773 if (! NILP (wait_for_cell) && ! NILP (XCAR (wait_for_cell)))
4774 break;
4775
4776 #ifdef SIGIO
4777 /* If we think we have keyboard input waiting, but didn't get SIGIO,
4778 go read it. This can happen with X on BSD after logging out.
4779 In that case, there really is no input and no SIGIO,
4780 but select says there is input. */
4781
4782 if (read_kbd && interrupt_input
4783 && keyboard_bit_set (&Available) && ! noninteractive)
4784 kill (getpid (), SIGIO);
4785 #endif
4786
4787 if (! wait_proc)
4788 got_some_input |= nfds > 0;
4789
4790 /* If checking input just got us a size-change event from X,
4791 obey it now if we should. */
4792 if (read_kbd || ! NILP (wait_for_cell))
4793 do_pending_window_change (0);
4794
4795 /* Check for data from a process. */
4796 if (no_avail || nfds == 0)
4797 continue;
4798
4799 for (channel = 0; channel <= max_input_desc; ++channel)
4800 {
4801 struct fd_callback_data *d = &fd_callback_info[channel];
4802 if (FD_ISSET (channel, &Available)
4803 && d->func != 0
4804 && (d->condition & FOR_READ) != 0)
4805 d->func (channel, d->data, 1);
4806 if (FD_ISSET (channel, &write_mask)
4807 && d->func != 0
4808 && (d->condition & FOR_WRITE) != 0)
4809 d->func (channel, d->data, 0);
4810 }
4811
4812 for (channel = 0; channel <= max_process_desc; channel++)
4813 {
4814 if (FD_ISSET (channel, &Available)
4815 && FD_ISSET (channel, &non_keyboard_wait_mask)
4816 && !FD_ISSET (channel, &non_process_wait_mask))
4817 {
4818 int nread;
4819
4820 /* If waiting for this channel, arrange to return as
4821 soon as no more input to be processed. No more
4822 waiting. */
4823 if (wait_channel == channel)
4824 {
4825 wait_channel = -1;
4826 time_limit = -1;
4827 got_some_input = 1;
4828 }
4829 proc = chan_process[channel];
4830 if (NILP (proc))
4831 continue;
4832
4833 /* If this is a server stream socket, accept connection. */
4834 if (EQ (XPROCESS (proc)->status, Qlisten))
4835 {
4836 server_accept_connection (proc, channel);
4837 continue;
4838 }
4839
4840 /* Read data from the process, starting with our
4841 buffered-ahead character if we have one. */
4842
4843 nread = read_process_output (proc, channel);
4844 if (nread > 0)
4845 {
4846 /* Since read_process_output can run a filter,
4847 which can call accept-process-output,
4848 don't try to read from any other processes
4849 before doing the select again. */
4850 FD_ZERO (&Available);
4851
4852 if (do_display)
4853 redisplay_preserve_echo_area (12);
4854 }
4855 #ifdef EWOULDBLOCK
4856 else if (nread == -1 && errno == EWOULDBLOCK)
4857 ;
4858 #endif
4859 /* ISC 4.1 defines both EWOULDBLOCK and O_NONBLOCK,
4860 and Emacs uses O_NONBLOCK, so what we get is EAGAIN. */
4861 #ifdef O_NONBLOCK
4862 else if (nread == -1 && errno == EAGAIN)
4863 ;
4864 #else
4865 #ifdef O_NDELAY
4866 else if (nread == -1 && errno == EAGAIN)
4867 ;
4868 /* Note that we cannot distinguish between no input
4869 available now and a closed pipe.
4870 With luck, a closed pipe will be accompanied by
4871 subprocess termination and SIGCHLD. */
4872 else if (nread == 0 && !NETCONN_P (proc) && !SERIALCONN_P (proc))
4873 ;
4874 #endif /* O_NDELAY */
4875 #endif /* O_NONBLOCK */
4876 #ifdef HAVE_PTYS
4877 /* On some OSs with ptys, when the process on one end of
4878 a pty exits, the other end gets an error reading with
4879 errno = EIO instead of getting an EOF (0 bytes read).
4880 Therefore, if we get an error reading and errno =
4881 EIO, just continue, because the child process has
4882 exited and should clean itself up soon (e.g. when we
4883 get a SIGCHLD).
4884
4885 However, it has been known to happen that the SIGCHLD
4886 got lost. So raise the signal again just in case.
4887 It can't hurt. */
4888 else if (nread == -1 && errno == EIO)
4889 {
4890 struct Lisp_Process *p = XPROCESS (proc);
4891
4892 /* Clear the descriptor now, so we only raise the
4893 signal once. */
4894 FD_CLR (channel, &input_wait_mask);
4895 FD_CLR (channel, &non_keyboard_wait_mask);
4896
4897 if (p->pid == -2)
4898 {
4899 /* If the EIO occurs on a pty, sigchld_handler's
4900 wait3() will not find the process object to
4901 delete. Do it here. */
4902 p->tick = ++process_tick;
4903 p->status = Qfailed;
4904 }
4905 else
4906 kill (getpid (), SIGCHLD);
4907 }
4908 #endif /* HAVE_PTYS */
4909 /* If we can detect process termination, don't consider the
4910 process gone just because its pipe is closed. */
4911 #ifdef SIGCHLD
4912 else if (nread == 0 && !NETCONN_P (proc) && !SERIALCONN_P (proc))
4913 ;
4914 #endif
4915 else
4916 {
4917 /* Preserve status of processes already terminated. */
4918 XPROCESS (proc)->tick = ++process_tick;
4919 deactivate_process (proc);
4920 if (XPROCESS (proc)->raw_status_new)
4921 update_status (XPROCESS (proc));
4922 if (EQ (XPROCESS (proc)->status, Qrun))
4923 XPROCESS (proc)->status
4924 = Fcons (Qexit, Fcons (make_number (256), Qnil));
4925 }
4926 }
4927 #ifdef NON_BLOCKING_CONNECT
4928 if (FD_ISSET (channel, &Writeok)
4929 && FD_ISSET (channel, &connect_wait_mask))
4930 {
4931 struct Lisp_Process *p;
4932
4933 FD_CLR (channel, &connect_wait_mask);
4934 FD_CLR (channel, &write_mask);
4935 if (--num_pending_connects < 0)
4936 abort ();
4937
4938 proc = chan_process[channel];
4939 if (NILP (proc))
4940 continue;
4941
4942 p = XPROCESS (proc);
4943
4944 #ifdef GNU_LINUX
4945 /* getsockopt(,,SO_ERROR,,) is said to hang on some systems.
4946 So only use it on systems where it is known to work. */
4947 {
4948 socklen_t xlen = sizeof (xerrno);
4949 if (getsockopt (channel, SOL_SOCKET, SO_ERROR, &xerrno, &xlen))
4950 xerrno = errno;
4951 }
4952 #else
4953 {
4954 struct sockaddr pname;
4955 int pnamelen = sizeof (pname);
4956
4957 /* If connection failed, getpeername will fail. */
4958 xerrno = 0;
4959 if (getpeername (channel, &pname, &pnamelen) < 0)
4960 {
4961 /* Obtain connect failure code through error slippage. */
4962 char dummy;
4963 xerrno = errno;
4964 if (errno == ENOTCONN && read (channel, &dummy, 1) < 0)
4965 xerrno = errno;
4966 }
4967 }
4968 #endif
4969 if (xerrno)
4970 {
4971 p->tick = ++process_tick;
4972 p->status = Fcons (Qfailed, Fcons (make_number (xerrno), Qnil));
4973 deactivate_process (proc);
4974 }
4975 else
4976 {
4977 p->status = Qrun;
4978 /* Execute the sentinel here. If we had relied on
4979 status_notify to do it later, it will read input
4980 from the process before calling the sentinel. */
4981 exec_sentinel (proc, build_string ("open\n"));
4982 if (!EQ (p->filter, Qt) && !EQ (p->command, Qt))
4983 {
4984 FD_SET (p->infd, &input_wait_mask);
4985 FD_SET (p->infd, &non_keyboard_wait_mask);
4986 }
4987 }
4988 }
4989 #endif /* NON_BLOCKING_CONNECT */
4990 } /* end for each file descriptor */
4991 } /* end while exit conditions not met */
4992
4993 unbind_to (count, Qnil);
4994
4995 /* If calling from keyboard input, do not quit
4996 since we want to return C-g as an input character.
4997 Otherwise, do pending quit if requested. */
4998 if (read_kbd >= 0)
4999 {
5000 /* Prevent input_pending from remaining set if we quit. */
5001 clear_input_pending ();
5002 QUIT;
5003 }
5004
5005 return got_some_input;
5006 }
5007 \f
5008 /* Given a list (FUNCTION ARGS...), apply FUNCTION to the ARGS. */
5009
5010 static Lisp_Object
5011 read_process_output_call (Lisp_Object fun_and_args)
5012 {
5013 return apply1 (XCAR (fun_and_args), XCDR (fun_and_args));
5014 }
5015
5016 static Lisp_Object
5017 read_process_output_error_handler (Lisp_Object error_val)
5018 {
5019 cmd_error_internal (error_val, "error in process filter: ");
5020 Vinhibit_quit = Qt;
5021 update_echo_area ();
5022 Fsleep_for (make_number (2), Qnil);
5023 return Qt;
5024 }
5025
5026 /* Read pending output from the process channel,
5027 starting with our buffered-ahead character if we have one.
5028 Yield number of decoded characters read.
5029
5030 This function reads at most 4096 characters.
5031 If you want to read all available subprocess output,
5032 you must call it repeatedly until it returns zero.
5033
5034 The characters read are decoded according to PROC's coding-system
5035 for decoding. */
5036
5037 static int
5038 read_process_output (Lisp_Object proc, register int channel)
5039 {
5040 register ssize_t nbytes;
5041 char *chars;
5042 register Lisp_Object outstream;
5043 register struct Lisp_Process *p = XPROCESS (proc);
5044 register ptrdiff_t opoint;
5045 struct coding_system *coding = proc_decode_coding_system[channel];
5046 int carryover = p->decoding_carryover;
5047 int readmax = 4096;
5048 ptrdiff_t count = SPECPDL_INDEX ();
5049 Lisp_Object odeactivate;
5050
5051 chars = (char *) alloca (carryover + readmax);
5052 if (carryover)
5053 /* See the comment above. */
5054 memcpy (chars, SDATA (p->decoding_buf), carryover);
5055
5056 #ifdef DATAGRAM_SOCKETS
5057 /* We have a working select, so proc_buffered_char is always -1. */
5058 if (DATAGRAM_CHAN_P (channel))
5059 {
5060 socklen_t len = datagram_address[channel].len;
5061 nbytes = recvfrom (channel, chars + carryover, readmax,
5062 0, datagram_address[channel].sa, &len);
5063 }
5064 else
5065 #endif
5066 {
5067 int buffered = 0 <= proc_buffered_char[channel];
5068 if (buffered)
5069 {
5070 chars[carryover] = proc_buffered_char[channel];
5071 proc_buffered_char[channel] = -1;
5072 }
5073 #ifdef HAVE_GNUTLS
5074 if (p->gnutls_p)
5075 nbytes = emacs_gnutls_read (p, chars + carryover + buffered,
5076 readmax - buffered);
5077 else
5078 #endif
5079 nbytes = emacs_read (channel, chars + carryover + buffered,
5080 readmax - buffered);
5081 #ifdef ADAPTIVE_READ_BUFFERING
5082 if (nbytes > 0 && p->adaptive_read_buffering)
5083 {
5084 int delay = p->read_output_delay;
5085 if (nbytes < 256)
5086 {
5087 if (delay < READ_OUTPUT_DELAY_MAX_MAX)
5088 {
5089 if (delay == 0)
5090 process_output_delay_count++;
5091 delay += READ_OUTPUT_DELAY_INCREMENT * 2;
5092 }
5093 }
5094 else if (delay > 0 && nbytes == readmax - buffered)
5095 {
5096 delay -= READ_OUTPUT_DELAY_INCREMENT;
5097 if (delay == 0)
5098 process_output_delay_count--;
5099 }
5100 p->read_output_delay = delay;
5101 if (delay)
5102 {
5103 p->read_output_skip = 1;
5104 process_output_skip = 1;
5105 }
5106 }
5107 #endif
5108 nbytes += buffered;
5109 nbytes += buffered && nbytes <= 0;
5110 }
5111
5112 p->decoding_carryover = 0;
5113
5114 /* At this point, NBYTES holds number of bytes just received
5115 (including the one in proc_buffered_char[channel]). */
5116 if (nbytes <= 0)
5117 {
5118 if (nbytes < 0 || coding->mode & CODING_MODE_LAST_BLOCK)
5119 return nbytes;
5120 coding->mode |= CODING_MODE_LAST_BLOCK;
5121 }
5122
5123 /* Now set NBYTES how many bytes we must decode. */
5124 nbytes += carryover;
5125
5126 odeactivate = Vdeactivate_mark;
5127 /* There's no good reason to let process filters change the current
5128 buffer, and many callers of accept-process-output, sit-for, and
5129 friends don't expect current-buffer to be changed from under them. */
5130 record_unwind_protect (set_buffer_if_live, Fcurrent_buffer ());
5131
5132 /* Read and dispose of the process output. */
5133 outstream = p->filter;
5134 if (!NILP (outstream))
5135 {
5136 Lisp_Object text;
5137 int outer_running_asynch_code = running_asynch_code;
5138 int waiting = waiting_for_user_input_p;
5139
5140 /* No need to gcpro these, because all we do with them later
5141 is test them for EQness, and none of them should be a string. */
5142 #if 0
5143 Lisp_Object obuffer, okeymap;
5144 XSETBUFFER (obuffer, current_buffer);
5145 okeymap = BVAR (current_buffer, keymap);
5146 #endif
5147
5148 /* We inhibit quit here instead of just catching it so that
5149 hitting ^G when a filter happens to be running won't screw
5150 it up. */
5151 specbind (Qinhibit_quit, Qt);
5152 specbind (Qlast_nonmenu_event, Qt);
5153
5154 /* In case we get recursively called,
5155 and we already saved the match data nonrecursively,
5156 save the same match data in safely recursive fashion. */
5157 if (outer_running_asynch_code)
5158 {
5159 Lisp_Object tem;
5160 /* Don't clobber the CURRENT match data, either! */
5161 tem = Fmatch_data (Qnil, Qnil, Qnil);
5162 restore_search_regs ();
5163 record_unwind_save_match_data ();
5164 Fset_match_data (tem, Qt);
5165 }
5166
5167 /* For speed, if a search happens within this code,
5168 save the match data in a special nonrecursive fashion. */
5169 running_asynch_code = 1;
5170
5171 decode_coding_c_string (coding, (unsigned char *) chars, nbytes, Qt);
5172 text = coding->dst_object;
5173 Vlast_coding_system_used = CODING_ID_NAME (coding->id);
5174 /* A new coding system might be found. */
5175 if (!EQ (p->decode_coding_system, Vlast_coding_system_used))
5176 {
5177 p->decode_coding_system = Vlast_coding_system_used;
5178
5179 /* Don't call setup_coding_system for
5180 proc_decode_coding_system[channel] here. It is done in
5181 detect_coding called via decode_coding above. */
5182
5183 /* If a coding system for encoding is not yet decided, we set
5184 it as the same as coding-system for decoding.
5185
5186 But, before doing that we must check if
5187 proc_encode_coding_system[p->outfd] surely points to a
5188 valid memory because p->outfd will be changed once EOF is
5189 sent to the process. */
5190 if (NILP (p->encode_coding_system)
5191 && proc_encode_coding_system[p->outfd])
5192 {
5193 p->encode_coding_system
5194 = coding_inherit_eol_type (Vlast_coding_system_used, Qnil);
5195 setup_coding_system (p->encode_coding_system,
5196 proc_encode_coding_system[p->outfd]);
5197 }
5198 }
5199
5200 if (coding->carryover_bytes > 0)
5201 {
5202 if (SCHARS (p->decoding_buf) < coding->carryover_bytes)
5203 p->decoding_buf = make_uninit_string (coding->carryover_bytes);
5204 memcpy (SDATA (p->decoding_buf), coding->carryover,
5205 coding->carryover_bytes);
5206 p->decoding_carryover = coding->carryover_bytes;
5207 }
5208 if (SBYTES (text) > 0)
5209 /* FIXME: It's wrong to wrap or not based on debug-on-error, and
5210 sometimes it's simply wrong to wrap (e.g. when called from
5211 accept-process-output). */
5212 internal_condition_case_1 (read_process_output_call,
5213 Fcons (outstream,
5214 Fcons (proc, Fcons (text, Qnil))),
5215 !NILP (Vdebug_on_error) ? Qnil : Qerror,
5216 read_process_output_error_handler);
5217
5218 /* If we saved the match data nonrecursively, restore it now. */
5219 restore_search_regs ();
5220 running_asynch_code = outer_running_asynch_code;
5221
5222 /* Restore waiting_for_user_input_p as it was
5223 when we were called, in case the filter clobbered it. */
5224 waiting_for_user_input_p = waiting;
5225
5226 #if 0 /* Call record_asynch_buffer_change unconditionally,
5227 because we might have changed minor modes or other things
5228 that affect key bindings. */
5229 if (! EQ (Fcurrent_buffer (), obuffer)
5230 || ! EQ (current_buffer->keymap, okeymap))
5231 #endif
5232 /* But do it only if the caller is actually going to read events.
5233 Otherwise there's no need to make him wake up, and it could
5234 cause trouble (for example it would make sit_for return). */
5235 if (waiting_for_user_input_p == -1)
5236 record_asynch_buffer_change ();
5237 }
5238
5239 /* If no filter, write into buffer if it isn't dead. */
5240 else if (!NILP (p->buffer) && !NILP (BVAR (XBUFFER (p->buffer), name)))
5241 {
5242 Lisp_Object old_read_only;
5243 ptrdiff_t old_begv, old_zv;
5244 ptrdiff_t old_begv_byte, old_zv_byte;
5245 ptrdiff_t before, before_byte;
5246 ptrdiff_t opoint_byte;
5247 Lisp_Object text;
5248 struct buffer *b;
5249
5250 Fset_buffer (p->buffer);
5251 opoint = PT;
5252 opoint_byte = PT_BYTE;
5253 old_read_only = BVAR (current_buffer, read_only);
5254 old_begv = BEGV;
5255 old_zv = ZV;
5256 old_begv_byte = BEGV_BYTE;
5257 old_zv_byte = ZV_BYTE;
5258
5259 BVAR (current_buffer, read_only) = Qnil;
5260
5261 /* Insert new output into buffer
5262 at the current end-of-output marker,
5263 thus preserving logical ordering of input and output. */
5264 if (XMARKER (p->mark)->buffer)
5265 SET_PT_BOTH (clip_to_bounds (BEGV, marker_position (p->mark), ZV),
5266 clip_to_bounds (BEGV_BYTE, marker_byte_position (p->mark),
5267 ZV_BYTE));
5268 else
5269 SET_PT_BOTH (ZV, ZV_BYTE);
5270 before = PT;
5271 before_byte = PT_BYTE;
5272
5273 /* If the output marker is outside of the visible region, save
5274 the restriction and widen. */
5275 if (! (BEGV <= PT && PT <= ZV))
5276 Fwiden ();
5277
5278 decode_coding_c_string (coding, (unsigned char *) chars, nbytes, Qt);
5279 text = coding->dst_object;
5280 Vlast_coding_system_used = CODING_ID_NAME (coding->id);
5281 /* A new coding system might be found. See the comment in the
5282 similar code in the previous `if' block. */
5283 if (!EQ (p->decode_coding_system, Vlast_coding_system_used))
5284 {
5285 p->decode_coding_system = Vlast_coding_system_used;
5286 if (NILP (p->encode_coding_system)
5287 && proc_encode_coding_system[p->outfd])
5288 {
5289 p->encode_coding_system
5290 = coding_inherit_eol_type (Vlast_coding_system_used, Qnil);
5291 setup_coding_system (p->encode_coding_system,
5292 proc_encode_coding_system[p->outfd]);
5293 }
5294 }
5295 if (coding->carryover_bytes > 0)
5296 {
5297 if (SCHARS (p->decoding_buf) < coding->carryover_bytes)
5298 p->decoding_buf = make_uninit_string (coding->carryover_bytes);
5299 memcpy (SDATA (p->decoding_buf), coding->carryover,
5300 coding->carryover_bytes);
5301 p->decoding_carryover = coding->carryover_bytes;
5302 }
5303 /* Adjust the multibyteness of TEXT to that of the buffer. */
5304 if (NILP (BVAR (current_buffer, enable_multibyte_characters))
5305 != ! STRING_MULTIBYTE (text))
5306 text = (STRING_MULTIBYTE (text)
5307 ? Fstring_as_unibyte (text)
5308 : Fstring_to_multibyte (text));
5309 /* Insert before markers in case we are inserting where
5310 the buffer's mark is, and the user's next command is Meta-y. */
5311 insert_from_string_before_markers (text, 0, 0,
5312 SCHARS (text), SBYTES (text), 0);
5313
5314 /* Make sure the process marker's position is valid when the
5315 process buffer is changed in the signal_after_change above.
5316 W3 is known to do that. */
5317 if (BUFFERP (p->buffer)
5318 && (b = XBUFFER (p->buffer), b != current_buffer))
5319 set_marker_both (p->mark, p->buffer, BUF_PT (b), BUF_PT_BYTE (b));
5320 else
5321 set_marker_both (p->mark, p->buffer, PT, PT_BYTE);
5322
5323 update_mode_lines++;
5324
5325 /* Make sure opoint and the old restrictions
5326 float ahead of any new text just as point would. */
5327 if (opoint >= before)
5328 {
5329 opoint += PT - before;
5330 opoint_byte += PT_BYTE - before_byte;
5331 }
5332 if (old_begv > before)
5333 {
5334 old_begv += PT - before;
5335 old_begv_byte += PT_BYTE - before_byte;
5336 }
5337 if (old_zv >= before)
5338 {
5339 old_zv += PT - before;
5340 old_zv_byte += PT_BYTE - before_byte;
5341 }
5342
5343 /* If the restriction isn't what it should be, set it. */
5344 if (old_begv != BEGV || old_zv != ZV)
5345 Fnarrow_to_region (make_number (old_begv), make_number (old_zv));
5346
5347
5348 BVAR (current_buffer, read_only) = old_read_only;
5349 SET_PT_BOTH (opoint, opoint_byte);
5350 }
5351 /* Handling the process output should not deactivate the mark. */
5352 Vdeactivate_mark = odeactivate;
5353
5354 unbind_to (count, Qnil);
5355 return nbytes;
5356 }
5357 \f
5358 /* Sending data to subprocess */
5359
5360 static jmp_buf send_process_frame;
5361 static Lisp_Object process_sent_to;
5362
5363 #ifndef FORWARD_SIGNAL_TO_MAIN_THREAD
5364 static void send_process_trap (int) NO_RETURN;
5365 #endif
5366
5367 static void
5368 send_process_trap (int ignore)
5369 {
5370 SIGNAL_THREAD_CHECK (SIGPIPE);
5371 sigunblock (sigmask (SIGPIPE));
5372 longjmp (send_process_frame, 1);
5373 }
5374
5375 /* In send_process, when a write fails temporarily,
5376 wait_reading_process_output is called. It may execute user code,
5377 e.g. timers, that attempts to write new data to the same process.
5378 We must ensure that data is sent in the right order, and not
5379 interspersed half-completed with other writes (Bug#10815). This is
5380 handled by the write_queue element of struct process. It is a list
5381 with each entry having the form
5382
5383 (string . (offset . length))
5384
5385 where STRING is a lisp string, OFFSET is the offset into the
5386 string's byte sequence from which we should begin to send, and
5387 LENGTH is the number of bytes left to send. */
5388
5389 /* Create a new entry in write_queue.
5390 INPUT_OBJ should be a buffer, string Qt, or Qnil.
5391 BUF is a pointer to the string sequence of the input_obj or a C
5392 string in case of Qt or Qnil. */
5393
5394 static void
5395 write_queue_push (struct Lisp_Process *p, Lisp_Object input_obj,
5396 const char *buf, ptrdiff_t len, int front)
5397 {
5398 ptrdiff_t offset;
5399 Lisp_Object entry, obj;
5400
5401 if (STRINGP (input_obj))
5402 {
5403 offset = buf - SSDATA (input_obj);
5404 obj = input_obj;
5405 }
5406 else
5407 {
5408 offset = 0;
5409 obj = make_unibyte_string (buf, len);
5410 }
5411
5412 entry = Fcons (obj, Fcons (make_number (offset), make_number (len)));
5413
5414 if (front)
5415 p->write_queue = Fcons (entry, p->write_queue);
5416 else
5417 p->write_queue = nconc2 (p->write_queue, Fcons (entry, Qnil));
5418 }
5419
5420 /* Remove the first element in the write_queue of process P, put its
5421 contents in OBJ, BUF and LEN, and return non-zero. If the
5422 write_queue is empty, return zero. */
5423
5424 static int
5425 write_queue_pop (struct Lisp_Process *p, Lisp_Object *obj,
5426 const char **buf, ptrdiff_t *len)
5427 {
5428 Lisp_Object entry, offset_length;
5429 ptrdiff_t offset;
5430
5431 if (NILP (p->write_queue))
5432 return 0;
5433
5434 entry = XCAR (p->write_queue);
5435 p->write_queue = XCDR (p->write_queue);
5436
5437 *obj = XCAR (entry);
5438 offset_length = XCDR (entry);
5439
5440 *len = XINT (XCDR (offset_length));
5441 offset = XINT (XCAR (offset_length));
5442 *buf = SSDATA (*obj) + offset;
5443
5444 return 1;
5445 }
5446
5447 /* Send some data to process PROC.
5448 BUF is the beginning of the data; LEN is the number of characters.
5449 OBJECT is the Lisp object that the data comes from. If OBJECT is
5450 nil or t, it means that the data comes from C string.
5451
5452 If OBJECT is not nil, the data is encoded by PROC's coding-system
5453 for encoding before it is sent.
5454
5455 This function can evaluate Lisp code and can garbage collect. */
5456
5457 static void
5458 send_process (volatile Lisp_Object proc, const char *volatile buf,
5459 volatile ptrdiff_t len, volatile Lisp_Object object)
5460 {
5461 /* Use volatile to protect variables from being clobbered by longjmp. */
5462 struct Lisp_Process *p = XPROCESS (proc);
5463 ssize_t rv;
5464 struct coding_system *coding;
5465 void (*volatile old_sigpipe) (int);
5466
5467 if (p->raw_status_new)
5468 update_status (p);
5469 if (! EQ (p->status, Qrun))
5470 error ("Process %s not running", SDATA (p->name));
5471 if (p->outfd < 0)
5472 error ("Output file descriptor of %s is closed", SDATA (p->name));
5473
5474 coding = proc_encode_coding_system[p->outfd];
5475 Vlast_coding_system_used = CODING_ID_NAME (coding->id);
5476
5477 if ((STRINGP (object) && STRING_MULTIBYTE (object))
5478 || (BUFFERP (object)
5479 && !NILP (BVAR (XBUFFER (object), enable_multibyte_characters)))
5480 || EQ (object, Qt))
5481 {
5482 p->encode_coding_system
5483 = complement_process_encoding_system (p->encode_coding_system);
5484 if (!EQ (Vlast_coding_system_used, p->encode_coding_system))
5485 {
5486 /* The coding system for encoding was changed to raw-text
5487 because we sent a unibyte text previously. Now we are
5488 sending a multibyte text, thus we must encode it by the
5489 original coding system specified for the current process.
5490
5491 Another reason we come here is that the coding system
5492 was just complemented and a new one was returned by
5493 complement_process_encoding_system. */
5494 setup_coding_system (p->encode_coding_system, coding);
5495 Vlast_coding_system_used = p->encode_coding_system;
5496 }
5497 coding->src_multibyte = 1;
5498 }
5499 else
5500 {
5501 coding->src_multibyte = 0;
5502 /* For sending a unibyte text, character code conversion should
5503 not take place but EOL conversion should. So, setup raw-text
5504 or one of the subsidiary if we have not yet done it. */
5505 if (CODING_REQUIRE_ENCODING (coding))
5506 {
5507 if (CODING_REQUIRE_FLUSHING (coding))
5508 {
5509 /* But, before changing the coding, we must flush out data. */
5510 coding->mode |= CODING_MODE_LAST_BLOCK;
5511 send_process (proc, "", 0, Qt);
5512 coding->mode &= CODING_MODE_LAST_BLOCK;
5513 }
5514 setup_coding_system (raw_text_coding_system
5515 (Vlast_coding_system_used),
5516 coding);
5517 coding->src_multibyte = 0;
5518 }
5519 }
5520 coding->dst_multibyte = 0;
5521
5522 if (CODING_REQUIRE_ENCODING (coding))
5523 {
5524 coding->dst_object = Qt;
5525 if (BUFFERP (object))
5526 {
5527 ptrdiff_t from_byte, from, to;
5528 ptrdiff_t save_pt, save_pt_byte;
5529 struct buffer *cur = current_buffer;
5530
5531 set_buffer_internal (XBUFFER (object));
5532 save_pt = PT, save_pt_byte = PT_BYTE;
5533
5534 from_byte = PTR_BYTE_POS ((unsigned char *) buf);
5535 from = BYTE_TO_CHAR (from_byte);
5536 to = BYTE_TO_CHAR (from_byte + len);
5537 TEMP_SET_PT_BOTH (from, from_byte);
5538 encode_coding_object (coding, object, from, from_byte,
5539 to, from_byte + len, Qt);
5540 TEMP_SET_PT_BOTH (save_pt, save_pt_byte);
5541 set_buffer_internal (cur);
5542 }
5543 else if (STRINGP (object))
5544 {
5545 encode_coding_object (coding, object, 0, 0, SCHARS (object),
5546 SBYTES (object), Qt);
5547 }
5548 else
5549 {
5550 coding->dst_object = make_unibyte_string (buf, len);
5551 coding->produced = len;
5552 }
5553
5554 len = coding->produced;
5555 object = coding->dst_object;
5556 buf = SSDATA (object);
5557 }
5558
5559 if (pty_max_bytes == 0)
5560 {
5561 #if defined (HAVE_FPATHCONF) && defined (_PC_MAX_CANON)
5562 pty_max_bytes = fpathconf (p->outfd, _PC_MAX_CANON);
5563 if (pty_max_bytes < 0)
5564 pty_max_bytes = 250;
5565 #else
5566 pty_max_bytes = 250;
5567 #endif
5568 /* Deduct one, to leave space for the eof. */
5569 pty_max_bytes--;
5570 }
5571
5572 /* 2000-09-21: Emacs 20.7, sparc-sun-solaris-2.6, GCC 2.95.2,
5573 CFLAGS="-g -O": The value of the parameter `proc' is clobbered
5574 when returning with longjmp despite being declared volatile. */
5575 if (!setjmp (send_process_frame))
5576 {
5577 p = XPROCESS (proc); /* Repair any setjmp clobbering. */
5578 process_sent_to = proc;
5579
5580 /* If there is already data in the write_queue, put the new data
5581 in the back of queue. Otherwise, ignore it. */
5582 if (!NILP (p->write_queue))
5583 write_queue_push (p, object, buf, len, 0);
5584
5585 do /* while !NILP (p->write_queue) */
5586 {
5587 ptrdiff_t cur_len = -1;
5588 const char *cur_buf;
5589 Lisp_Object cur_object;
5590
5591 /* If write_queue is empty, ignore it. */
5592 if (!write_queue_pop (p, &cur_object, &cur_buf, &cur_len))
5593 {
5594 cur_len = len;
5595 cur_buf = buf;
5596 cur_object = object;
5597 }
5598
5599 while (cur_len > 0)
5600 {
5601 /* Send this batch, using one or more write calls. */
5602 ptrdiff_t written = 0;
5603 int outfd = p->outfd;
5604 old_sigpipe = (void (*) (int)) signal (SIGPIPE, send_process_trap);
5605 #ifdef DATAGRAM_SOCKETS
5606 if (DATAGRAM_CHAN_P (outfd))
5607 {
5608 rv = sendto (outfd, cur_buf, cur_len,
5609 0, datagram_address[outfd].sa,
5610 datagram_address[outfd].len);
5611 if (0 <= rv)
5612 written = rv;
5613 else if (errno == EMSGSIZE)
5614 {
5615 signal (SIGPIPE, old_sigpipe);
5616 report_file_error ("sending datagram",
5617 Fcons (proc, Qnil));
5618 }
5619 }
5620 else
5621 #endif
5622 {
5623 #ifdef HAVE_GNUTLS
5624 if (p->gnutls_p)
5625 written = emacs_gnutls_write (p, cur_buf, cur_len);
5626 else
5627 #endif
5628 written = emacs_write (outfd, cur_buf, cur_len);
5629 rv = (written ? 0 : -1);
5630 #ifdef ADAPTIVE_READ_BUFFERING
5631 if (p->read_output_delay > 0
5632 && p->adaptive_read_buffering == 1)
5633 {
5634 p->read_output_delay = 0;
5635 process_output_delay_count--;
5636 p->read_output_skip = 0;
5637 }
5638 #endif
5639 }
5640 signal (SIGPIPE, old_sigpipe);
5641
5642 if (rv < 0)
5643 {
5644 if (0
5645 #ifdef EWOULDBLOCK
5646 || errno == EWOULDBLOCK
5647 #endif
5648 #ifdef EAGAIN
5649 || errno == EAGAIN
5650 #endif
5651 )
5652 /* Buffer is full. Wait, accepting input;
5653 that may allow the program
5654 to finish doing output and read more. */
5655 {
5656 #ifdef BROKEN_PTY_READ_AFTER_EAGAIN
5657 /* A gross hack to work around a bug in FreeBSD.
5658 In the following sequence, read(2) returns
5659 bogus data:
5660
5661 write(2) 1022 bytes
5662 write(2) 954 bytes, get EAGAIN
5663 read(2) 1024 bytes in process_read_output
5664 read(2) 11 bytes in process_read_output
5665
5666 That is, read(2) returns more bytes than have
5667 ever been written successfully. The 1033 bytes
5668 read are the 1022 bytes written successfully
5669 after processing (for example with CRs added if
5670 the terminal is set up that way which it is
5671 here). The same bytes will be seen again in a
5672 later read(2), without the CRs. */
5673
5674 if (errno == EAGAIN)
5675 {
5676 int flags = FWRITE;
5677 ioctl (p->outfd, TIOCFLUSH, &flags);
5678 }
5679 #endif /* BROKEN_PTY_READ_AFTER_EAGAIN */
5680
5681 /* Put what we should have written in wait_queue. */
5682 write_queue_push (p, cur_object, cur_buf, cur_len, 1);
5683 #ifdef EMACS_HAS_USECS
5684 wait_reading_process_output (0, 20000, 0, 0, Qnil, NULL, 0);
5685 #else
5686 wait_reading_process_output (1, 0, 0, 0, Qnil, NULL, 0);
5687 #endif
5688 /* Reread queue, to see what is left. */
5689 break;
5690 }
5691 else
5692 /* This is a real error. */
5693 report_file_error ("writing to process", Fcons (proc, Qnil));
5694 }
5695 cur_buf += written;
5696 cur_len -= written;
5697 }
5698 }
5699 while (!NILP (p->write_queue));
5700 }
5701 else
5702 {
5703 signal (SIGPIPE, old_sigpipe);
5704 proc = process_sent_to;
5705 p = XPROCESS (proc);
5706 p->raw_status_new = 0;
5707 p->status = Fcons (Qexit, Fcons (make_number (256), Qnil));
5708 p->tick = ++process_tick;
5709 deactivate_process (proc);
5710 error ("SIGPIPE raised on process %s; closed it", SDATA (p->name));
5711 }
5712 }
5713
5714 DEFUN ("process-send-region", Fprocess_send_region, Sprocess_send_region,
5715 3, 3, 0,
5716 doc: /* Send current contents of region as input to PROCESS.
5717 PROCESS may be a process, a buffer, the name of a process or buffer, or
5718 nil, indicating the current buffer's process.
5719 Called from program, takes three arguments, PROCESS, START and END.
5720 If the region is more than 500 characters long,
5721 it is sent in several bunches. This may happen even for shorter regions.
5722 Output from processes can arrive in between bunches. */)
5723 (Lisp_Object process, Lisp_Object start, Lisp_Object end)
5724 {
5725 Lisp_Object proc;
5726 ptrdiff_t start1, end1;
5727
5728 proc = get_process (process);
5729 validate_region (&start, &end);
5730
5731 if (XINT (start) < GPT && XINT (end) > GPT)
5732 move_gap (XINT (start));
5733
5734 start1 = CHAR_TO_BYTE (XINT (start));
5735 end1 = CHAR_TO_BYTE (XINT (end));
5736 send_process (proc, (char *) BYTE_POS_ADDR (start1), end1 - start1,
5737 Fcurrent_buffer ());
5738
5739 return Qnil;
5740 }
5741
5742 DEFUN ("process-send-string", Fprocess_send_string, Sprocess_send_string,
5743 2, 2, 0,
5744 doc: /* Send PROCESS the contents of STRING as input.
5745 PROCESS may be a process, a buffer, the name of a process or buffer, or
5746 nil, indicating the current buffer's process.
5747 If STRING is more than 500 characters long,
5748 it is sent in several bunches. This may happen even for shorter strings.
5749 Output from processes can arrive in between bunches. */)
5750 (Lisp_Object process, Lisp_Object string)
5751 {
5752 Lisp_Object proc;
5753 CHECK_STRING (string);
5754 proc = get_process (process);
5755 send_process (proc, SSDATA (string),
5756 SBYTES (string), string);
5757 return Qnil;
5758 }
5759 \f
5760 /* Return the foreground process group for the tty/pty that
5761 the process P uses. */
5762 static pid_t
5763 emacs_get_tty_pgrp (struct Lisp_Process *p)
5764 {
5765 pid_t gid = -1;
5766
5767 #ifdef TIOCGPGRP
5768 if (ioctl (p->infd, TIOCGPGRP, &gid) == -1 && ! NILP (p->tty_name))
5769 {
5770 int fd;
5771 /* Some OS:es (Solaris 8/9) does not allow TIOCGPGRP from the
5772 master side. Try the slave side. */
5773 fd = emacs_open (SSDATA (p->tty_name), O_RDONLY, 0);
5774
5775 if (fd != -1)
5776 {
5777 ioctl (fd, TIOCGPGRP, &gid);
5778 emacs_close (fd);
5779 }
5780 }
5781 #endif /* defined (TIOCGPGRP ) */
5782
5783 return gid;
5784 }
5785
5786 DEFUN ("process-running-child-p", Fprocess_running_child_p,
5787 Sprocess_running_child_p, 0, 1, 0,
5788 doc: /* Return t if PROCESS has given the terminal to a child.
5789 If the operating system does not make it possible to find out,
5790 return t unconditionally. */)
5791 (Lisp_Object process)
5792 {
5793 /* Initialize in case ioctl doesn't exist or gives an error,
5794 in a way that will cause returning t. */
5795 pid_t gid;
5796 Lisp_Object proc;
5797 struct Lisp_Process *p;
5798
5799 proc = get_process (process);
5800 p = XPROCESS (proc);
5801
5802 if (!EQ (p->type, Qreal))
5803 error ("Process %s is not a subprocess",
5804 SDATA (p->name));
5805 if (p->infd < 0)
5806 error ("Process %s is not active",
5807 SDATA (p->name));
5808
5809 gid = emacs_get_tty_pgrp (p);
5810
5811 if (gid == p->pid)
5812 return Qnil;
5813 return Qt;
5814 }
5815 \f
5816 /* send a signal number SIGNO to PROCESS.
5817 If CURRENT_GROUP is t, that means send to the process group
5818 that currently owns the terminal being used to communicate with PROCESS.
5819 This is used for various commands in shell mode.
5820 If CURRENT_GROUP is lambda, that means send to the process group
5821 that currently owns the terminal, but only if it is NOT the shell itself.
5822
5823 If NOMSG is zero, insert signal-announcements into process's buffers
5824 right away.
5825
5826 If we can, we try to signal PROCESS by sending control characters
5827 down the pty. This allows us to signal inferiors who have changed
5828 their uid, for which killpg would return an EPERM error. */
5829
5830 static void
5831 process_send_signal (Lisp_Object process, int signo, Lisp_Object current_group,
5832 int nomsg)
5833 {
5834 Lisp_Object proc;
5835 register struct Lisp_Process *p;
5836 pid_t gid;
5837 int no_pgrp = 0;
5838
5839 proc = get_process (process);
5840 p = XPROCESS (proc);
5841
5842 if (!EQ (p->type, Qreal))
5843 error ("Process %s is not a subprocess",
5844 SDATA (p->name));
5845 if (p->infd < 0)
5846 error ("Process %s is not active",
5847 SDATA (p->name));
5848
5849 if (!p->pty_flag)
5850 current_group = Qnil;
5851
5852 /* If we are using pgrps, get a pgrp number and make it negative. */
5853 if (NILP (current_group))
5854 /* Send the signal to the shell's process group. */
5855 gid = p->pid;
5856 else
5857 {
5858 #ifdef SIGNALS_VIA_CHARACTERS
5859 /* If possible, send signals to the entire pgrp
5860 by sending an input character to it. */
5861
5862 struct termios t;
5863 cc_t *sig_char = NULL;
5864
5865 tcgetattr (p->infd, &t);
5866
5867 switch (signo)
5868 {
5869 case SIGINT:
5870 sig_char = &t.c_cc[VINTR];
5871 break;
5872
5873 case SIGQUIT:
5874 sig_char = &t.c_cc[VQUIT];
5875 break;
5876
5877 case SIGTSTP:
5878 #if defined (VSWTCH) && !defined (PREFER_VSUSP)
5879 sig_char = &t.c_cc[VSWTCH];
5880 #else
5881 sig_char = &t.c_cc[VSUSP];
5882 #endif
5883 break;
5884 }
5885
5886 if (sig_char && *sig_char != CDISABLE)
5887 {
5888 send_process (proc, (char *) sig_char, 1, Qnil);
5889 return;
5890 }
5891 /* If we can't send the signal with a character,
5892 fall through and send it another way. */
5893
5894 /* The code above may fall through if it can't
5895 handle the signal. */
5896 #endif /* defined (SIGNALS_VIA_CHARACTERS) */
5897
5898 #ifdef TIOCGPGRP
5899 /* Get the current pgrp using the tty itself, if we have that.
5900 Otherwise, use the pty to get the pgrp.
5901 On pfa systems, saka@pfu.fujitsu.co.JP writes:
5902 "TIOCGPGRP symbol defined in sys/ioctl.h at E50.
5903 But, TIOCGPGRP does not work on E50 ;-P works fine on E60"
5904 His patch indicates that if TIOCGPGRP returns an error, then
5905 we should just assume that p->pid is also the process group id. */
5906
5907 gid = emacs_get_tty_pgrp (p);
5908
5909 if (gid == -1)
5910 /* If we can't get the information, assume
5911 the shell owns the tty. */
5912 gid = p->pid;
5913
5914 /* It is not clear whether anything really can set GID to -1.
5915 Perhaps on some system one of those ioctls can or could do so.
5916 Or perhaps this is vestigial. */
5917 if (gid == -1)
5918 no_pgrp = 1;
5919 #else /* ! defined (TIOCGPGRP ) */
5920 /* Can't select pgrps on this system, so we know that
5921 the child itself heads the pgrp. */
5922 gid = p->pid;
5923 #endif /* ! defined (TIOCGPGRP ) */
5924
5925 /* If current_group is lambda, and the shell owns the terminal,
5926 don't send any signal. */
5927 if (EQ (current_group, Qlambda) && gid == p->pid)
5928 return;
5929 }
5930
5931 switch (signo)
5932 {
5933 #ifdef SIGCONT
5934 case SIGCONT:
5935 p->raw_status_new = 0;
5936 p->status = Qrun;
5937 p->tick = ++process_tick;
5938 if (!nomsg)
5939 {
5940 status_notify (NULL);
5941 redisplay_preserve_echo_area (13);
5942 }
5943 break;
5944 #endif /* ! defined (SIGCONT) */
5945 case SIGINT:
5946 case SIGQUIT:
5947 case SIGKILL:
5948 flush_pending_output (p->infd);
5949 break;
5950 }
5951
5952 /* If we don't have process groups, send the signal to the immediate
5953 subprocess. That isn't really right, but it's better than any
5954 obvious alternative. */
5955 if (no_pgrp)
5956 {
5957 kill (p->pid, signo);
5958 return;
5959 }
5960
5961 /* gid may be a pid, or minus a pgrp's number */
5962 #ifdef TIOCSIGSEND
5963 if (!NILP (current_group))
5964 {
5965 if (ioctl (p->infd, TIOCSIGSEND, signo) == -1)
5966 EMACS_KILLPG (gid, signo);
5967 }
5968 else
5969 {
5970 gid = - p->pid;
5971 kill (gid, signo);
5972 }
5973 #else /* ! defined (TIOCSIGSEND) */
5974 EMACS_KILLPG (gid, signo);
5975 #endif /* ! defined (TIOCSIGSEND) */
5976 }
5977
5978 DEFUN ("interrupt-process", Finterrupt_process, Sinterrupt_process, 0, 2, 0,
5979 doc: /* Interrupt process PROCESS.
5980 PROCESS may be a process, a buffer, or the name of a process or buffer.
5981 No arg or nil means current buffer's process.
5982 Second arg CURRENT-GROUP non-nil means send signal to
5983 the current process-group of the process's controlling terminal
5984 rather than to the process's own process group.
5985 If the process is a shell, this means interrupt current subjob
5986 rather than the shell.
5987
5988 If CURRENT-GROUP is `lambda', and if the shell owns the terminal,
5989 don't send the signal. */)
5990 (Lisp_Object process, Lisp_Object current_group)
5991 {
5992 process_send_signal (process, SIGINT, current_group, 0);
5993 return process;
5994 }
5995
5996 DEFUN ("kill-process", Fkill_process, Skill_process, 0, 2, 0,
5997 doc: /* Kill process PROCESS. May be process or name of one.
5998 See function `interrupt-process' for more details on usage. */)
5999 (Lisp_Object process, Lisp_Object current_group)
6000 {
6001 process_send_signal (process, SIGKILL, current_group, 0);
6002 return process;
6003 }
6004
6005 DEFUN ("quit-process", Fquit_process, Squit_process, 0, 2, 0,
6006 doc: /* Send QUIT signal to process PROCESS. May be process or name of one.
6007 See function `interrupt-process' for more details on usage. */)
6008 (Lisp_Object process, Lisp_Object current_group)
6009 {
6010 process_send_signal (process, SIGQUIT, current_group, 0);
6011 return process;
6012 }
6013
6014 DEFUN ("stop-process", Fstop_process, Sstop_process, 0, 2, 0,
6015 doc: /* Stop process PROCESS. May be process or name of one.
6016 See function `interrupt-process' for more details on usage.
6017 If PROCESS is a network or serial process, inhibit handling of incoming
6018 traffic. */)
6019 (Lisp_Object process, Lisp_Object current_group)
6020 {
6021 if (PROCESSP (process) && (NETCONN_P (process) || SERIALCONN_P (process)))
6022 {
6023 struct Lisp_Process *p;
6024
6025 p = XPROCESS (process);
6026 if (NILP (p->command)
6027 && p->infd >= 0)
6028 {
6029 FD_CLR (p->infd, &input_wait_mask);
6030 FD_CLR (p->infd, &non_keyboard_wait_mask);
6031 }
6032 p->command = Qt;
6033 return process;
6034 }
6035 #ifndef SIGTSTP
6036 error ("No SIGTSTP support");
6037 #else
6038 process_send_signal (process, SIGTSTP, current_group, 0);
6039 #endif
6040 return process;
6041 }
6042
6043 DEFUN ("continue-process", Fcontinue_process, Scontinue_process, 0, 2, 0,
6044 doc: /* Continue process PROCESS. May be process or name of one.
6045 See function `interrupt-process' for more details on usage.
6046 If PROCESS is a network or serial process, resume handling of incoming
6047 traffic. */)
6048 (Lisp_Object process, Lisp_Object current_group)
6049 {
6050 if (PROCESSP (process) && (NETCONN_P (process) || SERIALCONN_P (process)))
6051 {
6052 struct Lisp_Process *p;
6053
6054 p = XPROCESS (process);
6055 if (EQ (p->command, Qt)
6056 && p->infd >= 0
6057 && (!EQ (p->filter, Qt) || EQ (p->status, Qlisten)))
6058 {
6059 FD_SET (p->infd, &input_wait_mask);
6060 FD_SET (p->infd, &non_keyboard_wait_mask);
6061 #ifdef WINDOWSNT
6062 if (fd_info[ p->infd ].flags & FILE_SERIAL)
6063 PurgeComm (fd_info[ p->infd ].hnd, PURGE_RXABORT | PURGE_RXCLEAR);
6064 #else /* not WINDOWSNT */
6065 tcflush (p->infd, TCIFLUSH);
6066 #endif /* not WINDOWSNT */
6067 }
6068 p->command = Qnil;
6069 return process;
6070 }
6071 #ifdef SIGCONT
6072 process_send_signal (process, SIGCONT, current_group, 0);
6073 #else
6074 error ("No SIGCONT support");
6075 #endif
6076 return process;
6077 }
6078
6079 DEFUN ("signal-process", Fsignal_process, Ssignal_process,
6080 2, 2, "sProcess (name or number): \nnSignal code: ",
6081 doc: /* Send PROCESS the signal with code SIGCODE.
6082 PROCESS may also be a number specifying the process id of the
6083 process to signal; in this case, the process need not be a child of
6084 this Emacs.
6085 SIGCODE may be an integer, or a symbol whose name is a signal name. */)
6086 (Lisp_Object process, Lisp_Object sigcode)
6087 {
6088 pid_t pid;
6089
6090 if (STRINGP (process))
6091 {
6092 Lisp_Object tem = Fget_process (process);
6093 if (NILP (tem))
6094 {
6095 Lisp_Object process_number =
6096 string_to_number (SSDATA (process), 10, 1);
6097 if (INTEGERP (process_number) || FLOATP (process_number))
6098 tem = process_number;
6099 }
6100 process = tem;
6101 }
6102 else if (!NUMBERP (process))
6103 process = get_process (process);
6104
6105 if (NILP (process))
6106 return process;
6107
6108 if (NUMBERP (process))
6109 CONS_TO_INTEGER (process, pid_t, pid);
6110 else
6111 {
6112 CHECK_PROCESS (process);
6113 pid = XPROCESS (process)->pid;
6114 if (pid <= 0)
6115 error ("Cannot signal process %s", SDATA (XPROCESS (process)->name));
6116 }
6117
6118 #define parse_signal(NAME, VALUE) \
6119 else if (!xstrcasecmp (name, NAME)) \
6120 XSETINT (sigcode, VALUE)
6121
6122 if (INTEGERP (sigcode))
6123 CHECK_TYPE_RANGED_INTEGER (int, sigcode);
6124 else
6125 {
6126 char *name;
6127
6128 CHECK_SYMBOL (sigcode);
6129 name = SSDATA (SYMBOL_NAME (sigcode));
6130
6131 if (!strncmp (name, "SIG", 3) || !strncmp (name, "sig", 3))
6132 name += 3;
6133
6134 if (0)
6135 ;
6136 #ifdef SIGUSR1
6137 parse_signal ("usr1", SIGUSR1);
6138 #endif
6139 #ifdef SIGUSR2
6140 parse_signal ("usr2", SIGUSR2);
6141 #endif
6142 #ifdef SIGTERM
6143 parse_signal ("term", SIGTERM);
6144 #endif
6145 #ifdef SIGHUP
6146 parse_signal ("hup", SIGHUP);
6147 #endif
6148 #ifdef SIGINT
6149 parse_signal ("int", SIGINT);
6150 #endif
6151 #ifdef SIGQUIT
6152 parse_signal ("quit", SIGQUIT);
6153 #endif
6154 #ifdef SIGILL
6155 parse_signal ("ill", SIGILL);
6156 #endif
6157 #ifdef SIGABRT
6158 parse_signal ("abrt", SIGABRT);
6159 #endif
6160 #ifdef SIGEMT
6161 parse_signal ("emt", SIGEMT);
6162 #endif
6163 #ifdef SIGKILL
6164 parse_signal ("kill", SIGKILL);
6165 #endif
6166 #ifdef SIGFPE
6167 parse_signal ("fpe", SIGFPE);
6168 #endif
6169 #ifdef SIGBUS
6170 parse_signal ("bus", SIGBUS);
6171 #endif
6172 #ifdef SIGSEGV
6173 parse_signal ("segv", SIGSEGV);
6174 #endif
6175 #ifdef SIGSYS
6176 parse_signal ("sys", SIGSYS);
6177 #endif
6178 #ifdef SIGPIPE
6179 parse_signal ("pipe", SIGPIPE);
6180 #endif
6181 #ifdef SIGALRM
6182 parse_signal ("alrm", SIGALRM);
6183 #endif
6184 #ifdef SIGURG
6185 parse_signal ("urg", SIGURG);
6186 #endif
6187 #ifdef SIGSTOP
6188 parse_signal ("stop", SIGSTOP);
6189 #endif
6190 #ifdef SIGTSTP
6191 parse_signal ("tstp", SIGTSTP);
6192 #endif
6193 #ifdef SIGCONT
6194 parse_signal ("cont", SIGCONT);
6195 #endif
6196 #ifdef SIGCHLD
6197 parse_signal ("chld", SIGCHLD);
6198 #endif
6199 #ifdef SIGTTIN
6200 parse_signal ("ttin", SIGTTIN);
6201 #endif
6202 #ifdef SIGTTOU
6203 parse_signal ("ttou", SIGTTOU);
6204 #endif
6205 #ifdef SIGIO
6206 parse_signal ("io", SIGIO);
6207 #endif
6208 #ifdef SIGXCPU
6209 parse_signal ("xcpu", SIGXCPU);
6210 #endif
6211 #ifdef SIGXFSZ
6212 parse_signal ("xfsz", SIGXFSZ);
6213 #endif
6214 #ifdef SIGVTALRM
6215 parse_signal ("vtalrm", SIGVTALRM);
6216 #endif
6217 #ifdef SIGPROF
6218 parse_signal ("prof", SIGPROF);
6219 #endif
6220 #ifdef SIGWINCH
6221 parse_signal ("winch", SIGWINCH);
6222 #endif
6223 #ifdef SIGINFO
6224 parse_signal ("info", SIGINFO);
6225 #endif
6226 else
6227 error ("Undefined signal name %s", name);
6228 }
6229
6230 #undef parse_signal
6231
6232 return make_number (kill (pid, XINT (sigcode)));
6233 }
6234
6235 DEFUN ("process-send-eof", Fprocess_send_eof, Sprocess_send_eof, 0, 1, 0,
6236 doc: /* Make PROCESS see end-of-file in its input.
6237 EOF comes after any text already sent to it.
6238 PROCESS may be a process, a buffer, the name of a process or buffer, or
6239 nil, indicating the current buffer's process.
6240 If PROCESS is a network connection, or is a process communicating
6241 through a pipe (as opposed to a pty), then you cannot send any more
6242 text to PROCESS after you call this function.
6243 If PROCESS is a serial process, wait until all output written to the
6244 process has been transmitted to the serial port. */)
6245 (Lisp_Object process)
6246 {
6247 Lisp_Object proc;
6248 struct coding_system *coding;
6249
6250 if (DATAGRAM_CONN_P (process))
6251 return process;
6252
6253 proc = get_process (process);
6254 coding = proc_encode_coding_system[XPROCESS (proc)->outfd];
6255
6256 /* Make sure the process is really alive. */
6257 if (XPROCESS (proc)->raw_status_new)
6258 update_status (XPROCESS (proc));
6259 if (! EQ (XPROCESS (proc)->status, Qrun))
6260 error ("Process %s not running", SDATA (XPROCESS (proc)->name));
6261
6262 if (CODING_REQUIRE_FLUSHING (coding))
6263 {
6264 coding->mode |= CODING_MODE_LAST_BLOCK;
6265 send_process (proc, "", 0, Qnil);
6266 }
6267
6268 if (XPROCESS (proc)->pty_flag)
6269 send_process (proc, "\004", 1, Qnil);
6270 else if (EQ (XPROCESS (proc)->type, Qserial))
6271 {
6272 #ifndef WINDOWSNT
6273 if (tcdrain (XPROCESS (proc)->outfd) != 0)
6274 error ("tcdrain() failed: %s", emacs_strerror (errno));
6275 #endif /* not WINDOWSNT */
6276 /* Do nothing on Windows because writes are blocking. */
6277 }
6278 else
6279 {
6280 int old_outfd, new_outfd;
6281
6282 #ifdef HAVE_SHUTDOWN
6283 /* If this is a network connection, or socketpair is used
6284 for communication with the subprocess, call shutdown to cause EOF.
6285 (In some old system, shutdown to socketpair doesn't work.
6286 Then we just can't win.) */
6287 if (EQ (XPROCESS (proc)->type, Qnetwork)
6288 || XPROCESS (proc)->outfd == XPROCESS (proc)->infd)
6289 shutdown (XPROCESS (proc)->outfd, 1);
6290 /* In case of socketpair, outfd == infd, so don't close it. */
6291 if (XPROCESS (proc)->outfd != XPROCESS (proc)->infd)
6292 emacs_close (XPROCESS (proc)->outfd);
6293 #else /* not HAVE_SHUTDOWN */
6294 emacs_close (XPROCESS (proc)->outfd);
6295 #endif /* not HAVE_SHUTDOWN */
6296 new_outfd = emacs_open (NULL_DEVICE, O_WRONLY, 0);
6297 if (new_outfd < 0)
6298 abort ();
6299 old_outfd = XPROCESS (proc)->outfd;
6300
6301 if (!proc_encode_coding_system[new_outfd])
6302 proc_encode_coding_system[new_outfd]
6303 = (struct coding_system *) xmalloc (sizeof (struct coding_system));
6304 memcpy (proc_encode_coding_system[new_outfd],
6305 proc_encode_coding_system[old_outfd],
6306 sizeof (struct coding_system));
6307 memset (proc_encode_coding_system[old_outfd], 0,
6308 sizeof (struct coding_system));
6309
6310 XPROCESS (proc)->outfd = new_outfd;
6311 }
6312 return process;
6313 }
6314 \f
6315 /* On receipt of a signal that a child status has changed, loop asking
6316 about children with changed statuses until the system says there
6317 are no more.
6318
6319 All we do is change the status; we do not run sentinels or print
6320 notifications. That is saved for the next time keyboard input is
6321 done, in order to avoid timing errors.
6322
6323 ** WARNING: this can be called during garbage collection.
6324 Therefore, it must not be fooled by the presence of mark bits in
6325 Lisp objects.
6326
6327 ** USG WARNING: Although it is not obvious from the documentation
6328 in signal(2), on a USG system the SIGCLD handler MUST NOT call
6329 signal() before executing at least one wait(), otherwise the
6330 handler will be called again, resulting in an infinite loop. The
6331 relevant portion of the documentation reads "SIGCLD signals will be
6332 queued and the signal-catching function will be continually
6333 reentered until the queue is empty". Invoking signal() causes the
6334 kernel to reexamine the SIGCLD queue. Fred Fish, UniSoft Systems
6335 Inc.
6336
6337 ** Malloc WARNING: This should never call malloc either directly or
6338 indirectly; if it does, that is a bug */
6339
6340 #ifdef SIGCHLD
6341 static void
6342 sigchld_handler (int signo)
6343 {
6344 int old_errno = errno;
6345 Lisp_Object proc;
6346 struct Lisp_Process *p;
6347
6348 SIGNAL_THREAD_CHECK (signo);
6349
6350 while (1)
6351 {
6352 pid_t pid;
6353 int w;
6354 Lisp_Object tail;
6355
6356 #ifdef WNOHANG
6357 #ifndef WUNTRACED
6358 #define WUNTRACED 0
6359 #endif /* no WUNTRACED */
6360 /* Keep trying to get a status until we get a definitive result. */
6361 do
6362 {
6363 errno = 0;
6364 pid = wait3 (&w, WNOHANG | WUNTRACED, 0);
6365 }
6366 while (pid < 0 && errno == EINTR);
6367
6368 if (pid <= 0)
6369 {
6370 /* PID == 0 means no processes found, PID == -1 means a real
6371 failure. We have done all our job, so return. */
6372
6373 errno = old_errno;
6374 return;
6375 }
6376 #else
6377 pid = wait (&w);
6378 #endif /* no WNOHANG */
6379
6380 /* Find the process that signaled us, and record its status. */
6381
6382 /* The process can have been deleted by Fdelete_process. */
6383 for (tail = deleted_pid_list; CONSP (tail); tail = XCDR (tail))
6384 {
6385 Lisp_Object xpid = XCAR (tail);
6386 if ((INTEGERP (xpid) && pid == XINT (xpid))
6387 || (FLOATP (xpid) && pid == XFLOAT_DATA (xpid)))
6388 {
6389 XSETCAR (tail, Qnil);
6390 goto sigchld_end_of_loop;
6391 }
6392 }
6393
6394 /* Otherwise, if it is asynchronous, it is in Vprocess_alist. */
6395 p = 0;
6396 for (tail = Vprocess_alist; CONSP (tail); tail = XCDR (tail))
6397 {
6398 proc = XCDR (XCAR (tail));
6399 p = XPROCESS (proc);
6400 if (EQ (p->type, Qreal) && p->pid == pid)
6401 break;
6402 p = 0;
6403 }
6404
6405 /* Look for an asynchronous process whose pid hasn't been filled
6406 in yet. */
6407 if (p == 0)
6408 for (tail = Vprocess_alist; CONSP (tail); tail = XCDR (tail))
6409 {
6410 proc = XCDR (XCAR (tail));
6411 p = XPROCESS (proc);
6412 if (p->pid == -1)
6413 break;
6414 p = 0;
6415 }
6416
6417 /* Change the status of the process that was found. */
6418 if (p != 0)
6419 {
6420 int clear_desc_flag = 0;
6421
6422 p->tick = ++process_tick;
6423 p->raw_status = w;
6424 p->raw_status_new = 1;
6425
6426 /* If process has terminated, stop waiting for its output. */
6427 if ((WIFSIGNALED (w) || WIFEXITED (w))
6428 && p->infd >= 0)
6429 clear_desc_flag = 1;
6430
6431 /* We use clear_desc_flag to avoid a compiler bug in Microsoft C. */
6432 if (clear_desc_flag)
6433 {
6434 FD_CLR (p->infd, &input_wait_mask);
6435 FD_CLR (p->infd, &non_keyboard_wait_mask);
6436 }
6437
6438 /* Tell wait_reading_process_output that it needs to wake up and
6439 look around. */
6440 if (input_available_clear_time)
6441 EMACS_SET_SECS_USECS (*input_available_clear_time, 0, 0);
6442 }
6443
6444 /* There was no asynchronous process found for that pid: we have
6445 a synchronous process. */
6446 else
6447 {
6448 synch_process_alive = 0;
6449
6450 /* Report the status of the synchronous process. */
6451 if (WIFEXITED (w))
6452 synch_process_retcode = WRETCODE (w);
6453 else if (WIFSIGNALED (w))
6454 synch_process_termsig = WTERMSIG (w);
6455
6456 /* Tell wait_reading_process_output that it needs to wake up and
6457 look around. */
6458 if (input_available_clear_time)
6459 EMACS_SET_SECS_USECS (*input_available_clear_time, 0, 0);
6460 }
6461
6462 sigchld_end_of_loop:
6463 ;
6464
6465 /* On some systems, we must return right away.
6466 If any more processes want to signal us, we will
6467 get another signal.
6468 Otherwise (on systems that have WNOHANG), loop around
6469 to use up all the processes that have something to tell us. */
6470 #if (defined WINDOWSNT \
6471 || (defined USG && !defined GNU_LINUX \
6472 && !(defined HPUX && defined WNOHANG)))
6473 errno = old_errno;
6474 return;
6475 #endif /* USG, but not HPUX with WNOHANG */
6476 }
6477 }
6478 #endif /* SIGCHLD */
6479 \f
6480
6481 static Lisp_Object
6482 exec_sentinel_unwind (Lisp_Object data)
6483 {
6484 XPROCESS (XCAR (data))->sentinel = XCDR (data);
6485 return Qnil;
6486 }
6487
6488 static Lisp_Object
6489 exec_sentinel_error_handler (Lisp_Object error_val)
6490 {
6491 cmd_error_internal (error_val, "error in process sentinel: ");
6492 Vinhibit_quit = Qt;
6493 update_echo_area ();
6494 Fsleep_for (make_number (2), Qnil);
6495 return Qt;
6496 }
6497
6498 static void
6499 exec_sentinel (Lisp_Object proc, Lisp_Object reason)
6500 {
6501 Lisp_Object sentinel, odeactivate;
6502 register struct Lisp_Process *p = XPROCESS (proc);
6503 ptrdiff_t count = SPECPDL_INDEX ();
6504 int outer_running_asynch_code = running_asynch_code;
6505 int waiting = waiting_for_user_input_p;
6506
6507 if (inhibit_sentinels)
6508 return;
6509
6510 /* No need to gcpro these, because all we do with them later
6511 is test them for EQness, and none of them should be a string. */
6512 odeactivate = Vdeactivate_mark;
6513 #if 0
6514 Lisp_Object obuffer, okeymap;
6515 XSETBUFFER (obuffer, current_buffer);
6516 okeymap = BVAR (current_buffer, keymap);
6517 #endif
6518
6519 /* There's no good reason to let sentinels change the current
6520 buffer, and many callers of accept-process-output, sit-for, and
6521 friends don't expect current-buffer to be changed from under them. */
6522 record_unwind_protect (set_buffer_if_live, Fcurrent_buffer ());
6523
6524 sentinel = p->sentinel;
6525 if (NILP (sentinel))
6526 return;
6527
6528 /* Zilch the sentinel while it's running, to avoid recursive invocations;
6529 assure that it gets restored no matter how the sentinel exits. */
6530 p->sentinel = Qnil;
6531 record_unwind_protect (exec_sentinel_unwind, Fcons (proc, sentinel));
6532 /* Inhibit quit so that random quits don't screw up a running filter. */
6533 specbind (Qinhibit_quit, Qt);
6534 specbind (Qlast_nonmenu_event, Qt); /* Why? --Stef */
6535
6536 /* In case we get recursively called,
6537 and we already saved the match data nonrecursively,
6538 save the same match data in safely recursive fashion. */
6539 if (outer_running_asynch_code)
6540 {
6541 Lisp_Object tem;
6542 tem = Fmatch_data (Qnil, Qnil, Qnil);
6543 restore_search_regs ();
6544 record_unwind_save_match_data ();
6545 Fset_match_data (tem, Qt);
6546 }
6547
6548 /* For speed, if a search happens within this code,
6549 save the match data in a special nonrecursive fashion. */
6550 running_asynch_code = 1;
6551
6552 internal_condition_case_1 (read_process_output_call,
6553 Fcons (sentinel,
6554 Fcons (proc, Fcons (reason, Qnil))),
6555 !NILP (Vdebug_on_error) ? Qnil : Qerror,
6556 exec_sentinel_error_handler);
6557
6558 /* If we saved the match data nonrecursively, restore it now. */
6559 restore_search_regs ();
6560 running_asynch_code = outer_running_asynch_code;
6561
6562 Vdeactivate_mark = odeactivate;
6563
6564 /* Restore waiting_for_user_input_p as it was
6565 when we were called, in case the filter clobbered it. */
6566 waiting_for_user_input_p = waiting;
6567
6568 #if 0
6569 if (! EQ (Fcurrent_buffer (), obuffer)
6570 || ! EQ (current_buffer->keymap, okeymap))
6571 #endif
6572 /* But do it only if the caller is actually going to read events.
6573 Otherwise there's no need to make him wake up, and it could
6574 cause trouble (for example it would make sit_for return). */
6575 if (waiting_for_user_input_p == -1)
6576 record_asynch_buffer_change ();
6577
6578 unbind_to (count, Qnil);
6579 }
6580
6581 /* Report all recent events of a change in process status
6582 (either run the sentinel or output a message).
6583 This is usually done while Emacs is waiting for keyboard input
6584 but can be done at other times. */
6585
6586 static void
6587 status_notify (struct Lisp_Process *deleting_process)
6588 {
6589 register Lisp_Object proc, buffer;
6590 Lisp_Object tail, msg;
6591 struct gcpro gcpro1, gcpro2;
6592
6593 tail = Qnil;
6594 msg = Qnil;
6595 /* We need to gcpro tail; if read_process_output calls a filter
6596 which deletes a process and removes the cons to which tail points
6597 from Vprocess_alist, and then causes a GC, tail is an unprotected
6598 reference. */
6599 GCPRO2 (tail, msg);
6600
6601 /* Set this now, so that if new processes are created by sentinels
6602 that we run, we get called again to handle their status changes. */
6603 update_tick = process_tick;
6604
6605 for (tail = Vprocess_alist; CONSP (tail); tail = XCDR (tail))
6606 {
6607 Lisp_Object symbol;
6608 register struct Lisp_Process *p;
6609
6610 proc = Fcdr (XCAR (tail));
6611 p = XPROCESS (proc);
6612
6613 if (p->tick != p->update_tick)
6614 {
6615 p->update_tick = p->tick;
6616
6617 /* If process is still active, read any output that remains. */
6618 while (! EQ (p->filter, Qt)
6619 && ! EQ (p->status, Qconnect)
6620 && ! EQ (p->status, Qlisten)
6621 /* Network or serial process not stopped: */
6622 && ! EQ (p->command, Qt)
6623 && p->infd >= 0
6624 && p != deleting_process
6625 && read_process_output (proc, p->infd) > 0);
6626
6627 buffer = p->buffer;
6628
6629 /* Get the text to use for the message. */
6630 if (p->raw_status_new)
6631 update_status (p);
6632 msg = status_message (p);
6633
6634 /* If process is terminated, deactivate it or delete it. */
6635 symbol = p->status;
6636 if (CONSP (p->status))
6637 symbol = XCAR (p->status);
6638
6639 if (EQ (symbol, Qsignal) || EQ (symbol, Qexit)
6640 || EQ (symbol, Qclosed))
6641 {
6642 if (delete_exited_processes)
6643 remove_process (proc);
6644 else
6645 deactivate_process (proc);
6646 }
6647
6648 /* The actions above may have further incremented p->tick.
6649 So set p->update_tick again
6650 so that an error in the sentinel will not cause
6651 this code to be run again. */
6652 p->update_tick = p->tick;
6653 /* Now output the message suitably. */
6654 if (!NILP (p->sentinel))
6655 exec_sentinel (proc, msg);
6656 /* Don't bother with a message in the buffer
6657 when a process becomes runnable. */
6658 else if (!EQ (symbol, Qrun) && !NILP (buffer))
6659 {
6660 Lisp_Object tem;
6661 struct buffer *old = current_buffer;
6662 ptrdiff_t opoint, opoint_byte;
6663 ptrdiff_t before, before_byte;
6664
6665 /* Avoid error if buffer is deleted
6666 (probably that's why the process is dead, too) */
6667 if (NILP (BVAR (XBUFFER (buffer), name)))
6668 continue;
6669 Fset_buffer (buffer);
6670
6671 opoint = PT;
6672 opoint_byte = PT_BYTE;
6673 /* Insert new output into buffer
6674 at the current end-of-output marker,
6675 thus preserving logical ordering of input and output. */
6676 if (XMARKER (p->mark)->buffer)
6677 Fgoto_char (p->mark);
6678 else
6679 SET_PT_BOTH (ZV, ZV_BYTE);
6680
6681 before = PT;
6682 before_byte = PT_BYTE;
6683
6684 tem = BVAR (current_buffer, read_only);
6685 BVAR (current_buffer, read_only) = Qnil;
6686 insert_string ("\nProcess ");
6687 Finsert (1, &p->name);
6688 insert_string (" ");
6689 Finsert (1, &msg);
6690 BVAR (current_buffer, read_only) = tem;
6691 set_marker_both (p->mark, p->buffer, PT, PT_BYTE);
6692
6693 if (opoint >= before)
6694 SET_PT_BOTH (opoint + (PT - before),
6695 opoint_byte + (PT_BYTE - before_byte));
6696 else
6697 SET_PT_BOTH (opoint, opoint_byte);
6698
6699 set_buffer_internal (old);
6700 }
6701 }
6702 } /* end for */
6703
6704 update_mode_lines++; /* in case buffers use %s in mode-line-format */
6705 UNGCPRO;
6706 }
6707
6708 \f
6709 DEFUN ("set-process-coding-system", Fset_process_coding_system,
6710 Sset_process_coding_system, 1, 3, 0,
6711 doc: /* Set coding systems of PROCESS to DECODING and ENCODING.
6712 DECODING will be used to decode subprocess output and ENCODING to
6713 encode subprocess input. */)
6714 (register Lisp_Object process, Lisp_Object decoding, Lisp_Object encoding)
6715 {
6716 register struct Lisp_Process *p;
6717
6718 CHECK_PROCESS (process);
6719 p = XPROCESS (process);
6720 if (p->infd < 0)
6721 error ("Input file descriptor of %s closed", SDATA (p->name));
6722 if (p->outfd < 0)
6723 error ("Output file descriptor of %s closed", SDATA (p->name));
6724 Fcheck_coding_system (decoding);
6725 Fcheck_coding_system (encoding);
6726 encoding = coding_inherit_eol_type (encoding, Qnil);
6727 p->decode_coding_system = decoding;
6728 p->encode_coding_system = encoding;
6729 setup_process_coding_systems (process);
6730
6731 return Qnil;
6732 }
6733
6734 DEFUN ("process-coding-system",
6735 Fprocess_coding_system, Sprocess_coding_system, 1, 1, 0,
6736 doc: /* Return a cons of coding systems for decoding and encoding of PROCESS. */)
6737 (register Lisp_Object process)
6738 {
6739 CHECK_PROCESS (process);
6740 return Fcons (XPROCESS (process)->decode_coding_system,
6741 XPROCESS (process)->encode_coding_system);
6742 }
6743
6744 DEFUN ("set-process-filter-multibyte", Fset_process_filter_multibyte,
6745 Sset_process_filter_multibyte, 2, 2, 0,
6746 doc: /* Set multibyteness of the strings given to PROCESS's filter.
6747 If FLAG is non-nil, the filter is given multibyte strings.
6748 If FLAG is nil, the filter is given unibyte strings. In this case,
6749 all character code conversion except for end-of-line conversion is
6750 suppressed. */)
6751 (Lisp_Object process, Lisp_Object flag)
6752 {
6753 register struct Lisp_Process *p;
6754
6755 CHECK_PROCESS (process);
6756 p = XPROCESS (process);
6757 if (NILP (flag))
6758 p->decode_coding_system = raw_text_coding_system (p->decode_coding_system);
6759 setup_process_coding_systems (process);
6760
6761 return Qnil;
6762 }
6763
6764 DEFUN ("process-filter-multibyte-p", Fprocess_filter_multibyte_p,
6765 Sprocess_filter_multibyte_p, 1, 1, 0,
6766 doc: /* Return t if a multibyte string is given to PROCESS's filter.*/)
6767 (Lisp_Object process)
6768 {
6769 register struct Lisp_Process *p;
6770 struct coding_system *coding;
6771
6772 CHECK_PROCESS (process);
6773 p = XPROCESS (process);
6774 coding = proc_decode_coding_system[p->infd];
6775 return (CODING_FOR_UNIBYTE (coding) ? Qnil : Qt);
6776 }
6777
6778
6779 \f
6780
6781 # ifdef HAVE_GPM
6782
6783 void
6784 add_gpm_wait_descriptor (int desc)
6785 {
6786 add_keyboard_wait_descriptor (desc);
6787 }
6788
6789 void
6790 delete_gpm_wait_descriptor (int desc)
6791 {
6792 delete_keyboard_wait_descriptor (desc);
6793 }
6794
6795 # endif
6796
6797 # ifdef SIGIO
6798
6799 /* Return nonzero if *MASK has a bit set
6800 that corresponds to one of the keyboard input descriptors. */
6801
6802 static int
6803 keyboard_bit_set (fd_set *mask)
6804 {
6805 int fd;
6806
6807 for (fd = 0; fd <= max_input_desc; fd++)
6808 if (FD_ISSET (fd, mask) && FD_ISSET (fd, &input_wait_mask)
6809 && !FD_ISSET (fd, &non_keyboard_wait_mask))
6810 return 1;
6811
6812 return 0;
6813 }
6814 # endif
6815
6816 #else /* not subprocesses */
6817
6818 /* Defined on msdos.c. */
6819 extern int sys_select (int, SELECT_TYPE *, SELECT_TYPE *, SELECT_TYPE *,
6820 EMACS_TIME *);
6821
6822 /* Implementation of wait_reading_process_output, assuming that there
6823 are no subprocesses. Used only by the MS-DOS build.
6824
6825 Wait for timeout to elapse and/or keyboard input to be available.
6826
6827 time_limit is:
6828 timeout in seconds, or
6829 zero for no limit, or
6830 -1 means gobble data immediately available but don't wait for any.
6831
6832 read_kbd is a Lisp_Object:
6833 0 to ignore keyboard input, or
6834 1 to return when input is available, or
6835 -1 means caller will actually read the input, so don't throw to
6836 the quit handler.
6837
6838 see full version for other parameters. We know that wait_proc will
6839 always be NULL, since `subprocesses' isn't defined.
6840
6841 do_display != 0 means redisplay should be done to show subprocess
6842 output that arrives.
6843
6844 Return true if we received input from any process. */
6845
6846 int
6847 wait_reading_process_output (int time_limit, int microsecs, int read_kbd,
6848 int do_display,
6849 Lisp_Object wait_for_cell,
6850 struct Lisp_Process *wait_proc, int just_wait_proc)
6851 {
6852 register int nfds;
6853 EMACS_TIME end_time, timeout;
6854 SELECT_TYPE waitchannels;
6855 int xerrno;
6856
6857 /* What does time_limit really mean? */
6858 if (time_limit || microsecs)
6859 {
6860 EMACS_GET_TIME (end_time);
6861 EMACS_SET_SECS_USECS (timeout, time_limit, microsecs);
6862 EMACS_ADD_TIME (end_time, end_time, timeout);
6863 }
6864
6865 /* Turn off periodic alarms (in case they are in use)
6866 and then turn off any other atimers,
6867 because the select emulator uses alarms. */
6868 stop_polling ();
6869 turn_on_atimers (0);
6870
6871 while (1)
6872 {
6873 int timeout_reduced_for_timers = 0;
6874
6875 /* If calling from keyboard input, do not quit
6876 since we want to return C-g as an input character.
6877 Otherwise, do pending quit if requested. */
6878 if (read_kbd >= 0)
6879 QUIT;
6880
6881 /* Exit now if the cell we're waiting for became non-nil. */
6882 if (! NILP (wait_for_cell) && ! NILP (XCAR (wait_for_cell)))
6883 break;
6884
6885 /* Compute time from now till when time limit is up */
6886 /* Exit if already run out */
6887 if (time_limit == -1)
6888 {
6889 /* -1 specified for timeout means
6890 gobble output available now
6891 but don't wait at all. */
6892
6893 EMACS_SET_SECS_USECS (timeout, 0, 0);
6894 }
6895 else if (time_limit || microsecs)
6896 {
6897 EMACS_GET_TIME (timeout);
6898 EMACS_SUB_TIME (timeout, end_time, timeout);
6899 if (EMACS_TIME_NEG_P (timeout))
6900 break;
6901 }
6902 else
6903 {
6904 EMACS_SET_SECS_USECS (timeout, 100000, 0);
6905 }
6906
6907 /* If our caller will not immediately handle keyboard events,
6908 run timer events directly.
6909 (Callers that will immediately read keyboard events
6910 call timer_delay on their own.) */
6911 if (NILP (wait_for_cell))
6912 {
6913 EMACS_TIME timer_delay;
6914
6915 do
6916 {
6917 int old_timers_run = timers_run;
6918 timer_delay = timer_check ();
6919 if (timers_run != old_timers_run && do_display)
6920 /* We must retry, since a timer may have requeued itself
6921 and that could alter the time delay. */
6922 redisplay_preserve_echo_area (14);
6923 else
6924 break;
6925 }
6926 while (!detect_input_pending ());
6927
6928 /* If there is unread keyboard input, also return. */
6929 if (read_kbd != 0
6930 && requeued_events_pending_p ())
6931 break;
6932
6933 if (! EMACS_TIME_NEG_P (timer_delay) && time_limit != -1)
6934 {
6935 EMACS_TIME difference;
6936 EMACS_SUB_TIME (difference, timer_delay, timeout);
6937 if (EMACS_TIME_NEG_P (difference))
6938 {
6939 timeout = timer_delay;
6940 timeout_reduced_for_timers = 1;
6941 }
6942 }
6943 }
6944
6945 /* Cause C-g and alarm signals to take immediate action,
6946 and cause input available signals to zero out timeout. */
6947 if (read_kbd < 0)
6948 set_waiting_for_input (&timeout);
6949
6950 /* Wait till there is something to do. */
6951
6952 if (! read_kbd && NILP (wait_for_cell))
6953 FD_ZERO (&waitchannels);
6954 else
6955 FD_SET (0, &waitchannels);
6956
6957 /* If a frame has been newly mapped and needs updating,
6958 reprocess its display stuff. */
6959 if (frame_garbaged && do_display)
6960 {
6961 clear_waiting_for_input ();
6962 redisplay_preserve_echo_area (15);
6963 if (read_kbd < 0)
6964 set_waiting_for_input (&timeout);
6965 }
6966
6967 if (read_kbd && detect_input_pending ())
6968 {
6969 nfds = 0;
6970 FD_ZERO (&waitchannels);
6971 }
6972 else
6973 nfds = select (1, &waitchannels, (SELECT_TYPE *)0, (SELECT_TYPE *)0,
6974 &timeout);
6975
6976 xerrno = errno;
6977
6978 /* Make C-g and alarm signals set flags again */
6979 clear_waiting_for_input ();
6980
6981 /* If we woke up due to SIGWINCH, actually change size now. */
6982 do_pending_window_change (0);
6983
6984 if (time_limit && nfds == 0 && ! timeout_reduced_for_timers)
6985 /* We waited the full specified time, so return now. */
6986 break;
6987
6988 if (nfds == -1)
6989 {
6990 /* If the system call was interrupted, then go around the
6991 loop again. */
6992 if (xerrno == EINTR)
6993 FD_ZERO (&waitchannels);
6994 else
6995 error ("select error: %s", emacs_strerror (xerrno));
6996 }
6997
6998 /* Check for keyboard input */
6999
7000 if (read_kbd
7001 && detect_input_pending_run_timers (do_display))
7002 {
7003 swallow_events (do_display);
7004 if (detect_input_pending_run_timers (do_display))
7005 break;
7006 }
7007
7008 /* If there is unread keyboard input, also return. */
7009 if (read_kbd
7010 && requeued_events_pending_p ())
7011 break;
7012
7013 /* If wait_for_cell. check for keyboard input
7014 but don't run any timers.
7015 ??? (It seems wrong to me to check for keyboard
7016 input at all when wait_for_cell, but the code
7017 has been this way since July 1994.
7018 Try changing this after version 19.31.) */
7019 if (! NILP (wait_for_cell)
7020 && detect_input_pending ())
7021 {
7022 swallow_events (do_display);
7023 if (detect_input_pending ())
7024 break;
7025 }
7026
7027 /* Exit now if the cell we're waiting for became non-nil. */
7028 if (! NILP (wait_for_cell) && ! NILP (XCAR (wait_for_cell)))
7029 break;
7030 }
7031
7032 start_polling ();
7033
7034 return 0;
7035 }
7036
7037 #endif /* not subprocesses */
7038
7039 /* The following functions are needed even if async subprocesses are
7040 not supported. Some of them are no-op stubs in that case. */
7041
7042 /* Add DESC to the set of keyboard input descriptors. */
7043
7044 void
7045 add_keyboard_wait_descriptor (int desc)
7046 {
7047 #ifdef subprocesses /* actually means "not MSDOS" */
7048 FD_SET (desc, &input_wait_mask);
7049 FD_SET (desc, &non_process_wait_mask);
7050 if (desc > max_input_desc)
7051 max_input_desc = desc;
7052 #endif
7053 }
7054
7055 /* From now on, do not expect DESC to give keyboard input. */
7056
7057 void
7058 delete_keyboard_wait_descriptor (int desc)
7059 {
7060 #ifdef subprocesses
7061 int fd;
7062 int lim = max_input_desc;
7063
7064 FD_CLR (desc, &input_wait_mask);
7065 FD_CLR (desc, &non_process_wait_mask);
7066
7067 if (desc == max_input_desc)
7068 for (fd = 0; fd < lim; fd++)
7069 if (FD_ISSET (fd, &input_wait_mask) || FD_ISSET (fd, &write_mask))
7070 max_input_desc = fd;
7071 #endif
7072 }
7073
7074 /* Setup coding systems of PROCESS. */
7075
7076 void
7077 setup_process_coding_systems (Lisp_Object process)
7078 {
7079 #ifdef subprocesses
7080 struct Lisp_Process *p = XPROCESS (process);
7081 int inch = p->infd;
7082 int outch = p->outfd;
7083 Lisp_Object coding_system;
7084
7085 if (inch < 0 || outch < 0)
7086 return;
7087
7088 if (!proc_decode_coding_system[inch])
7089 proc_decode_coding_system[inch]
7090 = (struct coding_system *) xmalloc (sizeof (struct coding_system));
7091 coding_system = p->decode_coding_system;
7092 if (! NILP (p->filter))
7093 ;
7094 else if (BUFFERP (p->buffer))
7095 {
7096 if (NILP (BVAR (XBUFFER (p->buffer), enable_multibyte_characters)))
7097 coding_system = raw_text_coding_system (coding_system);
7098 }
7099 setup_coding_system (coding_system, proc_decode_coding_system[inch]);
7100
7101 if (!proc_encode_coding_system[outch])
7102 proc_encode_coding_system[outch]
7103 = (struct coding_system *) xmalloc (sizeof (struct coding_system));
7104 setup_coding_system (p->encode_coding_system,
7105 proc_encode_coding_system[outch]);
7106 #endif
7107 }
7108
7109 /* Close all descriptors currently in use for communication
7110 with subprocess. This is used in a newly-forked subprocess
7111 to get rid of irrelevant descriptors. */
7112
7113 void
7114 close_process_descs (void)
7115 {
7116 #ifndef DOS_NT
7117 int i;
7118 for (i = 0; i < MAXDESC; i++)
7119 {
7120 Lisp_Object process;
7121 process = chan_process[i];
7122 if (!NILP (process))
7123 {
7124 int in = XPROCESS (process)->infd;
7125 int out = XPROCESS (process)->outfd;
7126 if (in >= 0)
7127 emacs_close (in);
7128 if (out >= 0 && in != out)
7129 emacs_close (out);
7130 }
7131 }
7132 #endif
7133 }
7134
7135 DEFUN ("get-buffer-process", Fget_buffer_process, Sget_buffer_process, 1, 1, 0,
7136 doc: /* Return the (or a) process associated with BUFFER.
7137 BUFFER may be a buffer or the name of one. */)
7138 (register Lisp_Object buffer)
7139 {
7140 #ifdef subprocesses
7141 register Lisp_Object buf, tail, proc;
7142
7143 if (NILP (buffer)) return Qnil;
7144 buf = Fget_buffer (buffer);
7145 if (NILP (buf)) return Qnil;
7146
7147 for (tail = Vprocess_alist; CONSP (tail); tail = XCDR (tail))
7148 {
7149 proc = Fcdr (XCAR (tail));
7150 if (PROCESSP (proc) && EQ (XPROCESS (proc)->buffer, buf))
7151 return proc;
7152 }
7153 #endif /* subprocesses */
7154 return Qnil;
7155 }
7156
7157 DEFUN ("process-inherit-coding-system-flag",
7158 Fprocess_inherit_coding_system_flag, Sprocess_inherit_coding_system_flag,
7159 1, 1, 0,
7160 doc: /* Return the value of inherit-coding-system flag for PROCESS.
7161 If this flag is t, `buffer-file-coding-system' of the buffer
7162 associated with PROCESS will inherit the coding system used to decode
7163 the process output. */)
7164 (register Lisp_Object process)
7165 {
7166 #ifdef subprocesses
7167 CHECK_PROCESS (process);
7168 return XPROCESS (process)->inherit_coding_system_flag ? Qt : Qnil;
7169 #else
7170 /* Ignore the argument and return the value of
7171 inherit-process-coding-system. */
7172 return inherit_process_coding_system ? Qt : Qnil;
7173 #endif
7174 }
7175
7176 /* Kill all processes associated with `buffer'.
7177 If `buffer' is nil, kill all processes */
7178
7179 void
7180 kill_buffer_processes (Lisp_Object buffer)
7181 {
7182 #ifdef subprocesses
7183 Lisp_Object tail, proc;
7184
7185 for (tail = Vprocess_alist; CONSP (tail); tail = XCDR (tail))
7186 {
7187 proc = XCDR (XCAR (tail));
7188 if (PROCESSP (proc)
7189 && (NILP (buffer) || EQ (XPROCESS (proc)->buffer, buffer)))
7190 {
7191 if (NETCONN_P (proc) || SERIALCONN_P (proc))
7192 Fdelete_process (proc);
7193 else if (XPROCESS (proc)->infd >= 0)
7194 process_send_signal (proc, SIGHUP, Qnil, 1);
7195 }
7196 }
7197 #else /* subprocesses */
7198 /* Since we have no subprocesses, this does nothing. */
7199 #endif /* subprocesses */
7200 }
7201
7202 DEFUN ("waiting-for-user-input-p", Fwaiting_for_user_input_p,
7203 Swaiting_for_user_input_p, 0, 0, 0,
7204 doc: /* Returns non-nil if Emacs is waiting for input from the user.
7205 This is intended for use by asynchronous process output filters and sentinels. */)
7206 (void)
7207 {
7208 #ifdef subprocesses
7209 return (waiting_for_user_input_p ? Qt : Qnil);
7210 #else
7211 return Qnil;
7212 #endif
7213 }
7214
7215 /* Stop reading input from keyboard sources. */
7216
7217 void
7218 hold_keyboard_input (void)
7219 {
7220 kbd_is_on_hold = 1;
7221 }
7222
7223 /* Resume reading input from keyboard sources. */
7224
7225 void
7226 unhold_keyboard_input (void)
7227 {
7228 kbd_is_on_hold = 0;
7229 }
7230
7231 /* Return non-zero if keyboard input is on hold, zero otherwise. */
7232
7233 int
7234 kbd_on_hold_p (void)
7235 {
7236 return kbd_is_on_hold;
7237 }
7238
7239 \f
7240 /* Enumeration of and access to system processes a-la ps(1). */
7241
7242 DEFUN ("list-system-processes", Flist_system_processes, Slist_system_processes,
7243 0, 0, 0,
7244 doc: /* Return a list of numerical process IDs of all running processes.
7245 If this functionality is unsupported, return nil.
7246
7247 See `process-attributes' for getting attributes of a process given its ID. */)
7248 (void)
7249 {
7250 return list_system_processes ();
7251 }
7252
7253 DEFUN ("process-attributes", Fprocess_attributes,
7254 Sprocess_attributes, 1, 1, 0,
7255 doc: /* Return attributes of the process given by its PID, a number.
7256
7257 Value is an alist where each element is a cons cell of the form
7258
7259 \(KEY . VALUE)
7260
7261 If this functionality is unsupported, the value is nil.
7262
7263 See `list-system-processes' for getting a list of all process IDs.
7264
7265 The KEYs of the attributes that this function may return are listed
7266 below, together with the type of the associated VALUE (in parentheses).
7267 Not all platforms support all of these attributes; unsupported
7268 attributes will not appear in the returned alist.
7269 Unless explicitly indicated otherwise, numbers can have either
7270 integer or floating point values.
7271
7272 euid -- Effective user User ID of the process (number)
7273 user -- User name corresponding to euid (string)
7274 egid -- Effective user Group ID of the process (number)
7275 group -- Group name corresponding to egid (string)
7276 comm -- Command name (executable name only) (string)
7277 state -- Process state code, such as "S", "R", or "T" (string)
7278 ppid -- Parent process ID (number)
7279 pgrp -- Process group ID (number)
7280 sess -- Session ID, i.e. process ID of session leader (number)
7281 ttname -- Controlling tty name (string)
7282 tpgid -- ID of foreground process group on the process's tty (number)
7283 minflt -- number of minor page faults (number)
7284 majflt -- number of major page faults (number)
7285 cminflt -- cumulative number of minor page faults (number)
7286 cmajflt -- cumulative number of major page faults (number)
7287 utime -- user time used by the process, in the (HIGH LOW USEC) format
7288 stime -- system time used by the process, in the (HIGH LOW USEC) format
7289 time -- sum of utime and stime, in the (HIGH LOW USEC) format
7290 cutime -- user time used by the process and its children, (HIGH LOW USEC)
7291 cstime -- system time used by the process and its children, (HIGH LOW USEC)
7292 ctime -- sum of cutime and cstime, in the (HIGH LOW USEC) format
7293 pri -- priority of the process (number)
7294 nice -- nice value of the process (number)
7295 thcount -- process thread count (number)
7296 start -- time the process started, in the (HIGH LOW USEC) format
7297 vsize -- virtual memory size of the process in KB's (number)
7298 rss -- resident set size of the process in KB's (number)
7299 etime -- elapsed time the process is running, in (HIGH LOW USEC) format
7300 pcpu -- percents of CPU time used by the process (floating-point number)
7301 pmem -- percents of total physical memory used by process's resident set
7302 (floating-point number)
7303 args -- command line which invoked the process (string). */)
7304 ( Lisp_Object pid)
7305 {
7306 return system_process_attributes (pid);
7307 }
7308
7309 \f
7310 void
7311 init_process (void)
7312 {
7313 #ifdef subprocesses
7314 register int i;
7315
7316 inhibit_sentinels = 0;
7317
7318 #ifdef SIGCHLD
7319 #ifndef CANNOT_DUMP
7320 if (! noninteractive || initialized)
7321 #endif
7322 signal (SIGCHLD, sigchld_handler);
7323 #endif
7324
7325 FD_ZERO (&input_wait_mask);
7326 FD_ZERO (&non_keyboard_wait_mask);
7327 FD_ZERO (&non_process_wait_mask);
7328 FD_ZERO (&write_mask);
7329 max_process_desc = 0;
7330 memset (fd_callback_info, 0, sizeof (fd_callback_info));
7331
7332 #ifdef NON_BLOCKING_CONNECT
7333 FD_ZERO (&connect_wait_mask);
7334 num_pending_connects = 0;
7335 #endif
7336
7337 #ifdef ADAPTIVE_READ_BUFFERING
7338 process_output_delay_count = 0;
7339 process_output_skip = 0;
7340 #endif
7341
7342 /* Don't do this, it caused infinite select loops. The display
7343 method should call add_keyboard_wait_descriptor on stdin if it
7344 needs that. */
7345 #if 0
7346 FD_SET (0, &input_wait_mask);
7347 #endif
7348
7349 Vprocess_alist = Qnil;
7350 #ifdef SIGCHLD
7351 deleted_pid_list = Qnil;
7352 #endif
7353 for (i = 0; i < MAXDESC; i++)
7354 {
7355 chan_process[i] = Qnil;
7356 proc_buffered_char[i] = -1;
7357 }
7358 memset (proc_decode_coding_system, 0, sizeof proc_decode_coding_system);
7359 memset (proc_encode_coding_system, 0, sizeof proc_encode_coding_system);
7360 #ifdef DATAGRAM_SOCKETS
7361 memset (datagram_address, 0, sizeof datagram_address);
7362 #endif
7363
7364 {
7365 Lisp_Object subfeatures = Qnil;
7366 const struct socket_options *sopt;
7367
7368 #define ADD_SUBFEATURE(key, val) \
7369 subfeatures = pure_cons (pure_cons (key, pure_cons (val, Qnil)), subfeatures)
7370
7371 #ifdef NON_BLOCKING_CONNECT
7372 ADD_SUBFEATURE (QCnowait, Qt);
7373 #endif
7374 #ifdef DATAGRAM_SOCKETS
7375 ADD_SUBFEATURE (QCtype, Qdatagram);
7376 #endif
7377 #ifdef HAVE_SEQPACKET
7378 ADD_SUBFEATURE (QCtype, Qseqpacket);
7379 #endif
7380 #ifdef HAVE_LOCAL_SOCKETS
7381 ADD_SUBFEATURE (QCfamily, Qlocal);
7382 #endif
7383 ADD_SUBFEATURE (QCfamily, Qipv4);
7384 #ifdef AF_INET6
7385 ADD_SUBFEATURE (QCfamily, Qipv6);
7386 #endif
7387 #ifdef HAVE_GETSOCKNAME
7388 ADD_SUBFEATURE (QCservice, Qt);
7389 #endif
7390 #if defined (O_NONBLOCK) || defined (O_NDELAY)
7391 ADD_SUBFEATURE (QCserver, Qt);
7392 #endif
7393
7394 for (sopt = socket_options; sopt->name; sopt++)
7395 subfeatures = pure_cons (intern_c_string (sopt->name), subfeatures);
7396
7397 Fprovide (intern_c_string ("make-network-process"), subfeatures);
7398 }
7399
7400 #if defined (DARWIN_OS)
7401 /* PTYs are broken on Darwin < 6, but are sometimes useful for interactive
7402 processes. As such, we only change the default value. */
7403 if (initialized)
7404 {
7405 char const *release = (STRINGP (Voperating_system_release)
7406 ? SSDATA (Voperating_system_release)
7407 : 0);
7408 if (!release || !release[0] || (release[0] < MIN_PTY_KERNEL_VERSION
7409 && release[1] == '.')) {
7410 Vprocess_connection_type = Qnil;
7411 }
7412 }
7413 #endif
7414 #endif /* subprocesses */
7415 kbd_is_on_hold = 0;
7416 }
7417
7418 void
7419 syms_of_process (void)
7420 {
7421 #ifdef subprocesses
7422
7423 DEFSYM (Qprocessp, "processp");
7424 DEFSYM (Qrun, "run");
7425 DEFSYM (Qstop, "stop");
7426 DEFSYM (Qsignal, "signal");
7427
7428 /* Qexit is already staticpro'd by syms_of_eval; don't staticpro it
7429 here again.
7430
7431 Qexit = intern_c_string ("exit");
7432 staticpro (&Qexit); */
7433
7434 DEFSYM (Qopen, "open");
7435 DEFSYM (Qclosed, "closed");
7436 DEFSYM (Qconnect, "connect");
7437 DEFSYM (Qfailed, "failed");
7438 DEFSYM (Qlisten, "listen");
7439 DEFSYM (Qlocal, "local");
7440 DEFSYM (Qipv4, "ipv4");
7441 #ifdef AF_INET6
7442 DEFSYM (Qipv6, "ipv6");
7443 #endif
7444 DEFSYM (Qdatagram, "datagram");
7445 DEFSYM (Qseqpacket, "seqpacket");
7446
7447 DEFSYM (QCport, ":port");
7448 DEFSYM (QCspeed, ":speed");
7449 DEFSYM (QCprocess, ":process");
7450
7451 DEFSYM (QCbytesize, ":bytesize");
7452 DEFSYM (QCstopbits, ":stopbits");
7453 DEFSYM (QCparity, ":parity");
7454 DEFSYM (Qodd, "odd");
7455 DEFSYM (Qeven, "even");
7456 DEFSYM (QCflowcontrol, ":flowcontrol");
7457 DEFSYM (Qhw, "hw");
7458 DEFSYM (Qsw, "sw");
7459 DEFSYM (QCsummary, ":summary");
7460
7461 DEFSYM (Qreal, "real");
7462 DEFSYM (Qnetwork, "network");
7463 DEFSYM (Qserial, "serial");
7464 DEFSYM (QCbuffer, ":buffer");
7465 DEFSYM (QChost, ":host");
7466 DEFSYM (QCservice, ":service");
7467 DEFSYM (QClocal, ":local");
7468 DEFSYM (QCremote, ":remote");
7469 DEFSYM (QCcoding, ":coding");
7470 DEFSYM (QCserver, ":server");
7471 DEFSYM (QCnowait, ":nowait");
7472 DEFSYM (QCsentinel, ":sentinel");
7473 DEFSYM (QClog, ":log");
7474 DEFSYM (QCnoquery, ":noquery");
7475 DEFSYM (QCstop, ":stop");
7476 DEFSYM (QCoptions, ":options");
7477 DEFSYM (QCplist, ":plist");
7478
7479 DEFSYM (Qlast_nonmenu_event, "last-nonmenu-event");
7480
7481 staticpro (&Vprocess_alist);
7482 #ifdef SIGCHLD
7483 staticpro (&deleted_pid_list);
7484 #endif
7485
7486 #endif /* subprocesses */
7487
7488 DEFSYM (QCname, ":name");
7489 DEFSYM (QCtype, ":type");
7490
7491 DEFSYM (Qeuid, "euid");
7492 DEFSYM (Qegid, "egid");
7493 DEFSYM (Quser, "user");
7494 DEFSYM (Qgroup, "group");
7495 DEFSYM (Qcomm, "comm");
7496 DEFSYM (Qstate, "state");
7497 DEFSYM (Qppid, "ppid");
7498 DEFSYM (Qpgrp, "pgrp");
7499 DEFSYM (Qsess, "sess");
7500 DEFSYM (Qttname, "ttname");
7501 DEFSYM (Qtpgid, "tpgid");
7502 DEFSYM (Qminflt, "minflt");
7503 DEFSYM (Qmajflt, "majflt");
7504 DEFSYM (Qcminflt, "cminflt");
7505 DEFSYM (Qcmajflt, "cmajflt");
7506 DEFSYM (Qutime, "utime");
7507 DEFSYM (Qstime, "stime");
7508 DEFSYM (Qtime, "time");
7509 DEFSYM (Qcutime, "cutime");
7510 DEFSYM (Qcstime, "cstime");
7511 DEFSYM (Qctime, "ctime");
7512 DEFSYM (Qpri, "pri");
7513 DEFSYM (Qnice, "nice");
7514 DEFSYM (Qthcount, "thcount");
7515 DEFSYM (Qstart, "start");
7516 DEFSYM (Qvsize, "vsize");
7517 DEFSYM (Qrss, "rss");
7518 DEFSYM (Qetime, "etime");
7519 DEFSYM (Qpcpu, "pcpu");
7520 DEFSYM (Qpmem, "pmem");
7521 DEFSYM (Qargs, "args");
7522
7523 DEFVAR_BOOL ("delete-exited-processes", delete_exited_processes,
7524 doc: /* Non-nil means delete processes immediately when they exit.
7525 A value of nil means don't delete them until `list-processes' is run. */);
7526
7527 delete_exited_processes = 1;
7528
7529 #ifdef subprocesses
7530 DEFVAR_LISP ("process-connection-type", Vprocess_connection_type,
7531 doc: /* Control type of device used to communicate with subprocesses.
7532 Values are nil to use a pipe, or t or `pty' to use a pty.
7533 The value has no effect if the system has no ptys or if all ptys are busy:
7534 then a pipe is used in any case.
7535 The value takes effect when `start-process' is called. */);
7536 Vprocess_connection_type = Qt;
7537
7538 #ifdef ADAPTIVE_READ_BUFFERING
7539 DEFVAR_LISP ("process-adaptive-read-buffering", Vprocess_adaptive_read_buffering,
7540 doc: /* If non-nil, improve receive buffering by delaying after short reads.
7541 On some systems, when Emacs reads the output from a subprocess, the output data
7542 is read in very small blocks, potentially resulting in very poor performance.
7543 This behavior can be remedied to some extent by setting this variable to a
7544 non-nil value, as it will automatically delay reading from such processes, to
7545 allow them to produce more output before Emacs tries to read it.
7546 If the value is t, the delay is reset after each write to the process; any other
7547 non-nil value means that the delay is not reset on write.
7548 The variable takes effect when `start-process' is called. */);
7549 Vprocess_adaptive_read_buffering = Qt;
7550 #endif
7551
7552 defsubr (&Sprocessp);
7553 defsubr (&Sget_process);
7554 defsubr (&Sdelete_process);
7555 defsubr (&Sprocess_status);
7556 defsubr (&Sprocess_exit_status);
7557 defsubr (&Sprocess_id);
7558 defsubr (&Sprocess_name);
7559 defsubr (&Sprocess_tty_name);
7560 defsubr (&Sprocess_command);
7561 defsubr (&Sset_process_buffer);
7562 defsubr (&Sprocess_buffer);
7563 defsubr (&Sprocess_mark);
7564 defsubr (&Sset_process_filter);
7565 defsubr (&Sprocess_filter);
7566 defsubr (&Sset_process_sentinel);
7567 defsubr (&Sprocess_sentinel);
7568 defsubr (&Sset_process_window_size);
7569 defsubr (&Sset_process_inherit_coding_system_flag);
7570 defsubr (&Sset_process_query_on_exit_flag);
7571 defsubr (&Sprocess_query_on_exit_flag);
7572 defsubr (&Sprocess_contact);
7573 defsubr (&Sprocess_plist);
7574 defsubr (&Sset_process_plist);
7575 defsubr (&Sprocess_list);
7576 defsubr (&Sstart_process);
7577 defsubr (&Sserial_process_configure);
7578 defsubr (&Smake_serial_process);
7579 defsubr (&Sset_network_process_option);
7580 defsubr (&Smake_network_process);
7581 defsubr (&Sformat_network_address);
7582 #if defined (HAVE_NET_IF_H)
7583 #ifdef SIOCGIFCONF
7584 defsubr (&Snetwork_interface_list);
7585 #endif
7586 #if defined (SIOCGIFADDR) || defined (SIOCGIFHWADDR) || defined (SIOCGIFFLAGS)
7587 defsubr (&Snetwork_interface_info);
7588 #endif
7589 #endif /* defined (HAVE_NET_IF_H) */
7590 #ifdef DATAGRAM_SOCKETS
7591 defsubr (&Sprocess_datagram_address);
7592 defsubr (&Sset_process_datagram_address);
7593 #endif
7594 defsubr (&Saccept_process_output);
7595 defsubr (&Sprocess_send_region);
7596 defsubr (&Sprocess_send_string);
7597 defsubr (&Sinterrupt_process);
7598 defsubr (&Skill_process);
7599 defsubr (&Squit_process);
7600 defsubr (&Sstop_process);
7601 defsubr (&Scontinue_process);
7602 defsubr (&Sprocess_running_child_p);
7603 defsubr (&Sprocess_send_eof);
7604 defsubr (&Ssignal_process);
7605 defsubr (&Swaiting_for_user_input_p);
7606 defsubr (&Sprocess_type);
7607 defsubr (&Sset_process_coding_system);
7608 defsubr (&Sprocess_coding_system);
7609 defsubr (&Sset_process_filter_multibyte);
7610 defsubr (&Sprocess_filter_multibyte_p);
7611
7612 #endif /* subprocesses */
7613
7614 defsubr (&Sget_buffer_process);
7615 defsubr (&Sprocess_inherit_coding_system_flag);
7616 defsubr (&Slist_system_processes);
7617 defsubr (&Sprocess_attributes);
7618 }