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