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_BOOL_F, 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_from_int (entry->h_addrtype));
 175   SCM_VECTOR_SET(result, 3, scm_from_int (entry->h_length));
 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_from_ulong (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_from_int (entry->n_addrtype));
 243   SCM_VECTOR_SET(result, 3, scm_from_ulong (entry->n_net));
 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_from_int (entry->p_proto));
 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_from_uint16 (ntohs (entry->s_port)));
 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),
 337                              SCM_STRING_CHARS (protocol));
 338     }
 339   else
 340     {
 341       entry = getservbyport (htons (scm_to_int (name)),
 342                              SCM_STRING_CHARS (protocol));
 343     }
 344   if (!entry)
 345     SCM_SYSERROR_MSG("no such service ~A", scm_list_1 (name), errno);
 346   return scm_return_entry (entry);
 347 }
 348 #undef FUNC_NAME
 349 #endif
 350
 351 #if defined(HAVE_SETHOSTENT) && defined(HAVE_ENDHOSTENT)
 352 SCM_DEFINE (scm_sethost, "sethost", 0, 1, 0,
 353             (SCM stayopen),
 354             "If @var{stayopen} is omitted, this is equivalent to @code{endhostent}.\n"
 355             "Otherwise it is equivalent to @code{sethostent stayopen}.")
 356 #define FUNC_NAME s_scm_sethost
 357 {
 358   if (SCM_UNBNDP (stayopen))
 359     endhostent ();
 360   else
 361     sethostent (scm_is_true (stayopen));
 362   return SCM_UNSPECIFIED;
 363 }
 364 #undef FUNC_NAME
 365 #endif
 366
 367 #if defined(HAVE_SETNETENT) && defined(HAVE_ENDNETENT)
 368 SCM_DEFINE (scm_setnet, "setnet", 0, 1, 0,
 369             (SCM stayopen),
 370             "If @var{stayopen} is omitted, this is equivalent to @code{endnetent}.\n"
 371             "Otherwise it is equivalent to @code{setnetent stayopen}.")
 372 #define FUNC_NAME s_scm_setnet
 373 {
 374   if (SCM_UNBNDP (stayopen))
 375     endnetent ();
 376   else
 377     setnetent (scm_is_true (stayopen));
 378   return SCM_UNSPECIFIED;
 379 }
 380 #undef FUNC_NAME
 381 #endif
 382
 383 #if defined (HAVE_SETPROTOENT) && defined (HAVE_ENDPROTOENT) || defined (__MINGW32__)
 384 SCM_DEFINE (scm_setproto, "setproto", 0, 1, 0,
 385             (SCM stayopen),
 386             "If @var{stayopen} is omitted, this is equivalent to @code{endprotoent}.\n"
 387             "Otherwise it is equivalent to @code{setprotoent stayopen}.")
 388 #define FUNC_NAME s_scm_setproto
 389 {
 390   if (SCM_UNBNDP (stayopen))
 391     endprotoent ();
 392   else
 393     setprotoent (scm_is_true (stayopen));
 394   return SCM_UNSPECIFIED;
 395 }
 396 #undef FUNC_NAME
 397 #endif
 398
 399 #if defined (HAVE_SETSERVENT) && defined (HAVE_ENDSERVENT) || defined (__MINGW32__)
 400 SCM_DEFINE (scm_setserv, "setserv", 0, 1, 0,
 401             (SCM stayopen),
 402             "If @var{stayopen} is omitted, this is equivalent to @code{endservent}.\n"
 403             "Otherwise it is equivalent to @code{setservent stayopen}.")
 404 #define FUNC_NAME s_scm_setserv
 405 {
 406   if (SCM_UNBNDP (stayopen))
 407     endservent ();
 408   else
 409     setservent (scm_is_true (stayopen));
 410   return SCM_UNSPECIFIED;
 411 }
 412 #undef FUNC_NAME
 413 #endif
 414
 415
 416 void
 417 scm_init_net_db ()
 418 {
 419   scm_add_feature ("net-db");
 420 #include "libguile/net_db.x"
 421 }
 422
 423 /*
 424   Local Variables:
 425   c-file-style: "gnu"
 426   End:
 427 */