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 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 HAVE_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   scm_must_free ((char *) soka);
 429   return SCM_UNSPECIFIED;
 430 }
 431
 432 SCM_PROC (s_listen, "listen", 2, 0, 0, scm_listen);
 433
 434 SCM
 435 scm_listen (sock, backlog)
 436      SCM sock;
 437      SCM backlog;
 438 {
 439   int fd;
 440   sock = SCM_COERCE_OUTPORT (sock);
 441   SCM_ASSERT (SCM_NIMP (sock) && SCM_FPORTP (sock), sock, SCM_ARG1, s_listen);
 442   SCM_ASSERT (SCM_INUMP (backlog), backlog, SCM_ARG2, s_listen);
 443   fd = fileno ((FILE *)SCM_STREAM (sock));
 444   if (listen (fd, SCM_INUM (backlog)) == -1)
 445     scm_syserror (s_listen);
 446   return SCM_UNSPECIFIED;
 447 }
 448
 449 /* Put the components of a sockaddr into a new SCM vector.  */
 450
 451 static SCM scm_addr_vector SCM_P ((struct sockaddr *address, char *proc));
 452
 453 static SCM
 454 scm_addr_vector (address, proc)
 455      struct sockaddr *address;
 456      char *proc;
 457 {
 458   short int fam = address->sa_family;
 459   SCM result;
 460   SCM *ve;
 461 #ifdef HAVE_UNIX_DOMAIN_SOCKETS
 462   if (fam == AF_UNIX)
 463     {
 464       struct sockaddr_un *nad = (struct sockaddr_un *) address;
 465       result = scm_make_vector (SCM_MAKINUM (2), SCM_UNSPECIFIED, SCM_BOOL_F);
 466       ve = SCM_VELTS (result);
 467       ve[0] = scm_ulong2num ((unsigned long) fam);
 468       ve[1] = scm_makfromstr (nad->sun_path,
 469                               (scm_sizet) strlen (nad->sun_path), 0);
 470     }
 471   else
 472 #endif
 473   if (fam == AF_INET)
 474     {
 475       struct sockaddr_in *nad = (struct sockaddr_in *) address;
 476       result = scm_make_vector (SCM_MAKINUM (3), SCM_UNSPECIFIED, SCM_BOOL_F);
 477       ve = SCM_VELTS (result);
 478       ve[0] = scm_ulong2num ((unsigned long) fam);
 479       ve[1] = scm_ulong2num (ntohl (nad->sin_addr.s_addr));
 480       ve[2] = scm_ulong2num ((unsigned long) ntohs (nad->sin_port));
 481     }
 482   else
 483     scm_misc_error (proc, "Unrecognised address family: %s",
 484                     scm_listify (SCM_MAKINUM (fam), SCM_UNDEFINED));
 485
 486   return result;
 487 }
 488
 489 /* Allocate a buffer large enough to hold any sockaddr type.  */
 490 static char *scm_addr_buffer;
 491 static int scm_addr_buffer_size;
 492
 493 static void scm_init_addr_buffer SCM_P ((void));
 494
 495 static void
 496 scm_init_addr_buffer ()
 497 {
 498   scm_addr_buffer_size =
 499 #ifdef HAVE_UNIX_DOMAIN_SOCKETS
 500   (int) sizeof (struct sockaddr_un)
 501 #else
 502   0
 503 #endif
 504   ;
 505   if (sizeof (struct sockaddr_in) > scm_addr_buffer_size)
 506     scm_addr_buffer_size = (int) sizeof (struct sockaddr_in);
 507   scm_addr_buffer = scm_must_malloc (scm_addr_buffer_size, "address buffer");
 508 }
 509
 510 SCM_PROC (s_accept, "accept", 1, 0, 0, scm_accept);
 511
 512 SCM
 513 scm_accept (sock)
 514      SCM sock;
 515 {
 516   int fd;
 517   int newfd;
 518   SCM address;
 519   SCM newsock;
 520
 521   int tmp_size;
 522   sock = SCM_COERCE_OUTPORT (sock);
 523   SCM_ASSERT (SCM_NIMP (sock) && SCM_FPORTP (sock), sock, SCM_ARG1, s_accept);
 524   fd = fileno ((FILE *)SCM_STREAM (sock));
 525   SCM_DEFER_INTS;
 526   tmp_size = scm_addr_buffer_size;
 527   newfd = accept (fd, (struct sockaddr *) scm_addr_buffer, &tmp_size);
 528   newsock = scm_sock_fd_to_port (newfd, s_accept);
 529   if (tmp_size > 0)
 530     address = scm_addr_vector ((struct sockaddr *) scm_addr_buffer, s_accept);
 531   else
 532     address = SCM_BOOL_F;
 533
 534   SCM_ALLOW_INTS;
 535   return scm_cons (newsock, address);
 536 }
 537
 538 SCM_PROC (s_getsockname, "getsockname", 1, 0, 0, scm_getsockname);
 539
 540 SCM
 541 scm_getsockname (sock)
 542      SCM sock;
 543 {
 544   int tmp_size;
 545   int fd;
 546   SCM result;
 547   sock = SCM_COERCE_OUTPORT (sock);
 548   SCM_ASSERT (SCM_NIMP (sock) && SCM_FPORTP (sock), sock, SCM_ARG1, s_getsockname);
 549   fd = fileno ((FILE *)SCM_STREAM (sock));
 550   SCM_DEFER_INTS;
 551   tmp_size = scm_addr_buffer_size;
 552   if (getsockname (fd, (struct sockaddr *) scm_addr_buffer, &tmp_size) == -1)
 553     scm_syserror (s_getsockname);
 554   if (tmp_size > 0)
 555     result = scm_addr_vector ((struct sockaddr *) scm_addr_buffer, s_getsockname);
 556   else
 557     result = SCM_BOOL_F;
 558   SCM_ALLOW_INTS;
 559   return result;
 560 }
 561
 562 SCM_PROC (s_getpeername, "getpeername", 1, 0, 0, scm_getpeername);
 563
 564 SCM
 565 scm_getpeername (sock)
 566      SCM sock;
 567 {
 568   int tmp_size;
 569   int fd;
 570   SCM result;
 571   sock = SCM_COERCE_OUTPORT (sock);
 572   SCM_ASSERT (SCM_NIMP (sock) && SCM_FPORTP (sock), sock, SCM_ARG1, s_getpeername);
 573   fd = fileno ((FILE *)SCM_STREAM (sock));
 574   SCM_DEFER_INTS;
 575   tmp_size = scm_addr_buffer_size;
 576   if (getpeername (fd, (struct sockaddr *) scm_addr_buffer, &tmp_size) == -1)
 577     scm_syserror (s_getpeername);
 578   if (tmp_size > 0)
 579     result = scm_addr_vector ((struct sockaddr *) scm_addr_buffer, s_getpeername);
 580   else
 581     result = SCM_BOOL_F;
 582   SCM_ALLOW_INTS;
 583   return result;
 584 }
 585
 586 SCM_PROC (s_recv, "recv!", 2, 1, 0, scm_recv);
 587
 588 SCM
 589 scm_recv (sock, buf, flags)
 590      SCM sock;
 591      SCM buf;
 592      SCM flags;
 593 {
 594   int rv;
 595   int fd;
 596   int flg;
 597
 598   SCM_ASSERT (SCM_NIMP (sock) && SCM_FPORTP (sock), sock, SCM_ARG1, s_recv);
 599   SCM_ASSERT (SCM_NIMP (buf) && SCM_STRINGP (buf), buf, SCM_ARG2, s_recv);
 600   fd = fileno ((FILE *)SCM_STREAM (sock));
 601
 602   if (SCM_UNBNDP (flags))
 603     flg = 0;
 604   else
 605     flg = scm_num2ulong (flags, (char *) SCM_ARG3, s_recv);
 606
 607   SCM_SYSCALL (rv = recv (fd, SCM_CHARS (buf), SCM_LENGTH (buf), flg));
 608   if (rv == -1)
 609     scm_syserror (s_recv);
 610
 611   return SCM_MAKINUM (rv);
 612 }
 613
 614 SCM_PROC (s_send, "send", 2, 1, 0, scm_send);
 615
 616 SCM
 617 scm_send (sock, message, flags)
 618      SCM sock;
 619      SCM message;
 620      SCM flags;
 621 {
 622   int rv;
 623   int fd;
 624   int flg;
 625
 626   sock = SCM_COERCE_OUTPORT (sock);
 627   SCM_ASSERT (SCM_NIMP (sock) && SCM_FPORTP (sock), sock, SCM_ARG1, s_send);
 628   SCM_ASSERT (SCM_NIMP (message) && SCM_ROSTRINGP (message), message, SCM_ARG2, s_send);
 629   fd = fileno ((FILE *)SCM_STREAM (sock));
 630
 631   if (SCM_UNBNDP (flags))
 632     flg = 0;
 633   else
 634     flg = scm_num2ulong (flags, (char *) SCM_ARG3, s_send);
 635
 636   SCM_SYSCALL (rv = send (fd, SCM_ROCHARS (message), SCM_ROLENGTH (message), flg));
 637   if (rv == -1)
 638     scm_syserror (s_send);
 639   return SCM_MAKINUM (rv);
 640 }
 641
 642 SCM_PROC (s_recvfrom, "recvfrom!", 2, 3, 0, scm_recvfrom);
 643
 644 SCM
 645 scm_recvfrom (sock, buf, flags, start, end)
 646      SCM sock;
 647      SCM buf;
 648      SCM flags;
 649      SCM start;
 650      SCM end;
 651 {
 652   int rv;
 653   int fd;
 654   int flg;
 655   int offset = 0;
 656   int cend;
 657   int tmp_size;
 658   SCM address;
 659
 660   SCM_ASSERT (SCM_NIMP (sock) && SCM_FPORTP (sock), sock, SCM_ARG1,
 661               s_recvfrom);
 662   SCM_ASSERT (SCM_NIMP (buf) && SCM_STRINGP (buf), buf, SCM_ARG2, s_recvfrom);
 663   cend = SCM_LENGTH (buf);
 664
 665   if (SCM_UNBNDP (flags))
 666     flg = 0;
 667   else
 668     {
 669       flg = scm_num2ulong (flags, (char *) SCM_ARG3, s_recvfrom);
 670
 671       if (!SCM_UNBNDP (start))
 672         {
 673           offset = (int) scm_num2long (start,
 674                                        (char *) SCM_ARG4, s_recvfrom);
 675
 676           if (offset < 0 || offset >= cend)
 677             scm_out_of_range (s_recvfrom, start);
 678
 679           if (!SCM_UNBNDP (end))
 680             {
 681               int tend = (int) scm_num2long (end,
 682                                              (char *) SCM_ARG5, s_recvfrom);
 683
 684               if (tend <= offset || tend > cend)
 685                 scm_out_of_range (s_recvfrom, end);
 686
 687               cend = tend;
 688             }
 689         }
 690     }
 691
 692   fd = fileno ((FILE *)SCM_STREAM (sock));
 693
 694   tmp_size = scm_addr_buffer_size;
 695   SCM_SYSCALL (rv = recvfrom (fd, SCM_CHARS (buf) + offset,
 696                               cend - offset, flg,
 697                               (struct sockaddr *) scm_addr_buffer,
 698                               &tmp_size));
 699   if (rv == -1)
 700     scm_syserror (s_recvfrom);
 701   if (tmp_size > 0)
 702     address = scm_addr_vector ((struct sockaddr *) scm_addr_buffer, s_recvfrom);
 703   else
 704     address = SCM_BOOL_F;
 705
 706   return scm_cons (SCM_MAKINUM (rv), address);
 707 }
 708
 709 SCM_PROC (s_sendto, "sendto", 4, 0, 1, scm_sendto);
 710
 711 SCM
 712 scm_sendto (sock, message, fam, address, args_and_flags)
 713      SCM sock;
 714      SCM message;
 715      SCM fam;
 716      SCM address;
 717      SCM args_and_flags;
 718 {
 719   int rv;
 720   int fd;
 721   int flg;
 722   struct sockaddr *soka;
 723   scm_sizet size;
 724
 725   sock = SCM_COERCE_OUTPORT (sock);
 726   SCM_ASSERT (SCM_NIMP (sock) && SCM_FPORTP (sock), sock, SCM_ARG1, s_sendto);
 727   SCM_ASSERT (SCM_NIMP (message) && SCM_ROSTRINGP (message), message,
 728               SCM_ARG2, s_sendto);
 729   SCM_ASSERT (SCM_INUMP (fam), fam, SCM_ARG3, s_sendto);
 730   fd = fileno ((FILE *)SCM_STREAM (sock));
 731   SCM_DEFER_INTS;
 732   soka = scm_fill_sockaddr (SCM_INUM (fam), address, &args_and_flags, 4,
 733                             s_sendto, &size);
 734   if (SCM_NULLP (args_and_flags))
 735     flg = 0;
 736   else
 737     {
 738       SCM_ASSERT (SCM_NIMP (args_and_flags) && SCM_CONSP (args_and_flags),
 739               args_and_flags, SCM_ARG5, s_sendto);
 740       flg = scm_num2ulong (SCM_CAR (args_and_flags), (char *) SCM_ARG5, s_sendto);
 741     }
 742   SCM_SYSCALL (rv = sendto (fd, SCM_ROCHARS (message), SCM_ROLENGTH (message),
 743                             flg, soka, size));
 744   if (rv == -1)
 745     scm_syserror (s_sendto);
 746   scm_must_free ((char *) soka);
 747   SCM_ALLOW_INTS;
 748   return SCM_MAKINUM (rv);
 749 }
 750 \f
 751
 752
 753 void
 754 scm_init_socket ()
 755 {
 756   /* protocol families.  */
 757 #ifdef AF_UNSPEC
 758   scm_sysintern ("AF_UNSPEC", SCM_MAKINUM (AF_UNSPEC));
 759 #endif
 760 #ifdef AF_UNIX
 761   scm_sysintern ("AF_UNIX", SCM_MAKINUM (AF_UNIX));
 762 #endif
 763 #ifdef AF_INET
 764   scm_sysintern ("AF_INET", SCM_MAKINUM (AF_INET));
 765 #endif
 766
 767 #ifdef PF_UNSPEC
 768   scm_sysintern ("PF_UNSPEC", SCM_MAKINUM (PF_UNSPEC));
 769 #endif
 770 #ifdef PF_UNIX
 771   scm_sysintern ("PF_UNIX", SCM_MAKINUM (PF_UNIX));
 772 #endif
 773 #ifdef PF_INET
 774   scm_sysintern ("PF_INET", SCM_MAKINUM (PF_INET));
 775 #endif
 776
 777   /* socket types.  */
 778 #ifdef SOCK_STREAM
 779   scm_sysintern ("SOCK_STREAM", SCM_MAKINUM (SOCK_STREAM));
 780 #endif
 781 #ifdef SOCK_DGRAM
 782   scm_sysintern ("SOCK_DGRAM", SCM_MAKINUM (SOCK_DGRAM));
 783 #endif
 784 #ifdef SOCK_RAW
 785   scm_sysintern ("SOCK_RAW", SCM_MAKINUM (SOCK_RAW));
 786 #endif
 787
 788   /* setsockopt level.  */
 789 #ifdef SOL_SOCKET
 790   scm_sysintern ("SOL_SOCKET", SCM_MAKINUM (SOL_SOCKET));
 791 #endif
 792 #ifdef SOL_IP
 793   scm_sysintern ("SOL_IP", SCM_MAKINUM (SOL_IP));
 794 #endif
 795 #ifdef SOL_TCP
 796   scm_sysintern ("SOL_TCP", SCM_MAKINUM (SOL_TCP));
 797 #endif
 798 #ifdef SOL_UDP
 799   scm_sysintern ("SOL_UDP", SCM_MAKINUM (SOL_UDP));
 800 #endif
 801
 802   /* setsockopt names.  */
 803 #ifdef SO_DEBUG
 804   scm_sysintern ("SO_DEBUG", SCM_MAKINUM (SO_DEBUG));
 805 #endif
 806 #ifdef SO_REUSEADDR
 807   scm_sysintern ("SO_REUSEADDR", SCM_MAKINUM (SO_REUSEADDR));
 808 #endif
 809 #ifdef SO_STYLE
 810   scm_sysintern ("SO_STYLE", SCM_MAKINUM (SO_STYLE));
 811 #endif
 812 #ifdef SO_TYPE
 813   scm_sysintern ("SO_TYPE", SCM_MAKINUM (SO_TYPE));
 814 #endif
 815 #ifdef SO_ERROR
 816   scm_sysintern ("SO_ERROR", SCM_MAKINUM (SO_ERROR));
 817 #endif
 818 #ifdef SO_DONTROUTE
 819   scm_sysintern ("SO_DONTROUTE", SCM_MAKINUM (SO_DONTROUTE));
 820 #endif
 821 #ifdef SO_BROADCAST
 822   scm_sysintern ("SO_BROADCAST", SCM_MAKINUM (SO_BROADCAST));
 823 #endif
 824 #ifdef SO_SNDBUF
 825   scm_sysintern ("SO_SNDBUF", SCM_MAKINUM (SO_SNDBUF));
 826 #endif
 827 #ifdef SO_RCVBUF
 828   scm_sysintern ("SO_RCVBUF", SCM_MAKINUM (SO_RCVBUF));
 829 #endif
 830 #ifdef SO_KEEPALIVE
 831   scm_sysintern ("SO_KEEPALIVE", SCM_MAKINUM (SO_KEEPALIVE));
 832 #endif
 833 #ifdef SO_OOBINLINE
 834   scm_sysintern ("SO_OOBINLINE", SCM_MAKINUM (SO_OOBINLINE));
 835 #endif
 836 #ifdef SO_NO_CHECK
 837   scm_sysintern ("SO_NO_CHECK", SCM_MAKINUM (SO_NO_CHECK));
 838 #endif
 839 #ifdef SO_PRIORITY
 840   scm_sysintern ("SO_PRIORITY", SCM_MAKINUM (SO_PRIORITY));
 841 #endif
 842 #ifdef SO_LINGER
 843   scm_sysintern ("SO_LINGER", SCM_MAKINUM (SO_LINGER));
 844 #endif
 845
 846   /* recv/send options.  */
 847 #ifdef MSG_OOB
 848   scm_sysintern ("MSG_OOB", SCM_MAKINUM (MSG_OOB));
 849 #endif
 850 #ifdef MSG_PEEK
 851   scm_sysintern ("MSG_PEEK", SCM_MAKINUM (MSG_PEEK));
 852 #endif
 853 #ifdef MSG_DONTROUTE
 854   scm_sysintern ("MSG_DONTROUTE", SCM_MAKINUM (MSG_DONTROUTE));
 855 #endif
 856
 857   scm_add_feature ("socket");
 858   scm_init_addr_buffer ();
 859
 860 #include "socket.x"
 861 }
 862