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