libguile/socket.c

   1 /*      Copyright (C) 1996,1997,1998 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 /* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
  43    gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
  44
  45 \f
  46
  47 #include <stdio.h>
  48
  49 #include "_scm.h"
  50 #include "unif.h"
  51 #include "feature.h"
  52 #include "fports.h"
  53
  54 #include "scm_validate.h"
  55 #include "socket.h"
  56
  57 #ifdef HAVE_STRING_H
  58 #include <string.h>
  59 #endif
  60 #ifdef HAVE_UNISTD_H
  61 #include <unistd.h>
  62 #endif
  63 #include <sys/types.h>
  64 #include <sys/socket.h>
  65 #ifdef HAVE_UNIX_DOMAIN_SOCKETS
  66 #include <sys/un.h>
  67 #endif
  68 #include <netinet/in.h>
  69 #include <netdb.h>
  70 #include <arpa/inet.h>
  71
  72 \f
  73
  74 SCM_DEFINE (scm_htons, "htons", 1, 0, 0,
  75             (SCM in),
  76 "Returns a new integer from @var{value} by converting from host to
  77 network order. @var{value} must be within the range of a C unsigned
  78 short integer.")
  79 #define FUNC_NAME s_scm_htons
  80 {
  81   unsigned short c_in;
  82
  83   SCM_VALIDATE_INUM_COPY (1,in,c_in);
  84   if (c_in != SCM_INUM (in))
  85     SCM_OUT_OF_RANGE (1,in);
  86
  87   return SCM_MAKINUM (htons (c_in));
  88 }
  89 #undef FUNC_NAME
  90
  91 SCM_DEFINE (scm_ntohs, "ntohs", 1, 0, 0,
  92             (SCM in),
  93 "Returns a new integer from @var{value} by converting from network to
  94 host order.  @var{value} must be within the range of a C unsigned short
  95 integer.")
  96 #define FUNC_NAME s_scm_ntohs
  97 {
  98   unsigned short c_in;
  99
 100   SCM_VALIDATE_INUM_COPY (1,in,c_in);
 101   if (c_in != SCM_INUM (in))
 102     SCM_OUT_OF_RANGE (1,in);
 103
 104   return SCM_MAKINUM (ntohs (c_in));
 105 }
 106 #undef FUNC_NAME
 107
 108 SCM_DEFINE (scm_htonl, "htonl", 1, 0, 0,
 109             (SCM in),
 110 "Returns a new integer from @var{value} by converting from host to
 111 network order. @var{value} must be within the range of a C unsigned
 112 long integer.")
 113 #define FUNC_NAME s_scm_htonl
 114 {
 115   unsigned long c_in = SCM_NUM2ULONG (1,in);
 116   return scm_ulong2num (htonl (c_in));
 117 }
 118 #undef FUNC_NAME
 119
 120 SCM_DEFINE (scm_ntohl, "ntohl", 1, 0, 0,
 121             (SCM in),
 122 "Returns a new integer from @var{value} by converting from network to
 123 host order. @var{value} must be within the range of a C unsigned
 124 long integer.")
 125 #define FUNC_NAME s_scm_ntohl
 126 {
 127   unsigned long c_in = SCM_NUM2ULONG (1,in);
 128   return scm_ulong2num (ntohl (c_in));
 129 }
 130 #undef FUNC_NAME
 131
 132 SCM_SYMBOL (sym_socket, "socket");
 133
 134 static SCM
 135 scm_sock_fd_to_port (int fd, const char *proc)
 136 {
 137   SCM result;
 138   if (fd == -1)
 139     scm_syserror (proc);
 140   result = scm_fdes_to_port (fd, "r+0", sym_socket);
 141   return result;
 142 }
 143
 144
 145 #define SCM_SOCK_FD_TO_PORT(fd) (scm_sock_fd_to_port((fd),FUNC_NAME))
 146
 147 SCM_DEFINE (scm_socket, "socket", 3, 0, 0,
 148             (SCM family, SCM style, SCM proto),
 149 "Returns a new socket port of the type specified by @var{family}, @var{style}
 150 and @var{protocol}.  All three parameters are integers.  Typical values
 151 for @var{family} are the values of @code{AF_UNIX}
 152 and @code{AF_INET}.  Typical values for @var{style} are
 153 the values of @code{SOCK_STREAM}, @code{SOCK_DGRAM} and @code{SOCK_RAW}.
 154
 155 @var{protocol} can be obtained from a protocol name using
 156 @code{getprotobyname}.  A value of
 157 zero specifies the default protocol, which is usually right.
 158
 159 A single socket port cannot by used for communication until
 160 it has been connected to another socket.")
 161 #define FUNC_NAME s_scm_socket
 162 {
 163   int fd;
 164   SCM result;
 165
 166   SCM_VALIDATE_INUM (1,family);
 167   SCM_VALIDATE_INUM (2,style);
 168   SCM_VALIDATE_INUM (3,proto);
 169   fd = socket (SCM_INUM (family), SCM_INUM (style), SCM_INUM (proto));
 170   result = SCM_SOCK_FD_TO_PORT (fd);
 171   return result;
 172 }
 173 #undef FUNC_NAME
 174
 175
 176
 177 #ifdef HAVE_SOCKETPAIR
 178 SCM_DEFINE (scm_socketpair, "socketpair", 3, 0, 0,
 179             (SCM family, SCM style, SCM proto),
 180 "Returns a pair of connected (but unnamed) socket ports of the type specified
 181 by @var{family}, @var{style} and @var{protocol}.
 182 Many systems support only
 183 socket pairs of the @code{AF_UNIX} family.  Zero is likely to be
 184 the only meaningful value for @var{protocol}.")
 185 #define FUNC_NAME s_scm_socketpair
 186 {
 187   int fam;
 188   int fd[2];
 189   SCM a;
 190   SCM b;
 191
 192   SCM_VALIDATE_INUM (1,family);
 193   SCM_VALIDATE_INUM (2,style);
 194   SCM_VALIDATE_INUM (3,proto);
 195
 196   fam = SCM_INUM (family);
 197
 198   if (socketpair (fam, SCM_INUM (style), SCM_INUM (proto), fd) == -1)
 199     SCM_SYSERROR;
 200
 201   a = SCM_SOCK_FD_TO_PORT(fd[0]);
 202   b = SCM_SOCK_FD_TO_PORT(fd[1]);
 203   return scm_cons (a, b);
 204 }
 205 #undef FUNC_NAME
 206 #endif
 207
 208 SCM_DEFINE (scm_getsockopt, "getsockopt", 3, 0, 0,
 209             (SCM sock, SCM level, SCM optname),
 210 "Returns the value of a particular socket option for the socket
 211 port @var{socket}.  @var{level} is an integer code for type of option
 212 being requested, e.g., @code{SOL_SOCKET} for socket-level options.
 213 @var{optname} is an
 214 integer code for the option required and should be specified using one of
 215 the symbols @code{SO_DEBUG}, @code{SO_REUSEADDR} etc.
 216
 217 The returned value is typically an integer but @code{SO_LINGER} returns a
 218 pair of integers.")
 219 #define FUNC_NAME s_scm_getsockopt
 220 {
 221   int fd;
 222   int optlen;
 223 #ifdef HAVE_STRUCT_LINGER
 224   char optval[sizeof (struct linger)];
 225 #else
 226   char optval[sizeof (scm_sizet)];
 227 #endif
 228   int ilevel;
 229   int ioptname;
 230
 231 #ifdef HAVE_STRUCT_LINGER
 232   optlen = (int) sizeof (struct linger);
 233 #else
 234   optlen = (int) sizeof (scm_sizet);
 235 #endif
 236
 237   sock = SCM_COERCE_OUTPORT (sock);
 238   SCM_VALIDATE_OPFPORT (1,sock);
 239   SCM_VALIDATE_INUM_COPY (2,level,ilevel);
 240   SCM_VALIDATE_INUM_COPY (3,optname,ioptname);
 241
 242   fd = SCM_FPORT_FDES (sock);
 243   if (getsockopt (fd, ilevel, ioptname, (void *) optval, &optlen) == -1)
 244     SCM_SYSERROR;
 245
 246 #ifdef SO_LINGER
 247   if (ilevel == SOL_SOCKET && ioptname == SO_LINGER)
 248     {
 249 #ifdef HAVE_STRUCT_LINGER
 250       struct linger *ling = (struct linger *) optval;
 251       return scm_cons (SCM_MAKINUM (ling->l_onoff),
 252                        SCM_MAKINUM (ling->l_linger));
 253 #else
 254       scm_sizet *ling = (scm_sizet *) optval;
 255       return scm_cons (SCM_MAKINUM (*ling),
 256                        SCM_MAKINUM (0));
 257 #endif
 258     }
 259 #endif
 260 #ifdef SO_SNDBUF
 261   if (ilevel == SOL_SOCKET && ioptname == SO_SNDBUF)
 262     {
 263       scm_sizet *bufsize = (scm_sizet *) optval;
 264       return SCM_MAKINUM (*bufsize);
 265     }
 266 #endif
 267 #ifdef SO_RCVBUF
 268   if (ilevel == SOL_SOCKET && ioptname == SO_RCVBUF)
 269     {
 270       scm_sizet *bufsize = (scm_sizet *) optval;
 271       return SCM_MAKINUM (*bufsize);
 272     }
 273 #endif
 274   return SCM_MAKINUM (*(int *) optval);
 275 }
 276 #undef FUNC_NAME
 277
 278 SCM_DEFINE (scm_setsockopt, "setsockopt", 4, 0, 0,
 279             (SCM sock, SCM level, SCM optname, SCM value),
 280 "Sets the value of a particular socket option for the socket
 281 port @var{socket}.  @var{level} is an integer code for type of option
 282 being set, e.g., @code{SOL_SOCKET} for socket-level options.
 283 @var{optname} is an
 284 integer code for the option to set and should be specified using one of
 285 the symbols @code{SO_DEBUG}, @code{SO_REUSEADDR} etc.
 286 @var{value} is the value to which the option should be set.  For
 287 most options this must be an integer, but for @code{SO_LINGER} it must
 288 be a pair.
 289
 290 The return value is unspecified.")
 291 #define FUNC_NAME s_scm_setsockopt
 292 {
 293   int fd;
 294   int optlen;
 295 #ifdef HAVE_STRUCT_LINGER
 296   char optval[sizeof (struct linger)]; /* Biggest option :-(  */
 297 #else
 298   char optval[sizeof (scm_sizet)];
 299 #endif
 300   int ilevel, ioptname;
 301   sock = SCM_COERCE_OUTPORT (sock);
 302   SCM_VALIDATE_OPFPORT (1,sock);
 303   SCM_VALIDATE_INUM_COPY (2,level,ilevel);
 304   SCM_VALIDATE_INUM_COPY (3,optname,ioptname);
 305   fd = SCM_FPORT_FDES (sock);
 306   if (0);
 307 #ifdef SO_LINGER
 308   else if (ilevel == SOL_SOCKET && ioptname == SO_LINGER)
 309     {
 310 #ifdef HAVE_STRUCT_LINGER
 311       struct linger ling;
 312       SCM_ASSERT (SCM_CONSP (value)
 313                   && SCM_INUMP (SCM_CAR (value))
 314                   &&  SCM_INUMP (SCM_CDR (value)),
 315                   value, SCM_ARG4, FUNC_NAME);
 316       ling.l_onoff = SCM_INUM (SCM_CAR (value));
 317       ling.l_linger = SCM_INUM (SCM_CDR (value));
 318       optlen = (int) sizeof (struct linger);
 319       memcpy (optval, (void *) &ling, optlen);
 320 #else
 321       scm_sizet ling;
 322       SCM_ASSERT (SCM_CONSP (value)
 323                   && SCM_INUMP (SCM_CAR (value))
 324                   &&  SCM_INUMP (SCM_CDR (value)),
 325                   value, SCM_ARG4, FUNC_NAME);
 326       ling = SCM_INUM (SCM_CAR (value));
 327       optlen = (int) sizeof (scm_sizet);
 328       (*(scm_sizet *) optval) = (scm_sizet) SCM_INUM (value);
 329 #endif
 330     }
 331 #endif
 332 #ifdef SO_SNDBUF
 333   else if (ilevel == SOL_SOCKET && ioptname == SO_SNDBUF)
 334     {
 335       SCM_VALIDATE_INUM (4,value);
 336       optlen = (int) sizeof (scm_sizet);
 337       (*(scm_sizet *) optval) = (scm_sizet) SCM_INUM (value);
 338     }
 339 #endif
 340 #ifdef SO_RCVBUF
 341   else if (ilevel == SOL_SOCKET && ioptname == SO_RCVBUF)
 342     {
 343       SCM_VALIDATE_INUM (4,value);
 344       optlen = (int) sizeof (scm_sizet);
 345       (*(scm_sizet *) optval) = (scm_sizet) SCM_INUM (value);
 346     }
 347 #endif
 348   else
 349     {
 350       /* Most options just take an int.  */
 351       SCM_VALIDATE_INUM (4,value);
 352       optlen = (int) sizeof (int);
 353       (*(int *) optval) = (int) SCM_INUM (value);
 354     }
 355   if (setsockopt (fd, ilevel, ioptname, (void *) optval, optlen) == -1)
 356     SCM_SYSERROR;
 357   return SCM_UNSPECIFIED;
 358 }
 359 #undef FUNC_NAME
 360
 361 SCM_DEFINE (scm_shutdown, "shutdown", 2, 0, 0,
 362           (SCM sock, SCM how),
 363 "Sockets can be closed simply by using @code{close-port}. The
 364 @code{shutdown} procedure allows reception or tranmission on a
 365 connection to be shut down individually, according to the parameter
 366 @var{how}:
 367
 368 @table @asis
 369 @item 0
 370 Stop receiving data for this socket.  If further data arrives,  reject it.
 371 @item 1
 372 Stop trying to transmit data from this socket.  Discard any
 373 data waiting to be sent.  Stop looking for acknowledgement of
 374 data already sent; don't retransmit it if it is lost.
 375 @item 2
 376 Stop both reception and transmission.
 377 @end table
 378
 379 The return value is unspecified.")
 380 #define FUNC_NAME s_scm_shutdown
 381 {
 382   int fd;
 383   sock = SCM_COERCE_OUTPORT (sock);
 384   SCM_VALIDATE_OPFPORT (1,sock);
 385   SCM_VALIDATE_INUM (2,how);
 386   SCM_ASSERT_RANGE(2,how,0 <= SCM_INUM (how) && 2 >= SCM_INUM (how));
 387   fd = SCM_FPORT_FDES (sock);
 388   if (shutdown (fd, SCM_INUM (how)) == -1)
 389     SCM_SYSERROR;
 390   return SCM_UNSPECIFIED;
 391 }
 392 #undef FUNC_NAME
 393
 394 /* convert fam/address/args into a sockaddr of the appropriate type.
 395    args is modified by removing the arguments actually used.
 396    which_arg and proc are used when reporting errors:
 397    which_arg is the position of address in the original argument list.
 398    proc is the name of the original procedure.
 399    size returns the size of the structure allocated.  */
 400
 401
 402 static struct sockaddr *
 403 scm_fill_sockaddr (int fam,SCM address,SCM *args,int which_arg,const char *proc,scm_sizet *size)
 404 {
 405   switch (fam)
 406     {
 407     case AF_INET:
 408       {
 409         SCM isport;
 410         struct sockaddr_in *soka;
 411
 412         soka = (struct sockaddr_in *)
 413           scm_must_malloc (sizeof (struct sockaddr_in), proc);
 414         /* e.g., for BSDs which don't like invalid sin_len.  */
 415         memset (soka, 0, sizeof (struct sockaddr_in));
 416         soka->sin_family = AF_INET;
 417         soka->sin_addr.s_addr =
 418           htonl (scm_num2ulong (address, (char *) which_arg, proc));
 419         SCM_ASSERT (SCM_CONSP (*args), *args,
 420                     which_arg + 1, proc);
 421         isport = SCM_CAR (*args);
 422         *args = SCM_CDR (*args);
 423         SCM_ASSERT (SCM_INUMP (isport), isport, which_arg + 1, proc);
 424         soka->sin_port = htons (SCM_INUM (isport));
 425         *size = sizeof (struct sockaddr_in);
 426         return (struct sockaddr *) soka;
 427       }
 428 #ifdef HAVE_UNIX_DOMAIN_SOCKETS
 429     case AF_UNIX:
 430       {
 431         struct sockaddr_un *soka;
 432
 433         soka = (struct sockaddr_un *)
 434           scm_must_malloc (sizeof (struct sockaddr_un), proc);
 435         memset (soka, 0, sizeof (struct sockaddr_un));
 436         soka->sun_family = AF_UNIX;
 437         SCM_ASSERT (SCM_ROSTRINGP (address), address,
 438                     which_arg, proc);
 439         memcpy (soka->sun_path, SCM_ROCHARS (address),
 440                 1 + SCM_ROLENGTH (address));
 441         *size = sizeof (struct sockaddr_un);
 442         return (struct sockaddr *) soka;
 443       }
 444 #endif
 445     default:
 446       scm_out_of_range (proc, SCM_MAKINUM (fam));
 447     }
 448 }
 449
 450 SCM_DEFINE (scm_connect, "connect", 3, 0, 1,
 451             (SCM sock, SCM fam, SCM address, SCM args),
 452 "Initiates a connection from @var{socket} to the address
 453 specified by @var{address} and possibly @var{arg @dots{}}.  The format
 454 required for @var{address}
 455 and @var{arg} @dots{} depends on the family of the socket.
 456
 457 For a socket of family @code{AF_UNIX},
 458 only @code{address} is specified and must be a string with the
 459 filename where the socket is to be created.
 460
 461 For a socket of family @code{AF_INET},
 462 @code{address} must be an integer Internet host address and @var{arg} @dots{}
 463 must be a single integer port number.
 464
 465 The return value is unspecified.")
 466 #define FUNC_NAME s_scm_connect
 467 {
 468   int fd;
 469   struct sockaddr *soka;
 470   scm_sizet size;
 471
 472   sock = SCM_COERCE_OUTPORT (sock);
 473   SCM_VALIDATE_OPFPORT (1,sock);
 474   SCM_VALIDATE_INUM (2,fam);
 475   fd = SCM_FPORT_FDES (sock);
 476   soka = scm_fill_sockaddr (SCM_INUM (fam), address, &args, 3, FUNC_NAME, &size);
 477   if (connect (fd, soka, size) == -1)
 478     SCM_SYSERROR;
 479   scm_must_free ((char *) soka);
 480   return SCM_UNSPECIFIED;
 481 }
 482 #undef FUNC_NAME
 483
 484 SCM_DEFINE (scm_bind, "bind", 3, 0, 1,
 485             (SCM sock, SCM fam, SCM address, SCM args),
 486 "Assigns an address to the socket port @var{socket}.
 487 Generally this only needs to be done for server sockets,
 488 so they know where to look for incoming connections.  A socket
 489 without an address will be assigned one automatically when it
 490 starts communicating.
 491
 492 The format of @var{address} and @var{ARG} @dots{} depends on the family
 493 of the socket.
 494
 495 For a socket of family @code{AF_UNIX}, only @var{address}
 496 is specified and must
 497 be a string with the filename where the socket is to be created.
 498
 499 For a socket of family @code{AF_INET}, @var{address} must be an integer
 500 Internet host address and @var{arg} @dots{} must be a single integer
 501 port number.
 502
 503 The values of the following variables can also be used for @var{address}:
 504
 505 @defvar INADDR_ANY
 506 Allow connections from any address.
 507 @end defvar
 508
 509 @defvar INADDR_LOOPBACK
 510 The address of the local host using the loopback device.
 511 @end defvar
 512
 513 @defvar INADDR_BROADCAST
 514 The broadcast address on the local network.
 515 @end defvar
 516
 517 @defvar INADDR_NONE
 518 No address.
 519 @end defvar
 520
 521 The return value is unspecified.")
 522 #define FUNC_NAME s_scm_bind
 523 {
 524   int rv;
 525   struct sockaddr *soka;
 526   scm_sizet size;
 527   int fd;
 528
 529   sock = SCM_COERCE_OUTPORT (sock);
 530   SCM_VALIDATE_OPFPORT (1,sock);
 531   SCM_VALIDATE_INUM (2,fam);
 532   soka = scm_fill_sockaddr (SCM_INUM (fam), address, &args, 3, FUNC_NAME, &size);
 533   fd = SCM_FPORT_FDES (sock);
 534   rv = bind (fd, soka, size);
 535   if (rv == -1)
 536     SCM_SYSERROR;
 537   scm_must_free ((char *) soka);
 538   return SCM_UNSPECIFIED;
 539 }
 540 #undef FUNC_NAME
 541
 542 SCM_DEFINE (scm_listen, "listen", 2, 0, 0,
 543             (SCM sock, SCM backlog),
 544 "This procedure enables @var{socket} to accept connection
 545 requests.  @var{backlog} is an integer specifying
 546 the maximum length of the queue for pending connections.
 547 If the queue fills, new clients will fail to connect until the
 548 server calls @code{accept} to accept a connection from the queue.
 549
 550 The return value is unspecified.")
 551 #define FUNC_NAME s_scm_listen
 552 {
 553   int fd;
 554   sock = SCM_COERCE_OUTPORT (sock);
 555   SCM_VALIDATE_OPFPORT (1,sock);
 556   SCM_VALIDATE_INUM (2,backlog);
 557   fd = SCM_FPORT_FDES (sock);
 558   if (listen (fd, SCM_INUM (backlog)) == -1)
 559     SCM_SYSERROR;
 560   return SCM_UNSPECIFIED;
 561 }
 562 #undef FUNC_NAME
 563
 564 /* Put the components of a sockaddr into a new SCM vector.  */
 565
 566 static SCM
 567 scm_addr_vector (struct sockaddr *address,const char *proc)
 568 {
 569   short int fam = address->sa_family;
 570   SCM result;
 571   SCM *ve;
 572 #ifdef HAVE_UNIX_DOMAIN_SOCKETS
 573   if (fam == AF_UNIX)
 574     {
 575       struct sockaddr_un *nad = (struct sockaddr_un *) address;
 576       result = scm_make_vector (SCM_MAKINUM (2), SCM_UNSPECIFIED);
 577       ve = SCM_VELTS (result);
 578       ve[0] = scm_ulong2num ((unsigned long) fam);
 579       ve[1] = scm_makfromstr (nad->sun_path,
 580                               (scm_sizet) strlen (nad->sun_path), 0);
 581     }
 582   else
 583 #endif
 584   if (fam == AF_INET)
 585     {
 586       struct sockaddr_in *nad = (struct sockaddr_in *) address;
 587       result = scm_make_vector (SCM_MAKINUM (3), SCM_UNSPECIFIED);
 588       ve = SCM_VELTS (result);
 589       ve[0] = scm_ulong2num ((unsigned long) fam);
 590       ve[1] = scm_ulong2num (ntohl (nad->sin_addr.s_addr));
 591       ve[2] = scm_ulong2num ((unsigned long) ntohs (nad->sin_port));
 592     }
 593   else
 594     scm_misc_error (proc, "Unrecognised address family: %s",
 595                     scm_listify (SCM_MAKINUM (fam), SCM_UNDEFINED));
 596
 597   return result;
 598 }
 599
 600 /* Allocate a buffer large enough to hold any sockaddr type.  */
 601 static char *scm_addr_buffer;
 602 static int scm_addr_buffer_size;
 603
 604 static void
 605 scm_init_addr_buffer (void)
 606 {
 607   scm_addr_buffer_size =
 608 #ifdef HAVE_UNIX_DOMAIN_SOCKETS
 609   (int) sizeof (struct sockaddr_un)
 610 #else
 611   0
 612 #endif
 613   ;
 614   if (sizeof (struct sockaddr_in) > scm_addr_buffer_size)
 615     scm_addr_buffer_size = (int) sizeof (struct sockaddr_in);
 616   scm_addr_buffer = scm_must_malloc (scm_addr_buffer_size, "address buffer");
 617 }
 618
 619 SCM_DEFINE (scm_accept, "accept", 1, 0, 0,
 620             (SCM sock),
 621 "Accepts a connection on a bound, listening socket @var{socket}.  If there
 622 are no pending connections in the queue, it waits until
 623 one is available unless the non-blocking option has been set on the
 624 socket.
 625
 626 The return value is a
 627 pair in which the CAR is a new socket port for the connection and
 628 the CDR is an object with address information about the client which
 629 initiated the connection.
 630
 631 If the address is not available then the CDR will be an empty vector.
 632
 633 @var{socket} does not become part of the
 634 connection and will continue to accept new requests.")
 635 #define FUNC_NAME s_scm_accept
 636 {
 637   int fd;
 638   int newfd;
 639   SCM address;
 640   SCM newsock;
 641
 642   int tmp_size;
 643   sock = SCM_COERCE_OUTPORT (sock);
 644   SCM_VALIDATE_OPFPORT (1,sock);
 645   fd = SCM_FPORT_FDES (sock);
 646   tmp_size = scm_addr_buffer_size;
 647   newfd = accept (fd, (struct sockaddr *) scm_addr_buffer, &tmp_size);
 648   newsock = scm_sock_fd_to_port (newfd, FUNC_NAME);
 649   if (tmp_size > 0)
 650     address = scm_addr_vector ((struct sockaddr *) scm_addr_buffer, FUNC_NAME);
 651   else
 652     address = SCM_BOOL_F;
 653
 654   return scm_cons (newsock, address);
 655 }
 656 #undef FUNC_NAME
 657
 658 SCM_DEFINE (scm_getsockname, "getsockname", 1, 0, 0,
 659             (SCM sock),
 660 "Returns the address of @var{socket}, in the same form as the object
 661 returned by @code{accept}.  On many systems the address of a socket
 662 in the @code{AF_FILE} namespace cannot be read.")
 663 #define FUNC_NAME s_scm_getsockname
 664 {
 665   int tmp_size;
 666   int fd;
 667   SCM result;
 668   sock = SCM_COERCE_OUTPORT (sock);
 669   SCM_VALIDATE_OPFPORT (1,sock);
 670   fd = SCM_FPORT_FDES (sock);
 671   tmp_size = scm_addr_buffer_size;
 672   if (getsockname (fd, (struct sockaddr *) scm_addr_buffer, &tmp_size) == -1)
 673     SCM_SYSERROR;
 674   if (tmp_size > 0)
 675     result = scm_addr_vector ((struct sockaddr *) scm_addr_buffer, FUNC_NAME);
 676   else
 677     result = SCM_BOOL_F;
 678   return result;
 679 }
 680 #undef FUNC_NAME
 681
 682 SCM_DEFINE (scm_getpeername, "getpeername", 1, 0, 0,
 683             (SCM sock),
 684 "Returns the address of the socket that the socket @var{socket} is connected to,
 685 in the same form as the object
 686 returned by @code{accept}.  On many systems the address of a socket
 687 in the @code{AF_FILE} namespace cannot be read.")
 688 #define FUNC_NAME s_scm_getpeername
 689 {
 690   int tmp_size;
 691   int fd;
 692   SCM result;
 693   sock = SCM_COERCE_OUTPORT (sock);
 694   SCM_VALIDATE_OPFPORT (1,sock);
 695   fd = SCM_FPORT_FDES (sock);
 696   tmp_size = scm_addr_buffer_size;
 697   if (getpeername (fd, (struct sockaddr *) scm_addr_buffer, &tmp_size) == -1)
 698     SCM_SYSERROR;
 699   if (tmp_size > 0)
 700     result = scm_addr_vector ((struct sockaddr *) scm_addr_buffer, FUNC_NAME);
 701   else
 702     result = SCM_BOOL_F;
 703   return result;
 704 }
 705 #undef FUNC_NAME
 706
 707 SCM_DEFINE (scm_recv, "recv!", 2, 1, 0,
 708             (SCM sock, SCM buf, SCM flags),
 709 "Receives data from the socket port @var{socket}.  @var{socket} must already
 710 be bound to the address from which data is to be received.
 711 @var{buf} is a string into which
 712 the data will be written.  The size of @var{buf} limits the amount of
 713 data which can be received: in the case of packet
 714 protocols, if a packet larger than this limit is encountered then some data
 715 will be irrevocably lost.
 716
 717 The optional @var{flags} argument is a value or
 718 bitwise OR of MSG_OOB, MSG_PEEK, MSG_DONTROUTE etc.
 719
 720 The value returned is the number of bytes read from the socket.
 721
 722 Note that the data is read directly from the socket file descriptor:
 723 any unread buffered port data is ignored.")
 724 #define FUNC_NAME s_scm_recv
 725 {
 726   int rv;
 727   int fd;
 728   int flg;
 729
 730   SCM_VALIDATE_OPFPORT (1,sock);
 731   SCM_VALIDATE_STRING (2,buf);
 732   SCM_VALIDATE_INUM_DEF_COPY (3,flags,0,flg);
 733   fd = SCM_FPORT_FDES (sock);
 734
 735   SCM_SYSCALL (rv = recv (fd, SCM_CHARS (buf), SCM_LENGTH (buf), flg));
 736   if (rv == -1)
 737     SCM_SYSERROR;
 738
 739   return SCM_MAKINUM (rv);
 740 }
 741 #undef FUNC_NAME
 742
 743 SCM_DEFINE (scm_send, "send", 2, 1, 0,
 744             (SCM sock, SCM message, SCM flags),
 745 "Transmits the string @var{message} on the socket port @var{socket}.
 746 @var{socket} must already be bound to a destination address.  The
 747 value returned is the number of bytes transmitted -- it's possible for
 748 this to be less than the length of @var{message} if the socket is
 749 set to be non-blocking.  The optional @var{flags} argument is a value or
 750 bitwise OR of MSG_OOB, MSG_PEEK, MSG_DONTROUTE etc.
 751
 752 Note that the data is written directly to the socket file descriptor:
 753 any unflushed buffered port data is ignored.")
 754 #define FUNC_NAME s_scm_send
 755 {
 756   int rv;
 757   int fd;
 758   int flg;
 759
 760   sock = SCM_COERCE_OUTPORT (sock);
 761   SCM_VALIDATE_OPFPORT (1,sock);
 762   SCM_VALIDATE_ROSTRING (2,message);
 763   SCM_VALIDATE_INUM_DEF_COPY (3,flags,0,flg);
 764   fd = SCM_FPORT_FDES (sock);
 765
 766   SCM_SYSCALL (rv = send (fd, SCM_ROCHARS (message), SCM_ROLENGTH (message), flg));
 767   if (rv == -1)
 768     SCM_SYSERROR;
 769   return SCM_MAKINUM (rv);
 770 }
 771 #undef FUNC_NAME
 772
 773 SCM_DEFINE (scm_recvfrom, "recvfrom!", 2, 3, 0,
 774             (SCM sock, SCM buf, SCM flags, SCM start, SCM end),
 775 "Returns data from the socket port @var{socket} and also information about
 776 where the data was received from.  @var{socket} must already
 777 be bound to the address from which data is to be received.
 778 @code{buf}, is a string into which
 779 the data will be written.  The size of @var{buf} limits the amount of
 780 data which can be received: in the case of packet
 781 protocols, if a packet larger than this limit is encountered then some data
 782 will be irrevocably lost.
 783
 784 The optional @var{flags} argument is a value or
 785 bitwise OR of MSG_OOB, MSG_PEEK, MSG_DONTROUTE etc.
 786
 787 The value returned is a pair: the CAR is the number of bytes read from
 788 the socket and the CDR an address object in the same form as returned by
 789 @code{accept}.
 790
 791 The @var{start} and @var{end} arguments specify a substring of @var{buf}
 792 to which the data should be written.
 793
 794 Note that the data is read directly from the socket file descriptor:
 795 any unread buffered port data is ignored.")
 796 #define FUNC_NAME s_scm_recvfrom
 797 {
 798   int rv;
 799   int fd;
 800   int flg;
 801   int offset = 0;
 802   int cend;
 803   int tmp_size;
 804   SCM address;
 805
 806   SCM_VALIDATE_OPFPORT (1,sock);
 807   SCM_VALIDATE_STRING (2,buf);
 808   cend = SCM_LENGTH (buf);
 809
 810   if (SCM_UNBNDP (flags))
 811     flg = 0;
 812   else
 813     {
 814       flg = SCM_NUM2ULONG (3,flags);
 815
 816       if (!SCM_UNBNDP (start))
 817         {
 818           offset = (int) SCM_NUM2LONG (4,start);
 819
 820           if (offset < 0 || offset >= cend)
 821             SCM_OUT_OF_RANGE (4, start);
 822
 823           if (!SCM_UNBNDP (end))
 824             {
 825               int tend = (int) SCM_NUM2LONG (5,end);
 826
 827               if (tend <= offset || tend > cend)
 828                 SCM_OUT_OF_RANGE (5, end);
 829
 830               cend = tend;
 831             }
 832         }
 833     }
 834
 835   fd = SCM_FPORT_FDES (sock);
 836
 837   tmp_size = scm_addr_buffer_size;
 838   SCM_SYSCALL (rv = recvfrom (fd, SCM_CHARS (buf) + offset,
 839                               cend - offset, flg,
 840                               (struct sockaddr *) scm_addr_buffer,
 841                               &tmp_size));
 842   if (rv == -1)
 843     SCM_SYSERROR;
 844   if (tmp_size > 0)
 845     address = scm_addr_vector ((struct sockaddr *) scm_addr_buffer, FUNC_NAME);
 846   else
 847     address = SCM_BOOL_F;
 848
 849   return scm_cons (SCM_MAKINUM (rv), address);
 850 }
 851 #undef FUNC_NAME
 852
 853 SCM_DEFINE (scm_sendto, "sendto", 4, 0, 1,
 854             (SCM sock, SCM message, SCM fam, SCM address, SCM args_and_flags),
 855 "Transmits the string @var{message} on the socket port @var{socket}.  The
 856 destination address is specified using the @var{family}, @var{address} and
 857 @var{arg} arguments, in a similar way to the @code{connect}
 858 procedure.  The
 859 value returned is the number of bytes transmitted -- it's possible for
 860 this to be less than the length of @var{message} if the socket is
 861 set to be non-blocking.  The optional @var{flags} argument is a value or
 862 bitwise OR of MSG_OOB, MSG_PEEK, MSG_DONTROUTE etc.
 863
 864 Note that the data is written directly to the socket file descriptor:
 865 any unflushed buffered port data is ignored.")
 866 #define FUNC_NAME s_scm_sendto
 867 {
 868   int rv;
 869   int fd;
 870   int flg;
 871   struct sockaddr *soka;
 872   scm_sizet size;
 873   int save_err;
 874
 875   sock = SCM_COERCE_OUTPORT (sock);
 876   SCM_VALIDATE_FPORT (1,sock);
 877   SCM_VALIDATE_ROSTRING (2,message);
 878   SCM_VALIDATE_INUM (3,fam);
 879   fd = SCM_FPORT_FDES (sock);
 880   soka = scm_fill_sockaddr (SCM_INUM (fam), address, &args_and_flags, 4,
 881                             FUNC_NAME, &size);
 882   if (SCM_NULLP (args_and_flags))
 883     flg = 0;
 884   else
 885     {
 886       SCM_VALIDATE_CONS (5,args_and_flags);
 887       flg = SCM_NUM2ULONG (5,SCM_CAR (args_and_flags));
 888     }
 889   SCM_SYSCALL (rv = sendto (fd, SCM_ROCHARS (message), SCM_ROLENGTH (message),
 890                             flg, soka, size));
 891   save_err = errno;
 892   scm_must_free ((char *) soka);
 893   errno = save_err;
 894   if (rv == -1)
 895     SCM_SYSERROR;
 896   return SCM_MAKINUM (rv);
 897 }
 898 #undef FUNC_NAME
 899 \f
 900
 901
 902 void
 903 scm_init_socket ()
 904 {
 905   /* protocol families.  */
 906 #ifdef AF_UNSPEC
 907   scm_sysintern ("AF_UNSPEC", SCM_MAKINUM (AF_UNSPEC));
 908 #endif
 909 #ifdef AF_UNIX
 910   scm_sysintern ("AF_UNIX", SCM_MAKINUM (AF_UNIX));
 911 #endif
 912 #ifdef AF_INET
 913   scm_sysintern ("AF_INET", SCM_MAKINUM (AF_INET));
 914 #endif
 915
 916 #ifdef PF_UNSPEC
 917   scm_sysintern ("PF_UNSPEC", SCM_MAKINUM (PF_UNSPEC));
 918 #endif
 919 #ifdef PF_UNIX
 920   scm_sysintern ("PF_UNIX", SCM_MAKINUM (PF_UNIX));
 921 #endif
 922 #ifdef PF_INET
 923   scm_sysintern ("PF_INET", SCM_MAKINUM (PF_INET));
 924 #endif
 925
 926   /* socket types.  */
 927 #ifdef SOCK_STREAM
 928   scm_sysintern ("SOCK_STREAM", SCM_MAKINUM (SOCK_STREAM));
 929 #endif
 930 #ifdef SOCK_DGRAM
 931   scm_sysintern ("SOCK_DGRAM", SCM_MAKINUM (SOCK_DGRAM));
 932 #endif
 933 #ifdef SOCK_RAW
 934   scm_sysintern ("SOCK_RAW", SCM_MAKINUM (SOCK_RAW));
 935 #endif
 936
 937   /* setsockopt level.  */
 938 #ifdef SOL_SOCKET
 939   scm_sysintern ("SOL_SOCKET", SCM_MAKINUM (SOL_SOCKET));
 940 #endif
 941 #ifdef SOL_IP
 942   scm_sysintern ("SOL_IP", SCM_MAKINUM (SOL_IP));
 943 #endif
 944 #ifdef SOL_TCP
 945   scm_sysintern ("SOL_TCP", SCM_MAKINUM (SOL_TCP));
 946 #endif
 947 #ifdef SOL_UDP
 948   scm_sysintern ("SOL_UDP", SCM_MAKINUM (SOL_UDP));
 949 #endif
 950
 951   /* setsockopt names.  */
 952 #ifdef SO_DEBUG
 953   scm_sysintern ("SO_DEBUG", SCM_MAKINUM (SO_DEBUG));
 954 #endif
 955 #ifdef SO_REUSEADDR
 956   scm_sysintern ("SO_REUSEADDR", SCM_MAKINUM (SO_REUSEADDR));
 957 #endif
 958 #ifdef SO_STYLE
 959   scm_sysintern ("SO_STYLE", SCM_MAKINUM (SO_STYLE));
 960 #endif
 961 #ifdef SO_TYPE
 962   scm_sysintern ("SO_TYPE", SCM_MAKINUM (SO_TYPE));
 963 #endif
 964 #ifdef SO_ERROR
 965   scm_sysintern ("SO_ERROR", SCM_MAKINUM (SO_ERROR));
 966 #endif
 967 #ifdef SO_DONTROUTE
 968   scm_sysintern ("SO_DONTROUTE", SCM_MAKINUM (SO_DONTROUTE));
 969 #endif
 970 #ifdef SO_BROADCAST
 971   scm_sysintern ("SO_BROADCAST", SCM_MAKINUM (SO_BROADCAST));
 972 #endif
 973 #ifdef SO_SNDBUF
 974   scm_sysintern ("SO_SNDBUF", SCM_MAKINUM (SO_SNDBUF));
 975 #endif
 976 #ifdef SO_RCVBUF
 977   scm_sysintern ("SO_RCVBUF", SCM_MAKINUM (SO_RCVBUF));
 978 #endif
 979 #ifdef SO_KEEPALIVE
 980   scm_sysintern ("SO_KEEPALIVE", SCM_MAKINUM (SO_KEEPALIVE));
 981 #endif
 982 #ifdef SO_OOBINLINE
 983   scm_sysintern ("SO_OOBINLINE", SCM_MAKINUM (SO_OOBINLINE));
 984 #endif
 985 #ifdef SO_NO_CHECK
 986   scm_sysintern ("SO_NO_CHECK", SCM_MAKINUM (SO_NO_CHECK));
 987 #endif
 988 #ifdef SO_PRIORITY
 989   scm_sysintern ("SO_PRIORITY", SCM_MAKINUM (SO_PRIORITY));
 990 #endif
 991 #ifdef SO_LINGER
 992   scm_sysintern ("SO_LINGER", SCM_MAKINUM (SO_LINGER));
 993 #endif
 994
 995   /* recv/send options.  */
 996 #ifdef MSG_OOB
 997   scm_sysintern ("MSG_OOB", SCM_MAKINUM (MSG_OOB));
 998 #endif
 999 #ifdef MSG_PEEK
1000   scm_sysintern ("MSG_PEEK", SCM_MAKINUM (MSG_PEEK));
1001 #endif
1002 #ifdef MSG_DONTROUTE
1003   scm_sysintern ("MSG_DONTROUTE", SCM_MAKINUM (MSG_DONTROUTE));
1004 #endif
1005
1006   scm_add_feature ("socket");
1007   scm_init_addr_buffer ();
1008
1009 #include "socket.x"
1010 }
1011