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