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