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