libguile/net_db.c

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