libguile/net_db.c

   1 /* "net_db.c" network database support
   2  * Copyright (C) 1995-2000 Free Software Foundation, Inc.
   3  *
   4  * This program is free software; you can redistribute it and/or modify
   5  * it under the terms of the GNU General Public License as published by
   6  * the Free Software Foundation; either version 2, or (at your option)
   7  * any later version.
   8  *
   9  * This program is distributed in the hope that it will be useful,
  10  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  11  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12  * GNU General Public License for more details.
  13  *
  14  * You should have received a copy of the GNU General Public License
  15  * along with this software; see the file COPYING.  If not, write to
  16  * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
  17  * Boston, MA 02111-1307 USA
  18  *
  19  * As a special exception, the Free Software Foundation gives permission
  20  * for additional uses of the text contained in its release of GUILE.
  21  *
  22  * The exception is that, if you link the GUILE library with other files
  23  * to produce an executable, this does not by itself cause the
  24  * resulting executable to be covered by the GNU General Public License.
  25  * Your use of that executable is in no way restricted on account of
  26  * linking the GUILE library code into it.
  27  *
  28  * This exception does not however invalidate any other reasons why
  29  * the executable file might be covered by the GNU General Public License.
  30  *
  31  * This exception applies only to the code released by the
  32  * Free Software Foundation under the name GUILE.  If you copy
  33  * code from other Free Software Foundation releases into a copy of
  34  * GUILE, as the General Public License permits, the exception does
  35  * not apply to the code that you add in this way.  To avoid misleading
  36  * anyone as to the status of such modified files, you must delete
  37  * this exception notice from them.
  38  *
  39  * If you write modifications of your own for GUILE, it is your choice
  40  * whether to permit this exception to apply to your modifications.
  41  * If you do not wish that, delete this exception notice.  */
  42
  43 /* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
  44    gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
  45
  46
  47 /* Written in 1994 by Aubrey Jaffer.
  48  * Thanks to Hallvard.Tretteberg@si.sintef.no for inspiration and discussion.
  49  * Rewritten by Gary Houston to be a closer interface to the C socket library.
  50  * Split into net_db.c and socket.c.
  51  */
  52 \f
  53
  54 #include <stdio.h>
  55 #include "_scm.h"
  56 #include "feature.h"
  57
  58 #include "scm_validate.h"
  59 #include "net_db.h"
  60
  61 #ifdef HAVE_STRING_H
  62 #include <string.h>
  63 #endif
  64
  65 #include <sys/types.h>
  66 #include <sys/socket.h>
  67 #include <netdb.h>
  68 #include <netinet/in.h>
  69 #include <arpa/inet.h>
  70
  71 /* Some systems do not declare this.  Some systems do declare it, as a
  72    macro.  */
  73 #ifndef h_errno
  74 extern int h_errno;
  75 #endif
  76
  77 \f
  78
  79 #ifndef STDC_HEADERS
  80 int close ();
  81 #endif /* STDC_HEADERS */
  82
  83 extern int inet_aton ();
  84
  85 SCM_DEFINE (scm_inet_aton, "inet-aton", 1, 0, 0,
  86             (SCM address),
  87             "Converts a string containing an Internet host address in the traditional\n"
  88             "dotted decimal notation into an integer.\n\n"
  89             "@smalllisp\n"
  90             "(inet-aton \"127.0.0.1\") @result{} 2130706433\n\n"
  91             "@end smalllisp")
  92 #define FUNC_NAME s_scm_inet_aton
  93 {
  94   struct in_addr soka;
  95
  96   SCM_VALIDATE_ROSTRING (1,address);
  97   if (SCM_SUBSTRP (address))
  98     address = scm_makfromstr (SCM_ROCHARS (address), SCM_ROLENGTH (address), 0);
  99   if (inet_aton (SCM_ROCHARS (address), &soka) == 0)
 100     SCM_MISC_ERROR ("bad address", SCM_EOL);
 101   return scm_ulong2num (ntohl (soka.s_addr));
 102 }
 103 #undef FUNC_NAME
 104
 105
 106 SCM_DEFINE (scm_inet_ntoa, "inet-ntoa", 1, 0, 0,
 107             (SCM inetid),
 108             "Converts an integer Internet host address into a string with the\n"
 109             "traditional dotted decimal representation.\n\n"
 110             "@smalllisp\n"
 111             "(inet-ntoa 2130706433) @result{} \"127.0.0.1\""
 112             "@end smalllisp")
 113 #define FUNC_NAME s_scm_inet_ntoa
 114 {
 115   struct in_addr addr;
 116   char *s;
 117   SCM answer;
 118   addr.s_addr = htonl (SCM_NUM2ULONG (1,inetid));
 119   s = inet_ntoa (addr);
 120   answer = scm_makfromstr (s, strlen (s), 0);
 121   return answer;
 122 }
 123 #undef FUNC_NAME
 124
 125 #ifdef HAVE_INET_NETOF
 126 SCM_DEFINE (scm_inet_netof, "inet-netof", 1, 0, 0,
 127             (SCM address),
 128             "Returns the network number part of the given integer Internet address.\n\n"
 129             "@smalllisp\n"
 130             "(inet-netof 2130706433) @result{} 127\n"
 131             "@end smalllisp")
 132 #define FUNC_NAME s_scm_inet_netof
 133 {
 134   struct in_addr addr;
 135   addr.s_addr = htonl (SCM_NUM2ULONG (1,address));
 136   return scm_ulong2num ((unsigned long) inet_netof (addr));
 137 }
 138 #undef FUNC_NAME
 139 #endif
 140
 141 #ifdef HAVE_INET_LNAOF
 142 SCM_DEFINE (scm_lnaof, "inet-lnaof", 1, 0, 0,
 143             (SCM address),
 144             "Returns the local-address-with-network part of the given Internet\n"
 145             "address.\n\n"
 146             "@smalllisp\n"
 147             "(inet-lnaof 2130706433) @result{} 1\n"
 148             "@end smalllisp")
 149 #define FUNC_NAME s_scm_lnaof
 150 {
 151   struct in_addr addr;
 152   addr.s_addr = htonl (SCM_NUM2ULONG (1,address));
 153   return scm_ulong2num ((unsigned long) inet_lnaof (addr));
 154 }
 155 #undef FUNC_NAME
 156 #endif
 157
 158 #ifdef HAVE_INET_MAKEADDR
 159 SCM_DEFINE (scm_inet_makeaddr, "inet-makeaddr", 2, 0, 0,
 160             (SCM net, SCM lna),
 161             "Makes an Internet host address by combining the network number @var{net}\n"
 162             "with the local-address-within-network number @var{lna}.\n\n"
 163             "@smalllisp\n"
 164             "(inet-makeaddr 127 1) @result{} 2130706433\n"
 165             "@end smalllisp")
 166 #define FUNC_NAME s_scm_inet_makeaddr
 167 {
 168   struct in_addr addr;
 169   unsigned long netnum;
 170   unsigned long lnanum;
 171
 172 #if 0 /* GJB:FIXME:: */
 173   SCM_VALIDATE_INUM_COPY (1,net,netnum);
 174   SCM_VALIDATE_INUM_COPY (2,lna,lnanum);
 175 #else
 176   netnum = SCM_NUM2ULONG (1, net);
 177   lnanum = SCM_NUM2ULONG (2, lna);
 178 #endif
 179   addr = inet_makeaddr (netnum, lnanum);
 180   return scm_ulong2num (ntohl (addr.s_addr));
 181 }
 182 #undef FUNC_NAME
 183 #endif
 184
 185 SCM_SYMBOL (scm_host_not_found_key, "host-not-found");
 186 SCM_SYMBOL (scm_try_again_key, "try-again");
 187 SCM_SYMBOL (scm_no_recovery_key, "no-recovery");
 188 SCM_SYMBOL (scm_no_data_key, "no-data");
 189
 190 static void scm_resolv_error (const char *subr, SCM bad_value)
 191 {
 192   if (h_errno == NETDB_INTERNAL)
 193     {
 194       /* errno supposedly contains a useful value.  */
 195       scm_syserror (subr);
 196     }
 197   else
 198     {
 199       SCM key;
 200       const char *errmsg;
 201
 202       switch (h_errno)
 203         {
 204         case HOST_NOT_FOUND:
 205           key = scm_host_not_found_key;
 206           errmsg = "Unknown host";
 207           break;
 208         case TRY_AGAIN:
 209           key = scm_try_again_key;
 210           errmsg = "Host name lookup failure";
 211           break;
 212         case NO_RECOVERY:
 213           key = scm_no_recovery_key;
 214           errmsg = "Unknown server error";
 215           break;
 216         case NO_DATA:
 217           key = scm_no_data_key;
 218           errmsg = "No address associated with name";
 219           break;
 220         default:
 221           scm_misc_error (subr, "Unknown resolver error", SCM_EOL);
 222           errmsg = NULL;
 223         }
 224
 225 #ifdef HAVE_HSTRERROR
 226       errmsg = (const char *) hstrerror (h_errno);
 227 #endif
 228       scm_error (key, subr, errmsg, scm_cons (bad_value, SCM_EOL), SCM_EOL);
 229     }
 230 }
 231
 232 /* Should take an extra arg for address format (will be needed for IPv6).
 233    Should use reentrant facilities if available.
 234  */
 235
 236 SCM_DEFINE (scm_gethost, "gethost", 0, 1, 0,
 237             (SCM name),
 238             "@deffnx procedure gethostbyname hostname\n"
 239             "@deffnx procedure gethostbyaddr address\n"
 240             "Look up a host by name or address, returning a host object.  The\n"
 241             "@code{gethost} procedure will accept either a string name or an integer\n"
 242             "address; if given no arguments, it behaves like @code{gethostent} (see\n"
 243             "below).  If a name or address is supplied but the address can not be\n"
 244             "found, an error will be thrown to one of the keys:\n"
 245             "@code{host-not-found}, @code{try-again}, @code{no-recovery} or\n"
 246             "@code{no-data}, corresponding to the equivalent @code{h_error} values.\n"
 247             "Unusual conditions may result in errors thrown to the\n"
 248             "@code{system-error} or @code{misc_error} keys.")
 249 #define FUNC_NAME s_scm_gethost
 250 {
 251   SCM ans = scm_make_vector (SCM_MAKINUM (5), SCM_UNSPECIFIED);
 252   SCM *ve = SCM_VELTS (ans);
 253   SCM lst = SCM_EOL;
 254   struct hostent *entry;
 255   struct in_addr inad;
 256   char **argv;
 257   int i = 0;
 258   if (SCM_UNBNDP (name))
 259     {
 260 #ifdef HAVE_GETHOSTENT
 261       entry = gethostent ();
 262 #else
 263       entry = NULL;
 264 #endif
 265       if (! entry)
 266         {
 267           /* As far as I can tell, there's no good way to tell whether
 268              zero means an error or end-of-file.  The trick of
 269              clearing errno before calling gethostent and checking it
 270              afterwards doesn't cut it, because, on Linux, it seems to
 271              try to contact some other server (YP?) and fails, which
 272              is a benign failure.  */
 273           return SCM_BOOL_F;
 274         }
 275     }
 276   else if (SCM_ROSTRINGP (name))
 277     {
 278       SCM_COERCE_SUBSTR (name);
 279       entry = gethostbyname (SCM_ROCHARS (name));
 280     }
 281   else
 282     {
 283       inad.s_addr = htonl (SCM_NUM2ULONG (1,name));
 284       entry = gethostbyaddr ((char *) &inad, sizeof (inad), AF_INET);
 285     }
 286   if (!entry)
 287     scm_resolv_error (FUNC_NAME, name);
 288
 289   ve[0] = scm_makfromstr (entry->h_name,
 290                           (scm_sizet) strlen (entry->h_name), 0);
 291   ve[1] = scm_makfromstrs (-1, entry->h_aliases);
 292   ve[2] = SCM_MAKINUM (entry->h_addrtype + 0L);
 293   ve[3] = SCM_MAKINUM (entry->h_length + 0L);
 294   if (sizeof (struct in_addr) != entry->h_length)
 295     {
 296       ve[4] = SCM_BOOL_F;
 297       return ans;
 298     }
 299   for (argv = entry->h_addr_list; argv[i]; i++);
 300   while (i--)
 301     {
 302       inad = *(struct in_addr *) argv[i];
 303       lst = scm_cons (scm_ulong2num (ntohl (inad.s_addr)), lst);
 304     }
 305   ve[4] = lst;
 306   return ans;
 307 }
 308 #undef FUNC_NAME
 309
 310
 311 /* In all subsequent getMUMBLE functions, when we're called with no
 312    arguments, we're supposed to traverse the tables entry by entry.
 313    However, there doesn't seem to be any documented way to distinguish
 314    between end-of-table and an error; in both cases the functions
 315    return zero.  Gotta love Unix.  For the time being, we clear errno,
 316    and if we get a zero and errno is set, we signal an error.  This
 317    doesn't seem quite right (what if errno gets set as part of healthy
 318    operation?), but it seems to work okay.  We'll see.  */
 319
 320 #if defined(HAVE_GETNETENT) && defined(HAVE_GETNETBYNAME) && defined(HAVE_GETNETBYADDR)
 321 SCM_DEFINE (scm_getnet, "getnet", 0, 1, 0,
 322             (SCM name),
 323             "@deffnx procedure getnetbyname net-name\n"
 324             "@deffnx procedure getnetbyaddr net-number\n"
 325             "Look up a network by name or net number in the network database.  The\n"
 326             "@var{net-name} argument must be a string, and the @var{net-number}\n"
 327             "argument must be an integer.  @code{getnet} will accept either type of\n"
 328             "argument, behaving like @code{getnetent} (see below) if no arguments are\n"
 329             "given.")
 330 #define FUNC_NAME s_scm_getnet
 331 {
 332   SCM ans;
 333   SCM *ve;
 334   struct netent *entry;
 335
 336   ans = scm_make_vector (SCM_MAKINUM (4), SCM_UNSPECIFIED);
 337   ve = SCM_VELTS (ans);
 338   if (SCM_UNBNDP (name))
 339     {
 340       errno = 0;
 341       entry = getnetent ();
 342       if (! entry)
 343         {
 344           if (errno)
 345             SCM_SYSERROR;
 346           else
 347             return SCM_BOOL_F;
 348         }
 349     }
 350   else if (SCM_ROSTRINGP (name))
 351     {
 352       SCM_COERCE_SUBSTR (name);
 353       entry = getnetbyname (SCM_ROCHARS (name));
 354     }
 355   else
 356     {
 357       unsigned long netnum;
 358       netnum = SCM_NUM2ULONG (1, name);
 359       entry = getnetbyaddr (netnum, AF_INET);
 360     }
 361   if (!entry)
 362     SCM_SYSERROR_MSG ("no such network ~A",
 363                       scm_listify (name, SCM_UNDEFINED), errno);
 364   ve[0] = scm_makfromstr (entry->n_name, (scm_sizet) strlen (entry->n_name), 0);
 365   ve[1] = scm_makfromstrs (-1, entry->n_aliases);
 366   ve[2] = SCM_MAKINUM (entry->n_addrtype + 0L);
 367   ve[3] = scm_ulong2num (entry->n_net + 0L);
 368   return ans;
 369 }
 370 #undef FUNC_NAME
 371 #endif
 372
 373 #ifdef HAVE_GETPROTOENT
 374 SCM_DEFINE (scm_getproto, "getproto", 0, 1, 0,
 375             (SCM name),
 376             "@deffnx procedure getprotobyname name\n"
 377             "@deffnx procedure getprotobynumber number\n"
 378             "Look up a network protocol by name or by number.  @code{getprotobyname}\n"
 379             "takes a string argument, and @code{getprotobynumber} takes an integer\n"
 380             "argument.  @code{getproto} will accept either type, behaving like\n"
 381             "@code{getprotoent} (see below) if no arguments are supplied.")
 382 #define FUNC_NAME s_scm_getproto
 383 {
 384   SCM ans;
 385   SCM *ve;
 386   struct protoent *entry;
 387
 388   ans = scm_make_vector (SCM_MAKINUM (3), SCM_UNSPECIFIED);
 389   ve = SCM_VELTS (ans);
 390   if (SCM_UNBNDP (name))
 391     {
 392       errno = 0;
 393       entry = getprotoent ();
 394       if (! entry)
 395         {
 396           if (errno)
 397             SCM_SYSERROR;
 398           else
 399             return SCM_BOOL_F;
 400         }
 401     }
 402   else if (SCM_ROSTRINGP (name))
 403     {
 404       SCM_COERCE_SUBSTR (name);
 405       entry = getprotobyname (SCM_ROCHARS (name));
 406     }
 407   else
 408     {
 409       unsigned long protonum;
 410       protonum = SCM_NUM2ULONG (1,name);
 411       entry = getprotobynumber (protonum);
 412     }
 413   if (!entry)
 414     SCM_SYSERROR_MSG ("no such protocol ~A",
 415                       scm_listify (name, SCM_UNDEFINED), errno);
 416   ve[0] = scm_makfromstr (entry->p_name, (scm_sizet) strlen (entry->p_name), 0);
 417   ve[1] = scm_makfromstrs (-1, entry->p_aliases);
 418   ve[2] = SCM_MAKINUM (entry->p_proto + 0L);
 419   return ans;
 420 }
 421 #undef FUNC_NAME
 422 #endif
 423
 424 static SCM
 425 scm_return_entry (struct servent *entry)
 426 {
 427   SCM ans;
 428   SCM *ve;
 429
 430   ans = scm_make_vector (SCM_MAKINUM (4), SCM_UNSPECIFIED);
 431   ve = SCM_VELTS (ans);
 432   ve[0] = scm_makfromstr (entry->s_name, (scm_sizet) strlen (entry->s_name), 0);
 433   ve[1] = scm_makfromstrs (-1, entry->s_aliases);
 434   ve[2] = SCM_MAKINUM (ntohs (entry->s_port) + 0L);
 435   ve[3] = scm_makfromstr (entry->s_proto, (scm_sizet) strlen (entry->s_proto), 0);
 436   return ans;
 437 }
 438
 439 #ifdef HAVE_GETSERVENT
 440 SCM_DEFINE (scm_getserv, "getserv", 0, 2, 0,
 441             (SCM name, SCM proto),
 442             "@deffnx procedure getservbyname name protocol\n"
 443             "@deffnx procedure getservbyport port protocol\n"
 444             "Look up a network service by name or by service number, and return a\n"
 445             "network service object.  The @var{protocol} argument specifies the name\n"
 446             "of the desired protocol; if the protocol found in the network service\n"
 447             "database does not match this name, a system error is signalled.\n\n"
 448             "The @code{getserv} procedure will take either a service name or number\n"
 449             "as its first argument; if given no arguments, it behaves like\n"
 450             "@code{getservent} (see below).")
 451 #define FUNC_NAME s_scm_getserv
 452 {
 453   struct servent *entry;
 454   if (SCM_UNBNDP (name))
 455     {
 456       errno = 0;
 457       entry = getservent ();
 458       if (!entry)
 459         {
 460           if (errno)
 461             SCM_SYSERROR;
 462           else
 463             return SCM_BOOL_F;
 464         }
 465       return scm_return_entry (entry);
 466     }
 467   SCM_VALIDATE_ROSTRING (2,proto);
 468   SCM_COERCE_SUBSTR (proto);
 469   if (SCM_ROSTRINGP (name))
 470     {
 471       SCM_COERCE_SUBSTR (name);
 472       entry = getservbyname (SCM_ROCHARS (name), SCM_ROCHARS (proto));
 473     }
 474   else
 475     {
 476       SCM_VALIDATE_INUM (1,name);
 477       entry = getservbyport (htons (SCM_INUM (name)), SCM_ROCHARS (proto));
 478     }
 479   if (!entry)
 480     SCM_SYSERROR_MSG("no such service ~A",
 481                      scm_listify (name, SCM_UNDEFINED), errno);
 482   return scm_return_entry (entry);
 483 }
 484 #undef FUNC_NAME
 485 #endif
 486
 487 #if defined(HAVE_SETHOSTENT) && defined(HAVE_ENDHOSTENT)
 488 SCM_DEFINE (scm_sethost, "sethost", 0, 1, 0,
 489             (SCM arg),
 490             "If @var{stayopen} is omitted, this is equivalent to @code{endhostent}.\n"
 491             "Otherwise it is equivalent to @code{sethostent stayopen}.")
 492 #define FUNC_NAME s_scm_sethost
 493 {
 494   if (SCM_UNBNDP (arg))
 495     endhostent ();
 496   else
 497     sethostent (SCM_NFALSEP (arg));
 498   return SCM_UNSPECIFIED;
 499 }
 500 #undef FUNC_NAME
 501 #endif
 502
 503 #if defined(HAVE_SETNETENT) && defined(HAVE_ENDNETENT)
 504 SCM_DEFINE (scm_setnet, "setnet", 0, 1, 0,
 505             (SCM arg),
 506             "If @var{stayopen} is omitted, this is equivalent to @code{endnetent}.\n"
 507             "Otherwise it is equivalent to @code{setnetent stayopen}.")
 508 #define FUNC_NAME s_scm_setnet
 509 {
 510   if (SCM_UNBNDP (arg))
 511     endnetent ();
 512   else
 513     setnetent (SCM_NFALSEP (arg));
 514   return SCM_UNSPECIFIED;
 515 }
 516 #undef FUNC_NAME
 517 #endif
 518
 519 #if defined(HAVE_SETPROTOENT) && defined(HAVE_ENDPROTOENT)
 520 SCM_DEFINE (scm_setproto, "setproto", 0, 1, 0,
 521             (SCM arg),
 522             "If @var{stayopen} is omitted, this is equivalent to @code{endprotoent}.\n"
 523             "Otherwise it is equivalent to @code{setprotoent stayopen}.")
 524 #define FUNC_NAME s_scm_setproto
 525 {
 526   if (SCM_UNBNDP (arg))
 527     endprotoent ();
 528   else
 529     setprotoent (SCM_NFALSEP (arg));
 530   return SCM_UNSPECIFIED;
 531 }
 532 #undef FUNC_NAME
 533 #endif
 534
 535 #if defined(HAVE_SETSERVENT) && defined(HAVE_ENDSERVENT)
 536 SCM_DEFINE (scm_setserv, "setserv", 0, 1, 0,
 537             (SCM arg),
 538             "If @var{stayopen} is omitted, this is equivalent to @code{endservent}.\n"
 539             "Otherwise it is equivalent to @code{setservent stayopen}.")
 540 #define FUNC_NAME s_scm_setserv
 541 {
 542   if (SCM_UNBNDP (arg))
 543     endservent ();
 544   else
 545     setservent (SCM_NFALSEP (arg));
 546   return SCM_UNSPECIFIED;
 547 }
 548 #undef FUNC_NAME
 549 #endif
 550
 551
 552 void
 553 scm_init_net_db ()
 554 {
 555 #ifdef INADDR_ANY
 556   scm_sysintern ("INADDR_ANY", scm_ulong2num (INADDR_ANY));
 557 #endif
 558 #ifdef INADDR_BROADCAST
 559   scm_sysintern ("INADDR_BROADCAST", scm_ulong2num (INADDR_BROADCAST));
 560 #endif
 561 #ifdef INADDR_NONE
 562   scm_sysintern ("INADDR_NONE", scm_ulong2num (INADDR_NONE));
 563 #endif
 564 #ifdef INADDR_LOOPBACK
 565   scm_sysintern ("INADDR_LOOPBACK", scm_ulong2num (INADDR_LOOPBACK));
 566 #endif
 567
 568   scm_add_feature ("net-db");
 569 #include "net_db.x"
 570 }