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
)
282 const scm_t_uint8
*ptr
= src
;
283 int num_zero_bytes
= 0;
284 scm_t_uint8 addr
[16];
286 /* count leading zeros (since we know it's bigendian, they'll be first) */
294 if (SCM_SIZEOF_UNSIGNED_LONG_LONG
!= 0) /* compiler should optimize this */
296 if ((16 - num_zero_bytes
) <= sizeof (unsigned long long))
299 unsigned long long x
;
301 FLIPCPY_NET_HOST_128(addr
, src
);
302 #ifdef WORDS_BIGENDIAN
303 memcpy (&x
, addr
+ (16 - sizeof (x
)), sizeof (x
));
305 memcpy (&x
, addr
, sizeof (x
));
307 return scm_from_ulong_long (x
);
312 if ((16 - num_zero_bytes
) <= sizeof (unsigned long))
314 /* this is just so that we use INUM where possible. */
317 FLIPCPY_NET_HOST_128(addr
, src
);
318 #ifdef WORDS_BIGENDIAN
319 memcpy (&x
, addr
+ (16 - sizeof (x
)), sizeof (x
));
321 memcpy (&x
, addr
, sizeof (x
));
323 return scm_from_ulong (x
);
326 /* otherwise get the big hammer */
328 SCM result
= scm_i_mkbig ();
330 mpz_import (SCM_I_BIG_MPZ (result
),
332 1, /* big-endian chunk ordering */
333 16, /* chunks are 16 bytes long */
334 1, /* big-endian byte ordering */
335 0, /* "nails" -- leading unused bits per chunk */
337 return scm_i_normbig (result
);
341 /* convert a host ordered SCM integer to a 128 bit IPv6 address in
344 scm_to_ipv6 (scm_t_uint8 dst
[16], SCM src
)
346 if (SCM_I_INUMP (src
))
348 scm_t_signed_bits n
= SCM_I_INUM (src
);
350 scm_out_of_range (NULL
, src
);
351 #ifdef WORDS_BIGENDIAN
352 memset (dst
, 0, 16 - sizeof (scm_t_signed_bits
));
353 memcpy (dst
+ (16 - sizeof (scm_t_signed_bits
)),
355 sizeof (scm_t_signed_bits
));
357 memset (dst
+ sizeof (scm_t_signed_bits
),
359 16 - sizeof (scm_t_signed_bits
));
360 /* FIXME: this pair of ops is kinda wasteful -- should rewrite as
361 a single loop perhaps, similar to the handling of bignums. */
362 memcpy (dst
, &n
, sizeof (scm_t_signed_bits
));
363 FLIP_NET_HOST_128 (dst
);
366 else if (SCM_BIGP (src
))
370 if ((mpz_sgn (SCM_I_BIG_MPZ (src
)) < 0)
371 || mpz_sizeinbase (SCM_I_BIG_MPZ (src
), 2) > 128)
372 scm_out_of_range (NULL
, src
);
377 1, /* big-endian chunk ordering */
378 16, /* chunks are 16 bytes long */
379 1, /* big-endian byte ordering */
380 0, /* "nails" -- leading unused bits per chunk */
381 SCM_I_BIG_MPZ (src
));
382 scm_remember_upto_here_1 (src
);
385 scm_wrong_type_arg (NULL
, 0, src
);
388 #ifdef HAVE_INET_PTON
389 SCM_DEFINE (scm_inet_pton
, "inet-pton", 2, 0, 0,
390 (SCM family
, SCM address
),
391 "Convert a string containing a printable network address to\n"
392 "an integer address. Note that unlike the C version of this\n"
394 "the result is an integer with normal host byte ordering.\n"
395 "@var{family} can be @code{AF_INET} or @code{AF_INET6}. E.g.,\n\n"
397 "(inet-pton AF_INET \"127.0.0.1\") @result{} 2130706433\n"
398 "(inet-pton AF_INET6 \"::1\") @result{} 1\n"
400 #define FUNC_NAME s_scm_inet_pton
407 af
= scm_to_int (family
);
408 SCM_ASSERT_RANGE (1, family
, af
== AF_INET
|| af
== AF_INET6
);
409 src
= scm_to_locale_string (address
);
410 rv
= inet_pton (af
, src
, dst
);
417 SCM_MISC_ERROR ("Bad address", SCM_EOL
);
419 return scm_from_ulong (ntohl (*(scm_t_uint32
*) dst
));
421 return scm_from_ipv6 ((char *) dst
);
426 #ifdef HAVE_INET_NTOP
427 SCM_DEFINE (scm_inet_ntop
, "inet-ntop", 2, 0, 0,
428 (SCM family
, SCM address
),
429 "Convert a network address into a printable string.\n"
430 "Note that unlike the C version of this function,\n"
431 "the input is an integer with normal host byte ordering.\n"
432 "@var{family} can be @code{AF_INET} or @code{AF_INET6}. E.g.,\n\n"
434 "(inet-ntop AF_INET 2130706433) @result{} \"127.0.0.1\"\n"
435 "(inet-ntop AF_INET6 (- (expt 2 128) 1)) @result{}\n"
436 "ffff:ffff:ffff:ffff:ffff:ffff:ffff:ffff\n"
438 #define FUNC_NAME s_scm_inet_ntop
441 #ifdef INET6_ADDRSTRLEN
442 char dst
[INET6_ADDRSTRLEN
];
448 af
= scm_to_int (family
);
449 SCM_ASSERT_RANGE (1, family
, af
== AF_INET
|| af
== AF_INET6
);
451 *(scm_t_uint32
*) addr6
= htonl (SCM_NUM2ULONG (2, address
));
453 scm_to_ipv6 (addr6
, address
);
454 if (inet_ntop (af
, &addr6
, dst
, sizeof dst
) == NULL
)
456 return scm_from_locale_string (dst
);
461 #endif /* HAVE_IPV6 */
463 SCM_SYMBOL (sym_socket
, "socket");
465 #define SCM_SOCK_FD_TO_PORT(fd) scm_fdes_to_port (fd, "r+0", sym_socket)
467 SCM_DEFINE (scm_socket
, "socket", 3, 0, 0,
468 (SCM family
, SCM style
, SCM proto
),
469 "Return a new socket port of the type specified by @var{family},\n"
470 "@var{style} and @var{proto}. All three parameters are\n"
471 "integers. Supported values for @var{family} are\n"
472 "@code{AF_UNIX}, @code{AF_INET} and @code{AF_INET6}.\n"
473 "Typical values for @var{style} are @code{SOCK_STREAM},\n"
474 "@code{SOCK_DGRAM} and @code{SOCK_RAW}.\n\n"
475 "@var{proto} can be obtained from a protocol name using\n"
476 "@code{getprotobyname}. A value of zero specifies the default\n"
477 "protocol, which is usually right.\n\n"
478 "A single socket port cannot by used for communication until it\n"
479 "has been connected to another socket.")
480 #define FUNC_NAME s_scm_socket
484 fd
= socket (scm_to_int (family
),
489 return SCM_SOCK_FD_TO_PORT (fd
);
493 #ifdef HAVE_SOCKETPAIR
494 SCM_DEFINE (scm_socketpair
, "socketpair", 3, 0, 0,
495 (SCM family
, SCM style
, SCM proto
),
496 "Return a pair of connected (but unnamed) socket ports of the\n"
497 "type specified by @var{family}, @var{style} and @var{proto}.\n"
498 "Many systems support only socket pairs of the @code{AF_UNIX}\n"
499 "family. Zero is likely to be the only meaningful value for\n"
501 #define FUNC_NAME s_scm_socketpair
506 fam
= scm_to_int (family
);
508 if (socketpair (fam
, scm_to_int (style
), scm_to_int (proto
), fd
) == -1)
511 return scm_cons (SCM_SOCK_FD_TO_PORT (fd
[0]), SCM_SOCK_FD_TO_PORT (fd
[1]));
516 SCM_DEFINE (scm_getsockopt
, "getsockopt", 3, 0, 0,
517 (SCM sock
, SCM level
, SCM optname
),
518 "Return the value of a particular socket option for the socket\n"
519 "port @var{sock}. @var{level} is an integer code for type of\n"
520 "option being requested, e.g., @code{SOL_SOCKET} for\n"
521 "socket-level options. @var{optname} is an integer code for the\n"
522 "option required and should be specified using one of the\n"
523 "symbols @code{SO_DEBUG}, @code{SO_REUSEADDR} etc.\n\n"
524 "The returned value is typically an integer but @code{SO_LINGER}\n"
525 "returns a pair of integers.")
526 #define FUNC_NAME s_scm_getsockopt
529 /* size of optval is the largest supported option. */
530 #ifdef HAVE_STRUCT_LINGER
531 char optval
[sizeof (struct linger
)];
532 int optlen
= sizeof (struct linger
);
534 char optval
[sizeof (size_t)];
535 int optlen
= sizeof (size_t);
540 sock
= SCM_COERCE_OUTPORT (sock
);
541 SCM_VALIDATE_OPFPORT (1, sock
);
542 ilevel
= scm_to_int (level
);
543 ioptname
= scm_to_int (optname
);
545 fd
= SCM_FPORT_FDES (sock
);
546 if (getsockopt (fd
, ilevel
, ioptname
, (void *) optval
, &optlen
) == -1)
549 if (ilevel
== SOL_SOCKET
)
552 if (ioptname
== SO_LINGER
)
554 #ifdef HAVE_STRUCT_LINGER
555 struct linger
*ling
= (struct linger
*) optval
;
557 return scm_cons (scm_from_long (ling
->l_onoff
),
558 scm_from_long (ling
->l_linger
));
560 return scm_cons (scm_from_long (*(int *) optval
),
568 || ioptname
== SO_SNDBUF
571 || ioptname
== SO_RCVBUF
575 return scm_from_size_t (*(size_t *) optval
);
578 return scm_from_int (*(int *) optval
);
582 SCM_DEFINE (scm_setsockopt
, "setsockopt", 4, 0, 0,
583 (SCM sock
, SCM level
, SCM optname
, SCM value
),
584 "Set the value of a particular socket option for the socket\n"
585 "port @var{sock}. @var{level} is an integer code for type of option\n"
586 "being set, e.g., @code{SOL_SOCKET} for socket-level options.\n"
587 "@var{optname} is an\n"
588 "integer code for the option to set and should be specified using one of\n"
589 "the symbols @code{SO_DEBUG}, @code{SO_REUSEADDR} etc.\n"
590 "@var{value} is the value to which the option should be set. For\n"
591 "most options this must be an integer, but for @code{SO_LINGER} it must\n"
593 "The return value is unspecified.")
594 #define FUNC_NAME s_scm_setsockopt
598 /* size of optval is the largest supported option. */
599 #ifdef HAVE_STRUCT_LINGER
600 char optval
[sizeof (struct linger
)];
602 char optval
[sizeof (size_t)];
604 int ilevel
, ioptname
;
606 sock
= SCM_COERCE_OUTPORT (sock
);
608 SCM_VALIDATE_OPFPORT (1, sock
);
609 ilevel
= scm_to_int (level
);
610 ioptname
= scm_to_int (optname
);
612 fd
= SCM_FPORT_FDES (sock
);
614 if (ilevel
== SOL_SOCKET
)
617 if (ioptname
== SO_LINGER
)
619 #ifdef HAVE_STRUCT_LINGER
623 SCM_ASSERT (SCM_CONSP (value
), value
, SCM_ARG4
, FUNC_NAME
);
624 lv
= SCM_NUM2LONG (4, SCM_CAR (value
));
625 ling
.l_onoff
= (int) lv
;
626 SCM_ASSERT_RANGE (SCM_ARG4
, value
, ling
.l_onoff
== lv
);
627 lv
= SCM_NUM2LONG (4, SCM_CDR (value
));
628 ling
.l_linger
= (int) lv
;
629 SCM_ASSERT_RANGE (SCM_ARG4
, value
, ling
.l_linger
== lv
);
630 optlen
= (int) sizeof (struct linger
);
631 memcpy (optval
, (void *) &ling
, optlen
);
636 SCM_ASSERT (SCM_CONSP (value
), value
, SCM_ARG4
, FUNC_NAME
);
637 /* timeout is ignored, but may as well validate it. */
638 lv
= SCM_NUM2LONG (4, SCM_CDR (value
));
640 SCM_ASSERT_RANGE (SCM_ARG4
, value
, ling
== lv
);
641 lv
= SCM_NUM2LONG (4, SCM_CAR (value
));
643 SCM_ASSERT_RANGE (SCM_ARG4
, value
, ling
== lv
);
644 optlen
= (int) sizeof (int);
645 (*(int *) optval
) = ling
;
652 || ioptname
== SO_SNDBUF
655 || ioptname
== SO_RCVBUF
659 long lv
= SCM_NUM2LONG (4, value
);
661 optlen
= (int) sizeof (size_t);
662 (*(size_t *) optval
) = (size_t) lv
;
667 /* Most options take an int. */
668 long lv
= SCM_NUM2LONG (4, value
);
671 SCM_ASSERT_RANGE (SCM_ARG4
, value
, val
== lv
);
672 optlen
= (int) sizeof (int);
673 (*(int *) optval
) = val
;
675 if (setsockopt (fd
, ilevel
, ioptname
, (void *) optval
, optlen
) == -1)
677 return SCM_UNSPECIFIED
;
681 SCM_DEFINE (scm_shutdown
, "shutdown", 2, 0, 0,
683 "Sockets can be closed simply by using @code{close-port}. The\n"
684 "@code{shutdown} procedure allows reception or transmission on a\n"
685 "connection to be shut down individually, according to the parameter\n"
689 "Stop receiving data for this socket. If further data arrives, reject it.\n"
691 "Stop trying to transmit data from this socket. Discard any\n"
692 "data waiting to be sent. Stop looking for acknowledgement of\n"
693 "data already sent; don't retransmit it if it is lost.\n"
695 "Stop both reception and transmission.\n"
697 "The return value is unspecified.")
698 #define FUNC_NAME s_scm_shutdown
701 sock
= SCM_COERCE_OUTPORT (sock
);
702 SCM_VALIDATE_OPFPORT (1, sock
);
703 fd
= SCM_FPORT_FDES (sock
);
704 if (shutdown (fd
, scm_to_signed_integer (how
, 0, 2)) == -1)
706 return SCM_UNSPECIFIED
;
710 /* convert fam/address/args into a sockaddr of the appropriate type.
711 args is modified by removing the arguments actually used.
712 which_arg and proc are used when reporting errors:
713 which_arg is the position of address in the original argument list.
714 proc is the name of the original procedure.
715 size returns the size of the structure allocated. */
717 static struct sockaddr
*
718 scm_fill_sockaddr (int fam
, SCM address
, SCM
*args
, int which_arg
,
719 const char *proc
, int *size
)
720 #define FUNC_NAME proc
726 struct sockaddr_in
*soka
;
730 SCM_VALIDATE_ULONG_COPY (which_arg
, address
, addr
);
731 SCM_VALIDATE_CONS (which_arg
+ 1, *args
);
732 port
= scm_to_int (SCM_CAR (*args
));
733 *args
= SCM_CDR (*args
);
734 soka
= (struct sockaddr_in
*) scm_malloc (sizeof (struct sockaddr_in
));
736 scm_memory_error (proc
);
737 /* 4.4BSD-style interface includes sin_len member and defines SIN_LEN,
740 soka
->sin_len
= sizeof (struct sockaddr_in
);
742 soka
->sin_family
= AF_INET
;
743 soka
->sin_addr
.s_addr
= htonl (addr
);
744 soka
->sin_port
= htons (port
);
745 *size
= sizeof (struct sockaddr_in
);
746 return (struct sockaddr
*) soka
;
753 struct sockaddr_in6
*soka
;
754 unsigned long flowinfo
= 0;
755 unsigned long scope_id
= 0;
757 SCM_VALIDATE_CONS (which_arg
+ 1, *args
);
758 port
= scm_to_int (SCM_CAR (*args
));
759 *args
= SCM_CDR (*args
);
760 if (SCM_CONSP (*args
))
762 SCM_VALIDATE_ULONG_COPY (which_arg
+ 2, SCM_CAR (*args
), flowinfo
);
763 *args
= SCM_CDR (*args
);
764 if (SCM_CONSP (*args
))
766 SCM_VALIDATE_ULONG_COPY (which_arg
+ 3, SCM_CAR (*args
),
768 *args
= SCM_CDR (*args
);
771 soka
= (struct sockaddr_in6
*) scm_malloc (sizeof (struct sockaddr_in6
));
773 scm_memory_error (proc
);
775 soka
->sin6_len
= sizeof (struct sockaddr_in6
);
777 soka
->sin6_family
= AF_INET6
;
778 scm_to_ipv6 (soka
->sin6_addr
.s6_addr
, address
);
779 soka
->sin6_port
= htons (port
);
780 soka
->sin6_flowinfo
= flowinfo
;
781 #ifdef HAVE_SIN6_SCOPE_ID
782 soka
->sin6_scope_id
= scope_id
;
784 *size
= sizeof (struct sockaddr_in6
);
785 return (struct sockaddr
*) soka
;
788 #ifdef HAVE_UNIX_DOMAIN_SOCKETS
791 struct sockaddr_un
*soka
;
797 c_address
= scm_to_locale_string (address
);
798 scm_frame_free (c_address
);
800 /* the static buffer size in sockaddr_un seems to be arbitrary
801 and not necessarily a hard limit. e.g., the glibc manual
802 suggests it may be possible to declare it size 0. let's
803 ignore it. if the O/S doesn't like the size it will cause
804 connect/bind etc., to fail. sun_path is always the last
805 member of the structure. */
806 addr_size
= sizeof (struct sockaddr_un
)
807 + max (0, strlen (c_address
) + 1 - (sizeof soka
->sun_path
));
808 soka
= (struct sockaddr_un
*) scm_malloc (addr_size
);
809 memset (soka
, 0, addr_size
); /* for sun_len: see sin_len above. */
810 soka
->sun_family
= AF_UNIX
;
811 strcpy (soka
->sun_path
, c_address
);
812 *size
= SUN_LEN (soka
);
815 return (struct sockaddr
*) soka
;
819 scm_out_of_range (proc
, scm_from_int (fam
));
824 SCM_DEFINE (scm_connect
, "connect", 3, 0, 1,
825 (SCM sock
, SCM fam
, SCM address
, SCM args
),
826 "Initiate a connection from a socket using a specified address\n"
827 "family to the address\n"
828 "specified by @var{address} and possibly @var{args}.\n"
829 "The format required for @var{address}\n"
830 "and @var{args} depends on the family of the socket.\n\n"
831 "For a socket of family @code{AF_UNIX},\n"
832 "only @var{address} is specified and must be a string with the\n"
833 "filename where the socket is to be created.\n\n"
834 "For a socket of family @code{AF_INET},\n"
835 "@var{address} must be an integer IPv4 host address and\n"
836 "@var{args} must be a single integer port number.\n\n"
837 "For a socket of family @code{AF_INET6},\n"
838 "@var{address} must be an integer IPv6 host address and\n"
839 "@var{args} may be up to three integers:\n"
840 "port [flowinfo] [scope_id],\n"
841 "where flowinfo and scope_id default to zero.\n\n"
842 "The return value is unspecified.")
843 #define FUNC_NAME s_scm_connect
846 struct sockaddr
*soka
;
849 sock
= SCM_COERCE_OUTPORT (sock
);
850 SCM_VALIDATE_OPFPORT (1, sock
);
851 fd
= SCM_FPORT_FDES (sock
);
852 soka
= scm_fill_sockaddr (scm_to_int (fam
), address
, &args
, 3, FUNC_NAME
,
854 if (connect (fd
, soka
, size
) == -1)
856 int save_errno
= errno
;
863 return SCM_UNSPECIFIED
;
867 SCM_DEFINE (scm_bind
, "bind", 3, 0, 1,
868 (SCM sock
, SCM fam
, SCM address
, SCM args
),
869 "Assign an address to the socket port @var{sock}.\n"
870 "Generally this only needs to be done for server sockets,\n"
871 "so they know where to look for incoming connections. A socket\n"
872 "without an address will be assigned one automatically when it\n"
873 "starts communicating.\n\n"
874 "The format of @var{address} and @var{args} depends\n"
875 "on the family of the socket.\n\n"
876 "For a socket of family @code{AF_UNIX}, only @var{address}\n"
877 "is specified and must be a string with the filename where\n"
878 "the socket is to be created.\n\n"
879 "For a socket of family @code{AF_INET}, @var{address}\n"
880 "must be an integer IPv4 address and @var{args}\n"
881 "must be a single integer port number.\n\n"
882 "The values of the following variables can also be used for\n"
884 "@defvar INADDR_ANY\n"
885 "Allow connections from any address.\n"
887 "@defvar INADDR_LOOPBACK\n"
888 "The address of the local host using the loopback device.\n"
890 "@defvar INADDR_BROADCAST\n"
891 "The broadcast address on the local network.\n"
893 "@defvar INADDR_NONE\n"
896 "For a socket of family @code{AF_INET6}, @var{address}\n"
897 "must be an integer IPv6 address and @var{args}\n"
898 "may be up to three integers:\n"
899 "port [flowinfo] [scope_id],\n"
900 "where flowinfo and scope_id default to zero.\n\n"
901 "The return value is unspecified.")
902 #define FUNC_NAME s_scm_bind
904 struct sockaddr
*soka
;
908 sock
= SCM_COERCE_OUTPORT (sock
);
909 SCM_VALIDATE_OPFPORT (1, sock
);
910 soka
= scm_fill_sockaddr (scm_to_int (fam
), address
, &args
, 3, FUNC_NAME
,
912 fd
= SCM_FPORT_FDES (sock
);
913 if (bind (fd
, soka
, size
) == -1)
915 int save_errno
= errno
;
922 return SCM_UNSPECIFIED
;
926 SCM_DEFINE (scm_listen
, "listen", 2, 0, 0,
927 (SCM sock
, SCM backlog
),
928 "Enable @var{sock} to accept connection\n"
929 "requests. @var{backlog} is an integer specifying\n"
930 "the maximum length of the queue for pending connections.\n"
931 "If the queue fills, new clients will fail to connect until\n"
932 "the server calls @code{accept} to accept a connection from\n"
934 "The return value is unspecified.")
935 #define FUNC_NAME s_scm_listen
938 sock
= SCM_COERCE_OUTPORT (sock
);
939 SCM_VALIDATE_OPFPORT (1, sock
);
940 fd
= SCM_FPORT_FDES (sock
);
941 if (listen (fd
, scm_to_int (backlog
)) == -1)
943 return SCM_UNSPECIFIED
;
947 /* Put the components of a sockaddr into a new SCM vector. */
949 scm_addr_vector (const struct sockaddr
*address
, int addr_size
,
952 short int fam
= address
->sa_family
;
960 const struct sockaddr_in
*nad
= (struct sockaddr_in
*) address
;
962 result
= scm_c_make_vector (3, SCM_UNSPECIFIED
);
964 SCM_VECTOR_SET(result
, 0,
965 scm_from_short (fam
));
966 SCM_VECTOR_SET(result
, 1,
967 scm_from_ulong (ntohl (nad
->sin_addr
.s_addr
)));
968 SCM_VECTOR_SET(result
, 2,
969 scm_from_ushort (ntohs (nad
->sin_port
)));
975 const struct sockaddr_in6
*nad
= (struct sockaddr_in6
*) address
;
977 result
= scm_c_make_vector (5, SCM_UNSPECIFIED
);
978 SCM_VECTOR_SET(result
, 0, scm_from_short (fam
));
979 SCM_VECTOR_SET(result
, 1, scm_from_ipv6 (nad
->sin6_addr
.s6_addr
));
980 SCM_VECTOR_SET(result
, 2, scm_from_ushort (ntohs (nad
->sin6_port
)));
981 SCM_VECTOR_SET(result
, 3, scm_from_uint32 (nad
->sin6_flowinfo
));
982 #ifdef HAVE_SIN6_SCOPE_ID
983 SCM_VECTOR_SET(result
, 4, scm_from_ulong (nad
->sin6_scope_id
));
985 SCM_VECTOR_SET(result
, 4, SCM_INUM0
);
990 #ifdef HAVE_UNIX_DOMAIN_SOCKETS
993 const struct sockaddr_un
*nad
= (struct sockaddr_un
*) address
;
995 result
= scm_c_make_vector (2, SCM_UNSPECIFIED
);
997 SCM_VECTOR_SET(result
, 0, scm_from_short (fam
));
998 /* When addr_size is not enough to cover sun_path, do not try
1000 if (addr_size
<= offsetof (struct sockaddr_un
, sun_path
))
1001 SCM_VECTOR_SET(result
, 1, SCM_BOOL_F
);
1003 SCM_VECTOR_SET(result
, 1, scm_from_locale_string (nad
->sun_path
));
1008 scm_misc_error (proc
, "Unrecognised address family: ~A",
1009 scm_list_1 (scm_from_int (fam
)));
1014 /* calculate the size of a buffer large enough to hold any supported
1015 sockaddr type. if the buffer isn't large enough, certain system
1016 calls will return a truncated address. */
1018 #if defined (HAVE_UNIX_DOMAIN_SOCKETS)
1019 #define MAX_SIZE_UN sizeof (struct sockaddr_un)
1021 #define MAX_SIZE_UN 0
1024 #if defined (HAVE_IPV6)
1025 #define MAX_SIZE_IN6 sizeof (struct sockaddr_in6)
1027 #define MAX_SIZE_IN6 0
1030 #define MAX_ADDR_SIZE max (max (sizeof (struct sockaddr_in), MAX_SIZE_IN6),\
1033 SCM_DEFINE (scm_accept
, "accept", 1, 0, 0,
1035 "Accept a connection on a bound, listening socket.\n"
1037 "are no pending connections in the queue, wait until\n"
1038 "one is available unless the non-blocking option has been\n"
1039 "set on the socket.\n\n"
1040 "The return value is a\n"
1041 "pair in which the @emph{car} is a new socket port for the\n"
1043 "the @emph{cdr} is an object with address information about the\n"
1044 "client which initiated the connection.\n\n"
1045 "@var{sock} does not become part of the\n"
1046 "connection and will continue to accept new requests.")
1047 #define FUNC_NAME s_scm_accept
1053 int addr_size
= MAX_ADDR_SIZE
;
1054 char max_addr
[MAX_ADDR_SIZE
];
1055 struct sockaddr
*addr
= (struct sockaddr
*) max_addr
;
1057 sock
= SCM_COERCE_OUTPORT (sock
);
1058 SCM_VALIDATE_OPFPORT (1, sock
);
1059 fd
= SCM_FPORT_FDES (sock
);
1060 newfd
= accept (fd
, addr
, &addr_size
);
1063 newsock
= SCM_SOCK_FD_TO_PORT (newfd
);
1064 address
= scm_addr_vector (addr
, addr_size
, FUNC_NAME
);
1065 return scm_cons (newsock
, address
);
1069 SCM_DEFINE (scm_getsockname
, "getsockname", 1, 0, 0,
1071 "Return the address of @var{sock}, in the same form as the\n"
1072 "object returned by @code{accept}. On many systems the address\n"
1073 "of a socket in the @code{AF_FILE} namespace cannot be read.")
1074 #define FUNC_NAME s_scm_getsockname
1077 int addr_size
= MAX_ADDR_SIZE
;
1078 char max_addr
[MAX_ADDR_SIZE
];
1079 struct sockaddr
*addr
= (struct sockaddr
*) max_addr
;
1081 sock
= SCM_COERCE_OUTPORT (sock
);
1082 SCM_VALIDATE_OPFPORT (1, sock
);
1083 fd
= SCM_FPORT_FDES (sock
);
1084 if (getsockname (fd
, addr
, &addr_size
) == -1)
1086 return scm_addr_vector (addr
, addr_size
, FUNC_NAME
);
1090 SCM_DEFINE (scm_getpeername
, "getpeername", 1, 0, 0,
1092 "Return the address that @var{sock}\n"
1093 "is connected to, in the same form as the object returned by\n"
1094 "@code{accept}. On many systems the address of a socket in the\n"
1095 "@code{AF_FILE} namespace cannot be read.")
1096 #define FUNC_NAME s_scm_getpeername
1099 int addr_size
= MAX_ADDR_SIZE
;
1100 char max_addr
[MAX_ADDR_SIZE
];
1101 struct sockaddr
*addr
= (struct sockaddr
*) max_addr
;
1103 sock
= SCM_COERCE_OUTPORT (sock
);
1104 SCM_VALIDATE_OPFPORT (1, sock
);
1105 fd
= SCM_FPORT_FDES (sock
);
1106 if (getpeername (fd
, addr
, &addr_size
) == -1)
1108 return scm_addr_vector (addr
, addr_size
, FUNC_NAME
);
1112 SCM_DEFINE (scm_recv
, "recv!", 2, 1, 0,
1113 (SCM sock
, SCM buf
, SCM flags
),
1114 "Receive data from a socket port.\n"
1115 "@var{sock} must already\n"
1116 "be bound to the address from which data is to be received.\n"
1117 "@var{buf} is a string into which\n"
1118 "the data will be written. The size of @var{buf} limits\n"
1120 "data which can be received: in the case of packet\n"
1121 "protocols, if a packet larger than this limit is encountered\n"
1123 "will be irrevocably lost.\n\n"
1124 "The optional @var{flags} argument is a value or\n"
1125 "bitwise OR of MSG_OOB, MSG_PEEK, MSG_DONTROUTE etc.\n\n"
1126 "The value returned is the number of bytes read from the\n"
1128 "Note that the data is read directly from the socket file\n"
1130 "any unread buffered port data is ignored.")
1131 #define FUNC_NAME s_scm_recv
1139 SCM_VALIDATE_OPFPORT (1, sock
);
1140 SCM_VALIDATE_STRING (2, buf
);
1141 if (SCM_UNBNDP (flags
))
1144 flg
= scm_to_int (flags
);
1145 fd
= SCM_FPORT_FDES (sock
);
1147 len
= scm_i_string_length (buf
);
1148 dest
= scm_i_string_writable_chars (buf
);
1149 SCM_SYSCALL (rv
= recv (fd
, dest
, len
, flg
));
1150 scm_i_string_stop_writing ();
1155 scm_remember_upto_here_1 (buf
);
1156 return scm_from_int (rv
);
1160 SCM_DEFINE (scm_send
, "send", 2, 1, 0,
1161 (SCM sock
, SCM message
, SCM flags
),
1162 "Transmit the string @var{message} on a socket port @var{sock}.\n"
1163 "@var{sock} must already be bound to a destination address. The\n"
1164 "value returned is the number of bytes transmitted --\n"
1165 "it's possible for\n"
1166 "this to be less than the length of @var{message}\n"
1167 "if the socket is\n"
1168 "set to be non-blocking. The optional @var{flags} argument\n"
1170 "bitwise OR of MSG_OOB, MSG_PEEK, MSG_DONTROUTE etc.\n\n"
1171 "Note that the data is written directly to the socket\n"
1172 "file descriptor:\n"
1173 "any unflushed buffered port data is ignored.")
1174 #define FUNC_NAME s_scm_send
1182 sock
= SCM_COERCE_OUTPORT (sock
);
1183 SCM_VALIDATE_OPFPORT (1, sock
);
1184 SCM_VALIDATE_STRING (2, message
);
1185 if (SCM_UNBNDP (flags
))
1188 flg
= scm_to_int (flags
);
1189 fd
= SCM_FPORT_FDES (sock
);
1191 len
= scm_i_string_length (message
);
1192 src
= scm_i_string_writable_chars (message
);
1193 SCM_SYSCALL (rv
= send (fd
, src
, len
, flg
));
1194 scm_i_string_stop_writing ();
1199 scm_remember_upto_here_1 (message
);
1200 return scm_from_int (rv
);
1204 SCM_DEFINE (scm_recvfrom
, "recvfrom!", 2, 3, 0,
1205 (SCM sock
, SCM str
, SCM flags
, SCM start
, SCM end
),
1206 "Return data from the socket port @var{sock} and also\n"
1207 "information about where the data was received from.\n"
1208 "@var{sock} must already be bound to the address from which\n"
1209 "data is to be received. @code{str}, is a string into which the\n"
1210 "data will be written. The size of @var{str} limits the amount\n"
1211 "of data which can be received: in the case of packet protocols,\n"
1212 "if a packet larger than this limit is encountered then some\n"
1213 "data will be irrevocably lost.\n\n"
1214 "The optional @var{flags} argument is a value or bitwise OR of\n"
1215 "@code{MSG_OOB}, @code{MSG_PEEK}, @code{MSG_DONTROUTE} etc.\n\n"
1216 "The value returned is a pair: the @emph{car} is the number of\n"
1217 "bytes read from the socket and the @emph{cdr} an address object\n"
1218 "in the same form as returned by @code{accept}. The address\n"
1219 "will given as @code{#f} if not available, as is usually the\n"
1220 "case for stream sockets.\n\n"
1221 "The @var{start} and @var{end} arguments specify a substring of\n"
1222 "@var{str} to which the data should be written.\n\n"
1223 "Note that the data is read directly from the socket file\n"
1224 "descriptor: any unread buffered port data is ignored.")
1225 #define FUNC_NAME s_scm_recvfrom
1234 int addr_size
= MAX_ADDR_SIZE
;
1235 char max_addr
[MAX_ADDR_SIZE
];
1236 struct sockaddr
*addr
= (struct sockaddr
*) max_addr
;
1238 SCM_VALIDATE_OPFPORT (1, sock
);
1239 fd
= SCM_FPORT_FDES (sock
);
1241 SCM_VALIDATE_STRING (2, str
);
1242 scm_i_get_substring_spec (scm_i_string_length (str
),
1243 start
, &offset
, end
, &cend
);
1245 if (SCM_UNBNDP (flags
))
1248 SCM_VALIDATE_ULONG_COPY (3, flags
, flg
);
1250 /* recvfrom will not necessarily return an address. usually nothing
1251 is returned for stream sockets. */
1252 buf
= scm_i_string_writable_chars (str
);
1253 addr
->sa_family
= AF_UNSPEC
;
1254 SCM_SYSCALL (rv
= recvfrom (fd
, buf
+ offset
,
1257 scm_i_string_stop_writing ();
1261 if (addr
->sa_family
!= AF_UNSPEC
)
1262 address
= scm_addr_vector (addr
, addr_size
, FUNC_NAME
);
1264 address
= SCM_BOOL_F
;
1266 scm_remember_upto_here_1 (str
);
1267 return scm_cons (scm_from_int (rv
), address
);
1271 SCM_DEFINE (scm_sendto
, "sendto", 4, 0, 1,
1272 (SCM sock
, SCM message
, SCM fam
, SCM address
, SCM args_and_flags
),
1273 "Transmit the string @var{message} on the socket port\n"
1275 "destination address is specified using the @var{fam},\n"
1276 "@var{address} and\n"
1277 "@var{args_and_flags} arguments, in a similar way to the\n"
1278 "@code{connect} procedure. @var{args_and_flags} contains\n"
1279 "the usual connection arguments optionally followed by\n"
1280 "a flags argument, which is a value or\n"
1281 "bitwise OR of MSG_OOB, MSG_PEEK, MSG_DONTROUTE etc.\n\n"
1282 "The value returned is the number of bytes transmitted --\n"
1283 "it's possible for\n"
1284 "this to be less than the length of @var{message} if the\n"
1286 "set to be non-blocking.\n"
1287 "Note that the data is written directly to the socket\n"
1288 "file descriptor:\n"
1289 "any unflushed buffered port data is ignored.")
1290 #define FUNC_NAME s_scm_sendto
1295 struct sockaddr
*soka
;
1298 sock
= SCM_COERCE_OUTPORT (sock
);
1299 SCM_VALIDATE_FPORT (1, sock
);
1300 SCM_VALIDATE_STRING (2, message
);
1301 fd
= SCM_FPORT_FDES (sock
);
1302 soka
= scm_fill_sockaddr (scm_to_int (fam
), address
, &args_and_flags
, 4,
1304 if (SCM_NULLP (args_and_flags
))
1308 SCM_VALIDATE_CONS (5, args_and_flags
);
1309 flg
= SCM_NUM2ULONG (5, SCM_CAR (args_and_flags
));
1311 SCM_SYSCALL (rv
= sendto (fd
,
1312 scm_i_string_chars (message
),
1313 scm_i_string_length (message
),
1317 int save_errno
= errno
;
1324 scm_remember_upto_here_1 (message
);
1325 return scm_from_int (rv
);
1334 /* protocol families. */
1336 scm_c_define ("AF_UNSPEC", scm_from_int (AF_UNSPEC
));
1339 scm_c_define ("AF_UNIX", scm_from_int (AF_UNIX
));
1342 scm_c_define ("AF_INET", scm_from_int (AF_INET
));
1345 scm_c_define ("AF_INET6", scm_from_int (AF_INET6
));
1349 scm_c_define ("PF_UNSPEC", scm_from_int (PF_UNSPEC
));
1352 scm_c_define ("PF_UNIX", scm_from_int (PF_UNIX
));
1355 scm_c_define ("PF_INET", scm_from_int (PF_INET
));
1358 scm_c_define ("PF_INET6", scm_from_int (PF_INET6
));
1361 /* standard addresses. */
1363 scm_c_define ("INADDR_ANY", scm_from_ulong (INADDR_ANY
));
1365 #ifdef INADDR_BROADCAST
1366 scm_c_define ("INADDR_BROADCAST", scm_from_ulong (INADDR_BROADCAST
));
1369 scm_c_define ("INADDR_NONE", scm_from_ulong (INADDR_NONE
));
1371 #ifdef INADDR_LOOPBACK
1372 scm_c_define ("INADDR_LOOPBACK", scm_from_ulong (INADDR_LOOPBACK
));
1377 SOCK_PACKET is deliberately omitted, the GNU/Linux socket(2) and
1378 packet(7) advise that it's obsolete and strongly deprecated. */
1381 scm_c_define ("SOCK_STREAM", scm_from_int (SOCK_STREAM
));
1384 scm_c_define ("SOCK_DGRAM", scm_from_int (SOCK_DGRAM
));
1386 #ifdef SOCK_SEQPACKET
1387 scm_c_define ("SOCK_SEQPACKET", scm_from_int (SOCK_SEQPACKET
));
1390 scm_c_define ("SOCK_RAW", scm_from_int (SOCK_RAW
));
1393 scm_c_define ("SOCK_RDM", scm_from_int (SOCK_RDM
));
1396 /* setsockopt level. */
1398 scm_c_define ("SOL_SOCKET", scm_from_int (SOL_SOCKET
));
1401 scm_c_define ("SOL_IP", scm_from_int (SOL_IP
));
1404 scm_c_define ("SOL_TCP", scm_from_int (SOL_TCP
));
1407 scm_c_define ("SOL_UDP", scm_from_int (SOL_UDP
));
1410 /* setsockopt names. */
1412 scm_c_define ("SO_DEBUG", scm_from_int (SO_DEBUG
));
1415 scm_c_define ("SO_REUSEADDR", scm_from_int (SO_REUSEADDR
));
1418 scm_c_define ("SO_STYLE", scm_from_int (SO_STYLE
));
1421 scm_c_define ("SO_TYPE", scm_from_int (SO_TYPE
));
1424 scm_c_define ("SO_ERROR", scm_from_int (SO_ERROR
));
1427 scm_c_define ("SO_DONTROUTE", scm_from_int (SO_DONTROUTE
));
1430 scm_c_define ("SO_BROADCAST", scm_from_int (SO_BROADCAST
));
1433 scm_c_define ("SO_SNDBUF", scm_from_int (SO_SNDBUF
));
1436 scm_c_define ("SO_RCVBUF", scm_from_int (SO_RCVBUF
));
1439 scm_c_define ("SO_KEEPALIVE", scm_from_int (SO_KEEPALIVE
));
1442 scm_c_define ("SO_OOBINLINE", scm_from_int (SO_OOBINLINE
));
1445 scm_c_define ("SO_NO_CHECK", scm_from_int (SO_NO_CHECK
));
1448 scm_c_define ("SO_PRIORITY", scm_from_int (SO_PRIORITY
));
1451 scm_c_define ("SO_LINGER", scm_from_int (SO_LINGER
));
1454 /* recv/send options. */
1456 scm_c_define ("MSG_OOB", scm_from_int (MSG_OOB
));
1459 scm_c_define ("MSG_PEEK", scm_from_int (MSG_PEEK
));
1461 #ifdef MSG_DONTROUTE
1462 scm_c_define ("MSG_DONTROUTE", scm_from_int (MSG_DONTROUTE
));
1466 scm_i_init_socket_Win32 ();
1469 scm_add_feature ("socket");
1471 #include "libguile/socket.x"