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