1 /* Copyright (C) 1996,1997,1998,2000,2001, 2002, 2003, 2004 Free Software Foundation, Inc.
3 * This library is free software; you can redistribute it and/or
4 * modify it under the terms of the GNU Lesser General Public
5 * License as published by the Free Software Foundation; either
6 * version 2.1 of the License, or (at your option) any later version.
8 * This library 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 GNU
11 * Lesser General Public License for more details.
13 * You should have received a copy of the GNU Lesser General Public
14 * License along with this library; if not, write to the Free Software
15 * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
28 #include "libguile/_scm.h"
29 #include "libguile/unif.h"
30 #include "libguile/feature.h"
31 #include "libguile/fports.h"
32 #include "libguile/strings.h"
33 #include "libguile/vectors.h"
34 #include "libguile/dynwind.h"
36 #include "libguile/validate.h"
37 #include "libguile/socket.h"
40 #include "win32-socket.h"
52 #include <sys/types.h>
53 #ifdef HAVE_WINSOCK2_H
56 #include <sys/socket.h>
57 #ifdef HAVE_UNIX_DOMAIN_SOCKETS
60 #include <netinet/in.h>
62 #include <arpa/inet.h>
65 #if defined (HAVE_UNIX_DOMAIN_SOCKETS) && !defined (SUN_LEN)
66 #define SUN_LEN(ptr) ((size_t) (((struct sockaddr_un *) 0)->sun_path) \
67 + strlen ((ptr)->sun_path))
70 /* we are not currently using socklen_t. it's not defined on all systems,
71 so would need to be checked by configure. in the meantime, plain
72 int is the best alternative. */
76 SCM_DEFINE (scm_htons
, "htons", 1, 0, 0,
78 "Convert a 16 bit quantity from host to network byte ordering.\n"
79 "@var{value} is packed into 2 bytes, which are then converted\n"
80 "and returned as a new integer.")
81 #define FUNC_NAME s_scm_htons
83 return scm_from_ushort (htons (scm_to_ushort (value
)));
87 SCM_DEFINE (scm_ntohs
, "ntohs", 1, 0, 0,
89 "Convert a 16 bit quantity from network to host byte ordering.\n"
90 "@var{value} is packed into 2 bytes, which are then converted\n"
91 "and returned as a new integer.")
92 #define FUNC_NAME s_scm_ntohs
94 return scm_from_ushort (ntohs (scm_to_ushort (value
)));
98 SCM_DEFINE (scm_htonl
, "htonl", 1, 0, 0,
100 "Convert a 32 bit quantity from host to network byte ordering.\n"
101 "@var{value} is packed into 4 bytes, which are then converted\n"
102 "and returned as a new integer.")
103 #define FUNC_NAME s_scm_htonl
105 scm_t_uint32 c_in
= SCM_NUM2ULONG (1, value
);
107 return scm_from_ulong (htonl (c_in
));
111 SCM_DEFINE (scm_ntohl
, "ntohl", 1, 0, 0,
113 "Convert a 32 bit quantity from network to host byte ordering.\n"
114 "@var{value} is packed into 4 bytes, which are then converted\n"
115 "and returned as a new integer.")
116 #define FUNC_NAME s_scm_ntohl
118 scm_t_uint32 c_in
= SCM_NUM2ULONG (1, value
);
120 return scm_from_ulong (ntohl (c_in
));
124 #ifndef HAVE_INET_ATON
125 /* for our definition in inet_aton.c, not usually needed. */
126 extern int inet_aton ();
129 SCM_DEFINE (scm_inet_aton
, "inet-aton", 1, 0, 0,
131 "Convert an IPv4 Internet address from printable string\n"
132 "(dotted decimal notation) to an integer. E.g.,\n\n"
134 "(inet-aton \"127.0.0.1\") @result{} 2130706433\n"
136 #define FUNC_NAME s_scm_inet_aton
142 c_address
= scm_to_locale_string (address
);
143 rv
= inet_aton (c_address
, &soka
);
146 SCM_MISC_ERROR ("bad address", SCM_EOL
);
147 return scm_from_ulong (ntohl (soka
.s_addr
));
152 SCM_DEFINE (scm_inet_ntoa
, "inet-ntoa", 1, 0, 0,
154 "Convert an IPv4 Internet address to a printable\n"
155 "(dotted decimal notation) string. E.g.,\n\n"
157 "(inet-ntoa 2130706433) @result{} \"127.0.0.1\"\n"
159 #define FUNC_NAME s_scm_inet_ntoa
164 addr
.s_addr
= htonl (SCM_NUM2ULONG (1, inetid
));
165 s
= inet_ntoa (addr
);
166 answer
= scm_from_locale_string (s
);
171 #ifdef HAVE_INET_NETOF
172 SCM_DEFINE (scm_inet_netof
, "inet-netof", 1, 0, 0,
174 "Return the network number part of the given IPv4\n"
175 "Internet address. E.g.,\n\n"
177 "(inet-netof 2130706433) @result{} 127\n"
179 #define FUNC_NAME s_scm_inet_netof
182 addr
.s_addr
= htonl (SCM_NUM2ULONG (1, address
));
183 return scm_from_ulong (inet_netof (addr
));
188 #ifdef HAVE_INET_LNAOF
189 SCM_DEFINE (scm_lnaof
, "inet-lnaof", 1, 0, 0,
191 "Return the local-address-with-network part of the given\n"
192 "IPv4 Internet address, using the obsolete class A/B/C system.\n"
195 "(inet-lnaof 2130706433) @result{} 1\n"
197 #define FUNC_NAME s_scm_lnaof
200 addr
.s_addr
= htonl (SCM_NUM2ULONG (1, address
));
201 return scm_from_ulong (inet_lnaof (addr
));
206 #ifdef HAVE_INET_MAKEADDR
207 SCM_DEFINE (scm_inet_makeaddr
, "inet-makeaddr", 2, 0, 0,
209 "Make an IPv4 Internet address by combining the network number\n"
210 "@var{net} with the local-address-within-network number\n"
211 "@var{lna}. E.g.,\n\n"
213 "(inet-makeaddr 127 1) @result{} 2130706433\n"
215 #define FUNC_NAME s_scm_inet_makeaddr
218 unsigned long netnum
;
219 unsigned long lnanum
;
221 netnum
= SCM_NUM2ULONG (1, net
);
222 lnanum
= SCM_NUM2ULONG (2, lna
);
223 addr
= inet_makeaddr (netnum
, lnanum
);
224 return scm_from_ulong (ntohl (addr
.s_addr
));
231 /* flip a 128 bit IPv6 address between host and network order. */
232 #ifdef WORDS_BIGENDIAN
233 #define FLIP_NET_HOST_128(addr)
235 #define FLIP_NET_HOST_128(addr)\
239 for (i = 0; i < 8; i++)\
241 scm_t_uint8 c = (addr)[i];\
243 (addr)[i] = (addr)[15 - i];\
249 #ifdef WORDS_BIGENDIAN
250 #define FLIPCPY_NET_HOST_128(dest, src) memcpy (dest, src, 16)
252 #define FLIPCPY_NET_HOST_128(dest, src) \
254 const scm_t_uint8 *tmp_srcp = (src) + 15; \
255 scm_t_uint8 *tmp_destp = (dest); \
258 *tmp_destp++ = *tmp_srcp--; \
259 } while (tmp_srcp != (src)); \
264 #if (SIZEOF_SCM_T_BITS * SCM_CHAR_BIT) > 128
265 #error "Assumption that scm_t_bits <= 128 bits has been violated."
268 #if (SIZEOF_UNSIGNED_LONG * SCM_CHAR_BIT) > 128
269 #error "Assumption that unsigned long <= 128 bits has been violated."
272 #if (SIZEOF_UNSIGNED_LONG_LONG * SCM_CHAR_BIT) > 128
273 #error "Assumption that unsigned long long <= 128 bits has been violated."
276 /* convert a 128 bit IPv6 address in network order to a host ordered
279 scm_from_ipv6 (const scm_t_uint8
*src
)
281 SCM result
= scm_i_mkbig ();
282 mpz_import (SCM_I_BIG_MPZ (result
),
284 1, /* big-endian chunk ordering */
285 16, /* chunks are 16 bytes long */
286 1, /* big-endian byte ordering */
287 0, /* "nails" -- leading unused bits per chunk */
289 return scm_i_normbig (result
);
292 /* convert a host ordered SCM integer to a 128 bit IPv6 address in
295 scm_to_ipv6 (scm_t_uint8 dst
[16], SCM src
)
297 if (SCM_I_INUMP (src
))
299 scm_t_signed_bits n
= SCM_I_INUM (src
);
301 scm_out_of_range (NULL
, src
);
302 #ifdef WORDS_BIGENDIAN
303 memset (dst
, 0, 16 - sizeof (scm_t_signed_bits
));
304 memcpy (dst
+ (16 - sizeof (scm_t_signed_bits
)),
306 sizeof (scm_t_signed_bits
));
308 memset (dst
+ sizeof (scm_t_signed_bits
),
310 16 - sizeof (scm_t_signed_bits
));
311 /* FIXME: this pair of ops is kinda wasteful -- should rewrite as
312 a single loop perhaps, similar to the handling of bignums. */
313 memcpy (dst
, &n
, sizeof (scm_t_signed_bits
));
314 FLIP_NET_HOST_128 (dst
);
317 else if (SCM_BIGP (src
))
321 if ((mpz_sgn (SCM_I_BIG_MPZ (src
)) < 0)
322 || mpz_sizeinbase (SCM_I_BIG_MPZ (src
), 2) > 128)
323 scm_out_of_range (NULL
, src
);
328 1, /* big-endian chunk ordering */
329 16, /* chunks are 16 bytes long */
330 1, /* big-endian byte ordering */
331 0, /* "nails" -- leading unused bits per chunk */
332 SCM_I_BIG_MPZ (src
));
333 scm_remember_upto_here_1 (src
);
336 scm_wrong_type_arg (NULL
, 0, src
);
339 #ifdef HAVE_INET_PTON
340 SCM_DEFINE (scm_inet_pton
, "inet-pton", 2, 0, 0,
341 (SCM family
, SCM address
),
342 "Convert a string containing a printable network address to\n"
343 "an integer address. Note that unlike the C version of this\n"
345 "the result is an integer with normal host byte ordering.\n"
346 "@var{family} can be @code{AF_INET} or @code{AF_INET6}. E.g.,\n\n"
348 "(inet-pton AF_INET \"127.0.0.1\") @result{} 2130706433\n"
349 "(inet-pton AF_INET6 \"::1\") @result{} 1\n"
351 #define FUNC_NAME s_scm_inet_pton
358 af
= scm_to_int (family
);
359 SCM_ASSERT_RANGE (1, family
, af
== AF_INET
|| af
== AF_INET6
);
360 src
= scm_to_locale_string (address
);
361 rv
= inet_pton (af
, src
, dst
);
368 SCM_MISC_ERROR ("Bad address", SCM_EOL
);
370 return scm_from_ulong (ntohl (*(scm_t_uint32
*) dst
));
372 return scm_from_ipv6 ((char *) dst
);
377 #ifdef HAVE_INET_NTOP
378 SCM_DEFINE (scm_inet_ntop
, "inet-ntop", 2, 0, 0,
379 (SCM family
, SCM address
),
380 "Convert a network address into a printable string.\n"
381 "Note that unlike the C version of this function,\n"
382 "the input is an integer with normal host byte ordering.\n"
383 "@var{family} can be @code{AF_INET} or @code{AF_INET6}. E.g.,\n\n"
385 "(inet-ntop AF_INET 2130706433) @result{} \"127.0.0.1\"\n"
386 "(inet-ntop AF_INET6 (- (expt 2 128) 1)) @result{}\n"
387 "ffff:ffff:ffff:ffff:ffff:ffff:ffff:ffff\n"
389 #define FUNC_NAME s_scm_inet_ntop
392 #ifdef INET6_ADDRSTRLEN
393 char dst
[INET6_ADDRSTRLEN
];
399 af
= scm_to_int (family
);
400 SCM_ASSERT_RANGE (1, family
, af
== AF_INET
|| af
== AF_INET6
);
402 *(scm_t_uint32
*) addr6
= htonl (SCM_NUM2ULONG (2, address
));
404 scm_to_ipv6 (addr6
, address
);
405 if (inet_ntop (af
, &addr6
, dst
, sizeof dst
) == NULL
)
407 return scm_from_locale_string (dst
);
412 #endif /* HAVE_IPV6 */
414 SCM_SYMBOL (sym_socket
, "socket");
416 #define SCM_SOCK_FD_TO_PORT(fd) scm_fdes_to_port (fd, "r+0", sym_socket)
418 SCM_DEFINE (scm_socket
, "socket", 3, 0, 0,
419 (SCM family
, SCM style
, SCM proto
),
420 "Return a new socket port of the type specified by @var{family},\n"
421 "@var{style} and @var{proto}. All three parameters are\n"
422 "integers. Supported values for @var{family} are\n"
423 "@code{AF_UNIX}, @code{AF_INET} and @code{AF_INET6}.\n"
424 "Typical values for @var{style} are @code{SOCK_STREAM},\n"
425 "@code{SOCK_DGRAM} and @code{SOCK_RAW}.\n\n"
426 "@var{proto} can be obtained from a protocol name using\n"
427 "@code{getprotobyname}. A value of zero specifies the default\n"
428 "protocol, which is usually right.\n\n"
429 "A single socket port cannot by used for communication until it\n"
430 "has been connected to another socket.")
431 #define FUNC_NAME s_scm_socket
435 fd
= socket (scm_to_int (family
),
440 return SCM_SOCK_FD_TO_PORT (fd
);
444 #ifdef HAVE_SOCKETPAIR
445 SCM_DEFINE (scm_socketpair
, "socketpair", 3, 0, 0,
446 (SCM family
, SCM style
, SCM proto
),
447 "Return a pair of connected (but unnamed) socket ports of the\n"
448 "type specified by @var{family}, @var{style} and @var{proto}.\n"
449 "Many systems support only socket pairs of the @code{AF_UNIX}\n"
450 "family. Zero is likely to be the only meaningful value for\n"
452 #define FUNC_NAME s_scm_socketpair
457 fam
= scm_to_int (family
);
459 if (socketpair (fam
, scm_to_int (style
), scm_to_int (proto
), fd
) == -1)
462 return scm_cons (SCM_SOCK_FD_TO_PORT (fd
[0]), SCM_SOCK_FD_TO_PORT (fd
[1]));
467 SCM_DEFINE (scm_getsockopt
, "getsockopt", 3, 0, 0,
468 (SCM sock
, SCM level
, SCM optname
),
469 "Return the value of a particular socket option for the socket\n"
470 "port @var{sock}. @var{level} is an integer code for type of\n"
471 "option being requested, e.g., @code{SOL_SOCKET} for\n"
472 "socket-level options. @var{optname} is an integer code for the\n"
473 "option required and should be specified using one of the\n"
474 "symbols @code{SO_DEBUG}, @code{SO_REUSEADDR} etc.\n\n"
475 "The returned value is typically an integer but @code{SO_LINGER}\n"
476 "returns a pair of integers.")
477 #define FUNC_NAME s_scm_getsockopt
480 /* size of optval is the largest supported option. */
481 #ifdef HAVE_STRUCT_LINGER
482 char optval
[sizeof (struct linger
)];
483 int optlen
= sizeof (struct linger
);
485 char optval
[sizeof (size_t)];
486 int optlen
= sizeof (size_t);
491 sock
= SCM_COERCE_OUTPORT (sock
);
492 SCM_VALIDATE_OPFPORT (1, sock
);
493 ilevel
= scm_to_int (level
);
494 ioptname
= scm_to_int (optname
);
496 fd
= SCM_FPORT_FDES (sock
);
497 if (getsockopt (fd
, ilevel
, ioptname
, (void *) optval
, &optlen
) == -1)
500 if (ilevel
== SOL_SOCKET
)
503 if (ioptname
== SO_LINGER
)
505 #ifdef HAVE_STRUCT_LINGER
506 struct linger
*ling
= (struct linger
*) optval
;
508 return scm_cons (scm_from_long (ling
->l_onoff
),
509 scm_from_long (ling
->l_linger
));
511 return scm_cons (scm_from_long (*(int *) optval
),
519 || ioptname
== SO_SNDBUF
522 || ioptname
== SO_RCVBUF
526 return scm_from_size_t (*(size_t *) optval
);
529 return scm_from_int (*(int *) optval
);
533 SCM_DEFINE (scm_setsockopt
, "setsockopt", 4, 0, 0,
534 (SCM sock
, SCM level
, SCM optname
, SCM value
),
535 "Set the value of a particular socket option for the socket\n"
536 "port @var{sock}. @var{level} is an integer code for type of option\n"
537 "being set, e.g., @code{SOL_SOCKET} for socket-level options.\n"
538 "@var{optname} is an\n"
539 "integer code for the option to set and should be specified using one of\n"
540 "the symbols @code{SO_DEBUG}, @code{SO_REUSEADDR} etc.\n"
541 "@var{value} is the value to which the option should be set. For\n"
542 "most options this must be an integer, but for @code{SO_LINGER} it must\n"
544 "The return value is unspecified.")
545 #define FUNC_NAME s_scm_setsockopt
550 #ifdef HAVE_STRUCT_LINGER
551 struct linger opt_linger
;
553 struct ip_mreq opt_mreq
;
555 const void *optval
= NULL
;
556 socklen_t optlen
= 0;
558 int ilevel
, ioptname
;
560 sock
= SCM_COERCE_OUTPORT (sock
);
562 SCM_VALIDATE_OPFPORT (1, sock
);
563 ilevel
= scm_to_int (level
);
564 ioptname
= scm_to_int (optname
);
566 fd
= SCM_FPORT_FDES (sock
);
568 if (ilevel
== SOL_SOCKET
)
571 if (ioptname
== SO_LINGER
)
573 #ifdef HAVE_STRUCT_LINGER
574 SCM_ASSERT (scm_is_pair (value
), value
, SCM_ARG4
, FUNC_NAME
);
575 opt_linger
.l_onoff
= scm_to_int (SCM_CAR (value
));
576 opt_linger
.l_linger
= scm_to_int (SCM_CDR (value
));
577 optlen
= sizeof (struct linger
);
578 optval
= &opt_linger
;
580 SCM_ASSERT (scm_is_pair (value
), value
, SCM_ARG4
, FUNC_NAME
);
581 opt_int
= scm_to_int (SCM_CAR (value
));
582 /* timeout is ignored, but may as well validate it. */
583 scm_to_int (SCM_CDR (value
));
584 optlen
= sizeof (int);
592 || ioptname
== SO_SNDBUF
595 || ioptname
== SO_RCVBUF
599 opt_int
= scm_to_int (value
);
600 optlen
= sizeof (size_t);
605 if (ilevel
== IPPROTO_IP
&&
606 (ioptname
== IP_ADD_MEMBERSHIP
|| ioptname
== IP_DROP_MEMBERSHIP
))
608 /* Fourth argument must be a pair of addresses. */
609 SCM_ASSERT (scm_is_pair (value
), value
, SCM_ARG4
, FUNC_NAME
);
610 opt_mreq
.imr_multiaddr
.s_addr
= htonl (scm_to_ulong (SCM_CAR (value
)));
611 opt_mreq
.imr_interface
.s_addr
= htonl (scm_to_ulong (SCM_CDR (value
)));
612 optlen
= sizeof (opt_mreq
);
618 /* Most options take an int. */
619 opt_int
= scm_to_int (value
);
620 optlen
= sizeof (int);
624 if (setsockopt (fd
, ilevel
, ioptname
, optval
, optlen
) == -1)
626 return SCM_UNSPECIFIED
;
630 SCM_DEFINE (scm_shutdown
, "shutdown", 2, 0, 0,
632 "Sockets can be closed simply by using @code{close-port}. The\n"
633 "@code{shutdown} procedure allows reception or transmission on a\n"
634 "connection to be shut down individually, according to the parameter\n"
638 "Stop receiving data for this socket. If further data arrives, reject it.\n"
640 "Stop trying to transmit data from this socket. Discard any\n"
641 "data waiting to be sent. Stop looking for acknowledgement of\n"
642 "data already sent; don't retransmit it if it is lost.\n"
644 "Stop both reception and transmission.\n"
646 "The return value is unspecified.")
647 #define FUNC_NAME s_scm_shutdown
650 sock
= SCM_COERCE_OUTPORT (sock
);
651 SCM_VALIDATE_OPFPORT (1, sock
);
652 fd
= SCM_FPORT_FDES (sock
);
653 if (shutdown (fd
, scm_to_signed_integer (how
, 0, 2)) == -1)
655 return SCM_UNSPECIFIED
;
659 /* convert fam/address/args into a sockaddr of the appropriate type.
660 args is modified by removing the arguments actually used.
661 which_arg and proc are used when reporting errors:
662 which_arg is the position of address in the original argument list.
663 proc is the name of the original procedure.
664 size returns the size of the structure allocated. */
666 static struct sockaddr
*
667 scm_fill_sockaddr (int fam
, SCM address
, SCM
*args
, int which_arg
,
668 const char *proc
, int *size
)
669 #define FUNC_NAME proc
675 struct sockaddr_in
*soka
;
679 SCM_VALIDATE_ULONG_COPY (which_arg
, address
, addr
);
680 SCM_VALIDATE_CONS (which_arg
+ 1, *args
);
681 port
= scm_to_int (SCM_CAR (*args
));
682 *args
= SCM_CDR (*args
);
683 soka
= (struct sockaddr_in
*) scm_malloc (sizeof (struct sockaddr_in
));
685 scm_memory_error (proc
);
686 #if HAVE_STRUCT_SOCKADDR_SIN_LEN
687 soka
->sin_len
= sizeof (struct sockaddr_in
);
689 soka
->sin_family
= AF_INET
;
690 soka
->sin_addr
.s_addr
= htonl (addr
);
691 soka
->sin_port
= htons (port
);
692 *size
= sizeof (struct sockaddr_in
);
693 return (struct sockaddr
*) soka
;
700 struct sockaddr_in6
*soka
;
701 unsigned long flowinfo
= 0;
702 unsigned long scope_id
= 0;
704 SCM_VALIDATE_CONS (which_arg
+ 1, *args
);
705 port
= scm_to_int (SCM_CAR (*args
));
706 *args
= SCM_CDR (*args
);
707 if (scm_is_pair (*args
))
709 SCM_VALIDATE_ULONG_COPY (which_arg
+ 2, SCM_CAR (*args
), flowinfo
);
710 *args
= SCM_CDR (*args
);
711 if (scm_is_pair (*args
))
713 SCM_VALIDATE_ULONG_COPY (which_arg
+ 3, SCM_CAR (*args
),
715 *args
= SCM_CDR (*args
);
718 soka
= (struct sockaddr_in6
*) scm_malloc (sizeof (struct sockaddr_in6
));
720 scm_memory_error (proc
);
721 #if HAVE_STRUCT_SOCKADDR_IN6_SIN6_LEN
722 soka
->sin6_len
= sizeof (struct sockaddr_in6
);
724 soka
->sin6_family
= AF_INET6
;
725 scm_to_ipv6 (soka
->sin6_addr
.s6_addr
, address
);
726 soka
->sin6_port
= htons (port
);
727 soka
->sin6_flowinfo
= flowinfo
;
728 #ifdef HAVE_SIN6_SCOPE_ID
729 soka
->sin6_scope_id
= scope_id
;
731 *size
= sizeof (struct sockaddr_in6
);
732 return (struct sockaddr
*) soka
;
735 #ifdef HAVE_UNIX_DOMAIN_SOCKETS
738 struct sockaddr_un
*soka
;
744 c_address
= scm_to_locale_string (address
);
745 scm_frame_free (c_address
);
747 /* the static buffer size in sockaddr_un seems to be arbitrary
748 and not necessarily a hard limit. e.g., the glibc manual
749 suggests it may be possible to declare it size 0. let's
750 ignore it. if the O/S doesn't like the size it will cause
751 connect/bind etc., to fail. sun_path is always the last
752 member of the structure. */
753 addr_size
= sizeof (struct sockaddr_un
)
754 + max (0, strlen (c_address
) + 1 - (sizeof soka
->sun_path
));
755 soka
= (struct sockaddr_un
*) scm_malloc (addr_size
);
756 memset (soka
, 0, addr_size
); /* for sun_len: see sin_len above. */
757 soka
->sun_family
= AF_UNIX
;
758 strcpy (soka
->sun_path
, c_address
);
759 *size
= SUN_LEN (soka
);
762 return (struct sockaddr
*) soka
;
766 scm_out_of_range (proc
, scm_from_int (fam
));
771 SCM_DEFINE (scm_connect
, "connect", 3, 0, 1,
772 (SCM sock
, SCM fam
, SCM address
, SCM args
),
773 "Initiate a connection from a socket using a specified address\n"
774 "family to the address\n"
775 "specified by @var{address} and possibly @var{args}.\n"
776 "The format required for @var{address}\n"
777 "and @var{args} depends on the family of the socket.\n\n"
778 "For a socket of family @code{AF_UNIX},\n"
779 "only @var{address} is specified and must be a string with the\n"
780 "filename where the socket is to be created.\n\n"
781 "For a socket of family @code{AF_INET},\n"
782 "@var{address} must be an integer IPv4 host address and\n"
783 "@var{args} must be a single integer port number.\n\n"
784 "For a socket of family @code{AF_INET6},\n"
785 "@var{address} must be an integer IPv6 host address and\n"
786 "@var{args} may be up to three integers:\n"
787 "port [flowinfo] [scope_id],\n"
788 "where flowinfo and scope_id default to zero.\n\n"
789 "The return value is unspecified.")
790 #define FUNC_NAME s_scm_connect
793 struct sockaddr
*soka
;
796 sock
= SCM_COERCE_OUTPORT (sock
);
797 SCM_VALIDATE_OPFPORT (1, sock
);
798 fd
= SCM_FPORT_FDES (sock
);
799 soka
= scm_fill_sockaddr (scm_to_int (fam
), address
, &args
, 3, FUNC_NAME
,
801 if (connect (fd
, soka
, size
) == -1)
803 int save_errno
= errno
;
810 return SCM_UNSPECIFIED
;
814 SCM_DEFINE (scm_bind
, "bind", 3, 0, 1,
815 (SCM sock
, SCM fam
, SCM address
, SCM args
),
816 "Assign an address to the socket port @var{sock}.\n"
817 "Generally this only needs to be done for server sockets,\n"
818 "so they know where to look for incoming connections. A socket\n"
819 "without an address will be assigned one automatically when it\n"
820 "starts communicating.\n\n"
821 "The format of @var{address} and @var{args} depends\n"
822 "on the family of the socket.\n\n"
823 "For a socket of family @code{AF_UNIX}, only @var{address}\n"
824 "is specified and must be a string with the filename where\n"
825 "the socket is to be created.\n\n"
826 "For a socket of family @code{AF_INET}, @var{address}\n"
827 "must be an integer IPv4 address and @var{args}\n"
828 "must be a single integer port number.\n\n"
829 "The values of the following variables can also be used for\n"
831 "@defvar INADDR_ANY\n"
832 "Allow connections from any address.\n"
834 "@defvar INADDR_LOOPBACK\n"
835 "The address of the local host using the loopback device.\n"
837 "@defvar INADDR_BROADCAST\n"
838 "The broadcast address on the local network.\n"
840 "@defvar INADDR_NONE\n"
843 "For a socket of family @code{AF_INET6}, @var{address}\n"
844 "must be an integer IPv6 address and @var{args}\n"
845 "may be up to three integers:\n"
846 "port [flowinfo] [scope_id],\n"
847 "where flowinfo and scope_id default to zero.\n\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 soka
= scm_fill_sockaddr (scm_to_int (fam
), address
, &args
, 3, FUNC_NAME
,
859 fd
= SCM_FPORT_FDES (sock
);
860 if (bind (fd
, soka
, size
) == -1)
862 int save_errno
= errno
;
869 return SCM_UNSPECIFIED
;
873 SCM_DEFINE (scm_listen
, "listen", 2, 0, 0,
874 (SCM sock
, SCM backlog
),
875 "Enable @var{sock} to accept connection\n"
876 "requests. @var{backlog} is an integer specifying\n"
877 "the maximum length of the queue for pending connections.\n"
878 "If the queue fills, new clients will fail to connect until\n"
879 "the server calls @code{accept} to accept a connection from\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 fd
= SCM_FPORT_FDES (sock
);
888 if (listen (fd
, scm_to_int (backlog
)) == -1)
890 return SCM_UNSPECIFIED
;
894 /* Put the components of a sockaddr into a new SCM vector. */
896 scm_addr_vector (const struct sockaddr
*address
, int addr_size
,
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
);
911 SCM_SIMPLE_VECTOR_SET(result
, 0,
912 scm_from_short (fam
));
913 SCM_SIMPLE_VECTOR_SET(result
, 1,
914 scm_from_ulong (ntohl (nad
->sin_addr
.s_addr
)));
915 SCM_SIMPLE_VECTOR_SET(result
, 2,
916 scm_from_ushort (ntohs (nad
->sin_port
)));
922 const struct sockaddr_in6
*nad
= (struct sockaddr_in6
*) address
;
924 result
= scm_c_make_vector (5, SCM_UNSPECIFIED
);
925 SCM_SIMPLE_VECTOR_SET(result
, 0, scm_from_short (fam
));
926 SCM_SIMPLE_VECTOR_SET(result
, 1, scm_from_ipv6 (nad
->sin6_addr
.s6_addr
));
927 SCM_SIMPLE_VECTOR_SET(result
, 2, scm_from_ushort (ntohs (nad
->sin6_port
)));
928 SCM_SIMPLE_VECTOR_SET(result
, 3, scm_from_uint32 (nad
->sin6_flowinfo
));
929 #ifdef HAVE_SIN6_SCOPE_ID
930 SCM_SIMPLE_VECTOR_SET(result
, 4, scm_from_ulong (nad
->sin6_scope_id
));
932 SCM_SIMPLE_VECTOR_SET(result
, 4, SCM_INUM0
);
937 #ifdef HAVE_UNIX_DOMAIN_SOCKETS
940 const struct sockaddr_un
*nad
= (struct sockaddr_un
*) address
;
942 result
= scm_c_make_vector (2, SCM_UNSPECIFIED
);
944 SCM_SIMPLE_VECTOR_SET(result
, 0, scm_from_short (fam
));
945 /* When addr_size is not enough to cover sun_path, do not try
947 if (addr_size
<= offsetof (struct sockaddr_un
, sun_path
))
948 SCM_SIMPLE_VECTOR_SET(result
, 1, SCM_BOOL_F
);
950 SCM_SIMPLE_VECTOR_SET(result
, 1, scm_from_locale_string (nad
->sun_path
));
955 scm_misc_error (proc
, "Unrecognised address family: ~A",
956 scm_list_1 (scm_from_int (fam
)));
961 /* calculate the size of a buffer large enough to hold any supported
962 sockaddr type. if the buffer isn't large enough, certain system
963 calls will return a truncated address. */
965 #if defined (HAVE_UNIX_DOMAIN_SOCKETS)
966 #define MAX_SIZE_UN sizeof (struct sockaddr_un)
968 #define MAX_SIZE_UN 0
971 #if defined (HAVE_IPV6)
972 #define MAX_SIZE_IN6 sizeof (struct sockaddr_in6)
974 #define MAX_SIZE_IN6 0
977 #define MAX_ADDR_SIZE max (max (sizeof (struct sockaddr_in), MAX_SIZE_IN6),\
980 SCM_DEFINE (scm_accept
, "accept", 1, 0, 0,
982 "Accept a connection on a bound, listening socket.\n"
984 "are no pending connections in the queue, wait until\n"
985 "one is available unless the non-blocking option has been\n"
986 "set on the socket.\n\n"
987 "The return value is a\n"
988 "pair in which the @emph{car} is a new socket port for the\n"
990 "the @emph{cdr} is an object with address information about the\n"
991 "client which initiated the connection.\n\n"
992 "@var{sock} does not become part of the\n"
993 "connection and will continue to accept new requests.")
994 #define FUNC_NAME s_scm_accept
1000 int addr_size
= MAX_ADDR_SIZE
;
1001 char max_addr
[MAX_ADDR_SIZE
];
1002 struct sockaddr
*addr
= (struct sockaddr
*) max_addr
;
1004 sock
= SCM_COERCE_OUTPORT (sock
);
1005 SCM_VALIDATE_OPFPORT (1, sock
);
1006 fd
= SCM_FPORT_FDES (sock
);
1007 newfd
= accept (fd
, addr
, &addr_size
);
1010 newsock
= SCM_SOCK_FD_TO_PORT (newfd
);
1011 address
= scm_addr_vector (addr
, addr_size
, FUNC_NAME
);
1012 return scm_cons (newsock
, address
);
1016 SCM_DEFINE (scm_getsockname
, "getsockname", 1, 0, 0,
1018 "Return the address of @var{sock}, in the same form as the\n"
1019 "object returned by @code{accept}. On many systems the address\n"
1020 "of a socket in the @code{AF_FILE} namespace cannot be read.")
1021 #define FUNC_NAME s_scm_getsockname
1024 int addr_size
= MAX_ADDR_SIZE
;
1025 char max_addr
[MAX_ADDR_SIZE
];
1026 struct sockaddr
*addr
= (struct sockaddr
*) max_addr
;
1028 sock
= SCM_COERCE_OUTPORT (sock
);
1029 SCM_VALIDATE_OPFPORT (1, sock
);
1030 fd
= SCM_FPORT_FDES (sock
);
1031 if (getsockname (fd
, addr
, &addr_size
) == -1)
1033 return scm_addr_vector (addr
, addr_size
, FUNC_NAME
);
1037 SCM_DEFINE (scm_getpeername
, "getpeername", 1, 0, 0,
1039 "Return the address that @var{sock}\n"
1040 "is connected to, in the same form as the object returned by\n"
1041 "@code{accept}. On many systems the address of a socket in the\n"
1042 "@code{AF_FILE} namespace cannot be read.")
1043 #define FUNC_NAME s_scm_getpeername
1046 int addr_size
= MAX_ADDR_SIZE
;
1047 char max_addr
[MAX_ADDR_SIZE
];
1048 struct sockaddr
*addr
= (struct sockaddr
*) max_addr
;
1050 sock
= SCM_COERCE_OUTPORT (sock
);
1051 SCM_VALIDATE_OPFPORT (1, sock
);
1052 fd
= SCM_FPORT_FDES (sock
);
1053 if (getpeername (fd
, addr
, &addr_size
) == -1)
1055 return scm_addr_vector (addr
, addr_size
, FUNC_NAME
);
1059 SCM_DEFINE (scm_recv
, "recv!", 2, 1, 0,
1060 (SCM sock
, SCM buf
, SCM flags
),
1061 "Receive data from a socket port.\n"
1062 "@var{sock} must already\n"
1063 "be bound to the address from which data is to be received.\n"
1064 "@var{buf} is a string into which\n"
1065 "the data will be written. The size of @var{buf} limits\n"
1067 "data which can be received: in the case of packet\n"
1068 "protocols, if a packet larger than this limit is encountered\n"
1070 "will be irrevocably lost.\n\n"
1071 "The optional @var{flags} argument is a value or\n"
1072 "bitwise OR of MSG_OOB, MSG_PEEK, MSG_DONTROUTE etc.\n\n"
1073 "The value returned is the number of bytes read from the\n"
1075 "Note that the data is read directly from the socket file\n"
1077 "any unread buffered port data is ignored.")
1078 #define FUNC_NAME s_scm_recv
1086 SCM_VALIDATE_OPFPORT (1, sock
);
1087 SCM_VALIDATE_STRING (2, buf
);
1088 if (SCM_UNBNDP (flags
))
1091 flg
= scm_to_int (flags
);
1092 fd
= SCM_FPORT_FDES (sock
);
1094 len
= scm_i_string_length (buf
);
1095 dest
= scm_i_string_writable_chars (buf
);
1096 SCM_SYSCALL (rv
= recv (fd
, dest
, len
, flg
));
1097 scm_i_string_stop_writing ();
1102 scm_remember_upto_here_1 (buf
);
1103 return scm_from_int (rv
);
1107 SCM_DEFINE (scm_send
, "send", 2, 1, 0,
1108 (SCM sock
, SCM message
, SCM flags
),
1109 "Transmit the string @var{message} on a socket port @var{sock}.\n"
1110 "@var{sock} must already be bound to a destination address. The\n"
1111 "value returned is the number of bytes transmitted --\n"
1112 "it's possible for\n"
1113 "this to be less than the length of @var{message}\n"
1114 "if the socket is\n"
1115 "set to be non-blocking. The optional @var{flags} argument\n"
1117 "bitwise OR of MSG_OOB, MSG_PEEK, MSG_DONTROUTE etc.\n\n"
1118 "Note that the data is written directly to the socket\n"
1119 "file descriptor:\n"
1120 "any unflushed buffered port data is ignored.")
1121 #define FUNC_NAME s_scm_send
1129 sock
= SCM_COERCE_OUTPORT (sock
);
1130 SCM_VALIDATE_OPFPORT (1, sock
);
1131 SCM_VALIDATE_STRING (2, message
);
1132 if (SCM_UNBNDP (flags
))
1135 flg
= scm_to_int (flags
);
1136 fd
= SCM_FPORT_FDES (sock
);
1138 len
= scm_i_string_length (message
);
1139 src
= scm_i_string_writable_chars (message
);
1140 SCM_SYSCALL (rv
= send (fd
, src
, len
, flg
));
1141 scm_i_string_stop_writing ();
1146 scm_remember_upto_here_1 (message
);
1147 return scm_from_int (rv
);
1151 SCM_DEFINE (scm_recvfrom
, "recvfrom!", 2, 3, 0,
1152 (SCM sock
, SCM str
, SCM flags
, SCM start
, SCM end
),
1153 "Return data from the socket port @var{sock} and also\n"
1154 "information about where the data was received from.\n"
1155 "@var{sock} must already be bound to the address from which\n"
1156 "data is to be received. @code{str}, is a string into which the\n"
1157 "data will be written. The size of @var{str} limits the amount\n"
1158 "of data which can be received: in the case of packet protocols,\n"
1159 "if a packet larger than this limit is encountered then some\n"
1160 "data will be irrevocably lost.\n\n"
1161 "The optional @var{flags} argument is a value or bitwise OR of\n"
1162 "@code{MSG_OOB}, @code{MSG_PEEK}, @code{MSG_DONTROUTE} etc.\n\n"
1163 "The value returned is a pair: the @emph{car} is the number of\n"
1164 "bytes read from the socket and the @emph{cdr} an address object\n"
1165 "in the same form as returned by @code{accept}. The address\n"
1166 "will given as @code{#f} if not available, as is usually the\n"
1167 "case for stream sockets.\n\n"
1168 "The @var{start} and @var{end} arguments specify a substring of\n"
1169 "@var{str} to which the data should be written.\n\n"
1170 "Note that the data is read directly from the socket file\n"
1171 "descriptor: any unread buffered port data is ignored.")
1172 #define FUNC_NAME s_scm_recvfrom
1181 int addr_size
= MAX_ADDR_SIZE
;
1182 char max_addr
[MAX_ADDR_SIZE
];
1183 struct sockaddr
*addr
= (struct sockaddr
*) max_addr
;
1185 SCM_VALIDATE_OPFPORT (1, sock
);
1186 fd
= SCM_FPORT_FDES (sock
);
1188 SCM_VALIDATE_STRING (2, str
);
1189 scm_i_get_substring_spec (scm_i_string_length (str
),
1190 start
, &offset
, end
, &cend
);
1192 if (SCM_UNBNDP (flags
))
1195 SCM_VALIDATE_ULONG_COPY (3, flags
, flg
);
1197 /* recvfrom will not necessarily return an address. usually nothing
1198 is returned for stream sockets. */
1199 buf
= scm_i_string_writable_chars (str
);
1200 addr
->sa_family
= AF_UNSPEC
;
1201 SCM_SYSCALL (rv
= recvfrom (fd
, buf
+ offset
,
1204 scm_i_string_stop_writing ();
1208 if (addr
->sa_family
!= AF_UNSPEC
)
1209 address
= scm_addr_vector (addr
, addr_size
, FUNC_NAME
);
1211 address
= SCM_BOOL_F
;
1213 scm_remember_upto_here_1 (str
);
1214 return scm_cons (scm_from_int (rv
), address
);
1218 SCM_DEFINE (scm_sendto
, "sendto", 4, 0, 1,
1219 (SCM sock
, SCM message
, SCM fam
, SCM address
, SCM args_and_flags
),
1220 "Transmit the string @var{message} on the socket port\n"
1222 "destination address is specified using the @var{fam},\n"
1223 "@var{address} and\n"
1224 "@var{args_and_flags} arguments, in a similar way to the\n"
1225 "@code{connect} procedure. @var{args_and_flags} contains\n"
1226 "the usual connection arguments optionally followed by\n"
1227 "a flags argument, which is a value or\n"
1228 "bitwise OR of MSG_OOB, MSG_PEEK, MSG_DONTROUTE etc.\n\n"
1229 "The value returned is the number of bytes transmitted --\n"
1230 "it's possible for\n"
1231 "this to be less than the length of @var{message} if the\n"
1233 "set to be non-blocking.\n"
1234 "Note that the data is written directly to the socket\n"
1235 "file descriptor:\n"
1236 "any unflushed buffered port data is ignored.")
1237 #define FUNC_NAME s_scm_sendto
1242 struct sockaddr
*soka
;
1245 sock
= SCM_COERCE_OUTPORT (sock
);
1246 SCM_VALIDATE_FPORT (1, sock
);
1247 SCM_VALIDATE_STRING (2, message
);
1248 fd
= SCM_FPORT_FDES (sock
);
1249 soka
= scm_fill_sockaddr (scm_to_int (fam
), address
, &args_and_flags
, 4,
1251 if (scm_is_null (args_and_flags
))
1255 SCM_VALIDATE_CONS (5, args_and_flags
);
1256 flg
= SCM_NUM2ULONG (5, SCM_CAR (args_and_flags
));
1258 SCM_SYSCALL (rv
= sendto (fd
,
1259 scm_i_string_chars (message
),
1260 scm_i_string_length (message
),
1264 int save_errno
= errno
;
1271 scm_remember_upto_here_1 (message
);
1272 return scm_from_int (rv
);
1281 /* protocol families. */
1283 scm_c_define ("AF_UNSPEC", scm_from_int (AF_UNSPEC
));
1286 scm_c_define ("AF_UNIX", scm_from_int (AF_UNIX
));
1289 scm_c_define ("AF_INET", scm_from_int (AF_INET
));
1292 scm_c_define ("AF_INET6", scm_from_int (AF_INET6
));
1296 scm_c_define ("PF_UNSPEC", scm_from_int (PF_UNSPEC
));
1299 scm_c_define ("PF_UNIX", scm_from_int (PF_UNIX
));
1302 scm_c_define ("PF_INET", scm_from_int (PF_INET
));
1305 scm_c_define ("PF_INET6", scm_from_int (PF_INET6
));
1308 /* standard addresses. */
1310 scm_c_define ("INADDR_ANY", scm_from_ulong (INADDR_ANY
));
1312 #ifdef INADDR_BROADCAST
1313 scm_c_define ("INADDR_BROADCAST", scm_from_ulong (INADDR_BROADCAST
));
1316 scm_c_define ("INADDR_NONE", scm_from_ulong (INADDR_NONE
));
1318 #ifdef INADDR_LOOPBACK
1319 scm_c_define ("INADDR_LOOPBACK", scm_from_ulong (INADDR_LOOPBACK
));
1324 SOCK_PACKET is deliberately omitted, the GNU/Linux socket(2) and
1325 packet(7) advise that it's obsolete and strongly deprecated. */
1328 scm_c_define ("SOCK_STREAM", scm_from_int (SOCK_STREAM
));
1331 scm_c_define ("SOCK_DGRAM", scm_from_int (SOCK_DGRAM
));
1333 #ifdef SOCK_SEQPACKET
1334 scm_c_define ("SOCK_SEQPACKET", scm_from_int (SOCK_SEQPACKET
));
1337 scm_c_define ("SOCK_RAW", scm_from_int (SOCK_RAW
));
1340 scm_c_define ("SOCK_RDM", scm_from_int (SOCK_RDM
));
1343 /* setsockopt level. */
1345 scm_c_define ("SOL_SOCKET", scm_from_int (SOL_SOCKET
));
1348 scm_c_define ("SOL_IP", scm_from_int (SOL_IP
));
1351 scm_c_define ("SOL_TCP", scm_from_int (SOL_TCP
));
1354 scm_c_define ("SOL_UDP", scm_from_int (SOL_UDP
));
1357 /* setsockopt names. */
1359 scm_c_define ("SO_DEBUG", scm_from_int (SO_DEBUG
));
1362 scm_c_define ("SO_REUSEADDR", scm_from_int (SO_REUSEADDR
));
1365 scm_c_define ("SO_STYLE", scm_from_int (SO_STYLE
));
1368 scm_c_define ("SO_TYPE", scm_from_int (SO_TYPE
));
1371 scm_c_define ("SO_ERROR", scm_from_int (SO_ERROR
));
1374 scm_c_define ("SO_DONTROUTE", scm_from_int (SO_DONTROUTE
));
1377 scm_c_define ("SO_BROADCAST", scm_from_int (SO_BROADCAST
));
1380 scm_c_define ("SO_SNDBUF", scm_from_int (SO_SNDBUF
));
1383 scm_c_define ("SO_RCVBUF", scm_from_int (SO_RCVBUF
));
1386 scm_c_define ("SO_KEEPALIVE", scm_from_int (SO_KEEPALIVE
));
1389 scm_c_define ("SO_OOBINLINE", scm_from_int (SO_OOBINLINE
));
1392 scm_c_define ("SO_NO_CHECK", scm_from_int (SO_NO_CHECK
));
1395 scm_c_define ("SO_PRIORITY", scm_from_int (SO_PRIORITY
));
1398 scm_c_define ("SO_LINGER", scm_from_int (SO_LINGER
));
1401 /* recv/send options. */
1403 scm_c_define ("MSG_OOB", scm_from_int (MSG_OOB
));
1406 scm_c_define ("MSG_PEEK", scm_from_int (MSG_PEEK
));
1408 #ifdef MSG_DONTROUTE
1409 scm_c_define ("MSG_DONTROUTE", scm_from_int (MSG_DONTROUTE
));
1413 scm_i_init_socket_Win32 ();
1416 #ifdef IP_ADD_MEMBERSHIP
1417 scm_c_define ("IP_ADD_MEMBERSHIP", scm_from_int (IP_ADD_MEMBERSHIP
));
1418 scm_c_define ("IP_DROP_MEMBERSHIP", scm_from_int (IP_DROP_MEMBERSHIP
));
1421 scm_add_feature ("socket");
1423 #include "libguile/socket.x"