Back to index

plt-scheme  4.2.1
network.c
Go to the documentation of this file.
00001 /*
00002   MzScheme
00003   Copyright (c) 2004-2009 PLT Scheme Inc.
00004   Copyright (c) 2000-2001 Matthew Flatt
00005 
00006     This library is free software; you can redistribute it and/or
00007     modify it under the terms of the GNU Library General Public
00008     License as published by the Free Software Foundation; either
00009     version 2 of the License, or (at your option) any later version.
00010 
00011     This library is distributed in the hope that it will be useful,
00012     but WITHOUT ANY WARRANTY; without even the implied warranty of
00013     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
00014     Library General Public License for more details.
00015 
00016     You should have received a copy of the GNU Library General Public
00017     License along with this library; if not, write to the Free
00018     Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
00019     Boston, MA 02110-1301 USA.
00020 
00021   libscheme
00022   Copyright (c) 1994 Brent Benson
00023   All rights reserved.
00024 */
00025 
00026 /* This file implements the TCP and UDP interfaces. */
00027 
00028 #include "schpriv.h"
00029 #include <ctype.h>
00030 
00031 #ifndef NO_TCP_SUPPORT
00032 #ifdef USE_TCP
00033 
00034 #ifdef UNISTD_INCLUDE
00035 # include <unistd.h>
00036 #endif
00037 #ifdef USE_ULIMIT
00038 # include <ulimit.h>
00039 #endif
00040 #ifdef FILES_HAVE_FDS
00041 # include <sys/types.h>
00042 # include <sys/time.h>
00043 # ifdef BSTRING_INCLUDE
00044 #  include <bstring.h>
00045 # endif
00046 # ifdef SELECT_INCLUDE
00047 #  include <sys/select.h>
00048 # endif
00049 #endif
00050 #ifdef IO_INCLUDE
00051 # include <io.h>
00052 #endif
00053 #ifdef INCLUDE_OSKIT_SOCKET
00054 # include <oskit/net/socket.h>
00055 #endif
00056 #ifdef NO_ERRNO_GLOBAL
00057 static int mzerrno = 0;
00058 # define errno mzerrno
00059 #else
00060 # include <errno.h>
00061 #endif
00062 #include "schfd.h"
00063 
00064 #ifdef USE_UNIX_SOCKETS_TCP
00065 # include <netinet/in.h>
00066 # include <netdb.h>
00067 # include <sys/socket.h>
00068 # include <fcntl.h>
00069 # define TCP_SOCKSENDBUF_SIZE 32768
00070 # define NOT_WINSOCK(x) x
00071 # define SOCK_ERRNO() errno
00072 # define WAS_EAGAIN(e) ((e == EWOULDBLOCK) || (e == EAGAIN) || (e == EINPROGRESS) || (e == EALREADY))
00073 # define WAS_WSAEMSGSIZE(e) 0
00074 # define mz_AFNOSUPPORT EAFNOSUPPORT
00075 #endif
00076 
00077 #ifdef USE_WINSOCK_TCP
00078 # include <process.h>
00079 # include <winsock2.h>
00080 # include <ws2tcpip.h>
00081 # include <wspiapi.h>
00082 struct SOCKADDR_IN {
00083   short sin_family;
00084   unsigned short sin_port;
00085   struct in_addr sin_addr;
00086   char sin_zero[8];
00087 };
00088 # define NOT_WINSOCK(x) 0
00089 # define SOCK_ERRNO() WSAGetLastError()
00090 # define WAS_EAGAIN(e) ((e == WSAEWOULDBLOCK) || (e == WSAEINPROGRESS))
00091 # define WAS_WSAEMSGSIZE(e) (e == WSAEMSGSIZE)
00092 # define mz_AFNOSUPPORT WSAEAFNOSUPPORT
00093 extern int scheme_stupid_windows_machine;
00094 #endif
00095 
00096 #define TCP_BUFFER_SIZE 4096
00097 
00098 #ifdef USE_UNIX_SOCKETS_TCP
00099 typedef long tcp_t;
00100 # define INVALID_SOCKET (-1)
00101 static void closesocket(long s) {
00102   int cr;
00103   do { 
00104     cr = close(s);
00105   } while ((cr == -1) && (errno == EINTR));
00106 }
00107 #endif
00108 
00109 #ifdef USE_WINSOCK_TCP
00110 typedef SOCKET tcp_t;
00111 #endif
00112 
00113 #ifdef USE_SOCKETS_TCP
00114 typedef struct {
00115   Scheme_Object so;
00116   Scheme_Custodian_Reference *mref;
00117   int count;
00118   tcp_t s[1];
00119 } listener_t;
00120 #endif
00121 
00122 typedef struct Scheme_Tcp_Buf {
00123   MZTAG_IF_REQUIRED
00124   short refcount;
00125   char *buffer, *out_buffer;
00126   short bufpos, bufmax;
00127   short hiteof, bufmode;
00128   short out_bufpos, out_bufmax;
00129   short out_bufmode;
00130 } Scheme_Tcp_Buf;
00131 
00132 typedef struct Scheme_Tcp {
00133   Scheme_Tcp_Buf b;
00134   tcp_t tcp;
00135   int flags;
00136 } Scheme_Tcp;
00137 
00138 # define MZ_TCP_ABANDON_OUTPUT 0x1
00139 # define MZ_TCP_ABANDON_INPUT  0x2
00140 
00141 #define UDP_IS_SUPPORTED
00142 
00143 #ifdef UDP_IS_SUPPORTED
00144 
00145 typedef struct Scheme_UDP {
00146   Scheme_Object so; /* scheme_udp_type */
00147   MZ_HASH_KEY_EX
00148   tcp_t s; /* ok, tcp_t was a bad name */
00149   char bound, connected;
00150   Scheme_Object *previous_from_addr;
00151   Scheme_Custodian_Reference *mref;
00152 } Scheme_UDP;
00153 
00154 #endif /* UDP_IS_SUPPORTED */
00155 
00156 #endif /* USE_TCP */
00157 
00158 #if defined(WINDOWS_PROCESSES) || defined(WINDOWS_FILE_HANDLES)
00159 # define DECL_OS_FDSET(n) fd_set n[1]
00160 # define INIT_DECL_OS_FDSET(n) /* empty */
00161 # define MZ_OS_FD_ZERO(p) FD_ZERO(p)
00162 # define MZ_OS_FD_SET(n, p) FD_SET(n, p)
00163 # define MZ_OS_FD_CLR(n, p) FD_CLR(n, p)
00164 #else
00165 # define DECL_OS_FDSET(n) DECL_FDSET(n, 1)
00166 # define INIT_DECL_OS_FDSET(n) INIT_DECL_FDSET(n, 1)
00167 # define MZ_OS_FD_ZERO(p) MZ_FD_ZERO(p)
00168 # define MZ_OS_FD_SET(n, p) MZ_FD_SET(n, p)
00169 # define MZ_OS_FD_CLR(n, p) MZ_FD_CLR(n, p)
00170 #endif
00171 #define MZ_OS_FD_ISSET(n, p) FD_ISSET(n, p)
00172 
00173 static Scheme_Object *tcp_connect(int argc, Scheme_Object *argv[]);
00174 static Scheme_Object *tcp_connect_break(int argc, Scheme_Object *argv[]);
00175 static Scheme_Object *tcp_listen(int argc, Scheme_Object *argv[]);
00176 static Scheme_Object *tcp_stop(int argc, Scheme_Object *argv[]);
00177 static Scheme_Object *tcp_accept_ready(int argc, Scheme_Object *argv[]);
00178 static Scheme_Object *tcp_accept(int argc, Scheme_Object *argv[]);
00179 static Scheme_Object *tcp_accept_evt(int argc, Scheme_Object *argv[]);
00180 static Scheme_Object *tcp_accept_break(int argc, Scheme_Object *argv[]);
00181 static Scheme_Object *tcp_listener_p(int argc, Scheme_Object *argv[]);
00182 static Scheme_Object *tcp_addresses(int argc, Scheme_Object *argv[]);
00183 static Scheme_Object *tcp_abandon_port(int argc, Scheme_Object *argv[]);
00184 static Scheme_Object *tcp_port_p(int argc, Scheme_Object *argv[]);
00185 
00186 static Scheme_Object *make_udp(int argc, Scheme_Object *argv[]);
00187 static Scheme_Object *udp_close(int argc, Scheme_Object *argv[]);
00188 static Scheme_Object *udp_p(int argc, Scheme_Object *argv[]);
00189 static Scheme_Object *udp_bound_p(int argc, Scheme_Object *argv[]);
00190 static Scheme_Object *udp_connected_p(int argc, Scheme_Object *argv[]);
00191 static Scheme_Object *udp_bind(int argc, Scheme_Object *argv[]);
00192 static Scheme_Object *udp_connect(int argc, Scheme_Object *argv[]);
00193 static Scheme_Object *udp_send_to(int argc, Scheme_Object *argv[]);
00194 static Scheme_Object *udp_send(int argc, Scheme_Object *argv[]);
00195 static Scheme_Object *udp_send_to_star(int argc, Scheme_Object *argv[]);
00196 static Scheme_Object *udp_send_star(int argc, Scheme_Object *argv[]);
00197 static Scheme_Object *udp_send_to_enable_break(int argc, Scheme_Object *argv[]);
00198 static Scheme_Object *udp_send_enable_break(int argc, Scheme_Object *argv[]);
00199 static Scheme_Object *udp_receive(int argc, Scheme_Object *argv[]);
00200 static Scheme_Object *udp_receive_star(int argc, Scheme_Object *argv[]);
00201 static Scheme_Object *udp_receive_enable_break(int argc, Scheme_Object *argv[]);
00202 static Scheme_Object *udp_read_ready_evt(int argc, Scheme_Object *argv[]);
00203 static Scheme_Object *udp_write_ready_evt(int argc, Scheme_Object *argv[]);
00204 static Scheme_Object *udp_read_evt(int argc, Scheme_Object *argv[]);
00205 static Scheme_Object *udp_write_evt(int argc, Scheme_Object *argv[]);
00206 static Scheme_Object *udp_write_to_evt(int argc, Scheme_Object *argv[]);
00207 
00208 static int tcp_check_accept_evt(Scheme_Object *ae, Scheme_Schedule_Info *sinfo);
00209 static void tcp_accept_evt_needs_wakeup(Scheme_Object *_ae, void *fds);
00210 #ifdef UDP_IS_SUPPORTED
00211 static int udp_evt_check_ready(Scheme_Object *uw, Scheme_Schedule_Info *sinfo);
00212 static void udp_evt_needs_wakeup(Scheme_Object *_uw, void *fds);
00213 #endif
00214 
00215 static void register_tcp_listener_sync();
00216 
00217 #ifdef MZ_PRECISE_GC
00218 static void register_traversers(void);
00219 #endif
00220 
00221 void scheme_init_network(Scheme_Env *env)
00222 {
00223   Scheme_Env *netenv;
00224 
00225 #ifdef MZ_PRECISE_GC
00226   register_traversers();
00227 #endif
00228 
00229   netenv = scheme_primitive_module(scheme_intern_symbol("#%network"), env);
00230 
00231   scheme_add_global_constant("tcp-connect", 
00232                           scheme_make_prim_w_arity2(tcp_connect,
00233                                                  "tcp-connect", 
00234                                                  2, 4,
00235                                                  2, 2), 
00236                           netenv);
00237   scheme_add_global_constant("tcp-connect/enable-break", 
00238                           scheme_make_prim_w_arity2(tcp_connect_break,
00239                                                  "tcp-connect/enable-break", 
00240                                                  2, 4,
00241                                                  2, 2), 
00242                           netenv);
00243   scheme_add_global_constant("tcp-listen", 
00244                           scheme_make_prim_w_arity(tcp_listen,
00245                                                 "tcp-listen", 
00246                                                 1, 4),
00247                           netenv);
00248   scheme_add_global_constant("tcp-close", 
00249                           scheme_make_prim_w_arity(tcp_stop,
00250                                                 "tcp-close", 
00251                                                 1, 1), 
00252                           netenv);
00253   scheme_add_global_constant("tcp-accept-ready?", 
00254                           scheme_make_prim_w_arity(tcp_accept_ready,
00255                                                 "tcp-accept-ready?", 
00256                                                 1, 1), 
00257                           netenv);
00258   scheme_add_global_constant("tcp-accept", 
00259                           scheme_make_prim_w_arity2(tcp_accept,
00260                                                  "tcp-accept", 
00261                                                  1, 1,
00262                                                  2, 2), 
00263                           netenv);
00264   scheme_add_global_constant("tcp-accept-evt", 
00265                           scheme_make_prim_w_arity(tcp_accept_evt,
00266                                                 "tcp-accept-evt", 
00267                                                 1, 1), 
00268                           netenv);
00269   scheme_add_global_constant("tcp-accept/enable-break", 
00270                           scheme_make_prim_w_arity2(tcp_accept_break,
00271                                                  "tcp-accept/enable-break", 
00272                                                  1, 1,
00273                                                  2, 2), 
00274                           netenv);
00275   scheme_add_global_constant("tcp-listener?", 
00276                           scheme_make_folding_prim(tcp_listener_p,
00277                                                 "tcp-listener?", 
00278                                                 1, 1, 1), 
00279                           netenv);
00280   scheme_add_global_constant("tcp-addresses", 
00281                           scheme_make_prim_w_arity2(tcp_addresses,
00282                                                  "tcp-addresses", 
00283                                                  1, 2,
00284                                                  2, 4), 
00285                           netenv);
00286   scheme_add_global_constant("tcp-abandon-port", 
00287                           scheme_make_prim_w_arity(tcp_abandon_port,
00288                                                 "tcp-abandon-port", 
00289                                                 1, 1), 
00290                           netenv);
00291   scheme_add_global_constant("tcp-port?", 
00292                           scheme_make_folding_prim(tcp_port_p,
00293                                                 "tcp-port?", 
00294                                                 1, 1, 1), 
00295                           netenv);
00296 
00297   scheme_add_global_constant("udp-open-socket", 
00298                           scheme_make_prim_w_arity(make_udp,
00299                                                 "udp-open-socket", 
00300                                                 0, 2), 
00301                           netenv);
00302   scheme_add_global_constant("udp-close", 
00303                           scheme_make_prim_w_arity(udp_close,
00304                                                 "udp-close", 
00305                                                 1, 1), 
00306                           netenv);
00307   scheme_add_global_constant("udp?", 
00308                           scheme_make_folding_prim(udp_p,
00309                                                 "udp?", 
00310                                                 1, 1, 1), 
00311                           netenv);
00312   scheme_add_global_constant("udp-bound?", 
00313                           scheme_make_prim_w_arity(udp_bound_p,
00314                                                 "udp-bound?", 
00315                                                 1, 1), 
00316                           netenv);
00317   scheme_add_global_constant("udp-connected?", 
00318                           scheme_make_prim_w_arity(udp_connected_p,
00319                                                 "udp-connected?", 
00320                                                 1, 1), 
00321                           netenv);
00322 
00323   scheme_add_global_constant("udp-bind!", 
00324                           scheme_make_prim_w_arity(udp_bind,
00325                                                 "udp-bind!", 
00326                                                 3, 3), 
00327                           netenv);
00328   scheme_add_global_constant("udp-connect!", 
00329                           scheme_make_prim_w_arity(udp_connect,
00330                                                 "udp-connect!", 
00331                                                 3, 3), 
00332                           netenv);
00333 
00334   scheme_add_global_constant("udp-send-to", 
00335                           scheme_make_prim_w_arity(udp_send_to,
00336                                                 "udp-send-to", 
00337                                                 4, 6), 
00338                           netenv);
00339   scheme_add_global_constant("udp-send", 
00340                           scheme_make_prim_w_arity(udp_send,
00341                                                 "udp-send", 
00342                                                 2, 4), 
00343                           netenv);
00344   scheme_add_global_constant("udp-send-to*", 
00345                           scheme_make_prim_w_arity(udp_send_to_star,
00346                                                 "udp-send-to*", 
00347                                                 4, 6), 
00348                           netenv);
00349   scheme_add_global_constant("udp-send*", 
00350                           scheme_make_prim_w_arity(udp_send_star,
00351                                                 "udp-send*", 
00352                                                 2, 4), 
00353                           netenv);
00354   scheme_add_global_constant("udp-send-to/enable-break", 
00355                           scheme_make_prim_w_arity(udp_send_to_enable_break,
00356                                                 "udp-send-to/enable-break", 
00357                                                 4, 6), 
00358                           netenv);
00359   scheme_add_global_constant("udp-send/enable-break", 
00360                           scheme_make_prim_w_arity(udp_send_enable_break,
00361                                                 "udp-send/enable-break", 
00362                                                 2, 4), 
00363                           netenv);
00364 
00365   scheme_add_global_constant("udp-receive!", 
00366                           scheme_make_prim_w_arity(udp_receive,
00367                                                 "udp-receive!", 
00368                                                 2, 4), 
00369                           netenv);
00370   scheme_add_global_constant("udp-receive!*", 
00371                           scheme_make_prim_w_arity(udp_receive_star,
00372                                                 "udp-receive!*", 
00373                                                 2, 4), 
00374                           netenv);
00375   scheme_add_global_constant("udp-receive!/enable-break", 
00376                           scheme_make_prim_w_arity(udp_receive_enable_break,
00377                                                 "udp-receive!/enable-break", 
00378                                                 2, 4), 
00379                           netenv);
00380   scheme_add_global_constant("udp-receive-ready-evt", 
00381                           scheme_make_prim_w_arity(udp_read_ready_evt,
00382                                                 "udp-receive-ready-evt", 
00383                                                 1, 1), 
00384                           netenv);
00385   scheme_add_global_constant("udp-send-ready-evt", 
00386                           scheme_make_prim_w_arity(udp_write_ready_evt,
00387                                                 "udp-send-ready-evt", 
00388                                                 1, 1), 
00389                           netenv);
00390   scheme_add_global_constant("udp-receive!-evt", 
00391                           scheme_make_prim_w_arity(udp_read_evt,
00392                                                 "udp-receive!-evt", 
00393                                                 2, 4), 
00394                           netenv);
00395   scheme_add_global_constant("udp-send-evt", 
00396                           scheme_make_prim_w_arity(udp_write_evt,
00397                                                 "udp-send-evt", 
00398                                                 2, 4), 
00399                           netenv);
00400   scheme_add_global_constant("udp-send-to-evt", 
00401                           scheme_make_prim_w_arity(udp_write_to_evt,
00402                                                 "udp-send-to-evt", 
00403                                                 4, 6), 
00404                           netenv);
00405 
00406   register_tcp_listener_sync();
00407 
00408   scheme_finish_primitive_module(netenv);
00409 }
00410 
00411 
00412 /*========================================================================*/
00413 /*                             TCP glue                                   */
00414 /*========================================================================*/
00415 
00416 
00417 /* These two need o be outside of USE_TCP */
00418 #define PORT_ID_TYPE "exact integer in [1, 65535]"
00419 #define CHECK_PORT_ID(obj) (SCHEME_INTP(obj) && (SCHEME_INT_VAL(obj) >= 1) && (SCHEME_INT_VAL(obj) <= 65535))
00420 
00421 #ifdef USE_TCP
00422 
00423 #ifdef USE_SOCKETS_TCP
00424 #define MAKE_TCP_ARG tcp_t tcp, 
00425 #else
00426 #define MAKE_TCP_ARG
00427 #endif
00428 
00429 #define REGISTER_SOCKET(s) 
00430 #define UNREGISTER_SOCKET(s) 
00431 
00432 #ifdef USE_UNIX_SOCKETS_TCP
00433 typedef struct sockaddr_in mz_unspec_address;
00434 #endif
00435 #ifdef USE_WINSOCK_TCP
00436 typedef struct SOCKADDR_IN mz_unspec_address;
00437 # undef REGISTER_SOCKET
00438 # undef UNREGISTER_SOCKET
00439 # define REGISTER_SOCKET(s) winsock_remember(s)
00440 # define UNREGISTER_SOCKET(s) winsock_forget(s)
00441 #endif
00442 
00443 /******************************* hostnames ************************************/
00444 
00445 #ifdef OS_X
00446 # define PTHREADS_OK_FOR_GHBN
00447 #endif
00448 
00449 # ifdef PROTOENT_IS_INT
00450 #  define PROTO_P_PROTO PROTOENT_IS_INT
00451 # else
00452 static struct protoent *proto;
00453 #  define PROTO_P_PROTO (proto ? proto->p_proto : 0)
00454 # endif
00455 
00456 # ifndef MZ_PF_INET
00457 #  define MZ_PF_INET PF_INET
00458 # endif
00459 
00460 /* For getting connection names: */
00461 #define MZ_SOCK_NAME_MAX_LEN 256
00462 #define MZ_SOCK_HOST_NAME_MAX_LEN 64
00463 #define MZ_SOCK_SVC_NAME_MAX_LEN 32
00464 
00465 /* mz_addrinfo is defined in scheme.h */
00466 
00467 #ifdef HAVE_GETADDRINFO
00468 # define mzAI_PASSIVE AI_PASSIVE 
00469 # define mz_getaddrinfo getaddrinfo
00470 # define mz_freeaddrinfo freeaddrinfo
00471 # define mz_gai_strerror gai_strerror
00472 #else
00473 # define mzAI_PASSIVE 0
00474 # ifdef MZ_XFORM
00475 START_XFORM_SKIP;
00476 # endif
00477 static int mz_getaddrinfo(const char *nodename, const char *servname,
00478                        const struct mz_addrinfo *hints, struct mz_addrinfo **res)
00479 {
00480   struct hostent *h;
00481 
00482   if (nodename)
00483     h = gethostbyname(nodename);
00484   else
00485     h = NULL;
00486 
00487   if (h || !nodename) {
00488     GC_CAN_IGNORE struct mz_addrinfo *ai;
00489     GC_CAN_IGNORE struct sockaddr_in *sa;
00490     int j, id = 0;
00491 
00492     ai = (struct mz_addrinfo *)malloc(sizeof(struct mz_addrinfo));
00493     sa = (struct sockaddr_in *)malloc(sizeof(struct sockaddr_in));
00494     ai->ai_addr = (struct sockaddr *)sa;
00495 
00496     ai->ai_addrlen = sizeof(struct sockaddr_in);
00497     if (servname) {
00498       for (j = 0; servname[j]; j++) {
00499        id = (id * 10) + (servname[j] - '0');
00500       }
00501     }
00502 
00503     ai->ai_family = MZ_PF_INET;
00504     ai->ai_socktype = hints->ai_socktype;
00505     ai->ai_protocol = hints->ai_protocol;
00506     ai->ai_next = NULL;
00507 
00508     sa->sin_family = (id ? AF_INET : AF_UNSPEC);
00509     j = htons(id);
00510     sa->sin_port = j;
00511     memset(&(sa->sin_addr), 0, sizeof(sa->sin_addr));
00512     memset(&(sa->sin_zero), 0, sizeof(sa->sin_zero));
00513     if (h)
00514       memcpy(&sa->sin_addr, h->h_addr_list[0], h->h_length); 
00515     
00516     *res = ai;
00517     return 0;
00518   }
00519   return h_errno;
00520 }
00521 void mz_freeaddrinfo(struct mz_addrinfo *ai)
00522 {
00523   free(ai->ai_addr);
00524   free(ai);
00525 }
00526 const char *mz_gai_strerror(int ecode)
00527 {
00528   return hstrerror(ecode);
00529 }
00530 # ifdef MZ_XFORM
00531 END_XFORM_SKIP;
00532 # endif
00533 #endif
00534 
00535 #if defined(USE_WINSOCK_TCP) || defined(PTHREADS_OK_FOR_GHBN)
00536 
00537 # ifdef USE_WINSOCK_TCP
00538 #  ifdef __BORLANDC__
00539 #   define MZ_LPTHREAD_START_ROUTINE unsigned int (__stdcall*)(void*)
00540 #  else
00541 #   define MZ_LPTHREAD_START_ROUTINE LPTHREAD_START_ROUTINE
00542 #  endif
00543 # else
00544 #  include <pthread.h>
00545 #   define MZ_LPTHREAD_START_ROUTINE void *(*)(void *)
00546 # endif
00547 
00548 static volatile int ghbn_lock;
00549 
00550 typedef struct {
00551 # ifdef USE_WINSOCK_TCP
00552   HANDLE th;
00553 # else
00554   int pin;
00555 # endif
00556   struct mz_addrinfo *result;
00557   int err;
00558   int done;
00559 } GHBN_Rec;
00560 
00561 static struct mz_addrinfo * volatile ghbn_result;
00562 static volatile int ghbn_err;
00563 
00564 /* For in-thread DNS: */
00565 #define MZ_MAX_HOSTNAME_LEN 128
00566 #define MZ_MAX_SERVNAME_LEN 32
00567 
00568 static char ghbn_hostname[MZ_MAX_HOSTNAME_LEN];
00569 static char ghbn_servname[MZ_MAX_SERVNAME_LEN];
00570 static struct mz_addrinfo ghbn_hints;
00571 # ifdef USE_WINSOCK_TCP
00572 HANDLE ready_sema;
00573 # else
00574 int ready_fd;
00575 # endif
00576 
00577 #ifdef MZ_XFORM
00578 START_XFORM_SKIP;
00579 #endif
00580 
00581 static long getaddrinfo_in_thread(void *data)
00582 {
00583   int ok;
00584   struct mz_addrinfo *res, hints;
00585   char hn_copy[MZ_MAX_HOSTNAME_LEN], sn_copy[MZ_MAX_SERVNAME_LEN];
00586 # ifndef USE_WINSOCK_TCP
00587   int fd = ready_fd;
00588 # endif
00589   
00590   if (ghbn_result) {
00591     mz_freeaddrinfo(ghbn_result);
00592     ghbn_result = NULL;
00593   }
00594 
00595   strcpy(hn_copy, ghbn_hostname);
00596   strcpy(sn_copy, ghbn_servname);
00597   memcpy(&hints, &ghbn_hints, sizeof(hints));
00598 
00599 # ifdef USE_WINSOCK_TCP
00600   ReleaseSemaphore(ready_sema, 1, NULL);  
00601 # else
00602   write(fd, "?", 1);
00603 # endif
00604 
00605   ok = mz_getaddrinfo(hn_copy[0] ? hn_copy : NULL, 
00606                     sn_copy[0] ? sn_copy : NULL, 
00607                     &hints, &res);
00608 
00609   ghbn_result = res;
00610   ghbn_err = ok;
00611 
00612 # ifndef USE_WINSOCK_TCP
00613   {
00614     long v = 1;
00615     write(fd, &v, sizeof(v));
00616     close(fd);
00617   }
00618 # endif
00619 
00620   return 1;
00621 }
00622 
00623 #ifdef MZ_XFORM
00624 END_XFORM_SKIP;
00625 #endif
00626 
00627 static void release_ghbn_lock(GHBN_Rec *rec)
00628 {
00629   ghbn_lock = 0;
00630 # ifdef USE_WINSOCK_TCP
00631   CloseHandle(rec->th);
00632 # else
00633   close(rec->pin);
00634 # endif
00635 }
00636 
00637 static int ghbn_lock_avail(Scheme_Object *_ignored)
00638 {
00639   return !ghbn_lock;
00640 }
00641 
00642 static int ghbn_thread_done(Scheme_Object *_rec)
00643 {
00644   GHBN_Rec *rec = (GHBN_Rec *)_rec;
00645 
00646   if (rec->done)
00647     return 1;
00648 
00649 # ifdef USE_WINSOCK_TCP
00650   if (WaitForSingleObject(rec->th, 0) == WAIT_OBJECT_0) {
00651     rec->result = ghbn_result;
00652     ghbn_result = NULL;
00653     rec->err = ghbn_err;
00654     rec->done = 1;
00655     return 1;
00656   }
00657 # else
00658   {
00659     long v;
00660     if (read(rec->pin, &v, sizeof(long)) > 0) {
00661       rec->result = ghbn_result;
00662       ghbn_result = NULL;
00663       rec->err = ghbn_err;
00664       rec->done = 1;
00665       return 1;
00666     }
00667   }
00668 # endif
00669 
00670   return 0;
00671 }
00672 
00673 static void ghbn_thread_need_wakeup(Scheme_Object *_rec, void *fds)
00674 {
00675   GHBN_Rec *rec = (GHBN_Rec *)_rec;
00676 
00677 # ifdef USE_WINSOCK_TCP
00678   scheme_add_fd_handle((void *)rec->th, fds, 0);
00679 # else
00680   {
00681     void *fds2;
00682     
00683     fds2 = MZ_GET_FDSET(fds, 2);
00684     
00685     MZ_FD_SET(rec->pin, (fd_set *)fds);
00686     MZ_FD_SET(rec->pin, (fd_set *)fds2);
00687   }
00688 # endif
00689 }
00690 
00691 static int MZ_GETADDRINFO(const char *name, const char *svc, struct mz_addrinfo *hints, struct mz_addrinfo **res)
00692 {
00693   GHBN_Rec *rec;
00694   int ok;
00695 
00696   if ((name && ((strlen(name) >= MZ_MAX_HOSTNAME_LEN) || !name[0]))
00697       || (svc && ((strlen(svc) >= MZ_MAX_SERVNAME_LEN) || !svc[0]))) {
00698     /* Give up on a separate thread. */
00699     return mz_getaddrinfo(name, svc, hints, res);
00700   }
00701 
00702   rec = MALLOC_ONE_ATOMIC(GHBN_Rec);
00703   rec->done = 0;
00704 
00705   scheme_block_until(ghbn_lock_avail, NULL, NULL, 0);
00706 
00707   ghbn_lock = 1;
00708 
00709   if (name)
00710     strcpy(ghbn_hostname, name);
00711   else
00712     ghbn_hostname[0] = 0;
00713   if (svc)
00714     strcpy(ghbn_servname, svc);
00715   else
00716     ghbn_servname[0] = 0;
00717   memcpy(&ghbn_hints, hints, sizeof(ghbn_hints));
00718 
00719 # ifdef USE_WINSOCK_TCP
00720   {
00721     DWORD id;
00722     long th;
00723     
00724     ready_sema = CreateSemaphore(NULL, 0, 1, NULL);
00725     th = _beginthreadex(NULL, 5000, 
00726                      (MZ_LPTHREAD_START_ROUTINE)getaddrinfo_in_thread,
00727                      NULL, 0, &id);
00728     WaitForSingleObject(ready_sema, INFINITE);
00729     CloseHandle(ready_sema);
00730     
00731     rec->th = (HANDLE)th;
00732     ok = 1;
00733   }
00734 # else
00735   {
00736     int p[2];
00737     if (pipe(p)) {
00738       ok = 0;
00739     } else {
00740       pthread_t t;
00741       rec->pin = p[0];
00742       ready_fd = p[1];
00743       if (pthread_create(&t, NULL, 
00744                       (MZ_LPTHREAD_START_ROUTINE)getaddrinfo_in_thread,
00745                       NULL)) {
00746        close(p[0]);
00747        close(p[1]);
00748        ok = 0;
00749       } else {
00750        char buf[1];
00751        pthread_detach(t);
00752        read(rec->pin, buf, 1);
00753        fcntl(rec->pin, F_SETFL, MZ_NONBLOCKING);
00754        ok = 1;
00755       }
00756     }
00757 
00758     if (!ok) {
00759       getaddrinfo_in_thread(rec);
00760       rec->result = ghbn_result;
00761       ghbn_result = NULL;
00762       rec->err = ghbn_err;
00763     }
00764   }
00765 # endif
00766 
00767   if (ok) {
00768     BEGIN_ESCAPEABLE(release_ghbn_lock, rec);
00769     scheme_block_until(ghbn_thread_done, ghbn_thread_need_wakeup, (Scheme_Object *)rec, 0);
00770     END_ESCAPEABLE();
00771 
00772 # ifdef USE_WINSOCK_TCP
00773     CloseHandle(rec->th);
00774 # else
00775     close(rec->pin);
00776 # endif
00777   }
00778 
00779   ghbn_lock = 0;
00780 
00781   *res = rec->result;
00782 
00783   return rec->err;
00784 }
00785 #else
00786 # define MZ_GETADDRINFO mz_getaddrinfo
00787 #endif
00788 
00789 #ifdef USE_SOCKETS_TCP
00790 
00791 struct mz_addrinfo *scheme_get_host_address(const char *address, int id, int *err, 
00792                                        int family, int passive, int tcp)
00793 {
00794   char buf[32], *service;
00795   int ok;
00796   GC_CAN_IGNORE struct mz_addrinfo *r, hints;
00797 
00798   if (id) {
00799     service = buf;
00800     sprintf(buf, "%d", id);
00801   } else
00802     service = NULL;
00803   
00804   if (!address && !service) {
00805     *err = -1;
00806     return NULL;
00807   }
00808 
00809   memset(&hints, 0, sizeof(struct mz_addrinfo));
00810   hints.ai_family = ((family < 0) ? PF_UNSPEC : family);
00811   if (passive) {
00812     hints.ai_flags |= mzAI_PASSIVE;
00813   }
00814   if (tcp) {
00815     hints.ai_socktype = SOCK_STREAM;
00816 # ifndef PROTOENT_IS_INT
00817     if (!proto) {
00818       proto = getprotobyname("tcp");
00819     }
00820 # endif
00821     hints.ai_protocol= PROTO_P_PROTO;
00822   } else {
00823     hints.ai_socktype = SOCK_DGRAM;
00824   }
00825 
00826   ok = MZ_GETADDRINFO(address, service, &hints, &r);
00827   *err = ok;
00828   
00829   if (!ok)
00830     return r;
00831   else
00832     return NULL;
00833 }
00834 
00835 void scheme_free_host_address(struct mz_addrinfo *a)
00836 {
00837   mz_freeaddrinfo(a);
00838 }
00839 
00840 const char *scheme_host_address_strerror(int errnum)
00841 {
00842   return mz_gai_strerror(errnum);
00843 }
00844 #endif
00845 
00846 /******************************* WinSock ***********************************/
00847 
00848 #ifdef USE_WINSOCK_TCP
00849 
00850 static int wsr_size = 0;
00851 static tcp_t *wsr_array;
00852 
00853 static void winsock_remember(tcp_t s)
00854 {
00855   int i, new_size;
00856   tcp_t *naya;
00857 
00858   for (i = 0; i < wsr_size; i++) {
00859     if (!wsr_array[i]) {
00860       wsr_array[i] = s;
00861       return;
00862     }
00863   }
00864 
00865   if (!wsr_size) {
00866     REGISTER_SO(wsr_array);
00867     new_size = 32;
00868   } else
00869     new_size = 2 * wsr_size;
00870 
00871   naya = MALLOC_N_ATOMIC(tcp_t, new_size);
00872   for (i = 0; i < wsr_size; i++) {
00873     naya[i] = wsr_array[i];
00874   }
00875 
00876   naya[wsr_size] = s;
00877 
00878   wsr_array = naya;
00879   wsr_size = new_size;  
00880 }
00881 
00882 static void winsock_forget(tcp_t s)
00883 {
00884   int i;
00885 
00886   for (i = 0; i < wsr_size; i++) {
00887     if (wsr_array[i] == s) {
00888       wsr_array[i] = (tcp_t)NULL;
00889       return;
00890     }
00891   }
00892 }
00893 
00894 static int winsock_done(void)
00895 {
00896   int i;
00897 
00898   for (i = 0; i < wsr_size; i++) {
00899     if (wsr_array[i]) {
00900       closesocket(wsr_array[i]);
00901       wsr_array[i] = (tcp_t)NULL;
00902     }
00903   }
00904 
00905   return WSACleanup();
00906 }
00907 
00908 static void TCP_INIT(char *name)
00909 {
00910   static int started = 0;
00911   
00912   if (!started) {
00913     WSADATA data;
00914     if (!WSAStartup(MAKEWORD(1, 1), &data)) {
00915       started = 1;
00916 #ifdef __BORLANDC__
00917       atexit((void(*)())winsock_done);
00918 #else      
00919       _onexit(winsock_done);
00920 #endif
00921       return;
00922     }
00923   } else
00924     return;
00925   
00926   scheme_raise_exn(MZEXN_FAIL_UNSUPPORTED,
00927                  "%s: not supported on this machine"
00928                  " (no winsock driver)",
00929                  name);
00930 }
00931 #else
00932 /* Not Winsock */
00933 # define TCP_INIT(x) /* nothing */
00934 #endif
00935 
00936 /*========================================================================*/
00937 /*                       TCP ports and listeners                          */
00938 /*========================================================================*/
00939 
00940 #ifdef USE_SOCKETS_TCP
00941 #define LISTENER_WAS_CLOSED(x) (((listener_t *)(x))->s[0] == INVALID_SOCKET)
00942 #endif
00943 #ifndef LISTENER_WAS_CLOSED
00944 #define LISTENER_WAS_CLOSED(x) 0
00945 #endif
00946 
00947 /* Forward declaration */
00948 static int stop_listener(Scheme_Object *o);
00949 
00950 static int tcp_check_accept(Scheme_Object *_listener)
00951 {
00952 #ifdef USE_SOCKETS_TCP
00953   tcp_t s, mx;
00954   listener_t *listener = (listener_t *)_listener;
00955   DECL_OS_FDSET(readfds);
00956   DECL_OS_FDSET(exnfds);
00957   struct timeval time = {0, 0};
00958   int sr, i;
00959 
00960   INIT_DECL_OS_FDSET(readfds);
00961   INIT_DECL_OS_FDSET(exnfds);
00962 
00963   if (LISTENER_WAS_CLOSED(listener))
00964     return 1;
00965 
00966   MZ_OS_FD_ZERO(readfds);
00967   MZ_OS_FD_ZERO(exnfds);
00968 
00969   mx = 0;
00970   for (i = 0; i < listener->count; i++) {
00971     s = listener->s[i];
00972     MZ_OS_FD_SET(s, readfds);
00973     MZ_OS_FD_SET(s, exnfds);
00974     if (s > mx)
00975       mx = s;
00976   }
00977   
00978   do {
00979     sr = select(mx + 1, readfds, NULL, exnfds, &time);
00980   } while ((sr == -1) && (NOT_WINSOCK(errno) == EINTR));
00981 
00982   if (sr) {
00983     for (i = 0; i < listener->count; i++) {
00984       s = listener->s[i];
00985       if (MZ_OS_FD_ISSET(s, readfds)
00986          || MZ_OS_FD_ISSET(s, exnfds))
00987        return i + 1;
00988     }
00989   }
00990 
00991   return sr;
00992 #endif
00993 }
00994 
00995 static void tcp_accept_needs_wakeup(Scheme_Object *_listener, void *fds)
00996 {
00997 #ifdef USE_SOCKETS_TCP
00998   if (!LISTENER_WAS_CLOSED(_listener)) {
00999     listener_t *listener = (listener_t *)_listener;
01000     int i;
01001     tcp_t s;
01002     void *fds2;
01003 
01004     fds2 = MZ_GET_FDSET(fds, 2);
01005     
01006     for (i = 0; i < listener->count; i++) {
01007       s = listener->s[i];
01008       MZ_FD_SET(s, (fd_set *)fds);
01009       MZ_FD_SET(s, (fd_set *)fds2);
01010     }
01011   }
01012 #endif
01013 }
01014 
01015 static int tcp_check_connect(Scheme_Object *connector_p)
01016 {
01017 #ifdef USE_SOCKETS_TCP
01018   tcp_t s;
01019   DECL_OS_FDSET(writefds);
01020   DECL_OS_FDSET(exnfds);
01021   struct timeval time = {0, 0};
01022   int sr;
01023 
01024   INIT_DECL_OS_FDSET(writefds);
01025   INIT_DECL_OS_FDSET(exnfds);
01026 
01027   s = *(tcp_t *)connector_p;
01028 
01029   MZ_OS_FD_ZERO(writefds);
01030   MZ_OS_FD_ZERO(exnfds);
01031 
01032   MZ_OS_FD_SET(s, writefds);
01033   MZ_OS_FD_SET(s, exnfds);
01034     
01035   do {
01036     sr = select(s + 1, NULL, writefds, exnfds, &time);
01037   } while ((sr == -1) && (NOT_WINSOCK(errno) == EINTR));
01038 
01039   if (!sr)
01040     return 0;
01041   if (FD_ISSET(s, exnfds))
01042     return -1;
01043   else
01044     return 1;
01045 #else
01046   return 0;
01047 #endif
01048 }
01049 
01050 static void tcp_connect_needs_wakeup(Scheme_Object *connector_p, void *fds)
01051 {
01052 #ifdef USE_SOCKETS_TCP
01053   void *fds1, *fds2;
01054   tcp_t s = *(tcp_t *)connector_p;
01055   
01056   fds1 = MZ_GET_FDSET(fds, 1);
01057   fds2 = MZ_GET_FDSET(fds, 2);
01058 
01059   MZ_FD_SET(s, (fd_set *)fds1);
01060   MZ_FD_SET(s, (fd_set *)fds2);
01061 #endif
01062 }
01063 
01064 static int tcp_check_write(Scheme_Object *port)
01065 {
01066   Scheme_Tcp *data = (Scheme_Tcp *)((Scheme_Output_Port *)port)->port_data;
01067 
01068   if (((Scheme_Output_Port *)port)->closed)
01069     return 1;
01070 
01071 #ifdef USE_SOCKETS_TCP
01072   {
01073     tcp_t s;
01074     DECL_OS_FDSET(writefds);
01075     DECL_OS_FDSET(exnfds);
01076     struct timeval time = {0, 0};
01077     int sr;
01078     
01079     INIT_DECL_OS_FDSET(writefds);
01080     INIT_DECL_OS_FDSET(exnfds);
01081     
01082     s = data->tcp;
01083     
01084     MZ_OS_FD_ZERO(writefds);
01085     MZ_OS_FD_SET(s, writefds);
01086     MZ_OS_FD_ZERO(exnfds);
01087     MZ_OS_FD_SET(s, exnfds);
01088     
01089     do {
01090       sr = select(s + 1, NULL, writefds, exnfds, &time);
01091     } while ((sr == -1) && (NOT_WINSOCK(errno) == EINTR));
01092     
01093     return sr;
01094   }
01095 #else
01096   {
01097     TCPiopbX *xpb;
01098     TCPiopb *pb;
01099     int bytes;
01100     
01101     xpb = mac_make_xpb(data);
01102     pb = (TCPiopb *)xpb;
01103     
01104     pb->csCode = TCPStatus;
01105     if (mzPBControlSync((ParamBlockRec*)pb))
01106       bytes = -1;
01107     else {
01108       bytes = pb->csParam.status.sendWindow - pb->csParam.status.amtUnackedData;
01109       if (bytes < 0)
01110        bytes = 0;
01111     }
01112     
01113     return !!bytes;
01114   }
01115 #endif
01116 }
01117 
01118 static void tcp_write_needs_wakeup(Scheme_Object *port, void *fds)
01119 {
01120 #ifdef USE_SOCKETS_TCP
01121   Scheme_Object *conn = ((Scheme_Output_Port *)port)->port_data;
01122   void *fds1, *fds2;
01123   tcp_t s = ((Scheme_Tcp *)conn)->tcp;
01124   
01125   fds1 = MZ_GET_FDSET(fds, 1);
01126   fds2 = MZ_GET_FDSET(fds, 2);
01127   
01128   MZ_FD_SET(s, (fd_set *)fds1);
01129   MZ_FD_SET(s, (fd_set *)fds2);
01130 #endif
01131 }
01132 
01133 
01134 static Scheme_Tcp *make_tcp_port_data(MAKE_TCP_ARG int refcount)
01135 {
01136   Scheme_Tcp *data;
01137   char *bfr;
01138   
01139   data = MALLOC_ONE_RT(Scheme_Tcp);
01140 #ifdef MZTAG_REQUIRED
01141   data->b.type = scheme_rt_tcp;
01142 #endif
01143 #ifdef USE_SOCKETS_TCP
01144   data->tcp = tcp;
01145 #endif
01146 
01147   bfr = (char *)scheme_malloc_atomic(TCP_BUFFER_SIZE);
01148   data->b.buffer = bfr;
01149   bfr = (char *)scheme_malloc_atomic(TCP_BUFFER_SIZE);
01150   data->b.out_buffer = bfr;
01151 
01152   data->b.bufpos = 0;
01153   data->b.bufmax = 0;
01154   data->b.hiteof = 0;
01155   data->b.refcount = refcount;
01156 
01157 #ifdef USE_WINSOCK_TCP
01158   {
01159     unsigned long ioarg = 1;
01160     ioctlsocket(tcp, FIONBIO, &ioarg);
01161   }
01162 #else
01163   fcntl(tcp, F_SETFL, MZ_NONBLOCKING);
01164 #endif
01165 
01166   return data;
01167 }
01168 
01169 static int tcp_byte_ready (Scheme_Input_Port *port)
01170 {
01171   Scheme_Tcp *data;
01172 #ifdef USE_SOCKETS_TCP
01173   int sr;
01174   DECL_OS_FDSET(readfds);
01175   DECL_OS_FDSET(exfds);
01176   struct timeval time = {0, 0};
01177 
01178   INIT_DECL_OS_FDSET(readfds);
01179   INIT_DECL_OS_FDSET(exfds);
01180 #endif
01181 
01182   if (port->closed)
01183     return 1;
01184 
01185   data = (Scheme_Tcp *)port->port_data;
01186 
01187   if (data->b.hiteof)
01188     return 1;
01189   if (data->b.bufpos < data->b.bufmax)
01190     return 1;
01191 
01192 #ifdef USE_SOCKETS_TCP
01193   MZ_OS_FD_ZERO(readfds);
01194   MZ_OS_FD_ZERO(exfds);
01195   MZ_OS_FD_SET(data->tcp, readfds);
01196   MZ_OS_FD_SET(data->tcp, exfds);
01197     
01198   do {
01199     sr = select(data->tcp + 1, readfds, NULL, exfds, &time);
01200   } while ((sr == -1) && (NOT_WINSOCK(errno) == EINTR));
01201 
01202   return sr;
01203 #endif
01204 
01205   return 0;
01206 }
01207 
01208 static long tcp_get_string(Scheme_Input_Port *port, 
01209                         char *buffer, long offset, long size,
01210                         int nonblock,
01211                         Scheme_Object *unless)
01212 {
01213   int errid;
01214   int read_amt;
01215   Scheme_Tcp *data;
01216 
01217   data = (Scheme_Tcp *)port->port_data;
01218 
01219  top:
01220 
01221   if (scheme_unless_ready(unless))
01222     return SCHEME_UNLESS_READY;
01223 
01224   if (data->b.hiteof)
01225     return EOF;
01226 
01227   if (data->b.bufpos < data->b.bufmax) {
01228     int n;
01229     n = data->b.bufmax - data->b.bufpos;
01230     n = ((size <= n)
01231         ? size
01232         : n);
01233     
01234     memcpy(buffer + offset, data->b.buffer + data->b.bufpos, n);
01235     data->b.bufpos += n;
01236     
01237     return n;
01238   }
01239   
01240   while (!tcp_byte_ready(port)) {
01241     if (nonblock > 0)
01242       return 0;
01243 
01244 #ifdef USE_SOCKETS_TCP
01245     scheme_block_until_unless((Scheme_Ready_Fun)tcp_byte_ready,
01246                            scheme_need_wakeup,
01247                            (Scheme_Object *)port,
01248                            0.0, unless,
01249                            nonblock);
01250 #else
01251     do {
01252       scheme_thread_block_enable_break((float)0.0, nonblock);
01253       if (scheme_unless_ready(unless))
01254        break;
01255     } while (!tcp_byte_ready(port));
01256     scheme_current_thread->ran_some = 1;
01257 #endif
01258 
01259     scheme_wait_input_allowed(port, nonblock);
01260 
01261     if (scheme_unless_ready(unless))
01262       return SCHEME_UNLESS_READY;
01263   }
01264 
01265   if (port->closed) {
01266     /* Another thread closed the input port while we were waiting. */
01267     /* Call scheme_get_byte to signal the error */
01268     scheme_get_byte((Scheme_Object *)port);
01269   }
01270 
01271   /* We assume that no other process has access to our sockets, so
01272      when we unblock, there's definitely something to read. */
01273 
01274   if (!data->b.bufmode || (size > TCP_BUFFER_SIZE))
01275     read_amt = TCP_BUFFER_SIZE;
01276   else
01277     read_amt = size;
01278 
01279 #ifdef USE_SOCKETS_TCP
01280   {
01281     int rn;
01282     do {
01283       rn = recv(data->tcp, data->b.buffer, read_amt, 0);
01284     } while ((rn == -1) && (NOT_WINSOCK(errno) == EINTR));
01285     data->b.bufmax = rn;
01286   }
01287   errid = SOCK_ERRNO();
01288 
01289   /* Is it possible that an EAGAIN error occurs? That means that data
01290      isn't ready, even though select() says that data is ready. It
01291      seems to happen for at least one user, and there appears to be
01292      no harm in protecting against it. */
01293   if ((data->b.bufmax == -1) && WAS_EAGAIN(errid))
01294     goto top;
01295 
01296 #endif
01297   
01298   if (data->b.bufmax == -1) {
01299     scheme_raise_exn(MZEXN_FAIL_NETWORK,
01300                    "tcp-read: error reading (%e)",
01301                    errid);
01302     return 0;
01303   } else if (!data->b.bufmax) {
01304     data->b.hiteof = 1;
01305     return EOF;
01306   }
01307 
01308   {
01309     int n;
01310     n = data->b.bufmax;
01311     if (size < n)
01312       n = size;
01313     memcpy(buffer + offset, data->b.buffer, n);
01314     data->b.bufpos = n;
01315 
01316     return n;
01317   }
01318 }
01319 
01320 static void tcp_need_wakeup(Scheme_Input_Port *port, void *fds)
01321 {
01322   Scheme_Tcp *data;
01323 
01324   data = (Scheme_Tcp *)port->port_data;
01325 
01326 #ifdef USE_SOCKETS_TCP
01327   {
01328     void *fds2;
01329   
01330     fds2 = MZ_GET_FDSET(fds, 2);
01331     
01332     MZ_FD_SET(data->tcp, (fd_set *)fds);
01333     MZ_FD_SET(data->tcp, (fd_set *)fds2);
01334   }
01335 #endif
01336 }
01337 
01338 static void tcp_close_input(Scheme_Input_Port *port)
01339 {
01340   Scheme_Tcp *data;
01341 
01342   data = (Scheme_Tcp *)port->port_data;
01343 
01344 #ifdef USE_SOCKETS_TCP
01345   if (!(data->flags & MZ_TCP_ABANDON_INPUT)) {
01346     int cr;
01347     do { 
01348       cr = shutdown(data->tcp, 0);
01349     } while ((cr == -1) && (errno == EINTR));
01350   }
01351 #endif
01352 
01353   if (--data->b.refcount)
01354     return;
01355 
01356 #ifdef USE_SOCKETS_TCP
01357   UNREGISTER_SOCKET(data->tcp);
01358   closesocket(data->tcp);
01359 #endif
01360 
01361   --scheme_file_open_count;
01362 }
01363 
01364 static int
01365 tcp_in_buffer_mode(Scheme_Port *p, int mode)
01366 {
01367   Scheme_Tcp *data;
01368 
01369   data = (Scheme_Tcp *)((Scheme_Input_Port *)p)->port_data;  
01370   if (mode < 0)
01371     return data->b.bufmode;
01372   else {
01373     data->b.bufmode = mode;
01374     return mode;
01375   }
01376 }
01377 
01378 static long tcp_do_write_string(Scheme_Output_Port *port, 
01379                             const char *s, long offset, long len, 
01380                             int rarely_block, int enable_break)
01381 {
01382   /* We've already checked for buffering before we got here. */
01383   /* If rarely_block is 1, it means only write as much as
01384      can be flushed immediately, blocking only if nothing
01385      can be written. */
01386   /* If rarely_block is 2, it means only write as much as
01387      can be flushed immediately, never ever blocking. */
01388 
01389   Scheme_Tcp *data;
01390   int errid, would_block = 0;
01391   long sent;
01392 
01393   data = (Scheme_Tcp *)port->port_data;
01394 
01395  top:
01396 
01397 #ifdef USE_SOCKETS_TCP
01398   do {
01399     sent = send(data->tcp, s XFORM_OK_PLUS offset, len, 0);
01400   } while ((sent == -1) && (NOT_WINSOCK(errno) == EINTR));
01401 
01402   if (sent != len) {
01403 #ifdef USE_WINSOCK_TCP
01404 # define SEND_BAD_MSG_SIZE(e) (e == WSAEMSGSIZE)
01405 #else    
01406 # ifdef SEND_IS_NEVER_TOO_BIG
01407 #  define SEND_BAD_MSG_SIZE(errid) 0
01408 # else
01409 #  define SEND_BAD_MSG_SIZE(errid) (errid == EMSGSIZE)
01410 # endif
01411 #endif
01412     errid = SOCK_ERRNO();
01413     if (sent > 0) {
01414       /* Some data was sent. Return, or recur to handle the rest. */
01415       if (rarely_block)
01416        return sent;
01417       else
01418        sent += tcp_do_write_string(port, s, offset + sent, len - sent, 0, enable_break);
01419       errid = 0;
01420     } else if ((len > 1) && SEND_BAD_MSG_SIZE(errid)) {
01421       /* split the message and try again: */
01422       int half = (len / 2);
01423       sent = tcp_do_write_string(port, s, offset, half, rarely_block, enable_break);
01424       if (rarely_block)
01425        return sent;
01426       sent += tcp_do_write_string(port, s, offset + half, len - half, 0, enable_break);
01427       errid = 0;
01428     } else if (WAS_EAGAIN(errid)) {
01429       errid = 0;
01430       would_block = 1;
01431     }
01432   } else
01433     errid = 0;
01434 #endif
01435 
01436   if (would_block) {
01437     if (rarely_block == 2)
01438       return 0;
01439 
01440     /* Block for writing: */
01441     scheme_block_until_enable_break(tcp_check_write, tcp_write_needs_wakeup, (Scheme_Object *)port, 
01442                                 (float)0.0, enable_break);
01443 
01444     /* Closed while blocking? */
01445     if (((Scheme_Output_Port *)port)->closed) {
01446       /* Call write again to signal the error: */
01447       scheme_put_byte_string("tcp-write-string", (Scheme_Object *)port, s, offset, len, 0);
01448       return sent + len; /* shouldn't get here */
01449     }
01450 
01451     /* Ok - try again! */
01452     would_block = 0;
01453     goto top;
01454   }
01455 
01456   if (errid)
01457     scheme_raise_exn(MZEXN_FAIL_NETWORK,
01458                    "tcp-write: error writing (%e)",
01459                    errid);
01460 
01461   return sent;
01462 }
01463 
01464 static int tcp_flush(Scheme_Output_Port *port,
01465                    int rarely_block, int enable_break)
01466 {
01467   Scheme_Tcp *data;
01468   int amt, flushed = 0;
01469   
01470   data = (Scheme_Tcp *)port->port_data;
01471 
01472   while (1) {
01473     if (data->b.out_bufpos == data->b.out_bufmax) {
01474       data->b.out_bufpos = 0;
01475       data->b.out_bufmax = 0;
01476       return flushed;
01477     }
01478     amt = tcp_do_write_string(port, data->b.out_buffer, data->b.out_bufpos, 
01479                            data->b.out_bufmax - data->b.out_bufpos,
01480                            rarely_block, enable_break);
01481     flushed += amt;
01482     data->b.out_bufpos += amt;
01483     if (rarely_block && (data->b.out_bufpos < data->b.out_bufmax))
01484       return flushed;
01485   }
01486 }
01487 
01488 static long tcp_write_string(Scheme_Output_Port *port, 
01489                           const char *s, long offset, long len, 
01490                           int rarely_block, int enable_break)
01491 {
01492   Scheme_Tcp *data;
01493 
01494   data = (Scheme_Tcp *)port->port_data;
01495 
01496   if (!len) {
01497     /* Flush */
01498     return tcp_flush(port, rarely_block, enable_break);
01499   }
01500 
01501   if (rarely_block) {
01502     tcp_flush(port, rarely_block, enable_break);
01503     if (data->b.out_bufmax)
01504       return -1;
01505   } else {
01506     if (data->b.out_bufmode < 2) {
01507       if (data->b.out_bufmax + len < TCP_BUFFER_SIZE) {
01508        memcpy(data->b.out_buffer + data->b.out_bufmax, s + offset, len);
01509        data->b.out_bufmax += (short)len;
01510        if (data->b.out_bufmode == 1) {
01511          /* Check for newline */
01512          int i;
01513          for (i = 0; i < len; i++) {
01514            if ((s[offset + i] == '\r')
01515               || (s[offset + i] == '\n'))
01516              break;
01517          }
01518          if (i < len)
01519            tcp_flush(port, rarely_block, enable_break);
01520        }
01521        return len;
01522       }
01523     }
01524     tcp_flush(port, rarely_block, enable_break);
01525   }
01526 
01527   /* When we get here, the buffer is empty */
01528   return tcp_do_write_string(port, s, offset, len, rarely_block, enable_break);
01529 }
01530 
01531 static void tcp_close_output(Scheme_Output_Port *port)
01532 {
01533   Scheme_Tcp *data;
01534 
01535   data = (Scheme_Tcp *)port->port_data;
01536 
01537   if (data->b.out_bufmax && !scheme_force_port_closed)
01538     tcp_flush(port, 0, 0);
01539 
01540 #ifdef USE_SOCKETS_TCP
01541   if (!(data->flags & MZ_TCP_ABANDON_OUTPUT)) {
01542     int cr;
01543     do { 
01544       cr = shutdown(data->tcp, 1);
01545     } while ((cr == -1) && (errno == EINTR));
01546   }
01547 #endif
01548 
01549   if (--data->b.refcount)
01550     return;
01551 
01552 #ifdef USE_SOCKETS_TCP
01553   UNREGISTER_SOCKET(data->tcp);
01554   closesocket(data->tcp);
01555 #endif
01556 
01557   --scheme_file_open_count;
01558 }
01559 
01560 static int
01561 tcp_out_buffer_mode(Scheme_Port *p, int mode)
01562 {
01563   Scheme_Tcp *data;
01564 
01565   data = (Scheme_Tcp *)((Scheme_Output_Port *)p)->port_data;  
01566   if (mode < 0)
01567     return data->b.out_bufmode;
01568   else {
01569     int go;
01570     go = (mode > data->b.out_bufmode);
01571     data->b.out_bufmode = mode;
01572     if (go)
01573       tcp_flush((Scheme_Output_Port *)p, 0, 0);
01574     return mode;
01575   }
01576 }
01577 
01578 static Scheme_Object *
01579 make_tcp_input_port(void *data, const char *name, Scheme_Object *cust)
01580 {
01581   Scheme_Input_Port *ip;
01582 
01583   if (cust)
01584     scheme_set_next_port_custodian((Scheme_Custodian *)cust);
01585   
01586   ip = scheme_make_input_port(scheme_tcp_input_port_type,
01587                            data,
01588                            scheme_intern_symbol(name),
01589                            tcp_get_string,
01590                            NULL,
01591                            scheme_progress_evt_via_get,
01592                            scheme_peeked_read_via_get,
01593                            tcp_byte_ready,
01594                            tcp_close_input,
01595                            tcp_need_wakeup,
01596                            1);
01597 
01598   ip->p.buffer_mode_fun = tcp_in_buffer_mode;
01599 
01600   return (Scheme_Object *)ip;
01601 }
01602 
01603 static Scheme_Object *
01604 make_tcp_output_port(void *data, const char *name, Scheme_Object *cust)
01605 {
01606   Scheme_Output_Port *op;
01607 
01608   if (cust)
01609     scheme_set_next_port_custodian((Scheme_Custodian *)cust);
01610 
01611   op = scheme_make_output_port(scheme_tcp_output_port_type,
01612                                             data,
01613                                             scheme_intern_symbol(name),
01614                                             scheme_write_evt_via_write,
01615                                             tcp_write_string,
01616                                             (Scheme_Out_Ready_Fun)tcp_check_write,
01617                                             tcp_close_output,
01618                                             (Scheme_Need_Wakeup_Output_Fun)tcp_write_needs_wakeup,
01619                                             NULL,
01620                                             NULL,
01621                                             1);
01622 
01623   op->p.buffer_mode_fun = tcp_out_buffer_mode;
01624 
01625   return (Scheme_Object *)op;
01626 }
01627 
01628 #endif /* USE_TCP */
01629 
01630 /*========================================================================*/
01631 /*                         TCP Scheme interface                           */
01632 /*========================================================================*/
01633 
01634 #ifdef USE_SOCKETS_TCP
01635 typedef struct Close_Socket_Data {
01636   tcp_t s;
01637   struct mz_addrinfo *src_addr, *dest_addr;
01638 } Close_Socket_Data;
01639 
01640 static void closesocket_w_decrement(Close_Socket_Data *csd)
01641 {
01642   closesocket(csd->s);
01643   if (csd->src_addr)
01644     mz_freeaddrinfo(csd->src_addr);
01645   mz_freeaddrinfo(csd->dest_addr);  
01646   --scheme_file_open_count;
01647 }
01648 #endif
01649 
01650 const char *scheme_hostname_error(int err)
01651 {
01652 #ifdef USE_SOCKETS_TCP
01653   return mz_gai_strerror(err);
01654 #else
01655   return "?";
01656 #endif
01657 }
01658 
01659 static Scheme_Object *tcp_connect(int argc, Scheme_Object *argv[])
01660 {
01661   char * volatile address = "", * volatile src_address, * volatile errmsg = "";
01662   unsigned short origid, id, src_origid, src_id;
01663   int errpart = 0, errid = 0;
01664   volatile int nameerr = 0, no_local_spec;
01665   Scheme_Object *bs, *src_bs;
01666 #ifdef USE_SOCKETS_TCP
01667   GC_CAN_IGNORE struct mz_addrinfo *tcp_connect_dest;
01668   GC_CAN_IGNORE struct mz_addrinfo * volatile tcp_connect_src;
01669 #endif
01670 
01671   if (!SCHEME_CHAR_STRINGP(argv[0]))
01672     scheme_wrong_type("tcp-connect", "string", 0, argc, argv);
01673   if (!CHECK_PORT_ID(argv[1]))
01674     scheme_wrong_type("tcp-connect", PORT_ID_TYPE, 1, argc, argv);
01675   if (argc > 2)
01676     if (!SCHEME_CHAR_STRINGP(argv[2]) && !SCHEME_FALSEP(argv[2]))
01677       scheme_wrong_type("tcp-connect", "string or #f", 2, argc, argv);
01678   if (argc > 3)
01679     if (SCHEME_TRUEP(argv[3]) && !CHECK_PORT_ID(argv[3]))
01680       scheme_wrong_type("tcp-connect", PORT_ID_TYPE " or #f", 3, argc, argv);
01681 
01682 #ifdef USE_TCP
01683   TCP_INIT("tcp-connect");
01684 #endif
01685 
01686   bs = argv[0];
01687   if (SCHEME_CHAR_STRINGP(bs))
01688     bs = scheme_char_string_to_byte_string(bs);
01689 
01690   address = SCHEME_BYTE_STR_VAL(bs);
01691   origid = (unsigned short)SCHEME_INT_VAL(argv[1]);
01692 
01693   if ((argc > 2) && SCHEME_TRUEP(argv[2])) {
01694     src_bs = scheme_char_string_to_byte_string(argv[2]);
01695     src_address = SCHEME_BYTE_STR_VAL(src_bs);
01696   } else
01697     src_address = NULL;
01698    
01699   if ((argc > 3) && SCHEME_TRUEP(argv[3])) {
01700     no_local_spec = 0;
01701     src_origid = (unsigned short)SCHEME_INT_VAL(argv[3]);
01702   } else {
01703     no_local_spec = 1;
01704     src_origid = 0;
01705     if (src_address) {
01706       scheme_arg_mismatch("tcp-connect",
01707                        "no local port number supplied when local hostname was supplied: ",
01708                        argv[2]);
01709     }
01710   }
01711 
01712   scheme_security_check_network("tcp-connect", address, origid, 1);
01713   scheme_custodian_check_available(NULL, "tcp-connect", "network");
01714 
01715 #ifdef USE_TCP
01716   id = origid;
01717   src_id = src_origid;
01718 #endif
01719 
01720 #ifdef USE_SOCKETS_TCP
01721   tcp_connect_dest = scheme_get_host_address(address, id, &errid, -1, 0, 1);
01722   if (tcp_connect_dest) {
01723     if (no_local_spec)
01724       tcp_connect_src = NULL;
01725     else
01726       tcp_connect_src = scheme_get_host_address(src_address, src_id, &errid, -1, 1, 1);
01727     if (no_local_spec || tcp_connect_src) {
01728       GC_CAN_IGNORE struct mz_addrinfo * volatile addr;
01729       for (addr = tcp_connect_dest; addr; addr = addr->ai_next) {
01730        tcp_t s;
01731        s = socket(addr->ai_family, addr->ai_socktype, addr->ai_protocol);
01732        if (s != INVALID_SOCKET) {
01733          int status, inprogress;
01734          if (no_local_spec
01735              || !bind(s, tcp_connect_src->ai_addr, tcp_connect_src->ai_addrlen)) {
01736 #ifdef USE_WINSOCK_TCP
01737            unsigned long ioarg = 1;
01738            ioctlsocket(s, FIONBIO, &ioarg);
01739 #else
01740            int size = TCP_SOCKSENDBUF_SIZE;
01741            fcntl(s, F_SETFL, MZ_NONBLOCKING);
01742 # ifndef CANT_SET_SOCKET_BUFSIZE
01743            setsockopt(s, SOL_SOCKET, SO_SNDBUF, (char *)&size, sizeof(int));
01744 # endif
01745 #endif
01746            status = connect(s, addr->ai_addr, addr->ai_addrlen);
01747 #ifdef USE_UNIX_SOCKETS_TCP
01748            if (status)
01749              status = errno;
01750            if (status == EINTR)
01751              status = EINPROGRESS;
01752        
01753            inprogress = (status == EINPROGRESS);
01754 #endif
01755 #ifdef USE_WINSOCK_TCP
01756            if (status)
01757              status = WSAGetLastError();
01758 
01759            inprogress = (status == WSAEWOULDBLOCK);
01760            errno = status;
01761 #endif
01762 
01763            scheme_file_open_count++;
01764          
01765            if (inprogress) {
01766              tcp_t *sptr;
01767              Close_Socket_Data *csd;
01768 
01769              sptr = (tcp_t *)scheme_malloc_atomic(sizeof(tcp_t));
01770              *sptr = s;
01771 
01772              csd = (Close_Socket_Data *)scheme_malloc_atomic(sizeof(Close_Socket_Data));
01773              csd->s = s;
01774              csd->src_addr = tcp_connect_src;
01775              csd->dest_addr = tcp_connect_dest;
01776 
01777              BEGIN_ESCAPEABLE(closesocket_w_decrement, csd);
01778              scheme_block_until(tcp_check_connect, tcp_connect_needs_wakeup, (void *)sptr, (float)0.0);
01779              END_ESCAPEABLE();
01780 
01781              /* Check whether connect succeeded, or get error: */
01782              {
01783               unsigned int so_len = sizeof(status);
01784               if (getsockopt(s, SOL_SOCKET, SO_ERROR, (void *)&status, &so_len) != 0) {
01785                 status = SOCK_ERRNO();
01786               }
01787               errno = status; /* for error reporting, below */
01788              }
01789 
01790 #ifdef USE_WINSOCK_TCP
01791              if (scheme_stupid_windows_machine > 0) {
01792               /* getsockopt() seems not to work in Windows 95, so use the
01793                  result from select(), which seems to reliably detect an error condition */
01794               if (!status) {
01795                 if (tcp_check_connect((Scheme_Object *)sptr) == -1) {
01796                   status = 1;
01797                   errno = WSAECONNREFUSED; /* guess! */
01798                 }
01799               }
01800              }
01801 #endif
01802            }
01803        
01804            if (!status) {
01805              Scheme_Object *v[2];
01806              Scheme_Tcp *tcp;
01807 
01808              if (tcp_connect_src)
01809               mz_freeaddrinfo(tcp_connect_src);
01810              mz_freeaddrinfo(tcp_connect_dest);
01811 
01812              tcp = make_tcp_port_data(s, 2);
01813              
01814              v[0] = make_tcp_input_port(tcp, address, NULL);
01815              v[1] = make_tcp_output_port(tcp, address, NULL);
01816              
01817              REGISTER_SOCKET(s);
01818 
01819              return scheme_values(2, v);
01820            } else {
01821              errid = errno;
01822              closesocket(s);
01823              --scheme_file_open_count;
01824              errpart = 6;
01825            }
01826          } else {
01827            errpart = 5;
01828            errid = SOCK_ERRNO();
01829          }
01830        } else {
01831          errpart = 4;
01832          errid = SOCK_ERRNO();
01833        }
01834       }
01835       if (tcp_connect_src)
01836        mz_freeaddrinfo(tcp_connect_src);
01837     } else {
01838       errpart = 2;
01839       nameerr = 1;
01840       errmsg = "; local host not found";
01841     } 
01842     if (tcp_connect_dest)
01843       mz_freeaddrinfo(tcp_connect_dest);
01844   } else {
01845     errpart = 1;
01846     nameerr = 1;
01847     errmsg = "; host not found";
01848   }
01849 #endif
01850 
01851 #ifdef USE_TCP
01852   scheme_raise_exn(MZEXN_FAIL_NETWORK,
01853                  "tcp-connect: connection to %s, port %d failed%s (at step %d: %N)",
01854                  address, origid, errmsg, errpart, nameerr, errid);
01855 #else
01856   scheme_raise_exn(MZEXN_FAIL_UNSUPPORTED,
01857                  "tcp-connect: not supported on this platform");
01858 #endif
01859 
01860   return NULL;
01861 }
01862 
01863 static Scheme_Object *
01864 tcp_connect_break(int argc, Scheme_Object *argv[])
01865 {
01866   return scheme_call_enable_break(tcp_connect, argc, argv);
01867 }
01868 
01869 static Scheme_Object *
01870 tcp_listen(int argc, Scheme_Object *argv[])
01871 {
01872   unsigned short id, origid;
01873   int backlog, errid;
01874   int reuse = 0;
01875 #ifdef MZ_TCP_LISTEN_IPV6_ONLY_SOCKOPT
01876   int no_ipv6 = 0;
01877 #endif
01878   const char *address;
01879   
01880   if (!CHECK_PORT_ID(argv[0]))
01881     scheme_wrong_type("tcp-listen", PORT_ID_TYPE, 0, argc, argv);
01882   if (argc > 1) {
01883     if (!SCHEME_INTP(argv[1]) || (SCHEME_INT_VAL(argv[1]) < 1))
01884       scheme_wrong_type("tcp-listen", "small positive integer", 1, argc, argv);
01885   }
01886   if (argc > 2)
01887     reuse = SCHEME_TRUEP(argv[2]);
01888   if (argc > 3) {
01889     if (!SCHEME_CHAR_STRINGP(argv[3]) && !SCHEME_FALSEP(argv[3]))
01890       scheme_wrong_type("tcp-listen", "string or #f", 3, argc, argv);
01891   }
01892     
01893 #ifdef USE_TCP
01894   TCP_INIT("tcp-listen");
01895 #endif
01896 
01897   origid = (unsigned short)SCHEME_INT_VAL(argv[0]);
01898   if (argc > 1)
01899     backlog = SCHEME_INT_VAL(argv[1]);
01900   else
01901     backlog = 4;
01902   if ((argc > 3) && SCHEME_TRUEP(argv[3])) {
01903     Scheme_Object *bs;
01904     bs = scheme_char_string_to_byte_string(argv[3]);
01905     address = SCHEME_BYTE_STR_VAL(bs);
01906   } else
01907     address = NULL;
01908 
01909   scheme_security_check_network("tcp-listen", address, origid, 0);
01910   scheme_custodian_check_available(NULL, "tcp-listen", "network");
01911 
01912 #ifdef USE_TCP
01913   id = origid;
01914 #endif
01915 
01916 #ifdef MZ_TCP_LISTEN_IPV6_ONLY_SOCKOPT
01917  retry:
01918 #endif
01919 
01920   {
01921     GC_CAN_IGNORE struct mz_addrinfo *tcp_listen_addr, *addr;
01922     int err, count = 0, pos = 0, i;
01923     listener_t *l = NULL;
01924 #ifdef MZ_TCP_LISTEN_IPV6_ONLY_SOCKOPT
01925     int any_v4 = 0, any_v6 = 0;
01926 #endif
01927 
01928     tcp_listen_addr = scheme_get_host_address(address, id, &err, 
01929 #ifdef MZ_TCP_LISTEN_IPV6_ONLY_SOCKOPT
01930                                          no_ipv6 ? MZ_PF_INET : -1,
01931 #else
01932                                          -1, 
01933 #endif
01934                                          1, 1);
01935 
01936     for (addr = tcp_listen_addr; addr; addr = addr->ai_next) {
01937 #ifdef MZ_TCP_LISTEN_IPV6_ONLY_SOCKOPT
01938       if (addr->ai_family == MZ_PF_INET)
01939        any_v4 = 1;
01940       else if (addr->ai_family == PF_INET6)
01941        any_v6 = 1;
01942 #endif
01943       count++;
01944     }
01945               
01946     if (tcp_listen_addr) {
01947       tcp_t s;
01948 #ifdef MZ_TCP_LISTEN_IPV6_ONLY_SOCKOPT
01949       /* Try IPv6 listeners first, so we can retry and use just IPv4 if
01950         IPv6 doesn't work right. */
01951       int v6_loop = (any_v6 && any_v4), skip_v6 = 0;
01952 #endif
01953 
01954       errid = 0;
01955       for (addr = tcp_listen_addr; addr; ) {
01956 #ifdef MZ_TCP_LISTEN_IPV6_ONLY_SOCKOPT
01957        if ((v6_loop && (addr->ai_family != PF_INET6))
01958            || (skip_v6 && (addr->ai_family == PF_INET6))) {
01959          addr = addr->ai_next;
01960          if (v6_loop && !addr) {
01961            v6_loop = 0;
01962            skip_v6 = 1;
01963            addr = tcp_listen_addr;
01964          }
01965          continue;
01966        }
01967 #endif
01968 
01969        s = socket(addr->ai_family, addr->ai_socktype, addr->ai_protocol);
01970 
01971 #ifdef MZ_TCP_LISTEN_IPV6_ONLY_SOCKOPT
01972        if (s == INVALID_SOCKET) {
01973          /* Maybe it failed because IPv6 is not available: */
01974          if ((addr->ai_family == PF_INET6) && (errno == EAFNOSUPPORT)) {
01975            if (any_v4 && !pos) {
01976              /* Maybe we can make it work with just IPv4. Try again. */
01977              no_ipv6 = 1;
01978              mz_freeaddrinfo(tcp_listen_addr);
01979              goto retry;
01980            }
01981          }
01982        }
01983        if (s != INVALID_SOCKET) {
01984          if (any_v4 && (addr->ai_family == PF_INET6)) {
01985            int ok;
01986 # ifdef IPV6_V6ONLY
01987            int on = 1;
01988            ok = setsockopt(s, IPPROTO_IPV6, IPV6_V6ONLY, &on, sizeof(on));
01989 # else
01990            ok = -1;
01991 # endif
01992            if (ok) {
01993              if (!pos) {
01994               /* IPV6_V6ONLY doesn't work */
01995               no_ipv6 = 1;
01996               mz_freeaddrinfo(tcp_listen_addr);
01997               goto retry;
01998              } else {
01999               errid = errno;
02000               closesocket(s);
02001               errno = errid;
02002               s = INVALID_SOCKET;
02003              }
02004            }
02005          }
02006        }
02007 #endif
02008 
02009        if (s != INVALID_SOCKET) {
02010 #ifdef USE_WINSOCK_TCP
02011          unsigned long ioarg = 1;
02012          ioctlsocket(s, FIONBIO, &ioarg);
02013 #else
02014          fcntl(s, F_SETFL, MZ_NONBLOCKING);
02015 #endif
02016 
02017          if (reuse) {
02018            setsockopt(s, SOL_SOCKET, SO_REUSEADDR, (char *)(&reuse), sizeof(int));
02019          }
02020       
02021          if (!bind(s, addr->ai_addr, addr->ai_addrlen)) {
02022            if (!listen(s, backlog)) {
02023              if (!pos) {
02024               l = scheme_malloc_tagged(sizeof(listener_t) + ((count - 1) * sizeof(tcp_t)));
02025               l->so.type = scheme_listener_type;
02026               l->count = count;
02027               {
02028                 Scheme_Custodian_Reference *mref;
02029                 mref = scheme_add_managed(NULL,
02030                                        (Scheme_Object *)l,
02031                                        (Scheme_Close_Custodian_Client *)stop_listener,
02032                                        NULL,
02033                                        1);
02034                 l->mref = mref;
02035               }
02036              }
02037              l->s[pos++] = s;
02038            
02039              scheme_file_open_count++;
02040              REGISTER_SOCKET(s);
02041 
02042              if (pos == count) {
02043               mz_freeaddrinfo(tcp_listen_addr);
02044 
02045               return (Scheme_Object *)l;
02046              }
02047            } else {
02048              errid = SOCK_ERRNO();
02049              closesocket(s);
02050              break;
02051            }
02052          } else {
02053            errid = SOCK_ERRNO();
02054            closesocket(s);
02055            break;
02056          }
02057        } else {
02058          errid = SOCK_ERRNO();
02059          break;
02060        }
02061 
02062        addr = addr->ai_next;
02063 
02064 #ifdef MZ_TCP_LISTEN_IPV6_ONLY_SOCKOPT
02065        if (!addr && v6_loop) {
02066          v6_loop = 0;
02067          skip_v6 = 1;
02068          addr = tcp_listen_addr;
02069        }
02070 #endif
02071       }
02072 
02073       for (i = 0; i < pos; i++) {
02074        s = l->s[i];
02075        UNREGISTER_SOCKET(s);
02076        closesocket(s);
02077        --scheme_file_open_count;
02078       }
02079       
02080       mz_freeaddrinfo(tcp_listen_addr);
02081     } else {
02082       scheme_raise_exn(MZEXN_FAIL_NETWORK,
02083                      "tcp-listen: host not found: %s (%N)",
02084                      address, 1, err);
02085       return NULL;
02086     }
02087   }
02088 
02089 #ifdef USE_TCP
02090   scheme_raise_exn(MZEXN_FAIL_NETWORK,
02091                  "tcp-listen: listen on %d failed (%E)",
02092                  origid, errid);
02093 #else
02094   scheme_raise_exn(MZEXN_FAIL_UNSUPPORTED,
02095                  "tcp-listen: not supported on this platform");
02096 #endif
02097 
02098   return NULL;
02099 }
02100 
02101 #ifdef USE_TCP
02102 static int stop_listener(Scheme_Object *o)
02103 {
02104   int was_closed = 0;
02105 
02106 #ifdef USE_SOCKETS_TCP
02107   {
02108     listener_t *listener = (listener_t *)o;
02109     int i;
02110     tcp_t s;
02111     s = listener->s[0];
02112     if (s == INVALID_SOCKET)
02113       was_closed = 1;
02114     else {
02115       for (i = 0; i < listener->count; i++) {
02116        s = listener->s[i];
02117        UNREGISTER_SOCKET(s);
02118        closesocket(s);
02119        listener->s[i] = INVALID_SOCKET;
02120        --scheme_file_open_count;
02121       }
02122       scheme_remove_managed(((listener_t *)o)->mref, o);
02123     }
02124   }
02125 #endif
02126 
02127   return was_closed;
02128 }
02129 #endif
02130 
02131 static Scheme_Object *
02132 tcp_stop(int argc, Scheme_Object *argv[])
02133 {
02134 #ifdef USE_TCP
02135   int was_closed;
02136 
02137   if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_listener_type))
02138     scheme_wrong_type("tcp-close", "tcp-listener", 0, argc, argv);
02139 
02140   TCP_INIT("tcp-close");
02141 
02142   was_closed = stop_listener(argv[0]);
02143 
02144   if (was_closed) {
02145     scheme_raise_exn(MZEXN_FAIL_NETWORK,
02146                    "tcp-close: listener was already closed");
02147     return NULL;
02148   }
02149 
02150   return scheme_void;
02151 #else
02152   scheme_wrong_type("tcp-close", "tcp-listener", 0, argc, argv);
02153   return NULL;
02154 #endif
02155 }
02156 
02157 static Scheme_Object *
02158 tcp_accept_ready(int argc, Scheme_Object *argv[])
02159 {
02160 #ifdef USE_TCP
02161   int ready;
02162 
02163   if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_listener_type))
02164     scheme_wrong_type("tcp-accept-ready?", "tcp-listener", 0, argc, argv);
02165 
02166   TCP_INIT("tcp-accept-ready?");
02167 
02168   if (LISTENER_WAS_CLOSED(argv[0])) {
02169     scheme_raise_exn(MZEXN_FAIL_NETWORK,
02170                    "tcp-accept-ready?: listener is closed");
02171     return NULL;
02172   }
02173 
02174   ready = tcp_check_accept(argv[0]);
02175 
02176   return (ready ? scheme_true : scheme_false);
02177 #else
02178   scheme_wrong_type("tcp-accept-ready?", "tcp-listener", 0, argc, argv);
02179   return NULL;
02180 #endif
02181 }
02182 
02183 static Scheme_Object *
02184 do_tcp_accept(int argc, Scheme_Object *argv[], Scheme_Object *cust, char **_fail_reason)
02185 /* If _fail_reason is not NULL, never raise an exception. */
02186 {
02187 #ifdef USE_TCP
02188   int was_closed = 0, errid, ready_pos;
02189   Scheme_Object *listener;
02190 # ifdef USE_SOCKETS_TCP
02191   tcp_t s, ls;
02192   unsigned int l;
02193   GC_CAN_IGNORE char tcp_accept_addr[MZ_SOCK_NAME_MAX_LEN];
02194 # endif
02195 
02196   if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_listener_type))
02197     scheme_wrong_type("tcp-accept", "tcp-listener", 0, argc, argv);
02198 
02199   TCP_INIT("tcp-accept");
02200 
02201   listener = argv[0];
02202 
02203   was_closed = LISTENER_WAS_CLOSED(listener);
02204 
02205   if (!was_closed) {
02206     ready_pos = tcp_check_accept(listener);
02207     if (!ready_pos) {
02208       scheme_block_until(tcp_check_accept, tcp_accept_needs_wakeup, listener, 0.0);
02209       ready_pos = tcp_check_accept(listener);
02210     }
02211     was_closed = LISTENER_WAS_CLOSED(listener);
02212   } else
02213     ready_pos = 0;
02214 
02215   if (was_closed) {
02216     if (_fail_reason)
02217       *_fail_reason = "tcp-accept-evt: listener is closed";
02218     else
02219       scheme_raise_exn(MZEXN_FAIL_NETWORK,
02220                        "tcp-accept: listener is closed");
02221     return NULL;
02222   }
02223 
02224   if (!_fail_reason)
02225     scheme_custodian_check_available((Scheme_Custodian *)cust, "tcp-accept", "network");
02226   else {
02227     if (!scheme_custodian_is_available((Scheme_Custodian *)cust)) {
02228       *_fail_reason = "tcp-accept-evt: custodian is shutdown";
02229       return NULL;
02230     }
02231   }
02232   
02233 # ifdef USE_SOCKETS_TCP
02234   ls = ((listener_t *)listener)->s[ready_pos-1];
02235 
02236   l = sizeof(tcp_accept_addr);
02237 
02238   do {
02239     s = accept(ls, (struct sockaddr *)tcp_accept_addr, &l);
02240   } while ((s == -1) && (NOT_WINSOCK(errno) == EINTR));
02241 
02242   if (s != INVALID_SOCKET) {
02243     Scheme_Object *v[2];
02244     Scheme_Tcp *tcp;
02245     
02246 #  ifdef USE_UNIX_SOCKETS_TCP
02247     int size = TCP_SOCKSENDBUF_SIZE;
02248 #   ifndef CANT_SET_SOCKET_BUFSIZE
02249     setsockopt(s, SOL_SOCKET, SO_SNDBUF, (char *)&size, sizeof(int));
02250 #   endif
02251 #  endif
02252 
02253     tcp = make_tcp_port_data(s, 2);
02254 
02255     v[0] = make_tcp_input_port(tcp, "tcp-accepted", cust);
02256     v[1] = make_tcp_output_port(tcp, "tcp-accepted", cust);
02257 
02258     scheme_file_open_count++;
02259     REGISTER_SOCKET(s);
02260     
02261     return scheme_values(2, v);
02262   }
02263   errid = SOCK_ERRNO();
02264 # endif
02265   
02266   if (_fail_reason)
02267     *_fail_reason = "tcp-accept-evt: accept from listener failed";
02268   else
02269     scheme_raise_exn(MZEXN_FAIL_NETWORK,
02270                      "tcp-accept: accept from listener failed (%E)", errid);
02271 #else
02272   scheme_wrong_type("tcp-accept", "tcp-listener", 0, argc, argv);
02273 #endif
02274 
02275   return NULL;
02276 }
02277 
02278 static Scheme_Object *
02279 tcp_accept(int argc, Scheme_Object *argv[])
02280 {
02281   return do_tcp_accept(argc, argv, NULL, NULL);
02282 }
02283 
02284 static Scheme_Object *
02285 tcp_accept_break(int argc, Scheme_Object *argv[])
02286 {
02287   return scheme_call_enable_break(tcp_accept, argc, argv);
02288 }
02289 
02290 static void register_tcp_listener_sync()
02291 {
02292 #ifdef USE_TCP
02293   scheme_add_evt(scheme_listener_type, tcp_check_accept, tcp_accept_needs_wakeup, NULL, 0);
02294   scheme_add_evt(scheme_tcp_accept_evt_type, (Scheme_Ready_Fun)tcp_check_accept_evt, tcp_accept_evt_needs_wakeup, NULL, 0);
02295 # ifdef UDP_IS_SUPPORTED
02296   scheme_add_evt(scheme_udp_evt_type, (Scheme_Ready_Fun)udp_evt_check_ready, udp_evt_needs_wakeup, NULL, 0);
02297 # endif
02298 #endif
02299 }
02300 
02301 static Scheme_Object *tcp_listener_p(int argc, Scheme_Object *argv[])
02302 {
02303    return (SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_listener_type)
02304           ? scheme_true
02305           : scheme_false);
02306 }
02307 
02308 void scheme_getnameinfo(void *sa, int salen, 
02309                      char *host, int hostlen,
02310                      char *serv, int servlen)
02311 {
02312 #ifdef HAVE_GETADDRINFO
02313   getnameinfo(sa, salen, host, hostlen, serv, servlen,
02314              NI_NUMERICHOST | NI_NUMERICSERV);
02315 #else
02316   if (host) {
02317     unsigned char *b;
02318     b = (unsigned char *)&((struct sockaddr_in *)sa)->sin_addr;
02319     sprintf(host, "%d.%d.%d.%d", b[0], b[1], b[2], b[3]);
02320   }
02321   if (serv) {
02322     int id;
02323     id = ntohs(((struct sockaddr_in *)sa)->sin_port);
02324     sprintf(serv, "%d", id);
02325   }
02326 #endif
02327 }
02328 
02329 static int extract_svc_value(char *svc_buf)
02330 {
02331   int id = 0, j;
02332   for (j = 0; svc_buf[j]; j++) {
02333     id = (id * 10) + (svc_buf[j] - '0');
02334   }
02335   return id;
02336 }
02337 
02338 static Scheme_Object *tcp_addresses(int argc, Scheme_Object *argv[])
02339 {
02340 #ifdef USE_TCP
02341   Scheme_Tcp *tcp = NULL;
02342   int closed = 0;
02343   Scheme_Object *result[4];
02344   int with_ports = 0;
02345 
02346   if (SCHEME_OUTPUT_PORTP(argv[0])) {
02347     Scheme_Output_Port *op;
02348     op = scheme_output_port_record(argv[0]);
02349     if (op->sub_type == scheme_tcp_output_port_type)
02350       tcp = op->port_data;
02351     closed = op->closed;
02352   } else if (SCHEME_INPUT_PORTP(argv[0])) {
02353     Scheme_Input_Port *ip;
02354     ip = scheme_input_port_record(argv[0]);
02355     if (ip->sub_type == scheme_tcp_input_port_type)
02356       tcp = ip->port_data;
02357     closed = ip->closed;
02358   }
02359 
02360   if (argc > 1)
02361     with_ports = SCHEME_TRUEP(argv[1]);
02362 
02363   if (!tcp)
02364     scheme_wrong_type("tcp-addresses", "tcp-port", 0, argc, argv);
02365 
02366   if (closed)
02367     scheme_raise_exn(MZEXN_FAIL_NETWORK,
02368                    "tcp-addresses: port is closed");
02369 
02370 # ifdef USE_SOCKETS_TCP
02371   {
02372     unsigned int l;
02373     char here[MZ_SOCK_NAME_MAX_LEN], there[MZ_SOCK_NAME_MAX_LEN];
02374     char host_buf[MZ_SOCK_HOST_NAME_MAX_LEN];
02375     char svc_buf[MZ_SOCK_SVC_NAME_MAX_LEN];
02376     unsigned int here_len, there_len;
02377 
02378     l = sizeof(here);
02379     if (getsockname(tcp->tcp, (struct sockaddr *)here, &l)) {
02380       scheme_raise_exn(MZEXN_FAIL_NETWORK,
02381                      "tcp-addresses: could not get local address (%e)",
02382                      SOCK_ERRNO());
02383     }
02384     here_len = l;
02385 
02386     l = sizeof(there);
02387     if (getpeername(tcp->tcp, (struct sockaddr *)there, &l)) {
02388       scheme_raise_exn(MZEXN_FAIL_NETWORK,
02389                      "tcp-addresses: could not get peer address (%e)",
02390                      SOCK_ERRNO());
02391     }
02392     there_len = l;
02393 
02394     scheme_getnameinfo((struct sockaddr *)here, here_len, 
02395                      host_buf, sizeof(host_buf),
02396                        (with_ports ? svc_buf : NULL), 
02397                        (with_ports ? sizeof(svc_buf) : 0));
02398     result[0] = scheme_make_utf8_string(host_buf);
02399     if (with_ports) {
02400       l = extract_svc_value(svc_buf);
02401       result[1] = scheme_make_integer(l);
02402     }
02403 
02404     scheme_getnameinfo((struct sockaddr *)there, there_len, 
02405                      host_buf, sizeof(host_buf),
02406                        (with_ports ? svc_buf : NULL), 
02407                        (with_ports ? sizeof(svc_buf) : 0));
02408     result[with_ports ? 2 : 1] = scheme_make_utf8_string(host_buf);
02409     if (with_ports) {
02410       l = extract_svc_value(svc_buf);
02411       result[3] = scheme_make_integer(l);
02412     }
02413   }
02414 # else
02415   result[0] = scheme_make_utf8_string("0.0.0.0");
02416   if (with_ports) {
02417     result[1] = scheme_make_integer(1);
02418     result[2] = result[0];
02419     result[3] = result[1];
02420   } else {
02421     result[1] = result[0];
02422   }
02423 # endif
02424 
02425   return scheme_values(with_ports ? 4 : 2, result);
02426 #else
02427   /* First arg can't possibly be right! */
02428   scheme_wrong_type("tcp-addresses", "tcp-port", 0, argc, argv);
02429 #endif
02430 }
02431 
02432 static Scheme_Object *tcp_abandon_port(int argc, Scheme_Object *argv[])
02433 {
02434 #ifdef USE_TCP
02435   if (SCHEME_OUTPUT_PORTP(argv[0])) {
02436     Scheme_Output_Port *op;
02437     op = scheme_output_port_record(argv[0]);
02438     if (op->sub_type == scheme_tcp_output_port_type) {
02439       if (!op->closed) {
02440        ((Scheme_Tcp *)op->port_data)->flags |= MZ_TCP_ABANDON_OUTPUT;
02441        scheme_close_output_port(argv[0]);
02442       }
02443       return scheme_void;
02444     }
02445   } else if (SCHEME_INPUT_PORTP(argv[0])) {
02446     /* Abandon is not really useful on input ports from the Schemer's
02447        perspective, but it's here for completeness. */
02448     Scheme_Input_Port *ip;
02449     ip = scheme_input_port_record(argv[0]);
02450     if (ip->sub_type == scheme_tcp_input_port_type) {
02451       if (!ip->closed) {
02452        ((Scheme_Tcp *)ip->port_data)->flags |= MZ_TCP_ABANDON_INPUT;
02453        scheme_close_input_port(argv[0]);
02454       }
02455       return scheme_void;
02456     }
02457   }
02458 #endif
02459 
02460   scheme_wrong_type("tcp-abandon-port", "tcp-port", 0, argc, argv);
02461 
02462   return NULL;
02463 }
02464 
02465 static Scheme_Object *tcp_port_p(int argc, Scheme_Object *argv[])
02466 {
02467 #ifdef USE_TCP
02468   if (SCHEME_OUTPUT_PORTP(argv[0])) {
02469     Scheme_Output_Port *op;
02470     op = scheme_output_port_record(argv[0]);
02471     if (op->sub_type == scheme_tcp_output_port_type) {
02472       return scheme_true;
02473     }
02474   } else if (SCHEME_INPUT_PORTP(argv[0])) {
02475     Scheme_Input_Port *ip;
02476     ip = scheme_input_port_record(argv[0]);
02477     if (ip->sub_type == scheme_tcp_input_port_type) {
02478       return scheme_true;
02479     }
02480   }
02481 #endif
02482 
02483   return scheme_false;
02484 }
02485 
02486 
02487 static Scheme_Object *tcp_accept_evt(int argc, Scheme_Object *argv[])
02488 {
02489   Scheme_Object *r, *custodian;
02490 
02491   if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_listener_type))
02492     scheme_wrong_type("tcp-accept-evt", "tcp-listener", 0, argc, argv);
02493 
02494   custodian = scheme_get_param(scheme_current_config(), MZCONFIG_CUSTODIAN);
02495 
02496   scheme_custodian_check_available((Scheme_Custodian *)custodian, "tcp-accept", "network");
02497   
02498   r = scheme_alloc_object();
02499   r->type = scheme_tcp_accept_evt_type;
02500   SCHEME_PTR1_VAL(r) = argv[0];
02501   SCHEME_PTR2_VAL(r) = custodian;
02502 
02503   return r;
02504 }
02505 
02506 static Scheme_Object *accept_failed(void *msg, int argc, Scheme_Object **argv)
02507 {
02508   scheme_raise_exn(MZEXN_FAIL_NETWORK, msg ? (const char *)msg : "accept failed");
02509   return NULL;
02510 } 
02511 
02512 static int tcp_check_accept_evt(Scheme_Object *ae, Scheme_Schedule_Info *sinfo)
02513 {
02514   if (tcp_check_accept(SCHEME_PTR1_VAL(ae))) {
02515     Scheme_Object *a[2];
02516     char *fail_reason = NULL;
02517     a[0] = SCHEME_PTR1_VAL(ae);
02518     if (do_tcp_accept(1, a, SCHEME_PTR2_VAL(ae), &fail_reason)) {
02519       a[0] = scheme_current_thread->ku.multiple.array[0];
02520       a[1] = scheme_current_thread->ku.multiple.array[1];
02521       scheme_set_sync_target(sinfo, scheme_build_list(2, a), NULL, NULL, 0, 0, NULL);
02522       return 1;
02523     } else {
02524       /* error on accept */
02525       scheme_set_sync_target(sinfo, scheme_always_ready_evt, 
02526                              scheme_make_closed_prim(accept_failed, fail_reason), 
02527                              NULL, 0, 0, NULL);
02528       return 1;
02529     }
02530   } else
02531     return 0;
02532 }
02533 
02534 static void tcp_accept_evt_needs_wakeup(Scheme_Object *ae, void *fds)
02535 {
02536   tcp_accept_needs_wakeup(SCHEME_PTR1_VAL(ae), fds);
02537 }
02538 
02539 int scheme_get_port_socket(Scheme_Object *p, long *_s)
02540 {
02541 #ifdef USE_TCP
02542   tcp_t s = 0;
02543   int s_ok = 0;
02544 
02545   if (SCHEME_OUTPUT_PORTP(p)) {
02546     Scheme_Output_Port *op;
02547     op = scheme_output_port_record(p);
02548     if (op->sub_type == scheme_tcp_output_port_type) {
02549       if (!op->closed) {
02550        s = ((Scheme_Tcp *)op->port_data)->tcp;
02551        s_ok = 1;
02552       }
02553     }
02554   } else if (SCHEME_INPUT_PORTP(p)) {
02555     Scheme_Input_Port *ip;
02556     ip = scheme_input_port_record(p);
02557     if (ip->sub_type == scheme_tcp_input_port_type) {
02558       if (!ip->closed) {
02559        s = ((Scheme_Tcp *)ip->port_data)->tcp;
02560        s_ok = 1;
02561       }
02562     }
02563   }
02564 
02565   if (s_ok) {
02566     *_s = (long)s;
02567     return 1;
02568   } else
02569     return 0;
02570 #endif
02571 }
02572 
02573 void scheme_socket_to_ports(long s, const char *name, int takeover,
02574                             Scheme_Object **_inp, Scheme_Object **_outp)
02575 {
02576   Scheme_Tcp *tcp;
02577   Scheme_Object *v;
02578 
02579   tcp = make_tcp_port_data(s, takeover ? 2 : 3);
02580 
02581   v = make_tcp_input_port(tcp, name, NULL);
02582   *_inp = v;
02583   v = make_tcp_output_port(tcp, name, NULL);
02584   *_outp = v;
02585   
02586   if (takeover) {
02587     scheme_file_open_count++;
02588     REGISTER_SOCKET(s);
02589   }
02590 }
02591 
02592 /*========================================================================*/
02593 /*                                 UDP                                    */
02594 /*========================================================================*/
02595 
02596 /* Based on a design and implemenation by Eduardo Cavazos. */
02597 
02598 #ifdef UDP_IS_SUPPORTED
02599 
02600 typedef struct Scheme_UDP_Evt {
02601   Scheme_Object so; /* scheme_udp_evt_type */
02602   Scheme_UDP *udp;
02603   short for_read, with_addr;
02604   int offset, len;
02605   char *str;
02606   char *dest_addr;
02607   int dest_addr_len;
02608 } Scheme_UDP_Evt;
02609 
02610 static int udp_close_it(Scheme_Object *_udp)
02611 {
02612   Scheme_UDP *udp = (Scheme_UDP *)_udp;
02613 
02614   if (udp->s != INVALID_SOCKET) {
02615     closesocket(udp->s);
02616     udp->s = INVALID_SOCKET;
02617 
02618     scheme_remove_managed(udp->mref, (Scheme_Object *)udp);
02619 
02620     return 0;
02621   }
02622 
02623   return 1;
02624 }
02625 
02626 #endif
02627 
02628 static Scheme_Object *make_udp(int argc, Scheme_Object *argv[])
02629 {
02630 #ifdef UDP_IS_SUPPORTED
02631   Scheme_UDP *udp;
02632   tcp_t s;
02633   char *address = "";
02634   unsigned short origid, id;
02635 
02636   TCP_INIT("udp-open-socket");
02637 
02638   if ((argc > 0) && !SCHEME_FALSEP(argv[0]) && !SCHEME_CHAR_STRINGP(argv[0]))
02639     scheme_wrong_type("udp-open-socket", "string or #f", 0, argc, argv);
02640   if ((argc > 1) && !SCHEME_FALSEP(argv[1]) && !CHECK_PORT_ID(argv[1]))
02641     scheme_wrong_type("udp-open-socket", PORT_ID_TYPE " or #f", 1, argc, argv);
02642 
02643   if ((argc > 0) && SCHEME_TRUEP(argv[0])) {
02644     Scheme_Object *bs;
02645     bs = scheme_char_string_to_byte_string(argv[0]);
02646     address = SCHEME_BYTE_STR_VAL(bs);
02647   } else
02648     address = NULL;
02649   if ((argc > 1) && SCHEME_TRUEP(argv[1]))
02650     origid = (unsigned short)SCHEME_INT_VAL(argv[1]);
02651   else
02652     origid = 0;
02653 
02654   scheme_security_check_network("udp-open-socket", address, origid, 0);
02655   scheme_custodian_check_available(NULL, "udp-open-socket", "network");
02656 
02657   if (address || origid) {
02658     int err;
02659     GC_CAN_IGNORE struct mz_addrinfo *udp_bind_addr = NULL;
02660     if (!origid)
02661       origid = 1025;
02662     id = origid;
02663     udp_bind_addr = scheme_get_host_address(address, id, &err, -1, 1, 0);
02664     if (!udp_bind_addr) {
02665       scheme_raise_exn(MZEXN_FAIL_NETWORK,
02666                      "udp-open-socket: can't resolve address: %s (%N)", 
02667                      address ? address : "<unspec>", 1, err);
02668       return NULL;
02669     }
02670     s = socket(udp_bind_addr->ai_family,
02671               udp_bind_addr->ai_socktype,
02672               udp_bind_addr->ai_protocol);
02673     mz_freeaddrinfo(udp_bind_addr);
02674   } else {
02675     s = socket(MZ_PF_INET, SOCK_DGRAM, 0);
02676   }
02677 
02678   if (s == INVALID_SOCKET) {
02679     int errid;
02680     errid = SOCK_ERRNO();
02681     scheme_raise_exn(MZEXN_FAIL_NETWORK,
02682                    "udp-open-socket: creation failed (%E)", errid);
02683     return NULL;
02684   }
02685 
02686   udp = MALLOC_ONE_TAGGED(Scheme_UDP);
02687   udp->so.type = scheme_udp_type;
02688   udp->s = s;
02689   udp->bound = 0;
02690   udp->connected = 0;
02691   udp->previous_from_addr = NULL;
02692 
02693 #ifdef USE_WINSOCK_TCP
02694   {
02695     unsigned long ioarg = 1;
02696     BOOL bc = 1;
02697     ioctlsocket(s, FIONBIO, &ioarg);
02698     setsockopt(s, SOL_SOCKET, SO_BROADCAST, (char *)(&bc), sizeof(BOOL));
02699   }
02700 #else
02701   fcntl(s, F_SETFL, MZ_NONBLOCKING);
02702 # ifdef SO_BROADCAST
02703   {
02704     int bc = 1;
02705     setsockopt(s, SOL_SOCKET, SO_BROADCAST, &bc, sizeof(bc));
02706   }
02707 # endif
02708 #endif
02709 
02710   {
02711     Scheme_Custodian_Reference *mref;
02712     mref = scheme_add_managed(NULL,
02713                            (Scheme_Object *)udp,
02714                            (Scheme_Close_Custodian_Client *)udp_close_it,
02715                            NULL,
02716                            1);
02717     udp->mref = mref;
02718   }
02719 
02720   return (Scheme_Object *)udp;
02721 #else
02722   scheme_raise_exn(MZEXN_FAIL_UNSUPPORTED,
02723                  "udp-open-socket: not supported on this platform");
02724   return NULL;
02725 #endif
02726 }
02727 
02728 static Scheme_Object *
02729 udp_close(int argc, Scheme_Object *argv[])
02730 {
02731   if (!SCHEME_UDPP(argv[0]))
02732     scheme_wrong_type("udp-close", "udp socket", 0, argc, argv);
02733 
02734 #ifdef UDP_IS_SUPPORTED
02735   if (udp_close_it(argv[0])) {
02736     scheme_raise_exn(MZEXN_FAIL_NETWORK,
02737                    "udp-close: udp socket was already closed");
02738     return NULL;
02739   }
02740 #endif
02741 
02742   return scheme_void;
02743 }
02744 
02745 static Scheme_Object *
02746 udp_p(int argc, Scheme_Object *argv[])
02747 {
02748   return (SCHEME_UDPP(argv[0]) ? scheme_true : scheme_false);
02749 }
02750 
02751 static Scheme_Object *
02752 udp_bound_p(int argc, Scheme_Object *argv[])
02753 {
02754   if (!SCHEME_UDPP(argv[0]))
02755     scheme_wrong_type("udp-bound?", "udp socket", 0, argc, argv);
02756 
02757 #ifdef UDP_IS_SUPPORTED
02758   return (((Scheme_UDP *)argv[0])->bound ? scheme_true : scheme_false);
02759 #else
02760   return scheme_void;
02761 #endif
02762 }
02763 
02764 static Scheme_Object *
02765 udp_connected_p(int argc, Scheme_Object *argv[])
02766 {
02767   if (!SCHEME_UDPP(argv[0]))
02768     scheme_wrong_type("udp-connected?", "udp socket", 0, argc, argv);
02769 
02770 #ifdef UDP_IS_SUPPORTED
02771   return (((Scheme_UDP *)argv[0])->connected ? scheme_true : scheme_false);
02772 #else
02773   return scheme_void;
02774 #endif
02775 }
02776 
02777 #ifdef UDP_DISCONNECT_EADRNOTAVAIL_OK
02778 # define OK_DISCONNECT_ERROR(e) (((e) == mz_AFNOSUPPORT) || ((e) == EADDRNOTAVAIL))
02779 #else
02780 # define OK_DISCONNECT_ERROR(e) ((e) == mz_AFNOSUPPORT)
02781 #endif
02782 
02783 static Scheme_Object *udp_bind_or_connect(const char *name, int argc, Scheme_Object *argv[], int do_bind)
02784 {
02785 #ifdef UDP_IS_SUPPORTED
02786   Scheme_UDP *udp;
02787   char *address = "";
02788   unsigned short origid, id;
02789   GC_CAN_IGNORE struct mz_addrinfo *udp_bind_addr;
02790   int errid, err;
02791 
02792   udp = (Scheme_UDP *)argv[0];
02793 #endif
02794 
02795   if (!SCHEME_UDPP(argv[0]))
02796     scheme_wrong_type(name, "udp socket", 0, argc, argv);
02797 
02798 #ifdef UDP_IS_SUPPORTED
02799   if (!SCHEME_FALSEP(argv[1]) && !SCHEME_CHAR_STRINGP(argv[1]))
02800     scheme_wrong_type(name, "string or #f", 1, argc, argv);
02801   if ((do_bind || !SCHEME_FALSEP(argv[2])) && !CHECK_PORT_ID(argv[2]))
02802     scheme_wrong_type(name, (do_bind ? PORT_ID_TYPE : PORT_ID_TYPE " or #f"), 2, argc, argv);
02803                     
02804   if (SCHEME_TRUEP(argv[1])) {
02805     Scheme_Object *bs;
02806     bs = scheme_char_string_to_byte_string(argv[1]);
02807     address = SCHEME_BYTE_STR_VAL(bs);
02808   } else
02809     address = NULL;
02810   if (SCHEME_TRUEP(argv[2]))
02811     origid = (unsigned short)SCHEME_INT_VAL(argv[2]);
02812   else
02813     origid = 0;
02814 
02815   if (!do_bind && (SCHEME_TRUEP(argv[1]) != SCHEME_TRUEP(argv[2]))) {
02816     scheme_raise_exn(MZEXN_FAIL_CONTRACT,
02817                    "%s: last two arguments must be both #f or both non-#f, given: %V %V",
02818                    name, argv[1], argv[2]);
02819   }
02820 
02821   scheme_security_check_network(name, address, origid, !do_bind);
02822 
02823   if (udp->s == INVALID_SOCKET) {
02824     scheme_raise_exn(MZEXN_FAIL_NETWORK,
02825                    "%s: udp socket was already closed: %V",
02826                    name,
02827                    udp);
02828     return NULL;
02829   }
02830 
02831 
02832   if (do_bind && udp->bound) {
02833     scheme_raise_exn(MZEXN_FAIL_NETWORK,
02834                    "%s: udp socket is already bound: %V",
02835                    name,
02836                    udp);
02837     return NULL;
02838   }
02839 
02840   id = origid;
02841 
02842   if (address || id)
02843     udp_bind_addr = scheme_get_host_address(address, id, &err, -1, do_bind, 0);
02844   else
02845     udp_bind_addr = NULL;
02846 
02847   if (udp_bind_addr || !origid) {
02848     if (do_bind) {
02849       if (!bind(udp->s, udp_bind_addr->ai_addr, udp_bind_addr->ai_addrlen)) {
02850        udp->bound = 1;
02851        mz_freeaddrinfo(udp_bind_addr);
02852        return scheme_void;
02853       }
02854       errid = SOCK_ERRNO();
02855     } else {
02856       int ok = 1;
02857 
02858 #ifdef USE_NULL_TO_DISCONNECT_UDP
02859       if (!origid) {
02860        if (udp->connected)
02861          ok = !connect(udp->s, NULL, 0);
02862       } else
02863 #endif
02864        {
02865          if (udp_bind_addr)
02866            ok = !connect(udp->s, udp_bind_addr->ai_addr, udp_bind_addr->ai_addrlen);
02867 #ifndef USE_NULL_TO_DISCONNECT_UDP
02868          else {
02869            GC_CAN_IGNORE mz_unspec_address ua;
02870            ua.sin_family = AF_UNSPEC;
02871            ua.sin_port = 0;
02872            memset(&(ua.sin_addr), 0, sizeof(ua.sin_addr));
02873            memset(&(ua.sin_zero), 0, sizeof(ua.sin_zero));
02874            ok = !connect(udp->s, (struct sockaddr *)&ua, sizeof(ua));
02875          }
02876 #endif
02877        }
02878       
02879       if (!ok)
02880        errid = SOCK_ERRNO();
02881       else
02882        errid = 0;
02883 
02884       if (!ok && OK_DISCONNECT_ERROR(errid) && !origid) {
02885        /* It's ok. We were trying to disconnect */
02886        ok = 1;
02887       }
02888 
02889       if (ok) {
02890        if (origid)
02891          udp->connected = 1;
02892        else
02893          udp->connected = 0;
02894        if (udp_bind_addr)
02895          mz_freeaddrinfo(udp_bind_addr);
02896        return scheme_void;
02897       }
02898     }
02899 
02900     if (udp_bind_addr)
02901       mz_freeaddrinfo(udp_bind_addr);
02902 
02903     scheme_raise_exn(MZEXN_FAIL_NETWORK,
02904                    "%s: can't %s to port: %d on address: %s (%E)", 
02905                    name,
02906                    do_bind ? "bind" : "connect",
02907                    origid,
02908                    address ? address : "#f",
02909                    errid);
02910     return NULL;
02911   } else {
02912     scheme_raise_exn(MZEXN_FAIL_NETWORK,
02913                    "%s: can't resolve address: %s (%N)", 
02914                    name,
02915                    address, 1, err);
02916     return NULL;
02917   }
02918 #else
02919   return scheme_void;
02920 #endif
02921 }
02922 
02923 static Scheme_Object *udp_bind(int argc, Scheme_Object *argv[])
02924 {
02925   return udp_bind_or_connect("udp-bind!", argc, argv, 1);
02926 }
02927 
02928 static Scheme_Object *udp_connect(int argc, Scheme_Object *argv[])
02929 {
02930   return udp_bind_or_connect("udp-connect!", argc, argv, 0);
02931 }
02932 
02933 #ifdef UDP_IS_SUPPORTED
02934 
02935 static int udp_check_send(Scheme_Object *_udp)
02936 {
02937   Scheme_UDP *udp = (Scheme_UDP *)_udp;
02938 
02939   if (udp->s == INVALID_SOCKET)
02940     return 1;
02941 
02942   {
02943     DECL_OS_FDSET(writefds);
02944     DECL_OS_FDSET(exnfds);
02945     struct timeval time = {0, 0};
02946     int sr;
02947     
02948     INIT_DECL_OS_FDSET(writefds);
02949     INIT_DECL_OS_FDSET(exnfds);
02950     
02951     MZ_OS_FD_ZERO(writefds);
02952     MZ_OS_FD_SET(udp->s, writefds);
02953     MZ_OS_FD_ZERO(exnfds);
02954     MZ_OS_FD_SET(udp->s, exnfds);
02955     
02956     do {
02957       sr = select(udp->s + 1, NULL, writefds, exnfds, &time);
02958     } while ((sr == -1) && (NOT_WINSOCK(errno) == EINTR));
02959     
02960     return sr;
02961   }
02962 }
02963 
02964 static void udp_send_needs_wakeup(Scheme_Object *_udp, void *fds)
02965 {
02966   Scheme_UDP *udp = (Scheme_UDP *)_udp;
02967   void *fds1, *fds2;
02968   tcp_t s = udp->s;
02969   
02970   fds1 = MZ_GET_FDSET(fds, 1);
02971   fds2 = MZ_GET_FDSET(fds, 2);
02972   
02973   MZ_FD_SET(s, (fd_set *)fds1);
02974   MZ_FD_SET(s, (fd_set *)fds2);
02975 }
02976 
02977 #endif
02978 
02979 static Scheme_Object *do_udp_send_it(const char *name, Scheme_UDP *udp,
02980                                  char *bstr, long start, long end,
02981                                  char *dest_addr, int dest_addr_len, int can_block)
02982 {
02983   long x;
02984   int errid = 0;
02985 
02986   while (1) {
02987     if (udp->s == INVALID_SOCKET) {
02988       /* socket was closed, maybe while we slept */
02989       scheme_raise_exn(MZEXN_FAIL_NETWORK,
02990                      "%s: udp socket is closed: %V",
02991                      name, udp);
02992       return NULL;
02993     }
02994     if ((!dest_addr && !udp->connected)
02995        || (dest_addr && udp->connected)) {
02996       /* socket is unconnected, maybe disconnected while we slept */
02997       scheme_raise_exn(MZEXN_FAIL_NETWORK,
02998                      "%s: udp socket is%s connected: %V",
02999                      name, 
03000                      dest_addr ? "" : " not",
03001                      udp);
03002       return NULL;
03003     }
03004 
03005     udp->bound = 1; /* in case it's not bound already, send[to] binds it */
03006 
03007     if (dest_addr)
03008       x = sendto(udp->s, bstr XFORM_OK_PLUS start, end - start, 
03009                0, (struct sockaddr *)dest_addr, dest_addr_len);
03010     else
03011       x = send(udp->s, bstr XFORM_OK_PLUS start, end - start, 0);
03012 
03013     if (x == -1) {
03014       errid = SOCK_ERRNO();
03015       if (WAS_EAGAIN(errid)) {
03016        if (can_block) {
03017          /* Block and eventually try again. */
03018          scheme_block_until(udp_check_send, udp_send_needs_wakeup, (Scheme_Object *)udp, 0);
03019        } else
03020          return scheme_false;
03021       } else if (NOT_WINSOCK(errid) != EINTR)
03022        break;
03023     } else if (x != (end - start)) {
03024       /* this isn't supposed to happen: */
03025       scheme_raise_exn(MZEXN_FAIL_NETWORK,
03026                      "%s: didn't send enough (%d != %d)", 
03027                      name,
03028                      x, end - start);
03029       return NULL;
03030     } else
03031       break;
03032   }
03033     
03034   if (x > -1) {
03035     return (can_block ? scheme_void : scheme_true);
03036   } else {
03037     scheme_raise_exn(MZEXN_FAIL_NETWORK,
03038                    "%s: send failed (%E)", 
03039                    name,
03040                    errid);
03041     return NULL;
03042   }
03043 }
03044 
03045 static Scheme_Object *udp_send_it(const char *name, int argc, Scheme_Object *argv[],
03046                               int with_addr, int can_block, Scheme_UDP_Evt *fill_evt)
03047 {
03048 #ifdef UDP_IS_SUPPORTED
03049   Scheme_UDP *udp;
03050   char *address = "";
03051   long start, end;
03052   int delta, err;
03053   unsigned short origid, id;
03054   GC_CAN_IGNORE struct mz_addrinfo *udp_dest_addr;
03055 
03056   udp = (Scheme_UDP *)argv[0];
03057 #endif
03058 
03059   if (!SCHEME_UDPP(argv[0]))
03060     scheme_wrong_type(name, "udp socket", 0, argc, argv);
03061 
03062 #ifdef UDP_IS_SUPPORTED
03063   if (with_addr) {
03064     if (!SCHEME_CHAR_STRINGP(argv[1]))
03065       scheme_wrong_type(name, "string", 1, argc, argv);
03066     if (!CHECK_PORT_ID(argv[2]))
03067       scheme_wrong_type(name, PORT_ID_TYPE, 2, argc, argv);
03068     delta = 0;
03069   } else
03070     delta = -2;
03071 
03072   if (!SCHEME_BYTE_STRINGP(argv[3 + delta]))
03073     scheme_wrong_type(name, "byte string", 3 + delta, argc, argv);
03074   
03075   scheme_get_substring_indices(name, argv[3 + delta], 
03076                             argc, argv,
03077                             4 + delta, 5 + delta, &start, &end);
03078 
03079   if (with_addr) {
03080     Scheme_Object *bs;
03081     bs = scheme_char_string_to_byte_string(argv[1]);
03082     address = SCHEME_BYTE_STR_VAL(bs);
03083     origid = (unsigned short)SCHEME_INT_VAL(argv[2]);
03084 
03085     scheme_security_check_network(name, address, origid, 1);
03086 
03087     id = origid;
03088   } else {
03089     address = NULL;
03090     id = origid = 0;
03091   }
03092 
03093   if (with_addr)
03094     udp_dest_addr = scheme_get_host_address(address, id, &err, -1, 0, 0);
03095   else
03096     udp_dest_addr = NULL;
03097 
03098   if (!with_addr || udp_dest_addr) {
03099     if (fill_evt) {
03100       char *s;
03101       fill_evt->str = SCHEME_BYTE_STR_VAL(argv[3+delta]);
03102       fill_evt->offset = start;
03103       fill_evt->len = end - start;
03104       if (udp_dest_addr) {
03105        s = (char *)scheme_malloc_atomic(udp_dest_addr->ai_addrlen);
03106        memcpy(s, udp_dest_addr->ai_addr, udp_dest_addr->ai_addrlen);
03107        fill_evt->dest_addr = s;
03108        fill_evt->dest_addr_len = udp_dest_addr->ai_addrlen;
03109        mz_freeaddrinfo(udp_dest_addr);
03110       }
03111       return scheme_void;
03112     } else {
03113       Scheme_Object *r;
03114       r = do_udp_send_it(name, udp,
03115                       SCHEME_BYTE_STR_VAL(argv[3+delta]), start, end,
03116                       (udp_dest_addr ? (char *)udp_dest_addr->ai_addr : NULL),
03117                       (udp_dest_addr ? udp_dest_addr->ai_addrlen : 0),
03118                       can_block);
03119       if (udp_dest_addr)
03120        mz_freeaddrinfo(udp_dest_addr);
03121       return r;
03122     }
03123   } else {
03124     scheme_raise_exn(MZEXN_FAIL_NETWORK,
03125                    "%s: can't resolve address: %s (%N)", 
03126                    name,
03127                    address, 1, err);
03128     return NULL;
03129   }
03130 #else
03131   return scheme_void;
03132 #endif
03133 }
03134 
03135 static Scheme_Object *udp_send_to(int argc, Scheme_Object *argv[])
03136 {
03137   return udp_send_it("udp-send-to", argc, argv, 1, 1, NULL);
03138 }
03139 
03140 static Scheme_Object *udp_send(int argc, Scheme_Object *argv[])
03141 {
03142   return udp_send_it("udp-send", argc, argv, 0, 1, NULL);
03143 }
03144 
03145 static Scheme_Object *udp_send_to_star(int argc, Scheme_Object *argv[])
03146 {
03147   return udp_send_it("udp-send-to*", argc, argv, 1, 0, NULL);
03148 }
03149 
03150 static Scheme_Object *udp_send_star(int argc, Scheme_Object *argv[])
03151 {
03152   return udp_send_it("udp-send*", argc, argv, 0, 0, NULL);
03153 }
03154 
03155 static Scheme_Object *udp_send_to_enable_break(int argc, Scheme_Object *argv[])
03156 {
03157   return scheme_call_enable_break(udp_send_to, argc, argv);
03158 }
03159 
03160 static Scheme_Object *udp_send_enable_break(int argc, Scheme_Object *argv[])
03161 {
03162   return scheme_call_enable_break(udp_send, argc, argv);
03163 }
03164 
03165 #ifdef UDP_IS_SUPPORTED
03166 
03167 static int udp_check_recv(Scheme_Object *_udp)
03168 {
03169   Scheme_UDP *udp = (Scheme_UDP *)_udp;
03170 
03171   if (udp->s == INVALID_SOCKET)
03172     return 1;
03173 
03174   {
03175     DECL_OS_FDSET(readfds);
03176     DECL_OS_FDSET(exnfds);
03177     struct timeval time = {0, 0};
03178     int sr;
03179     
03180     INIT_DECL_OS_FDSET(readfds);
03181     INIT_DECL_OS_FDSET(exnfds);
03182     
03183     MZ_OS_FD_ZERO(readfds);
03184     MZ_OS_FD_SET(udp->s, readfds);
03185     MZ_OS_FD_ZERO(exnfds);
03186     MZ_OS_FD_SET(udp->s, exnfds);
03187     
03188     do {
03189       sr = select(udp->s + 1, readfds, NULL, exnfds, &time);
03190     } while ((sr == -1) && (NOT_WINSOCK(errno) == EINTR));
03191     
03192     return sr;
03193   }
03194 }
03195 
03196 static void udp_recv_needs_wakeup(Scheme_Object *_udp, void *fds)
03197 {
03198   Scheme_UDP *udp = (Scheme_UDP *)_udp;
03199   void *fds1, *fds2;
03200 
03201   tcp_t s = udp->s;
03202   
03203   fds1 = MZ_GET_FDSET(fds, 0);
03204   fds2 = MZ_GET_FDSET(fds, 2);
03205   
03206   MZ_FD_SET(s, (fd_set *)fds1);
03207   MZ_FD_SET(s, (fd_set *)fds2);
03208 }
03209 
03210 #endif
03211 
03212 static int do_udp_recv(const char *name, Scheme_UDP *udp, char *bstr, long start, long end, 
03213                      int can_block, Scheme_Object **v)
03214 {
03215 #ifdef UDP_IS_SUPPORTED
03216   long x;
03217   int errid = 0;
03218   char src_addr[MZ_SOCK_NAME_MAX_LEN];
03219   unsigned int asize = sizeof(src_addr);
03220 
03221   if (!udp->bound) {
03222     scheme_raise_exn(MZEXN_FAIL_NETWORK,
03223                    "%s: udp socket is not bound: %V",
03224                    name,
03225                    udp);
03226     return 0;
03227   }
03228 
03229   while (1) {
03230     if (udp->s == INVALID_SOCKET) {
03231       /* socket was closed, maybe while we slept */
03232       scheme_raise_exn(MZEXN_FAIL_NETWORK,
03233                      "%s: udp socket is closed: %V",
03234                      name, udp);
03235       return 0;
03236     }
03237 
03238     {
03239       x = recvfrom(udp->s, bstr XFORM_OK_PLUS start, end - start, 0,
03240                  (struct sockaddr *)src_addr, &asize);
03241     }
03242 
03243     if (x == -1) {
03244       errid = SOCK_ERRNO();
03245       if (WAS_WSAEMSGSIZE(errid)) {
03246        x = end - start;
03247        errid = 0;
03248       } if (WAS_EAGAIN(errid)) {
03249        if (can_block) {
03250          /* Block and eventually try again. */
03251          scheme_block_until(udp_check_recv, udp_recv_needs_wakeup, (Scheme_Object *)udp, 0);
03252        } else {
03253          v[0] = scheme_false;
03254          v[1] = scheme_false;
03255          v[2] = scheme_false;
03256          return 0;
03257        }
03258       } else if (NOT_WINSOCK(errid) != EINTR)
03259        break;
03260     } else
03261       break;
03262   }
03263   
03264   if (x > -1) {
03265     char host_buf[MZ_SOCK_HOST_NAME_MAX_LEN];
03266     char prev_buf[MZ_SOCK_HOST_NAME_MAX_LEN];
03267     char svc_buf[MZ_SOCK_SVC_NAME_MAX_LEN];
03268     int j, id;
03269 
03270     v[0] = scheme_make_integer(x);
03271 
03272     scheme_getnameinfo((struct sockaddr *)src_addr, asize,
03273                      host_buf, sizeof(host_buf),
03274                      svc_buf, sizeof(svc_buf));
03275     
03276     if (udp->previous_from_addr) {
03277       mzchar *s;
03278       s = SCHEME_CHAR_STR_VAL(udp->previous_from_addr);
03279       for (j = 0; s[j]; j++) {
03280        prev_buf[j] = (char)s[j];
03281       }
03282       prev_buf[j] = 0;
03283     }
03284 
03285     if (udp->previous_from_addr && !strcmp(prev_buf, host_buf)) {
03286       v[1] = udp->previous_from_addr;
03287     } else {
03288       Scheme_Object *vv;
03289       vv = scheme_make_immutable_sized_utf8_string(host_buf, -1);
03290       v[1] = vv;
03291       udp->previous_from_addr = v[1];
03292     }
03293 
03294     id = extract_svc_value(svc_buf);
03295 
03296     v[2] = scheme_make_integer(id);
03297 
03298     return 1;
03299   } else {
03300     scheme_raise_exn(MZEXN_FAIL_NETWORK,
03301                    "%s: receive failed (%E)", 
03302                    name,
03303                    errid);
03304     return 0;
03305   }
03306 #else
03307   return 0;
03308 #endif
03309 }
03310 
03311 static Scheme_Object *udp_recv(const char *name, int argc, Scheme_Object *argv[], 
03312                             int can_block, Scheme_UDP_Evt *fill_evt)
03313 {
03314   Scheme_UDP *udp;
03315   long start, end;
03316   Scheme_Object *v[3];
03317 
03318   udp = (Scheme_UDP *)argv[0];
03319 
03320   if (!SCHEME_UDPP(argv[0]))
03321     scheme_wrong_type(name, "udp socket", 0, argc, argv);
03322   if (!SCHEME_BYTE_STRINGP(argv[1]) || !SCHEME_MUTABLEP(argv[1]))
03323     scheme_wrong_type(name, "mutable byte string", 1, argc, argv);
03324   
03325   scheme_get_substring_indices(name, argv[1], 
03326                             argc, argv,
03327                             2, 3, &start, &end);
03328   if (fill_evt) {
03329     fill_evt->str = SCHEME_BYTE_STR_VAL(argv[1]);
03330     fill_evt->offset = start;
03331     fill_evt->len = end - start;
03332     return scheme_void;
03333   } else {
03334     do_udp_recv(name, udp, SCHEME_BYTE_STR_VAL(argv[1]), start, end, can_block, v);
03335     
03336     return scheme_values(3,v);
03337   }
03338 }
03339 
03340 static Scheme_Object *udp_receive(int argc, Scheme_Object *argv[])
03341 {
03342   return udp_recv("udp-receive!", argc, argv, 1, NULL);
03343 }
03344 
03345 static Scheme_Object *udp_receive_star(int argc, Scheme_Object *argv[])
03346 {
03347   return udp_recv("udp-receive!*", argc, argv, 0, NULL);
03348 }
03349 
03350 static Scheme_Object *udp_receive_enable_break(int argc, Scheme_Object *argv[])
03351 {
03352   return scheme_call_enable_break(udp_receive, argc, argv);
03353 }
03354 
03355 static Scheme_Object *make_udp_evt(const char *name, int argc, Scheme_Object **argv, int for_read)
03356 {
03357 #ifdef UDP_IS_SUPPORTED
03358   Scheme_UDP_Evt *uw;
03359 #endif
03360 
03361   if (!SCHEME_UDPP(argv[0]))
03362     scheme_wrong_type(name, "udp socket", 0, argc, argv);
03363 
03364 #ifdef UDP_IS_SUPPORTED
03365   uw = MALLOC_ONE_TAGGED(Scheme_UDP_Evt);
03366   uw->so.type = scheme_udp_evt_type;
03367   uw->udp = (Scheme_UDP *)argv[0];
03368   uw->for_read = for_read;
03369 
03370   return (Scheme_Object *)uw;
03371 #else
03372   return scheme_void;
03373 #endif
03374 }
03375 
03376 static Scheme_Object *udp_read_ready_evt(int argc, Scheme_Object *argv[])
03377 {
03378   return make_udp_evt("udp-receive-ready-evt", argc, argv, 1);
03379 }
03380 
03381 static Scheme_Object *udp_write_ready_evt(int argc, Scheme_Object *argv[])
03382 {
03383   return make_udp_evt("udp-send-ready-evt", argc, argv, 0);
03384 }
03385 
03386 static Scheme_Object *udp_read_evt(int argc, Scheme_Object *argv[])
03387 {
03388   Scheme_Object *evt;
03389   evt = make_udp_evt("udp-receive!-evt", argc, argv, 1);
03390   udp_recv("udp-receive!-evt", argc, argv, 0, (Scheme_UDP_Evt *)evt);
03391   return evt;
03392 }
03393 
03394 static Scheme_Object *udp_write_evt(int argc, Scheme_Object *argv[])
03395 {
03396   Scheme_Object *evt;
03397   evt = make_udp_evt("udp-send-evt", argc, argv, 0);
03398   udp_send_it("udp-send-evt", argc, argv, 0, 0, (Scheme_UDP_Evt *)evt);
03399   return evt;
03400 }
03401 
03402 static Scheme_Object *udp_write_to_evt(int argc, Scheme_Object *argv[])
03403 {
03404   Scheme_Object *evt;
03405   evt = make_udp_evt("udp-send-to-evt", argc, argv, 0);
03406   udp_send_it("udp-send-to-evt", argc, argv, 1, 0, (Scheme_UDP_Evt *)evt);
03407   ((Scheme_UDP_Evt *)evt)->with_addr = 1;
03408   return evt;
03409 }
03410 
03411 #ifdef UDP_IS_SUPPORTED
03412 static int udp_evt_check_ready(Scheme_Object *_uw, Scheme_Schedule_Info *sinfo)
03413 {
03414   Scheme_UDP_Evt *uw = (Scheme_UDP_Evt *)_uw;
03415 
03416   if (uw->for_read) {
03417     if (uw->str) {
03418       Scheme_Object *v[3];
03419       if (do_udp_recv("udp-receive!-evt", uw->udp, 
03420                     uw->str, uw->offset, uw->offset + uw->len, 
03421                     0, v)) {
03422        scheme_set_sync_target(sinfo, scheme_build_list(3, v), NULL, NULL, 0, 0, NULL);
03423        return 1;
03424       } else
03425        return 0;
03426     } else {
03427       return udp_check_recv((Scheme_Object *)uw->udp);
03428     }
03429   } else {
03430     if (uw->str) {
03431       Scheme_Object *r;
03432       r = do_udp_send_it("udp-send-evt", uw->udp, 
03433                       uw->str, uw->offset, uw->offset + uw->len, 
03434                       uw->dest_addr, uw->dest_addr_len,
03435                       0);
03436       if (SCHEME_TRUEP(r)) {
03437        scheme_set_sync_target(sinfo, scheme_void, NULL, NULL, 0, 0, NULL);
03438        return 1;
03439       } else
03440        return 0;
03441     } else
03442       return udp_check_send((Scheme_Object *)uw->udp);
03443   }
03444 }
03445 
03446 static void udp_evt_needs_wakeup(Scheme_Object *_uw, void *fds)
03447 {
03448   Scheme_UDP_Evt *uw = (Scheme_UDP_Evt *)_uw;
03449 
03450   if (uw->for_read)
03451     udp_recv_needs_wakeup((Scheme_Object *)uw->udp, fds);
03452   else
03453     udp_send_needs_wakeup((Scheme_Object *)uw->udp, fds);
03454 }
03455 #endif
03456 
03457 /*========================================================================*/
03458 /*                       precise GC traversers                            */
03459 /*========================================================================*/
03460 
03461 #ifdef MZ_PRECISE_GC
03462 
03463 START_XFORM_SKIP;
03464 
03465 #define MARKS_FOR_NETWORK_C
03466 #include "mzmark.c"
03467 
03468 static void register_traversers(void)
03469 {
03470 #ifdef USE_TCP
03471   GC_REG_TRAV(scheme_rt_tcp, mark_tcp);
03472 # ifdef UDP_IS_SUPPORTED
03473   GC_REG_TRAV(scheme_udp_type, mark_udp);
03474   GC_REG_TRAV(scheme_udp_evt_type, mark_udp_evt);
03475 # endif
03476 #endif
03477   GC_REG_TRAV(scheme_listener_type, mark_listener);  
03478 }
03479 
03480 END_XFORM_SKIP;
03481 
03482 #endif
03483 
03484 #endif /* !NO_TCP_SUPPORT */