From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.org!not-for-mail From: ludovic.courtes@laas.fr (Ludovic =?iso-8859-1?Q?Court=E8s?=) Newsgroups: gmane.lisp.guile.user Subject: Socket API improvement, patch #6 Date: Tue, 04 Oct 2005 16:08:13 +0200 Organization: LAAS-CNRS Message-ID: <87wtkt9xyq.fsf_-_@laas.fr> References: <87oecutxox.fsf@laas.fr> <87vf58cxxq.fsf@zagadka.de> <87k6kwopv5.fsf@laas.fr> <87fysk7ady.fsf@zagadka.de> <87mzmpmcm2.fsf@laas.fr> <87aci6u6f4.fsf@laas.fr> <87psr22c2p.fsf@zip.com.au> <87irwtqkop.fsf@laas.fr> <87slvog9sd.fsf@zip.com.au> NNTP-Posting-Host: main.gmane.org Mime-Version: 1.0 Content-Type: text/plain; charset=us-ascii X-Trace: sea.gmane.org 1128437446 5182 80.91.229.2 (4 Oct 2005 14:50:46 GMT) X-Complaints-To: usenet@sea.gmane.org NNTP-Posting-Date: Tue, 4 Oct 2005 14:50:46 +0000 (UTC) Cc: guile-user@gnu.org Original-X-From: guile-user-bounces+guile-user=m.gmane.org@gnu.org Tue Oct 04 16:50:34 2005 Return-path: Original-Received: from lists.gnu.org ([199.232.76.165]) by ciao.gmane.org with esmtp (Exim 4.43) id 1EMo4N-0001h1-IF for guile-user@m.gmane.org; Tue, 04 Oct 2005 16:47:04 +0200 Original-Received: from localhost ([127.0.0.1] helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.43) id 1EMo4M-0003SA-9o for guile-user@m.gmane.org; Tue, 04 Oct 2005 10:47:02 -0400 Original-Received: from mailman by lists.gnu.org with tmda-scanned (Exim 4.43) id 1EMnxV-0000dk-40 for guile-user@gnu.org; Tue, 04 Oct 2005 10:39:57 -0400 Original-Received: from exim by lists.gnu.org with spam-scanned (Exim 4.43) id 1EMnxT-0000dH-Un for guile-user@gnu.org; Tue, 04 Oct 2005 10:39:56 -0400 Original-Received: from [199.232.76.173] (helo=monty-python.gnu.org) by lists.gnu.org with esmtp (Exim 4.43) id 1EMnvD-0007Ge-WE for guile-user@gnu.org; Tue, 04 Oct 2005 10:37:36 -0400 Original-Received: from [140.93.0.15] (helo=laas.laas.fr) by monty-python.gnu.org with esmtp (TLS-1.0:DHE_RSA_3DES_EDE_CBC_SHA:24) (Exim 4.34) id 1EMnUw-0002ls-Rr for guile-user@gnu.org; Tue, 04 Oct 2005 10:10:27 -0400 Original-Received: by laas.laas.fr (8.13.1/8.13.4) with SMTP id j94EAKhZ017462; Tue, 4 Oct 2005 16:10:25 +0200 (CEST) Original-To: Kevin Ryde X-URL: http://www.laas.fr/~lcourtes/ X-Revolutionary-Date: 13 =?iso-8859-1?Q?Vend=E9miaire?= an 214 de la =?iso-8859-1?Q?R=E9volution?= X-PGP-Key-ID: 0xEB1F5364 X-PGP-Key: http://www.laas.fr/~lcourtes/ludovic.asc X-PGP-Fingerprint: 821D 815D 902A 7EAB 5CEE D120 7FBA 3D4F EB1F 5364 X-OS: powerpc-unknown-linux-gnu Mail-Followup-To: Kevin Ryde , guile-user@gnu.org In-Reply-To: <87slvog9sd.fsf@zip.com.au> (Kevin Ryde's message of "Thu, 29 Sep 2005 07:30:26 +1000") User-Agent: Gnus/5.110004 (No Gnus v0.4) Emacs/21.4 (gnu/linux) X-Spam-Score: 0.496 () MAILTO_TO_SPAM_ADDR X-Scanned-By: MIMEDefang at CNRS-LAAS X-BeenThere: guile-user@gnu.org X-Mailman-Version: 2.1.5 Precedence: list List-Id: General Guile related discussions List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Original-Sender: guile-user-bounces+guile-user=m.gmane.org@gnu.org Errors-To: guile-user-bounces+guile-user=m.gmane.org@gnu.org Xref: news.gmane.org gmane.lisp.guile.user:4809 Archived-At: Hi Kevin, Kevin Ryde writes: > Looks like a memory leak here if scm_to_ulong throws an error. > Obviously it won't normally, but a vector with any garbage could reach > here. Maybe build the addr on the stack then memdup. Ditto the other > cases. Right, I fixed this one. > What is #f here meant to support? Mostly, it aims at being consistent with `_scm_from_sockaddr ()' which may set the `path' element to `#f'. > How about sizeof(c_unix->sun_path)? Right, fixed. > I think scm_to_locale_stringbuf will store nulls from the string but > then SUN_LEN will truncate at the first one of those. Maybe nulls in > the SCM should be an error (per scm_to_locale_stringn). I added a sanity check for this, too (although I'm unsure if it's really useful). I attach a full patch which includes the test-case too, so that we don't have too much of a hard time keeping track of the thing. ;-) BTW, I should receive the papers from the FSF shortly. Thanks, Ludovic. --- orig/ice-9/networking.scm +++ mod/ice-9/networking.scm @@ -80,3 +80,5 @@ (define (sockaddr:path obj) (vector-ref obj 1)) (define (sockaddr:addr obj) (vector-ref obj 1)) (define (sockaddr:port obj) (vector-ref obj 2)) +(define (sockaddr:flowinfo obj) (vector-ref obj 3)) +(define (sockaddr:scopeid obj) (vector-ref obj 4)) --- orig/libguile/socket.c +++ mod/libguile/socket.c @@ -664,9 +664,9 @@ proc is the name of the original procedure. size returns the size of the structure allocated. */ -static struct sockaddr * +static SCM_C_INLINE_KEYWORD struct sockaddr * scm_fill_sockaddr (int fam, SCM address, SCM *args, int which_arg, - const char *proc, int *size) + const char *proc, size_t *size) #define FUNC_NAME proc { switch (fam) @@ -682,8 +682,7 @@ port = scm_to_int (SCM_CAR (*args)); *args = SCM_CDR (*args); soka = (struct sockaddr_in *) scm_malloc (sizeof (struct sockaddr_in)); - if (!soka) - scm_memory_error (proc); + #if HAVE_STRUCT_SOCKADDR_SIN_LEN soka->sin_len = sizeof (struct sockaddr_in); #endif @@ -717,8 +716,7 @@ } } soka = (struct sockaddr_in6 *) scm_malloc (sizeof (struct sockaddr_in6)); - if (!soka) - scm_memory_error (proc); + #if HAVE_STRUCT_SOCKADDR_IN6_SIN6_LEN soka->sin6_len = sizeof (struct sockaddr_in6); #endif @@ -768,9 +766,9 @@ } } #undef FUNC_NAME - -SCM_DEFINE (scm_connect, "connect", 3, 0, 1, - (SCM sock, SCM fam, SCM address, SCM args), + +SCM_DEFINE (scm_connect, "connect", 2, 1, 1, + (SCM sock, SCM fam_or_sockaddr, SCM address, SCM args), "Initiate a connection from a socket using a specified address\n" "family to the address\n" "specified by @var{address} and possibly @var{args}.\n" @@ -787,22 +785,32 @@ "@var{args} may be up to three integers:\n" "port [flowinfo] [scope_id],\n" "where flowinfo and scope_id default to zero.\n\n" + "Alternatively, the second argument can be a socket address object " + "as returned by @code{make-socket-address}, in which case the " + "no additional arguments should be passed.\n\n" "The return value is unspecified.") #define FUNC_NAME s_scm_connect { int fd; struct sockaddr *soka; - int size; + size_t size; sock = SCM_COERCE_OUTPORT (sock); SCM_VALIDATE_OPFPORT (1, sock); fd = SCM_FPORT_FDES (sock); - soka = scm_fill_sockaddr (scm_to_int (fam), address, &args, 3, FUNC_NAME, - &size); + + if (address == SCM_UNDEFINED) + /* No third argument was passed to FAM_OR_SOCKADDR must actually be a + `socket address' object. */ + soka = scm_to_sockaddr (fam_or_sockaddr, &size); + else + soka = scm_fill_sockaddr (scm_to_int (fam_or_sockaddr), address, + &args, 3, FUNC_NAME, &size); + if (connect (fd, soka, size) == -1) { int save_errno = errno; - + free (soka); errno = save_errno; SCM_SYSERROR; @@ -812,8 +820,8 @@ } #undef FUNC_NAME -SCM_DEFINE (scm_bind, "bind", 3, 0, 1, - (SCM sock, SCM fam, SCM address, SCM args), +SCM_DEFINE (scm_bind, "bind", 2, 1, 1, + (SCM sock, SCM fam_or_sockaddr, SCM address, SCM args), "Assign an address to the socket port @var{sock}.\n" "Generally this only needs to be done for server sockets,\n" "so they know where to look for incoming connections. A socket\n" @@ -846,22 +854,33 @@ "may be up to three integers:\n" "port [flowinfo] [scope_id],\n" "where flowinfo and scope_id default to zero.\n\n" + "Alternatively, the second argument can be a socket address object " + "as returned by @code{make-socket-address}, in which case the " + "no additional arguments should be passed.\n\n" "The return value is unspecified.") #define FUNC_NAME s_scm_bind { struct sockaddr *soka; - int size; + size_t size; int fd; sock = SCM_COERCE_OUTPORT (sock); SCM_VALIDATE_OPFPORT (1, sock); - soka = scm_fill_sockaddr (scm_to_int (fam), address, &args, 3, FUNC_NAME, - &size); fd = SCM_FPORT_FDES (sock); + + if (address == SCM_UNDEFINED) + /* No third argument was passed to FAM_OR_SOCKADDR must actually be a + `socket address' object. */ + soka = scm_to_sockaddr (fam_or_sockaddr, &size); + else + soka = scm_fill_sockaddr (scm_to_int (fam_or_sockaddr), address, + &args, 3, FUNC_NAME, &size); + + if (bind (fd, soka, size) == -1) { int save_errno = errno; - + free (soka); errno = save_errno; SCM_SYSERROR; @@ -893,8 +912,8 @@ #undef FUNC_NAME /* Put the components of a sockaddr into a new SCM vector. */ -static SCM -scm_addr_vector (const struct sockaddr *address, int addr_size, +static SCM_C_INLINE_KEYWORD SCM +_scm_from_sockaddr (const struct sockaddr *address, unsigned addr_size, const char *proc) { short int fam = address->sa_family; @@ -953,12 +972,212 @@ break; #endif default: - scm_misc_error (proc, "Unrecognised address family: ~A", + result = SCM_UNSPECIFIED; + scm_misc_error (proc, "unrecognised address family: ~A", scm_list_1 (scm_from_int (fam))); + } return result; } +/* The publicly-visible function. Return a Scheme object representing + ADDRESS, an address of ADDR_SIZE bytes. */ +SCM +scm_from_sockaddr (const struct sockaddr *address, unsigned addr_size) +{ + return (_scm_from_sockaddr (address, addr_size, "scm_from_sockaddr")); +} + +/* Convert ADDRESS, an address object returned by either + `scm_from_sockaddr ()' or `scm_make_socket_address ()', into its C + representation. On success, a non-NULL pointer is returned and + ADDRESS_SIZE is updated to the actual size (in bytes) of the returned + address. The result must eventually be freed using `free ()'. */ +struct sockaddr * +scm_to_sockaddr (SCM address, size_t *address_size) +#define FUNC_NAME "scm_to_sockaddr" +{ + short int family; + struct sockaddr *c_address = NULL; + + SCM_VALIDATE_VECTOR (1, address); + + *address_size = 0; + family = scm_to_short (SCM_SIMPLE_VECTOR_REF (address, 0)); + + switch (family) + { + case AF_INET: + { + if (SCM_SIMPLE_VECTOR_LENGTH (address) != 3) + scm_misc_error (FUNC_NAME, + "invalid inet address representation: ~A", + scm_list_1 (address)); + else + { + struct sockaddr_in c_inet; + + c_inet.sin_addr.s_addr = + htonl (scm_to_ulong (SCM_SIMPLE_VECTOR_REF (address, 1))); + c_inet.sin_port = + htons (scm_to_ushort (SCM_SIMPLE_VECTOR_REF (address, 2))); + c_inet.sin_family = AF_INET; + + *address_size = sizeof (c_inet); + c_address = scm_malloc (sizeof (c_inet)); + memcpy (c_address, &c_inet, sizeof (c_inet)); + } + + break; + } + +#ifdef HAVE_IPV6 + case AF_INET6: + { + if (SCM_SIMPLE_VECTOR_LENGTH (address) != 5) + scm_misc_error (FUNC_NAME, "invalid inet6 address representation: ~A", + scm_list_1 (address)); + else + { + struct sockaddr_in6 c_inet6; + + scm_to_ipv6 (c_inet6.sin6_addr.s6_addr, address); + c_inet6.sin6_port = + htons (scm_to_ushort (SCM_SIMPLE_VECTOR_REF (address, 2))); + c_inet6.sin6_flowinfo = + scm_to_uint32 (SCM_SIMPLE_VECTOR_REF (address, 3)); +#ifdef HAVE_SIN6_SCOPE_ID + c_inet6.sin6_scope_id = + scm_to_ulong (SCM_SIMPLE_VECTOR_REF (address, 4)); +#endif + + c_inet6.sin6_family = AF_INET6; + + *address_size = sizeof (c_inet6); + c_address = scm_malloc (sizeof (c_inet6)); + memcpy (c_address, &c_inet6, sizeof (c_inet6)); + } + + break; + } +#endif + +#ifdef HAVE_UNIX_DOMAIN_SOCKETS + case AF_UNIX: + { + if (SCM_SIMPLE_VECTOR_LENGTH (address) != 2) + scm_misc_error (FUNC_NAME, "invalid unix address representation: ~A", + scm_list_1 (address)); + else + { + SCM path; + size_t path_len = 0; + + path = SCM_SIMPLE_VECTOR_REF (address, 1); + if ((!scm_is_string (path)) && (path != SCM_BOOL_F)) + scm_misc_error (FUNC_NAME, "invalid unix address " + "path: ~A", scm_list_1 (path)); + else + { + struct sockaddr_un c_unix; + + if (path == SCM_BOOL_F) + path_len = 0; + else + path_len = scm_c_string_length (path); + +#ifdef UNIX_PATH_MAX + if (path_len >= UNIX_PATH_MAX) +#else +/* We can hope that this limit will eventually vanish, at least on GNU. + However, currently, while glibc doesn't define `UNIX_PATH_MAX', it + documents it has being limited to 108 bytes. */ + if (path_len >= sizeof (c_unix.sun_path)) +#endif + scm_misc_error (FUNC_NAME, "unix address path " + "too long: ~A", scm_list_1 (path)); + else + { + if (path_len) + { + scm_to_locale_stringbuf (path, c_unix.sun_path, +#ifdef UNIX_PATH_MAX + UNIX_PATH_MAX); +#else + sizeof (c_unix.sun_path)); +#endif + c_unix.sun_path[path_len] = '\0'; + + /* Sanity check. */ + if (strlen (c_unix.sun_path) != path_len) + scm_misc_error (FUNC_NAME, "unix address path " + "contains nul characters: ~A", + scm_list_1 (path)); + } + else + c_unix.sun_path[0] = '\0'; + + c_unix.sun_family = AF_UNIX; + + *address_size = SUN_LEN (&c_unix); + c_address = scm_malloc (sizeof (c_unix)); + memcpy (c_address, &c_unix, sizeof (c_unix)); + } + } + } + + break; + } +#endif + + default: + scm_misc_error (FUNC_NAME, "unrecognised address family: ~A", + scm_list_1 (scm_from_ushort (family))); + } + + return c_address; +} +#undef FUNC_NAME + + +/* Return a newly-allocated `sockaddr' structure that reflects ADDRESS, being + an address of family FAMILY, with the family-specific parameters ARGS (see + the description of `connect' for details). The returned structure may be + freed using `free ()'. */ +struct sockaddr * +scm_c_make_socket_address (SCM family, SCM address, SCM args, + size_t *address_size) +{ + size_t size; + struct sockaddr *soka; + + soka = scm_fill_sockaddr (scm_to_ushort (family), address, &args, 1, + "scm_c_make_socket_address", &size); + + return soka; +} + +SCM_DEFINE (scm_make_socket_address, "make-socket-address", 2, 0, 1, + (SCM family, SCM address, SCM args), + "Return a Scheme address object that reflects @var{address}, " + "being an address of family @var{family}, with the " + "family-specific parameters @var{args} (see the description of " + "@code{connect} for details).") +#define FUNC_NAME s_scm_make_socket_address +{ + struct sockaddr *c_address; + size_t c_address_size; + + c_address = scm_c_make_socket_address (family, address, args, + &c_address_size); + if (!c_address) + return SCM_BOOL_F; + + return (scm_from_sockaddr (c_address, c_address_size)); +} +#undef FUNC_NAME + + /* calculate the size of a buffer large enough to hold any supported sockaddr type. if the buffer isn't large enough, certain system calls will return a truncated address. */ @@ -1009,7 +1228,7 @@ if (newfd == -1) SCM_SYSERROR; newsock = SCM_SOCK_FD_TO_PORT (newfd); - address = scm_addr_vector (addr, addr_size, FUNC_NAME); + address = _scm_from_sockaddr (addr, addr_size, FUNC_NAME); return scm_cons (newsock, address); } #undef FUNC_NAME @@ -1031,7 +1250,7 @@ fd = SCM_FPORT_FDES (sock); if (getsockname (fd, addr, &addr_size) == -1) SCM_SYSERROR; - return scm_addr_vector (addr, addr_size, FUNC_NAME); + return _scm_from_sockaddr (addr, addr_size, FUNC_NAME); } #undef FUNC_NAME @@ -1053,7 +1272,7 @@ fd = SCM_FPORT_FDES (sock); if (getpeername (fd, addr, &addr_size) == -1) SCM_SYSERROR; - return scm_addr_vector (addr, addr_size, FUNC_NAME); + return _scm_from_sockaddr (addr, addr_size, FUNC_NAME); } #undef FUNC_NAME @@ -1207,7 +1426,7 @@ if (rv == -1) SCM_SYSERROR; if (addr->sa_family != AF_UNSPEC) - address = scm_addr_vector (addr, addr_size, FUNC_NAME); + address = _scm_from_sockaddr (addr, addr_size, FUNC_NAME); else address = SCM_BOOL_F; @@ -1216,13 +1435,14 @@ } #undef FUNC_NAME -SCM_DEFINE (scm_sendto, "sendto", 4, 0, 1, - (SCM sock, SCM message, SCM fam, SCM address, SCM args_and_flags), +SCM_DEFINE (scm_sendto, "sendto", 3, 1, 1, + (SCM sock, SCM message, SCM fam_or_sockaddr, SCM address, SCM args_and_flags), "Transmit the string @var{message} on the socket port\n" "@var{sock}. The\n" "destination address is specified using the @var{fam},\n" "@var{address} and\n" - "@var{args_and_flags} arguments, in a similar way to the\n" + "@var{args_and_flags} arguments, or just a socket address object " + "returned by @code{make-socket-address}, in a similar way to the\n" "@code{connect} procedure. @var{args_and_flags} contains\n" "the usual connection arguments optionally followed by\n" "a flags argument, which is a value or\n" @@ -1241,14 +1461,26 @@ int fd; int flg; struct sockaddr *soka; - int size; + size_t size; sock = SCM_COERCE_OUTPORT (sock); SCM_VALIDATE_FPORT (1, sock); SCM_VALIDATE_STRING (2, message); fd = SCM_FPORT_FDES (sock); - soka = scm_fill_sockaddr (scm_to_int (fam), address, &args_and_flags, 4, - FUNC_NAME, &size); + + if (!scm_is_number (fam_or_sockaddr)) + { + /* FAM_OR_SOCKADDR must actually be a `socket address' object. This + means that the following arguments, i.e. ADDRESS and those listed in + ARGS_AND_FLAGS, are the `MSG_' flags. */ + soka = scm_to_sockaddr (fam_or_sockaddr, &size); + if (address != SCM_UNDEFINED) + args_and_flags = scm_cons (address, args_and_flags); + } + else + soka = scm_fill_sockaddr (scm_to_int (fam_or_sockaddr), address, + &args_and_flags, 3, FUNC_NAME, &size); + if (scm_is_null (args_and_flags)) flg = 0; else --- orig/libguile/socket.h +++ mod/libguile/socket.h @@ -54,6 +54,16 @@ SCM_API SCM scm_sendto (SCM sockfd, SCM message, SCM fam, SCM address, SCM args_and_flags); SCM_API void scm_init_socket (void); +/* Wrapping/unwrapping address objects. */ +struct sockaddr; +SCM_API SCM scm_from_sockaddr (const struct sockaddr *address, + unsigned addr_size); +SCM_API struct sockaddr *scm_to_sockaddr (SCM address, size_t *adress_size); +SCM_API struct sockaddr *scm_c_make_socket_address (SCM family, SCM address, + SCM args, + size_t *address_size); +SCM_API SCM scm_make_socket_address (SCM family, SCM address, SCM args); + #endif /* SCM_SOCKET_H */ /* --- orig/test-suite/tests/socket.test +++ mod/test-suite/tests/socket.test @@ -6,12 +6,12 @@ ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either ;;;; version 2.1 of the License, or (at your option) any later version. -;;;; +;;;; ;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;;; Lesser General Public License for more details. -;;;; +;;;; ;;;; You should have received a copy of the GNU Lesser General Public ;;;; License along with this library; if not, write to the Free Software ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA @@ -19,6 +19,7 @@ (define-module (test-suite test-numbers) #:use-module (test-suite lib)) + ;;; ;;; inet-ntop ;;; @@ -78,3 +79,177 @@ (eqv? #xF0 (inet-pton AF_INET6 "0000:0000:0000:0000:0000:0000:0000:00F0")))))) + + +;;; +;;; make-socket-address +;;; + +(with-test-prefix "make-socket-address" + (if (defined? 'AF_INET) + (pass-if "AF_INET" + (let ((sa (make-socket-address AF_INET 123456 80))) + (and (= (sockaddr:fam sa) AF_INET) + (= (sockaddr:addr sa) 123456) + (= (sockaddr:port sa) 80))))) + + (if (defined? 'AF_INET6) + (pass-if "AF_INET6" + ;; Since the platform doesn't necessarily support `scopeid', we won't + ;; test it. + (let ((sa* (make-socket-address AF_INET6 123456 80 1)) + (sa+ (make-socket-address AF_INET6 123456 80))) + (and (= (sockaddr:fam sa*) (sockaddr:fam sa+) AF_INET6) + (= (sockaddr:addr sa*) (sockaddr:addr sa+) 123456) + (= (sockaddr:port sa*) (sockaddr:port sa+) 80) + (= (sockaddr:flowinfo sa*) 1))))) + + (if (defined? 'AF_UNIX) + (pass-if "AF_UNIX" + (let ((sa (make-socket-address AF_UNIX "/tmp/unix-socket"))) + (and (= (sockaddr:fam sa) AF_UNIX) + (string=? (sockaddr:path sa) "/tmp/unix-socket")))))) + + + +;;; +;;; AF_UNIX sockets and `make-socket-address' +;;; + +(if (defined? 'AF_UNIX) + (with-test-prefix "AF_UNIX/SOCK_DGRAM" + + ;; testing `bind' and `sendto' and datagram sockets + + (let ((server-socket (socket AF_UNIX SOCK_DGRAM 0)) + (server-bound? #f) + (path (tmpnam))) + + (pass-if "bind" + (catch 'system-error + (lambda () + (bind server-socket AF_UNIX path) + (set! server-bound? #t) + #t) + (lambda args + (let ((errno (system-error-errno args))) + (cond ((= errno EADDRINUSE) (throw 'unresolved)) + (else (apply throw args))))))) + + (pass-if "bind/sockaddr" + (let* ((sock (socket AF_UNIX SOCK_STREAM 0)) + (path (tmpnam)) + (sockaddr (make-socket-address AF_UNIX path))) + (catch 'system-error + (lambda () + (bind sock sockaddr) + (false-if-exception (delete-file path)) + #t) + (lambda args + (let ((errno (system-error-errno args))) + (cond ((= errno EADDRINUSE) (throw 'unresolved)) + (else (apply throw args)))))))) + + (pass-if "sendto" + (if (not server-bound?) + (throw 'unresolved) + (let ((client (socket AF_UNIX SOCK_DGRAM 0))) + (> (sendto client "hello" AF_UNIX path) 0)))) + + (pass-if "sendto/sockaddr" + (if (not server-bound?) + (throw 'unresolved) + (let ((client (socket AF_UNIX SOCK_DGRAM 0)) + (sockaddr (make-socket-address AF_UNIX path))) + (> (sendto client "hello" sockaddr) 0)))) + + (false-if-exception (delete-file path))))) + + +(if (defined? 'AF_UNIX) + (with-test-prefix "AF_UNIX/SOCK_STREAM" + + ;; testing `bind', `listen' and `connect' on stream-oriented sockets + + (let ((server-socket (socket AF_UNIX SOCK_STREAM 0)) + (server-bound? #f) + (server-listening? #f) + (server-pid #f) + (path (tmpnam))) + + (pass-if "bind" + (catch 'system-error + (lambda () + (bind server-socket AF_UNIX path) + (set! server-bound? #t) + #t) + (lambda args + (let ((errno (system-error-errno args))) + (cond ((= errno EADDRINUSE) (throw 'unresolved)) + (else (apply throw args))))))) + + (pass-if "bind/sockaddr" + (let* ((sock (socket AF_UNIX SOCK_STREAM 0)) + (path (tmpnam)) + (sockaddr (make-socket-address AF_UNIX path))) + (catch 'system-error + (lambda () + (bind sock sockaddr) + (false-if-exception (delete-file path)) + #t) + (lambda args + (let ((errno (system-error-errno args))) + (cond ((= errno EADDRINUSE) (throw 'unresolved)) + (else (apply throw args)))))))) + + (pass-if "listen" + (if (not server-bound?) + (throw 'unresolved) + (begin + (listen server-socket 123) + (set! server-listening? #t) + #t))) + + (if server-listening? + (let ((pid (primitive-fork))) + ;; Spawn a server process. + (case pid + ((-1) (throw 'unresolved)) + ((0) ;; the kid: serve two connections and exit + (let serve ((conn + (false-if-exception (accept server-socket))) + (count 1)) + (if (not conn) + (exit 1) + (if (> count 0) + (serve (false-if-exception (accept server-socket)) + (- count 1))))) + (exit 0)) + (else ;; the parent + (set! server-pid pid) + #t)))) + + (pass-if "connect" + (if (not server-pid) + (throw 'unresolved) + (let ((s (socket AF_UNIX SOCK_STREAM 0))) + (connect s AF_UNIX path) + #t))) + + (pass-if "connect/sockaddr" + (if (not server-pid) + (throw 'unresolved) + (let ((s (socket AF_UNIX SOCK_STREAM 0))) + (connect s (make-socket-address AF_UNIX path)) + #t))) + + (pass-if "accept" + (if (not server-pid) + (throw 'unresolved) + (let ((status (cdr (waitpid server-pid)))) + (eq? 0 (status:exit-val status))))) + + (false-if-exception (delete-file path)) + + #t))) + _______________________________________________ Guile-user mailing list Guile-user@gnu.org http://lists.gnu.org/mailman/listinfo/guile-user