libguile/net_db.c

   1 /* "net_db.c" network database support
   2  * Copyright (C) 1995, 1996, 1997, 1998, 1999 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 GUILE_PROC (scm_inet_aton, "inet-aton", 1, 0, 0,
  86             (SCM address),
  87 "Converts a string containing an Internet host address in the traditional
  88 dotted decimal notation into an integer.
  89
  90 @smalllisp
  91 (inet-aton "127.0.0.1") @result{} 2130706433
  92
  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 GUILE_PROC (scm_inet_ntoa, "inet-ntoa", 1, 0, 0,
 109             (SCM inetid),
 110 "Converts an integer Internet host address into a string with the
 111 traditional dotted decimal representation.
 112
 113 @smalllisp
 114 (inet-ntoa 2130706433) @result{} "127.0.0.1"
 115 @end smalllisp")
 116 #define FUNC_NAME s_scm_inet_ntoa
 117 {
 118   struct in_addr addr;
 119   char *s;
 120   SCM answer;
 121   addr.s_addr = htonl (SCM_NUM2ULONG (1,inetid));
 122   s = inet_ntoa (addr);
 123   answer = scm_makfromstr (s, strlen (s), 0);
 124   return answer;
 125 }
 126 #undef FUNC_NAME
 127
 128 #ifdef HAVE_INET_NETOF
 129 GUILE_PROC (scm_inet_netof, "inet-netof", 1, 0, 0,
 130             (SCM address),
 131 "Returns the network number part of the given integer Internet address.
 132
 133 @smalllisp
 134 (inet-netof 2130706433) @result{} 127
 135 @end smalllisp")
 136 #define FUNC_NAME s_scm_inet_netof
 137 {
 138   struct in_addr addr;
 139   addr.s_addr = htonl (SCM_NUM2ULONG (1,address));
 140   return scm_ulong2num ((unsigned long) inet_netof (addr));
 141 }
 142 #undef FUNC_NAME
 143 #endif
 144
 145 #ifdef HAVE_INET_LNAOF
 146 GUILE_PROC (scm_lnaof, "inet-lnaof", 1, 0, 0,
 147             (SCM address),
 148 "Returns the local-address-with-network part of the given Internet
 149 address.
 150
 151 @smalllisp
 152 (inet-lnaof 2130706433) @result{} 1
 153 @end smalllisp")
 154 #define FUNC_NAME s_scm_lnaof
 155 {
 156   struct in_addr addr;
 157   addr.s_addr = htonl (SCM_NUM2ULONG (1,address));
 158   return scm_ulong2num ((unsigned long) inet_lnaof (addr));
 159 }
 160 #undef FUNC_NAME
 161 #endif
 162
 163 #ifdef HAVE_INET_MAKEADDR
 164 GUILE_PROC (scm_inet_makeaddr, "inet-makeaddr", 2, 0, 0,
 165             (SCM net, SCM lna),
 166 "Makes an Internet host address by combining the network number @var{net}
 167 with the local-address-within-network number @var{lna}.
 168
 169 @smalllisp
 170 (inet-makeaddr 127 1) @result{} 2130706433
 171 @end smalllisp")
 172 #define FUNC_NAME s_scm_inet_makeaddr
 173 {
 174   struct in_addr addr;
 175   unsigned long netnum;
 176   unsigned long lnanum;
 177
 178   SCM_VALIDATE_INT_COPY(1,net,netnum);
 179   SCM_VALIDATE_INT_COPY(2,lna,lnanum);
 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 = 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 GUILE_PROC (scm_gethost, "gethost", 0, 1, 0,
 238             (SCM name),
 239 "@deffnx procedure gethostbyname hostname
 240 @deffnx procedure gethostbyaddr address
 241 Look up a host by name or address, returning a host object.  The
 242 @code{gethost} procedure will accept either a string name or an integer
 243 address; if given no arguments, it behaves like @code{gethostent} (see
 244 below).  If a name or address is supplied but the address can not be
 245 found, an error will be thrown to one of the keys:
 246 @code{host-not-found}, @code{try-again}, @code{no-recovery} or
 247 @code{no-data}, corresponding to the equivalent @code{h_error} values.
 248 Unusual conditions may result in errors thrown to the
 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 (name, (char *) SCM_ARG1, FUNC_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 GUILE_PROC (scm_getnet, "getnet", 0, 1, 0,
 323             (SCM name),
 324 "@deffnx procedure getnetbyname net-name
 325 @deffnx procedure getnetbyaddr net-number
 326 Look up a network by name or net number in the network database.  The
 327 @var{net-name} argument must be a string, and the @var{net-number}
 328 argument must be an integer.  @code{getnet} will accept either type of
 329 argument, behaving like @code{getnetent} (see below) if no arguments are
 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 (name, (char *) SCM_ARG1, FUNC_NAME);
 360       entry = getnetbyaddr (netnum, AF_INET);
 361     }
 362   if (!entry)
 363     scm_syserror_msg (FUNC_NAME, "no such network %s",
 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 GUILE_PROC (scm_getproto, "getproto", 0, 1, 0,
 376             (SCM name),
 377 "@deffnx procedure getprotobyname name
 378 @deffnx procedure getprotobynumber number
 379 Look up a network protocol by name or by number.  @code{getprotobyname}
 380 takes a string argument, and @code{getprotobynumber} takes an integer
 381 argument.  @code{getproto} will accept either type, behaving like
 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 %s",
 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 GUILE_PROC (scm_getserv, "getserv", 0, 2, 0,
 442             (SCM name, SCM proto),
 443 "@deffnx procedure getservbyname name protocol
 444 @deffnx procedure getservbyport port protocol
 445 Look up a network service by name or by service number, and return a
 446 network service object.  The @var{protocol} argument specifies the name
 447 of the desired protocol; if the protocol found in the network service
 448 database does not match this name, a system error is signalled.
 449
 450 The @code{getserv} procedure will take either a service name or number
 451 as its first argument; if given no arguments, it behaves like
 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_INT(1,name);
 479       entry = getservbyport (htons (SCM_INUM (name)), SCM_ROCHARS (proto));
 480     }
 481   if (!entry)
 482     SCM_SYSERROR_MSG("no such service %s",
 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 GUILE_PROC (scm_sethost, "sethost", 0, 1, 0,
 491             (SCM arg),
 492 "If @var{stayopen} is omitted, this is equivalent to @code{endhostent}.
 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 GUILE_PROC (scm_setnet, "setnet", 0, 1, 0,
 507             (SCM arg),
 508 "If @var{stayopen} is omitted, this is equivalent to @code{endnetent}.
 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 GUILE_PROC (scm_setproto, "setproto", 0, 1, 0,
 523             (SCM arg),
 524 "If @var{stayopen} is omitted, this is equivalent to @code{endprotoent}.
 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 GUILE_PROC (scm_setserv, "setserv", 0, 1, 0,
 539             (SCM arg),
 540 "If @var{stayopen} is omitted, this is equivalent to @code{endservent}.
 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 "net_db.x"
 572 }