libguile/socket.c

   1 /*      Copyright (C) 1996,1997 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 \f
  42
  43 #include <stdio.h>
  44
  45 #include "_scm.h"
  46 #include "unif.h"
  47 #include "feature.h"
  48 #include "fports.h"
  49
  50 #include "socket.h"
  51
  52 #ifdef HAVE_STRING_H
  53 #include <string.h>
  54 #endif
  55 #ifdef HAVE_UNISTD_H
  56 #include <unistd.h>
  57 #endif
  58 #include <sys/types.h>
  59 #include <sys/socket.h>
  60 #ifdef HAVE_UNIX_DOMAIN_SOCKETS
  61 #include <sys/un.h>
  62 #endif
  63 #include <netinet/in.h>
  64 #include <netdb.h>
  65 #include <arpa/inet.h>
  66
  67 \f
  68
  69 SCM_SYMBOL (sym_socket, "socket");
  70 static SCM scm_sock_fd_to_port SCM_P ((int fd, char *proc));
  71
  72 static SCM
  73 scm_sock_fd_to_port (fd, proc)
  74      int fd;
  75      char *proc;
  76 {
  77   SCM result;
  78   FILE *f;
  79
  80   if (fd == -1)
  81     scm_syserror (proc);
  82   f = fdopen (fd, "r+");
  83   if (!f)
  84     {
  85       SCM_SYSCALL (close (fd));
  86       scm_syserror (proc);
  87     }
  88   result = scm_stdio_to_port (f, "r+0", sym_socket);
  89   scm_setbuf0 (result);
  90   return result;
  91 }
  92
  93 SCM_PROC (s_socket, "socket", 3, 0, 0, scm_socket);
  94
  95 SCM
  96 scm_socket (family, style, proto)
  97      SCM family;
  98      SCM style;
  99      SCM proto;
 100 {
 101   int fd;
 102   SCM result;
 103
 104   SCM_ASSERT (SCM_INUMP (family), family, SCM_ARG1, s_socket);
 105   SCM_ASSERT (SCM_INUMP (style), style, SCM_ARG2, s_socket);
 106   SCM_ASSERT (SCM_INUMP (proto), proto, SCM_ARG3, s_socket);
 107   SCM_DEFER_INTS;
 108   fd = socket (SCM_INUM (family), SCM_INUM (style), SCM_INUM (proto));
 109   result = scm_sock_fd_to_port (fd, s_socket);
 110   SCM_SETOR_CAR (result, SCM_NOFTELL);
 111   SCM_ALLOW_INTS;
 112   return result;
 113 }
 114
 115
 116
 117 #ifdef HAVE_SOCKETPAIR
 118 SCM_PROC (s_socketpair, "socketpair", 3, 0, 0, scm_socketpair);
 119
 120 SCM
 121 scm_socketpair (family, style, proto)
 122      SCM family;
 123      SCM style;
 124      SCM proto;
 125 {
 126   int fam;
 127   int fd[2];
 128   SCM a;
 129   SCM b;
 130
 131   SCM_ASSERT (SCM_INUMP (family), family, SCM_ARG1, s_socketpair);
 132   SCM_ASSERT (SCM_INUMP (style), style, SCM_ARG2, s_socketpair);
 133   SCM_ASSERT (SCM_INUMP (proto), proto, SCM_ARG3, s_socketpair);
 134
 135   fam = SCM_INUM (family);
 136
 137   SCM_DEFER_INTS;
 138   if (socketpair (fam, SCM_INUM (style), SCM_INUM (proto), fd) == -1)
 139     scm_syserror (s_socketpair);
 140
 141   a = scm_sock_fd_to_port (fd[0], s_socketpair);
 142   b = scm_sock_fd_to_port (fd[1], s_socketpair);
 143   SCM_ALLOW_INTS;
 144   return scm_cons (a, b);
 145 }
 146 #endif
 147
 148 SCM_PROC (s_getsockopt, "getsockopt", 3, 0, 0, scm_getsockopt);
 149
 150 SCM
 151 scm_getsockopt (sock, level, optname)
 152      SCM sock;
 153      SCM level;
 154      SCM optname;
 155 {
 156   int fd;
 157   int optlen;
 158 #ifdef HAVE_STRUCT_LINGER
 159   char optval[sizeof (struct linger)];
 160 #else
 161   char optval[sizeof (scm_sizet)];
 162 #endif
 163   int ilevel;
 164   int ioptname;
 165
 166 #ifdef HAVE_STRUCT_LINGER
 167   optlen = (int) sizeof (struct linger);
 168 #else
 169   optlen = (int) sizeof (scm_sizet);
 170 #endif
 171
 172   sock = SCM_COERCE_OUTPORT (sock);
 173   SCM_ASSERT (SCM_NIMP (sock) && SCM_FPORTP (sock), sock, SCM_ARG1,
 174               s_getsockopt);
 175   SCM_ASSERT (SCM_INUMP (level), level, SCM_ARG2, s_getsockopt);
 176   SCM_ASSERT (SCM_INUMP (optname), optname, SCM_ARG3, s_getsockopt);
 177
 178   fd = fileno ((FILE *)SCM_STREAM (sock));
 179   ilevel = SCM_INUM (level);
 180   ioptname = SCM_INUM (optname);
 181   if (getsockopt (fd, ilevel, ioptname, (void *) optval, &optlen) == -1)
 182     scm_syserror (s_getsockopt);
 183
 184 #ifdef SO_LINGER
 185   if (ilevel == SOL_SOCKET && ioptname == SO_LINGER)
 186     {
 187 #ifdef HAVE_STRUCT_LINGER
 188       struct linger *ling = (struct linger *) optval;
 189       return scm_cons (SCM_MAKINUM (ling->l_onoff),
 190                        SCM_MAKINUM (ling->l_linger));
 191 #else
 192       scm_sizet *ling = (scm_sizet *) optval;
 193       return scm_cons (SCM_MAKINUM (*ling),
 194                        SCM_MAKINUM (0));
 195 #endif
 196     }
 197 #endif
 198 #ifdef SO_SNDBUF
 199   if (ilevel == SOL_SOCKET && ioptname == SO_SNDBUF)
 200     {
 201       scm_sizet *bufsize = (scm_sizet *) optval;
 202       return SCM_MAKINUM (*bufsize);
 203     }
 204 #endif
 205 #ifdef SO_RCVBUF
 206   if (ilevel == SOL_SOCKET && ioptname == SO_RCVBUF)
 207     {
 208       scm_sizet *bufsize = (scm_sizet *) optval;
 209       return SCM_MAKINUM (*bufsize);
 210     }
 211 #endif
 212   return SCM_MAKINUM (*(int *) optval);
 213 }
 214
 215 SCM_PROC (s_setsockopt, "setsockopt", 4, 0, 0, scm_setsockopt);
 216
 217 SCM
 218 scm_setsockopt (sock, level, optname, value)
 219      SCM sock;
 220      SCM level;
 221      SCM optname;
 222      SCM value;
 223 {
 224   int fd;
 225   int optlen;
 226 #ifdef HAVE_STRUCT_LINGER
 227   char optval[sizeof (struct linger)]; /* Biggest option :-(  */
 228 #else
 229   char optval[sizeof (scm_sizet)];
 230 #endif
 231   int ilevel, ioptname;
 232   sock = SCM_COERCE_OUTPORT (sock);
 233   SCM_ASSERT (SCM_NIMP (sock) && SCM_FPORTP (sock), sock, SCM_ARG1,
 234               s_setsockopt);
 235   SCM_ASSERT (SCM_INUMP (level), level, SCM_ARG2, s_setsockopt);
 236   SCM_ASSERT (SCM_INUMP (optname), optname, SCM_ARG3, s_setsockopt);
 237   fd = fileno ((FILE *)SCM_STREAM (sock));
 238   ilevel = SCM_INUM (level);
 239   ioptname = SCM_INUM (optname);
 240   if (0);
 241 #ifdef SO_LINGER
 242   else if (ilevel == SOL_SOCKET && ioptname == SO_LINGER)
 243     {
 244 #ifdef HAVE_STRUCT_LINGER
 245       struct linger ling;
 246       SCM_ASSERT (SCM_NIMP (value) && SCM_CONSP (value)
 247                   && SCM_INUMP (SCM_CAR (value))
 248                   &&  SCM_INUMP (SCM_CDR (value)),
 249                   value, SCM_ARG4, s_setsockopt);
 250       ling.l_onoff = SCM_INUM (SCM_CAR (value));
 251       ling.l_linger = SCM_INUM (SCM_CDR (value));
 252       optlen = (int) sizeof (struct linger);
 253       memcpy (optval, (void *) &ling, optlen);
 254 #else
 255       scm_sizet ling;
 256       SCM_ASSERT (SCM_NIMP (value) && SCM_CONSP (value)
 257                   && SCM_INUMP (SCM_CAR (value))
 258                   &&  SCM_INUMP (SCM_CDR (value)),
 259                   value, SCM_ARG4, s_setsockopt);
 260       ling = SCM_INUM (SCM_CAR (value));
 261       optlen = (int) sizeof (scm_sizet);
 262       (*(scm_sizet *) optval) = (scm_sizet) SCM_INUM (value);
 263 #endif
 264     }
 265 #endif
 266 #ifdef SO_SNDBUF
 267   else if (ilevel == SOL_SOCKET && ioptname == SO_SNDBUF)
 268     {
 269       SCM_ASSERT (SCM_INUMP (value), value, SCM_ARG4, s_setsockopt);
 270       optlen = (int) sizeof (scm_sizet);
 271       (*(scm_sizet *) optval) = (scm_sizet) SCM_INUM (value);
 272     }
 273 #endif
 274 #ifdef SO_RCVBUF
 275   else if (ilevel == SOL_SOCKET && ioptname == SO_RCVBUF)
 276     {
 277       SCM_ASSERT (SCM_INUMP (value), value, SCM_ARG4, s_setsockopt);
 278       optlen = (int) sizeof (scm_sizet);
 279       (*(scm_sizet *) optval) = (scm_sizet) SCM_INUM (value);
 280     }
 281 #endif
 282   else
 283     {
 284       /* Most options just take an int.  */
 285       SCM_ASSERT (SCM_INUMP (value), value, SCM_ARG4, s_setsockopt);
 286       optlen = (int) sizeof (int);
 287       (*(int *) optval) = (int) SCM_INUM (value);
 288     }
 289   if (setsockopt (fd, ilevel, ioptname, (void *) optval, optlen) == -1)
 290     scm_syserror (s_setsockopt);
 291   return SCM_UNSPECIFIED;
 292 }
 293
 294 SCM_PROC (s_shutdown, "shutdown", 2, 0, 0, scm_shutdown);
 295
 296 SCM
 297 scm_shutdown (sock, how)
 298      SCM sock;
 299      SCM how;
 300 {
 301   int fd;
 302   sock = SCM_COERCE_OUTPORT (sock);
 303   SCM_ASSERT (SCM_NIMP (sock) && SCM_FPORTP (sock), sock, SCM_ARG1,
 304               s_shutdown);
 305   SCM_ASSERT (SCM_INUMP (how) && 0 <= SCM_INUM (how) && 2 >= SCM_INUM (how),
 306           how, SCM_ARG2, s_shutdown);
 307   fd = fileno ((FILE *)SCM_STREAM (sock));
 308   if (shutdown (fd, SCM_INUM (how)) == -1)
 309     scm_syserror (s_shutdown);
 310   return SCM_UNSPECIFIED;
 311 }
 312
 313 /* convert fam/address/args into a sockaddr of the appropriate type.
 314    args is modified by removing the arguments actually used.
 315    which_arg and proc are used when reporting errors:
 316    which_arg is the position of address in the original argument list.
 317    proc is the name of the original procedure.
 318    size returns the size of the structure allocated.  */
 319
 320
 321 static struct sockaddr * scm_fill_sockaddr SCM_P ((int fam, SCM address, SCM *args, int which_arg, char *proc, scm_sizet *size));
 322
 323 static struct sockaddr *
 324 scm_fill_sockaddr (fam, address, args, which_arg, proc, size)
 325      int fam;
 326      SCM address;
 327      SCM *args;
 328      int which_arg;
 329      char *proc;
 330      scm_sizet *size;
 331 {
 332   switch (fam)
 333     {
 334     case AF_INET:
 335       {
 336         SCM isport;
 337         struct sockaddr_in *soka;
 338
 339         soka = (struct sockaddr_in *)
 340           scm_must_malloc (sizeof (struct sockaddr_in), proc);
 341         soka->sin_family = AF_INET;
 342         soka->sin_addr.s_addr =
 343           htonl (scm_num2ulong (address, (char *) which_arg, proc));
 344         SCM_ASSERT (SCM_NIMP (*args) && SCM_CONSP (*args), *args,
 345                     which_arg + 1, proc);
 346         isport = SCM_CAR (*args);
 347         *args = SCM_CDR (*args);
 348         SCM_ASSERT (SCM_INUMP (isport), isport, which_arg + 1, proc);
 349         soka->sin_port = htons (SCM_INUM (isport));
 350         *size = sizeof (struct sockaddr_in);
 351         return (struct sockaddr *) soka;
 352       }
 353 #ifdef HAVE_UNIX_DOMAIN_SOCKETS
 354     case AF_UNIX:
 355       {
 356         struct sockaddr_un *soka;
 357
 358         soka = (struct sockaddr_un *)
 359           scm_must_malloc (sizeof (struct sockaddr_un), proc);
 360         soka->sun_family = AF_UNIX;
 361         SCM_ASSERT (SCM_NIMP (address) && SCM_ROSTRINGP (address), address,
 362                     which_arg, proc);
 363         memcpy (soka->sun_path, SCM_ROCHARS (address),
 364                 1 + SCM_ROLENGTH (address));
 365         *size = sizeof (struct sockaddr_un);
 366         return (struct sockaddr *) soka;
 367       }
 368 #endif
 369     default:
 370       scm_out_of_range (proc, SCM_MAKINUM (fam));
 371     }
 372 }
 373
 374 SCM_PROC (s_connect, "connect", 3, 0, 1, scm_connect);
 375
 376 SCM
 377 scm_connect (sock, fam, address, args)
 378
 379      SCM sock;
 380      SCM fam;
 381      SCM address;
 382      SCM args;
 383 {
 384   int fd;
 385   struct sockaddr *soka;
 386   scm_sizet size;
 387
 388   sock = SCM_COERCE_OUTPORT (sock);
 389   SCM_ASSERT (SCM_NIMP (sock) && SCM_FPORTP (sock), sock, SCM_ARG1, s_connect);
 390   SCM_ASSERT (SCM_INUMP (fam), fam, SCM_ARG2, s_connect);
 391   fd = fileno ((FILE *)SCM_STREAM (sock));
 392   SCM_DEFER_INTS;
 393   soka = scm_fill_sockaddr (SCM_INUM (fam), address, &args, 3, s_connect, &size);
 394   if (connect (fd, soka, size) == -1)
 395     scm_syserror (s_connect);
 396   scm_must_free ((char *) soka);
 397   SCM_ALLOW_INTS;
 398   return SCM_UNSPECIFIED;
 399 }
 400
 401 SCM_PROC (s_bind, "bind", 3, 0, 1, scm_bind);
 402
 403 SCM
 404 scm_bind (sock, fam, address, args)
 405      SCM sock;
 406      SCM fam;
 407      SCM address;
 408      SCM args;
 409 {
 410   int rv;
 411   struct sockaddr *soka;
 412   scm_sizet size;
 413   int fd;
 414
 415   sock = SCM_COERCE_OUTPORT (sock);
 416   SCM_ASSERT (SCM_NIMP (sock) && SCM_FPORTP (sock), sock, SCM_ARG1, s_bind);
 417   SCM_ASSERT (SCM_INUMP (fam), fam, SCM_ARG2, s_bind);
 418   soka = scm_fill_sockaddr (SCM_INUM (fam), address, &args, 3, s_bind, &size);
 419   fd = fileno ((FILE *)SCM_STREAM (sock));
 420   rv = bind (fd, soka, size);
 421   if (rv == -1)
 422     scm_syserror (s_bind);
 423   scm_must_free ((char *) soka);
 424   return SCM_UNSPECIFIED;
 425 }
 426
 427 SCM_PROC (s_listen, "listen", 2, 0, 0, scm_listen);
 428
 429 SCM
 430 scm_listen (sock, backlog)
 431      SCM sock;
 432      SCM backlog;
 433 {
 434   int fd;
 435   sock = SCM_COERCE_OUTPORT (sock);
 436   SCM_ASSERT (SCM_NIMP (sock) && SCM_FPORTP (sock), sock, SCM_ARG1, s_listen);
 437   SCM_ASSERT (SCM_INUMP (backlog), backlog, SCM_ARG2, s_listen);
 438   fd = fileno ((FILE *)SCM_STREAM (sock));
 439   if (listen (fd, SCM_INUM (backlog)) == -1)
 440     scm_syserror (s_listen);
 441   return SCM_UNSPECIFIED;
 442 }
 443
 444 /* Put the components of a sockaddr into a new SCM vector.  */
 445
 446 static SCM scm_addr_vector SCM_P ((struct sockaddr *address, char *proc));
 447
 448 static SCM
 449 scm_addr_vector (address, proc)
 450      struct sockaddr *address;
 451      char *proc;
 452 {
 453   short int fam = address->sa_family;
 454   SCM result;
 455   SCM *ve;
 456 #ifdef HAVE_UNIX_DOMAIN_SOCKETS
 457   if (fam == AF_UNIX)
 458     {
 459       struct sockaddr_un *nad = (struct sockaddr_un *) address;
 460       result = scm_make_vector (SCM_MAKINUM (2), SCM_UNSPECIFIED);
 461       ve = SCM_VELTS (result);
 462       ve[0] = scm_ulong2num ((unsigned long) fam);
 463       ve[1] = scm_makfromstr (nad->sun_path,
 464                               (scm_sizet) strlen (nad->sun_path), 0);
 465     }
 466   else
 467 #endif
 468   if (fam == AF_INET)
 469     {
 470       struct sockaddr_in *nad = (struct sockaddr_in *) address;
 471       result = scm_make_vector (SCM_MAKINUM (3), SCM_UNSPECIFIED);
 472       ve = SCM_VELTS (result);
 473       ve[0] = scm_ulong2num ((unsigned long) fam);
 474       ve[1] = scm_ulong2num (ntohl (nad->sin_addr.s_addr));
 475       ve[2] = scm_ulong2num ((unsigned long) ntohs (nad->sin_port));
 476     }
 477   else
 478     scm_misc_error (proc, "Unrecognised address family: %s",
 479                     scm_listify (SCM_MAKINUM (fam), SCM_UNDEFINED));
 480
 481   return result;
 482 }
 483
 484 /* Allocate a buffer large enough to hold any sockaddr type.  */
 485 static char *scm_addr_buffer;
 486 static int scm_addr_buffer_size;
 487
 488 static void scm_init_addr_buffer SCM_P ((void));
 489
 490 static void
 491 scm_init_addr_buffer ()
 492 {
 493   scm_addr_buffer_size =
 494 #ifdef HAVE_UNIX_DOMAIN_SOCKETS
 495   (int) sizeof (struct sockaddr_un)
 496 #else
 497   0
 498 #endif
 499   ;
 500   if (sizeof (struct sockaddr_in) > scm_addr_buffer_size)
 501     scm_addr_buffer_size = (int) sizeof (struct sockaddr_in);
 502   scm_addr_buffer = scm_must_malloc (scm_addr_buffer_size, "address buffer");
 503 }
 504
 505 SCM_PROC (s_accept, "accept", 1, 0, 0, scm_accept);
 506
 507 SCM
 508 scm_accept (sock)
 509      SCM sock;
 510 {
 511   int fd;
 512   int newfd;
 513   SCM address;
 514   SCM newsock;
 515
 516   int tmp_size;
 517   sock = SCM_COERCE_OUTPORT (sock);
 518   SCM_ASSERT (SCM_NIMP (sock) && SCM_FPORTP (sock), sock, SCM_ARG1, s_accept);
 519   fd = fileno ((FILE *)SCM_STREAM (sock));
 520   SCM_DEFER_INTS;
 521   tmp_size = scm_addr_buffer_size;
 522   newfd = accept (fd, (struct sockaddr *) scm_addr_buffer, &tmp_size);
 523   newsock = scm_sock_fd_to_port (newfd, s_accept);
 524   if (tmp_size > 0)
 525     address = scm_addr_vector ((struct sockaddr *) scm_addr_buffer, s_accept);
 526   else
 527     address = SCM_BOOL_F;
 528
 529   SCM_ALLOW_INTS;
 530   return scm_cons (newsock, address);
 531 }
 532
 533 SCM_PROC (s_getsockname, "getsockname", 1, 0, 0, scm_getsockname);
 534
 535 SCM
 536 scm_getsockname (sock)
 537      SCM sock;
 538 {
 539   int tmp_size;
 540   int fd;
 541   SCM result;
 542   sock = SCM_COERCE_OUTPORT (sock);
 543   SCM_ASSERT (SCM_NIMP (sock) && SCM_FPORTP (sock), sock, SCM_ARG1, s_getsockname);
 544   fd = fileno ((FILE *)SCM_STREAM (sock));
 545   SCM_DEFER_INTS;
 546   tmp_size = scm_addr_buffer_size;
 547   if (getsockname (fd, (struct sockaddr *) scm_addr_buffer, &tmp_size) == -1)
 548     scm_syserror (s_getsockname);
 549   if (tmp_size > 0)
 550     result = scm_addr_vector ((struct sockaddr *) scm_addr_buffer, s_getsockname);
 551   else
 552     result = SCM_BOOL_F;
 553   SCM_ALLOW_INTS;
 554   return result;
 555 }
 556
 557 SCM_PROC (s_getpeername, "getpeername", 1, 0, 0, scm_getpeername);
 558
 559 SCM
 560 scm_getpeername (sock)
 561      SCM sock;
 562 {
 563   int tmp_size;
 564   int fd;
 565   SCM result;
 566   sock = SCM_COERCE_OUTPORT (sock);
 567   SCM_ASSERT (SCM_NIMP (sock) && SCM_FPORTP (sock), sock, SCM_ARG1, s_getpeername);
 568   fd = fileno ((FILE *)SCM_STREAM (sock));
 569   SCM_DEFER_INTS;
 570   tmp_size = scm_addr_buffer_size;
 571   if (getpeername (fd, (struct sockaddr *) scm_addr_buffer, &tmp_size) == -1)
 572     scm_syserror (s_getpeername);
 573   if (tmp_size > 0)
 574     result = scm_addr_vector ((struct sockaddr *) scm_addr_buffer, s_getpeername);
 575   else
 576     result = SCM_BOOL_F;
 577   SCM_ALLOW_INTS;
 578   return result;
 579 }
 580
 581 SCM_PROC (s_recv, "recv!", 2, 1, 0, scm_recv);
 582
 583 SCM
 584 scm_recv (sock, buf, flags)
 585      SCM sock;
 586      SCM buf;
 587      SCM flags;
 588 {
 589   int rv;
 590   int fd;
 591   int flg;
 592
 593   SCM_ASSERT (SCM_NIMP (sock) && SCM_FPORTP (sock), sock, SCM_ARG1, s_recv);
 594   SCM_ASSERT (SCM_NIMP (buf) && SCM_STRINGP (buf), buf, SCM_ARG2, s_recv);
 595   fd = fileno ((FILE *)SCM_STREAM (sock));
 596
 597   if (SCM_UNBNDP (flags))
 598     flg = 0;
 599   else
 600     flg = scm_num2ulong (flags, (char *) SCM_ARG3, s_recv);
 601
 602   SCM_SYSCALL (rv = recv (fd, SCM_CHARS (buf), SCM_LENGTH (buf), flg));
 603   if (rv == -1)
 604     scm_syserror (s_recv);
 605
 606   return SCM_MAKINUM (rv);
 607 }
 608
 609 SCM_PROC (s_send, "send", 2, 1, 0, scm_send);
 610
 611 SCM
 612 scm_send (sock, message, flags)
 613      SCM sock;
 614      SCM message;
 615      SCM flags;
 616 {
 617   int rv;
 618   int fd;
 619   int flg;
 620
 621   sock = SCM_COERCE_OUTPORT (sock);
 622   SCM_ASSERT (SCM_NIMP (sock) && SCM_FPORTP (sock), sock, SCM_ARG1, s_send);
 623   SCM_ASSERT (SCM_NIMP (message) && SCM_ROSTRINGP (message), message, SCM_ARG2, s_send);
 624   fd = fileno ((FILE *)SCM_STREAM (sock));
 625
 626   if (SCM_UNBNDP (flags))
 627     flg = 0;
 628   else
 629     flg = scm_num2ulong (flags, (char *) SCM_ARG3, s_send);
 630
 631   SCM_SYSCALL (rv = send (fd, SCM_ROCHARS (message), SCM_ROLENGTH (message), flg));
 632   if (rv == -1)
 633     scm_syserror (s_send);
 634   return SCM_MAKINUM (rv);
 635 }
 636
 637 SCM_PROC (s_recvfrom, "recvfrom!", 2, 3, 0, scm_recvfrom);
 638
 639 SCM
 640 scm_recvfrom (sock, buf, flags, start, end)
 641      SCM sock;
 642      SCM buf;
 643      SCM flags;
 644      SCM start;
 645      SCM end;
 646 {
 647   int rv;
 648   int fd;
 649   int flg;
 650   int offset = 0;
 651   int cend;
 652   int tmp_size;
 653   SCM address;
 654
 655   SCM_ASSERT (SCM_NIMP (sock) && SCM_FPORTP (sock), sock, SCM_ARG1,
 656               s_recvfrom);
 657   SCM_ASSERT (SCM_NIMP (buf) && SCM_STRINGP (buf), buf, SCM_ARG2, s_recvfrom);
 658   cend = SCM_LENGTH (buf);
 659
 660   if (SCM_UNBNDP (flags))
 661     flg = 0;
 662   else
 663     {
 664       flg = scm_num2ulong (flags, (char *) SCM_ARG3, s_recvfrom);
 665
 666       if (!SCM_UNBNDP (start))
 667         {
 668           offset = (int) scm_num2long (start,
 669                                        (char *) SCM_ARG4, s_recvfrom);
 670
 671           if (offset < 0 || offset >= cend)
 672             scm_out_of_range (s_recvfrom, start);
 673
 674           if (!SCM_UNBNDP (end))
 675             {
 676               int tend = (int) scm_num2long (end,
 677                                              (char *) SCM_ARG5, s_recvfrom);
 678
 679               if (tend <= offset || tend > cend)
 680                 scm_out_of_range (s_recvfrom, end);
 681
 682               cend = tend;
 683             }
 684         }
 685     }
 686
 687   fd = fileno ((FILE *)SCM_STREAM (sock));
 688
 689   tmp_size = scm_addr_buffer_size;
 690   SCM_SYSCALL (rv = recvfrom (fd, SCM_CHARS (buf) + offset,
 691                               cend - offset, flg,
 692                               (struct sockaddr *) scm_addr_buffer,
 693                               &tmp_size));
 694   if (rv == -1)
 695     scm_syserror (s_recvfrom);
 696   if (tmp_size > 0)
 697     address = scm_addr_vector ((struct sockaddr *) scm_addr_buffer, s_recvfrom);
 698   else
 699     address = SCM_BOOL_F;
 700
 701   return scm_cons (SCM_MAKINUM (rv), address);
 702 }
 703
 704 SCM_PROC (s_sendto, "sendto", 4, 0, 1, scm_sendto);
 705
 706 SCM
 707 scm_sendto (sock, message, fam, address, args_and_flags)
 708      SCM sock;
 709      SCM message;
 710      SCM fam;
 711      SCM address;
 712      SCM args_and_flags;
 713 {
 714   int rv;
 715   int fd;
 716   int flg;
 717   struct sockaddr *soka;
 718   scm_sizet size;
 719
 720   sock = SCM_COERCE_OUTPORT (sock);
 721   SCM_ASSERT (SCM_NIMP (sock) && SCM_FPORTP (sock), sock, SCM_ARG1, s_sendto);
 722   SCM_ASSERT (SCM_NIMP (message) && SCM_ROSTRINGP (message), message,
 723               SCM_ARG2, s_sendto);
 724   SCM_ASSERT (SCM_INUMP (fam), fam, SCM_ARG3, s_sendto);
 725   fd = fileno ((FILE *)SCM_STREAM (sock));
 726   SCM_DEFER_INTS;
 727   soka = scm_fill_sockaddr (SCM_INUM (fam), address, &args_and_flags, 4,
 728                             s_sendto, &size);
 729   if (SCM_NULLP (args_and_flags))
 730     flg = 0;
 731   else
 732     {
 733       SCM_ASSERT (SCM_NIMP (args_and_flags) && SCM_CONSP (args_and_flags),
 734               args_and_flags, SCM_ARG5, s_sendto);
 735       flg = scm_num2ulong (SCM_CAR (args_and_flags), (char *) SCM_ARG5, s_sendto);
 736     }
 737   SCM_SYSCALL (rv = sendto (fd, SCM_ROCHARS (message), SCM_ROLENGTH (message),
 738                             flg, soka, size));
 739   if (rv == -1)
 740     scm_syserror (s_sendto);
 741   scm_must_free ((char *) soka);
 742   SCM_ALLOW_INTS;
 743   return SCM_MAKINUM (rv);
 744 }
 745 \f
 746
 747
 748 void
 749 scm_init_socket ()
 750 {
 751   /* protocol families.  */
 752 #ifdef AF_UNSPEC
 753   scm_sysintern ("AF_UNSPEC", SCM_MAKINUM (AF_UNSPEC));
 754 #endif
 755 #ifdef AF_UNIX
 756   scm_sysintern ("AF_UNIX", SCM_MAKINUM (AF_UNIX));
 757 #endif
 758 #ifdef AF_INET
 759   scm_sysintern ("AF_INET", SCM_MAKINUM (AF_INET));
 760 #endif
 761
 762 #ifdef PF_UNSPEC
 763   scm_sysintern ("PF_UNSPEC", SCM_MAKINUM (PF_UNSPEC));
 764 #endif
 765 #ifdef PF_UNIX
 766   scm_sysintern ("PF_UNIX", SCM_MAKINUM (PF_UNIX));
 767 #endif
 768 #ifdef PF_INET
 769   scm_sysintern ("PF_INET", SCM_MAKINUM (PF_INET));
 770 #endif
 771
 772   /* socket types.  */
 773 #ifdef SOCK_STREAM
 774   scm_sysintern ("SOCK_STREAM", SCM_MAKINUM (SOCK_STREAM));
 775 #endif
 776 #ifdef SOCK_DGRAM
 777   scm_sysintern ("SOCK_DGRAM", SCM_MAKINUM (SOCK_DGRAM));
 778 #endif
 779 #ifdef SOCK_RAW
 780   scm_sysintern ("SOCK_RAW", SCM_MAKINUM (SOCK_RAW));
 781 #endif
 782
 783   /* setsockopt level.  */
 784 #ifdef SOL_SOCKET
 785   scm_sysintern ("SOL_SOCKET", SCM_MAKINUM (SOL_SOCKET));
 786 #endif
 787 #ifdef SOL_IP
 788   scm_sysintern ("SOL_IP", SCM_MAKINUM (SOL_IP));
 789 #endif
 790 #ifdef SOL_TCP
 791   scm_sysintern ("SOL_TCP", SCM_MAKINUM (SOL_TCP));
 792 #endif
 793 #ifdef SOL_UDP
 794   scm_sysintern ("SOL_UDP", SCM_MAKINUM (SOL_UDP));
 795 #endif
 796
 797   /* setsockopt names.  */
 798 #ifdef SO_DEBUG
 799   scm_sysintern ("SO_DEBUG", SCM_MAKINUM (SO_DEBUG));
 800 #endif
 801 #ifdef SO_REUSEADDR
 802   scm_sysintern ("SO_REUSEADDR", SCM_MAKINUM (SO_REUSEADDR));
 803 #endif
 804 #ifdef SO_STYLE
 805   scm_sysintern ("SO_STYLE", SCM_MAKINUM (SO_STYLE));
 806 #endif
 807 #ifdef SO_TYPE
 808   scm_sysintern ("SO_TYPE", SCM_MAKINUM (SO_TYPE));
 809 #endif
 810 #ifdef SO_ERROR
 811   scm_sysintern ("SO_ERROR", SCM_MAKINUM (SO_ERROR));
 812 #endif
 813 #ifdef SO_DONTROUTE
 814   scm_sysintern ("SO_DONTROUTE", SCM_MAKINUM (SO_DONTROUTE));
 815 #endif
 816 #ifdef SO_BROADCAST
 817   scm_sysintern ("SO_BROADCAST", SCM_MAKINUM (SO_BROADCAST));
 818 #endif
 819 #ifdef SO_SNDBUF
 820   scm_sysintern ("SO_SNDBUF", SCM_MAKINUM (SO_SNDBUF));
 821 #endif
 822 #ifdef SO_RCVBUF
 823   scm_sysintern ("SO_RCVBUF", SCM_MAKINUM (SO_RCVBUF));
 824 #endif
 825 #ifdef SO_KEEPALIVE
 826   scm_sysintern ("SO_KEEPALIVE", SCM_MAKINUM (SO_KEEPALIVE));
 827 #endif
 828 #ifdef SO_OOBINLINE
 829   scm_sysintern ("SO_OOBINLINE", SCM_MAKINUM (SO_OOBINLINE));
 830 #endif
 831 #ifdef SO_NO_CHECK
 832   scm_sysintern ("SO_NO_CHECK", SCM_MAKINUM (SO_NO_CHECK));
 833 #endif
 834 #ifdef SO_PRIORITY
 835   scm_sysintern ("SO_PRIORITY", SCM_MAKINUM (SO_PRIORITY));
 836 #endif
 837 #ifdef SO_LINGER
 838   scm_sysintern ("SO_LINGER", SCM_MAKINUM (SO_LINGER));
 839 #endif
 840
 841   /* recv/send options.  */
 842 #ifdef MSG_OOB
 843   scm_sysintern ("MSG_OOB", SCM_MAKINUM (MSG_OOB));
 844 #endif
 845 #ifdef MSG_PEEK
 846   scm_sysintern ("MSG_PEEK", SCM_MAKINUM (MSG_PEEK));
 847 #endif
 848 #ifdef MSG_DONTROUTE
 849   scm_sysintern ("MSG_DONTROUTE", SCM_MAKINUM (MSG_DONTROUTE));
 850 #endif
 851
 852   scm_add_feature ("socket");
 853   scm_init_addr_buffer ();
 854
 855 #include "socket.x"
 856 }
 857