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 #if !defined (HAVE_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 #ifndef HAVE_INET_ATON
  84 extern int inet_aton ();
  85 #endif
  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_STRING (1, address);
  99   SCM_STRING_COERCE_0TERMINATION_X (address);
 100   if (inet_aton (SCM_STRING_CHARS (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\"\n"
 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 #ifdef NETDB_INTERNAL
 194   if (h_errno == NETDB_INTERNAL)
 195     {
 196       /* errno supposedly contains a useful value.  */
 197       scm_syserror (subr);
 198     }
 199   else
 200 #endif
 201     {
 202       SCM key;
 203       const char *errmsg;
 204
 205       switch (h_errno)
 206         {
 207         case HOST_NOT_FOUND:
 208           key = scm_host_not_found_key;
 209           errmsg = "Unknown host";
 210           break;
 211         case TRY_AGAIN:
 212           key = scm_try_again_key;
 213           errmsg = "Host name lookup failure";
 214           break;
 215         case NO_RECOVERY:
 216           key = scm_no_recovery_key;
 217           errmsg = "Unknown server error";
 218           break;
 219         case NO_DATA:
 220           key = scm_no_data_key;
 221           errmsg = "No address associated with name";
 222           break;
 223         default:
 224           scm_misc_error (subr, "Unknown resolver error", SCM_EOL);
 225           errmsg = NULL;
 226         }
 227
 228 #ifdef HAVE_HSTRERROR
 229       errmsg = (const char *) hstrerror (h_errno);
 230 #endif
 231       scm_error (key, subr, errmsg, scm_cons (bad_value, SCM_EOL), SCM_EOL);
 232     }
 233 }
 234
 235 /* Should take an extra arg for address format (will be needed for IPv6).
 236    Should use reentrant facilities if available.
 237  */
 238
 239 SCM_DEFINE (scm_gethost, "gethost", 0, 1, 0,
 240             (SCM host),
 241             "@deffnx procedure gethostbyname hostname\n"
 242             "@deffnx procedure gethostbyaddr address\n"
 243             "Look up a host by name or address, returning a host object.  The\n"
 244             "@code{gethost} procedure will accept either a string name or an integer\n"
 245             "address; if given no arguments, it behaves like @code{gethostent} (see\n"
 246             "below).  If a name or address is supplied but the address can not be\n"
 247             "found, an error will be thrown to one of the keys:\n"
 248             "@code{host-not-found}, @code{try-again}, @code{no-recovery} or\n"
 249             "@code{no-data}, corresponding to the equivalent @code{h_error} values.\n"
 250             "Unusual conditions may result in errors thrown to the\n"
 251             "@code{system-error} or @code{misc_error} keys.")
 252 #define FUNC_NAME s_scm_gethost
 253 {
 254   SCM ans = scm_make_vector (SCM_MAKINUM (5), SCM_UNSPECIFIED);
 255   SCM *ve = SCM_VELTS (ans);
 256   SCM lst = SCM_EOL;
 257   struct hostent *entry;
 258   struct in_addr inad;
 259   char **argv;
 260   int i = 0;
 261   if (SCM_UNBNDP (host))
 262     {
 263 #ifdef HAVE_GETHOSTENT
 264       entry = gethostent ();
 265 #else
 266       entry = NULL;
 267 #endif
 268       if (! entry)
 269         {
 270           /* As far as I can tell, there's no good way to tell whether
 271              zero means an error or end-of-file.  The trick of
 272              clearing errno before calling gethostent and checking it
 273              afterwards doesn't cut it, because, on Linux, it seems to
 274              try to contact some other server (YP?) and fails, which
 275              is a benign failure.  */
 276           return SCM_BOOL_F;
 277         }
 278     }
 279   else if (SCM_STRINGP (host))
 280     {
 281       SCM_STRING_COERCE_0TERMINATION_X (host);
 282       entry = gethostbyname (SCM_STRING_CHARS (host));
 283     }
 284   else
 285     {
 286       inad.s_addr = htonl (SCM_NUM2ULONG (1,host));
 287       entry = gethostbyaddr ((char *) &inad, sizeof (inad), AF_INET);
 288     }
 289   if (!entry)
 290     scm_resolv_error (FUNC_NAME, host);
 291
 292   ve[0] = scm_makfromstr (entry->h_name,
 293                           (scm_sizet) strlen (entry->h_name), 0);
 294   ve[1] = scm_makfromstrs (-1, entry->h_aliases);
 295   ve[2] = SCM_MAKINUM (entry->h_addrtype + 0L);
 296   ve[3] = SCM_MAKINUM (entry->h_length + 0L);
 297   if (sizeof (struct in_addr) != entry->h_length)
 298     {
 299       ve[4] = SCM_BOOL_F;
 300       return ans;
 301     }
 302   for (argv = entry->h_addr_list; argv[i]; i++);
 303   while (i--)
 304     {
 305       inad = *(struct in_addr *) argv[i];
 306       lst = scm_cons (scm_ulong2num (ntohl (inad.s_addr)), lst);
 307     }
 308   ve[4] = lst;
 309   return ans;
 310 }
 311 #undef FUNC_NAME
 312
 313
 314 /* In all subsequent getMUMBLE functions, when we're called with no
 315    arguments, we're supposed to traverse the tables entry by entry.
 316    However, there doesn't seem to be any documented way to distinguish
 317    between end-of-table and an error; in both cases the functions
 318    return zero.  Gotta love Unix.  For the time being, we clear errno,
 319    and if we get a zero and errno is set, we signal an error.  This
 320    doesn't seem quite right (what if errno gets set as part of healthy
 321    operation?), but it seems to work okay.  We'll see.  */
 322
 323 #if defined(HAVE_GETNETENT) && defined(HAVE_GETNETBYNAME) && defined(HAVE_GETNETBYADDR)
 324 SCM_DEFINE (scm_getnet, "getnet", 0, 1, 0,
 325             (SCM net),
 326             "@deffnx procedure getnetbyname net-name\n"
 327             "@deffnx procedure getnetbyaddr net-number\n"
 328             "Look up a network by name or net number in the network database.  The\n"
 329             "@var{net-name} argument must be a string, and the @var{net-number}\n"
 330             "argument must be an integer.  @code{getnet} will accept either type of\n"
 331             "argument, behaving like @code{getnetent} (see below) if no arguments are\n"
 332             "given.")
 333 #define FUNC_NAME s_scm_getnet
 334 {
 335   SCM ans;
 336   SCM *ve;
 337   struct netent *entry;
 338
 339   ans = scm_make_vector (SCM_MAKINUM (4), SCM_UNSPECIFIED);
 340   ve = SCM_VELTS (ans);
 341   if (SCM_UNBNDP (net))
 342     {
 343       errno = 0;
 344       entry = getnetent ();
 345       if (! entry)
 346         {
 347           if (errno)
 348             SCM_SYSERROR;
 349           else
 350             return SCM_BOOL_F;
 351         }
 352     }
 353   else if (SCM_STRINGP (net))
 354     {
 355       SCM_STRING_COERCE_0TERMINATION_X (net);
 356       entry = getnetbyname (SCM_STRING_CHARS (net));
 357     }
 358   else
 359     {
 360       unsigned long netnum;
 361       netnum = SCM_NUM2ULONG (1, net);
 362       entry = getnetbyaddr (netnum, AF_INET);
 363     }
 364   if (!entry)
 365     SCM_SYSERROR_MSG ("no such network ~A",
 366                       scm_listify (net, SCM_UNDEFINED), errno);
 367   ve[0] = scm_makfromstr (entry->n_name, (scm_sizet) strlen (entry->n_name), 0);
 368   ve[1] = scm_makfromstrs (-1, entry->n_aliases);
 369   ve[2] = SCM_MAKINUM (entry->n_addrtype + 0L);
 370   ve[3] = scm_ulong2num (entry->n_net + 0L);
 371   return ans;
 372 }
 373 #undef FUNC_NAME
 374 #endif
 375
 376 #ifdef HAVE_GETPROTOENT
 377 SCM_DEFINE (scm_getproto, "getproto", 0, 1, 0,
 378             (SCM protocol),
 379             "@deffnx procedure getprotobyname name\n"
 380             "@deffnx procedure getprotobynumber number\n"
 381             "Look up a network protocol by name or by number.  @code{getprotobyname}\n"
 382             "takes a string argument, and @code{getprotobynumber} takes an integer\n"
 383             "argument.  @code{getproto} will accept either type, behaving like\n"
 384             "@code{getprotoent} (see below) if no arguments are supplied.")
 385 #define FUNC_NAME s_scm_getproto
 386 {
 387   SCM ans;
 388   SCM *ve;
 389   struct protoent *entry;
 390
 391   ans = scm_make_vector (SCM_MAKINUM (3), SCM_UNSPECIFIED);
 392   ve = SCM_VELTS (ans);
 393   if (SCM_UNBNDP (protocol))
 394     {
 395       errno = 0;
 396       entry = getprotoent ();
 397       if (! entry)
 398         {
 399           if (errno)
 400             SCM_SYSERROR;
 401           else
 402             return SCM_BOOL_F;
 403         }
 404     }
 405   else if (SCM_STRINGP (protocol))
 406     {
 407       SCM_STRING_COERCE_0TERMINATION_X (protocol);
 408       entry = getprotobyname (SCM_STRING_CHARS (protocol));
 409     }
 410   else
 411     {
 412       unsigned long protonum;
 413       protonum = SCM_NUM2ULONG (1,protocol);
 414       entry = getprotobynumber (protonum);
 415     }
 416   if (!entry)
 417     SCM_SYSERROR_MSG ("no such protocol ~A",
 418                       scm_listify (protocol, SCM_UNDEFINED), errno);
 419   ve[0] = scm_makfromstr (entry->p_name, (scm_sizet) strlen (entry->p_name), 0);
 420   ve[1] = scm_makfromstrs (-1, entry->p_aliases);
 421   ve[2] = SCM_MAKINUM (entry->p_proto + 0L);
 422   return ans;
 423 }
 424 #undef FUNC_NAME
 425 #endif
 426
 427 static SCM
 428 scm_return_entry (struct servent *entry)
 429 {
 430   SCM ans;
 431   SCM *ve;
 432
 433   ans = scm_make_vector (SCM_MAKINUM (4), SCM_UNSPECIFIED);
 434   ve = SCM_VELTS (ans);
 435   ve[0] = scm_makfromstr (entry->s_name, (scm_sizet) strlen (entry->s_name), 0);
 436   ve[1] = scm_makfromstrs (-1, entry->s_aliases);
 437   ve[2] = SCM_MAKINUM (ntohs (entry->s_port) + 0L);
 438   ve[3] = scm_makfromstr (entry->s_proto, (scm_sizet) strlen (entry->s_proto), 0);
 439   return ans;
 440 }
 441
 442 #ifdef HAVE_GETSERVENT
 443 SCM_DEFINE (scm_getserv, "getserv", 0, 2, 0,
 444             (SCM name, SCM protocol),
 445             "@deffnx procedure getservbyname name protocol\n"
 446             "@deffnx procedure getservbyport port protocol\n"
 447             "Look up a network service by name or by service number, and return a\n"
 448             "network service object.  The @var{protocol} argument specifies the name\n"
 449             "of the desired protocol; if the protocol found in the network service\n"
 450             "database does not match this name, a system error is signalled.\n\n"
 451             "The @code{getserv} procedure will take either a service name or number\n"
 452             "as its first argument; if given no arguments, it behaves like\n"
 453             "@code{getservent} (see below).")
 454 #define FUNC_NAME s_scm_getserv
 455 {
 456   struct servent *entry;
 457   if (SCM_UNBNDP (name))
 458     {
 459       errno = 0;
 460       entry = getservent ();
 461       if (!entry)
 462         {
 463           if (errno)
 464             SCM_SYSERROR;
 465           else
 466             return SCM_BOOL_F;
 467         }
 468       return scm_return_entry (entry);
 469     }
 470   SCM_VALIDATE_STRING (2, protocol);
 471   SCM_STRING_COERCE_0TERMINATION_X (protocol);
 472   if (SCM_STRINGP (name))
 473     {
 474       SCM_STRING_COERCE_0TERMINATION_X (name);
 475       entry = getservbyname (SCM_STRING_CHARS (name), SCM_STRING_CHARS (protocol));
 476     }
 477   else
 478     {
 479       SCM_VALIDATE_INUM (1,name);
 480       entry = getservbyport (htons (SCM_INUM (name)), SCM_STRING_CHARS (protocol));
 481     }
 482   if (!entry)
 483     SCM_SYSERROR_MSG("no such service ~A",
 484                      scm_listify (name, SCM_UNDEFINED), errno);
 485   return scm_return_entry (entry);
 486 }
 487 #undef FUNC_NAME
 488 #endif
 489
 490 #if defined(HAVE_SETHOSTENT) && defined(HAVE_ENDHOSTENT)
 491 SCM_DEFINE (scm_sethost, "sethost", 0, 1, 0,
 492             (SCM stayopen),
 493             "If @var{stayopen} is omitted, this is equivalent to @code{endhostent}.\n"
 494             "Otherwise it is equivalent to @code{sethostent stayopen}.")
 495 #define FUNC_NAME s_scm_sethost
 496 {
 497   if (SCM_UNBNDP (stayopen))
 498     endhostent ();
 499   else
 500     sethostent (SCM_NFALSEP (stayopen));
 501   return SCM_UNSPECIFIED;
 502 }
 503 #undef FUNC_NAME
 504 #endif
 505
 506 #if defined(HAVE_SETNETENT) && defined(HAVE_ENDNETENT)
 507 SCM_DEFINE (scm_setnet, "setnet", 0, 1, 0,
 508             (SCM stayopen),
 509             "If @var{stayopen} is omitted, this is equivalent to @code{endnetent}.\n"
 510             "Otherwise it is equivalent to @code{setnetent stayopen}.")
 511 #define FUNC_NAME s_scm_setnet
 512 {
 513   if (SCM_UNBNDP (stayopen))
 514     endnetent ();
 515   else
 516     setnetent (SCM_NFALSEP (stayopen));
 517   return SCM_UNSPECIFIED;
 518 }
 519 #undef FUNC_NAME
 520 #endif
 521
 522 #if defined(HAVE_SETPROTOENT) && defined(HAVE_ENDPROTOENT)
 523 SCM_DEFINE (scm_setproto, "setproto", 0, 1, 0,
 524             (SCM stayopen),
 525             "If @var{stayopen} is omitted, this is equivalent to @code{endprotoent}.\n"
 526             "Otherwise it is equivalent to @code{setprotoent stayopen}.")
 527 #define FUNC_NAME s_scm_setproto
 528 {
 529   if (SCM_UNBNDP (stayopen))
 530     endprotoent ();
 531   else
 532     setprotoent (SCM_NFALSEP (stayopen));
 533   return SCM_UNSPECIFIED;
 534 }
 535 #undef FUNC_NAME
 536 #endif
 537
 538 #if defined(HAVE_SETSERVENT) && defined(HAVE_ENDSERVENT)
 539 SCM_DEFINE (scm_setserv, "setserv", 0, 1, 0,
 540             (SCM stayopen),
 541             "If @var{stayopen} is omitted, this is equivalent to @code{endservent}.\n"
 542             "Otherwise it is equivalent to @code{setservent stayopen}.")
 543 #define FUNC_NAME s_scm_setserv
 544 {
 545   if (SCM_UNBNDP (stayopen))
 546     endservent ();
 547   else
 548     setservent (SCM_NFALSEP (stayopen));
 549   return SCM_UNSPECIFIED;
 550 }
 551 #undef FUNC_NAME
 552 #endif
 553
 554
 555 void
 556 scm_init_net_db ()
 557 {
 558 #ifdef INADDR_ANY
 559   scm_sysintern ("INADDR_ANY", scm_ulong2num (INADDR_ANY));
 560 #endif
 561 #ifdef INADDR_BROADCAST
 562   scm_sysintern ("INADDR_BROADCAST", scm_ulong2num (INADDR_BROADCAST));
 563 #endif
 564 #ifdef INADDR_NONE
 565   scm_sysintern ("INADDR_NONE", scm_ulong2num (INADDR_NONE));
 566 #endif
 567 #ifdef INADDR_LOOPBACK
 568   scm_sysintern ("INADDR_LOOPBACK", scm_ulong2num (INADDR_LOOPBACK));
 569 #endif
 570
 571   scm_add_feature ("net-db");
 572 #include "libguile/net_db.x"
 573 }
 574
 575 /*
 576   Local Variables:
 577   c-file-style: "gnu"
 578   End:
 579 */