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"
35 #include "libguile/validate.h"
36 #include "libguile/socket.h"
39 #include "win32-socket.h"
51 #include <sys/types.h>
52 #ifdef HAVE_WINSOCK2_H
55 #include <sys/socket.h>
56 #ifdef HAVE_UNIX_DOMAIN_SOCKETS
59 #include <netinet/in.h>
61 #include <arpa/inet.h>
64 #if defined (HAVE_UNIX_DOMAIN_SOCKETS) && !defined (SUN_LEN)
65 #define SUN_LEN(ptr) ((size_t) (((struct sockaddr_un *) 0)->sun_path) \
66 + strlen ((ptr)->sun_path))
69 /* we are not currently using socklen_t. it's not defined on all systems,
70 so would need to be checked by configure. in the meantime, plain
71 int is the best alternative. */
75 SCM_DEFINE (scm_htons
, "htons", 1, 0, 0,
77 "Convert a 16 bit quantity from host to network byte ordering.\n"
78 "@var{value} is packed into 2 bytes, which are then converted\n"
79 "and returned as a new integer.")
80 #define FUNC_NAME s_scm_htons
82 return scm_from_ushort (htons (scm_to_ushort (value
)));
86 SCM_DEFINE (scm_ntohs
, "ntohs", 1, 0, 0,
88 "Convert a 16 bit quantity from network to host byte ordering.\n"
89 "@var{value} is packed into 2 bytes, which are then converted\n"
90 "and returned as a new integer.")
91 #define FUNC_NAME s_scm_ntohs
93 return scm_from_ushort (ntohs (scm_to_ushort (value
)));
97 SCM_DEFINE (scm_htonl
, "htonl", 1, 0, 0,
99 "Convert a 32 bit quantity from host to network byte ordering.\n"
100 "@var{value} is packed into 4 bytes, which are then converted\n"
101 "and returned as a new integer.")
102 #define FUNC_NAME s_scm_htonl
104 scm_t_uint32 c_in
= SCM_NUM2ULONG (1, value
);
106 return scm_ulong2num (htonl (c_in
));
110 SCM_DEFINE (scm_ntohl
, "ntohl", 1, 0, 0,
112 "Convert a 32 bit quantity from network to host byte ordering.\n"
113 "@var{value} is packed into 4 bytes, which are then converted\n"
114 "and returned as a new integer.")
115 #define FUNC_NAME s_scm_ntohl
117 scm_t_uint32 c_in
= SCM_NUM2ULONG (1, value
);
119 return scm_ulong2num (ntohl (c_in
));
123 #ifndef HAVE_INET_ATON
124 /* for our definition in inet_aton.c, not usually needed. */
125 extern int inet_aton ();
128 SCM_DEFINE (scm_inet_aton
, "inet-aton", 1, 0, 0,
130 "Convert an IPv4 Internet address from printable string\n"
131 "(dotted decimal notation) to an integer. E.g.,\n\n"
133 "(inet-aton \"127.0.0.1\") @result{} 2130706433\n"
135 #define FUNC_NAME s_scm_inet_aton
139 SCM_VALIDATE_STRING (1, address
);
140 if (inet_aton (SCM_STRING_CHARS (address
), &soka
) == 0)
141 SCM_MISC_ERROR ("bad address", SCM_EOL
);
142 return scm_ulong2num (ntohl (soka
.s_addr
));
147 SCM_DEFINE (scm_inet_ntoa
, "inet-ntoa", 1, 0, 0,
149 "Convert an IPv4 Internet address to a printable\n"
150 "(dotted decimal notation) string. E.g.,\n\n"
152 "(inet-ntoa 2130706433) @result{} \"127.0.0.1\"\n"
154 #define FUNC_NAME s_scm_inet_ntoa
159 addr
.s_addr
= htonl (SCM_NUM2ULONG (1, inetid
));
160 s
= inet_ntoa (addr
);
161 answer
= scm_mem2string (s
, strlen (s
));
166 #ifdef HAVE_INET_NETOF
167 SCM_DEFINE (scm_inet_netof
, "inet-netof", 1, 0, 0,
169 "Return the network number part of the given IPv4\n"
170 "Internet address. E.g.,\n\n"
172 "(inet-netof 2130706433) @result{} 127\n"
174 #define FUNC_NAME s_scm_inet_netof
177 addr
.s_addr
= htonl (SCM_NUM2ULONG (1, address
));
178 return scm_ulong2num ((unsigned long) inet_netof (addr
));
183 #ifdef HAVE_INET_LNAOF
184 SCM_DEFINE (scm_lnaof
, "inet-lnaof", 1, 0, 0,
186 "Return the local-address-with-network part of the given\n"
187 "IPv4 Internet address, using the obsolete class A/B/C system.\n"
190 "(inet-lnaof 2130706433) @result{} 1\n"
192 #define FUNC_NAME s_scm_lnaof
195 addr
.s_addr
= htonl (SCM_NUM2ULONG (1, address
));
196 return scm_ulong2num ((unsigned long) inet_lnaof (addr
));
201 #ifdef HAVE_INET_MAKEADDR
202 SCM_DEFINE (scm_inet_makeaddr
, "inet-makeaddr", 2, 0, 0,
204 "Make an IPv4 Internet address by combining the network number\n"
205 "@var{net} with the local-address-within-network number\n"
206 "@var{lna}. E.g.,\n\n"
208 "(inet-makeaddr 127 1) @result{} 2130706433\n"
210 #define FUNC_NAME s_scm_inet_makeaddr
213 unsigned long netnum
;
214 unsigned long lnanum
;
216 netnum
= SCM_NUM2ULONG (1, net
);
217 lnanum
= SCM_NUM2ULONG (2, lna
);
218 addr
= inet_makeaddr (netnum
, lnanum
);
219 return scm_ulong2num (ntohl (addr
.s_addr
));
226 /* flip a 128 bit IPv6 address between host and network order. */
227 #ifdef WORDS_BIGENDIAN
228 #define FLIP_NET_HOST_128(addr)
230 #define FLIP_NET_HOST_128(addr)\
234 for (i = 0; i < 8; i++)\
236 scm_t_uint8 c = (addr)[i];\
238 (addr)[i] = (addr)[15 - i];\
244 #ifdef WORDS_BIGENDIAN
245 #define FLIPCPY_NET_HOST_128(dest, src) memcpy (dest, src, 16)
247 #define FLIPCPY_NET_HOST_128(dest, src) \
249 const scm_t_uint8 *tmp_srcp = (src) + 15; \
250 scm_t_uint8 *tmp_destp = (dest); \
253 *tmp_destp++ = *tmp_srcp--; \
254 } while (tmp_srcp != (src)); \
259 #if (SIZEOF_SCM_T_BITS * SCM_CHAR_BIT) > 128
260 #error "Assumption that scm_t_bits <= 128 bits has been violated."
263 #if (SIZEOF_UNSIGNED_LONG * SCM_CHAR_BIT) > 128
264 #error "Assumption that unsigned long <= 128 bits has been violated."
267 #if (SIZEOF_UNSIGNED_LONG_LONG * SCM_CHAR_BIT) > 128
268 #error "Assumption that unsigned long long <= 128 bits has been violated."
271 /* convert a 128 bit IPv6 address in network order to a host ordered
274 scm_from_ipv6 (const scm_t_uint8
*src
)
277 const scm_t_uint8
*ptr
= src
;
278 int num_zero_bytes
= 0;
279 scm_t_uint8 addr
[16];
281 /* count leading zeros (since we know it's bigendian, they'll be first) */
289 if (SCM_SIZEOF_UNSIGNED_LONG_LONG
!= 0) /* compiler should optimize this */
291 if ((16 - num_zero_bytes
) <= sizeof (unsigned long long))
294 unsigned long long x
;
296 FLIPCPY_NET_HOST_128(addr
, src
);
297 #ifdef WORDS_BIGENDIAN
298 memcpy (&x
, addr
+ (16 - sizeof (x
)), sizeof (x
));
300 memcpy (&x
, addr
, sizeof (x
));
302 return scm_ulong_long2num (x
);
307 if ((16 - num_zero_bytes
) <= sizeof (unsigned long))
309 /* this is just so that we use INUM where possible. */
312 FLIPCPY_NET_HOST_128(addr
, src
);
313 #ifdef WORDS_BIGENDIAN
314 memcpy (&x
, addr
+ (16 - sizeof (x
)), sizeof (x
));
316 memcpy (&x
, addr
, sizeof (x
));
318 return scm_ulong2num (x
);
321 /* otherwise get the big hammer */
323 SCM result
= scm_i_mkbig ();
325 mpz_import (SCM_I_BIG_MPZ (result
),
327 1, /* big-endian chunk ordering */
328 16, /* chunks are 16 bytes long */
329 1, /* big-endian byte ordering */
330 0, /* "nails" -- leading unused bits per chunk */
332 return scm_i_normbig (result
);
336 /* convert a host ordered SCM integer to a 128 bit IPv6 address in
339 scm_to_ipv6 (scm_t_uint8 dst
[16], SCM src
)
341 if (SCM_I_INUMP (src
))
343 scm_t_signed_bits n
= SCM_I_INUM (src
);
345 scm_out_of_range (NULL
, src
);
346 #ifdef WORDS_BIGENDIAN
347 memset (dst
, 0, 16 - sizeof (scm_t_signed_bits
));
348 memcpy (dst
+ (16 - sizeof (scm_t_signed_bits
)),
350 sizeof (scm_t_signed_bits
));
352 memset (dst
+ sizeof (scm_t_signed_bits
),
354 16 - sizeof (scm_t_signed_bits
));
355 /* FIXME: this pair of ops is kinda wasteful -- should rewrite as
356 a single loop perhaps, similar to the handling of bignums. */
357 memcpy (dst
, &n
, sizeof (scm_t_signed_bits
));
358 FLIP_NET_HOST_128 (dst
);
361 else if (SCM_BIGP (src
))
365 if ((mpz_sgn (SCM_I_BIG_MPZ (src
)) < 0)
366 || mpz_sizeinbase (SCM_I_BIG_MPZ (src
), 2) > 128)
367 scm_out_of_range (NULL
, src
);
372 1, /* big-endian chunk ordering */
373 16, /* chunks are 16 bytes long */
374 1, /* big-endian byte ordering */
375 0, /* "nails" -- leading unused bits per chunk */
376 SCM_I_BIG_MPZ (src
));
377 scm_remember_upto_here_1 (src
);
380 scm_wrong_type_arg (NULL
, 0, src
);
383 #ifdef HAVE_INET_PTON
384 SCM_DEFINE (scm_inet_pton
, "inet-pton", 2, 0, 0,
385 (SCM family
, SCM address
),
386 "Convert a string containing a printable network address to\n"
387 "an integer address. Note that unlike the C version of this\n"
389 "the result is an integer with normal host byte ordering.\n"
390 "@var{family} can be @code{AF_INET} or @code{AF_INET6}. E.g.,\n\n"
392 "(inet-pton AF_INET \"127.0.0.1\") @result{} 2130706433\n"
393 "(inet-pton AF_INET6 \"::1\") @result{} 1\n"
395 #define FUNC_NAME s_scm_inet_pton
402 af
= scm_to_int (family
);
403 SCM_ASSERT_RANGE (1, family
, af
== AF_INET
|| af
== AF_INET6
);
404 SCM_VALIDATE_STRING_COPY (2, address
, src
);
405 rv
= inet_pton (af
, src
, dst
);
409 SCM_MISC_ERROR ("Bad address", SCM_EOL
);
411 return scm_ulong2num (ntohl (*(scm_t_uint32
*) dst
));
413 return scm_from_ipv6 ((char *) dst
);
418 #ifdef HAVE_INET_NTOP
419 SCM_DEFINE (scm_inet_ntop
, "inet-ntop", 2, 0, 0,
420 (SCM family
, SCM address
),
421 "Convert a network address into a printable string.\n"
422 "Note that unlike the C version of this function,\n"
423 "the input is an integer with normal host byte ordering.\n"
424 "@var{family} can be @code{AF_INET} or @code{AF_INET6}. E.g.,\n\n"
426 "(inet-ntop AF_INET 2130706433) @result{} \"127.0.0.1\"\n"
427 "(inet-ntop AF_INET6 (- (expt 2 128) 1)) @result{}\n"
428 "ffff:ffff:ffff:ffff:ffff:ffff:ffff:ffff\n"
430 #define FUNC_NAME s_scm_inet_ntop
433 #ifdef INET6_ADDRSTRLEN
434 char dst
[INET6_ADDRSTRLEN
];
440 af
= scm_to_int (family
);
441 SCM_ASSERT_RANGE (1, family
, af
== AF_INET
|| af
== AF_INET6
);
443 *(scm_t_uint32
*) addr6
= htonl (SCM_NUM2ULONG (2, address
));
445 scm_to_ipv6 (addr6
, address
);
446 if (inet_ntop (af
, &addr6
, dst
, sizeof dst
) == NULL
)
448 return scm_makfrom0str (dst
);
453 #endif /* HAVE_IPV6 */
455 SCM_SYMBOL (sym_socket
, "socket");
457 #define SCM_SOCK_FD_TO_PORT(fd) scm_fdes_to_port (fd, "r+0", sym_socket)
459 SCM_DEFINE (scm_socket
, "socket", 3, 0, 0,
460 (SCM family
, SCM style
, SCM proto
),
461 "Return a new socket port of the type specified by @var{family},\n"
462 "@var{style} and @var{proto}. All three parameters are\n"
463 "integers. Supported values for @var{family} are\n"
464 "@code{AF_UNIX}, @code{AF_INET} and @code{AF_INET6}.\n"
465 "Typical values for @var{style} are @code{SOCK_STREAM},\n"
466 "@code{SOCK_DGRAM} and @code{SOCK_RAW}.\n\n"
467 "@var{proto} can be obtained from a protocol name using\n"
468 "@code{getprotobyname}. A value of zero specifies the default\n"
469 "protocol, which is usually right.\n\n"
470 "A single socket port cannot by used for communication until it\n"
471 "has been connected to another socket.")
472 #define FUNC_NAME s_scm_socket
476 fd
= socket (scm_to_int (family
),
481 return SCM_SOCK_FD_TO_PORT (fd
);
485 #ifdef HAVE_SOCKETPAIR
486 SCM_DEFINE (scm_socketpair
, "socketpair", 3, 0, 0,
487 (SCM family
, SCM style
, SCM proto
),
488 "Return a pair of connected (but unnamed) socket ports of the\n"
489 "type specified by @var{family}, @var{style} and @var{proto}.\n"
490 "Many systems support only socket pairs of the @code{AF_UNIX}\n"
491 "family. Zero is likely to be the only meaningful value for\n"
493 #define FUNC_NAME s_scm_socketpair
498 fam
= scm_to_int (family
);
500 if (socketpair (fam
, scm_to_int (style
), scm_to_int (proto
), fd
) == -1)
503 return scm_cons (SCM_SOCK_FD_TO_PORT (fd
[0]), SCM_SOCK_FD_TO_PORT (fd
[1]));
508 SCM_DEFINE (scm_getsockopt
, "getsockopt", 3, 0, 0,
509 (SCM sock
, SCM level
, SCM optname
),
510 "Return the value of a particular socket option for the socket\n"
511 "port @var{sock}. @var{level} is an integer code for type of\n"
512 "option being requested, e.g., @code{SOL_SOCKET} for\n"
513 "socket-level options. @var{optname} is an integer code for the\n"
514 "option required and should be specified using one of the\n"
515 "symbols @code{SO_DEBUG}, @code{SO_REUSEADDR} etc.\n\n"
516 "The returned value is typically an integer but @code{SO_LINGER}\n"
517 "returns a pair of integers.")
518 #define FUNC_NAME s_scm_getsockopt
521 /* size of optval is the largest supported option. */
522 #ifdef HAVE_STRUCT_LINGER
523 char optval
[sizeof (struct linger
)];
524 int optlen
= sizeof (struct linger
);
526 char optval
[sizeof (size_t)];
527 int optlen
= sizeof (size_t);
532 sock
= SCM_COERCE_OUTPORT (sock
);
533 SCM_VALIDATE_OPFPORT (1, sock
);
534 ilevel
= scm_to_int (level
);
535 ioptname
= scm_to_int (optname
);
537 fd
= SCM_FPORT_FDES (sock
);
538 if (getsockopt (fd
, ilevel
, ioptname
, (void *) optval
, &optlen
) == -1)
541 if (ilevel
== SOL_SOCKET
)
544 if (ioptname
== SO_LINGER
)
546 #ifdef HAVE_STRUCT_LINGER
547 struct linger
*ling
= (struct linger
*) optval
;
549 return scm_cons (scm_long2num (ling
->l_onoff
),
550 scm_long2num (ling
->l_linger
));
552 return scm_cons (scm_long2num (*(int *) optval
),
560 || ioptname
== SO_SNDBUF
563 || ioptname
== SO_RCVBUF
567 return scm_long2num (*(size_t *) optval
);
570 return scm_long2num (*(int *) optval
);
574 SCM_DEFINE (scm_setsockopt
, "setsockopt", 4, 0, 0,
575 (SCM sock
, SCM level
, SCM optname
, SCM value
),
576 "Set the value of a particular socket option for the socket\n"
577 "port @var{sock}. @var{level} is an integer code for type of option\n"
578 "being set, e.g., @code{SOL_SOCKET} for socket-level options.\n"
579 "@var{optname} is an\n"
580 "integer code for the option to set and should be specified using one of\n"
581 "the symbols @code{SO_DEBUG}, @code{SO_REUSEADDR} etc.\n"
582 "@var{value} is the value to which the option should be set. For\n"
583 "most options this must be an integer, but for @code{SO_LINGER} it must\n"
585 "The return value is unspecified.")
586 #define FUNC_NAME s_scm_setsockopt
590 /* size of optval is the largest supported option. */
591 #ifdef HAVE_STRUCT_LINGER
592 char optval
[sizeof (struct linger
)];
594 char optval
[sizeof (size_t)];
596 int ilevel
, ioptname
;
598 sock
= SCM_COERCE_OUTPORT (sock
);
600 SCM_VALIDATE_OPFPORT (1, sock
);
601 ilevel
= scm_to_int (level
);
602 ioptname
= scm_to_int (optname
);
604 fd
= SCM_FPORT_FDES (sock
);
606 if (ilevel
== SOL_SOCKET
)
609 if (ioptname
== SO_LINGER
)
611 #ifdef HAVE_STRUCT_LINGER
615 SCM_ASSERT (SCM_CONSP (value
), value
, SCM_ARG4
, FUNC_NAME
);
616 lv
= SCM_NUM2LONG (4, SCM_CAR (value
));
617 ling
.l_onoff
= (int) lv
;
618 SCM_ASSERT_RANGE (SCM_ARG4
, value
, ling
.l_onoff
== lv
);
619 lv
= SCM_NUM2LONG (4, SCM_CDR (value
));
620 ling
.l_linger
= (int) lv
;
621 SCM_ASSERT_RANGE (SCM_ARG4
, value
, ling
.l_linger
== lv
);
622 optlen
= (int) sizeof (struct linger
);
623 memcpy (optval
, (void *) &ling
, optlen
);
628 SCM_ASSERT (SCM_CONSP (value
), value
, SCM_ARG4
, FUNC_NAME
);
629 /* timeout is ignored, but may as well validate it. */
630 lv
= SCM_NUM2LONG (4, SCM_CDR (value
));
632 SCM_ASSERT_RANGE (SCM_ARG4
, value
, ling
== lv
);
633 lv
= SCM_NUM2LONG (4, SCM_CAR (value
));
635 SCM_ASSERT_RANGE (SCM_ARG4
, value
, ling
== lv
);
636 optlen
= (int) sizeof (int);
637 (*(int *) optval
) = ling
;
644 || ioptname
== SO_SNDBUF
647 || ioptname
== SO_RCVBUF
651 long lv
= SCM_NUM2LONG (4, value
);
653 optlen
= (int) sizeof (size_t);
654 (*(size_t *) optval
) = (size_t) lv
;
659 /* Most options take an int. */
660 long lv
= SCM_NUM2LONG (4, value
);
663 SCM_ASSERT_RANGE (SCM_ARG4
, value
, val
== lv
);
664 optlen
= (int) sizeof (int);
665 (*(int *) optval
) = val
;
667 if (setsockopt (fd
, ilevel
, ioptname
, (void *) optval
, optlen
) == -1)
669 return SCM_UNSPECIFIED
;
673 SCM_DEFINE (scm_shutdown
, "shutdown", 2, 0, 0,
675 "Sockets can be closed simply by using @code{close-port}. The\n"
676 "@code{shutdown} procedure allows reception or transmission on a\n"
677 "connection to be shut down individually, according to the parameter\n"
681 "Stop receiving data for this socket. If further data arrives, reject it.\n"
683 "Stop trying to transmit data from this socket. Discard any\n"
684 "data waiting to be sent. Stop looking for acknowledgement of\n"
685 "data already sent; don't retransmit it if it is lost.\n"
687 "Stop both reception and transmission.\n"
689 "The return value is unspecified.")
690 #define FUNC_NAME s_scm_shutdown
693 sock
= SCM_COERCE_OUTPORT (sock
);
694 SCM_VALIDATE_OPFPORT (1, sock
);
695 fd
= SCM_FPORT_FDES (sock
);
696 if (shutdown (fd
, scm_to_signed_integer (how
, 0, 2)) == -1)
698 return SCM_UNSPECIFIED
;
702 /* convert fam/address/args into a sockaddr of the appropriate type.
703 args is modified by removing the arguments actually used.
704 which_arg and proc are used when reporting errors:
705 which_arg is the position of address in the original argument list.
706 proc is the name of the original procedure.
707 size returns the size of the structure allocated. */
709 static struct sockaddr
*
710 scm_fill_sockaddr (int fam
, SCM address
, SCM
*args
, int which_arg
,
711 const char *proc
, int *size
)
712 #define FUNC_NAME proc
718 struct sockaddr_in
*soka
;
722 SCM_VALIDATE_ULONG_COPY (which_arg
, address
, addr
);
723 SCM_VALIDATE_CONS (which_arg
+ 1, *args
);
724 port
= scm_to_int (SCM_CAR (*args
));
725 *args
= SCM_CDR (*args
);
726 soka
= (struct sockaddr_in
*) scm_malloc (sizeof (struct sockaddr_in
));
728 scm_memory_error (proc
);
729 /* 4.4BSD-style interface includes sin_len member and defines SIN_LEN,
732 soka
->sin_len
= sizeof (struct sockaddr_in
);
734 soka
->sin_family
= AF_INET
;
735 soka
->sin_addr
.s_addr
= htonl (addr
);
736 soka
->sin_port
= htons (port
);
737 *size
= sizeof (struct sockaddr_in
);
738 return (struct sockaddr
*) soka
;
745 struct sockaddr_in6
*soka
;
746 unsigned long flowinfo
= 0;
747 unsigned long scope_id
= 0;
749 SCM_VALIDATE_CONS (which_arg
+ 1, *args
);
750 port
= scm_to_int (SCM_CAR (*args
));
751 *args
= SCM_CDR (*args
);
752 if (SCM_CONSP (*args
))
754 SCM_VALIDATE_ULONG_COPY (which_arg
+ 2, SCM_CAR (*args
), flowinfo
);
755 *args
= SCM_CDR (*args
);
756 if (SCM_CONSP (*args
))
758 SCM_VALIDATE_ULONG_COPY (which_arg
+ 3, SCM_CAR (*args
),
760 *args
= SCM_CDR (*args
);
763 soka
= (struct sockaddr_in6
*) scm_malloc (sizeof (struct sockaddr_in6
));
765 scm_memory_error (proc
);
767 soka
->sin6_len
= sizeof (struct sockaddr_in6
);
769 soka
->sin6_family
= AF_INET6
;
770 scm_to_ipv6 (soka
->sin6_addr
.s6_addr
, address
);
771 soka
->sin6_port
= htons (port
);
772 soka
->sin6_flowinfo
= flowinfo
;
773 #ifdef HAVE_SIN6_SCOPE_ID
774 soka
->sin6_scope_id
= scope_id
;
776 *size
= sizeof (struct sockaddr_in6
);
777 return (struct sockaddr
*) soka
;
780 #ifdef HAVE_UNIX_DOMAIN_SOCKETS
783 struct sockaddr_un
*soka
;
786 SCM_ASSERT (SCM_STRINGP (address
), address
, which_arg
, proc
);
787 /* the static buffer size in sockaddr_un seems to be arbitrary
788 and not necessarily a hard limit. e.g., the glibc manual
789 suggests it may be possible to declare it size 0. let's
790 ignore it. if the O/S doesn't like the size it will cause
791 connect/bind etc., to fail. sun_path is always the last
792 member of the structure. */
793 addr_size
= sizeof (struct sockaddr_un
)
794 + max (0, SCM_STRING_LENGTH (address
) + 1 - (sizeof soka
->sun_path
));
795 soka
= (struct sockaddr_un
*) scm_malloc (addr_size
);
797 scm_memory_error (proc
);
798 memset (soka
, 0, addr_size
); /* for sun_len: see sin_len above. */
799 soka
->sun_family
= AF_UNIX
;
800 memcpy (soka
->sun_path
, SCM_STRING_CHARS (address
),
801 SCM_STRING_LENGTH (address
));
802 *size
= SUN_LEN (soka
);
803 return (struct sockaddr
*) soka
;
807 scm_out_of_range (proc
, scm_from_int (fam
));
812 SCM_DEFINE (scm_connect
, "connect", 3, 0, 1,
813 (SCM sock
, SCM fam
, SCM address
, SCM args
),
814 "Initiate a connection from a socket using a specified address\n"
815 "family to the address\n"
816 "specified by @var{address} and possibly @var{args}.\n"
817 "The format required for @var{address}\n"
818 "and @var{args} depends on the family of the socket.\n\n"
819 "For a socket of family @code{AF_UNIX},\n"
820 "only @var{address} is specified and must be a string with the\n"
821 "filename where the socket is to be created.\n\n"
822 "For a socket of family @code{AF_INET},\n"
823 "@var{address} must be an integer IPv4 host address and\n"
824 "@var{args} must be a single integer port number.\n\n"
825 "For a socket of family @code{AF_INET6},\n"
826 "@var{address} must be an integer IPv6 host address and\n"
827 "@var{args} may be up to three integers:\n"
828 "port [flowinfo] [scope_id],\n"
829 "where flowinfo and scope_id default to zero.\n\n"
830 "The return value is unspecified.")
831 #define FUNC_NAME s_scm_connect
834 struct sockaddr
*soka
;
837 sock
= SCM_COERCE_OUTPORT (sock
);
838 SCM_VALIDATE_OPFPORT (1, sock
);
839 fd
= SCM_FPORT_FDES (sock
);
840 soka
= scm_fill_sockaddr (scm_to_int (fam
), address
, &args
, 3, FUNC_NAME
,
842 if (connect (fd
, soka
, size
) == -1)
844 int save_errno
= errno
;
851 return SCM_UNSPECIFIED
;
855 SCM_DEFINE (scm_bind
, "bind", 3, 0, 1,
856 (SCM sock
, SCM fam
, SCM address
, SCM args
),
857 "Assign an address to the socket port @var{sock}.\n"
858 "Generally this only needs to be done for server sockets,\n"
859 "so they know where to look for incoming connections. A socket\n"
860 "without an address will be assigned one automatically when it\n"
861 "starts communicating.\n\n"
862 "The format of @var{address} and @var{args} depends\n"
863 "on the family of the socket.\n\n"
864 "For a socket of family @code{AF_UNIX}, only @var{address}\n"
865 "is specified and must be a string with the filename where\n"
866 "the socket is to be created.\n\n"
867 "For a socket of family @code{AF_INET}, @var{address}\n"
868 "must be an integer IPv4 address and @var{args}\n"
869 "must be a single integer port number.\n\n"
870 "The values of the following variables can also be used for\n"
872 "@defvar INADDR_ANY\n"
873 "Allow connections from any address.\n"
875 "@defvar INADDR_LOOPBACK\n"
876 "The address of the local host using the loopback device.\n"
878 "@defvar INADDR_BROADCAST\n"
879 "The broadcast address on the local network.\n"
881 "@defvar INADDR_NONE\n"
884 "For a socket of family @code{AF_INET6}, @var{address}\n"
885 "must be an integer IPv6 address and @var{args}\n"
886 "may be up to three integers:\n"
887 "port [flowinfo] [scope_id],\n"
888 "where flowinfo and scope_id default to zero.\n\n"
889 "The return value is unspecified.")
890 #define FUNC_NAME s_scm_bind
892 struct sockaddr
*soka
;
896 sock
= SCM_COERCE_OUTPORT (sock
);
897 SCM_VALIDATE_OPFPORT (1, sock
);
898 soka
= scm_fill_sockaddr (scm_to_int (fam
), address
, &args
, 3, FUNC_NAME
,
900 fd
= SCM_FPORT_FDES (sock
);
901 if (bind (fd
, soka
, size
) == -1)
903 int save_errno
= errno
;
910 return SCM_UNSPECIFIED
;
914 SCM_DEFINE (scm_listen
, "listen", 2, 0, 0,
915 (SCM sock
, SCM backlog
),
916 "Enable @var{sock} to accept connection\n"
917 "requests. @var{backlog} is an integer specifying\n"
918 "the maximum length of the queue for pending connections.\n"
919 "If the queue fills, new clients will fail to connect until\n"
920 "the server calls @code{accept} to accept a connection from\n"
922 "The return value is unspecified.")
923 #define FUNC_NAME s_scm_listen
926 sock
= SCM_COERCE_OUTPORT (sock
);
927 SCM_VALIDATE_OPFPORT (1, sock
);
928 fd
= SCM_FPORT_FDES (sock
);
929 if (listen (fd
, scm_to_int (backlog
)) == -1)
931 return SCM_UNSPECIFIED
;
935 /* Put the components of a sockaddr into a new SCM vector. */
937 scm_addr_vector (const struct sockaddr
*address
, int addr_size
,
940 short int fam
= address
->sa_family
;
948 const struct sockaddr_in
*nad
= (struct sockaddr_in
*) address
;
950 result
= scm_c_make_vector (3, SCM_UNSPECIFIED
);
952 SCM_VECTOR_SET(result
, 0, scm_ulong2num ((unsigned long) fam
));
953 SCM_VECTOR_SET(result
, 1, scm_ulong2num (ntohl (nad
->sin_addr
.s_addr
)));
954 SCM_VECTOR_SET(result
, 2, scm_ulong2num ((unsigned long) ntohs (nad
->sin_port
)));
960 const struct sockaddr_in6
*nad
= (struct sockaddr_in6
*) address
;
962 result
= scm_c_make_vector (5, SCM_UNSPECIFIED
);
963 SCM_VECTOR_SET(result
, 0, scm_ulong2num ((unsigned long) fam
));
964 SCM_VECTOR_SET(result
, 1, scm_from_ipv6 (nad
->sin6_addr
.s6_addr
));
965 SCM_VECTOR_SET(result
, 2, scm_ulong2num ((unsigned long) ntohs (nad
->sin6_port
)));
966 SCM_VECTOR_SET(result
, 3, scm_ulong2num ((unsigned long) nad
->sin6_flowinfo
));
967 #ifdef HAVE_SIN6_SCOPE_ID
968 SCM_VECTOR_SET(result
, 4, scm_ulong2num ((unsigned long) nad
->sin6_scope_id
));
970 SCM_VECTOR_SET(result
, 4, SCM_INUM0
);
975 #ifdef HAVE_UNIX_DOMAIN_SOCKETS
978 const struct sockaddr_un
*nad
= (struct sockaddr_un
*) address
;
980 result
= scm_c_make_vector (2, SCM_UNSPECIFIED
);
982 SCM_VECTOR_SET(result
, 0, scm_ulong2num ((unsigned long) fam
));
983 /* When addr_size is not enough to cover sun_path, do not try
985 if (addr_size
<= offsetof (struct sockaddr_un
, sun_path
))
986 SCM_VECTOR_SET(result
, 1, SCM_BOOL_F
);
988 SCM_VECTOR_SET(result
, 1, scm_mem2string (nad
->sun_path
,
989 strlen (nad
->sun_path
)));
994 scm_misc_error (proc
, "Unrecognised address family: ~A",
995 scm_list_1 (scm_from_int (fam
)));
1000 /* calculate the size of a buffer large enough to hold any supported
1001 sockaddr type. if the buffer isn't large enough, certain system
1002 calls will return a truncated address. */
1004 #if defined (HAVE_UNIX_DOMAIN_SOCKETS)
1005 #define MAX_SIZE_UN sizeof (struct sockaddr_un)
1007 #define MAX_SIZE_UN 0
1010 #if defined (HAVE_IPV6)
1011 #define MAX_SIZE_IN6 sizeof (struct sockaddr_in6)
1013 #define MAX_SIZE_IN6 0
1016 #define MAX_ADDR_SIZE max (max (sizeof (struct sockaddr_in), MAX_SIZE_IN6),\
1019 SCM_DEFINE (scm_accept
, "accept", 1, 0, 0,
1021 "Accept a connection on a bound, listening socket.\n"
1023 "are no pending connections in the queue, wait until\n"
1024 "one is available unless the non-blocking option has been\n"
1025 "set on the socket.\n\n"
1026 "The return value is a\n"
1027 "pair in which the @emph{car} is a new socket port for the\n"
1029 "the @emph{cdr} is an object with address information about the\n"
1030 "client which initiated the connection.\n\n"
1031 "@var{sock} does not become part of the\n"
1032 "connection and will continue to accept new requests.")
1033 #define FUNC_NAME s_scm_accept
1039 int addr_size
= MAX_ADDR_SIZE
;
1040 char max_addr
[MAX_ADDR_SIZE
];
1041 struct sockaddr
*addr
= (struct sockaddr
*) max_addr
;
1043 sock
= SCM_COERCE_OUTPORT (sock
);
1044 SCM_VALIDATE_OPFPORT (1, sock
);
1045 fd
= SCM_FPORT_FDES (sock
);
1046 newfd
= accept (fd
, addr
, &addr_size
);
1049 newsock
= SCM_SOCK_FD_TO_PORT (newfd
);
1050 address
= scm_addr_vector (addr
, addr_size
, FUNC_NAME
);
1051 return scm_cons (newsock
, address
);
1055 SCM_DEFINE (scm_getsockname
, "getsockname", 1, 0, 0,
1057 "Return the address of @var{sock}, in the same form as the\n"
1058 "object returned by @code{accept}. On many systems the address\n"
1059 "of a socket in the @code{AF_FILE} namespace cannot be read.")
1060 #define FUNC_NAME s_scm_getsockname
1063 int addr_size
= MAX_ADDR_SIZE
;
1064 char max_addr
[MAX_ADDR_SIZE
];
1065 struct sockaddr
*addr
= (struct sockaddr
*) max_addr
;
1067 sock
= SCM_COERCE_OUTPORT (sock
);
1068 SCM_VALIDATE_OPFPORT (1, sock
);
1069 fd
= SCM_FPORT_FDES (sock
);
1070 if (getsockname (fd
, addr
, &addr_size
) == -1)
1072 return scm_addr_vector (addr
, addr_size
, FUNC_NAME
);
1076 SCM_DEFINE (scm_getpeername
, "getpeername", 1, 0, 0,
1078 "Return the address that @var{sock}\n"
1079 "is connected to, in the same form as the object returned by\n"
1080 "@code{accept}. On many systems the address of a socket in the\n"
1081 "@code{AF_FILE} namespace cannot be read.")
1082 #define FUNC_NAME s_scm_getpeername
1085 int addr_size
= MAX_ADDR_SIZE
;
1086 char max_addr
[MAX_ADDR_SIZE
];
1087 struct sockaddr
*addr
= (struct sockaddr
*) max_addr
;
1089 sock
= SCM_COERCE_OUTPORT (sock
);
1090 SCM_VALIDATE_OPFPORT (1, sock
);
1091 fd
= SCM_FPORT_FDES (sock
);
1092 if (getpeername (fd
, addr
, &addr_size
) == -1)
1094 return scm_addr_vector (addr
, addr_size
, FUNC_NAME
);
1098 SCM_DEFINE (scm_recv
, "recv!", 2, 1, 0,
1099 (SCM sock
, SCM buf
, SCM flags
),
1100 "Receive data from a socket port.\n"
1101 "@var{sock} must already\n"
1102 "be bound to the address from which data is to be received.\n"
1103 "@var{buf} is a string into which\n"
1104 "the data will be written. The size of @var{buf} limits\n"
1106 "data which can be received: in the case of packet\n"
1107 "protocols, if a packet larger than this limit is encountered\n"
1109 "will be irrevocably lost.\n\n"
1110 "The optional @var{flags} argument is a value or\n"
1111 "bitwise OR of MSG_OOB, MSG_PEEK, MSG_DONTROUTE etc.\n\n"
1112 "The value returned is the number of bytes read from the\n"
1114 "Note that the data is read directly from the socket file\n"
1116 "any unread buffered port data is ignored.")
1117 #define FUNC_NAME s_scm_recv
1123 SCM_VALIDATE_OPFPORT (1, sock
);
1124 SCM_VALIDATE_STRING (2, buf
);
1125 if (SCM_UNBNDP (flags
))
1128 flg
= scm_to_int (flags
);
1129 fd
= SCM_FPORT_FDES (sock
);
1131 SCM_SYSCALL (rv
= recv (fd
, SCM_STRING_CHARS (buf
), SCM_STRING_LENGTH (buf
), flg
));
1135 return scm_from_int (rv
);
1139 SCM_DEFINE (scm_send
, "send", 2, 1, 0,
1140 (SCM sock
, SCM message
, SCM flags
),
1141 "Transmit the string @var{message} on a socket port @var{sock}.\n"
1142 "@var{sock} must already be bound to a destination address. The\n"
1143 "value returned is the number of bytes transmitted --\n"
1144 "it's possible for\n"
1145 "this to be less than the length of @var{message}\n"
1146 "if the socket is\n"
1147 "set to be non-blocking. The optional @var{flags} argument\n"
1149 "bitwise OR of MSG_OOB, MSG_PEEK, MSG_DONTROUTE etc.\n\n"
1150 "Note that the data is written directly to the socket\n"
1151 "file descriptor:\n"
1152 "any unflushed buffered port data is ignored.")
1153 #define FUNC_NAME s_scm_send
1159 sock
= SCM_COERCE_OUTPORT (sock
);
1160 SCM_VALIDATE_OPFPORT (1, sock
);
1161 SCM_VALIDATE_STRING (2, message
);
1162 if (SCM_UNBNDP (flags
))
1165 flg
= scm_to_int (flags
);
1166 fd
= SCM_FPORT_FDES (sock
);
1168 SCM_SYSCALL (rv
= send (fd
, SCM_STRING_CHARS (message
), SCM_STRING_LENGTH (message
), flg
));
1171 return scm_from_int (rv
);
1175 SCM_DEFINE (scm_recvfrom
, "recvfrom!", 2, 3, 0,
1176 (SCM sock
, SCM str
, SCM flags
, SCM start
, SCM end
),
1177 "Return data from the socket port @var{sock} and also\n"
1178 "information about where the data was received from.\n"
1179 "@var{sock} must already be bound to the address from which\n"
1180 "data is to be received. @code{str}, is a string into which the\n"
1181 "data will be written. The size of @var{str} limits the amount\n"
1182 "of data which can be received: in the case of packet protocols,\n"
1183 "if a packet larger than this limit is encountered then some\n"
1184 "data will be irrevocably lost.\n\n"
1185 "The optional @var{flags} argument is a value or bitwise OR of\n"
1186 "@code{MSG_OOB}, @code{MSG_PEEK}, @code{MSG_DONTROUTE} etc.\n\n"
1187 "The value returned is a pair: the @emph{car} is the number of\n"
1188 "bytes read from the socket and the @emph{cdr} an address object\n"
1189 "in the same form as returned by @code{accept}. The address\n"
1190 "will given as @code{#f} if not available, as is usually the\n"
1191 "case for stream sockets.\n\n"
1192 "The @var{start} and @var{end} arguments specify a substring of\n"
1193 "@var{str} to which the data should be written.\n\n"
1194 "Note that the data is read directly from the socket file\n"
1195 "descriptor: any unread buffered port data is ignored.")
1196 #define FUNC_NAME s_scm_recvfrom
1205 int addr_size
= MAX_ADDR_SIZE
;
1206 char max_addr
[MAX_ADDR_SIZE
];
1207 struct sockaddr
*addr
= (struct sockaddr
*) max_addr
;
1209 SCM_VALIDATE_OPFPORT (1, sock
);
1210 fd
= SCM_FPORT_FDES (sock
);
1211 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, str
, buf
, 4, start
, offset
,
1213 if (SCM_UNBNDP (flags
))
1216 SCM_VALIDATE_ULONG_COPY (3, flags
, flg
);
1218 /* recvfrom will not necessarily return an address. usually nothing
1219 is returned for stream sockets. */
1220 addr
->sa_family
= AF_UNSPEC
;
1221 SCM_SYSCALL (rv
= recvfrom (fd
, buf
+ offset
,
1226 if (addr
->sa_family
!= AF_UNSPEC
)
1227 address
= scm_addr_vector (addr
, addr_size
, FUNC_NAME
);
1229 address
= SCM_BOOL_F
;
1231 return scm_cons (scm_from_int (rv
), address
);
1235 SCM_DEFINE (scm_sendto
, "sendto", 4, 0, 1,
1236 (SCM sock
, SCM message
, SCM fam
, SCM address
, SCM args_and_flags
),
1237 "Transmit the string @var{message} on the socket port\n"
1239 "destination address is specified using the @var{fam},\n"
1240 "@var{address} and\n"
1241 "@var{args_and_flags} arguments, in a similar way to the\n"
1242 "@code{connect} procedure. @var{args_and_flags} contains\n"
1243 "the usual connection arguments optionally followed by\n"
1244 "a flags argument, which is a value or\n"
1245 "bitwise OR of MSG_OOB, MSG_PEEK, MSG_DONTROUTE etc.\n\n"
1246 "The value returned is the number of bytes transmitted --\n"
1247 "it's possible for\n"
1248 "this to be less than the length of @var{message} if the\n"
1250 "set to be non-blocking.\n"
1251 "Note that the data is written directly to the socket\n"
1252 "file descriptor:\n"
1253 "any unflushed buffered port data is ignored.")
1254 #define FUNC_NAME s_scm_sendto
1259 struct sockaddr
*soka
;
1262 sock
= SCM_COERCE_OUTPORT (sock
);
1263 SCM_VALIDATE_FPORT (1, sock
);
1264 SCM_VALIDATE_STRING (2, message
);
1265 fd
= SCM_FPORT_FDES (sock
);
1266 soka
= scm_fill_sockaddr (scm_to_int (fam
), address
, &args_and_flags
, 4,
1268 if (SCM_NULLP (args_and_flags
))
1272 SCM_VALIDATE_CONS (5, args_and_flags
);
1273 flg
= SCM_NUM2ULONG (5, SCM_CAR (args_and_flags
));
1275 SCM_SYSCALL (rv
= sendto (fd
, SCM_STRING_CHARS (message
),
1276 SCM_STRING_LENGTH (message
),
1280 int save_errno
= errno
;
1286 return scm_from_int (rv
);
1295 /* protocol families. */
1297 scm_c_define ("AF_UNSPEC", scm_from_int (AF_UNSPEC
));
1300 scm_c_define ("AF_UNIX", scm_from_int (AF_UNIX
));
1303 scm_c_define ("AF_INET", scm_from_int (AF_INET
));
1306 scm_c_define ("AF_INET6", scm_from_int (AF_INET6
));
1310 scm_c_define ("PF_UNSPEC", scm_from_int (PF_UNSPEC
));
1313 scm_c_define ("PF_UNIX", scm_from_int (PF_UNIX
));
1316 scm_c_define ("PF_INET", scm_from_int (PF_INET
));
1319 scm_c_define ("PF_INET6", scm_from_int (PF_INET6
));
1322 /* standard addresses. */
1324 scm_c_define ("INADDR_ANY", scm_ulong2num (INADDR_ANY
));
1326 #ifdef INADDR_BROADCAST
1327 scm_c_define ("INADDR_BROADCAST", scm_ulong2num (INADDR_BROADCAST
));
1330 scm_c_define ("INADDR_NONE", scm_ulong2num (INADDR_NONE
));
1332 #ifdef INADDR_LOOPBACK
1333 scm_c_define ("INADDR_LOOPBACK", scm_ulong2num (INADDR_LOOPBACK
));
1338 scm_c_define ("SOCK_STREAM", scm_from_int (SOCK_STREAM
));
1341 scm_c_define ("SOCK_DGRAM", scm_from_int (SOCK_DGRAM
));
1344 scm_c_define ("SOCK_RAW", scm_from_int (SOCK_RAW
));
1347 /* setsockopt level. */
1349 scm_c_define ("SOL_SOCKET", scm_from_int (SOL_SOCKET
));
1352 scm_c_define ("SOL_IP", scm_from_int (SOL_IP
));
1355 scm_c_define ("SOL_TCP", scm_from_int (SOL_TCP
));
1358 scm_c_define ("SOL_UDP", scm_from_int (SOL_UDP
));
1361 /* setsockopt names. */
1363 scm_c_define ("SO_DEBUG", scm_from_int (SO_DEBUG
));
1366 scm_c_define ("SO_REUSEADDR", scm_from_int (SO_REUSEADDR
));
1369 scm_c_define ("SO_STYLE", scm_from_int (SO_STYLE
));
1372 scm_c_define ("SO_TYPE", scm_from_int (SO_TYPE
));
1375 scm_c_define ("SO_ERROR", scm_from_int (SO_ERROR
));
1378 scm_c_define ("SO_DONTROUTE", scm_from_int (SO_DONTROUTE
));
1381 scm_c_define ("SO_BROADCAST", scm_from_int (SO_BROADCAST
));
1384 scm_c_define ("SO_SNDBUF", scm_from_int (SO_SNDBUF
));
1387 scm_c_define ("SO_RCVBUF", scm_from_int (SO_RCVBUF
));
1390 scm_c_define ("SO_KEEPALIVE", scm_from_int (SO_KEEPALIVE
));
1393 scm_c_define ("SO_OOBINLINE", scm_from_int (SO_OOBINLINE
));
1396 scm_c_define ("SO_NO_CHECK", scm_from_int (SO_NO_CHECK
));
1399 scm_c_define ("SO_PRIORITY", scm_from_int (SO_PRIORITY
));
1402 scm_c_define ("SO_LINGER", scm_from_int (SO_LINGER
));
1405 /* recv/send options. */
1407 scm_c_define ("MSG_OOB", scm_from_int (MSG_OOB
));
1410 scm_c_define ("MSG_PEEK", scm_from_int (MSG_PEEK
));
1412 #ifdef MSG_DONTROUTE
1413 scm_c_define ("MSG_DONTROUTE", scm_from_int (MSG_DONTROUTE
));
1417 scm_i_init_socket_Win32 ();
1420 scm_add_feature ("socket");
1422 #include "libguile/socket.x"