libguile/net_db.c

   1 /* "net_db.c" network database support
   2  * Copyright (C) 1995,1996,1997,1998,1999,2000,2001 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
  44
  45 /* Written in 1994 by Aubrey Jaffer.
  46  * Thanks to Hallvard.Tretteberg@si.sintef.no for inspiration and discussion.
  47  * Rewritten by Gary Houston to be a closer interface to the C socket library.
  48  * Split into net_db.c and socket.c.
  49  */
  50 \f
  51
  52 #include <errno.h>
  53
  54 #include "libguile/_scm.h"
  55 #include "libguile/feature.h"
  56 #include "libguile/strings.h"
  57 #include "libguile/vectors.h"
  58
  59 #include "libguile/validate.h"
  60 #include "libguile/net_db.h"
  61
  62 #ifdef HAVE_STRING_H
  63 #include <string.h>
  64 #endif
  65
  66 #include <sys/types.h>
  67
  68 #ifdef HAVE_WINSOCK2_H
  69 #include <winsock2.h>
  70 #else
  71 #include <sys/socket.h>
  72 #include <netdb.h>
  73 #include <netinet/in.h>
  74 #include <arpa/inet.h>
  75 #endif
  76
  77 #ifdef __MINGW32__
  78 #include "win32-socket.h"
  79 #endif
  80
  81 #if !defined (HAVE_H_ERRNO) && !defined (__MINGW32__) && !defined (__CYGWIN__)
  82 /* h_errno not found in netdb.h, maybe this will help.  */
  83 extern int h_errno;
  84 #endif
  85
  86 \f
  87
  88 SCM_SYMBOL (scm_host_not_found_key, "host-not-found");
  89 SCM_SYMBOL (scm_try_again_key, "try-again");
  90 SCM_SYMBOL (scm_no_recovery_key, "no-recovery");
  91 SCM_SYMBOL (scm_no_data_key, "no-data");
  92
  93 static void scm_resolv_error (const char *subr, SCM bad_value)
  94 {
  95 #ifdef NETDB_INTERNAL
  96   if (h_errno == NETDB_INTERNAL)
  97     {
  98       /* errno supposedly contains a useful value.  */
  99       scm_syserror (subr);
 100     }
 101   else
 102 #endif
 103     {
 104       SCM key;
 105       const char *errmsg;
 106
 107       switch (h_errno)
 108         {
 109         case HOST_NOT_FOUND:
 110           key = scm_host_not_found_key;
 111           errmsg = "Unknown host";
 112           break;
 113         case TRY_AGAIN:
 114           key = scm_try_again_key;
 115           errmsg = "Host name lookup failure";
 116           break;
 117         case NO_RECOVERY:
 118           key = scm_no_recovery_key;
 119           errmsg = "Unknown server error";
 120           break;
 121         case NO_DATA:
 122           key = scm_no_data_key;
 123           errmsg = "No address associated with name";
 124           break;
 125         default:
 126           scm_misc_error (subr, "Unknown resolver error", SCM_EOL);
 127           errmsg = NULL;
 128         }
 129
 130 #ifdef HAVE_HSTRERROR
 131       errmsg = (const char *) hstrerror (h_errno);
 132 #endif
 133       scm_error (key, subr, errmsg, scm_cons (bad_value, SCM_EOL), SCM_EOL);
 134     }
 135 }
 136
 137 /* Should take an extra arg for address format (will be needed for IPv6).
 138    Should use reentrant facilities if available.
 139  */
 140
 141 SCM_DEFINE (scm_gethost, "gethost", 0, 1, 0,
 142             (SCM host),
 143             "@deffnx {Scheme Procedure} gethostbyname hostname\n"
 144             "@deffnx {Scheme Procedure} gethostbyaddr address\n"
 145             "Look up a host by name or address, returning a host object.  The\n"
 146             "@code{gethost} procedure will accept either a string name or an integer\n"
 147             "address; if given no arguments, it behaves like @code{gethostent} (see\n"
 148             "below).  If a name or address is supplied but the address can not be\n"
 149             "found, an error will be thrown to one of the keys:\n"
 150             "@code{host-not-found}, @code{try-again}, @code{no-recovery} or\n"
 151             "@code{no-data}, corresponding to the equivalent @code{h_error} values.\n"
 152             "Unusual conditions may result in errors thrown to the\n"
 153             "@code{system-error} or @code{misc_error} keys.")
 154 #define FUNC_NAME s_scm_gethost
 155 {
 156   SCM result = scm_c_make_vector (5, SCM_UNSPECIFIED);
 157   SCM lst = SCM_EOL;
 158   struct hostent *entry;
 159   struct in_addr inad;
 160   char **argv;
 161   int i = 0;
 162   if (SCM_UNBNDP (host))
 163     {
 164 #ifdef HAVE_GETHOSTENT
 165       entry = gethostent ();
 166 #else
 167       entry = NULL;
 168 #endif
 169       if (! entry)
 170         {
 171           /* As far as I can tell, there's no good way to tell whether
 172              zero means an error or end-of-file.  The trick of
 173              clearing errno before calling gethostent and checking it
 174              afterwards doesn't cut it, because, on Linux, it seems to
 175              try to contact some other server (YP?) and fails, which
 176              is a benign failure.  */
 177           return SCM_BOOL_F;
 178         }
 179     }
 180   else if (SCM_STRINGP (host))
 181     {
 182       entry = gethostbyname (SCM_STRING_CHARS (host));
 183     }
 184   else
 185     {
 186       inad.s_addr = htonl (SCM_NUM2ULONG (1, host));
 187       entry = gethostbyaddr ((char *) &inad, sizeof (inad), AF_INET);
 188     }
 189   if (!entry)
 190     scm_resolv_error (FUNC_NAME, host);
 191
 192   SCM_VECTOR_SET(result, 0, scm_mem2string (entry->h_name, strlen (entry->h_name)));
 193   SCM_VECTOR_SET(result, 1, scm_makfromstrs (-1, entry->h_aliases));
 194   SCM_VECTOR_SET(result, 2, SCM_MAKINUM (entry->h_addrtype + 0L));
 195   SCM_VECTOR_SET(result, 3, SCM_MAKINUM (entry->h_length + 0L));
 196   if (sizeof (struct in_addr) != entry->h_length)
 197     {
 198       SCM_VECTOR_SET(result, 4, SCM_BOOL_F);
 199       return result;
 200     }
 201   for (argv = entry->h_addr_list; argv[i]; i++);
 202   while (i--)
 203     {
 204       inad = *(struct in_addr *) argv[i];
 205       lst = scm_cons (scm_ulong2num (ntohl (inad.s_addr)), lst);
 206     }
 207   SCM_VECTOR_SET(result, 4, lst);
 208   return result;
 209 }
 210 #undef FUNC_NAME
 211
 212
 213 /* In all subsequent getMUMBLE functions, when we're called with no
 214    arguments, we're supposed to traverse the tables entry by entry.
 215    However, there doesn't seem to be any documented way to distinguish
 216    between end-of-table and an error; in both cases the functions
 217    return zero.  Gotta love Unix.  For the time being, we clear errno,
 218    and if we get a zero and errno is set, we signal an error.  This
 219    doesn't seem quite right (what if errno gets set as part of healthy
 220    operation?), but it seems to work okay.  We'll see.  */
 221
 222 #if defined(HAVE_GETNETENT) && defined(HAVE_GETNETBYNAME) && defined(HAVE_GETNETBYADDR)
 223 SCM_DEFINE (scm_getnet, "getnet", 0, 1, 0,
 224             (SCM net),
 225             "@deffnx {Scheme Procedure} getnetbyname net-name\n"
 226             "@deffnx {Scheme Procedure} getnetbyaddr net-number\n"
 227             "Look up a network by name or net number in the network database.  The\n"
 228             "@var{net-name} argument must be a string, and the @var{net-number}\n"
 229             "argument must be an integer.  @code{getnet} will accept either type of\n"
 230             "argument, behaving like @code{getnetent} (see below) if no arguments are\n"
 231             "given.")
 232 #define FUNC_NAME s_scm_getnet
 233 {
 234   SCM   result = scm_c_make_vector (4, SCM_UNSPECIFIED);
 235   struct netent *entry;
 236
 237   if (SCM_UNBNDP (net))
 238     {
 239       entry = getnetent ();
 240       if (! entry)
 241         {
 242           /* There's no good way to tell whether zero means an error
 243              or end-of-file, so we always return #f.  See `gethost'
 244              for details. */
 245           return SCM_BOOL_F;
 246         }
 247     }
 248   else if (SCM_STRINGP (net))
 249     {
 250       entry = getnetbyname (SCM_STRING_CHARS (net));
 251     }
 252   else
 253     {
 254       unsigned long netnum;
 255       netnum = SCM_NUM2ULONG (1, net);
 256       entry = getnetbyaddr (netnum, AF_INET);
 257     }
 258   if (!entry)
 259     SCM_SYSERROR_MSG ("no such network ~A", scm_list_1 (net), errno);
 260   SCM_VECTOR_SET(result, 0, scm_mem2string (entry->n_name, strlen (entry->n_name)));
 261   SCM_VECTOR_SET(result, 1, scm_makfromstrs (-1, entry->n_aliases));
 262   SCM_VECTOR_SET(result, 2, SCM_MAKINUM (entry->n_addrtype + 0L));
 263   SCM_VECTOR_SET(result, 3, scm_ulong2num (entry->n_net + 0L));
 264   return result;
 265 }
 266 #undef FUNC_NAME
 267 #endif
 268
 269 #if defined (HAVE_GETPROTOENT) || defined (__MINGW32__)
 270 SCM_DEFINE (scm_getproto, "getproto", 0, 1, 0,
 271             (SCM protocol),
 272             "@deffnx {Scheme Procedure} getprotobyname name\n"
 273             "@deffnx {Scheme Procedure} getprotobynumber number\n"
 274             "Look up a network protocol by name or by number.  @code{getprotobyname}\n"
 275             "takes a string argument, and @code{getprotobynumber} takes an integer\n"
 276             "argument.  @code{getproto} will accept either type, behaving like\n"
 277             "@code{getprotoent} (see below) if no arguments are supplied.")
 278 #define FUNC_NAME s_scm_getproto
 279 {
 280   SCM   result = scm_c_make_vector (3, SCM_UNSPECIFIED);
 281
 282   struct protoent *entry;
 283   if (SCM_UNBNDP (protocol))
 284     {
 285       entry = getprotoent ();
 286       if (! entry)
 287         {
 288           /* There's no good way to tell whether zero means an error
 289              or end-of-file, so we always return #f.  See `gethost'
 290              for details. */
 291           return SCM_BOOL_F;
 292         }
 293     }
 294   else if (SCM_STRINGP (protocol))
 295     {
 296       entry = getprotobyname (SCM_STRING_CHARS (protocol));
 297     }
 298   else
 299     {
 300       unsigned long protonum;
 301       protonum = SCM_NUM2ULONG (1, protocol);
 302       entry = getprotobynumber (protonum);
 303     }
 304   if (!entry)
 305     SCM_SYSERROR_MSG ("no such protocol ~A", scm_list_1 (protocol), errno);
 306   SCM_VECTOR_SET(result, 0, scm_mem2string (entry->p_name, strlen (entry->p_name)));
 307   SCM_VECTOR_SET(result, 1, scm_makfromstrs (-1, entry->p_aliases));
 308   SCM_VECTOR_SET(result, 2, SCM_MAKINUM (entry->p_proto + 0L));
 309   return result;
 310 }
 311 #undef FUNC_NAME
 312 #endif
 313
 314 #if defined (HAVE_GETSERVENT) || defined (__MINGW32__)
 315 static SCM
 316 scm_return_entry (struct servent *entry)
 317 {
 318   SCM result = scm_c_make_vector (4, SCM_UNSPECIFIED);
 319
 320   SCM_VECTOR_SET(result, 0, scm_mem2string (entry->s_name, strlen (entry->s_name)));
 321   SCM_VECTOR_SET(result, 1, scm_makfromstrs (-1, entry->s_aliases));
 322   SCM_VECTOR_SET(result, 2, SCM_MAKINUM (ntohs (entry->s_port) + 0L));
 323   SCM_VECTOR_SET(result, 3, scm_mem2string (entry->s_proto, strlen (entry->s_proto)));
 324   return result;
 325 }
 326
 327 SCM_DEFINE (scm_getserv, "getserv", 0, 2, 0,
 328             (SCM name, SCM protocol),
 329             "@deffnx {Scheme Procedure} getservbyname name protocol\n"
 330             "@deffnx {Scheme Procedure} getservbyport port protocol\n"
 331             "Look up a network service by name or by service number, and return a\n"
 332             "network service object.  The @var{protocol} argument specifies the name\n"
 333             "of the desired protocol; if the protocol found in the network service\n"
 334             "database does not match this name, a system error is signalled.\n\n"
 335             "The @code{getserv} procedure will take either a service name or number\n"
 336             "as its first argument; if given no arguments, it behaves like\n"
 337             "@code{getservent} (see below).")
 338 #define FUNC_NAME s_scm_getserv
 339 {
 340   struct servent *entry;
 341   if (SCM_UNBNDP (name))
 342     {
 343       entry = getservent ();
 344       if (!entry)
 345         {
 346           /* There's no good way to tell whether zero means an error
 347              or end-of-file, so we always return #f.  See `gethost'
 348              for details. */
 349           return SCM_BOOL_F;
 350         }
 351       return scm_return_entry (entry);
 352     }
 353   SCM_VALIDATE_STRING (2, protocol);
 354   if (SCM_STRINGP (name))
 355     {
 356       entry = getservbyname (SCM_STRING_CHARS (name), SCM_STRING_CHARS (protocol));
 357     }
 358   else
 359     {
 360       SCM_VALIDATE_INUM (1, name);
 361       entry = getservbyport (htons (SCM_INUM (name)), SCM_STRING_CHARS (protocol));
 362     }
 363   if (!entry)
 364     SCM_SYSERROR_MSG("no such service ~A", scm_list_1 (name), errno);
 365   return scm_return_entry (entry);
 366 }
 367 #undef FUNC_NAME
 368 #endif
 369
 370 #if defined(HAVE_SETHOSTENT) && defined(HAVE_ENDHOSTENT)
 371 SCM_DEFINE (scm_sethost, "sethost", 0, 1, 0,
 372             (SCM stayopen),
 373             "If @var{stayopen} is omitted, this is equivalent to @code{endhostent}.\n"
 374             "Otherwise it is equivalent to @code{sethostent stayopen}.")
 375 #define FUNC_NAME s_scm_sethost
 376 {
 377   if (SCM_UNBNDP (stayopen))
 378     endhostent ();
 379   else
 380     sethostent (!SCM_FALSEP (stayopen));
 381   return SCM_UNSPECIFIED;
 382 }
 383 #undef FUNC_NAME
 384 #endif
 385
 386 #if defined(HAVE_SETNETENT) && defined(HAVE_ENDNETENT)
 387 SCM_DEFINE (scm_setnet, "setnet", 0, 1, 0,
 388             (SCM stayopen),
 389             "If @var{stayopen} is omitted, this is equivalent to @code{endnetent}.\n"
 390             "Otherwise it is equivalent to @code{setnetent stayopen}.")
 391 #define FUNC_NAME s_scm_setnet
 392 {
 393   if (SCM_UNBNDP (stayopen))
 394     endnetent ();
 395   else
 396     setnetent (!SCM_FALSEP (stayopen));
 397   return SCM_UNSPECIFIED;
 398 }
 399 #undef FUNC_NAME
 400 #endif
 401
 402 #if defined (HAVE_SETPROTOENT) && defined (HAVE_ENDPROTOENT) || defined (__MINGW32__)
 403 SCM_DEFINE (scm_setproto, "setproto", 0, 1, 0,
 404             (SCM stayopen),
 405             "If @var{stayopen} is omitted, this is equivalent to @code{endprotoent}.\n"
 406             "Otherwise it is equivalent to @code{setprotoent stayopen}.")
 407 #define FUNC_NAME s_scm_setproto
 408 {
 409   if (SCM_UNBNDP (stayopen))
 410     endprotoent ();
 411   else
 412     setprotoent (!SCM_FALSEP (stayopen));
 413   return SCM_UNSPECIFIED;
 414 }
 415 #undef FUNC_NAME
 416 #endif
 417
 418 #if defined (HAVE_SETSERVENT) && defined (HAVE_ENDSERVENT) || defined (__MINGW32__)
 419 SCM_DEFINE (scm_setserv, "setserv", 0, 1, 0,
 420             (SCM stayopen),
 421             "If @var{stayopen} is omitted, this is equivalent to @code{endservent}.\n"
 422             "Otherwise it is equivalent to @code{setservent stayopen}.")
 423 #define FUNC_NAME s_scm_setserv
 424 {
 425   if (SCM_UNBNDP (stayopen))
 426     endservent ();
 427   else
 428     setservent (!SCM_FALSEP (stayopen));
 429   return SCM_UNSPECIFIED;
 430 }
 431 #undef FUNC_NAME
 432 #endif
 433
 434
 435 void
 436 scm_init_net_db ()
 437 {
 438   scm_add_feature ("net-db");
 439 #include "libguile/net_db.x"
 440 }
 441
 442 /*
 443   Local Variables:
 444   c-file-style: "gnu"
 445   End:
 446 */