libguile/net_db.c

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