libguile/net_db.c

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