aboutsummaryrefslogtreecommitdiffstats
path: root/src
diff options
context:
space:
mode:
authorLars Ingebrigtsen2016-02-22 15:06:33 +1100
committerLars Ingebrigtsen2016-02-22 15:06:33 +1100
commitf577f59a5216bc7708bb840f5eac3e82950e81e8 (patch)
treec154db8bc4b920ea06c98efb7fc407562753b2d6 /src
parent5df6e3212bbb3213d1704dab89299a96b60eac6d (diff)
parent0d3c0f6f906d5494f76b8b686bae72853b1f729c (diff)
downloademacs-f577f59a5216bc7708bb840f5eac3e82950e81e8.tar.gz
emacs-f577f59a5216bc7708bb840f5eac3e82950e81e8.zip
Fix merge conflicts in network-stream-tests.el
Diffstat (limited to 'src')
-rw-r--r--src/Makefile.in4
-rw-r--r--src/eval.c15
-rw-r--r--src/gnutls.c388
-rw-r--r--src/gnutls.h2
-rw-r--r--src/lisp.h2
-rw-r--r--src/process.c1395
-rw-r--r--src/process.h25
7 files changed, 1171 insertions, 660 deletions
diff --git a/src/Makefile.in b/src/Makefile.in
index a14d36f3f80..99394ac57cf 100644
--- a/src/Makefile.in
+++ b/src/Makefile.in
@@ -235,6 +235,8 @@ IMAGEMAGICK_CFLAGS= @IMAGEMAGICK_CFLAGS@
235LIBXML2_LIBS = @LIBXML2_LIBS@ 235LIBXML2_LIBS = @LIBXML2_LIBS@
236LIBXML2_CFLAGS = @LIBXML2_CFLAGS@ 236LIBXML2_CFLAGS = @LIBXML2_CFLAGS@
237 237
238GETADDRINFO_A_LIBS = @GETADDRINFO_A_LIBS@
239
238LIBZ = @LIBZ@ 240LIBZ = @LIBZ@
239 241
240## system-specific libs for dynamic modules, else empty 242## system-specific libs for dynamic modules, else empty
@@ -486,7 +488,7 @@ LIBES = $(LIBS) $(W32_LIBS) $(LIBS_GNUSTEP) $(LIBX_BASE) $(LIBIMAGE) \
486 $(LIBXML2_LIBS) $(LIBGPM) $(LIBRESOLV) $(LIBS_SYSTEM) $(CAIRO_LIBS) \ 488 $(LIBXML2_LIBS) $(LIBGPM) $(LIBRESOLV) $(LIBS_SYSTEM) $(CAIRO_LIBS) \
487 $(LIBS_TERMCAP) $(GETLOADAVG_LIBS) $(SETTINGS_LIBS) $(LIBSELINUX_LIBS) \ 489 $(LIBS_TERMCAP) $(GETLOADAVG_LIBS) $(SETTINGS_LIBS) $(LIBSELINUX_LIBS) \
488 $(FREETYPE_LIBS) $(FONTCONFIG_LIBS) $(LIBOTF_LIBS) $(M17N_FLT_LIBS) \ 490 $(FREETYPE_LIBS) $(FONTCONFIG_LIBS) $(LIBOTF_LIBS) $(M17N_FLT_LIBS) \
489 $(LIBGNUTLS_LIBS) $(LIB_PTHREAD) \ 491 $(LIBGNUTLS_LIBS) $(LIB_PTHREAD) $(GETADDRINFO_A_LIBS) \
490 $(NOTIFY_LIBS) $(LIB_MATH) $(LIBZ) $(LIBMODULES) 492 $(NOTIFY_LIBS) $(LIB_MATH) $(LIBZ) $(LIBMODULES)
491 493
492$(leimdir)/leim-list.el: bootstrap-emacs$(EXEEXT) 494$(leimdir)/leim-list.el: bootstrap-emacs$(EXEEXT)
diff --git a/src/eval.c b/src/eval.c
index 26104a58277..b6bf0e64052 100644
--- a/src/eval.c
+++ b/src/eval.c
@@ -1751,9 +1751,9 @@ find_handler_clause (Lisp_Object handlers, Lisp_Object conditions)
1751} 1751}
1752 1752
1753 1753
1754/* Dump an error message; called like vprintf. */ 1754/* Format and return a string; called like vprintf. */
1755void 1755Lisp_Object
1756verror (const char *m, va_list ap) 1756vformat_string (const char *m, va_list ap)
1757{ 1757{
1758 char buf[4000]; 1758 char buf[4000];
1759 ptrdiff_t size = sizeof buf; 1759 ptrdiff_t size = sizeof buf;
@@ -1767,7 +1767,14 @@ verror (const char *m, va_list ap)
1767 if (buffer != buf) 1767 if (buffer != buf)
1768 xfree (buffer); 1768 xfree (buffer);
1769 1769
1770 xsignal1 (Qerror, string); 1770 return string;
1771}
1772
1773/* Dump an error message; called like vprintf. */
1774void
1775verror (const char *m, va_list ap)
1776{
1777 xsignal1 (Qerror, vformat_string (m, ap));
1771} 1778}
1772 1779
1773 1780
diff --git a/src/gnutls.c b/src/gnutls.c
index 01a5983d3b0..ce4fbf9b7ef 100644
--- a/src/gnutls.c
+++ b/src/gnutls.c
@@ -397,11 +397,42 @@ gnutls_log_function2i (int level, const char *string, int extra)
397 message ("gnutls.c: [%d] %s %d", level, string, extra); 397 message ("gnutls.c: [%d] %s %d", level, string, extra);
398} 398}
399 399
400int
401gnutls_try_handshake (struct Lisp_Process *proc)
402{
403 gnutls_session_t state = proc->gnutls_state;
404 int ret;
405
406 do
407 {
408 ret = gnutls_handshake (state);
409 emacs_gnutls_handle_error (state, ret);
410 QUIT;
411 }
412 while (ret < 0 && gnutls_error_is_fatal (ret) == 0 &&
413 ! proc->is_non_blocking_client);
414
415 proc->gnutls_initstage = GNUTLS_STAGE_HANDSHAKE_TRIED;
416
417 if (proc->is_non_blocking_client)
418 proc->gnutls_p = 1;
419
420 if (ret == GNUTLS_E_SUCCESS)
421 {
422 /* Here we're finally done. */
423 proc->gnutls_initstage = GNUTLS_STAGE_READY;
424 }
425 else
426 {
427 //check_memory_full (gnutls_alert_send_appropriate (state, ret));
428 }
429 return ret;
430}
431
400static int 432static int
401emacs_gnutls_handshake (struct Lisp_Process *proc) 433emacs_gnutls_handshake (struct Lisp_Process *proc)
402{ 434{
403 gnutls_session_t state = proc->gnutls_state; 435 gnutls_session_t state = proc->gnutls_state;
404 int ret;
405 436
406 if (proc->gnutls_initstage < GNUTLS_STAGE_HANDSHAKE_CANDO) 437 if (proc->gnutls_initstage < GNUTLS_STAGE_HANDSHAKE_CANDO)
407 return -1; 438 return -1;
@@ -443,26 +474,7 @@ emacs_gnutls_handshake (struct Lisp_Process *proc)
443 proc->gnutls_initstage = GNUTLS_STAGE_TRANSPORT_POINTERS_SET; 474 proc->gnutls_initstage = GNUTLS_STAGE_TRANSPORT_POINTERS_SET;
444 } 475 }
445 476
446 do 477 return gnutls_try_handshake (proc);
447 {
448 ret = gnutls_handshake (state);
449 emacs_gnutls_handle_error (state, ret);
450 QUIT;
451 }
452 while (ret < 0 && gnutls_error_is_fatal (ret) == 0);
453
454 proc->gnutls_initstage = GNUTLS_STAGE_HANDSHAKE_TRIED;
455
456 if (ret == GNUTLS_E_SUCCESS)
457 {
458 /* Here we're finally done. */
459 proc->gnutls_initstage = GNUTLS_STAGE_READY;
460 }
461 else
462 {
463 check_memory_full (gnutls_alert_send_appropriate (state, ret));
464 }
465 return ret;
466} 478}
467 479
468ptrdiff_t 480ptrdiff_t
@@ -528,26 +540,9 @@ emacs_gnutls_read (struct Lisp_Process *proc, char *buf, ptrdiff_t nbyte)
528 ssize_t rtnval; 540 ssize_t rtnval;
529 gnutls_session_t state = proc->gnutls_state; 541 gnutls_session_t state = proc->gnutls_state;
530 542
531 int log_level = proc->gnutls_log_level;
532
533 if (proc->gnutls_initstage != GNUTLS_STAGE_READY) 543 if (proc->gnutls_initstage != GNUTLS_STAGE_READY)
534 { 544 return -1;
535 /* If the handshake count is under the limit, try the handshake
536 again and increment the handshake count. This count is kept
537 per process (connection), not globally. */
538 if (proc->gnutls_handshakes_tried < GNUTLS_EMACS_HANDSHAKES_LIMIT)
539 {
540 proc->gnutls_handshakes_tried++;
541 emacs_gnutls_handshake (proc);
542 GNUTLS_LOG2i (5, log_level, "Retried handshake",
543 proc->gnutls_handshakes_tried);
544 return -1;
545 }
546 545
547 GNUTLS_LOG (2, log_level, "Giving up on handshake; resetting retries");
548 proc->gnutls_handshakes_tried = 0;
549 return 0;
550 }
551 rtnval = gnutls_record_recv (state, buf, nbyte); 546 rtnval = gnutls_record_recv (state, buf, nbyte);
552 if (rtnval >= 0) 547 if (rtnval >= 0)
553 return rtnval; 548 return rtnval;
@@ -686,6 +681,19 @@ emacs_gnutls_deinit (Lisp_Object proc)
686 return Qt; 681 return Qt;
687} 682}
688 683
684DEFUN ("gnutls-asynchronous-parameters", Fgnutls_asynchronous_parameters,
685 Sgnutls_asynchronous_parameters, 2, 2, 0,
686 doc: /* Mark this process as being a pre-init GnuTLS process.
687The second parameter is the list of parameters to feed to gnutls-boot
688to finish setting up the connection. */)
689 (Lisp_Object proc, Lisp_Object params)
690{
691 CHECK_PROCESS (proc);
692
693 XPROCESS (proc)->gnutls_boot_parameters = params;
694 return Qnil;
695}
696
689DEFUN ("gnutls-get-initstage", Fgnutls_get_initstage, Sgnutls_get_initstage, 1, 1, 0, 697DEFUN ("gnutls-get-initstage", Fgnutls_get_initstage, Sgnutls_get_initstage, 1, 1, 0,
690 doc: /* Return the GnuTLS init stage of process PROC. 698 doc: /* Return the GnuTLS init stage of process PROC.
691See also `gnutls-boot'. */) 699See also `gnutls-boot'. */)
@@ -1022,7 +1030,7 @@ The return value is a property list with top-level keys :warnings and
1022 1030
1023 CHECK_PROCESS (proc); 1031 CHECK_PROCESS (proc);
1024 1032
1025 if (GNUTLS_INITSTAGE (proc) < GNUTLS_STAGE_INIT) 1033 if (GNUTLS_INITSTAGE (proc) != GNUTLS_STAGE_READY)
1026 return Qnil; 1034 return Qnil;
1027 1035
1028 /* Then collect any warnings already computed by the handshake. */ 1036 /* Then collect any warnings already computed by the handshake. */
@@ -1154,6 +1162,162 @@ emacs_gnutls_global_deinit (void)
1154} 1162}
1155#endif 1163#endif
1156 1164
1165/* VARARGS 1 */
1166static void
1167boot_error (struct Lisp_Process *p, const char *m, ...)
1168{
1169 va_list ap;
1170 va_start (ap, m);
1171 if (p->is_non_blocking_client)
1172 pset_status (p, list2 (Qfailed, vformat_string (m, ap)));
1173 else
1174 verror (m, ap);
1175}
1176
1177Lisp_Object
1178gnutls_verify_boot (Lisp_Object proc, Lisp_Object proplist)
1179{
1180 int ret;
1181 struct Lisp_Process *p = XPROCESS (proc);
1182 gnutls_session_t state = p->gnutls_state;
1183 unsigned int peer_verification;
1184 Lisp_Object warnings;
1185 int max_log_level = p->gnutls_log_level;
1186 Lisp_Object hostname, verify_error;
1187 bool verify_error_all = 0;
1188 char *c_hostname;
1189
1190 if (NILP (proplist))
1191 proplist = Fcdr (Fplist_get (p->childp, QCtls_parameters));
1192
1193 verify_error = Fplist_get (proplist, QCgnutls_bootprop_verify_error);
1194 hostname = Fplist_get (proplist, QCgnutls_bootprop_hostname);
1195
1196 if (EQ (verify_error, Qt))
1197 {
1198 verify_error_all = 1;
1199 }
1200 else if (NILP (Flistp (verify_error)))
1201 {
1202 boot_error (p, "gnutls-boot: invalid :verify_error parameter (not a list)");
1203 return Qnil;
1204 }
1205
1206 if (!STRINGP (hostname))
1207 {
1208 boot_error (p, "gnutls-boot: invalid :hostname parameter (not a string)");
1209 return Qnil;
1210 }
1211 c_hostname = SSDATA (hostname);
1212
1213 /* Now verify the peer, following
1214 http://www.gnu.org/software/gnutls/manual/html_node/Verifying-peer_0027s-certificate.html.
1215 The peer should present at least one certificate in the chain; do a
1216 check of the certificate's hostname with
1217 gnutls_x509_crt_check_hostname against :hostname. */
1218
1219 ret = gnutls_certificate_verify_peers2 (state, &peer_verification);
1220 if (ret < GNUTLS_E_SUCCESS)
1221 return gnutls_make_error (ret);
1222
1223 XPROCESS (proc)->gnutls_peer_verification = peer_verification;
1224
1225 warnings = Fplist_get (Fgnutls_peer_status (proc), intern (":warnings"));
1226 if (!NILP (warnings))
1227 {
1228 Lisp_Object tail;
1229 for (tail = warnings; CONSP (tail); tail = XCDR (tail))
1230 {
1231 Lisp_Object warning = XCAR (tail);
1232 Lisp_Object message = Fgnutls_peer_status_warning_describe (warning);
1233 if (!NILP (message))
1234 GNUTLS_LOG2 (1, max_log_level, "verification:", SSDATA (message));
1235 }
1236 }
1237
1238 if (peer_verification != 0)
1239 {
1240 if (verify_error_all
1241 || !NILP (Fmember (QCgnutls_bootprop_trustfiles, verify_error)))
1242 {
1243 emacs_gnutls_deinit (proc);
1244 boot_error (p, "Certificate validation failed %s, verification code %x",
1245 c_hostname, peer_verification);
1246 return Qnil;
1247 }
1248 else
1249 {
1250 GNUTLS_LOG2 (1, max_log_level, "certificate validation failed:",
1251 c_hostname);
1252 }
1253 }
1254
1255 /* Up to here the process is the same for X.509 certificates and
1256 OpenPGP keys. From now on X.509 certificates are assumed. This
1257 can be easily extended to work with openpgp keys as well. */
1258 if (gnutls_certificate_type_get (state) == GNUTLS_CRT_X509)
1259 {
1260 gnutls_x509_crt_t gnutls_verify_cert;
1261 const gnutls_datum_t *gnutls_verify_cert_list;
1262 unsigned int gnutls_verify_cert_list_size;
1263
1264 ret = gnutls_x509_crt_init (&gnutls_verify_cert);
1265 if (ret < GNUTLS_E_SUCCESS)
1266 return gnutls_make_error (ret);
1267
1268 gnutls_verify_cert_list =
1269 gnutls_certificate_get_peers (state, &gnutls_verify_cert_list_size);
1270
1271 if (gnutls_verify_cert_list == NULL)
1272 {
1273 gnutls_x509_crt_deinit (gnutls_verify_cert);
1274 emacs_gnutls_deinit (proc);
1275 boot_error (p, "No x509 certificate was found\n");
1276 return Qnil;
1277 }
1278
1279 /* We only check the first certificate in the given chain. */
1280 ret = gnutls_x509_crt_import (gnutls_verify_cert,
1281 &gnutls_verify_cert_list[0],
1282 GNUTLS_X509_FMT_DER);
1283
1284 if (ret < GNUTLS_E_SUCCESS)
1285 {
1286 gnutls_x509_crt_deinit (gnutls_verify_cert);
1287 return gnutls_make_error (ret);
1288 }
1289
1290 XPROCESS (proc)->gnutls_certificate = gnutls_verify_cert;
1291
1292 int err = gnutls_x509_crt_check_hostname (gnutls_verify_cert,
1293 c_hostname);
1294 check_memory_full (err);
1295 if (!err)
1296 {
1297 XPROCESS (proc)->gnutls_extra_peer_verification |=
1298 CERTIFICATE_NOT_MATCHING;
1299 if (verify_error_all
1300 || !NILP (Fmember (QCgnutls_bootprop_hostname, verify_error)))
1301 {
1302 gnutls_x509_crt_deinit (gnutls_verify_cert);
1303 emacs_gnutls_deinit (proc);
1304 boot_error (p, "The x509 certificate does not match \"%s\"", c_hostname);
1305 return Qnil;
1306 }
1307 else
1308 {
1309 GNUTLS_LOG2 (1, max_log_level, "x509 certificate does not match:",
1310 c_hostname);
1311 }
1312 }
1313 }
1314
1315 /* Set this flag only if the whole initialization succeeded. */
1316 XPROCESS (proc)->gnutls_p = 1;
1317
1318 return gnutls_make_error (ret);
1319}
1320
1157DEFUN ("gnutls-boot", Fgnutls_boot, Sgnutls_boot, 3, 3, 0, 1321DEFUN ("gnutls-boot", Fgnutls_boot, Sgnutls_boot, 3, 3, 0,
1158 doc: /* Initialize GnuTLS client for process PROC with TYPE+PROPLIST. 1322 doc: /* Initialize GnuTLS client for process PROC with TYPE+PROPLIST.
1159Currently only client mode is supported. Return a success/failure 1323Currently only client mode is supported. Return a success/failure
@@ -1212,14 +1376,12 @@ one trustfile (usually a CA bundle). */)
1212{ 1376{
1213 int ret = GNUTLS_E_SUCCESS; 1377 int ret = GNUTLS_E_SUCCESS;
1214 int max_log_level = 0; 1378 int max_log_level = 0;
1215 bool verify_error_all = 0;
1216 1379
1217 gnutls_session_t state; 1380 gnutls_session_t state;
1218 gnutls_certificate_credentials_t x509_cred = NULL; 1381 gnutls_certificate_credentials_t x509_cred = NULL;
1219 gnutls_anon_client_credentials_t anon_cred = NULL; 1382 gnutls_anon_client_credentials_t anon_cred = NULL;
1220 Lisp_Object global_init; 1383 Lisp_Object global_init;
1221 char const *priority_string_ptr = "NORMAL"; /* default priority string. */ 1384 char const *priority_string_ptr = "NORMAL"; /* default priority string. */
1222 unsigned int peer_verification;
1223 char *c_hostname; 1385 char *c_hostname;
1224 1386
1225 /* Placeholders for the property list elements. */ 1387 /* Placeholders for the property list elements. */
@@ -1230,19 +1392,24 @@ one trustfile (usually a CA bundle). */)
1230 /* Lisp_Object callbacks; */ 1392 /* Lisp_Object callbacks; */
1231 Lisp_Object loglevel; 1393 Lisp_Object loglevel;
1232 Lisp_Object hostname; 1394 Lisp_Object hostname;
1233 Lisp_Object verify_error;
1234 Lisp_Object prime_bits; 1395 Lisp_Object prime_bits;
1235 Lisp_Object warnings; 1396 struct Lisp_Process *p = XPROCESS (proc);
1236 1397
1237 CHECK_PROCESS (proc); 1398 CHECK_PROCESS (proc);
1238 CHECK_SYMBOL (type); 1399 CHECK_SYMBOL (type);
1239 CHECK_LIST (proplist); 1400 CHECK_LIST (proplist);
1240 1401
1241 if (NILP (Fgnutls_available_p ())) 1402 if (NILP (Fgnutls_available_p ()))
1242 error ("GnuTLS not available"); 1403 {
1404 boot_error (p, "GnuTLS not available");
1405 return Qnil;
1406 }
1243 1407
1244 if (!EQ (type, Qgnutls_x509pki) && !EQ (type, Qgnutls_anon)) 1408 if (!EQ (type, Qgnutls_x509pki) && !EQ (type, Qgnutls_anon))
1245 error ("Invalid GnuTLS credential type"); 1409 {
1410 boot_error (p, "Invalid GnuTLS credential type");
1411 return Qnil;
1412 }
1246 1413
1247 hostname = Fplist_get (proplist, QCgnutls_bootprop_hostname); 1414 hostname = Fplist_get (proplist, QCgnutls_bootprop_hostname);
1248 priority_string = Fplist_get (proplist, QCgnutls_bootprop_priority); 1415 priority_string = Fplist_get (proplist, QCgnutls_bootprop_priority);
@@ -1250,20 +1417,13 @@ one trustfile (usually a CA bundle). */)
1250 keylist = Fplist_get (proplist, QCgnutls_bootprop_keylist); 1417 keylist = Fplist_get (proplist, QCgnutls_bootprop_keylist);
1251 crlfiles = Fplist_get (proplist, QCgnutls_bootprop_crlfiles); 1418 crlfiles = Fplist_get (proplist, QCgnutls_bootprop_crlfiles);
1252 loglevel = Fplist_get (proplist, QCgnutls_bootprop_loglevel); 1419 loglevel = Fplist_get (proplist, QCgnutls_bootprop_loglevel);
1253 verify_error = Fplist_get (proplist, QCgnutls_bootprop_verify_error);
1254 prime_bits = Fplist_get (proplist, QCgnutls_bootprop_min_prime_bits); 1420 prime_bits = Fplist_get (proplist, QCgnutls_bootprop_min_prime_bits);
1255 1421
1256 if (EQ (verify_error, Qt)) 1422 if (!STRINGP (hostname))
1257 {
1258 verify_error_all = 1;
1259 }
1260 else if (NILP (Flistp (verify_error)))
1261 { 1423 {
1262 error ("gnutls-boot: invalid :verify_error parameter (not a list)"); 1424 boot_error (p, "gnutls-boot: invalid :hostname parameter (not a string)");
1425 return Qnil;
1263 } 1426 }
1264
1265 if (!STRINGP (hostname))
1266 error ("gnutls-boot: invalid :hostname parameter (not a string)");
1267 c_hostname = SSDATA (hostname); 1427 c_hostname = SSDATA (hostname);
1268 1428
1269 state = XPROCESS (proc)->gnutls_state; 1429 state = XPROCESS (proc)->gnutls_state;
@@ -1371,7 +1531,8 @@ one trustfile (usually a CA bundle). */)
1371 else 1531 else
1372 { 1532 {
1373 emacs_gnutls_deinit (proc); 1533 emacs_gnutls_deinit (proc);
1374 error ("Invalid trustfile"); 1534 boot_error (p, "Invalid trustfile");
1535 return Qnil;
1375 } 1536 }
1376 } 1537 }
1377 1538
@@ -1395,7 +1556,8 @@ one trustfile (usually a CA bundle). */)
1395 else 1556 else
1396 { 1557 {
1397 emacs_gnutls_deinit (proc); 1558 emacs_gnutls_deinit (proc);
1398 error ("Invalid CRL file"); 1559 boot_error (p, "Invalid CRL file");
1560 return Qnil;
1399 } 1561 }
1400 } 1562 }
1401 1563
@@ -1424,8 +1586,9 @@ one trustfile (usually a CA bundle). */)
1424 else 1586 else
1425 { 1587 {
1426 emacs_gnutls_deinit (proc); 1588 emacs_gnutls_deinit (proc);
1427 error (STRINGP (keyfile) ? "Invalid client cert file" 1589 boot_error (p, STRINGP (keyfile) ? "Invalid client cert file"
1428 : "Invalid client key file"); 1590 : "Invalid client key file");
1591 return Qnil;
1429 } 1592 }
1430 } 1593 }
1431 } 1594 }
@@ -1484,109 +1647,7 @@ one trustfile (usually a CA bundle). */)
1484 if (ret < GNUTLS_E_SUCCESS) 1647 if (ret < GNUTLS_E_SUCCESS)
1485 return gnutls_make_error (ret); 1648 return gnutls_make_error (ret);
1486 1649
1487 /* Now verify the peer, following 1650 return gnutls_verify_boot (proc, proplist);
1488 http://www.gnu.org/software/gnutls/manual/html_node/Verifying-peer_0027s-certificate.html.
1489 The peer should present at least one certificate in the chain; do a
1490 check of the certificate's hostname with
1491 gnutls_x509_crt_check_hostname against :hostname. */
1492
1493 ret = gnutls_certificate_verify_peers2 (state, &peer_verification);
1494 if (ret < GNUTLS_E_SUCCESS)
1495 return gnutls_make_error (ret);
1496
1497 XPROCESS (proc)->gnutls_peer_verification = peer_verification;
1498
1499 warnings = Fplist_get (Fgnutls_peer_status (proc), intern (":warnings"));
1500 if (!NILP (warnings))
1501 {
1502 Lisp_Object tail;
1503 for (tail = warnings; CONSP (tail); tail = XCDR (tail))
1504 {
1505 Lisp_Object warning = XCAR (tail);
1506 Lisp_Object message = Fgnutls_peer_status_warning_describe (warning);
1507 if (!NILP (message))
1508 GNUTLS_LOG2 (1, max_log_level, "verification:", SSDATA (message));
1509 }
1510 }
1511
1512 if (peer_verification != 0)
1513 {
1514 if (verify_error_all
1515 || !NILP (Fmember (QCgnutls_bootprop_trustfiles, verify_error)))
1516 {
1517 emacs_gnutls_deinit (proc);
1518 error ("Certificate validation failed %s, verification code %x",
1519 c_hostname, peer_verification);
1520 }
1521 else
1522 {
1523 GNUTLS_LOG2 (1, max_log_level, "certificate validation failed:",
1524 c_hostname);
1525 }
1526 }
1527
1528 /* Up to here the process is the same for X.509 certificates and
1529 OpenPGP keys. From now on X.509 certificates are assumed. This
1530 can be easily extended to work with openpgp keys as well. */
1531 if (gnutls_certificate_type_get (state) == GNUTLS_CRT_X509)
1532 {
1533 gnutls_x509_crt_t gnutls_verify_cert;
1534 const gnutls_datum_t *gnutls_verify_cert_list;
1535 unsigned int gnutls_verify_cert_list_size;
1536
1537 ret = gnutls_x509_crt_init (&gnutls_verify_cert);
1538 if (ret < GNUTLS_E_SUCCESS)
1539 return gnutls_make_error (ret);
1540
1541 gnutls_verify_cert_list =
1542 gnutls_certificate_get_peers (state, &gnutls_verify_cert_list_size);
1543
1544 if (gnutls_verify_cert_list == NULL)
1545 {
1546 gnutls_x509_crt_deinit (gnutls_verify_cert);
1547 emacs_gnutls_deinit (proc);
1548 error ("No x509 certificate was found\n");
1549 }
1550
1551 /* We only check the first certificate in the given chain. */
1552 ret = gnutls_x509_crt_import (gnutls_verify_cert,
1553 &gnutls_verify_cert_list[0],
1554 GNUTLS_X509_FMT_DER);
1555
1556 if (ret < GNUTLS_E_SUCCESS)
1557 {
1558 gnutls_x509_crt_deinit (gnutls_verify_cert);
1559 return gnutls_make_error (ret);
1560 }
1561
1562 XPROCESS (proc)->gnutls_certificate = gnutls_verify_cert;
1563
1564 int err = gnutls_x509_crt_check_hostname (gnutls_verify_cert,
1565 c_hostname);
1566 check_memory_full (err);
1567 if (!err)
1568 {
1569 XPROCESS (proc)->gnutls_extra_peer_verification |=
1570 CERTIFICATE_NOT_MATCHING;
1571 if (verify_error_all
1572 || !NILP (Fmember (QCgnutls_bootprop_hostname, verify_error)))
1573 {
1574 gnutls_x509_crt_deinit (gnutls_verify_cert);
1575 emacs_gnutls_deinit (proc);
1576 error ("The x509 certificate does not match \"%s\"", c_hostname);
1577 }
1578 else
1579 {
1580 GNUTLS_LOG2 (1, max_log_level, "x509 certificate does not match:",
1581 c_hostname);
1582 }
1583 }
1584 }
1585
1586 /* Set this flag only if the whole initialization succeeded. */
1587 XPROCESS (proc)->gnutls_p = 1;
1588
1589 return gnutls_make_error (ret);
1590} 1651}
1591 1652
1592DEFUN ("gnutls-bye", Fgnutls_bye, 1653DEFUN ("gnutls-bye", Fgnutls_bye,
@@ -1693,6 +1754,7 @@ syms_of_gnutls (void)
1693 make_number (GNUTLS_E_APPLICATION_ERROR_MIN)); 1754 make_number (GNUTLS_E_APPLICATION_ERROR_MIN));
1694 1755
1695 defsubr (&Sgnutls_get_initstage); 1756 defsubr (&Sgnutls_get_initstage);
1757 defsubr (&Sgnutls_asynchronous_parameters);
1696 defsubr (&Sgnutls_errorp); 1758 defsubr (&Sgnutls_errorp);
1697 defsubr (&Sgnutls_error_fatalp); 1759 defsubr (&Sgnutls_error_fatalp);
1698 defsubr (&Sgnutls_error_string); 1760 defsubr (&Sgnutls_error_string);
diff --git a/src/gnutls.h b/src/gnutls.h
index 8e879c168bd..d03332ec2b6 100644
--- a/src/gnutls.h
+++ b/src/gnutls.h
@@ -84,6 +84,8 @@ extern void emacs_gnutls_transport_set_errno (gnutls_session_t state, int err);
84#endif 84#endif
85extern Lisp_Object emacs_gnutls_deinit (Lisp_Object); 85extern Lisp_Object emacs_gnutls_deinit (Lisp_Object);
86extern Lisp_Object emacs_gnutls_global_init (void); 86extern Lisp_Object emacs_gnutls_global_init (void);
87extern int gnutls_try_handshake (struct Lisp_Process *p);
88extern Lisp_Object gnutls_verify_boot (Lisp_Object proc, Lisp_Object proplist);
87 89
88#endif 90#endif
89 91
diff --git a/src/lisp.h b/src/lisp.h
index 8aa286159d7..18d986441f0 100644
--- a/src/lisp.h
+++ b/src/lisp.h
@@ -3906,6 +3906,8 @@ extern Lisp_Object unbind_to (ptrdiff_t, Lisp_Object);
3906extern _Noreturn void error (const char *, ...) ATTRIBUTE_FORMAT_PRINTF (1, 2); 3906extern _Noreturn void error (const char *, ...) ATTRIBUTE_FORMAT_PRINTF (1, 2);
3907extern _Noreturn void verror (const char *, va_list) 3907extern _Noreturn void verror (const char *, va_list)
3908 ATTRIBUTE_FORMAT_PRINTF (1, 0); 3908 ATTRIBUTE_FORMAT_PRINTF (1, 0);
3909extern Lisp_Object vformat_string (const char *, va_list)
3910 ATTRIBUTE_FORMAT_PRINTF (1, 0);
3909extern void un_autoload (Lisp_Object); 3911extern void un_autoload (Lisp_Object);
3910extern Lisp_Object call_debugger (Lisp_Object arg); 3912extern Lisp_Object call_debugger (Lisp_Object arg);
3911extern void *near_C_stack_top (void); 3913extern void *near_C_stack_top (void);
diff --git a/src/process.c b/src/process.c
index 1eac5e12663..c881a20790e 100644
--- a/src/process.c
+++ b/src/process.c
@@ -281,6 +281,7 @@ static int max_input_desc;
281 281
282/* Indexed by descriptor, gives the process (if any) for that descriptor. */ 282/* Indexed by descriptor, gives the process (if any) for that descriptor. */
283static Lisp_Object chan_process[FD_SETSIZE]; 283static Lisp_Object chan_process[FD_SETSIZE];
284static void wait_for_socket_fds (Lisp_Object process, char *name);
284 285
285/* Alist of elements (NAME . PROCESS). */ 286/* Alist of elements (NAME . PROCESS). */
286static Lisp_Object Vprocess_alist; 287static Lisp_Object Vprocess_alist;
@@ -381,11 +382,6 @@ pset_sentinel (struct Lisp_Process *p, Lisp_Object val)
381 p->sentinel = NILP (val) ? Qinternal_default_process_sentinel : val; 382 p->sentinel = NILP (val) ? Qinternal_default_process_sentinel : val;
382} 383}
383static void 384static void
384pset_status (struct Lisp_Process *p, Lisp_Object val)
385{
386 p->status = val;
387}
388static void
389pset_tty_name (struct Lisp_Process *p, Lisp_Object val) 385pset_tty_name (struct Lisp_Process *p, Lisp_Object val)
390{ 386{
391 p->tty_name = val; 387 p->tty_name = val;
@@ -711,6 +707,7 @@ make_process (Lisp_Object name)
711 707
712#ifdef HAVE_GNUTLS 708#ifdef HAVE_GNUTLS
713 p->gnutls_initstage = GNUTLS_STAGE_EMPTY; 709 p->gnutls_initstage = GNUTLS_STAGE_EMPTY;
710 p->gnutls_boot_parameters = Qnil;
714#endif 711#endif
715 712
716 /* If name is already in use, modify it until it is unused. */ 713 /* If name is already in use, modify it until it is unused. */
@@ -742,6 +739,23 @@ remove_process (register Lisp_Object proc)
742 deactivate_process (proc); 739 deactivate_process (proc);
743} 740}
744 741
742#ifdef HAVE_GETADDRINFO_A
743static void
744free_dns_request (Lisp_Object proc)
745{
746 struct Lisp_Process *p = XPROCESS (proc);
747
748 if (p->dns_requests[0]->ar_result)
749 freeaddrinfo (p->dns_requests[0]->ar_result);
750 xfree ((void *)p->dns_requests[0]->ar_request);
751 xfree ((void *)p->dns_requests[0]->ar_name);
752 xfree ((void *)p->dns_requests[0]->ar_service);
753 xfree (p->dns_requests[0]);
754 xfree (p->dns_requests);
755 p->dns_requests = NULL;
756}
757#endif
758
745 759
746DEFUN ("processp", Fprocessp, Sprocessp, 1, 1, 0, 760DEFUN ("processp", Fprocessp, Sprocessp, 1, 1, 0,
747 doc: /* Return t if OBJECT is a process. */) 761 doc: /* Return t if OBJECT is a process. */)
@@ -832,6 +846,14 @@ nil, indicating the current buffer's process. */)
832 process = get_process (process); 846 process = get_process (process);
833 p = XPROCESS (process); 847 p = XPROCESS (process);
834 848
849#ifdef HAVE_GETADDRINFO_A
850 if (p->dns_requests)
851 {
852 gai_cancel (p->dns_requests[0]);
853 free_dns_request (process);
854 }
855#endif
856
835 p->raw_status_new = 0; 857 p->raw_status_new = 0;
836 if (NETCONN1_P (p) || SERIALCONN1_P (p) || PIPECONN1_P (p)) 858 if (NETCONN1_P (p) || SERIALCONN1_P (p) || PIPECONN1_P (p))
837 { 859 {
@@ -1008,6 +1030,23 @@ DEFUN ("process-mark", Fprocess_mark, Sprocess_mark,
1008 return XPROCESS (process)->mark; 1030 return XPROCESS (process)->mark;
1009} 1031}
1010 1032
1033static void
1034set_process_filter_masks (struct Lisp_Process *p)
1035{
1036 if (EQ (p->filter, Qt) && !EQ (p->status, Qlisten))
1037 {
1038 FD_CLR (p->infd, &input_wait_mask);
1039 FD_CLR (p->infd, &non_keyboard_wait_mask);
1040 }
1041 else if (EQ (p->filter, Qt)
1042 /* Network or serial process not stopped: */
1043 && !EQ (p->command, Qt))
1044 {
1045 FD_SET (p->infd, &input_wait_mask);
1046 FD_SET (p->infd, &non_keyboard_wait_mask);
1047 }
1048}
1049
1011DEFUN ("set-process-filter", Fset_process_filter, Sset_process_filter, 1050DEFUN ("set-process-filter", Fset_process_filter, Sset_process_filter,
1012 2, 2, 0, 1051 2, 2, 0,
1013 doc: /* Give PROCESS the filter function FILTER; nil means default. 1052 doc: /* Give PROCESS the filter function FILTER; nil means default.
@@ -1029,6 +1068,7 @@ The string argument is normally a multibyte string, except:
1029 struct Lisp_Process *p; 1068 struct Lisp_Process *p;
1030 1069
1031 CHECK_PROCESS (process); 1070 CHECK_PROCESS (process);
1071
1032 p = XPROCESS (process); 1072 p = XPROCESS (process);
1033 1073
1034 /* Don't signal an error if the process's input file descriptor 1074 /* Don't signal an error if the process's input file descriptor
@@ -1042,23 +1082,11 @@ The string argument is normally a multibyte string, except:
1042 if (NILP (filter)) 1082 if (NILP (filter))
1043 filter = Qinternal_default_process_filter; 1083 filter = Qinternal_default_process_filter;
1044 1084
1085 pset_filter (p, filter);
1086
1045 if (p->infd >= 0) 1087 if (p->infd >= 0)
1046 { 1088 set_process_filter_masks (p);
1047 if (EQ (filter, Qt) && !EQ (p->status, Qlisten))
1048 {
1049 FD_CLR (p->infd, &input_wait_mask);
1050 FD_CLR (p->infd, &non_keyboard_wait_mask);
1051 }
1052 else if (EQ (p->filter, Qt)
1053 /* Network or serial process not stopped: */
1054 && !EQ (p->command, Qt))
1055 {
1056 FD_SET (p->infd, &input_wait_mask);
1057 FD_SET (p->infd, &non_keyboard_wait_mask);
1058 }
1059 }
1060 1089
1061 pset_filter (p, filter);
1062 if (NETCONN1_P (p) || SERIALCONN1_P (p) || PIPECONN1_P (p)) 1090 if (NETCONN1_P (p) || SERIALCONN1_P (p) || PIPECONN1_P (p))
1063 pset_childp (p, Fplist_put (p->childp, QCfilter, filter)); 1091 pset_childp (p, Fplist_put (p->childp, QCfilter, filter));
1064 setup_process_coding_systems (process); 1092 setup_process_coding_systems (process);
@@ -1117,7 +1145,8 @@ DEFUN ("set-process-window-size", Fset_process_window_size,
1117 CHECK_RANGED_INTEGER (height, 0, USHRT_MAX); 1145 CHECK_RANGED_INTEGER (height, 0, USHRT_MAX);
1118 CHECK_RANGED_INTEGER (width, 0, USHRT_MAX); 1146 CHECK_RANGED_INTEGER (width, 0, USHRT_MAX);
1119 1147
1120 if (XPROCESS (process)->infd < 0 1148 if (NETCONN_P (process)
1149 || XPROCESS (process)->infd < 0
1121 || (set_window_size (XPROCESS (process)->infd, 1150 || (set_window_size (XPROCESS (process)->infd,
1122 XINT (height), XINT (width)) 1151 XINT (height), XINT (width))
1123 < 0)) 1152 < 0))
@@ -1185,7 +1214,9 @@ SERVICE) for a network connection or (PORT SPEED) for a serial
1185connection. If KEY is t, the complete contact information for the 1214connection. If KEY is t, the complete contact information for the
1186connection is returned, else the specific value for the keyword KEY is 1215connection is returned, else the specific value for the keyword KEY is
1187returned. See `make-network-process' or `make-serial-process' for a 1216returned. See `make-network-process' or `make-serial-process' for a
1188list of keywords. */) 1217list of keywords.
1218If PROCESS is a non-blocking network process that hasn't been fully
1219set up yet, this function will block until socket setup has completed. */)
1189 (register Lisp_Object process, Lisp_Object key) 1220 (register Lisp_Object process, Lisp_Object key)
1190{ 1221{
1191 Lisp_Object contact; 1222 Lisp_Object contact;
@@ -1194,6 +1225,10 @@ list of keywords. */)
1194 contact = XPROCESS (process)->childp; 1225 contact = XPROCESS (process)->childp;
1195 1226
1196#ifdef DATAGRAM_SOCKETS 1227#ifdef DATAGRAM_SOCKETS
1228
1229 if (NETCONN_P (process))
1230 wait_for_socket_fds (process, "process-contact");
1231
1197 if (DATAGRAM_CONN_P (process) 1232 if (DATAGRAM_CONN_P (process)
1198 && (EQ (key, Qt) || EQ (key, QCremote))) 1233 && (EQ (key, Qt) || EQ (key, QCremote)))
1199 contact = Fplist_put (contact, QCremote, 1234 contact = Fplist_put (contact, QCremote,
@@ -2416,13 +2451,18 @@ conv_lisp_to_sockaddr (int family, Lisp_Object address, struct sockaddr *sa, int
2416#ifdef DATAGRAM_SOCKETS 2451#ifdef DATAGRAM_SOCKETS
2417DEFUN ("process-datagram-address", Fprocess_datagram_address, Sprocess_datagram_address, 2452DEFUN ("process-datagram-address", Fprocess_datagram_address, Sprocess_datagram_address,
2418 1, 1, 0, 2453 1, 1, 0,
2419 doc: /* Get the current datagram address associated with PROCESS. */) 2454 doc: /* Get the current datagram address associated with PROCESS.
2455If PROCESS is a non-blocking network process that hasn't been fully
2456set up yet, this function will block until socket setup has completed. */)
2420 (Lisp_Object process) 2457 (Lisp_Object process)
2421{ 2458{
2422 int channel; 2459 int channel;
2423 2460
2424 CHECK_PROCESS (process); 2461 CHECK_PROCESS (process);
2425 2462
2463 if (NETCONN_P (process))
2464 wait_for_socket_fds (process, "process-datagram-address");
2465
2426 if (!DATAGRAM_CONN_P (process)) 2466 if (!DATAGRAM_CONN_P (process))
2427 return Qnil; 2467 return Qnil;
2428 2468
@@ -2434,7 +2474,10 @@ DEFUN ("process-datagram-address", Fprocess_datagram_address, Sprocess_datagram_
2434DEFUN ("set-process-datagram-address", Fset_process_datagram_address, Sset_process_datagram_address, 2474DEFUN ("set-process-datagram-address", Fset_process_datagram_address, Sset_process_datagram_address,
2435 2, 2, 0, 2475 2, 2, 0,
2436 doc: /* Set the datagram address for PROCESS to ADDRESS. 2476 doc: /* Set the datagram address for PROCESS to ADDRESS.
2437Returns nil upon error setting address, ADDRESS otherwise. */) 2477Returns nil upon error setting address, ADDRESS otherwise.
2478
2479If PROCESS is a non-blocking network process that hasn't been fully
2480set up yet, this function will block until socket setup has completed. */)
2438 (Lisp_Object process, Lisp_Object address) 2481 (Lisp_Object process, Lisp_Object address)
2439{ 2482{
2440 int channel; 2483 int channel;
@@ -2442,6 +2485,9 @@ Returns nil upon error setting address, ADDRESS otherwise. */)
2442 2485
2443 CHECK_PROCESS (process); 2486 CHECK_PROCESS (process);
2444 2487
2488 if (NETCONN_P (process))
2489 wait_for_socket_fds (process, "set-process-datagram-address");
2490
2445 if (!DATAGRAM_CONN_P (process)) 2491 if (!DATAGRAM_CONN_P (process))
2446 return Qnil; 2492 return Qnil;
2447 2493
@@ -2599,7 +2645,10 @@ DEFUN ("set-network-process-option",
2599 doc: /* For network process PROCESS set option OPTION to value VALUE. 2645 doc: /* For network process PROCESS set option OPTION to value VALUE.
2600See `make-network-process' for a list of options and values. 2646See `make-network-process' for a list of options and values.
2601If optional fourth arg NO-ERROR is non-nil, don't signal an error if 2647If optional fourth arg NO-ERROR is non-nil, don't signal an error if
2602OPTION is not a supported option, return nil instead; otherwise return t. */) 2648OPTION is not a supported option, return nil instead; otherwise return t.
2649
2650If PROCESS is a non-blocking network process that hasn't been fully
2651set up yet, this function will block until socket setup has completed. */)
2603 (Lisp_Object process, Lisp_Object option, Lisp_Object value, Lisp_Object no_error) 2652 (Lisp_Object process, Lisp_Object option, Lisp_Object value, Lisp_Object no_error)
2604{ 2653{
2605 int s; 2654 int s;
@@ -2610,6 +2659,8 @@ OPTION is not a supported option, return nil instead; otherwise return t. */)
2610 if (!NETCONN1_P (p)) 2659 if (!NETCONN1_P (p))
2611 error ("Process is not a network process"); 2660 error ("Process is not a network process");
2612 2661
2662 wait_for_socket_fds (process, "set-network-process-option");
2663
2613 s = p->infd; 2664 s = p->infd;
2614 if (s < 0) 2665 if (s < 0)
2615 error ("Process is not running"); 2666 error ("Process is not running");
@@ -2904,6 +2955,487 @@ usage: (make-serial-process &rest ARGS) */)
2904 return proc; 2955 return proc;
2905} 2956}
2906 2957
2958void set_network_socket_coding_system (Lisp_Object proc,
2959 Lisp_Object host,
2960 Lisp_Object service,
2961 Lisp_Object name)
2962{
2963 Lisp_Object tem;
2964 struct Lisp_Process *p = XPROCESS (proc);
2965 Lisp_Object contact = p->childp;
2966 Lisp_Object coding_systems = Qt;
2967 Lisp_Object val;
2968
2969 tem = Fplist_member (contact, QCcoding);
2970 if (!NILP (tem) && (!CONSP (tem) || !CONSP (XCDR (tem))))
2971 tem = Qnil; /* No error message (too late!). */
2972
2973 /* Setup coding systems for communicating with the network stream. */
2974 /* Qt denotes we have not yet called Ffind_operation_coding_system. */
2975
2976 if (!NILP (tem))
2977 {
2978 val = XCAR (XCDR (tem));
2979 if (CONSP (val))
2980 val = XCAR (val);
2981 }
2982 else if (!NILP (Vcoding_system_for_read))
2983 val = Vcoding_system_for_read;
2984 else if ((!NILP (p->buffer) &&
2985 NILP (BVAR (XBUFFER (p->buffer), enable_multibyte_characters)))
2986 || (NILP (p->buffer) && NILP (BVAR (&buffer_defaults, enable_multibyte_characters))))
2987 /* We dare not decode end-of-line format by setting VAL to
2988 Qraw_text, because the existing Emacs Lisp libraries
2989 assume that they receive bare code including a sequence of
2990 CR LF. */
2991 val = Qnil;
2992 else
2993 {
2994 if (NILP (host) || NILP (service))
2995 coding_systems = Qnil;
2996 else
2997 coding_systems = CALLN (Ffind_operation_coding_system,
2998 Qopen_network_stream, name, p->buffer,
2999 host, service);
3000 if (CONSP (coding_systems))
3001 val = XCAR (coding_systems);
3002 else if (CONSP (Vdefault_process_coding_system))
3003 val = XCAR (Vdefault_process_coding_system);
3004 else
3005 val = Qnil;
3006 }
3007 pset_decode_coding_system (p, val);
3008
3009 if (!NILP (tem))
3010 {
3011 val = XCAR (XCDR (tem));
3012 if (CONSP (val))
3013 val = XCDR (val);
3014 }
3015 else if (!NILP (Vcoding_system_for_write))
3016 val = Vcoding_system_for_write;
3017 else if (NILP (BVAR (current_buffer, enable_multibyte_characters)))
3018 val = Qnil;
3019 else
3020 {
3021 if (EQ (coding_systems, Qt))
3022 {
3023 if (NILP (host) || NILP (service))
3024 coding_systems = Qnil;
3025 else
3026 coding_systems = CALLN (Ffind_operation_coding_system,
3027 Qopen_network_stream, name, p->buffer,
3028 host, service);
3029 }
3030 if (CONSP (coding_systems))
3031 val = XCDR (coding_systems);
3032 else if (CONSP (Vdefault_process_coding_system))
3033 val = XCDR (Vdefault_process_coding_system);
3034 else
3035 val = Qnil;
3036 }
3037 pset_encode_coding_system (p, val);
3038
3039 pset_decoding_buf (p, empty_unibyte_string);
3040 p->decoding_carryover = 0;
3041 pset_encoding_buf (p, empty_unibyte_string);
3042
3043 p->inherit_coding_system_flag
3044 = !(!NILP (tem) || NILP (p->buffer) || !inherit_process_coding_system);
3045}
3046
3047#ifdef HAVE_GNUTLS
3048void
3049finish_after_tls_connection (Lisp_Object proc)
3050{
3051 struct Lisp_Process *p = XPROCESS (proc);
3052 Lisp_Object contact = p->childp;
3053 Lisp_Object result = Qt;
3054
3055 if (!NILP (Ffboundp (Qnsm_verify_connection)))
3056 result = call3 (Qnsm_verify_connection,
3057 proc,
3058 Fplist_get (contact, QChost),
3059 Fplist_get (contact, QCservice));
3060
3061 if (NILP (result))
3062 {
3063 pset_status (p, list2 (Qfailed,
3064 build_string ("The Network Security Manager stopped the connections")));
3065 deactivate_process (proc);
3066 }
3067 else
3068 {
3069 /* If we cleared the connection wait mask before we did
3070 the TLS setup, then we have to say that the process
3071 is finally "open" here. */
3072 if (! FD_ISSET (p->outfd, &connect_wait_mask))
3073 {
3074 pset_status (p, Qrun);
3075 /* Execute the sentinel here. If we had relied on
3076 status_notify to do it later, it will read input
3077 from the process before calling the sentinel. */
3078 exec_sentinel (proc, build_string ("open\n"));
3079 }
3080 }
3081}
3082#endif
3083
3084void
3085connect_network_socket (Lisp_Object proc, Lisp_Object ip_addresses)
3086{
3087 ptrdiff_t count = SPECPDL_INDEX ();
3088 ptrdiff_t count1;
3089 int s = -1, outch, inch;
3090 int xerrno = 0;
3091 Lisp_Object ip_address;
3092 int family;
3093 struct sockaddr *sa = NULL;
3094 int ret;
3095 int addrlen;
3096 struct Lisp_Process *p = XPROCESS (proc);
3097 Lisp_Object contact = p->childp;
3098 int optbits = 0;
3099
3100 /* Do this in case we never enter the while-loop below. */
3101 count1 = SPECPDL_INDEX ();
3102 s = -1;
3103
3104 while (!NILP (ip_addresses))
3105 {
3106 ip_address = XCAR (ip_addresses);
3107 ip_addresses = XCDR (ip_addresses);
3108
3109#ifdef WINDOWSNT
3110 retry_connect:
3111#endif
3112
3113 addrlen = get_lisp_to_sockaddr_size (ip_address, &family);
3114 if (sa)
3115 free (sa);
3116 sa = xmalloc (addrlen);
3117 conv_lisp_to_sockaddr (family, ip_address, sa, addrlen);
3118
3119 s = socket (family, p->socktype | SOCK_CLOEXEC, p->ai_protocol);
3120 if (s < 0)
3121 {
3122 xerrno = errno;
3123 continue;
3124 }
3125
3126#ifdef DATAGRAM_SOCKETS
3127 if (!p->is_server && p->socktype == SOCK_DGRAM)
3128 break;
3129#endif /* DATAGRAM_SOCKETS */
3130
3131#ifdef NON_BLOCKING_CONNECT
3132 if (p->is_non_blocking_client)
3133 {
3134 ret = fcntl (s, F_SETFL, O_NONBLOCK);
3135 if (ret < 0)
3136 {
3137 xerrno = errno;
3138 emacs_close (s);
3139 s = -1;
3140 continue;
3141 }
3142 }
3143#endif
3144
3145 /* Make us close S if quit. */
3146 record_unwind_protect_int (close_file_unwind, s);
3147
3148 /* Parse network options in the arg list. We simply ignore anything
3149 which isn't a known option (including other keywords). An error
3150 is signaled if setting a known option fails. */
3151 {
3152 Lisp_Object params = contact, key, val;
3153
3154 while (!NILP (params))
3155 {
3156 key = XCAR (params);
3157 params = XCDR (params);
3158 val = XCAR (params);
3159 params = XCDR (params);
3160 optbits |= set_socket_option (s, key, val);
3161 }
3162 }
3163
3164 if (p->is_server)
3165 {
3166 /* Configure as a server socket. */
3167
3168 /* SO_REUSEADDR = 1 is default for server sockets; must specify
3169 explicit :reuseaddr key to override this. */
3170#ifdef HAVE_LOCAL_SOCKETS
3171 if (family != AF_LOCAL)
3172#endif
3173 if (!(optbits & (1 << OPIX_REUSEADDR)))
3174 {
3175 int optval = 1;
3176 if (setsockopt (s, SOL_SOCKET, SO_REUSEADDR, &optval, sizeof optval))
3177 report_file_error ("Cannot set reuse option on server socket", Qnil);
3178 }
3179
3180 if (bind (s, sa, addrlen))
3181 report_file_error ("Cannot bind server socket", Qnil);
3182
3183#ifdef HAVE_GETSOCKNAME
3184 if (p->port == 0)
3185 {
3186 struct sockaddr_in sa1;
3187 socklen_t len1 = sizeof (sa1);
3188 if (getsockname (s, (struct sockaddr *)&sa1, &len1) == 0)
3189 {
3190 Lisp_Object service;
3191 service = make_number (ntohs (sa1.sin_port));
3192 contact = Fplist_put (contact, QCservice, service);
3193 // Save the port number so that we can stash it in
3194 // the process object later.
3195 ((struct sockaddr_in *)sa)->sin_port = sa1.sin_port;
3196 }
3197 }
3198#endif
3199
3200 if (p->socktype != SOCK_DGRAM && listen (s, p->backlog))
3201 report_file_error ("Cannot listen on server socket", Qnil);
3202
3203 break;
3204 }
3205
3206 immediate_quit = 1;
3207 QUIT;
3208
3209 ret = connect (s, sa, addrlen);
3210 xerrno = errno;
3211
3212 if (ret == 0 || xerrno == EISCONN)
3213 {
3214 /* The unwind-protect will be discarded afterwards.
3215 Likewise for immediate_quit. */
3216 break;
3217 }
3218
3219#ifdef NON_BLOCKING_CONNECT
3220#ifdef EINPROGRESS
3221 if (p->is_non_blocking_client && xerrno == EINPROGRESS)
3222 break;
3223#else
3224#ifdef EWOULDBLOCK
3225 if (p->is_non_blocking_client && xerrno == EWOULDBLOCK)
3226 break;
3227#endif
3228#endif
3229#endif
3230
3231#ifndef WINDOWSNT
3232 if (xerrno == EINTR)
3233 {
3234 /* Unlike most other syscalls connect() cannot be called
3235 again. (That would return EALREADY.) The proper way to
3236 wait for completion is pselect(). */
3237 int sc;
3238 socklen_t len;
3239 fd_set fdset;
3240 retry_select:
3241 FD_ZERO (&fdset);
3242 FD_SET (s, &fdset);
3243 QUIT;
3244 sc = pselect (s + 1, NULL, &fdset, NULL, NULL, NULL);
3245 if (sc == -1)
3246 {
3247 if (errno == EINTR)
3248 goto retry_select;
3249 else
3250 report_file_error ("Failed select", Qnil);
3251 }
3252 eassert (sc > 0);
3253
3254 len = sizeof xerrno;
3255 eassert (FD_ISSET (s, &fdset));
3256 if (getsockopt (s, SOL_SOCKET, SO_ERROR, &xerrno, &len) < 0)
3257 report_file_error ("Failed getsockopt", Qnil);
3258 if (xerrno)
3259 report_file_errno ("Failed connect", Qnil, xerrno);
3260 break;
3261 }
3262#endif /* !WINDOWSNT */
3263
3264 immediate_quit = 0;
3265
3266 /* Discard the unwind protect closing S. */
3267 specpdl_ptr = specpdl + count1;
3268 emacs_close (s);
3269 s = -1;
3270
3271#ifdef WINDOWSNT
3272 if (xerrno == EINTR)
3273 goto retry_connect;
3274#endif
3275 }
3276
3277 if (s >= 0)
3278 {
3279#ifdef DATAGRAM_SOCKETS
3280 if (p->socktype == SOCK_DGRAM)
3281 {
3282 if (datagram_address[s].sa)
3283 emacs_abort ();
3284
3285 datagram_address[s].sa = xmalloc (addrlen);
3286 datagram_address[s].len = addrlen;
3287 if (p->is_server)
3288 {
3289 Lisp_Object remote;
3290 memset (datagram_address[s].sa, 0, addrlen);
3291 if (remote = Fplist_get (contact, QCremote), !NILP (remote))
3292 {
3293 int rfamily, rlen;
3294 rlen = get_lisp_to_sockaddr_size (remote, &rfamily);
3295 if (rlen != 0 && rfamily == family
3296 && rlen == addrlen)
3297 conv_lisp_to_sockaddr (rfamily, remote,
3298 datagram_address[s].sa, rlen);
3299 }
3300 }
3301 else
3302 memcpy (datagram_address[s].sa, sa, addrlen);
3303 }
3304#endif
3305
3306 contact = Fplist_put (contact, p->is_server? QClocal: QCremote,
3307 conv_sockaddr_to_lisp (sa, addrlen));
3308#ifdef HAVE_GETSOCKNAME
3309 if (!p->is_server)
3310 {
3311 struct sockaddr_in sa1;
3312 socklen_t len1 = sizeof (sa1);
3313 if (getsockname (s, (struct sockaddr *)&sa1, &len1) == 0)
3314 contact = Fplist_put (contact, QClocal,
3315 conv_sockaddr_to_lisp ((struct sockaddr *)&sa1, len1));
3316 }
3317#endif
3318 }
3319
3320 immediate_quit = 0;
3321
3322 if (s < 0)
3323 {
3324 /* If non-blocking got this far - and failed - assume non-blocking is
3325 not supported after all. This is probably a wrong assumption, but
3326 the normal blocking calls to open-network-stream handles this error
3327 better. */
3328 if (p->is_non_blocking_client)
3329 return;
3330
3331 report_file_errno ((p->is_server
3332 ? "make server process failed"
3333 : "make client process failed"),
3334 contact, xerrno);
3335 }
3336
3337 inch = s;
3338 outch = s;
3339
3340 chan_process[inch] = proc;
3341
3342 fcntl (inch, F_SETFL, O_NONBLOCK);
3343
3344 p = XPROCESS (proc);
3345 p->open_fd[SUBPROCESS_STDIN] = inch;
3346 p->infd = inch;
3347 p->outfd = outch;
3348
3349 /* Discard the unwind protect for closing S, if any. */
3350 specpdl_ptr = specpdl + count1;
3351
3352 /* Unwind bind_polling_period and request_sigio. */
3353 unbind_to (count, Qnil);
3354
3355 if (p->is_server && p->socktype != SOCK_DGRAM)
3356 pset_status (p, Qlisten);
3357
3358 /* Make the process marker point into the process buffer (if any). */
3359 if (BUFFERP (p->buffer))
3360 set_marker_both (p->mark, p->buffer,
3361 BUF_ZV (XBUFFER (p->buffer)),
3362 BUF_ZV_BYTE (XBUFFER (p->buffer)));
3363
3364#ifdef NON_BLOCKING_CONNECT
3365 if (p->is_non_blocking_client)
3366 {
3367 /* We may get here if connect did succeed immediately. However,
3368 in that case, we still need to signal this like a non-blocking
3369 connection. */
3370 pset_status (p, Qconnect);
3371 if (!FD_ISSET (inch, &connect_wait_mask))
3372 {
3373 FD_SET (inch, &connect_wait_mask);
3374 FD_SET (inch, &write_mask);
3375 num_pending_connects++;
3376 }
3377 }
3378 else
3379#endif
3380 /* A server may have a client filter setting of Qt, but it must
3381 still listen for incoming connects unless it is stopped. */
3382 if ((!EQ (p->filter, Qt) && !EQ (p->command, Qt))
3383 || (EQ (p->status, Qlisten) && NILP (p->command)))
3384 {
3385 FD_SET (inch, &input_wait_mask);
3386 FD_SET (inch, &non_keyboard_wait_mask);
3387 }
3388
3389 if (inch > max_process_desc)
3390 max_process_desc = inch;
3391
3392 /* Set up the masks based on the process filter. */
3393 set_process_filter_masks (p);
3394
3395 setup_process_coding_systems (proc);
3396
3397#ifdef HAVE_GNUTLS
3398 /* Continue the asynchronous connection. */
3399 if (!NILP (p->gnutls_boot_parameters))
3400 {
3401 Lisp_Object boot, params = p->gnutls_boot_parameters;
3402
3403 boot = Fgnutls_boot (proc, XCAR (params), XCDR (params));
3404 p->gnutls_boot_parameters = Qnil;
3405
3406 if (p->gnutls_initstage == GNUTLS_STAGE_READY)
3407 /* Run sentinels, etc. */
3408 finish_after_tls_connection (proc);
3409 else if (p->gnutls_initstage != GNUTLS_STAGE_HANDSHAKE_TRIED)
3410 {
3411 deactivate_process (proc);
3412 if (NILP (boot))
3413 pset_status (p, list2 (Qfailed,
3414 build_string ("TLS negotiation failed")));
3415 else
3416 pset_status (p, list2 (Qfailed, boot));
3417 }
3418 }
3419#endif
3420
3421}
3422
3423#ifndef HAVE_GETADDRINFO
3424static Lisp_Object
3425conv_numerical_to_lisp (unsigned char *number, unsigned int length, int port)
3426{
3427 Lisp_Object address = Fmake_vector (make_number (length + 1), Qnil);
3428 register struct Lisp_Vector *p = XVECTOR (address);
3429 int i;
3430
3431 p->contents[length] = make_number (port);
3432 for (i = 0; i < length; i++)
3433 p->contents[i] = make_number (*(number + i));
3434
3435 return address;
3436}
3437#endif
3438
2907/* Create a network stream/datagram client/server process. Treated 3439/* Create a network stream/datagram client/server process. Treated
2908 exactly like a normal process when reading and writing. Primary 3440 exactly like a normal process when reading and writing. Primary
2909 differences are in status display and process deletion. A network 3441 differences are in status display and process deletion. A network
@@ -2982,11 +3514,12 @@ system used for both reading and writing for this process. If CODING
2982is a cons (DECODING . ENCODING), DECODING is used for reading, and 3514is a cons (DECODING . ENCODING), DECODING is used for reading, and
2983ENCODING is used for writing. 3515ENCODING is used for writing.
2984 3516
2985:nowait BOOL -- If BOOL is non-nil for a stream type client process, 3517:nowait BOOL -- If NOWAIT is non-nil for a stream type client
2986return without waiting for the connection to complete; instead, the 3518process, return without waiting for the connection to complete;
2987sentinel function will be called with second arg matching "open" (if 3519instead, the sentinel function will be called with second arg matching
2988successful) or "failed" when the connect completes. Default is to use 3520"open" (if successful) or "failed" when the connect completes.
2989a blocking connect (i.e. wait) for stream type connections. 3521Default is to use a blocking connect (i.e. wait) for stream type
3522connections.
2990 3523
2991:noquery BOOL -- Query the user unless BOOL is non-nil, and process is 3524:noquery BOOL -- Query the user unless BOOL is non-nil, and process is
2992running when Emacs is exited. 3525running when Emacs is exited.
@@ -3014,6 +3547,12 @@ and MESSAGE is a string.
3014 3547
3015:plist PLIST -- Install PLIST as the new process's initial plist. 3548:plist PLIST -- Install PLIST as the new process's initial plist.
3016 3549
3550:tls-parameters LIST -- is a list that should be supplied if you're
3551opening a TLS connection. The first element is the TLS type (either
3552`gnutls-x509pki' or `gnutls-anon'), and the remaining elements should
3553be a keyword list accepted by gnutls-boot (as returned by
3554`gnutls-boot-parameters').
3555
3017:server QLEN -- if QLEN is non-nil, create a server process for the 3556:server QLEN -- if QLEN is non-nil, create a server process for the
3018specified FAMILY, SERVICE, and connection type (stream or datagram). 3557specified FAMILY, SERVICE, and connection type (stream or datagram).
3019If QLEN is an integer, it is used as the max. length of the server's 3558If QLEN is an integer, it is used as the max. length of the server's
@@ -3067,41 +3606,26 @@ usage: (make-network-process &rest ARGS) */)
3067 Lisp_Object proc; 3606 Lisp_Object proc;
3068 Lisp_Object contact; 3607 Lisp_Object contact;
3069 struct Lisp_Process *p; 3608 struct Lisp_Process *p;
3070#ifdef HAVE_GETADDRINFO 3609#if defined(HAVE_GETADDRINFO) || defined(HAVE_GETADDRINFO_A)
3071 struct addrinfo ai, *res, *lres; 3610 struct addrinfo *hints;
3072 struct addrinfo hints;
3073 const char *portstring; 3611 const char *portstring;
3074 char portbuf[128]; 3612 char portbuf[128];
3075#else /* HAVE_GETADDRINFO */ 3613#endif
3076 struct _emacs_addrinfo
3077 {
3078 int ai_family;
3079 int ai_socktype;
3080 int ai_protocol;
3081 int ai_addrlen;
3082 struct sockaddr *ai_addr;
3083 struct _emacs_addrinfo *ai_next;
3084 } ai, *res, *lres;
3085#endif /* HAVE_GETADDRINFO */
3086 struct sockaddr_in address_in;
3087#ifdef HAVE_LOCAL_SOCKETS 3614#ifdef HAVE_LOCAL_SOCKETS
3088 struct sockaddr_un address_un; 3615 struct sockaddr_un address_un;
3089#endif 3616#endif
3090 int port; 3617 int port = 0;
3091 int ret = 0;
3092 int xerrno = 0;
3093 int s = -1, outch, inch;
3094 ptrdiff_t count = SPECPDL_INDEX ();
3095 ptrdiff_t count1;
3096 Lisp_Object colon_address; /* Either QClocal or QCremote. */
3097 Lisp_Object tem; 3618 Lisp_Object tem;
3098 Lisp_Object name, buffer, host, service, address; 3619 Lisp_Object name, buffer, host, service, address;
3099 Lisp_Object filter, sentinel; 3620 Lisp_Object filter, sentinel;
3100 bool is_non_blocking_client = 0; 3621 Lisp_Object ip_addresses = Qnil;
3101 bool is_server = 0;
3102 int backlog = 5;
3103 int socktype; 3622 int socktype;
3104 int family = -1; 3623 int family = -1;
3624 int ai_protocol = 0;
3625#ifdef HAVE_GETADDRINFO_A
3626 struct gaicb **dns_requests = NULL;
3627#endif
3628 ptrdiff_t count = SPECPDL_INDEX ();
3105 3629
3106 if (nargs == 0) 3630 if (nargs == 0)
3107 return Qnil; 3631 return Qnil;
@@ -3129,31 +3653,6 @@ usage: (make-network-process &rest ARGS) */)
3129 else 3653 else
3130 error ("Unsupported connection type"); 3654 error ("Unsupported connection type");
3131 3655
3132 /* :server BOOL */
3133 tem = Fplist_get (contact, QCserver);
3134 if (!NILP (tem))
3135 {
3136 /* Don't support network sockets when non-blocking mode is
3137 not available, since a blocked Emacs is not useful. */
3138 is_server = 1;
3139 if (TYPE_RANGED_INTEGERP (int, tem))
3140 backlog = XINT (tem);
3141 }
3142
3143 /* Make colon_address an alias for :local (server) or :remote (client). */
3144 colon_address = is_server ? QClocal : QCremote;
3145
3146 /* :nowait BOOL */
3147 if (!is_server && socktype != SOCK_DGRAM
3148 && (tem = Fplist_get (contact, QCnowait), !NILP (tem)))
3149 {
3150#ifndef NON_BLOCKING_CONNECT
3151 error ("Non-blocking connect not supported");
3152#else
3153 is_non_blocking_client = 1;
3154#endif
3155 }
3156
3157 name = Fplist_get (contact, QCname); 3656 name = Fplist_get (contact, QCname);
3158 buffer = Fplist_get (contact, QCbuffer); 3657 buffer = Fplist_get (contact, QCbuffer);
3159 filter = Fplist_get (contact, QCfilter); 3658 filter = Fplist_get (contact, QCfilter);
@@ -3161,23 +3660,20 @@ usage: (make-network-process &rest ARGS) */)
3161 3660
3162 CHECK_STRING (name); 3661 CHECK_STRING (name);
3163 3662
3164 /* Initialize addrinfo structure in case we don't use getaddrinfo. */
3165 ai.ai_socktype = socktype;
3166 ai.ai_protocol = 0;
3167 ai.ai_next = NULL;
3168 res = &ai;
3169
3170 /* :local ADDRESS or :remote ADDRESS */ 3663 /* :local ADDRESS or :remote ADDRESS */
3171 address = Fplist_get (contact, colon_address); 3664 tem = Fplist_get (contact, QCserver);
3665 if (!NILP (tem))
3666 address = Fplist_get (contact, QCremote);
3667 else
3668 address = Fplist_get (contact, QClocal);
3172 if (!NILP (address)) 3669 if (!NILP (address))
3173 { 3670 {
3174 host = service = Qnil; 3671 host = service = Qnil;
3175 3672
3176 if (!(ai.ai_addrlen = get_lisp_to_sockaddr_size (address, &family))) 3673 if (!get_lisp_to_sockaddr_size (address, &family))
3177 error ("Malformed :address"); 3674 error ("Malformed :address");
3178 ai.ai_family = family; 3675
3179 ai.ai_addr = alloca (ai.ai_addrlen); 3676 ip_addresses = Fcons (address, Qnil);
3180 conv_lisp_to_sockaddr (family, address, ai.ai_addr, ai.ai_addrlen);
3181 goto open_socket; 3677 goto open_socket;
3182 } 3678 }
3183 3679
@@ -3206,14 +3702,21 @@ usage: (make-network-process &rest ARGS) */)
3206 else 3702 else
3207 error ("Unknown address family"); 3703 error ("Unknown address family");
3208 3704
3209 ai.ai_family = family;
3210
3211 /* :service SERVICE -- string, integer (port number), or t (random port). */ 3705 /* :service SERVICE -- string, integer (port number), or t (random port). */
3212 service = Fplist_get (contact, QCservice); 3706 service = Fplist_get (contact, QCservice);
3213 3707
3214 /* :host HOST -- hostname, ip address, or 'local for localhost. */ 3708 /* :host HOST -- hostname, ip address, or 'local for localhost. */
3215 host = Fplist_get (contact, QChost); 3709 host = Fplist_get (contact, QChost);
3216 if (!NILP (host)) 3710 if (NILP (host))
3711 {
3712 /* The "connection" function gets it bind info from the address we're
3713 given, so use this dummy address if nothing is specified. */
3714#ifdef HAVE_LOCAL_SOCKETS
3715 if (family != AF_LOCAL)
3716#endif
3717 host = build_string ("127.0.0.1");
3718 }
3719 else
3217 { 3720 {
3218 if (EQ (host, Qlocal)) 3721 if (EQ (host, Qlocal))
3219 /* Depending on setup, "localhost" may map to different IPv4 and/or 3722 /* Depending on setup, "localhost" may map to different IPv4 and/or
@@ -3232,13 +3735,9 @@ usage: (make-network-process &rest ARGS) */)
3232 host = Qnil; 3735 host = Qnil;
3233 } 3736 }
3234 CHECK_STRING (service); 3737 CHECK_STRING (service);
3235 memset (&address_un, 0, sizeof address_un);
3236 address_un.sun_family = AF_LOCAL;
3237 if (sizeof address_un.sun_path <= SBYTES (service)) 3738 if (sizeof address_un.sun_path <= SBYTES (service))
3238 error ("Service name too long"); 3739 error ("Service name too long");
3239 lispstpcpy (address_un.sun_path, service); 3740 ip_addresses = Fcons (service, Qnil);
3240 ai.ai_addr = (struct sockaddr *) &address_un;
3241 ai.ai_addrlen = sizeof address_un;
3242 goto open_socket; 3741 goto open_socket;
3243 } 3742 }
3244#endif 3743#endif
@@ -3254,9 +3753,7 @@ usage: (make-network-process &rest ARGS) */)
3254 } 3753 }
3255#endif 3754#endif
3256 3755
3257#ifdef HAVE_GETADDRINFO 3756#if defined (HAVE_GETADDRINFO) || defined (HAVE_GETADDRINFO_A)
3258 /* If we have a host, use getaddrinfo to resolve both host and service.
3259 Otherwise, use getservbyname to lookup the service. */
3260 if (!NILP (host)) 3757 if (!NILP (host))
3261 { 3758 {
3262 3759
@@ -3275,19 +3772,54 @@ usage: (make-network-process &rest ARGS) */)
3275 portstring = SSDATA (service); 3772 portstring = SSDATA (service);
3276 } 3773 }
3277 3774
3775 hints = xzalloc (sizeof (struct addrinfo));
3776 hints->ai_flags = 0;
3777 hints->ai_family = family;
3778 hints->ai_socktype = socktype;
3779 hints->ai_protocol = 0;
3780 }
3781
3782#endif
3783
3784#ifdef HAVE_GETADDRINFO_A
3785 if (!NILP (Fplist_get (contact, QCnowait)) &&
3786 !NILP (host))
3787 {
3788 int ret;
3789
3790 printf("Async DNS for '%s'\n", SSDATA (host));
3791 dns_requests = xmalloc (sizeof (struct gaicb*));
3792 dns_requests[0] = xmalloc (sizeof (struct gaicb));
3793 dns_requests[0]->ar_name = strdup (SSDATA (host));
3794 dns_requests[0]->ar_service = strdup (portstring);
3795 dns_requests[0]->ar_request = hints;
3796 dns_requests[0]->ar_result = NULL;
3797
3798 ret = getaddrinfo_a (GAI_NOWAIT, dns_requests, 1, NULL);
3799 if (ret)
3800 error ("%s/%s getaddrinfo_a error %d", SSDATA (host), portstring, ret);
3801
3802 goto open_socket;
3803 }
3804#endif /* HAVE_GETADDRINFO_A */
3805
3806#ifdef HAVE_GETADDRINFO
3807 /* If we have a host, use getaddrinfo to resolve both host and service.
3808 Otherwise, use getservbyname to lookup the service. */
3809
3810 if (!NILP (host))
3811 {
3812 struct addrinfo *res, *lres;
3813 int ret;
3814
3278 immediate_quit = 1; 3815 immediate_quit = 1;
3279 QUIT; 3816 QUIT;
3280 memset (&hints, 0, sizeof (hints));
3281 hints.ai_flags = 0;
3282 hints.ai_family = family;
3283 hints.ai_socktype = socktype;
3284 hints.ai_protocol = 0;
3285 3817
3286#ifdef HAVE_RES_INIT 3818#ifdef HAVE_RES_INIT
3287 res_init (); 3819 res_init ();
3288#endif 3820#endif
3289 3821
3290 ret = getaddrinfo (SSDATA (host), portstring, &hints, &res); 3822 ret = getaddrinfo (SSDATA (host), portstring, hints, &res);
3291 if (ret) 3823 if (ret)
3292#ifdef HAVE_GAI_STRERROR 3824#ifdef HAVE_GAI_STRERROR
3293 error ("%s/%s %s", SSDATA (host), portstring, gai_strerror (ret)); 3825 error ("%s/%s %s", SSDATA (host), portstring, gai_strerror (ret));
@@ -3296,6 +3828,19 @@ usage: (make-network-process &rest ARGS) */)
3296#endif 3828#endif
3297 immediate_quit = 0; 3829 immediate_quit = 0;
3298 3830
3831 for (lres = res; lres; lres = lres->ai_next)
3832 {
3833 ip_addresses = Fcons (conv_sockaddr_to_lisp
3834 (lres->ai_addr, lres->ai_addrlen),
3835 ip_addresses);
3836 ai_protocol = lres->ai_protocol;
3837 }
3838
3839 ip_addresses = Fnreverse (ip_addresses);
3840
3841 freeaddrinfo (res);
3842 xfree (hints);
3843
3299 goto open_socket; 3844 goto open_socket;
3300 } 3845 }
3301#endif /* HAVE_GETADDRINFO */ 3846#endif /* HAVE_GETADDRINFO */
@@ -3306,7 +3851,7 @@ usage: (make-network-process &rest ARGS) */)
3306 if (EQ (service, Qt)) 3851 if (EQ (service, Qt))
3307 port = 0; 3852 port = 0;
3308 else if (INTEGERP (service)) 3853 else if (INTEGERP (service))
3309 port = htons ((unsigned short) XINT (service)); 3854 port = (unsigned short) XINT (service);
3310 else 3855 else
3311 { 3856 {
3312 struct servent *svc_info; 3857 struct servent *svc_info;
@@ -3315,14 +3860,9 @@ usage: (make-network-process &rest ARGS) */)
3315 (socktype == SOCK_DGRAM ? "udp" : "tcp")); 3860 (socktype == SOCK_DGRAM ? "udp" : "tcp"));
3316 if (svc_info == 0) 3861 if (svc_info == 0)
3317 error ("Unknown service: %s", SDATA (service)); 3862 error ("Unknown service: %s", SDATA (service));
3318 port = svc_info->s_port; 3863 port = ntohs (svc_info->s_port);
3319 } 3864 }
3320 3865
3321 memset (&address_in, 0, sizeof address_in);
3322 address_in.sin_family = family;
3323 address_in.sin_addr.s_addr = INADDR_ANY;
3324 address_in.sin_port = port;
3325
3326#ifndef HAVE_GETADDRINFO 3866#ifndef HAVE_GETADDRINFO
3327 if (!NILP (host)) 3867 if (!NILP (host))
3328 { 3868 {
@@ -3337,276 +3877,40 @@ usage: (make-network-process &rest ARGS) */)
3337 res_init (); 3877 res_init ();
3338#endif 3878#endif
3339 3879
3340 host_info_ptr = gethostbyname (SDATA (host)); 3880 host_info_ptr = gethostbyname ((const char *) SDATA (host));
3341 immediate_quit = 0; 3881 immediate_quit = 0;
3342 3882
3343 if (host_info_ptr) 3883 if (host_info_ptr)
3344 { 3884 {
3345 memcpy (&address_in.sin_addr, host_info_ptr->h_addr, 3885 ip_addresses = Fcons (conv_numerical_to_lisp
3346 host_info_ptr->h_length); 3886 ((unsigned char *) host_info_ptr->h_addr,
3347 family = host_info_ptr->h_addrtype; 3887 host_info_ptr->h_length,
3348 address_in.sin_family = family; 3888 port),
3889 Qnil);
3349 } 3890 }
3350 else 3891 else
3351 /* Attempt to interpret host as numeric inet address. */ 3892 /* Attempt to interpret host as numeric inet address. This
3893 only works for IPv4 addresses. */
3352 { 3894 {
3353 unsigned long numeric_addr; 3895 unsigned long numeric_addr = inet_addr (SSDATA (host));
3354 numeric_addr = inet_addr (SSDATA (host)); 3896
3355 if (numeric_addr == -1) 3897 if (numeric_addr == -1)
3356 error ("Unknown host \"%s\"", SDATA (host)); 3898 error ("Unknown host \"%s\"", SDATA (host));
3357 3899
3358 memcpy (&address_in.sin_addr, &numeric_addr, 3900 ip_addresses = Fcons (conv_numerical_to_lisp
3359 sizeof (address_in.sin_addr)); 3901 ((unsigned char *) &numeric_addr, 4, port),
3902 Qnil);
3360 } 3903 }
3361 3904
3362 } 3905 }
3363#endif /* not HAVE_GETADDRINFO */ 3906#endif /* not HAVE_GETADDRINFO */
3364 3907
3365 ai.ai_family = family;
3366 ai.ai_addr = (struct sockaddr *) &address_in;
3367 ai.ai_addrlen = sizeof address_in;
3368
3369 open_socket: 3908 open_socket:
3370 3909
3371 /* Do this in case we never enter the for-loop below. */
3372 count1 = SPECPDL_INDEX ();
3373 s = -1;
3374
3375 for (lres = res; lres; lres = lres->ai_next)
3376 {
3377 ptrdiff_t optn;
3378 int optbits;
3379
3380#ifdef WINDOWSNT
3381 retry_connect:
3382#endif
3383
3384 s = socket (lres->ai_family, lres->ai_socktype | SOCK_CLOEXEC,
3385 lres->ai_protocol);
3386 if (s < 0)
3387 {
3388 xerrno = errno;
3389 continue;
3390 }
3391
3392#ifdef DATAGRAM_SOCKETS
3393 if (!is_server && socktype == SOCK_DGRAM)
3394 break;
3395#endif /* DATAGRAM_SOCKETS */
3396
3397#ifdef NON_BLOCKING_CONNECT
3398 if (is_non_blocking_client)
3399 {
3400 ret = fcntl (s, F_SETFL, O_NONBLOCK);
3401 if (ret < 0)
3402 {
3403 xerrno = errno;
3404 emacs_close (s);
3405 s = -1;
3406 continue;
3407 }
3408 }
3409#endif
3410
3411 /* Make us close S if quit. */
3412 record_unwind_protect_int (close_file_unwind, s);
3413
3414 /* Parse network options in the arg list.
3415 We simply ignore anything which isn't a known option (including other keywords).
3416 An error is signaled if setting a known option fails. */
3417 for (optn = optbits = 0; optn < nargs - 1; optn += 2)
3418 optbits |= set_socket_option (s, args[optn], args[optn + 1]);
3419
3420 if (is_server)
3421 {
3422 /* Configure as a server socket. */
3423
3424 /* SO_REUSEADDR = 1 is default for server sockets; must specify
3425 explicit :reuseaddr key to override this. */
3426#ifdef HAVE_LOCAL_SOCKETS
3427 if (family != AF_LOCAL)
3428#endif
3429 if (!(optbits & (1 << OPIX_REUSEADDR)))
3430 {
3431 int optval = 1;
3432 if (setsockopt (s, SOL_SOCKET, SO_REUSEADDR, &optval, sizeof optval))
3433 report_file_error ("Cannot set reuse option on server socket", Qnil);
3434 }
3435
3436 if (bind (s, lres->ai_addr, lres->ai_addrlen))
3437 report_file_error ("Cannot bind server socket", Qnil);
3438
3439#ifdef HAVE_GETSOCKNAME
3440 if (EQ (service, Qt))
3441 {
3442 struct sockaddr_in sa1;
3443 socklen_t len1 = sizeof (sa1);
3444 if (getsockname (s, (struct sockaddr *)&sa1, &len1) == 0)
3445 {
3446 ((struct sockaddr_in *)(lres->ai_addr))->sin_port = sa1.sin_port;
3447 service = make_number (ntohs (sa1.sin_port));
3448 contact = Fplist_put (contact, QCservice, service);
3449 }
3450 }
3451#endif
3452
3453 if (socktype != SOCK_DGRAM && listen (s, backlog))
3454 report_file_error ("Cannot listen on server socket", Qnil);
3455
3456 break;
3457 }
3458
3459 immediate_quit = 1;
3460 QUIT;
3461
3462 ret = connect (s, lres->ai_addr, lres->ai_addrlen);
3463 xerrno = errno;
3464
3465 if (ret == 0 || xerrno == EISCONN)
3466 {
3467 /* The unwind-protect will be discarded afterwards.
3468 Likewise for immediate_quit. */
3469 break;
3470 }
3471
3472#ifdef NON_BLOCKING_CONNECT
3473#ifdef EINPROGRESS
3474 if (is_non_blocking_client && xerrno == EINPROGRESS)
3475 break;
3476#else
3477#ifdef EWOULDBLOCK
3478 if (is_non_blocking_client && xerrno == EWOULDBLOCK)
3479 break;
3480#endif
3481#endif
3482#endif
3483
3484#ifndef WINDOWSNT
3485 if (xerrno == EINTR)
3486 {
3487 /* Unlike most other syscalls connect() cannot be called
3488 again. (That would return EALREADY.) The proper way to
3489 wait for completion is pselect(). */
3490 int sc;
3491 socklen_t len;
3492 fd_set fdset;
3493 retry_select:
3494 FD_ZERO (&fdset);
3495 FD_SET (s, &fdset);
3496 QUIT;
3497 sc = pselect (s + 1, NULL, &fdset, NULL, NULL, NULL);
3498 if (sc == -1)
3499 {
3500 if (errno == EINTR)
3501 goto retry_select;
3502 else
3503 report_file_error ("Failed select", Qnil);
3504 }
3505 eassert (sc > 0);
3506
3507 len = sizeof xerrno;
3508 eassert (FD_ISSET (s, &fdset));
3509 if (getsockopt (s, SOL_SOCKET, SO_ERROR, &xerrno, &len) < 0)
3510 report_file_error ("Failed getsockopt", Qnil);
3511 if (xerrno)
3512 report_file_errno ("Failed connect", Qnil, xerrno);
3513 break;
3514 }
3515#endif /* !WINDOWSNT */
3516
3517 immediate_quit = 0;
3518
3519 /* Discard the unwind protect closing S. */
3520 specpdl_ptr = specpdl + count1;
3521 emacs_close (s);
3522 s = -1;
3523
3524#ifdef WINDOWSNT
3525 if (xerrno == EINTR)
3526 goto retry_connect;
3527#endif
3528 }
3529
3530 if (s >= 0)
3531 {
3532#ifdef DATAGRAM_SOCKETS
3533 if (socktype == SOCK_DGRAM)
3534 {
3535 if (datagram_address[s].sa)
3536 emacs_abort ();
3537 datagram_address[s].sa = xmalloc (lres->ai_addrlen);
3538 datagram_address[s].len = lres->ai_addrlen;
3539 if (is_server)
3540 {
3541 Lisp_Object remote;
3542 memset (datagram_address[s].sa, 0, lres->ai_addrlen);
3543 if (remote = Fplist_get (contact, QCremote), !NILP (remote))
3544 {
3545 int rfamily, rlen;
3546 rlen = get_lisp_to_sockaddr_size (remote, &rfamily);
3547 if (rlen != 0 && rfamily == lres->ai_family
3548 && rlen == lres->ai_addrlen)
3549 conv_lisp_to_sockaddr (rfamily, remote,
3550 datagram_address[s].sa, rlen);
3551 }
3552 }
3553 else
3554 memcpy (datagram_address[s].sa, lres->ai_addr, lres->ai_addrlen);
3555 }
3556#endif
3557 contact = Fplist_put (contact, colon_address,
3558 conv_sockaddr_to_lisp (lres->ai_addr, lres->ai_addrlen));
3559#ifdef HAVE_GETSOCKNAME
3560 if (!is_server)
3561 {
3562 struct sockaddr_in sa1;
3563 socklen_t len1 = sizeof (sa1);
3564 if (getsockname (s, (struct sockaddr *)&sa1, &len1) == 0)
3565 contact = Fplist_put (contact, QClocal,
3566 conv_sockaddr_to_lisp ((struct sockaddr *)&sa1, len1));
3567 }
3568#endif
3569 }
3570
3571 immediate_quit = 0;
3572
3573#ifdef HAVE_GETADDRINFO
3574 if (res != &ai)
3575 {
3576 block_input ();
3577 freeaddrinfo (res);
3578 unblock_input ();
3579 }
3580#endif
3581
3582 if (s < 0)
3583 {
3584 /* If non-blocking got this far - and failed - assume non-blocking is
3585 not supported after all. This is probably a wrong assumption, but
3586 the normal blocking calls to open-network-stream handles this error
3587 better. */
3588 if (is_non_blocking_client)
3589 return Qnil;
3590
3591 report_file_errno ((is_server
3592 ? "make server process failed"
3593 : "make client process failed"),
3594 contact, xerrno);
3595 }
3596
3597 inch = s;
3598 outch = s;
3599
3600 if (!NILP (buffer)) 3910 if (!NILP (buffer))
3601 buffer = Fget_buffer_create (buffer); 3911 buffer = Fget_buffer_create (buffer);
3602 proc = make_process (name); 3912 proc = make_process (name);
3603
3604 chan_process[inch] = proc;
3605
3606 fcntl (inch, F_SETFL, O_NONBLOCK);
3607
3608 p = XPROCESS (proc); 3913 p = XPROCESS (proc);
3609
3610 pset_childp (p, contact); 3914 pset_childp (p, contact);
3611 pset_plist (p, Fcopy_sequence (Fplist_get (contact, QCplist))); 3915 pset_plist (p, Fcopy_sequence (Fplist_get (contact, QCplist)));
3612 pset_type (p, Qnetwork); 3916 pset_type (p, Qnetwork);
@@ -3620,134 +3924,62 @@ usage: (make-network-process &rest ARGS) */)
3620 if ((tem = Fplist_get (contact, QCstop), !NILP (tem))) 3924 if ((tem = Fplist_get (contact, QCstop), !NILP (tem)))
3621 pset_command (p, Qt); 3925 pset_command (p, Qt);
3622 p->pid = 0; 3926 p->pid = 0;
3927 p->backlog = 5;
3928 p->is_non_blocking_client = 0;
3929 p->is_server = 0;
3930 p->port = port;
3931 p->socktype = socktype;
3932 p->ai_protocol = ai_protocol;
3933#ifdef HAVE_GETADDRINFO_A
3934 p->dns_requests = NULL;
3935#endif
3936#ifdef HAVE_GNUTLS
3937 tem = Fplist_get (contact, QCtls_parameters);
3938 CHECK_LIST (tem);
3939 p->gnutls_boot_parameters = tem;
3940#endif
3623 3941
3624 p->open_fd[SUBPROCESS_STDIN] = inch; 3942 set_network_socket_coding_system (proc, service, host, name);
3625 p->infd = inch;
3626 p->outfd = outch;
3627
3628 /* Discard the unwind protect for closing S, if any. */
3629 specpdl_ptr = specpdl + count1;
3630 3943
3631 /* Unwind bind_polling_period and request_sigio. */
3632 unbind_to (count, Qnil); 3944 unbind_to (count, Qnil);
3633 3945
3634 if (is_server && socktype != SOCK_DGRAM) 3946 /* :server BOOL */
3635 pset_status (p, Qlisten); 3947 tem = Fplist_get (contact, QCserver);
3948 if (!NILP (tem))
3949 {
3950 /* Don't support network sockets when non-blocking mode is
3951 not available, since a blocked Emacs is not useful. */
3952 p->is_server = 1;
3953 if (TYPE_RANGED_INTEGERP (int, tem))
3954 p->backlog = XINT (tem);
3955 }
3636 3956
3637 /* Make the process marker point into the process buffer (if any). */ 3957 /* :nowait BOOL */
3638 if (BUFFERP (buffer)) 3958 if (!p->is_server && socktype != SOCK_DGRAM
3639 set_marker_both (p->mark, buffer, 3959 && (tem = Fplist_get (contact, QCnowait), !NILP (tem)))
3640 BUF_ZV (XBUFFER (buffer)), 3960 {
3641 BUF_ZV_BYTE (XBUFFER (buffer))); 3961#ifndef NON_BLOCKING_CONNECT
3962 error ("Non-blocking connect not supported");
3963#else
3964 p->is_non_blocking_client = 1;
3965#endif
3966 }
3642 3967
3643#ifdef NON_BLOCKING_CONNECT 3968#ifdef HAVE_GETADDRINFO_A
3644 if (is_non_blocking_client) 3969 /* If we're doing async address resolution, the list of addresses
3970 here will be nil, so we postpone connecting to the server. */
3971 if (!p->is_server && NILP (ip_addresses))
3645 { 3972 {
3646 /* We may get here if connect did succeed immediately. However, 3973 p->dns_requests = dns_requests;
3647 in that case, we still need to signal this like a non-blocking 3974 p->status = Qconnect;
3648 connection. */
3649 pset_status (p, Qconnect);
3650 if (!FD_ISSET (inch, &connect_wait_mask))
3651 {
3652 FD_SET (inch, &connect_wait_mask);
3653 FD_SET (inch, &write_mask);
3654 num_pending_connects++;
3655 }
3656 } 3975 }
3657 else 3976 else
3977 {
3978 connect_network_socket (proc, ip_addresses);
3979 }
3980#else /* HAVE_GETADDRINFO_A */
3981 connect_network_socket (proc, ip_addresses);
3658#endif 3982#endif
3659 /* A server may have a client filter setting of Qt, but it must
3660 still listen for incoming connects unless it is stopped. */
3661 if ((!EQ (p->filter, Qt) && !EQ (p->command, Qt))
3662 || (EQ (p->status, Qlisten) && NILP (p->command)))
3663 {
3664 FD_SET (inch, &input_wait_mask);
3665 FD_SET (inch, &non_keyboard_wait_mask);
3666 }
3667
3668 if (inch > max_process_desc)
3669 max_process_desc = inch;
3670
3671 tem = Fplist_member (contact, QCcoding);
3672 if (!NILP (tem) && (!CONSP (tem) || !CONSP (XCDR (tem))))
3673 tem = Qnil; /* No error message (too late!). */
3674
3675 {
3676 /* Setup coding systems for communicating with the network stream. */
3677 /* Qt denotes we have not yet called Ffind_operation_coding_system. */
3678 Lisp_Object coding_systems = Qt;
3679 Lisp_Object val;
3680
3681 if (!NILP (tem))
3682 {
3683 val = XCAR (XCDR (tem));
3684 if (CONSP (val))
3685 val = XCAR (val);
3686 }
3687 else if (!NILP (Vcoding_system_for_read))
3688 val = Vcoding_system_for_read;
3689 else if ((!NILP (buffer) && NILP (BVAR (XBUFFER (buffer), enable_multibyte_characters)))
3690 || (NILP (buffer) && NILP (BVAR (&buffer_defaults, enable_multibyte_characters))))
3691 /* We dare not decode end-of-line format by setting VAL to
3692 Qraw_text, because the existing Emacs Lisp libraries
3693 assume that they receive bare code including a sequence of
3694 CR LF. */
3695 val = Qnil;
3696 else
3697 {
3698 if (NILP (host) || NILP (service))
3699 coding_systems = Qnil;
3700 else
3701 coding_systems = CALLN (Ffind_operation_coding_system,
3702 Qopen_network_stream, name, buffer,
3703 host, service);
3704 if (CONSP (coding_systems))
3705 val = XCAR (coding_systems);
3706 else if (CONSP (Vdefault_process_coding_system))
3707 val = XCAR (Vdefault_process_coding_system);
3708 else
3709 val = Qnil;
3710 }
3711 pset_decode_coding_system (p, val);
3712
3713 if (!NILP (tem))
3714 {
3715 val = XCAR (XCDR (tem));
3716 if (CONSP (val))
3717 val = XCDR (val);
3718 }
3719 else if (!NILP (Vcoding_system_for_write))
3720 val = Vcoding_system_for_write;
3721 else if (NILP (BVAR (current_buffer, enable_multibyte_characters)))
3722 val = Qnil;
3723 else
3724 {
3725 if (EQ (coding_systems, Qt))
3726 {
3727 if (NILP (host) || NILP (service))
3728 coding_systems = Qnil;
3729 else
3730 coding_systems = CALLN (Ffind_operation_coding_system,
3731 Qopen_network_stream, name, buffer,
3732 host, service);
3733 }
3734 if (CONSP (coding_systems))
3735 val = XCDR (coding_systems);
3736 else if (CONSP (Vdefault_process_coding_system))
3737 val = XCDR (Vdefault_process_coding_system);
3738 else
3739 val = Qnil;
3740 }
3741 pset_encode_coding_system (p, val);
3742 }
3743 setup_process_coding_systems (proc);
3744
3745 pset_decoding_buf (p, empty_unibyte_string);
3746 p->decoding_carryover = 0;
3747 pset_encoding_buf (p, empty_unibyte_string);
3748
3749 p->inherit_coding_system_flag
3750 = !(!NILP (tem) || NILP (buffer) || !inherit_process_coding_system);
3751 3983
3752 return proc; 3984 return proc;
3753} 3985}
@@ -4453,6 +4685,92 @@ server_accept_connection (Lisp_Object server, int channel)
4453 exec_sentinel (proc, concat3 (open_from, host_string, nl)); 4685 exec_sentinel (proc, concat3 (open_from, host_string, nl));
4454} 4686}
4455 4687
4688#ifdef HAVE_GETADDRINFO_A
4689static Lisp_Object
4690check_for_dns (Lisp_Object proc)
4691{
4692 struct Lisp_Process *p = XPROCESS (proc);
4693 Lisp_Object ip_addresses = Qnil;
4694 int ret = 0;
4695
4696 /* Sanity check. */
4697 if (! p->dns_requests)
4698 return Qnil;
4699
4700 ret = gai_error (p->dns_requests[0]);
4701 if (ret == EAI_INPROGRESS)
4702 return Qt;
4703
4704 /* We got a response. */
4705 if (ret == 0)
4706 {
4707 struct addrinfo *res;
4708
4709 for (res = p->dns_requests[0]->ar_result; res; res = res->ai_next)
4710 {
4711 ip_addresses = Fcons (conv_sockaddr_to_lisp
4712 (res->ai_addr, res->ai_addrlen),
4713 ip_addresses);
4714 }
4715
4716 ip_addresses = Fnreverse (ip_addresses);
4717 }
4718 /* The DNS lookup failed. */
4719 else if (EQ (p->status, Qconnect))
4720 {
4721 deactivate_process (proc);
4722 pset_status (p, (list2
4723 (Qfailed,
4724 concat3 (build_string ("Name lookup of "),
4725 build_string (p->dns_requests[0]->ar_name),
4726 build_string (" failed")))));
4727 }
4728
4729 free_dns_request (proc);
4730
4731 /* This process should not already be connected (or killed). */
4732 if (!EQ (p->status, Qconnect))
4733 return Qnil;
4734
4735 return ip_addresses;
4736}
4737
4738#endif /* HAVE_GETADDRINFO_A */
4739
4740static void
4741wait_for_socket_fds (Lisp_Object process, char *name)
4742{
4743 while (XPROCESS (process)->infd < 0 &&
4744 EQ (XPROCESS (process)->status, Qconnect))
4745 {
4746 add_to_log ("Waiting for socket from %s...\n", build_string (name));
4747 wait_reading_process_output (0, 20 * 1000 * 1000, 0, 0, Qnil, NULL, 0);
4748 }
4749}
4750
4751static void
4752wait_while_connecting (Lisp_Object process)
4753{
4754 while (EQ (XPROCESS (process)->status, Qconnect))
4755 {
4756 add_to_log ("Waiting for connection...\n");
4757 wait_reading_process_output (0, 20 * 1000 * 1000, 0, 0, Qnil, NULL, 0);
4758 }
4759}
4760
4761static void
4762wait_for_tls_negotiation (Lisp_Object process)
4763{
4764#ifdef HAVE_GNUTLS
4765 while (XPROCESS (process)->gnutls_p &&
4766 XPROCESS (process)->gnutls_initstage != GNUTLS_STAGE_READY)
4767 {
4768 add_to_log ("Waiting for TLS...\n");
4769 wait_reading_process_output (0, 20 * 1000 * 1000, 0, 0, Qnil, NULL, 0);
4770 }
4771#endif
4772}
4773
4456/* This variable is different from waiting_for_input in keyboard.c. 4774/* This variable is different from waiting_for_input in keyboard.c.
4457 It is used to communicate to a lisp process-filter/sentinel (via the 4775 It is used to communicate to a lisp process-filter/sentinel (via the
4458 function Fwaiting_for_user_input_p below) whether Emacs was waiting 4776 function Fwaiting_for_user_input_p below) whether Emacs was waiting
@@ -4578,6 +4896,55 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd,
4578 if (! NILP (wait_for_cell) && ! NILP (XCAR (wait_for_cell))) 4896 if (! NILP (wait_for_cell) && ! NILP (XCAR (wait_for_cell)))
4579 break; 4897 break;
4580 4898
4899#if defined (HAVE_GETADDRINFO_A) || defined (HAVE_GNUTLS)
4900 {
4901 Lisp_Object ip_addresses;
4902 Lisp_Object process_list_head, aproc;
4903 struct Lisp_Process *p;
4904
4905 FOR_EACH_PROCESS(process_list_head, aproc)
4906 {
4907 p = XPROCESS (aproc);
4908
4909 if (! wait_proc || p == wait_proc)
4910 {
4911#ifdef HAVE_GETADDRINFO_A
4912 /* Check for pending DNS requests. */
4913 if (p->dns_requests)
4914 {
4915 ip_addresses = check_for_dns (aproc);
4916 if (!NILP (ip_addresses) &&
4917 !EQ (ip_addresses, Qt))
4918 connect_network_socket (aproc, ip_addresses);
4919 }
4920#endif
4921#ifdef HAVE_GNUTLS
4922 /* Continue TLS negotiation. */
4923 if (p->gnutls_initstage == GNUTLS_STAGE_HANDSHAKE_TRIED &&
4924 p->is_non_blocking_client)
4925 {
4926 gnutls_try_handshake (p);
4927 p->gnutls_handshakes_tried++;
4928
4929 if (p->gnutls_initstage == GNUTLS_STAGE_READY)
4930 {
4931 gnutls_verify_boot (proc, Qnil);
4932 finish_after_tls_connection (aproc);
4933 }
4934 else if (p->gnutls_handshakes_tried >
4935 GNUTLS_EMACS_HANDSHAKES_LIMIT)
4936 {
4937 deactivate_process (aproc);
4938 pset_status (p, list2 (Qfailed,
4939 build_string ("TLS negotiation failed")));
4940 }
4941 }
4942#endif
4943 }
4944 }
4945 }
4946#endif /* GETADDRINFO_A or GNUTLS */
4947
4581 /* Compute time from now till when time limit is up. */ 4948 /* Compute time from now till when time limit is up. */
4582 /* Exit if already run out. */ 4949 /* Exit if already run out. */
4583 if (wait == TIMEOUT) 4950 if (wait == TIMEOUT)
@@ -5197,11 +5564,21 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd,
5197 } 5564 }
5198 else 5565 else
5199 { 5566 {
5200 pset_status (p, Qrun); 5567#ifdef HAVE_GNUTLS
5201 /* Execute the sentinel here. If we had relied on 5568 /* If we have an incompletely set up TLS connection,
5202 status_notify to do it later, it will read input 5569 then defer the sentinel signalling until
5203 from the process before calling the sentinel. */ 5570 later. */
5204 exec_sentinel (proc, build_string ("open\n")); 5571 if (NILP (p->gnutls_boot_parameters) &&
5572 !p->gnutls_p)
5573#endif
5574 {
5575 pset_status (p, Qrun);
5576 /* Execute the sentinel here. If we had relied on
5577 status_notify to do it later, it will read input
5578 from the process before calling the sentinel. */
5579 exec_sentinel (proc, build_string ("open\n"));
5580 }
5581
5205 if (0 <= p->infd && !EQ (p->filter, Qt) 5582 if (0 <= p->infd && !EQ (p->filter, Qt)
5206 && !EQ (p->command, Qt)) 5583 && !EQ (p->command, Qt))
5207 { 5584 {
@@ -5658,6 +6035,11 @@ send_process (Lisp_Object proc, const char *buf, ptrdiff_t len,
5658 ssize_t rv; 6035 ssize_t rv;
5659 struct coding_system *coding; 6036 struct coding_system *coding;
5660 6037
6038 if (NETCONN_P (proc)) {
6039 wait_while_connecting (proc);
6040 wait_for_tls_negotiation (proc);
6041 }
6042
5661 if (p->raw_status_new) 6043 if (p->raw_status_new)
5662 update_status (p); 6044 update_status (p);
5663 if (! EQ (p->status, Qrun)) 6045 if (! EQ (p->status, Qrun))
@@ -5875,7 +6257,10 @@ nil, indicating the current buffer's process.
5875Called from program, takes three arguments, PROCESS, START and END. 6257Called from program, takes three arguments, PROCESS, START and END.
5876If the region is more than 500 characters long, 6258If the region is more than 500 characters long,
5877it is sent in several bunches. This may happen even for shorter regions. 6259it is sent in several bunches. This may happen even for shorter regions.
5878Output from processes can arrive in between bunches. */) 6260Output from processes can arrive in between bunches.
6261
6262If PROCESS is a non-blocking network process that hasn't been fully
6263set up yet, this function will block until socket setup has completed. */)
5879 (Lisp_Object process, Lisp_Object start, Lisp_Object end) 6264 (Lisp_Object process, Lisp_Object start, Lisp_Object end)
5880{ 6265{
5881 Lisp_Object proc = get_process (process); 6266 Lisp_Object proc = get_process (process);
@@ -5889,6 +6274,9 @@ Output from processes can arrive in between bunches. */)
5889 if (XINT (start) < GPT && XINT (end) > GPT) 6274 if (XINT (start) < GPT && XINT (end) > GPT)
5890 move_gap_both (XINT (start), start_byte); 6275 move_gap_both (XINT (start), start_byte);
5891 6276
6277 if (NETCONN_P (proc))
6278 wait_while_connecting (proc);
6279
5892 send_process (proc, (char *) BYTE_POS_ADDR (start_byte), 6280 send_process (proc, (char *) BYTE_POS_ADDR (start_byte),
5893 end_byte - start_byte, Fcurrent_buffer ()); 6281 end_byte - start_byte, Fcurrent_buffer ());
5894 6282
@@ -5902,12 +6290,16 @@ PROCESS may be a process, a buffer, the name of a process or buffer, or
5902nil, indicating the current buffer's process. 6290nil, indicating the current buffer's process.
5903If STRING is more than 500 characters long, 6291If STRING is more than 500 characters long,
5904it is sent in several bunches. This may happen even for shorter strings. 6292it is sent in several bunches. This may happen even for shorter strings.
5905Output from processes can arrive in between bunches. */) 6293Output from processes can arrive in between bunches.
6294
6295If PROCESS is a non-blocking network process that hasn't been fully
6296set up yet, this function will block until socket setup has completed. */)
5906 (Lisp_Object process, Lisp_Object string) 6297 (Lisp_Object process, Lisp_Object string)
5907{ 6298{
5908 Lisp_Object proc; 6299 Lisp_Object proc;
5909 CHECK_STRING (string); 6300 CHECK_STRING (string);
5910 proc = get_process (process); 6301 proc = get_process (process);
6302
5911 send_process (proc, SSDATA (string), 6303 send_process (proc, SSDATA (string),
5912 SBYTES (string), string); 6304 SBYTES (string), string);
5913 return Qnil; 6305 return Qnil;
@@ -6322,10 +6714,15 @@ process has been transmitted to the serial port. */)
6322 struct coding_system *coding = NULL; 6714 struct coding_system *coding = NULL;
6323 int outfd; 6715 int outfd;
6324 6716
6325 if (DATAGRAM_CONN_P (process)) 6717 proc = get_process (process);
6718
6719 if (NETCONN_P (proc))
6720 wait_while_connecting (proc);
6721
6722 if (DATAGRAM_CONN_P (proc))
6326 return process; 6723 return process;
6327 6724
6328 proc = get_process (process); 6725
6329 outfd = XPROCESS (proc)->outfd; 6726 outfd = XPROCESS (proc)->outfd;
6330 if (outfd >= 0) 6727 if (outfd >= 0)
6331 coding = proc_encode_coding_system[outfd]; 6728 coding = proc_encode_coding_system[outfd];
@@ -6770,13 +7167,21 @@ DEFUN ("set-process-coding-system", Fset_process_coding_system,
6770 Sset_process_coding_system, 1, 3, 0, 7167 Sset_process_coding_system, 1, 3, 0,
6771 doc: /* Set coding systems of PROCESS to DECODING and ENCODING. 7168 doc: /* Set coding systems of PROCESS to DECODING and ENCODING.
6772DECODING will be used to decode subprocess output and ENCODING to 7169DECODING will be used to decode subprocess output and ENCODING to
6773encode subprocess input. */) 7170encode subprocess input.
7171
7172If PROCESS is a non-blocking network process that hasn't been fully
7173set up yet, this function will block until socket setup has completed. */)
6774 (register Lisp_Object process, Lisp_Object decoding, Lisp_Object encoding) 7174 (register Lisp_Object process, Lisp_Object decoding, Lisp_Object encoding)
6775{ 7175{
6776 register struct Lisp_Process *p; 7176 register struct Lisp_Process *p;
6777 7177
6778 CHECK_PROCESS (process); 7178 CHECK_PROCESS (process);
7179
7180 if (NETCONN_P (process))
7181 wait_for_socket_fds (process, "set-process-coding-system");
7182
6779 p = XPROCESS (process); 7183 p = XPROCESS (process);
7184
6780 if (p->infd < 0) 7185 if (p->infd < 0)
6781 error ("Input file descriptor of %s closed", SDATA (p->name)); 7186 error ("Input file descriptor of %s closed", SDATA (p->name));
6782 if (p->outfd < 0) 7187 if (p->outfd < 0)
@@ -6813,6 +7218,10 @@ suppressed. */)
6813 register struct Lisp_Process *p; 7218 register struct Lisp_Process *p;
6814 7219
6815 CHECK_PROCESS (process); 7220 CHECK_PROCESS (process);
7221
7222 if (NETCONN_P (process))
7223 wait_for_socket_fds (process, "set-process-filter-multibyte");
7224
6816 p = XPROCESS (process); 7225 p = XPROCESS (process);
6817 if (NILP (flag)) 7226 if (NILP (flag))
6818 pset_decode_coding_system 7227 pset_decode_coding_system
@@ -7501,6 +7910,8 @@ syms_of_process (void)
7501 DEFSYM (QCserver, ":server"); 7910 DEFSYM (QCserver, ":server");
7502 DEFSYM (QCnowait, ":nowait"); 7911 DEFSYM (QCnowait, ":nowait");
7503 DEFSYM (QCsentinel, ":sentinel"); 7912 DEFSYM (QCsentinel, ":sentinel");
7913 DEFSYM (QCtls_parameters, ":tls-parameters");
7914 DEFSYM (Qnsm_verify_connection, "nsm-verify-connection");
7504 DEFSYM (QClog, ":log"); 7915 DEFSYM (QClog, ":log");
7505 DEFSYM (QCnoquery, ":noquery"); 7916 DEFSYM (QCnoquery, ":noquery");
7506 DEFSYM (QCstop, ":stop"); 7917 DEFSYM (QCstop, ":stop");
diff --git a/src/process.h b/src/process.h
index 8d9f8f4c072..c7531576915 100644
--- a/src/process.h
+++ b/src/process.h
@@ -106,6 +106,7 @@ struct Lisp_Process
106 106
107#ifdef HAVE_GNUTLS 107#ifdef HAVE_GNUTLS
108 Lisp_Object gnutls_cred_type; 108 Lisp_Object gnutls_cred_type;
109 Lisp_Object gnutls_boot_parameters;
109#endif 110#endif
110 111
111 /* Pipe process attached to the standard error of this process. */ 112 /* Pipe process attached to the standard error of this process. */
@@ -161,7 +162,25 @@ struct Lisp_Process
161 flag indicates that `raw_status' contains a new status that still 162 flag indicates that `raw_status' contains a new status that still
162 needs to be synced to `status'. */ 163 needs to be synced to `status'. */
163 bool_bf raw_status_new : 1; 164 bool_bf raw_status_new : 1;
165 /* Whether this is a nonblocking socket. */
166 bool_bf is_non_blocking_client : 1;
167 /* Whether this is a server or a client socket. */
168 bool_bf is_server : 1;
164 int raw_status; 169 int raw_status;
170 /* The length of the socket backlog. */
171 int backlog;
172 /* The port number. */
173 int port;
174 /* The socket type. */
175 int socktype;
176 /* The socket protocol. */
177 int ai_protocol;
178
179#ifdef HAVE_GETADDRINFO_A
180 /* Whether the socket is waiting for response from an asynchronous
181 DNS call. */
182 struct gaicb **dns_requests;
183#endif
165 184
166#ifdef HAVE_GNUTLS 185#ifdef HAVE_GNUTLS
167 gnutls_initstage_t gnutls_initstage; 186 gnutls_initstage_t gnutls_initstage;
@@ -191,6 +210,12 @@ pset_childp (struct Lisp_Process *p, Lisp_Object val)
191 p->childp = val; 210 p->childp = val;
192} 211}
193 212
213INLINE void
214pset_status (struct Lisp_Process *p, Lisp_Object val)
215{
216 p->status = val;
217}
218
194#ifdef HAVE_GNUTLS 219#ifdef HAVE_GNUTLS
195INLINE void 220INLINE void
196pset_gnutls_cred_type (struct Lisp_Process *p, Lisp_Object val) 221pset_gnutls_cred_type (struct Lisp_Process *p, Lisp_Object val)
generated by cgit v1.2.1 (git 2.18.0) at 2026-01-16 08:21:18 +0000