* win32-socket.c: #include <config.h> if HAVE_CONFIG_H.
[bpt/guile.git] / libguile / socket.c
1 /* Copyright (C) 1996,1997,1998,2000,2001, 2002 Free Software Foundation, Inc.
2 *
3 * This program is free software; you can redistribute it and/or modify
4 * it under the terms of the GNU General Public License as published by
5 * the Free Software Foundation; either version 2, or (at your option)
6 * any later version.
7 *
8 * This program is distributed in the hope that it will be useful,
9 * but WITHOUT ANY WARRANTY; without even the implied warranty of
10 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
11 * GNU General Public License for more details.
12 *
13 * You should have received a copy of the GNU General Public License
14 * along with this software; see the file COPYING. If not, write to
15 * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
16 * Boston, MA 02111-1307 USA
17 *
18 * As a special exception, the Free Software Foundation gives permission
19 * for additional uses of the text contained in its release of GUILE.
20 *
21 * The exception is that, if you link the GUILE library with other files
22 * to produce an executable, this does not by itself cause the
23 * resulting executable to be covered by the GNU General Public License.
24 * Your use of that executable is in no way restricted on account of
25 * linking the GUILE library code into it.
26 *
27 * This exception does not however invalidate any other reasons why
28 * the executable file might be covered by the GNU General Public License.
29 *
30 * This exception applies only to the code released by the
31 * Free Software Foundation under the name GUILE. If you copy
32 * code from other Free Software Foundation releases into a copy of
33 * GUILE, as the General Public License permits, the exception does
34 * not apply to the code that you add in this way. To avoid misleading
35 * anyone as to the status of such modified files, you must delete
36 * this exception notice from them.
37 *
38 * If you write modifications of your own for GUILE, it is your choice
39 * whether to permit this exception to apply to your modifications.
40 * If you do not wish that, delete this exception notice. */
41
42
43 \f
44
45 #if HAVE_CONFIG_H
46 # include <config.h>
47 #endif
48
49 #include <errno.h>
50
51 #include "libguile/_scm.h"
52 #include "libguile/unif.h"
53 #include "libguile/feature.h"
54 #include "libguile/fports.h"
55 #include "libguile/strings.h"
56 #include "libguile/vectors.h"
57
58 #include "libguile/validate.h"
59 #include "libguile/socket.h"
60
61 #ifdef __MINGW32__
62 #include "win32-socket.h"
63 #endif
64
65 #ifdef HAVE_STDINT_H
66 #include <stdint.h>
67 #endif
68 #ifdef HAVE_STRING_H
69 #include <string.h>
70 #endif
71 #ifdef HAVE_UNISTD_H
72 #include <unistd.h>
73 #endif
74 #include <sys/types.h>
75 #ifdef HAVE_WINSOCK2_H
76 #include <winsock2.h>
77 #else
78 #include <sys/socket.h>
79 #ifdef HAVE_UNIX_DOMAIN_SOCKETS
80 #include <sys/un.h>
81 #endif
82 #include <netinet/in.h>
83 #include <netdb.h>
84 #include <arpa/inet.h>
85 #endif
86
87 #if defined (HAVE_UNIX_DOMAIN_SOCKETS) && !defined (SUN_LEN)
88 #define SUN_LEN(ptr) ((size_t) (((struct sockaddr_un *) 0)->sun_path) \
89 + strlen ((ptr)->sun_path))
90 #endif
91
92 /* we are not currently using socklen_t. it's not defined on all systems,
93 so would need to be checked by configure. in the meantime, plain
94 int is the best alternative. */
95
96 \f
97
98 SCM_DEFINE (scm_htons, "htons", 1, 0, 0,
99 (SCM value),
100 "Convert a 16 bit quantity from host to network byte ordering.\n"
101 "@var{value} is packed into 2 bytes, which are then converted\n"
102 "and returned as a new integer.")
103 #define FUNC_NAME s_scm_htons
104 {
105 unsigned short c_in;
106
107 SCM_VALIDATE_INUM_COPY (1, value, c_in);
108 if (c_in != SCM_INUM (value))
109 SCM_OUT_OF_RANGE (1, value);
110
111 return SCM_MAKINUM (htons (c_in));
112 }
113 #undef FUNC_NAME
114
115 SCM_DEFINE (scm_ntohs, "ntohs", 1, 0, 0,
116 (SCM value),
117 "Convert a 16 bit quantity from network to host byte ordering.\n"
118 "@var{value} is packed into 2 bytes, which are then converted\n"
119 "and returned as a new integer.")
120 #define FUNC_NAME s_scm_ntohs
121 {
122 unsigned short c_in;
123
124 SCM_VALIDATE_INUM_COPY (1, value, c_in);
125 if (c_in != SCM_INUM (value))
126 SCM_OUT_OF_RANGE (1, value);
127
128 return SCM_MAKINUM (ntohs (c_in));
129 }
130 #undef FUNC_NAME
131
132 SCM_DEFINE (scm_htonl, "htonl", 1, 0, 0,
133 (SCM value),
134 "Convert a 32 bit quantity from host to network byte ordering.\n"
135 "@var{value} is packed into 4 bytes, which are then converted\n"
136 "and returned as a new integer.")
137 #define FUNC_NAME s_scm_htonl
138 {
139 scm_t_uint32 c_in = SCM_NUM2ULONG (1, value);
140
141 return scm_ulong2num (htonl (c_in));
142 }
143 #undef FUNC_NAME
144
145 SCM_DEFINE (scm_ntohl, "ntohl", 1, 0, 0,
146 (SCM value),
147 "Convert a 32 bit quantity from network to host byte ordering.\n"
148 "@var{value} is packed into 4 bytes, which are then converted\n"
149 "and returned as a new integer.")
150 #define FUNC_NAME s_scm_ntohl
151 {
152 scm_t_uint32 c_in = SCM_NUM2ULONG (1, value);
153
154 return scm_ulong2num (ntohl (c_in));
155 }
156 #undef FUNC_NAME
157
158 #ifndef HAVE_INET_ATON
159 /* for our definition in inet_aton.c, not usually needed. */
160 extern int inet_aton ();
161 #endif
162
163 SCM_DEFINE (scm_inet_aton, "inet-aton", 1, 0, 0,
164 (SCM address),
165 "Convert an IPv4 Internet address from printable string\n"
166 "(dotted decimal notation) to an integer. E.g.,\n\n"
167 "@lisp\n"
168 "(inet-aton \"127.0.0.1\") @result{} 2130706433\n"
169 "@end lisp")
170 #define FUNC_NAME s_scm_inet_aton
171 {
172 struct in_addr soka;
173
174 SCM_VALIDATE_STRING (1, address);
175 if (inet_aton (SCM_STRING_CHARS (address), &soka) == 0)
176 SCM_MISC_ERROR ("bad address", SCM_EOL);
177 return scm_ulong2num (ntohl (soka.s_addr));
178 }
179 #undef FUNC_NAME
180
181
182 SCM_DEFINE (scm_inet_ntoa, "inet-ntoa", 1, 0, 0,
183 (SCM inetid),
184 "Convert an IPv4 Internet address to a printable\n"
185 "(dotted decimal notation) string. E.g.,\n\n"
186 "@lisp\n"
187 "(inet-ntoa 2130706433) @result{} \"127.0.0.1\"\n"
188 "@end lisp")
189 #define FUNC_NAME s_scm_inet_ntoa
190 {
191 struct in_addr addr;
192 char *s;
193 SCM answer;
194 addr.s_addr = htonl (SCM_NUM2ULONG (1, inetid));
195 s = inet_ntoa (addr);
196 answer = scm_mem2string (s, strlen (s));
197 return answer;
198 }
199 #undef FUNC_NAME
200
201 #ifdef HAVE_INET_NETOF
202 SCM_DEFINE (scm_inet_netof, "inet-netof", 1, 0, 0,
203 (SCM address),
204 "Return the network number part of the given IPv4\n"
205 "Internet address. E.g.,\n\n"
206 "@lisp\n"
207 "(inet-netof 2130706433) @result{} 127\n"
208 "@end lisp")
209 #define FUNC_NAME s_scm_inet_netof
210 {
211 struct in_addr addr;
212 addr.s_addr = htonl (SCM_NUM2ULONG (1, address));
213 return scm_ulong2num ((unsigned long) inet_netof (addr));
214 }
215 #undef FUNC_NAME
216 #endif
217
218 #ifdef HAVE_INET_LNAOF
219 SCM_DEFINE (scm_lnaof, "inet-lnaof", 1, 0, 0,
220 (SCM address),
221 "Return the local-address-with-network part of the given\n"
222 "IPv4 Internet address, using the obsolete class A/B/C system.\n"
223 "E.g.,\n\n"
224 "@lisp\n"
225 "(inet-lnaof 2130706433) @result{} 1\n"
226 "@end lisp")
227 #define FUNC_NAME s_scm_lnaof
228 {
229 struct in_addr addr;
230 addr.s_addr = htonl (SCM_NUM2ULONG (1, address));
231 return scm_ulong2num ((unsigned long) inet_lnaof (addr));
232 }
233 #undef FUNC_NAME
234 #endif
235
236 #ifdef HAVE_INET_MAKEADDR
237 SCM_DEFINE (scm_inet_makeaddr, "inet-makeaddr", 2, 0, 0,
238 (SCM net, SCM lna),
239 "Make an IPv4 Internet address by combining the network number\n"
240 "@var{net} with the local-address-within-network number\n"
241 "@var{lna}. E.g.,\n\n"
242 "@lisp\n"
243 "(inet-makeaddr 127 1) @result{} 2130706433\n"
244 "@end lisp")
245 #define FUNC_NAME s_scm_inet_makeaddr
246 {
247 struct in_addr addr;
248 unsigned long netnum;
249 unsigned long lnanum;
250
251 netnum = SCM_NUM2ULONG (1, net);
252 lnanum = SCM_NUM2ULONG (2, lna);
253 addr = inet_makeaddr (netnum, lnanum);
254 return scm_ulong2num (ntohl (addr.s_addr));
255 }
256 #undef FUNC_NAME
257 #endif
258
259 #ifdef HAVE_IPV6
260
261 /* flip a 128 bit IPv6 address between host and network order. */
262 #ifdef WORDS_BIGENDIAN
263 #define FLIP_NET_HOST_128(addr)
264 #else
265 #define FLIP_NET_HOST_128(addr)\
266 {\
267 int i;\
268 \
269 for (i = 0; i < 8; i++)\
270 {\
271 char c = (addr)[i];\
272 \
273 (addr)[i] = (addr)[15 - i];\
274 (addr)[15 - i] = c;\
275 }\
276 }
277 #endif
278
279 /* convert a 128 bit IPv6 address in network order to a host ordered
280 SCM integer. */
281 static SCM ipv6_net_to_num (const char *src)
282 {
283 int big_digits = 128 / SCM_BITSPERDIG;
284 const int bytes_per_dig = SCM_BITSPERDIG / 8;
285 char addr[16];
286 char *ptr = addr;
287 SCM result;
288
289 memcpy (addr, src, 16);
290 /* get rid of leading zeros. */
291 while (big_digits > 0)
292 {
293 long test = 0;
294
295 memcpy (&test, ptr, bytes_per_dig);
296 if (test != 0)
297 break;
298 ptr += bytes_per_dig;
299 big_digits--;
300 }
301 FLIP_NET_HOST_128 (addr);
302 if (big_digits * bytes_per_dig <= sizeof (unsigned long))
303 {
304 /* this is just so that we use INUM where possible. */
305 unsigned long l_addr;
306
307 memcpy (&l_addr, addr, sizeof (unsigned long));
308 result = scm_ulong2num (l_addr);
309 }
310 else
311 {
312 result = scm_i_mkbig (big_digits, 0);
313 memcpy (SCM_BDIGITS (result), addr, big_digits * bytes_per_dig);
314 }
315 return result;
316 }
317
318 /* convert a host ordered SCM integer to a 128 bit IPv6 address in
319 network order. */
320 static void ipv6_num_to_net (SCM src, char *dst)
321 {
322 if (SCM_INUMP (src))
323 {
324 scm_t_uint32 addr = htonl (SCM_INUM (src));
325
326 memset (dst, 0, 12);
327 memcpy (dst + 12, &addr, 4);
328 }
329 else
330 {
331 memset (dst, 0, 16);
332 memcpy (dst, SCM_BDIGITS (src),
333 SCM_NUMDIGS (src) * (SCM_BITSPERDIG / 8));
334 FLIP_NET_HOST_128 (dst);
335 }
336 }
337
338 /* check that an SCM variable contains an IPv6 integer address. */
339 #define VALIDATE_INET6(which_arg, address)\
340 if (SCM_INUMP (address))\
341 SCM_ASSERT_RANGE (which_arg, address, SCM_INUM (address) >= 0);\
342 else\
343 {\
344 SCM_VALIDATE_BIGINT (which_arg, address);\
345 SCM_ASSERT_RANGE (which_arg, address,\
346 !SCM_BIGSIGN (address)\
347 && (SCM_BITSPERDIG\
348 * SCM_NUMDIGS (address) <= 128));\
349 }
350
351 #ifdef HAVE_INET_PTON
352 SCM_DEFINE (scm_inet_pton, "inet-pton", 2, 0, 0,
353 (SCM family, SCM address),
354 "Convert a string containing a printable network address to\n"
355 "an integer address. Note that unlike the C version of this\n"
356 "function,\n"
357 "the result is an integer with normal host byte ordering.\n"
358 "@var{family} can be @code{AF_INET} or @code{AF_INET6}. E.g.,\n\n"
359 "@lisp\n"
360 "(inet-pton AF_INET \"127.0.0.1\") @result{} 2130706433\n"
361 "(inet-pton AF_INET6 \"::1\") @result{} 1\n"
362 "@end lisp")
363 #define FUNC_NAME s_scm_inet_pton
364 {
365 int af;
366 char *src;
367 char dst[16];
368 int rv;
369
370 SCM_VALIDATE_INUM_COPY (1, family, af);
371 SCM_ASSERT_RANGE (1, family, af == AF_INET || af == AF_INET6);
372 SCM_VALIDATE_STRING_COPY (2, address, src);
373 rv = inet_pton (af, src, dst);
374 if (rv == -1)
375 SCM_SYSERROR;
376 else if (rv == 0)
377 SCM_MISC_ERROR ("Bad address", SCM_EOL);
378 if (af == AF_INET)
379 return scm_ulong2num (ntohl (*(scm_t_uint32 *) dst));
380 else
381 return ipv6_net_to_num ((char *) dst);
382 }
383 #undef FUNC_NAME
384 #endif
385
386 #ifdef HAVE_INET_NTOP
387 SCM_DEFINE (scm_inet_ntop, "inet-ntop", 2, 0, 0,
388 (SCM family, SCM address),
389 "Convert a network address into a printable string.\n"
390 "Note that unlike the C version of this function,\n"
391 "the input is an integer with normal host byte ordering.\n"
392 "@var{family} can be @code{AF_INET} or @code{AF_INET6}. E.g.,\n\n"
393 "@lisp\n"
394 "(inet-ntop AF_INET 2130706433) @result{} \"127.0.0.1\"\n"
395 "(inet-ntop AF_INET6 (- (expt 2 128) 1)) @result{}\n"
396 "ffff:ffff:ffff:ffff:ffff:ffff:ffff:ffff\n"
397 "@end lisp")
398 #define FUNC_NAME s_scm_inet_ntop
399 {
400 int af;
401 #ifdef INET6_ADDRSTRLEN
402 char dst[INET6_ADDRSTRLEN];
403 #else
404 char dst[46];
405 #endif
406 char addr6[16];
407
408 SCM_VALIDATE_INUM_COPY (1, family, af);
409 SCM_ASSERT_RANGE (1, family, af == AF_INET || af == AF_INET6);
410 if (af == AF_INET)
411 *(scm_t_uint32 *) addr6 = htonl (SCM_NUM2ULONG (2, address));
412 else
413 {
414 VALIDATE_INET6 (2, address);
415 ipv6_num_to_net (address, addr6);
416 }
417 if (inet_ntop (af, &addr6, dst, sizeof dst) == NULL)
418 SCM_SYSERROR;
419 return scm_makfrom0str (dst);
420 }
421 #undef FUNC_NAME
422 #endif
423
424 #endif /* HAVE_IPV6 */
425
426 SCM_SYMBOL (sym_socket, "socket");
427
428 #define SCM_SOCK_FD_TO_PORT(fd) scm_fdes_to_port (fd, "r+0", sym_socket)
429
430 SCM_DEFINE (scm_socket, "socket", 3, 0, 0,
431 (SCM family, SCM style, SCM proto),
432 "Return a new socket port of the type specified by @var{family},\n"
433 "@var{style} and @var{proto}. All three parameters are\n"
434 "integers. Supported values for @var{family} are\n"
435 "@code{AF_UNIX}, @code{AF_INET} and @code{AF_INET6}.\n"
436 "Typical values for @var{style} are @code{SOCK_STREAM},\n"
437 "@code{SOCK_DGRAM} and @code{SOCK_RAW}.\n\n"
438 "@var{proto} can be obtained from a protocol name using\n"
439 "@code{getprotobyname}. A value of zero specifies the default\n"
440 "protocol, which is usually right.\n\n"
441 "A single socket port cannot by used for communication until it\n"
442 "has been connected to another socket.")
443 #define FUNC_NAME s_scm_socket
444 {
445 int fd;
446
447 SCM_VALIDATE_INUM (1, family);
448 SCM_VALIDATE_INUM (2, style);
449 SCM_VALIDATE_INUM (3, proto);
450 fd = socket (SCM_INUM (family), SCM_INUM (style), SCM_INUM (proto));
451 if (fd == -1)
452 SCM_SYSERROR;
453 return SCM_SOCK_FD_TO_PORT (fd);
454 }
455 #undef FUNC_NAME
456
457 #ifdef HAVE_SOCKETPAIR
458 SCM_DEFINE (scm_socketpair, "socketpair", 3, 0, 0,
459 (SCM family, SCM style, SCM proto),
460 "Return a pair of connected (but unnamed) socket ports of the\n"
461 "type specified by @var{family}, @var{style} and @var{proto}.\n"
462 "Many systems support only socket pairs of the @code{AF_UNIX}\n"
463 "family. Zero is likely to be the only meaningful value for\n"
464 "@var{proto}.")
465 #define FUNC_NAME s_scm_socketpair
466 {
467 int fam;
468 int fd[2];
469
470 SCM_VALIDATE_INUM (1, family);
471 SCM_VALIDATE_INUM (2, style);
472 SCM_VALIDATE_INUM (3, proto);
473
474 fam = SCM_INUM (family);
475
476 if (socketpair (fam, SCM_INUM (style), SCM_INUM (proto), fd) == -1)
477 SCM_SYSERROR;
478
479 return scm_cons (SCM_SOCK_FD_TO_PORT (fd[0]), SCM_SOCK_FD_TO_PORT (fd[1]));
480 }
481 #undef FUNC_NAME
482 #endif
483
484 SCM_DEFINE (scm_getsockopt, "getsockopt", 3, 0, 0,
485 (SCM sock, SCM level, SCM optname),
486 "Return the value of a particular socket option for the socket\n"
487 "port @var{sock}. @var{level} is an integer code for type of\n"
488 "option being requested, e.g., @code{SOL_SOCKET} for\n"
489 "socket-level options. @var{optname} is an integer code for the\n"
490 "option required and should be specified using one of the\n"
491 "symbols @code{SO_DEBUG}, @code{SO_REUSEADDR} etc.\n\n"
492 "The returned value is typically an integer but @code{SO_LINGER}\n"
493 "returns a pair of integers.")
494 #define FUNC_NAME s_scm_getsockopt
495 {
496 int fd;
497 /* size of optval is the largest supported option. */
498 #ifdef HAVE_STRUCT_LINGER
499 char optval[sizeof (struct linger)];
500 int optlen = sizeof (struct linger);
501 #else
502 char optval[sizeof (size_t)];
503 int optlen = sizeof (size_t);
504 #endif
505 int ilevel;
506 int ioptname;
507
508 sock = SCM_COERCE_OUTPORT (sock);
509 SCM_VALIDATE_OPFPORT (1, sock);
510 SCM_VALIDATE_INUM_COPY (2, level, ilevel);
511 SCM_VALIDATE_INUM_COPY (3, optname, ioptname);
512
513 fd = SCM_FPORT_FDES (sock);
514 if (getsockopt (fd, ilevel, ioptname, (void *) optval, &optlen) == -1)
515 SCM_SYSERROR;
516
517 if (ilevel == SOL_SOCKET)
518 {
519 #ifdef SO_LINGER
520 if (ioptname == SO_LINGER)
521 {
522 #ifdef HAVE_STRUCT_LINGER
523 struct linger *ling = (struct linger *) optval;
524
525 return scm_cons (scm_long2num (ling->l_onoff),
526 scm_long2num (ling->l_linger));
527 #else
528 return scm_cons (scm_long2num (*(int *) optval),
529 SCM_MAKINUM (0));
530 #endif
531 }
532 else
533 #endif
534 if (0
535 #ifdef SO_SNDBUF
536 || ioptname == SO_SNDBUF
537 #endif
538 #ifdef SO_RCVBUF
539 || ioptname == SO_RCVBUF
540 #endif
541 )
542 {
543 return scm_long2num (*(size_t *) optval);
544 }
545 }
546 return scm_long2num (*(int *) optval);
547 }
548 #undef FUNC_NAME
549
550 SCM_DEFINE (scm_setsockopt, "setsockopt", 4, 0, 0,
551 (SCM sock, SCM level, SCM optname, SCM value),
552 "Set the value of a particular socket option for the socket\n"
553 "port @var{sock}. @var{level} is an integer code for type of option\n"
554 "being set, e.g., @code{SOL_SOCKET} for socket-level options.\n"
555 "@var{optname} is an\n"
556 "integer code for the option to set and should be specified using one of\n"
557 "the symbols @code{SO_DEBUG}, @code{SO_REUSEADDR} etc.\n"
558 "@var{value} is the value to which the option should be set. For\n"
559 "most options this must be an integer, but for @code{SO_LINGER} it must\n"
560 "be a pair.\n\n"
561 "The return value is unspecified.")
562 #define FUNC_NAME s_scm_setsockopt
563 {
564 int fd;
565 int optlen = -1;
566 /* size of optval is the largest supported option. */
567 #ifdef HAVE_STRUCT_LINGER
568 char optval[sizeof (struct linger)];
569 #else
570 char optval[sizeof (size_t)];
571 #endif
572 int ilevel, ioptname;
573
574 sock = SCM_COERCE_OUTPORT (sock);
575
576 SCM_VALIDATE_OPFPORT (1, sock);
577 SCM_VALIDATE_INUM_COPY (2, level, ilevel);
578 SCM_VALIDATE_INUM_COPY (3, optname, ioptname);
579
580 fd = SCM_FPORT_FDES (sock);
581
582 if (ilevel == SOL_SOCKET)
583 {
584 #ifdef SO_LINGER
585 if (ioptname == SO_LINGER)
586 {
587 #ifdef HAVE_STRUCT_LINGER
588 struct linger ling;
589 long lv;
590
591 SCM_ASSERT (SCM_CONSP (value), value, SCM_ARG4, FUNC_NAME);
592 lv = SCM_NUM2LONG (4, SCM_CAR (value));
593 ling.l_onoff = (int) lv;
594 SCM_ASSERT_RANGE (SCM_ARG4, value, ling.l_onoff == lv);
595 lv = SCM_NUM2LONG (4, SCM_CDR (value));
596 ling.l_linger = (int) lv;
597 SCM_ASSERT_RANGE (SCM_ARG4, value, ling.l_linger == lv);
598 optlen = (int) sizeof (struct linger);
599 memcpy (optval, (void *) &ling, optlen);
600 #else
601 int ling;
602 long lv;
603
604 SCM_ASSERT (SCM_CONSP (value), value, SCM_ARG4, FUNC_NAME);
605 /* timeout is ignored, but may as well validate it. */
606 lv = SCM_NUM2LONG (4, SCM_CDR (value));
607 ling = (int) lv;
608 SCM_ASSERT_RANGE (SCM_ARG4, value, ling == lv);
609 lv = SCM_NUM2LONG (4, SCM_CAR (value));
610 ling = (int) lv;
611 SCM_ASSERT_RANGE (SCM_ARG4, value, ling == lv);
612 optlen = (int) sizeof (int);
613 (*(int *) optval) = ling;
614 #endif
615 }
616 else
617 #endif
618 if (0
619 #ifdef SO_SNDBUF
620 || ioptname == SO_SNDBUF
621 #endif
622 #ifdef SO_RCVBUF
623 || ioptname == SO_RCVBUF
624 #endif
625 )
626 {
627 long lv = SCM_NUM2LONG (4, value);
628
629 optlen = (int) sizeof (size_t);
630 (*(size_t *) optval) = (size_t) lv;
631 }
632 }
633 if (optlen == -1)
634 {
635 /* Most options take an int. */
636 long lv = SCM_NUM2LONG (4, value);
637 int val = (int) lv;
638
639 SCM_ASSERT_RANGE (SCM_ARG4, value, val == lv);
640 optlen = (int) sizeof (int);
641 (*(int *) optval) = val;
642 }
643 if (setsockopt (fd, ilevel, ioptname, (void *) optval, optlen) == -1)
644 SCM_SYSERROR;
645 return SCM_UNSPECIFIED;
646 }
647 #undef FUNC_NAME
648
649 SCM_DEFINE (scm_shutdown, "shutdown", 2, 0, 0,
650 (SCM sock, SCM how),
651 "Sockets can be closed simply by using @code{close-port}. The\n"
652 "@code{shutdown} procedure allows reception or transmission on a\n"
653 "connection to be shut down individually, according to the parameter\n"
654 "@var{how}:\n\n"
655 "@table @asis\n"
656 "@item 0\n"
657 "Stop receiving data for this socket. If further data arrives, reject it.\n"
658 "@item 1\n"
659 "Stop trying to transmit data from this socket. Discard any\n"
660 "data waiting to be sent. Stop looking for acknowledgement of\n"
661 "data already sent; don't retransmit it if it is lost.\n"
662 "@item 2\n"
663 "Stop both reception and transmission.\n"
664 "@end table\n\n"
665 "The return value is unspecified.")
666 #define FUNC_NAME s_scm_shutdown
667 {
668 int fd;
669 sock = SCM_COERCE_OUTPORT (sock);
670 SCM_VALIDATE_OPFPORT (1, sock);
671 SCM_VALIDATE_INUM (2, how);
672 SCM_ASSERT_RANGE(2, how,0 <= SCM_INUM (how) && 2 >= SCM_INUM (how));
673 fd = SCM_FPORT_FDES (sock);
674 if (shutdown (fd, SCM_INUM (how)) == -1)
675 SCM_SYSERROR;
676 return SCM_UNSPECIFIED;
677 }
678 #undef FUNC_NAME
679
680 /* convert fam/address/args into a sockaddr of the appropriate type.
681 args is modified by removing the arguments actually used.
682 which_arg and proc are used when reporting errors:
683 which_arg is the position of address in the original argument list.
684 proc is the name of the original procedure.
685 size returns the size of the structure allocated. */
686
687 static struct sockaddr *
688 scm_fill_sockaddr (int fam, SCM address, SCM *args, int which_arg,
689 const char *proc, int *size)
690 #define FUNC_NAME proc
691 {
692 switch (fam)
693 {
694 case AF_INET:
695 {
696 struct sockaddr_in *soka;
697 unsigned long addr;
698 int port;
699
700 SCM_VALIDATE_ULONG_COPY (which_arg, address, addr);
701 SCM_VALIDATE_CONS (which_arg + 1, *args);
702 SCM_VALIDATE_INUM_COPY (which_arg + 1, SCM_CAR (*args), port);
703 *args = SCM_CDR (*args);
704 soka = (struct sockaddr_in *) scm_malloc (sizeof (struct sockaddr_in));
705 if (!soka)
706 scm_memory_error (proc);
707 /* 4.4BSD-style interface includes sin_len member and defines SIN_LEN,
708 4.3BSD does not. */
709 #ifdef SIN_LEN
710 soka->sin_len = sizeof (struct sockaddr_in);
711 #endif
712 soka->sin_family = AF_INET;
713 soka->sin_addr.s_addr = htonl (addr);
714 soka->sin_port = htons (port);
715 *size = sizeof (struct sockaddr_in);
716 return (struct sockaddr *) soka;
717 }
718 #ifdef HAVE_IPV6
719 case AF_INET6:
720 {
721 /* see RFC2553. */
722 int port;
723 struct sockaddr_in6 *soka;
724 unsigned long flowinfo = 0;
725 unsigned long scope_id = 0;
726
727 VALIDATE_INET6 (which_arg, address);
728 SCM_VALIDATE_CONS (which_arg + 1, *args);
729 SCM_VALIDATE_INUM_COPY (which_arg + 1, SCM_CAR (*args), port);
730 *args = SCM_CDR (*args);
731 if (SCM_CONSP (*args))
732 {
733 SCM_VALIDATE_ULONG_COPY (which_arg + 2, SCM_CAR (*args), flowinfo);
734 *args = SCM_CDR (*args);
735 if (SCM_CONSP (*args))
736 {
737 SCM_VALIDATE_ULONG_COPY (which_arg + 3, SCM_CAR (*args),
738 scope_id);
739 *args = SCM_CDR (*args);
740 }
741 }
742 soka = (struct sockaddr_in6 *) scm_malloc (sizeof (struct sockaddr_in6));
743 if (!soka)
744 scm_memory_error (proc);
745 #ifdef SIN_LEN6
746 soka->sin6_len = sizeof (struct sockaddr_in6);
747 #endif
748 soka->sin6_family = AF_INET6;
749 ipv6_num_to_net (address, soka->sin6_addr.s6_addr);
750 soka->sin6_port = htons (port);
751 soka->sin6_flowinfo = flowinfo;
752 #ifdef HAVE_SIN6_SCOPE_ID
753 soka->sin6_scope_id = scope_id;
754 #endif
755 *size = sizeof (struct sockaddr_in6);
756 return (struct sockaddr *) soka;
757 }
758 #endif
759 #ifdef HAVE_UNIX_DOMAIN_SOCKETS
760 case AF_UNIX:
761 {
762 struct sockaddr_un *soka;
763 int addr_size;
764
765 SCM_ASSERT (SCM_STRINGP (address), address, which_arg, proc);
766 /* the static buffer size in sockaddr_un seems to be arbitrary
767 and not necessarily a hard limit. e.g., the glibc manual
768 suggests it may be possible to declare it size 0. let's
769 ignore it. if the O/S doesn't like the size it will cause
770 connect/bind etc., to fail. sun_path is always the last
771 member of the structure. */
772 addr_size = sizeof (struct sockaddr_un)
773 + max (0, SCM_STRING_LENGTH (address) + 1 - (sizeof soka->sun_path));
774 soka = (struct sockaddr_un *) scm_malloc (addr_size);
775 if (!soka)
776 scm_memory_error (proc);
777 memset (soka, 0, addr_size); /* for sun_len: see sin_len above. */
778 soka->sun_family = AF_UNIX;
779 memcpy (soka->sun_path, SCM_STRING_CHARS (address),
780 SCM_STRING_LENGTH (address));
781 *size = SUN_LEN (soka);
782 return (struct sockaddr *) soka;
783 }
784 #endif
785 default:
786 scm_out_of_range (proc, SCM_MAKINUM (fam));
787 }
788 }
789 #undef FUNC_NAME
790
791 SCM_DEFINE (scm_connect, "connect", 3, 0, 1,
792 (SCM sock, SCM fam, SCM address, SCM args),
793 "Initiate a connection from a socket using a specified address\n"
794 "family to the address\n"
795 "specified by @var{address} and possibly @var{args}.\n"
796 "The format required for @var{address}\n"
797 "and @var{args} depends on the family of the socket.\n\n"
798 "For a socket of family @code{AF_UNIX},\n"
799 "only @var{address} is specified and must be a string with the\n"
800 "filename where the socket is to be created.\n\n"
801 "For a socket of family @code{AF_INET},\n"
802 "@var{address} must be an integer IPv4 host address and\n"
803 "@var{args} must be a single integer port number.\n\n"
804 "For a socket of family @code{AF_INET6},\n"
805 "@var{address} must be an integer IPv6 host address and\n"
806 "@var{args} may be up to three integers:\n"
807 "port [flowinfo] [scope_id],\n"
808 "where flowinfo and scope_id default to zero.\n\n"
809 "The return value is unspecified.")
810 #define FUNC_NAME s_scm_connect
811 {
812 int fd;
813 struct sockaddr *soka;
814 int size;
815
816 sock = SCM_COERCE_OUTPORT (sock);
817 SCM_VALIDATE_OPFPORT (1, sock);
818 SCM_VALIDATE_INUM (2, fam);
819 fd = SCM_FPORT_FDES (sock);
820 soka = scm_fill_sockaddr (SCM_INUM (fam), address, &args, 3, FUNC_NAME,
821 &size);
822 if (connect (fd, soka, size) == -1)
823 {
824 int save_errno = errno;
825
826 free (soka);
827 errno = save_errno;
828 SCM_SYSERROR;
829 }
830 free (soka);
831 return SCM_UNSPECIFIED;
832 }
833 #undef FUNC_NAME
834
835 SCM_DEFINE (scm_bind, "bind", 3, 0, 1,
836 (SCM sock, SCM fam, SCM address, SCM args),
837 "Assign an address to the socket port @var{sock}.\n"
838 "Generally this only needs to be done for server sockets,\n"
839 "so they know where to look for incoming connections. A socket\n"
840 "without an address will be assigned one automatically when it\n"
841 "starts communicating.\n\n"
842 "The format of @var{address} and @var{args} depends\n"
843 "on the family of the socket.\n\n"
844 "For a socket of family @code{AF_UNIX}, only @var{address}\n"
845 "is specified and must be a string with the filename where\n"
846 "the socket is to be created.\n\n"
847 "For a socket of family @code{AF_INET}, @var{address}\n"
848 "must be an integer IPv4 address and @var{args}\n"
849 "must be a single integer port number.\n\n"
850 "The values of the following variables can also be used for\n"
851 "@var{address}:\n\n"
852 "@defvar INADDR_ANY\n"
853 "Allow connections from any address.\n"
854 "@end defvar\n\n"
855 "@defvar INADDR_LOOPBACK\n"
856 "The address of the local host using the loopback device.\n"
857 "@end defvar\n\n"
858 "@defvar INADDR_BROADCAST\n"
859 "The broadcast address on the local network.\n"
860 "@end defvar\n\n"
861 "@defvar INADDR_NONE\n"
862 "No address.\n"
863 "@end defvar\n\n"
864 "For a socket of family @code{AF_INET6}, @var{address}\n"
865 "must be an integer IPv6 address and @var{args}\n"
866 "may be up to three integers:\n"
867 "port [flowinfo] [scope_id],\n"
868 "where flowinfo and scope_id default to zero.\n\n"
869 "The return value is unspecified.")
870 #define FUNC_NAME s_scm_bind
871 {
872 struct sockaddr *soka;
873 int size;
874 int fd;
875
876 sock = SCM_COERCE_OUTPORT (sock);
877 SCM_VALIDATE_OPFPORT (1, sock);
878 SCM_VALIDATE_INUM (2, fam);
879 soka = scm_fill_sockaddr (SCM_INUM (fam), address, &args, 3, FUNC_NAME,
880 &size);
881 fd = SCM_FPORT_FDES (sock);
882 if (bind (fd, soka, size) == -1)
883 {
884 int save_errno = errno;
885
886 free (soka);
887 errno = save_errno;
888 SCM_SYSERROR;
889 }
890 free (soka);
891 return SCM_UNSPECIFIED;
892 }
893 #undef FUNC_NAME
894
895 SCM_DEFINE (scm_listen, "listen", 2, 0, 0,
896 (SCM sock, SCM backlog),
897 "Enable @var{sock} to accept connection\n"
898 "requests. @var{backlog} is an integer specifying\n"
899 "the maximum length of the queue for pending connections.\n"
900 "If the queue fills, new clients will fail to connect until\n"
901 "the server calls @code{accept} to accept a connection from\n"
902 "the queue.\n\n"
903 "The return value is unspecified.")
904 #define FUNC_NAME s_scm_listen
905 {
906 int fd;
907 sock = SCM_COERCE_OUTPORT (sock);
908 SCM_VALIDATE_OPFPORT (1, sock);
909 SCM_VALIDATE_INUM (2, backlog);
910 fd = SCM_FPORT_FDES (sock);
911 if (listen (fd, SCM_INUM (backlog)) == -1)
912 SCM_SYSERROR;
913 return SCM_UNSPECIFIED;
914 }
915 #undef FUNC_NAME
916
917 /* Put the components of a sockaddr into a new SCM vector. */
918 static SCM
919 scm_addr_vector (const struct sockaddr *address, int addr_size,
920 const char *proc)
921 {
922 short int fam = address->sa_family;
923 SCM result =SCM_EOL;
924
925
926 switch (fam)
927 {
928 case AF_INET:
929 {
930 const struct sockaddr_in *nad = (struct sockaddr_in *) address;
931
932 result = scm_c_make_vector (3, SCM_UNSPECIFIED);
933
934 SCM_VECTOR_SET(result, 0, scm_ulong2num ((unsigned long) fam));
935 SCM_VECTOR_SET(result, 1, scm_ulong2num (ntohl (nad->sin_addr.s_addr)));
936 SCM_VECTOR_SET(result, 2, scm_ulong2num ((unsigned long) ntohs (nad->sin_port)));
937 }
938 break;
939 #ifdef HAVE_IPV6
940 case AF_INET6:
941 {
942 const struct sockaddr_in6 *nad = (struct sockaddr_in6 *) address;
943
944 result = scm_c_make_vector (5, SCM_UNSPECIFIED);
945 SCM_VECTOR_SET(result, 0, scm_ulong2num ((unsigned long) fam));
946 SCM_VECTOR_SET(result, 1, ipv6_net_to_num (nad->sin6_addr.s6_addr));
947 SCM_VECTOR_SET(result, 2, scm_ulong2num ((unsigned long) ntohs (nad->sin6_port)));
948 SCM_VECTOR_SET(result, 3, scm_ulong2num ((unsigned long) nad->sin6_flowinfo));
949 #ifdef HAVE_SIN6_SCOPE_ID
950 SCM_VECTOR_SET(result, 4, scm_ulong2num ((unsigned long) nad->sin6_scope_id));
951 #else
952 SCM_VECTOR_SET(result, 4, SCM_INUM0);
953 #endif
954 }
955 break;
956 #endif
957 #ifdef HAVE_UNIX_DOMAIN_SOCKETS
958 case AF_UNIX:
959 {
960 const struct sockaddr_un *nad = (struct sockaddr_un *) address;
961
962 result = scm_c_make_vector (2, SCM_UNSPECIFIED);
963
964 SCM_VECTOR_SET(result, 0, scm_ulong2num ((unsigned long) fam));
965 /* When addr_size is not enough to cover sun_path, do not try
966 to access it. */
967 if (addr_size <= offsetof (struct sockaddr_un, sun_path))
968 SCM_VECTOR_SET(result, 1, SCM_BOOL_F);
969 else
970 SCM_VECTOR_SET(result, 1, scm_mem2string (nad->sun_path,
971 strlen (nad->sun_path)));
972 }
973 break;
974 #endif
975 default:
976 scm_misc_error (proc, "Unrecognised address family: ~A",
977 scm_list_1 (SCM_MAKINUM (fam)));
978 }
979 return result;
980 }
981
982 /* calculate the size of a buffer large enough to hold any supported
983 sockaddr type. if the buffer isn't large enough, certain system
984 calls will return a truncated address. */
985
986 #if defined (HAVE_UNIX_DOMAIN_SOCKETS)
987 #define MAX_SIZE_UN sizeof (struct sockaddr_un)
988 #else
989 #define MAX_SIZE_UN 0
990 #endif
991
992 #if defined (HAVE_IPV6)
993 #define MAX_SIZE_IN6 sizeof (struct sockaddr_in6)
994 #else
995 #define MAX_SIZE_IN6 0
996 #endif
997
998 #define MAX_ADDR_SIZE max (max (sizeof (struct sockaddr_in), MAX_SIZE_IN6),\
999 MAX_SIZE_UN)
1000
1001 SCM_DEFINE (scm_accept, "accept", 1, 0, 0,
1002 (SCM sock),
1003 "Accept a connection on a bound, listening socket.\n"
1004 "If there\n"
1005 "are no pending connections in the queue, wait until\n"
1006 "one is available unless the non-blocking option has been\n"
1007 "set on the socket.\n\n"
1008 "The return value is a\n"
1009 "pair in which the @emph{car} is a new socket port for the\n"
1010 "connection and\n"
1011 "the @emph{cdr} is an object with address information about the\n"
1012 "client which initiated the connection.\n\n"
1013 "@var{sock} does not become part of the\n"
1014 "connection and will continue to accept new requests.")
1015 #define FUNC_NAME s_scm_accept
1016 {
1017 int fd;
1018 int newfd;
1019 SCM address;
1020 SCM newsock;
1021 int addr_size = MAX_ADDR_SIZE;
1022 char max_addr[MAX_ADDR_SIZE];
1023 struct sockaddr *addr = (struct sockaddr *) max_addr;
1024
1025 sock = SCM_COERCE_OUTPORT (sock);
1026 SCM_VALIDATE_OPFPORT (1, sock);
1027 fd = SCM_FPORT_FDES (sock);
1028 newfd = accept (fd, addr, &addr_size);
1029 if (newfd == -1)
1030 SCM_SYSERROR;
1031 newsock = SCM_SOCK_FD_TO_PORT (newfd);
1032 address = scm_addr_vector (addr, addr_size, FUNC_NAME);
1033 return scm_cons (newsock, address);
1034 }
1035 #undef FUNC_NAME
1036
1037 SCM_DEFINE (scm_getsockname, "getsockname", 1, 0, 0,
1038 (SCM sock),
1039 "Return the address of @var{sock}, in the same form as the\n"
1040 "object returned by @code{accept}. On many systems the address\n"
1041 "of a socket in the @code{AF_FILE} namespace cannot be read.")
1042 #define FUNC_NAME s_scm_getsockname
1043 {
1044 int fd;
1045 int addr_size = MAX_ADDR_SIZE;
1046 char max_addr[MAX_ADDR_SIZE];
1047 struct sockaddr *addr = (struct sockaddr *) max_addr;
1048
1049 sock = SCM_COERCE_OUTPORT (sock);
1050 SCM_VALIDATE_OPFPORT (1, sock);
1051 fd = SCM_FPORT_FDES (sock);
1052 if (getsockname (fd, addr, &addr_size) == -1)
1053 SCM_SYSERROR;
1054 return scm_addr_vector (addr, addr_size, FUNC_NAME);
1055 }
1056 #undef FUNC_NAME
1057
1058 SCM_DEFINE (scm_getpeername, "getpeername", 1, 0, 0,
1059 (SCM sock),
1060 "Return the address that @var{sock}\n"
1061 "is connected to, in the same form as the object returned by\n"
1062 "@code{accept}. On many systems the address of a socket in the\n"
1063 "@code{AF_FILE} namespace cannot be read.")
1064 #define FUNC_NAME s_scm_getpeername
1065 {
1066 int fd;
1067 int addr_size = MAX_ADDR_SIZE;
1068 char max_addr[MAX_ADDR_SIZE];
1069 struct sockaddr *addr = (struct sockaddr *) max_addr;
1070
1071 sock = SCM_COERCE_OUTPORT (sock);
1072 SCM_VALIDATE_OPFPORT (1, sock);
1073 fd = SCM_FPORT_FDES (sock);
1074 if (getpeername (fd, addr, &addr_size) == -1)
1075 SCM_SYSERROR;
1076 return scm_addr_vector (addr, addr_size, FUNC_NAME);
1077 }
1078 #undef FUNC_NAME
1079
1080 SCM_DEFINE (scm_recv, "recv!", 2, 1, 0,
1081 (SCM sock, SCM buf, SCM flags),
1082 "Receive data from a socket port.\n"
1083 "@var{sock} must already\n"
1084 "be bound to the address from which data is to be received.\n"
1085 "@var{buf} is a string into which\n"
1086 "the data will be written. The size of @var{buf} limits\n"
1087 "the amount of\n"
1088 "data which can be received: in the case of packet\n"
1089 "protocols, if a packet larger than this limit is encountered\n"
1090 "then some data\n"
1091 "will be irrevocably lost.\n\n"
1092 "The optional @var{flags} argument is a value or\n"
1093 "bitwise OR of MSG_OOB, MSG_PEEK, MSG_DONTROUTE etc.\n\n"
1094 "The value returned is the number of bytes read from the\n"
1095 "socket.\n\n"
1096 "Note that the data is read directly from the socket file\n"
1097 "descriptor:\n"
1098 "any unread buffered port data is ignored.")
1099 #define FUNC_NAME s_scm_recv
1100 {
1101 int rv;
1102 int fd;
1103 int flg;
1104
1105 SCM_VALIDATE_OPFPORT (1, sock);
1106 SCM_VALIDATE_STRING (2, buf);
1107 SCM_VALIDATE_INUM_DEF_COPY (3, flags,0, flg);
1108 fd = SCM_FPORT_FDES (sock);
1109
1110 SCM_SYSCALL (rv = recv (fd, SCM_STRING_CHARS (buf), SCM_STRING_LENGTH (buf), flg));
1111 if (rv == -1)
1112 SCM_SYSERROR;
1113
1114 return SCM_MAKINUM (rv);
1115 }
1116 #undef FUNC_NAME
1117
1118 SCM_DEFINE (scm_send, "send", 2, 1, 0,
1119 (SCM sock, SCM message, SCM flags),
1120 "Transmit the string @var{message} on a socket port @var{sock}.\n"
1121 "@var{sock} must already be bound to a destination address. The\n"
1122 "value returned is the number of bytes transmitted --\n"
1123 "it's possible for\n"
1124 "this to be less than the length of @var{message}\n"
1125 "if the socket is\n"
1126 "set to be non-blocking. The optional @var{flags} argument\n"
1127 "is a value or\n"
1128 "bitwise OR of MSG_OOB, MSG_PEEK, MSG_DONTROUTE etc.\n\n"
1129 "Note that the data is written directly to the socket\n"
1130 "file descriptor:\n"
1131 "any unflushed buffered port data is ignored.")
1132 #define FUNC_NAME s_scm_send
1133 {
1134 int rv;
1135 int fd;
1136 int flg;
1137
1138 sock = SCM_COERCE_OUTPORT (sock);
1139 SCM_VALIDATE_OPFPORT (1, sock);
1140 SCM_VALIDATE_STRING (2, message);
1141 SCM_VALIDATE_INUM_DEF_COPY (3, flags,0, flg);
1142 fd = SCM_FPORT_FDES (sock);
1143
1144 SCM_SYSCALL (rv = send (fd, SCM_STRING_CHARS (message), SCM_STRING_LENGTH (message), flg));
1145 if (rv == -1)
1146 SCM_SYSERROR;
1147 return SCM_MAKINUM (rv);
1148 }
1149 #undef FUNC_NAME
1150
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
1173 {
1174 int rv;
1175 int fd;
1176 int flg;
1177 char *buf;
1178 int offset;
1179 int cend;
1180 SCM address;
1181 int addr_size = MAX_ADDR_SIZE;
1182 char max_addr[MAX_ADDR_SIZE];
1183 struct sockaddr *addr = (struct sockaddr *) max_addr;
1184
1185 SCM_VALIDATE_OPFPORT (1, sock);
1186 fd = SCM_FPORT_FDES (sock);
1187 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, str, buf, 4, start, offset,
1188 5, end, cend);
1189 if (SCM_UNBNDP (flags))
1190 flg = 0;
1191 else
1192 SCM_VALIDATE_ULONG_COPY (3, flags, flg);
1193
1194 /* recvfrom will not necessarily return an address. usually nothing
1195 is returned for stream sockets. */
1196 addr->sa_family = AF_UNSPEC;
1197 SCM_SYSCALL (rv = recvfrom (fd, buf + offset,
1198 cend - offset, flg,
1199 addr, &addr_size));
1200 if (rv == -1)
1201 SCM_SYSERROR;
1202 if (addr->sa_family != AF_UNSPEC)
1203 address = scm_addr_vector (addr, addr_size, FUNC_NAME);
1204 else
1205 address = SCM_BOOL_F;
1206
1207 return scm_cons (SCM_MAKINUM (rv), address);
1208 }
1209 #undef FUNC_NAME
1210
1211 SCM_DEFINE (scm_sendto, "sendto", 4, 0, 1,
1212 (SCM sock, SCM message, SCM fam, SCM address, SCM args_and_flags),
1213 "Transmit the string @var{message} on the socket port\n"
1214 "@var{sock}. The\n"
1215 "destination address is specified using the @var{fam},\n"
1216 "@var{address} and\n"
1217 "@var{args_and_flags} arguments, in a similar way to the\n"
1218 "@code{connect} procedure. @var{args_and_flags} contains\n"
1219 "the usual connection arguments optionally followed by\n"
1220 "a flags argument, which is a value or\n"
1221 "bitwise OR of MSG_OOB, MSG_PEEK, MSG_DONTROUTE etc.\n\n"
1222 "The value returned is the number of bytes transmitted --\n"
1223 "it's possible for\n"
1224 "this to be less than the length of @var{message} if the\n"
1225 "socket is\n"
1226 "set to be non-blocking.\n"
1227 "Note that the data is written directly to the socket\n"
1228 "file descriptor:\n"
1229 "any unflushed buffered port data is ignored.")
1230 #define FUNC_NAME s_scm_sendto
1231 {
1232 int rv;
1233 int fd;
1234 int flg;
1235 struct sockaddr *soka;
1236 int size;
1237
1238 sock = SCM_COERCE_OUTPORT (sock);
1239 SCM_VALIDATE_FPORT (1, sock);
1240 SCM_VALIDATE_STRING (2, message);
1241 SCM_VALIDATE_INUM (3, fam);
1242 fd = SCM_FPORT_FDES (sock);
1243 soka = scm_fill_sockaddr (SCM_INUM (fam), address, &args_and_flags, 4,
1244 FUNC_NAME, &size);
1245 if (SCM_NULLP (args_and_flags))
1246 flg = 0;
1247 else
1248 {
1249 SCM_VALIDATE_CONS (5, args_and_flags);
1250 flg = SCM_NUM2ULONG (5, SCM_CAR (args_and_flags));
1251 }
1252 SCM_SYSCALL (rv = sendto (fd, SCM_STRING_CHARS (message),
1253 SCM_STRING_LENGTH (message),
1254 flg, soka, size));
1255 if (rv == -1)
1256 {
1257 int save_errno = errno;
1258 free (soka);
1259 errno = save_errno;
1260 SCM_SYSERROR;
1261 }
1262 free (soka);
1263 return SCM_MAKINUM (rv);
1264 }
1265 #undef FUNC_NAME
1266 \f
1267
1268
1269 void
1270 scm_init_socket ()
1271 {
1272 /* protocol families. */
1273 #ifdef AF_UNSPEC
1274 scm_c_define ("AF_UNSPEC", SCM_MAKINUM (AF_UNSPEC));
1275 #endif
1276 #ifdef AF_UNIX
1277 scm_c_define ("AF_UNIX", SCM_MAKINUM (AF_UNIX));
1278 #endif
1279 #ifdef AF_INET
1280 scm_c_define ("AF_INET", SCM_MAKINUM (AF_INET));
1281 #endif
1282 #ifdef AF_INET6
1283 scm_c_define ("AF_INET6", SCM_MAKINUM (AF_INET6));
1284 #endif
1285
1286 #ifdef PF_UNSPEC
1287 scm_c_define ("PF_UNSPEC", SCM_MAKINUM (PF_UNSPEC));
1288 #endif
1289 #ifdef PF_UNIX
1290 scm_c_define ("PF_UNIX", SCM_MAKINUM (PF_UNIX));
1291 #endif
1292 #ifdef PF_INET
1293 scm_c_define ("PF_INET", SCM_MAKINUM (PF_INET));
1294 #endif
1295 #ifdef PF_INET6
1296 scm_c_define ("PF_INET6", SCM_MAKINUM (PF_INET6));
1297 #endif
1298
1299 /* standard addresses. */
1300 #ifdef INADDR_ANY
1301 scm_c_define ("INADDR_ANY", scm_ulong2num (INADDR_ANY));
1302 #endif
1303 #ifdef INADDR_BROADCAST
1304 scm_c_define ("INADDR_BROADCAST", scm_ulong2num (INADDR_BROADCAST));
1305 #endif
1306 #ifdef INADDR_NONE
1307 scm_c_define ("INADDR_NONE", scm_ulong2num (INADDR_NONE));
1308 #endif
1309 #ifdef INADDR_LOOPBACK
1310 scm_c_define ("INADDR_LOOPBACK", scm_ulong2num (INADDR_LOOPBACK));
1311 #endif
1312
1313 /* socket types. */
1314 #ifdef SOCK_STREAM
1315 scm_c_define ("SOCK_STREAM", SCM_MAKINUM (SOCK_STREAM));
1316 #endif
1317 #ifdef SOCK_DGRAM
1318 scm_c_define ("SOCK_DGRAM", SCM_MAKINUM (SOCK_DGRAM));
1319 #endif
1320 #ifdef SOCK_RAW
1321 scm_c_define ("SOCK_RAW", SCM_MAKINUM (SOCK_RAW));
1322 #endif
1323
1324 /* setsockopt level. */
1325 #ifdef SOL_SOCKET
1326 scm_c_define ("SOL_SOCKET", SCM_MAKINUM (SOL_SOCKET));
1327 #endif
1328 #ifdef SOL_IP
1329 scm_c_define ("SOL_IP", SCM_MAKINUM (SOL_IP));
1330 #endif
1331 #ifdef SOL_TCP
1332 scm_c_define ("SOL_TCP", SCM_MAKINUM (SOL_TCP));
1333 #endif
1334 #ifdef SOL_UDP
1335 scm_c_define ("SOL_UDP", SCM_MAKINUM (SOL_UDP));
1336 #endif
1337
1338 /* setsockopt names. */
1339 #ifdef SO_DEBUG
1340 scm_c_define ("SO_DEBUG", SCM_MAKINUM (SO_DEBUG));
1341 #endif
1342 #ifdef SO_REUSEADDR
1343 scm_c_define ("SO_REUSEADDR", SCM_MAKINUM (SO_REUSEADDR));
1344 #endif
1345 #ifdef SO_STYLE
1346 scm_c_define ("SO_STYLE", SCM_MAKINUM (SO_STYLE));
1347 #endif
1348 #ifdef SO_TYPE
1349 scm_c_define ("SO_TYPE", SCM_MAKINUM (SO_TYPE));
1350 #endif
1351 #ifdef SO_ERROR
1352 scm_c_define ("SO_ERROR", SCM_MAKINUM (SO_ERROR));
1353 #endif
1354 #ifdef SO_DONTROUTE
1355 scm_c_define ("SO_DONTROUTE", SCM_MAKINUM (SO_DONTROUTE));
1356 #endif
1357 #ifdef SO_BROADCAST
1358 scm_c_define ("SO_BROADCAST", SCM_MAKINUM (SO_BROADCAST));
1359 #endif
1360 #ifdef SO_SNDBUF
1361 scm_c_define ("SO_SNDBUF", SCM_MAKINUM (SO_SNDBUF));
1362 #endif
1363 #ifdef SO_RCVBUF
1364 scm_c_define ("SO_RCVBUF", SCM_MAKINUM (SO_RCVBUF));
1365 #endif
1366 #ifdef SO_KEEPALIVE
1367 scm_c_define ("SO_KEEPALIVE", SCM_MAKINUM (SO_KEEPALIVE));
1368 #endif
1369 #ifdef SO_OOBINLINE
1370 scm_c_define ("SO_OOBINLINE", SCM_MAKINUM (SO_OOBINLINE));
1371 #endif
1372 #ifdef SO_NO_CHECK
1373 scm_c_define ("SO_NO_CHECK", SCM_MAKINUM (SO_NO_CHECK));
1374 #endif
1375 #ifdef SO_PRIORITY
1376 scm_c_define ("SO_PRIORITY", SCM_MAKINUM (SO_PRIORITY));
1377 #endif
1378 #ifdef SO_LINGER
1379 scm_c_define ("SO_LINGER", SCM_MAKINUM (SO_LINGER));
1380 #endif
1381
1382 /* recv/send options. */
1383 #ifdef MSG_OOB
1384 scm_c_define ("MSG_OOB", SCM_MAKINUM (MSG_OOB));
1385 #endif
1386 #ifdef MSG_PEEK
1387 scm_c_define ("MSG_PEEK", SCM_MAKINUM (MSG_PEEK));
1388 #endif
1389 #ifdef MSG_DONTROUTE
1390 scm_c_define ("MSG_DONTROUTE", SCM_MAKINUM (MSG_DONTROUTE));
1391 #endif
1392
1393 #ifdef __MINGW32__
1394 scm_i_init_socket_Win32 ();
1395 #endif
1396
1397 scm_add_feature ("socket");
1398
1399 #include "libguile/socket.x"
1400 }
1401
1402
1403 /*
1404 Local Variables:
1405 c-file-style: "gnu"
1406 End:
1407 */