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