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