1 /* Copyright (C) 1996,1997,1998,2000,2001 Free Software Foundation, Inc.
3 * This program is free software; you can redistribute it and/or modify
4 * it under the terms of the GNU General Public License as published by
5 * the Free Software Foundation; either version 2, or (at your option)
8 * This program is distributed in the hope that it will be useful,
9 * but WITHOUT ANY WARRANTY; without even the implied warranty of
10 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
11 * GNU General Public License for more details.
13 * You should have received a copy of the GNU General Public License
14 * along with this software; see the file COPYING. If not, write to
15 * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
16 * Boston, MA 02111-1307 USA
18 * As a special exception, the Free Software Foundation gives permission
19 * for additional uses of the text contained in its release of GUILE.
21 * The exception is that, if you link the GUILE library with other files
22 * to produce an executable, this does not by itself cause the
23 * resulting executable to be covered by the GNU General Public License.
24 * Your use of that executable is in no way restricted on account of
25 * linking the GUILE library code into it.
27 * This exception does not however invalidate any other reasons why
28 * the executable file might be covered by the GNU General Public License.
30 * This exception applies only to the code released by the
31 * Free Software Foundation under the name GUILE. If you copy
32 * code from other Free Software Foundation releases into a copy of
33 * GUILE, as the General Public License permits, the exception does
34 * not apply to the code that you add in this way. To avoid misleading
35 * anyone as to the status of such modified files, you must delete
36 * this exception notice from them.
38 * If you write modifications of your own for GUILE, it is your choice
39 * whether to permit this exception to apply to your modifications.
40 * If you do not wish that, delete this exception notice. */
42 /* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
43 gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
49 #include "libguile/_scm.h"
50 #include "libguile/unif.h"
51 #include "libguile/feature.h"
52 #include "libguile/fports.h"
53 #include "libguile/strings.h"
54 #include "libguile/vectors.h"
56 #include "libguile/validate.h"
57 #include "libguile/socket.h"
65 #include <sys/types.h>
66 #include <sys/socket.h>
67 #ifdef HAVE_UNIX_DOMAIN_SOCKETS
70 #include <netinet/in.h>
72 #include <arpa/inet.h>
74 #if defined (HAVE_UNIX_DOMAIN_SOCKETS) && !defined (SUN_LEN)
75 #define SUN_LEN(ptr) ((size_t) (((struct sockaddr_un *) 0)->sun_path) \
76 + strlen ((ptr)->sun_path))
79 /* we are not currently using socklen_t. it's not defined on all systems,
80 so would need to be checked by configure. in the meantime, plain
81 int is the best alternative. */
85 SCM_DEFINE (scm_htons
, "htons", 1, 0, 0,
87 "Return a new integer from @var{value} by converting from host\n"
88 "to network order. @var{value} must be within the range of a C\n"
89 "unsigned short integer.")
90 #define FUNC_NAME s_scm_htons
94 SCM_VALIDATE_INUM_COPY (1,in
,c_in
);
95 if (c_in
!= SCM_INUM (in
))
96 SCM_OUT_OF_RANGE (1,in
);
98 return SCM_MAKINUM (htons (c_in
));
102 SCM_DEFINE (scm_ntohs
, "ntohs", 1, 0, 0,
104 "Return a new integer from @var{value} by converting from\n"
105 "network to host order. @var{value} must be within the range of\n"
106 "a C unsigned short integer.")
107 #define FUNC_NAME s_scm_ntohs
111 SCM_VALIDATE_INUM_COPY (1,in
,c_in
);
112 if (c_in
!= SCM_INUM (in
))
113 SCM_OUT_OF_RANGE (1,in
);
115 return SCM_MAKINUM (ntohs (c_in
));
119 SCM_DEFINE (scm_htonl
, "htonl", 1, 0, 0,
121 "Return a new integer from @var{value} by converting from host\n"
122 "to network order. @var{value} must be within the range of a\n"
123 "32 bit unsigned integer.")
124 #define FUNC_NAME s_scm_htonl
126 uint32_t c_in
= SCM_NUM2ULONG (1, in
);
128 return scm_ulong2num (htonl (c_in
));
132 SCM_DEFINE (scm_ntohl
, "ntohl", 1, 0, 0,
134 "Return a new integer from @var{value} by converting from\n"
135 "network to host order. @var{value} must be within the range of\n"
136 "a 32 bit unsigned integer.")
137 #define FUNC_NAME s_scm_ntohl
139 uint32_t c_in
= SCM_NUM2ULONG (1, in
);
141 return scm_ulong2num (ntohl (c_in
));
145 #ifndef HAVE_INET_ATON
146 /* for our definition in inet_aton.c, not usually needed. */
147 extern int inet_aton ();
150 SCM_DEFINE (scm_inet_aton
, "inet-aton", 1, 0, 0,
152 "Converts a string containing an Internet host address in the\n"
153 "traditional dotted decimal notation into an integer.\n"
155 "(inet-aton \"127.0.0.1\") @result{} 2130706433\n"
157 #define FUNC_NAME s_scm_inet_aton
161 SCM_VALIDATE_STRING (1, address
);
162 SCM_STRING_COERCE_0TERMINATION_X (address
);
163 if (inet_aton (SCM_STRING_CHARS (address
), &soka
) == 0)
164 SCM_MISC_ERROR ("bad address", SCM_EOL
);
165 return scm_ulong2num (ntohl (soka
.s_addr
));
170 SCM_DEFINE (scm_inet_ntoa
, "inet-ntoa", 1, 0, 0,
172 "Converts an integer Internet host address into a string with\n"
173 "the traditional dotted decimal representation.\n"
175 "(inet-ntoa 2130706433) @result{} \"127.0.0.1\"\n"
177 #define FUNC_NAME s_scm_inet_ntoa
182 addr
.s_addr
= htonl (SCM_NUM2ULONG (1, inetid
));
183 s
= inet_ntoa (addr
);
184 answer
= scm_makfromstr (s
, strlen (s
), 0);
189 #ifdef HAVE_INET_NETOF
190 SCM_DEFINE (scm_inet_netof
, "inet-netof", 1, 0, 0,
192 "Return the network number part of the given integer Internet\n"
195 "(inet-netof 2130706433) @result{} 127\n"
197 #define FUNC_NAME s_scm_inet_netof
200 addr
.s_addr
= htonl (SCM_NUM2ULONG (1, address
));
201 return scm_ulong2num ((unsigned long) inet_netof (addr
));
206 #ifdef HAVE_INET_LNAOF
207 SCM_DEFINE (scm_lnaof
, "inet-lnaof", 1, 0, 0,
209 "Return the local-address-with-network part of the given\n"
210 "Internet address.\n"
212 "(inet-lnaof 2130706433) @result{} 1\n"
214 #define FUNC_NAME s_scm_lnaof
217 addr
.s_addr
= htonl (SCM_NUM2ULONG (1, address
));
218 return scm_ulong2num ((unsigned long) inet_lnaof (addr
));
223 #ifdef HAVE_INET_MAKEADDR
224 SCM_DEFINE (scm_inet_makeaddr
, "inet-makeaddr", 2, 0, 0,
226 "Makes an Internet host address by combining the network number\n"
227 "@var{net} with the local-address-within-network number\n"
230 "(inet-makeaddr 127 1) @result{} 2130706433\n"
232 #define FUNC_NAME s_scm_inet_makeaddr
235 unsigned long netnum
;
236 unsigned long lnanum
;
238 netnum
= SCM_NUM2ULONG (1, net
);
239 lnanum
= SCM_NUM2ULONG (2, lna
);
240 addr
= inet_makeaddr (netnum
, lnanum
);
241 return scm_ulong2num (ntohl (addr
.s_addr
));
246 /* flip a 128 bit IPv6 address between host and network order. */
247 #ifdef WORDS_BIGENDIAN
248 #define FLIP_NET_HOST_128(addr)
250 #define FLIP_NET_HOST_128(addr)\
254 for (i = 0; i < 8; i++)\
258 (addr)[i] = (addr)[15 - i];\
264 /* convert a 128 bit IPv6 address in network order to a host ordered
266 static SCM
ipv6_net_to_num (const char *src
)
268 int big_digits
= 128 / SCM_BITSPERDIG
;
269 const int bytes_per_dig
= SCM_BITSPERDIG
/ 8;
274 memcpy (addr
, src
, 16);
275 /* get rid of leading zeros. */
276 while (big_digits
> 0)
280 memcpy (&test
, ptr
, bytes_per_dig
);
283 ptr
+= bytes_per_dig
;
286 FLIP_NET_HOST_128 (addr
);
287 if (big_digits
* bytes_per_dig
<= sizeof (unsigned long))
289 /* this is just so that we use INUM where possible. */
290 unsigned long l_addr
;
292 memcpy (&l_addr
, addr
, sizeof (unsigned long));
293 result
= scm_ulong2num (l_addr
);
297 result
= scm_mkbig (big_digits
, 0);
298 memcpy (SCM_BDIGITS (result
), addr
, big_digits
* bytes_per_dig
);
303 /* convert a host ordered SCM integer to a 128 bit IPv6 address in
305 static void ipv6_num_to_net (SCM src
, char *dst
)
309 uint32_t addr
= htonl (SCM_INUM (src
));
312 memcpy (dst
+ 12, &addr
, 4);
317 memcpy (dst
, SCM_BDIGITS (src
),
318 SCM_NUMDIGS (src
) * (SCM_BITSPERDIG
/ 8));
319 FLIP_NET_HOST_128 (dst
);
323 /* check that an SCM variable contains an IPv6 integer address. */
324 #define VALIDATE_INET6(which_arg, address)\
325 if (SCM_INUMP (address))\
326 SCM_ASSERT_RANGE (which_arg, address, SCM_INUM (address) >= 0);\
329 SCM_VALIDATE_BIGINT (which_arg, address);\
330 SCM_ASSERT_RANGE (which_arg, address,\
331 !SCM_BIGSIGN (address)\
333 * SCM_NUMDIGS (address) <= 128));\
336 #ifdef HAVE_INET_PTON
337 SCM_DEFINE (scm_inet_pton
, "inet-pton", 2, 0, 0,
338 (SCM family
, SCM address
),
339 "Convert a printable string network address into\n"
340 "an integer. Note that unlike the C version of this function,\n"
341 "the result is an integer with normal host byte ordering.\n"
342 "@var{family} can be @code{AF_INET} or @code{AF_INET6}. e.g.,\n"
344 "(inet-pton AF_INET "127.0.0.1") @result{} 2130706433\n"
345 "(inet-pton AF_INET6 "::1") @result{} 1\n"
347 #define FUNC_NAME s_scm_inet_pton
354 SCM_VALIDATE_INUM_COPY (1, family
, af
);
355 SCM_ASSERT_RANGE (1, family
, af
== AF_INET
|| af
== AF_INET6
);
356 SCM_VALIDATE_STRING_COPY (2, address
, src
);
357 rv
= inet_pton (af
, src
, dst
);
361 SCM_MISC_ERROR ("Bad address", SCM_EOL
);
363 return scm_ulong2num (ntohl (*(uint32_t *) dst
));
365 return ipv6_net_to_num ((char *) dst
);
370 #ifdef HAVE_INET_NTOP
371 SCM_DEFINE (scm_inet_ntop
, "inet-ntop", 2, 0, 0,
372 (SCM family
, SCM address
),
373 "Convert an integer network address into a printable string.\n"
374 "Note that unlike the C version of this function,\n"
375 "the input is an integer with normal host byte ordering.\n"
376 "@var{family} can be @code{AF_INET} or @code{AF_INET6}. e.g.,\n"
378 "(inet-ntop AF_INET 2130706433) @result{} "127.0.0.1"\n"
379 "(inet-ntop AF_INET6 (- (expt 2 128) 1)) @result{}\n"
380 "ffff:ffff:ffff:ffff:ffff:ffff:ffff:ffff\n"
382 #define FUNC_NAME s_scm_inet_ntop
385 #ifdef INET6_ADDRSTRLEN
386 char dst
[INET6_ADDRSTRLEN
];
392 SCM_VALIDATE_INUM_COPY (1, family
, af
);
393 SCM_ASSERT_RANGE (1, family
, af
== AF_INET
|| af
== AF_INET6
);
395 *(uint32_t *) addr6
= htonl (SCM_NUM2ULONG (2, address
));
398 VALIDATE_INET6 (2, address
);
399 ipv6_num_to_net (address
, addr6
);
401 if (inet_ntop (af
, &addr6
, dst
, sizeof dst
) == NULL
)
403 return scm_makfrom0str (dst
);
408 SCM_SYMBOL (sym_socket
, "socket");
410 #define SCM_SOCK_FD_TO_PORT(fd) scm_fdes_to_port (fd, "r+0", sym_socket)
412 SCM_DEFINE (scm_socket
, "socket", 3, 0, 0,
413 (SCM family
, SCM style
, SCM proto
),
414 "Return a new socket port of the type specified by @var{family},\n"
415 "@var{style} and @var{protocol}. All three parameters are\n"
416 "integers. Supported values for @var{family} are\n"
417 "@code{AF_UNIX}, @code{AF_INET} and @code{AF_INET6}.\n"
418 "Typical values for @var{style} are @code{SOCK_STREAM},\n"
419 "@code{SOCK_DGRAM} and @code{SOCK_RAW}.\n"
421 "@var{protocol} can be obtained from a protocol name using\n"
422 "@code{getprotobyname}. A value of zero specifies the default\n"
423 "protocol, which is usually right.\n"
425 "A single socket port cannot by used for communication until it\n"
426 "has been connected to another socket.")
427 #define FUNC_NAME s_scm_socket
431 SCM_VALIDATE_INUM (1, family
);
432 SCM_VALIDATE_INUM (2, style
);
433 SCM_VALIDATE_INUM (3, proto
);
434 fd
= socket (SCM_INUM (family
), SCM_INUM (style
), SCM_INUM (proto
));
437 return SCM_SOCK_FD_TO_PORT (fd
);
441 #ifdef HAVE_SOCKETPAIR
442 SCM_DEFINE (scm_socketpair
, "socketpair", 3, 0, 0,
443 (SCM family
, SCM style
, SCM proto
),
444 "Return a pair of connected (but unnamed) socket ports of the\n"
445 "type specified by @var{family}, @var{style} and @var{protocol}.\n"
446 "Many systems support only socket pairs of the @code{AF_UNIX}\n"
447 "family. Zero is likely to be the only meaningful value for\n"
449 #define FUNC_NAME s_scm_socketpair
454 SCM_VALIDATE_INUM (1,family
);
455 SCM_VALIDATE_INUM (2,style
);
456 SCM_VALIDATE_INUM (3,proto
);
458 fam
= SCM_INUM (family
);
460 if (socketpair (fam
, SCM_INUM (style
), SCM_INUM (proto
), fd
) == -1)
463 return scm_cons (SCM_SOCK_FD_TO_PORT (fd
[0]), SCM_SOCK_FD_TO_PORT (fd
[1]));
468 SCM_DEFINE (scm_getsockopt
, "getsockopt", 3, 0, 0,
469 (SCM sock
, SCM level
, SCM optname
),
470 "Return the value of a particular socket option for the socket\n"
471 "port @var{socket}. @var{level} is an integer code for type of\n"
472 "option being requested, e.g., @code{SOL_SOCKET} for\n"
473 "socket-level options. @var{optname} is an integer code for the\n"
474 "option required and should be specified using one of the\n"
475 "symbols @code{SO_DEBUG}, @code{SO_REUSEADDR} etc.\n"
477 "The returned value is typically an integer but @code{SO_LINGER}\n"
478 "returns a pair of integers.")
479 #define FUNC_NAME s_scm_getsockopt
482 /* size of optval is the largest supported option. */
483 #ifdef HAVE_STRUCT_LINGER
484 char optval
[sizeof (struct linger
)];
485 int optlen
= sizeof (struct linger
);
487 char optval
[sizeof (scm_sizet
)];
488 int optlen
= sizeof (scm_sizet
);
493 sock
= SCM_COERCE_OUTPORT (sock
);
494 SCM_VALIDATE_OPFPORT (1, sock
);
495 SCM_VALIDATE_INUM_COPY (2, level
, ilevel
);
496 SCM_VALIDATE_INUM_COPY (3, optname
, ioptname
);
498 fd
= SCM_FPORT_FDES (sock
);
499 if (getsockopt (fd
, ilevel
, ioptname
, (void *) optval
, &optlen
) == -1)
502 if (ilevel
== SOL_SOCKET
)
505 if (ioptname
== SO_LINGER
)
507 #ifdef HAVE_STRUCT_LINGER
508 struct linger
*ling
= (struct linger
*) optval
;
510 return scm_cons (scm_long2num (ling
->l_onoff
),
511 scm_long2num (ling
->l_linger
));
513 return scm_cons (scm_long2num (*(int *) optval
)
521 || ioptname
== SO_SNDBUF
524 || ioptname
== SO_RCVBUF
528 return scm_long2num (*(scm_sizet
*) optval
);
531 return scm_long2num (*(int *) optval
);
535 SCM_DEFINE (scm_setsockopt
, "setsockopt", 4, 0, 0,
536 (SCM sock
, SCM level
, SCM optname
, SCM value
),
537 "Sets the value of a particular socket option for the socket\n"
538 "port @var{socket}. @var{level} is an integer code for type of option\n"
539 "being set, e.g., @code{SOL_SOCKET} for socket-level options.\n"
540 "@var{optname} is an\n"
541 "integer code for the option to set and should be specified using one of\n"
542 "the symbols @code{SO_DEBUG}, @code{SO_REUSEADDR} etc.\n"
543 "@var{value} is the value to which the option should be set. For\n"
544 "most options this must be an integer, but for @code{SO_LINGER} it must\n"
546 "The return value is unspecified.")
547 #define FUNC_NAME s_scm_setsockopt
551 /* size of optval is the largest supported option. */
552 #ifdef HAVE_STRUCT_LINGER
553 char optval
[sizeof (struct linger
)];
555 char optval
[sizeof (scm_sizet
)];
557 int ilevel
, ioptname
;
559 sock
= SCM_COERCE_OUTPORT (sock
);
561 SCM_VALIDATE_OPFPORT (1, sock
);
562 SCM_VALIDATE_INUM_COPY (2, level
, ilevel
);
563 SCM_VALIDATE_INUM_COPY (3, optname
, ioptname
);
565 fd
= SCM_FPORT_FDES (sock
);
567 if (ilevel
== SOL_SOCKET
)
570 if (ioptname
== SO_LINGER
)
572 #ifdef HAVE_STRUCT_LINGER
576 SCM_ASSERT (SCM_CONSP (value
), value
, SCM_ARG4
, FUNC_NAME
);
577 lv
= SCM_NUM2LONG (4, SCM_CAR (value
));
578 ling
.l_onoff
= (int) lv
;
579 SCM_ASSERT_RANGE (SCM_ARG4
, value
, ling
.l_onoff
== lv
);
580 lv
= SCM_NUM2LONG (4, SCM_CDR (value
));
581 ling
.l_linger
= (int) lv
;
582 SCM_ASSERT_RANGE (SCM_ARG4
, value
, ling
.l_linger
== lv
);
583 optlen
= (int) sizeof (struct linger
);
584 memcpy (optval
, (void *) &ling
, optlen
);
589 SCM_ASSERT (SCM_CONSP (value
), value
, SCM_ARG4
, FUNC_NAME
);
590 /* timeout is ignored, but may as well validate it. */
591 lv
= SCM_NUM2LONG (4, SCM_CDR (value
));
593 SCM_ASSERT_RANGE (SCM_ARG4
, value
, ling
== lv
);
594 lv
= SCM_NUM2LONG (4, SCM_CAR (value
));
596 SCM_ASSERT_RANGE (SCM_ARG4
, value
, ling
== lv
);
597 optlen
= (int) sizeof (int);
598 (*(int *) optval
) = ling
;
605 || ioptname
== SO_SNDBUF
608 || ioptname
== SO_RCVBUF
612 long lv
= SCM_NUM2LONG (4, value
);
614 optlen
= (int) sizeof (scm_sizet
);
615 (*(scm_sizet
*) optval
) = (scm_sizet
) lv
;
620 /* Most options take an int. */
621 long lv
= SCM_NUM2LONG (4, value
);
624 SCM_ASSERT_RANGE (SCM_ARG4
, value
, val
== lv
);
625 optlen
= (int) sizeof (int);
626 (*(int *) optval
) = val
;
628 if (setsockopt (fd
, ilevel
, ioptname
, (void *) optval
, optlen
) == -1)
630 return SCM_UNSPECIFIED
;
634 SCM_DEFINE (scm_shutdown
, "shutdown", 2, 0, 0,
636 "Sockets can be closed simply by using @code{close-port}. The\n"
637 "@code{shutdown} procedure allows reception or tranmission on a\n"
638 "connection to be shut down individually, according to the parameter\n"
642 "Stop receiving data for this socket. If further data arrives, reject it.\n"
644 "Stop trying to transmit data from this socket. Discard any\n"
645 "data waiting to be sent. Stop looking for acknowledgement of\n"
646 "data already sent; don't retransmit it if it is lost.\n"
648 "Stop both reception and transmission.\n"
650 "The return value is unspecified.")
651 #define FUNC_NAME s_scm_shutdown
654 sock
= SCM_COERCE_OUTPORT (sock
);
655 SCM_VALIDATE_OPFPORT (1,sock
);
656 SCM_VALIDATE_INUM (2,how
);
657 SCM_ASSERT_RANGE(2,how
,0 <= SCM_INUM (how
) && 2 >= SCM_INUM (how
));
658 fd
= SCM_FPORT_FDES (sock
);
659 if (shutdown (fd
, SCM_INUM (how
)) == -1)
661 return SCM_UNSPECIFIED
;
665 /* convert fam/address/args into a sockaddr of the appropriate type.
666 args is modified by removing the arguments actually used.
667 which_arg and proc are used when reporting errors:
668 which_arg is the position of address in the original argument list.
669 proc is the name of the original procedure.
670 size returns the size of the structure allocated. */
672 static struct sockaddr
*
673 scm_fill_sockaddr (int fam
, SCM address
, SCM
*args
, int which_arg
,
674 const char *proc
, int *size
)
675 #define FUNC_NAME proc
681 struct sockaddr_in
*soka
;
685 SCM_VALIDATE_ULONG_COPY (which_arg
, address
, addr
);
686 SCM_VALIDATE_CONS (which_arg
+ 1, *args
);
687 SCM_VALIDATE_INUM_COPY (which_arg
+ 1, SCM_CAR (*args
), port
);
688 *args
= SCM_CDR (*args
);
689 soka
= (struct sockaddr_in
*) malloc (sizeof (struct sockaddr_in
));
691 scm_memory_error (proc
);
692 /* 4.4BSD-style interface includes sin_len member and defines SIN_LEN,
695 soka
->sin_len
= sizeof (struct sockaddr_in
);
697 soka
->sin_family
= AF_INET
;
698 soka
->sin_addr
.s_addr
= htonl (addr
);
699 soka
->sin_port
= htons (port
);
700 *size
= sizeof (struct sockaddr_in
);
701 return (struct sockaddr
*) soka
;
708 struct sockaddr_in6
*soka
;
709 unsigned long flowinfo
= 0;
710 unsigned long scope_id
= 0;
712 VALIDATE_INET6 (which_arg
, address
);
713 SCM_VALIDATE_CONS (which_arg
+ 1, *args
);
714 SCM_VALIDATE_INUM_COPY (which_arg
+ 1, SCM_CAR (*args
), port
);
715 *args
= SCM_CDR (*args
);
716 if (SCM_CONSP (*args
))
718 SCM_VALIDATE_ULONG_COPY (which_arg
+ 2, SCM_CAR (*args
), flowinfo
);
719 *args
= SCM_CDR (*args
);
720 if (SCM_CONSP (*args
))
722 SCM_VALIDATE_ULONG_COPY (which_arg
+ 3, SCM_CAR (*args
),
724 *args
= SCM_CDR (*args
);
727 soka
= (struct sockaddr_in6
*) malloc (sizeof (struct sockaddr_in6
));
729 scm_memory_error (proc
);
731 soka
->sin6_len
= sizeof (struct sockaddr_in6
);
733 soka
->sin6_family
= AF_INET6
;
734 ipv6_num_to_net (address
, soka
->sin6_addr
.s6_addr
);
735 soka
->sin6_port
= htons (port
);
736 soka
->sin6_flowinfo
= flowinfo
;
737 #ifdef HAVE_SIN6_SCOPE_ID
738 soka
->sin6_scope_id
= scope_id
;
740 *size
= sizeof (struct sockaddr_in6
);
741 return (struct sockaddr
*) soka
;
744 #ifdef HAVE_UNIX_DOMAIN_SOCKETS
747 struct sockaddr_un
*soka
;
750 SCM_ASSERT (SCM_STRINGP (address
), address
, which_arg
, proc
);
751 /* the static buffer size in sockaddr_un seems to be arbitrary
752 and not necessarily a hard limit. e.g., the glibc manual
753 suggests it may be possible to declare it size 0. let's
754 ignore it. if the O/S doesn't like the size it will cause
755 connect/bind etc., to fail. sun_path is always the last
756 member of the structure. */
757 addr_size
= sizeof (struct sockaddr_un
)
758 + max (0, SCM_STRING_LENGTH (address
) + 1 - (sizeof soka
->sun_path
));
759 soka
= (struct sockaddr_un
*) malloc (addr_size
);
761 scm_memory_error (proc
);
762 memset (soka
, 0, addr_size
); /* for sun_len: see sin_len above. */
763 soka
->sun_family
= AF_UNIX
;
764 memcpy (soka
->sun_path
, SCM_STRING_CHARS (address
),
765 SCM_STRING_LENGTH (address
));
766 *size
= SUN_LEN (soka
);
767 return (struct sockaddr
*) soka
;
771 scm_out_of_range (proc
, SCM_MAKINUM (fam
));
776 SCM_DEFINE (scm_connect
, "connect", 3, 0, 1,
777 (SCM sock
, SCM fam
, SCM address
, SCM args
),
778 "Initiates a connection from a socket using a specified address\n"
779 "family to the address\n"
780 "specified by @var{address} and possibly @var{args}.\n"
781 "The format required for @var{address}\n"
782 "and @var{args} depends on the family of the socket.\n\n"
783 "For a socket of family @code{AF_UNIX},\n"
784 "only @var{address} is specified and must be a string with the\n"
785 "filename where the socket is to be created.\n\n"
786 "For a socket of family @code{AF_INET},\n"
787 "@var{address} must be an integer IPv4 host address and\n"
788 "@var{args} must be a single integer port number.\n\n"
789 "For a socket of family @code{AF_INET6},\n"
790 "@var{address} must be an integer IPv6 host address and\n"
791 "@var{args} may be up to three integers:\n"
792 "port [flowinfo] [scope_id],\n"
793 "where flowinfo and scope_id default to zero.\n\n"
794 "The return value is unspecified.")
795 #define FUNC_NAME s_scm_connect
798 struct sockaddr
*soka
;
801 sock
= SCM_COERCE_OUTPORT (sock
);
802 SCM_VALIDATE_OPFPORT (1,sock
);
803 SCM_VALIDATE_INUM (2,fam
);
804 fd
= SCM_FPORT_FDES (sock
);
805 soka
= scm_fill_sockaddr (SCM_INUM (fam
), address
, &args
, 3, FUNC_NAME
,
807 if (connect (fd
, soka
, size
) == -1)
809 int save_errno
= errno
;
816 return SCM_UNSPECIFIED
;
820 SCM_DEFINE (scm_bind
, "bind", 3, 0, 1,
821 (SCM sock
, SCM fam
, SCM address
, SCM args
),
822 "Assigns an address to the socket port @var{socket}.\n"
823 "Generally this only needs to be done for server sockets,\n"
824 "so they know where to look for incoming connections. A socket\n"
825 "without an address will be assigned one automatically when it\n"
826 "starts communicating.\n\n"
827 "The format of @var{address} and @var{ARG} @dots{} depends on the family\n"
829 "For a socket of family @code{AF_UNIX}, only @var{address}\n"
830 "is specified and must \n"
831 "be a string with the filename where the socket is to be created.\n\n"
832 "For a socket of family @code{AF_INET}, @var{address} must be an integer\n"
833 "Internet host address and @var{arg} @dots{} must be a single integer\n"
835 "The values of the following variables can also be used for @var{address}:\n\n"
836 "@defvar INADDR_ANY\n"
837 "Allow connections from any address.\n"
839 "@defvar INADDR_LOOPBACK\n"
840 "The address of the local host using the loopback device.\n"
842 "@defvar INADDR_BROADCAST\n"
843 "The broadcast address on the local network.\n"
845 "@defvar INADDR_NONE\n"
848 "The return value is unspecified.")
849 #define FUNC_NAME s_scm_bind
851 struct sockaddr
*soka
;
855 sock
= SCM_COERCE_OUTPORT (sock
);
856 SCM_VALIDATE_OPFPORT (1, sock
);
857 SCM_VALIDATE_INUM (2, fam
);
858 soka
= scm_fill_sockaddr (SCM_INUM (fam
), address
, &args
, 3, FUNC_NAME
,
860 fd
= SCM_FPORT_FDES (sock
);
861 if (bind (fd
, soka
, size
) == -1)
863 int save_errno
= errno
;
870 return SCM_UNSPECIFIED
;
874 SCM_DEFINE (scm_listen
, "listen", 2, 0, 0,
875 (SCM sock
, SCM backlog
),
876 "This procedure enables @var{socket} to accept connection\n"
877 "requests. @var{backlog} is an integer specifying\n"
878 "the maximum length of the queue for pending connections.\n"
879 "If the queue fills, new clients will fail to connect until the\n"
880 "server calls @code{accept} to accept a connection from the queue.\n\n"
881 "The return value is unspecified.")
882 #define FUNC_NAME s_scm_listen
885 sock
= SCM_COERCE_OUTPORT (sock
);
886 SCM_VALIDATE_OPFPORT (1,sock
);
887 SCM_VALIDATE_INUM (2,backlog
);
888 fd
= SCM_FPORT_FDES (sock
);
889 if (listen (fd
, SCM_INUM (backlog
)) == -1)
891 return SCM_UNSPECIFIED
;
895 /* Put the components of a sockaddr into a new SCM vector. */
897 scm_addr_vector (const struct sockaddr
*address
, const char *proc
)
899 short int fam
= address
->sa_family
;
907 const struct sockaddr_in
*nad
= (struct sockaddr_in
*) address
;
909 result
= scm_c_make_vector (3, SCM_UNSPECIFIED
);
910 ve
= SCM_VELTS (result
);
911 ve
[0] = scm_ulong2num ((unsigned long) fam
);
912 ve
[1] = scm_ulong2num (ntohl (nad
->sin_addr
.s_addr
));
913 ve
[2] = scm_ulong2num ((unsigned long) ntohs (nad
->sin_port
));
919 const struct sockaddr_in6
*nad
= (struct sockaddr_in6
*) address
;
921 result
= scm_c_make_vector (5, SCM_UNSPECIFIED
);
922 ve
= SCM_VELTS (result
);
923 ve
[0] = scm_ulong2num ((unsigned long) fam
);
924 ve
[1] = ipv6_net_to_num (nad
->sin6_addr
.s6_addr
);
925 ve
[2] = scm_ulong2num ((unsigned long) ntohs (nad
->sin6_port
));
926 ve
[3] = scm_ulong2num ((unsigned long) nad
->sin6_flowinfo
);
927 #ifdef HAVE_SIN6_SCOPE_ID
928 ve
[4] = scm_ulong2num ((unsigned long) nad
->sin6_scope_id
);
935 #ifdef HAVE_UNIX_DOMAIN_SOCKETS
938 const struct sockaddr_un
*nad
= (struct sockaddr_un
*) address
;
940 result
= scm_c_make_vector (2, SCM_UNSPECIFIED
);
941 ve
= SCM_VELTS (result
);
942 ve
[0] = scm_ulong2num ((unsigned long) fam
);
943 ve
[1] = scm_makfromstr (nad
->sun_path
,
944 (scm_sizet
) strlen (nad
->sun_path
), 0);
949 scm_misc_error (proc
, "Unrecognised address family: ~A",
950 SCM_LIST1 (SCM_MAKINUM (fam
)));
955 /* calculate the size of a buffer large enough to hold any supported
956 sockaddr type. if the buffer isn't large enough, certain system
957 calls will return a truncated address. */
959 #if defined (HAVE_UNIX_DOMAIN_SOCKETS)
960 #define MAX_SIZE_UN sizeof (struct sockaddr_un)
962 #define MAX_SIZE_UN 0
965 #if defined (AF_INET6)
966 #define MAX_SIZE_IN6 sizeof (struct sockaddr_in6)
968 #define MAX_SIZE_IN6 0
971 #define MAX_ADDR_SIZE max (max (sizeof (struct sockaddr_in), MAX_SIZE_IN6),\
974 SCM_DEFINE (scm_accept
, "accept", 1, 0, 0,
976 "Accepts a connection on a bound, listening socket @var{socket}. If there\n"
977 "are no pending connections in the queue, it waits until\n"
978 "one is available unless the non-blocking option has been set on the\n"
980 "The return value is a\n"
981 "pair in which the CAR is a new socket port for the connection and\n"
982 "the CDR is an object with address information about the client which\n"
983 "initiated the connection.\n\n"
984 "If the address is not available then the CDR will be an empty vector.\n\n"
985 "@var{socket} does not become part of the\n"
986 "connection and will continue to accept new requests.")
987 #define FUNC_NAME s_scm_accept
993 int addr_size
= MAX_ADDR_SIZE
;
994 char max_addr
[MAX_ADDR_SIZE
];
995 struct sockaddr
*addr
= (struct sockaddr
*) max_addr
;
997 sock
= SCM_COERCE_OUTPORT (sock
);
998 SCM_VALIDATE_OPFPORT (1, sock
);
999 fd
= SCM_FPORT_FDES (sock
);
1000 newfd
= accept (fd
, addr
, &addr_size
);
1003 newsock
= SCM_SOCK_FD_TO_PORT (newfd
);
1005 address
= scm_addr_vector (addr
, FUNC_NAME
);
1007 address
= SCM_BOOL_F
;
1009 return scm_cons (newsock
, address
);
1013 SCM_DEFINE (scm_getsockname
, "getsockname", 1, 0, 0,
1015 "Return the address of @var{socket}, in the same form as the\n"
1016 "object returned by @code{accept}. On many systems the address\n"
1017 "of a socket in the @code{AF_FILE} namespace cannot be read.")
1018 #define FUNC_NAME s_scm_getsockname
1022 int addr_size
= MAX_ADDR_SIZE
;
1023 char max_addr
[MAX_ADDR_SIZE
];
1024 struct sockaddr
*addr
= (struct sockaddr
*) max_addr
;
1026 sock
= SCM_COERCE_OUTPORT (sock
);
1027 SCM_VALIDATE_OPFPORT (1,sock
);
1028 fd
= SCM_FPORT_FDES (sock
);
1029 if (getsockname (fd
, addr
, &addr_size
) == -1)
1032 result
= scm_addr_vector (addr
, FUNC_NAME
);
1034 result
= SCM_BOOL_F
;
1039 SCM_DEFINE (scm_getpeername
, "getpeername", 1, 0, 0,
1041 "Return the address of the socket that the socket @var{socket}\n"
1042 "is connected to, in the same form as the object returned by\n"
1043 "@code{accept}. On many systems the address of a socket in the\n"
1044 "@code{AF_FILE} namespace cannot be read.")
1045 #define FUNC_NAME s_scm_getpeername
1049 int addr_size
= MAX_ADDR_SIZE
;
1050 char max_addr
[MAX_ADDR_SIZE
];
1051 struct sockaddr
*addr
= (struct sockaddr
*) max_addr
;
1053 sock
= SCM_COERCE_OUTPORT (sock
);
1054 SCM_VALIDATE_OPFPORT (1,sock
);
1055 fd
= SCM_FPORT_FDES (sock
);
1056 if (getpeername (fd
, addr
, &addr_size
) == -1)
1059 result
= scm_addr_vector (addr
, FUNC_NAME
);
1061 result
= SCM_BOOL_F
;
1066 SCM_DEFINE (scm_recv
, "recv!", 2, 1, 0,
1067 (SCM sock
, SCM buf
, SCM flags
),
1068 "Receives data from the socket port @var{socket}. @var{socket} must already\n"
1069 "be bound to the address from which data is to be received.\n"
1070 "@var{buf} is a string into which\n"
1071 "the data will be written. The size of @var{buf} limits the amount of\n"
1072 "data which can be received: in the case of packet\n"
1073 "protocols, if a packet larger than this limit is encountered then some data\n"
1074 "will be irrevocably lost.\n\n"
1075 "The optional @var{flags} argument is a value or\n"
1076 "bitwise OR of MSG_OOB, MSG_PEEK, MSG_DONTROUTE etc.\n\n"
1077 "The value returned is the number of bytes read from the socket.\n\n"
1078 "Note that the data is read directly from the socket file descriptor:\n"
1079 "any unread buffered port data is ignored.")
1080 #define FUNC_NAME s_scm_recv
1086 SCM_VALIDATE_OPFPORT (1,sock
);
1087 SCM_VALIDATE_STRING (2,buf
);
1088 SCM_VALIDATE_INUM_DEF_COPY (3,flags
,0,flg
);
1089 fd
= SCM_FPORT_FDES (sock
);
1091 SCM_SYSCALL (rv
= recv (fd
, SCM_STRING_CHARS (buf
), SCM_STRING_LENGTH (buf
), flg
));
1095 return SCM_MAKINUM (rv
);
1099 SCM_DEFINE (scm_send
, "send", 2, 1, 0,
1100 (SCM sock
, SCM message
, SCM flags
),
1101 "Transmits the string @var{message} on the socket port @var{socket}. \n"
1102 "@var{socket} must already be bound to a destination address. The\n"
1103 "value returned is the number of bytes transmitted -- it's possible for\n"
1104 "this to be less than the length of @var{message} if the socket is\n"
1105 "set to be non-blocking. The optional @var{flags} argument is a value or\n"
1106 "bitwise OR of MSG_OOB, MSG_PEEK, MSG_DONTROUTE etc.\n\n"
1107 "Note that the data is written directly to the socket file descriptor:\n"
1108 "any unflushed buffered port data is ignored.")
1109 #define FUNC_NAME s_scm_send
1115 sock
= SCM_COERCE_OUTPORT (sock
);
1116 SCM_VALIDATE_OPFPORT (1,sock
);
1117 SCM_VALIDATE_STRING (2, message
);
1118 SCM_VALIDATE_INUM_DEF_COPY (3,flags
,0,flg
);
1119 fd
= SCM_FPORT_FDES (sock
);
1121 SCM_SYSCALL (rv
= send (fd
, SCM_STRING_CHARS (message
), SCM_STRING_LENGTH (message
), flg
));
1124 return SCM_MAKINUM (rv
);
1128 SCM_DEFINE (scm_recvfrom
, "recvfrom!", 2, 3, 0,
1129 (SCM sock
, SCM str
, SCM flags
, SCM start
, SCM end
),
1130 "Return data from the socket port @var{socket} and also\n"
1131 "information about where the data was received from.\n"
1132 "@var{socket} must already be bound to the address from which\n"
1133 "data is to be received. @code{str}, is a string into which the\n"
1134 "data will be written. The size of @var{str} limits the amount\n"
1135 "of data which can be received: in the case of packet protocols,\n"
1136 "if a packet larger than this limit is encountered then some\n"
1137 "data will be irrevocably lost.\n"
1139 "The optional @var{flags} argument is a value or bitwise OR of\n"
1140 "@code{MSG_OOB}, @code{MSG_PEEK}, @code{MSG_DONTROUTE} etc.\n"
1142 "The value returned is a pair: the @emph{car} is the number of\n"
1143 "bytes read from the socket and the @emph{cdr} an address object\n"
1144 "in the same form as returned by @code{accept}.\n"
1146 "The @var{start} and @var{end} arguments specify a substring of\n"
1147 "@var{str} to which the data should be written.\n"
1149 "Note that the data is read directly from the socket file\n"
1150 "descriptor: any unread buffered port data is ignored.")
1151 #define FUNC_NAME s_scm_recvfrom
1160 int addr_size
= MAX_ADDR_SIZE
;
1161 char max_addr
[MAX_ADDR_SIZE
];
1162 struct sockaddr
*addr
= (struct sockaddr
*) max_addr
;
1164 SCM_VALIDATE_OPFPORT (1,sock
);
1165 fd
= SCM_FPORT_FDES (sock
);
1166 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, str
, buf
, 4, start
, offset
,
1168 if (SCM_UNBNDP (flags
))
1171 SCM_VALIDATE_ULONG_COPY (3, flags
, flg
);
1173 /* recvfrom will not necessarily return an address. usually nothing
1174 is returned for stream sockets. */
1175 addr
->sa_family
= AF_UNSPEC
;
1176 SCM_SYSCALL (rv
= recvfrom (fd
, buf
+ offset
,
1181 if (addr_size
> 0 && addr
->sa_family
!= AF_UNSPEC
)
1182 address
= scm_addr_vector (addr
, FUNC_NAME
);
1184 address
= SCM_BOOL_F
;
1186 return scm_cons (SCM_MAKINUM (rv
), address
);
1190 SCM_DEFINE (scm_sendto
, "sendto", 4, 0, 1,
1191 (SCM sock
, SCM message
, SCM fam
, SCM address
, SCM args_and_flags
),
1192 "Transmits the string @var{message} on the socket port @var{socket}. The\n"
1193 "destination address is specified using the @var{family}, @var{address} and\n"
1194 "@var{arg} arguments, in a similar way to the @code{connect}\n"
1196 "value returned is the number of bytes transmitted -- it's possible for\n"
1197 "this to be less than the length of @var{message} if the socket is\n"
1198 "set to be non-blocking. The optional @var{flags} argument is a value or\n"
1199 "bitwise OR of MSG_OOB, MSG_PEEK, MSG_DONTROUTE etc.\n\n"
1200 "Note that the data is written directly to the socket file descriptor:\n"
1201 "any unflushed buffered port data is ignored.")
1202 #define FUNC_NAME s_scm_sendto
1207 struct sockaddr
*soka
;
1210 sock
= SCM_COERCE_OUTPORT (sock
);
1211 SCM_VALIDATE_FPORT (1,sock
);
1212 SCM_VALIDATE_STRING (2, message
);
1213 SCM_VALIDATE_INUM (3,fam
);
1214 fd
= SCM_FPORT_FDES (sock
);
1215 soka
= scm_fill_sockaddr (SCM_INUM (fam
), address
, &args_and_flags
, 4,
1217 if (SCM_NULLP (args_and_flags
))
1221 SCM_VALIDATE_CONS (5,args_and_flags
);
1222 flg
= SCM_NUM2ULONG (5, SCM_CAR (args_and_flags
));
1224 SCM_SYSCALL (rv
= sendto (fd
, SCM_STRING_CHARS (message
),
1225 SCM_STRING_LENGTH (message
),
1229 int save_errno
= errno
;
1235 return SCM_MAKINUM (rv
);
1244 /* protocol families. */
1246 scm_sysintern ("AF_UNSPEC", SCM_MAKINUM (AF_UNSPEC
));
1249 scm_sysintern ("AF_UNIX", SCM_MAKINUM (AF_UNIX
));
1252 scm_sysintern ("AF_INET", SCM_MAKINUM (AF_INET
));
1255 scm_sysintern ("AF_INET6", SCM_MAKINUM (AF_INET6
));
1259 scm_sysintern ("PF_UNSPEC", SCM_MAKINUM (PF_UNSPEC
));
1262 scm_sysintern ("PF_UNIX", SCM_MAKINUM (PF_UNIX
));
1265 scm_sysintern ("PF_INET", SCM_MAKINUM (PF_INET
));
1268 scm_sysintern ("PF_INET6", SCM_MAKINUM (PF_INET6
));
1271 /* standard addresses. */
1273 scm_sysintern ("INADDR_ANY", scm_ulong2num (INADDR_ANY
));
1275 #ifdef INADDR_BROADCAST
1276 scm_sysintern ("INADDR_BROADCAST", scm_ulong2num (INADDR_BROADCAST
));
1279 scm_sysintern ("INADDR_NONE", scm_ulong2num (INADDR_NONE
));
1281 #ifdef INADDR_LOOPBACK
1282 scm_sysintern ("INADDR_LOOPBACK", scm_ulong2num (INADDR_LOOPBACK
));
1287 scm_sysintern ("SOCK_STREAM", SCM_MAKINUM (SOCK_STREAM
));
1290 scm_sysintern ("SOCK_DGRAM", SCM_MAKINUM (SOCK_DGRAM
));
1293 scm_sysintern ("SOCK_RAW", SCM_MAKINUM (SOCK_RAW
));
1296 /* setsockopt level. */
1298 scm_sysintern ("SOL_SOCKET", SCM_MAKINUM (SOL_SOCKET
));
1301 scm_sysintern ("SOL_IP", SCM_MAKINUM (SOL_IP
));
1304 scm_sysintern ("SOL_TCP", SCM_MAKINUM (SOL_TCP
));
1307 scm_sysintern ("SOL_UDP", SCM_MAKINUM (SOL_UDP
));
1310 /* setsockopt names. */
1312 scm_sysintern ("SO_DEBUG", SCM_MAKINUM (SO_DEBUG
));
1315 scm_sysintern ("SO_REUSEADDR", SCM_MAKINUM (SO_REUSEADDR
));
1318 scm_sysintern ("SO_STYLE", SCM_MAKINUM (SO_STYLE
));
1321 scm_sysintern ("SO_TYPE", SCM_MAKINUM (SO_TYPE
));
1324 scm_sysintern ("SO_ERROR", SCM_MAKINUM (SO_ERROR
));
1327 scm_sysintern ("SO_DONTROUTE", SCM_MAKINUM (SO_DONTROUTE
));
1330 scm_sysintern ("SO_BROADCAST", SCM_MAKINUM (SO_BROADCAST
));
1333 scm_sysintern ("SO_SNDBUF", SCM_MAKINUM (SO_SNDBUF
));
1336 scm_sysintern ("SO_RCVBUF", SCM_MAKINUM (SO_RCVBUF
));
1339 scm_sysintern ("SO_KEEPALIVE", SCM_MAKINUM (SO_KEEPALIVE
));
1342 scm_sysintern ("SO_OOBINLINE", SCM_MAKINUM (SO_OOBINLINE
));
1345 scm_sysintern ("SO_NO_CHECK", SCM_MAKINUM (SO_NO_CHECK
));
1348 scm_sysintern ("SO_PRIORITY", SCM_MAKINUM (SO_PRIORITY
));
1351 scm_sysintern ("SO_LINGER", SCM_MAKINUM (SO_LINGER
));
1354 /* recv/send options. */
1356 scm_sysintern ("MSG_OOB", SCM_MAKINUM (MSG_OOB
));
1359 scm_sysintern ("MSG_PEEK", SCM_MAKINUM (MSG_PEEK
));
1361 #ifdef MSG_DONTROUTE
1362 scm_sysintern ("MSG_DONTROUTE", SCM_MAKINUM (MSG_DONTROUTE
));
1365 scm_add_feature ("socket");
1367 #ifndef SCM_MAGIC_SNARFER
1368 #include "libguile/socket.x"