libguile/socket.c

   1 /*      Copyright (C) 1996,1997,1998 Free Software Foundation, Inc.
   2  *
   3  * This program is free software; you can redistribute it and/or modify
   4  * it under the terms of the GNU General Public License as published by
   5  * the Free Software Foundation; either version 2, or (at your option)
   6  * any later version.
   7  *
   8  * This program is distributed in the hope that it will be useful,
   9  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  10  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11  * GNU General Public License for more details.
  12  *
  13  * You should have received a copy of the GNU General Public License
  14  * along with this software; see the file COPYING.  If not, write to
  15  * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
  16  * Boston, MA 02111-1307 USA
  17  *
  18  * As a special exception, the Free Software Foundation gives permission
  19  * for additional uses of the text contained in its release of GUILE.
  20  *
  21  * The exception is that, if you link the GUILE library with other files
  22  * to produce an executable, this does not by itself cause the
  23  * resulting executable to be covered by the GNU General Public License.
  24  * Your use of that executable is in no way restricted on account of
  25  * linking the GUILE library code into it.
  26  *
  27  * This exception does not however invalidate any other reasons why
  28  * the executable file might be covered by the GNU General Public License.
  29  *
  30  * This exception applies only to the code released by the
  31  * Free Software Foundation under the name GUILE.  If you copy
  32  * code from other Free Software Foundation releases into a copy of
  33  * GUILE, as the General Public License permits, the exception does
  34  * not apply to the code that you add in this way.  To avoid misleading
  35  * anyone as to the status of such modified files, you must delete
  36  * this exception notice from them.
  37  *
  38  * If you write modifications of your own for GUILE, it is your choice
  39  * whether to permit this exception to apply to your modifications.
  40  * If you do not wish that, delete this exception notice.  */
  41 \f
  42
  43 #include <stdio.h>
  44
  45 #include "_scm.h"
  46 #include "unif.h"
  47 #include "feature.h"
  48 #include "fports.h"
  49
  50 #include "socket.h"
  51
  52 #ifdef HAVE_STRING_H
  53 #include <string.h>
  54 #endif
  55 #ifdef HAVE_UNISTD_H
  56 #include <unistd.h>
  57 #endif
  58 #include <sys/types.h>
  59 #include <sys/socket.h>
  60 #ifdef HAVE_UNIX_DOMAIN_SOCKETS
  61 #include <sys/un.h>
  62 #endif
  63 #include <netinet/in.h>
  64 #include <netdb.h>
  65 #include <arpa/inet.h>
  66
  67 \f
  68
  69 SCM_SYMBOL (sym_socket, "socket");
  70 static SCM scm_sock_fd_to_port SCM_P ((int fd, const char *proc));
  71
  72 static SCM
  73 scm_sock_fd_to_port (fd, proc)
  74      int fd;
  75      const char *proc;
  76 {
  77   SCM result;
  78
  79   if (fd == -1)
  80     scm_syserror (proc);
  81   result = scm_fdes_to_port (fd, "r+0", sym_socket);
  82   return result;
  83 }
  84
  85 SCM_PROC (s_socket, "socket", 3, 0, 0, scm_socket);
  86
  87 SCM
  88 scm_socket (family, style, proto)
  89      SCM family;
  90      SCM style;
  91      SCM proto;
  92 {
  93   int fd;
  94   SCM result;
  95
  96   SCM_ASSERT (SCM_INUMP (family), family, SCM_ARG1, s_socket);
  97   SCM_ASSERT (SCM_INUMP (style), style, SCM_ARG2, s_socket);
  98   SCM_ASSERT (SCM_INUMP (proto), proto, SCM_ARG3, s_socket);
  99   fd = socket (SCM_INUM (family), SCM_INUM (style), SCM_INUM (proto));
 100   result = scm_sock_fd_to_port (fd, s_socket);
 101   return result;
 102 }
 103
 104
 105
 106 #ifdef HAVE_SOCKETPAIR
 107 SCM_PROC (s_socketpair, "socketpair", 3, 0, 0, scm_socketpair);
 108
 109 SCM
 110 scm_socketpair (family, style, proto)
 111      SCM family;
 112      SCM style;
 113      SCM proto;
 114 {
 115   int fam;
 116   int fd[2];
 117   SCM a;
 118   SCM b;
 119
 120   SCM_ASSERT (SCM_INUMP (family), family, SCM_ARG1, s_socketpair);
 121   SCM_ASSERT (SCM_INUMP (style), style, SCM_ARG2, s_socketpair);
 122   SCM_ASSERT (SCM_INUMP (proto), proto, SCM_ARG3, s_socketpair);
 123
 124   fam = SCM_INUM (family);
 125
 126   if (socketpair (fam, SCM_INUM (style), SCM_INUM (proto), fd) == -1)
 127     scm_syserror (s_socketpair);
 128
 129   a = scm_sock_fd_to_port (fd[0], s_socketpair);
 130   b = scm_sock_fd_to_port (fd[1], s_socketpair);
 131   return scm_cons (a, b);
 132 }
 133 #endif
 134
 135 SCM_PROC (s_getsockopt, "getsockopt", 3, 0, 0, scm_getsockopt);
 136
 137 SCM
 138 scm_getsockopt (sock, level, optname)
 139      SCM sock;
 140      SCM level;
 141      SCM optname;
 142 {
 143   int fd;
 144   int optlen;
 145 #ifdef HAVE_STRUCT_LINGER
 146   char optval[sizeof (struct linger)];
 147 #else
 148   char optval[sizeof (scm_sizet)];
 149 #endif
 150   int ilevel;
 151   int ioptname;
 152
 153 #ifdef HAVE_STRUCT_LINGER
 154   optlen = (int) sizeof (struct linger);
 155 #else
 156   optlen = (int) sizeof (scm_sizet);
 157 #endif
 158
 159   sock = SCM_COERCE_OUTPORT (sock);
 160   SCM_ASSERT (SCM_NIMP (sock) && SCM_OPFPORTP (sock), sock, SCM_ARG1,
 161               s_getsockopt);
 162   SCM_ASSERT (SCM_INUMP (level), level, SCM_ARG2, s_getsockopt);
 163   SCM_ASSERT (SCM_INUMP (optname), optname, SCM_ARG3, s_getsockopt);
 164
 165   fd = SCM_FPORT_FDES (sock);
 166   ilevel = SCM_INUM (level);
 167   ioptname = SCM_INUM (optname);
 168   if (getsockopt (fd, ilevel, ioptname, (void *) optval, &optlen) == -1)
 169     scm_syserror (s_getsockopt);
 170
 171 #ifdef SO_LINGER
 172   if (ilevel == SOL_SOCKET && ioptname == SO_LINGER)
 173     {
 174 #ifdef HAVE_STRUCT_LINGER
 175       struct linger *ling = (struct linger *) optval;
 176       return scm_cons (SCM_MAKINUM (ling->l_onoff),
 177                        SCM_MAKINUM (ling->l_linger));
 178 #else
 179       scm_sizet *ling = (scm_sizet *) optval;
 180       return scm_cons (SCM_MAKINUM (*ling),
 181                        SCM_MAKINUM (0));
 182 #endif
 183     }
 184 #endif
 185 #ifdef SO_SNDBUF
 186   if (ilevel == SOL_SOCKET && ioptname == SO_SNDBUF)
 187     {
 188       scm_sizet *bufsize = (scm_sizet *) optval;
 189       return SCM_MAKINUM (*bufsize);
 190     }
 191 #endif
 192 #ifdef SO_RCVBUF
 193   if (ilevel == SOL_SOCKET && ioptname == SO_RCVBUF)
 194     {
 195       scm_sizet *bufsize = (scm_sizet *) optval;
 196       return SCM_MAKINUM (*bufsize);
 197     }
 198 #endif
 199   return SCM_MAKINUM (*(int *) optval);
 200 }
 201
 202 SCM_PROC (s_setsockopt, "setsockopt", 4, 0, 0, scm_setsockopt);
 203
 204 SCM
 205 scm_setsockopt (sock, level, optname, value)
 206      SCM sock;
 207      SCM level;
 208      SCM optname;
 209      SCM value;
 210 {
 211   int fd;
 212   int optlen;
 213 #ifdef HAVE_STRUCT_LINGER
 214   char optval[sizeof (struct linger)]; /* Biggest option :-(  */
 215 #else
 216   char optval[sizeof (scm_sizet)];
 217 #endif
 218   int ilevel, ioptname;
 219   sock = SCM_COERCE_OUTPORT (sock);
 220   SCM_ASSERT (SCM_NIMP (sock) && SCM_OPFPORTP (sock), sock, SCM_ARG1,
 221               s_setsockopt);
 222   SCM_ASSERT (SCM_INUMP (level), level, SCM_ARG2, s_setsockopt);
 223   SCM_ASSERT (SCM_INUMP (optname), optname, SCM_ARG3, s_setsockopt);
 224   fd = SCM_FPORT_FDES (sock);
 225   ilevel = SCM_INUM (level);
 226   ioptname = SCM_INUM (optname);
 227   if (0);
 228 #ifdef SO_LINGER
 229   else if (ilevel == SOL_SOCKET && ioptname == SO_LINGER)
 230     {
 231 #ifdef HAVE_STRUCT_LINGER
 232       struct linger ling;
 233       SCM_ASSERT (SCM_NIMP (value) && SCM_CONSP (value)
 234                   && SCM_INUMP (SCM_CAR (value))
 235                   &&  SCM_INUMP (SCM_CDR (value)),
 236                   value, SCM_ARG4, s_setsockopt);
 237       ling.l_onoff = SCM_INUM (SCM_CAR (value));
 238       ling.l_linger = SCM_INUM (SCM_CDR (value));
 239       optlen = (int) sizeof (struct linger);
 240       memcpy (optval, (void *) &ling, optlen);
 241 #else
 242       scm_sizet ling;
 243       SCM_ASSERT (SCM_NIMP (value) && SCM_CONSP (value)
 244                   && SCM_INUMP (SCM_CAR (value))
 245                   &&  SCM_INUMP (SCM_CDR (value)),
 246                   value, SCM_ARG4, s_setsockopt);
 247       ling = SCM_INUM (SCM_CAR (value));
 248       optlen = (int) sizeof (scm_sizet);
 249       (*(scm_sizet *) optval) = (scm_sizet) SCM_INUM (value);
 250 #endif
 251     }
 252 #endif
 253 #ifdef SO_SNDBUF
 254   else if (ilevel == SOL_SOCKET && ioptname == SO_SNDBUF)
 255     {
 256       SCM_ASSERT (SCM_INUMP (value), value, SCM_ARG4, s_setsockopt);
 257       optlen = (int) sizeof (scm_sizet);
 258       (*(scm_sizet *) optval) = (scm_sizet) SCM_INUM (value);
 259     }
 260 #endif
 261 #ifdef SO_RCVBUF
 262   else if (ilevel == SOL_SOCKET && ioptname == SO_RCVBUF)
 263     {
 264       SCM_ASSERT (SCM_INUMP (value), value, SCM_ARG4, s_setsockopt);
 265       optlen = (int) sizeof (scm_sizet);
 266       (*(scm_sizet *) optval) = (scm_sizet) SCM_INUM (value);
 267     }
 268 #endif
 269   else
 270     {
 271       /* Most options just take an int.  */
 272       SCM_ASSERT (SCM_INUMP (value), value, SCM_ARG4, s_setsockopt);
 273       optlen = (int) sizeof (int);
 274       (*(int *) optval) = (int) SCM_INUM (value);
 275     }
 276   if (setsockopt (fd, ilevel, ioptname, (void *) optval, optlen) == -1)
 277     scm_syserror (s_setsockopt);
 278   return SCM_UNSPECIFIED;
 279 }
 280
 281 SCM_PROC (s_shutdown, "shutdown", 2, 0, 0, scm_shutdown);
 282
 283 SCM
 284 scm_shutdown (sock, how)
 285      SCM sock;
 286      SCM how;
 287 {
 288   int fd;
 289   sock = SCM_COERCE_OUTPORT (sock);
 290   SCM_ASSERT (SCM_NIMP (sock) && SCM_OPFPORTP (sock), sock, SCM_ARG1,
 291               s_shutdown);
 292   SCM_ASSERT (SCM_INUMP (how) && 0 <= SCM_INUM (how) && 2 >= SCM_INUM (how),
 293           how, SCM_ARG2, s_shutdown);
 294   fd = SCM_FPORT_FDES (sock);
 295   if (shutdown (fd, SCM_INUM (how)) == -1)
 296     scm_syserror (s_shutdown);
 297   return SCM_UNSPECIFIED;
 298 }
 299
 300 /* convert fam/address/args into a sockaddr of the appropriate type.
 301    args is modified by removing the arguments actually used.
 302    which_arg and proc are used when reporting errors:
 303    which_arg is the position of address in the original argument list.
 304    proc is the name of the original procedure.
 305    size returns the size of the structure allocated.  */
 306
 307
 308 static struct sockaddr * scm_fill_sockaddr SCM_P ((int fam, SCM address, SCM *args, int which_arg, const char *proc, scm_sizet *size));
 309
 310 static struct sockaddr *
 311 scm_fill_sockaddr (fam, address, args, which_arg, proc, size)
 312      int fam;
 313      SCM address;
 314      SCM *args;
 315      int which_arg;
 316      const char *proc;
 317      scm_sizet *size;
 318 {
 319   switch (fam)
 320     {
 321     case AF_INET:
 322       {
 323         SCM isport;
 324         struct sockaddr_in *soka;
 325
 326         soka = (struct sockaddr_in *)
 327           scm_must_malloc (sizeof (struct sockaddr_in), proc);
 328         soka->sin_family = AF_INET;
 329         soka->sin_addr.s_addr =
 330           htonl (scm_num2ulong (address, (char *) which_arg, proc));
 331         SCM_ASSERT (SCM_NIMP (*args) && SCM_CONSP (*args), *args,
 332                     which_arg + 1, proc);
 333         isport = SCM_CAR (*args);
 334         *args = SCM_CDR (*args);
 335         SCM_ASSERT (SCM_INUMP (isport), isport, which_arg + 1, proc);
 336         soka->sin_port = htons (SCM_INUM (isport));
 337         *size = sizeof (struct sockaddr_in);
 338         return (struct sockaddr *) soka;
 339       }
 340 #ifdef HAVE_UNIX_DOMAIN_SOCKETS
 341     case AF_UNIX:
 342       {
 343         struct sockaddr_un *soka;
 344
 345         soka = (struct sockaddr_un *)
 346           scm_must_malloc (sizeof (struct sockaddr_un), proc);
 347         soka->sun_family = AF_UNIX;
 348         SCM_ASSERT (SCM_NIMP (address) && SCM_ROSTRINGP (address), address,
 349                     which_arg, proc);
 350         memcpy (soka->sun_path, SCM_ROCHARS (address),
 351                 1 + SCM_ROLENGTH (address));
 352         *size = sizeof (struct sockaddr_un);
 353         return (struct sockaddr *) soka;
 354       }
 355 #endif
 356     default:
 357       scm_out_of_range (proc, SCM_MAKINUM (fam));
 358     }
 359 }
 360
 361 SCM_PROC (s_connect, "connect", 3, 0, 1, scm_connect);
 362
 363 SCM
 364 scm_connect (sock, fam, address, args)
 365
 366      SCM sock;
 367      SCM fam;
 368      SCM address;
 369      SCM args;
 370 {
 371   int fd;
 372   struct sockaddr *soka;
 373   scm_sizet size;
 374
 375   sock = SCM_COERCE_OUTPORT (sock);
 376   SCM_ASSERT (SCM_NIMP (sock) && SCM_OPFPORTP (sock), sock, SCM_ARG1, s_connect);
 377   SCM_ASSERT (SCM_INUMP (fam), fam, SCM_ARG2, s_connect);
 378   fd = SCM_FPORT_FDES (sock);
 379   soka = scm_fill_sockaddr (SCM_INUM (fam), address, &args, 3, s_connect, &size);
 380   if (connect (fd, soka, size) == -1)
 381     scm_syserror (s_connect);
 382   scm_must_free ((char *) soka);
 383   return SCM_UNSPECIFIED;
 384 }
 385
 386 SCM_PROC (s_bind, "bind", 3, 0, 1, scm_bind);
 387
 388 SCM
 389 scm_bind (sock, fam, address, args)
 390      SCM sock;
 391      SCM fam;
 392      SCM address;
 393      SCM args;
 394 {
 395   int rv;
 396   struct sockaddr *soka;
 397   scm_sizet size;
 398   int fd;
 399
 400   sock = SCM_COERCE_OUTPORT (sock);
 401   SCM_ASSERT (SCM_NIMP (sock) && SCM_OPFPORTP (sock), sock, SCM_ARG1, s_bind);
 402   SCM_ASSERT (SCM_INUMP (fam), fam, SCM_ARG2, s_bind);
 403   soka = scm_fill_sockaddr (SCM_INUM (fam), address, &args, 3, s_bind, &size);
 404   fd = SCM_FPORT_FDES (sock);
 405   rv = bind (fd, soka, size);
 406   if (rv == -1)
 407     scm_syserror (s_bind);
 408   scm_must_free ((char *) soka);
 409   return SCM_UNSPECIFIED;
 410 }
 411
 412 SCM_PROC (s_listen, "listen", 2, 0, 0, scm_listen);
 413
 414 SCM
 415 scm_listen (sock, backlog)
 416      SCM sock;
 417      SCM backlog;
 418 {
 419   int fd;
 420   sock = SCM_COERCE_OUTPORT (sock);
 421   SCM_ASSERT (SCM_NIMP (sock) && SCM_OPFPORTP (sock), sock, SCM_ARG1, s_listen);
 422   SCM_ASSERT (SCM_INUMP (backlog), backlog, SCM_ARG2, s_listen);
 423   fd = SCM_FPORT_FDES (sock);
 424   if (listen (fd, SCM_INUM (backlog)) == -1)
 425     scm_syserror (s_listen);
 426   return SCM_UNSPECIFIED;
 427 }
 428
 429 /* Put the components of a sockaddr into a new SCM vector.  */
 430
 431 static SCM scm_addr_vector SCM_P ((struct sockaddr *address, const char *proc));
 432
 433 static SCM
 434 scm_addr_vector (address, proc)
 435      struct sockaddr *address;
 436      const char *proc;
 437 {
 438   short int fam = address->sa_family;
 439   SCM result;
 440   SCM *ve;
 441 #ifdef HAVE_UNIX_DOMAIN_SOCKETS
 442   if (fam == AF_UNIX)
 443     {
 444       struct sockaddr_un *nad = (struct sockaddr_un *) address;
 445       result = scm_make_vector (SCM_MAKINUM (2), SCM_UNSPECIFIED);
 446       ve = SCM_VELTS (result);
 447       ve[0] = scm_ulong2num ((unsigned long) fam);
 448       ve[1] = scm_makfromstr (nad->sun_path,
 449                               (scm_sizet) strlen (nad->sun_path), 0);
 450     }
 451   else
 452 #endif
 453   if (fam == AF_INET)
 454     {
 455       struct sockaddr_in *nad = (struct sockaddr_in *) address;
 456       result = scm_make_vector (SCM_MAKINUM (3), SCM_UNSPECIFIED);
 457       ve = SCM_VELTS (result);
 458       ve[0] = scm_ulong2num ((unsigned long) fam);
 459       ve[1] = scm_ulong2num (ntohl (nad->sin_addr.s_addr));
 460       ve[2] = scm_ulong2num ((unsigned long) ntohs (nad->sin_port));
 461     }
 462   else
 463     scm_misc_error (proc, "Unrecognised address family: %s",
 464                     scm_listify (SCM_MAKINUM (fam), SCM_UNDEFINED));
 465
 466   return result;
 467 }
 468
 469 /* Allocate a buffer large enough to hold any sockaddr type.  */
 470 static char *scm_addr_buffer;
 471 static int scm_addr_buffer_size;
 472
 473 static void scm_init_addr_buffer SCM_P ((void));
 474
 475 static void
 476 scm_init_addr_buffer ()
 477 {
 478   scm_addr_buffer_size =
 479 #ifdef HAVE_UNIX_DOMAIN_SOCKETS
 480   (int) sizeof (struct sockaddr_un)
 481 #else
 482   0
 483 #endif
 484   ;
 485   if (sizeof (struct sockaddr_in) > scm_addr_buffer_size)
 486     scm_addr_buffer_size = (int) sizeof (struct sockaddr_in);
 487   scm_addr_buffer = scm_must_malloc (scm_addr_buffer_size, "address buffer");
 488 }
 489
 490 SCM_PROC (s_accept, "accept", 1, 0, 0, scm_accept);
 491
 492 SCM
 493 scm_accept (sock)
 494      SCM sock;
 495 {
 496   int fd;
 497   int newfd;
 498   SCM address;
 499   SCM newsock;
 500
 501   int tmp_size;
 502   sock = SCM_COERCE_OUTPORT (sock);
 503   SCM_ASSERT (SCM_NIMP (sock) && SCM_OPFPORTP (sock), sock, SCM_ARG1, s_accept);
 504   fd = SCM_FPORT_FDES (sock);
 505   tmp_size = scm_addr_buffer_size;
 506   newfd = accept (fd, (struct sockaddr *) scm_addr_buffer, &tmp_size);
 507   newsock = scm_sock_fd_to_port (newfd, s_accept);
 508   if (tmp_size > 0)
 509     address = scm_addr_vector ((struct sockaddr *) scm_addr_buffer, s_accept);
 510   else
 511     address = SCM_BOOL_F;
 512
 513   return scm_cons (newsock, address);
 514 }
 515
 516 SCM_PROC (s_getsockname, "getsockname", 1, 0, 0, scm_getsockname);
 517
 518 SCM
 519 scm_getsockname (sock)
 520      SCM sock;
 521 {
 522   int tmp_size;
 523   int fd;
 524   SCM result;
 525   sock = SCM_COERCE_OUTPORT (sock);
 526   SCM_ASSERT (SCM_NIMP (sock) && SCM_OPFPORTP (sock), sock, SCM_ARG1, s_getsockname);
 527   fd = SCM_FPORT_FDES (sock);
 528   tmp_size = scm_addr_buffer_size;
 529   if (getsockname (fd, (struct sockaddr *) scm_addr_buffer, &tmp_size) == -1)
 530     scm_syserror (s_getsockname);
 531   if (tmp_size > 0)
 532     result = scm_addr_vector ((struct sockaddr *) scm_addr_buffer, s_getsockname);
 533   else
 534     result = SCM_BOOL_F;
 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   sock = SCM_COERCE_OUTPORT (sock);
 548   SCM_ASSERT (SCM_NIMP (sock) && SCM_FPORTP (sock), sock, SCM_ARG1, s_getpeername);
 549   fd = SCM_FPORT_FDES (sock);
 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   return result;
 558 }
 559
 560 SCM_PROC (s_recv, "recv!", 2, 1, 0, scm_recv);
 561
 562 SCM
 563 scm_recv (sock, buf, flags)
 564      SCM sock;
 565      SCM buf;
 566      SCM flags;
 567 {
 568   int rv;
 569   int fd;
 570   int flg;
 571
 572   SCM_ASSERT (SCM_NIMP (sock) && SCM_OPFPORTP (sock), sock, SCM_ARG1, s_recv);
 573   SCM_ASSERT (SCM_NIMP (buf) && SCM_STRINGP (buf), buf, SCM_ARG2, s_recv);
 574
 575   fd = SCM_FPORT_FDES (sock);
 576   if (SCM_UNBNDP (flags))
 577     flg = 0;
 578   else
 579     flg = scm_num2ulong (flags, (char *) SCM_ARG3, s_recv);
 580
 581   SCM_SYSCALL (rv = recv (fd, SCM_CHARS (buf), SCM_LENGTH (buf), flg));
 582   if (rv == -1)
 583     scm_syserror (s_recv);
 584
 585   return SCM_MAKINUM (rv);
 586 }
 587
 588 SCM_PROC (s_send, "send", 2, 1, 0, scm_send);
 589
 590 SCM
 591 scm_send (sock, message, flags)
 592      SCM sock;
 593      SCM message;
 594      SCM flags;
 595 {
 596   int rv;
 597   int fd;
 598   int flg;
 599
 600   sock = SCM_COERCE_OUTPORT (sock);
 601   SCM_ASSERT (SCM_NIMP (sock) && SCM_OPFPORTP (sock), sock, SCM_ARG1, s_send);
 602   SCM_ASSERT (SCM_NIMP (message) && SCM_ROSTRINGP (message), message, SCM_ARG2, s_send);
 603
 604   fd = SCM_FPORT_FDES (sock);
 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_ROCHARS (message), SCM_ROLENGTH (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_OPFPORTP (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 = SCM_FPORT_FDES (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   int save_err;
 699
 700   sock = SCM_COERCE_OUTPORT (sock);
 701   SCM_ASSERT (SCM_NIMP (sock) && SCM_FPORTP (sock), sock, SCM_ARG1, s_sendto);
 702   SCM_ASSERT (SCM_NIMP (message) && SCM_ROSTRINGP (message), message,
 703               SCM_ARG2, s_sendto);
 704   SCM_ASSERT (SCM_INUMP (fam), fam, SCM_ARG3, s_sendto);
 705   fd = SCM_FPORT_FDES (sock);
 706   soka = scm_fill_sockaddr (SCM_INUM (fam), address, &args_and_flags, 4,
 707                             s_sendto, &size);
 708   if (SCM_NULLP (args_and_flags))
 709     flg = 0;
 710   else
 711     {
 712       SCM_ASSERT (SCM_NIMP (args_and_flags) && SCM_CONSP (args_and_flags),
 713               args_and_flags, SCM_ARG5, s_sendto);
 714       flg = scm_num2ulong (SCM_CAR (args_and_flags), (char *) SCM_ARG5, s_sendto);
 715     }
 716   SCM_SYSCALL (rv = sendto (fd, SCM_ROCHARS (message), SCM_ROLENGTH (message),
 717                             flg, soka, size));
 718   save_err = errno;
 719   scm_must_free ((char *) soka);
 720   errno = save_err;
 721   if (rv == -1)
 722     scm_syserror (s_sendto);
 723   return SCM_MAKINUM (rv);
 724 }
 725 \f
 726
 727
 728 void
 729 scm_init_socket ()
 730 {
 731   /* protocol families.  */
 732 #ifdef AF_UNSPEC
 733   scm_sysintern ("AF_UNSPEC", SCM_MAKINUM (AF_UNSPEC));
 734 #endif
 735 #ifdef AF_UNIX
 736   scm_sysintern ("AF_UNIX", SCM_MAKINUM (AF_UNIX));
 737 #endif
 738 #ifdef AF_INET
 739   scm_sysintern ("AF_INET", SCM_MAKINUM (AF_INET));
 740 #endif
 741
 742 #ifdef PF_UNSPEC
 743   scm_sysintern ("PF_UNSPEC", SCM_MAKINUM (PF_UNSPEC));
 744 #endif
 745 #ifdef PF_UNIX
 746   scm_sysintern ("PF_UNIX", SCM_MAKINUM (PF_UNIX));
 747 #endif
 748 #ifdef PF_INET
 749   scm_sysintern ("PF_INET", SCM_MAKINUM (PF_INET));
 750 #endif
 751
 752   /* socket types.  */
 753 #ifdef SOCK_STREAM
 754   scm_sysintern ("SOCK_STREAM", SCM_MAKINUM (SOCK_STREAM));
 755 #endif
 756 #ifdef SOCK_DGRAM
 757   scm_sysintern ("SOCK_DGRAM", SCM_MAKINUM (SOCK_DGRAM));
 758 #endif
 759 #ifdef SOCK_RAW
 760   scm_sysintern ("SOCK_RAW", SCM_MAKINUM (SOCK_RAW));
 761 #endif
 762
 763   /* setsockopt level.  */
 764 #ifdef SOL_SOCKET
 765   scm_sysintern ("SOL_SOCKET", SCM_MAKINUM (SOL_SOCKET));
 766 #endif
 767 #ifdef SOL_IP
 768   scm_sysintern ("SOL_IP", SCM_MAKINUM (SOL_IP));
 769 #endif
 770 #ifdef SOL_TCP
 771   scm_sysintern ("SOL_TCP", SCM_MAKINUM (SOL_TCP));
 772 #endif
 773 #ifdef SOL_UDP
 774   scm_sysintern ("SOL_UDP", SCM_MAKINUM (SOL_UDP));
 775 #endif
 776
 777   /* setsockopt names.  */
 778 #ifdef SO_DEBUG
 779   scm_sysintern ("SO_DEBUG", SCM_MAKINUM (SO_DEBUG));
 780 #endif
 781 #ifdef SO_REUSEADDR
 782   scm_sysintern ("SO_REUSEADDR", SCM_MAKINUM (SO_REUSEADDR));
 783 #endif
 784 #ifdef SO_STYLE
 785   scm_sysintern ("SO_STYLE", SCM_MAKINUM (SO_STYLE));
 786 #endif
 787 #ifdef SO_TYPE
 788   scm_sysintern ("SO_TYPE", SCM_MAKINUM (SO_TYPE));
 789 #endif
 790 #ifdef SO_ERROR
 791   scm_sysintern ("SO_ERROR", SCM_MAKINUM (SO_ERROR));
 792 #endif
 793 #ifdef SO_DONTROUTE
 794   scm_sysintern ("SO_DONTROUTE", SCM_MAKINUM (SO_DONTROUTE));
 795 #endif
 796 #ifdef SO_BROADCAST
 797   scm_sysintern ("SO_BROADCAST", SCM_MAKINUM (SO_BROADCAST));
 798 #endif
 799 #ifdef SO_SNDBUF
 800   scm_sysintern ("SO_SNDBUF", SCM_MAKINUM (SO_SNDBUF));
 801 #endif
 802 #ifdef SO_RCVBUF
 803   scm_sysintern ("SO_RCVBUF", SCM_MAKINUM (SO_RCVBUF));
 804 #endif
 805 #ifdef SO_KEEPALIVE
 806   scm_sysintern ("SO_KEEPALIVE", SCM_MAKINUM (SO_KEEPALIVE));
 807 #endif
 808 #ifdef SO_OOBINLINE
 809   scm_sysintern ("SO_OOBINLINE", SCM_MAKINUM (SO_OOBINLINE));
 810 #endif
 811 #ifdef SO_NO_CHECK
 812   scm_sysintern ("SO_NO_CHECK", SCM_MAKINUM (SO_NO_CHECK));
 813 #endif
 814 #ifdef SO_PRIORITY
 815   scm_sysintern ("SO_PRIORITY", SCM_MAKINUM (SO_PRIORITY));
 816 #endif
 817 #ifdef SO_LINGER
 818   scm_sysintern ("SO_LINGER", SCM_MAKINUM (SO_LINGER));
 819 #endif
 820
 821   /* recv/send options.  */
 822 #ifdef MSG_OOB
 823   scm_sysintern ("MSG_OOB", SCM_MAKINUM (MSG_OOB));
 824 #endif
 825 #ifdef MSG_PEEK
 826   scm_sysintern ("MSG_PEEK", SCM_MAKINUM (MSG_PEEK));
 827 #endif
 828 #ifdef MSG_DONTROUTE
 829   scm_sysintern ("MSG_DONTROUTE", SCM_MAKINUM (MSG_DONTROUTE));
 830 #endif
 831
 832   scm_add_feature ("socket");
 833   scm_init_addr_buffer ();
 834
 835 #include "socket.x"
 836 }
 837