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