libguile/net_db.c

   1 /* "net_db.c" network database support
   2  * Copyright (C) 1995, 1996, 1997, 1998, 1999 Free Software Foundation, Inc.
   3  *
   4  * This program is free software; you can redistribute it and/or modify
   5  * it under the terms of the GNU General Public License as published by
   6  * the Free Software Foundation; either version 2, or (at your option)
   7  * any later version.
   8  *
   9  * This program 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
  12  * GNU General Public License for more details.
  13  *
  14  * You should have received a copy of the GNU General Public License
  15  * along with this software; see the file COPYING.  If not, write to
  16  * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
  17  * Boston, MA 02111-1307 USA
  18  *
  19  * As a special exception, the Free Software Foundation gives permission
  20  * for additional uses of the text contained in its release of GUILE.
  21  *
  22  * The exception is that, if you link the GUILE library with other files
  23  * to produce an executable, this does not by itself cause the
  24  * resulting executable to be covered by the GNU General Public License.
  25  * Your use of that executable is in no way restricted on account of
  26  * linking the GUILE library code into it.
  27  *
  28  * This exception does not however invalidate any other reasons why
  29  * the executable file might be covered by the GNU General Public License.
  30  *
  31  * This exception applies only to the code released by the
  32  * Free Software Foundation under the name GUILE.  If you copy
  33  * code from other Free Software Foundation releases into a copy of
  34  * GUILE, as the General Public License permits, the exception does
  35  * not apply to the code that you add in this way.  To avoid misleading
  36  * anyone as to the status of such modified files, you must delete
  37  * this exception notice from them.
  38  *
  39  * If you write modifications of your own for GUILE, it is your choice
  40  * whether to permit this exception to apply to your modifications.
  41  * If you do not wish that, delete this exception notice.  */
  42
  43 /* Written in 1994 by Aubrey Jaffer.
  44  * Thanks to Hallvard.Tretteberg@si.sintef.no for inspiration and discussion.
  45  * Rewritten by Gary Houston to be a closer interface to the C socket library.
  46  * Split into net_db.c and socket.c.
  47  */
  48 \f
  49
  50 #include <stdio.h>
  51 #include "_scm.h"
  52 #include "feature.h"
  53
  54 #include "net_db.h"
  55
  56 #ifdef HAVE_STRING_H
  57 #include <string.h>
  58 #endif
  59
  60 #include <sys/types.h>
  61 #include <sys/socket.h>
  62 #include <netdb.h>
  63 #include <netinet/in.h>
  64 #include <arpa/inet.h>
  65
  66 /* Some systems do not declare this.  Some systems do declare it, as a
  67    macro.  */
  68 #ifndef h_errno
  69 extern int h_errno;
  70 #endif
  71
  72 \f
  73
  74 #ifndef STDC_HEADERS
  75 int close ();
  76 #endif /* STDC_HEADERS */
  77
  78 extern int inet_aton ();
  79
  80 SCM_PROC (s_inet_aton, "inet-aton", 1, 0, 0, scm_inet_aton);
  81
  82 SCM
  83 scm_inet_aton (address)
  84      SCM address;
  85 {
  86   struct in_addr soka;
  87
  88   SCM_ASSERT (SCM_NIMP (address) && SCM_ROSTRINGP (address), address, SCM_ARG1, s_inet_aton);
  89   if (SCM_SUBSTRP (address))
  90     address = scm_makfromstr (SCM_ROCHARS (address), SCM_ROLENGTH (address), 0);
  91   if (inet_aton (SCM_ROCHARS (address), &soka) == 0)
  92     scm_misc_error (s_inet_aton, "bad address", SCM_EOL);
  93   return scm_ulong2num (ntohl (soka.s_addr));
  94 }
  95
  96
  97 SCM_PROC (s_inet_ntoa, "inet-ntoa", 1, 0, 0, scm_inet_ntoa);
  98
  99 SCM
 100 scm_inet_ntoa (inetid)
 101      SCM inetid;
 102 {
 103   struct in_addr addr;
 104   char *s;
 105   SCM answer;
 106   addr.s_addr = htonl (scm_num2ulong (inetid, (char *) SCM_ARG1, s_inet_ntoa));
 107   s = inet_ntoa (addr);
 108   answer = scm_makfromstr (s, strlen (s), 0);
 109   return answer;
 110 }
 111
 112 #ifdef HAVE_INET_NETOF
 113 SCM_PROC (s_inet_netof, "inet-netof", 1, 0, 0, scm_inet_netof);
 114
 115 SCM
 116 scm_inet_netof (address)
 117      SCM address;
 118 {
 119   struct in_addr addr;
 120   addr.s_addr = htonl (scm_num2ulong (address, (char *) SCM_ARG1, s_inet_netof));
 121   return scm_ulong2num ((unsigned long) inet_netof (addr));
 122 }
 123 #endif
 124
 125 #ifdef HAVE_INET_LNAOF
 126 SCM_PROC (s_lnaof, "inet-lnaof", 1, 0, 0, scm_lnaof);
 127
 128 SCM
 129 scm_lnaof (address)
 130      SCM address;
 131 {
 132   struct in_addr addr;
 133   addr.s_addr = htonl (scm_num2ulong (address, (char *) SCM_ARG1, s_lnaof));
 134   return scm_ulong2num ((unsigned long) inet_lnaof (addr));
 135 }
 136 #endif
 137
 138 #ifdef HAVE_INET_MAKEADDR
 139 SCM_PROC (s_inet_makeaddr, "inet-makeaddr", 2, 0, 0, scm_inet_makeaddr);
 140
 141 SCM
 142 scm_inet_makeaddr (net, lna)
 143      SCM net;
 144      SCM lna;
 145 {
 146   struct in_addr addr;
 147   unsigned long netnum;
 148   unsigned long lnanum;
 149
 150   netnum = scm_num2ulong (net, (char *) SCM_ARG1, s_inet_makeaddr);
 151   lnanum = scm_num2ulong (lna, (char *) SCM_ARG2, s_inet_makeaddr);
 152   addr = inet_makeaddr (netnum, lnanum);
 153   return scm_ulong2num (ntohl (addr.s_addr));
 154 }
 155 #endif
 156
 157 SCM_SYMBOL (scm_host_not_found_key, "host-not-found");
 158 SCM_SYMBOL (scm_try_again_key, "try-again");
 159 SCM_SYMBOL (scm_no_recovery_key, "no-recovery");
 160 SCM_SYMBOL (scm_no_data_key, "no-data");
 161
 162 static void scm_resolv_error (const char *subr, SCM bad_value)
 163 {
 164   if (h_errno == NETDB_INTERNAL)
 165     {
 166       /* errno supposedly contains a useful value.  */
 167       scm_syserror (subr);
 168     }
 169   else
 170     {
 171       SCM key;
 172       const char *errmsg;
 173
 174       switch (h_errno)
 175         {
 176         case HOST_NOT_FOUND:
 177           key = scm_host_not_found_key;
 178           errmsg = "Unknown host";
 179           break;
 180         case TRY_AGAIN:
 181           key = scm_try_again_key;
 182           errmsg = "Host name lookup failure";
 183           break;
 184         case NO_RECOVERY:
 185           key = scm_no_recovery_key;
 186           errmsg = "Unknown server error";
 187           break;
 188         case NO_DATA:
 189           key = scm_no_data_key;
 190           errmsg = "No address associated with name";
 191           break;
 192         default:
 193           scm_misc_error (subr, "Unknown resolver error", SCM_EOL);
 194           errmsg = NULL;
 195         }
 196
 197 #ifdef HAVE_HSTRERROR
 198       errmsg = hstrerror (h_errno);
 199 #endif
 200       scm_error (key, subr, errmsg, scm_cons (bad_value, SCM_EOL), SCM_EOL);
 201     }
 202 }
 203
 204 /* Should take an extra arg for address format (will be needed for IPv6).
 205    Should use reentrant facilities if available.
 206  */
 207
 208 SCM_PROC (s_gethost, "gethost", 0, 1, 0, scm_gethost);
 209
 210 SCM
 211 scm_gethost (name)
 212      SCM name;
 213 {
 214   SCM ans = scm_make_vector (SCM_MAKINUM (5), SCM_UNSPECIFIED);
 215   SCM *ve = SCM_VELTS (ans);
 216   SCM lst = SCM_EOL;
 217   struct hostent *entry;
 218   struct in_addr inad;
 219   char **argv;
 220   int i = 0;
 221   if (SCM_UNBNDP (name))
 222     {
 223 #ifdef HAVE_GETHOSTENT
 224       entry = gethostent ();
 225 #else
 226       entry = NULL;
 227 #endif
 228       if (! entry)
 229         {
 230           /* As far as I can tell, there's no good way to tell whether
 231              zero means an error or end-of-file.  The trick of
 232              clearing errno before calling gethostent and checking it
 233              afterwards doesn't cut it, because, on Linux, it seems to
 234              try to contact some other server (YP?) and fails, which
 235              is a benign failure.  */
 236           return SCM_BOOL_F;
 237         }
 238     }
 239   else if (SCM_NIMP (name) && SCM_ROSTRINGP (name))
 240     {
 241       SCM_COERCE_SUBSTR (name);
 242       entry = gethostbyname (SCM_ROCHARS (name));
 243     }
 244   else
 245     {
 246       inad.s_addr = htonl (scm_num2ulong (name, (char *) SCM_ARG1, s_gethost));
 247       entry = gethostbyaddr ((char *) &inad, sizeof (inad), AF_INET);
 248     }
 249   if (!entry)
 250     scm_resolv_error (s_gethost, name);
 251
 252   ve[0] = scm_makfromstr (entry->h_name,
 253                           (scm_sizet) strlen (entry->h_name), 0);
 254   ve[1] = scm_makfromstrs (-1, entry->h_aliases);
 255   ve[2] = SCM_MAKINUM (entry->h_addrtype + 0L);
 256   ve[3] = SCM_MAKINUM (entry->h_length + 0L);
 257   if (sizeof (struct in_addr) != entry->h_length)
 258     {
 259       ve[4] = SCM_BOOL_F;
 260       return ans;
 261     }
 262   for (argv = entry->h_addr_list; argv[i]; i++);
 263   while (i--)
 264     {
 265       inad = *(struct in_addr *) argv[i];
 266       lst = scm_cons (scm_ulong2num (ntohl (inad.s_addr)), lst);
 267     }
 268   ve[4] = lst;
 269   return ans;
 270 }
 271
 272
 273 /* In all subsequent getMUMBLE functions, when we're called with no
 274    arguments, we're supposed to traverse the tables entry by entry.
 275    However, there doesn't seem to be any documented way to distinguish
 276    between end-of-table and an error; in both cases the functions
 277    return zero.  Gotta love Unix.  For the time being, we clear errno,
 278    and if we get a zero and errno is set, we signal an error.  This
 279    doesn't seem quite right (what if errno gets set as part of healthy
 280    operation?), but it seems to work okay.  We'll see.  */
 281
 282 #if defined(HAVE_GETNETENT) && defined(HAVE_GETNETBYNAME) && defined(HAVE_GETNETBYADDR)
 283 SCM_PROC (s_getnet, "getnet", 0, 1, 0, scm_getnet);
 284
 285 SCM
 286 scm_getnet (name)
 287      SCM name;
 288 {
 289   SCM ans;
 290   SCM *ve;
 291   struct netent *entry;
 292
 293   ans = scm_make_vector (SCM_MAKINUM (4), SCM_UNSPECIFIED);
 294   ve = SCM_VELTS (ans);
 295   if (SCM_UNBNDP (name))
 296     {
 297       errno = 0;
 298       entry = getnetent ();
 299       if (! entry)
 300         {
 301           if (errno)
 302             scm_syserror (s_getnet);
 303           else
 304             return SCM_BOOL_F;
 305         }
 306     }
 307   else if (SCM_NIMP (name) && SCM_ROSTRINGP (name))
 308     {
 309       SCM_COERCE_SUBSTR (name);
 310       entry = getnetbyname (SCM_ROCHARS (name));
 311     }
 312   else
 313     {
 314       unsigned long netnum;
 315       netnum = scm_num2ulong (name, (char *) SCM_ARG1, s_getnet);
 316       entry = getnetbyaddr (netnum, AF_INET);
 317     }
 318   if (!entry)
 319     scm_syserror_msg (s_getnet, "no such network %s",
 320                       scm_listify (name, SCM_UNDEFINED), errno);
 321   ve[0] = scm_makfromstr (entry->n_name, (scm_sizet) strlen (entry->n_name), 0);
 322   ve[1] = scm_makfromstrs (-1, entry->n_aliases);
 323   ve[2] = SCM_MAKINUM (entry->n_addrtype + 0L);
 324   ve[3] = scm_ulong2num (entry->n_net + 0L);
 325   return ans;
 326 }
 327 #endif
 328
 329 #ifdef HAVE_GETPROTOENT
 330 SCM_PROC (s_getproto, "getproto", 0, 1, 0, scm_getproto);
 331
 332 SCM
 333 scm_getproto (name)
 334      SCM name;
 335 {
 336   SCM ans;
 337   SCM *ve;
 338   struct protoent *entry;
 339
 340   ans = scm_make_vector (SCM_MAKINUM (3), SCM_UNSPECIFIED);
 341   ve = SCM_VELTS (ans);
 342   if (SCM_UNBNDP (name))
 343     {
 344       errno = 0;
 345       entry = getprotoent ();
 346       if (! entry)
 347         {
 348           if (errno)
 349             scm_syserror (s_getproto);
 350           else
 351             return SCM_BOOL_F;
 352         }
 353     }
 354   else if (SCM_NIMP (name) && SCM_ROSTRINGP (name))
 355     {
 356       SCM_COERCE_SUBSTR (name);
 357       entry = getprotobyname (SCM_ROCHARS (name));
 358     }
 359   else
 360     {
 361       unsigned long protonum;
 362       protonum = scm_num2ulong (name, (char *) SCM_ARG1, s_getproto);
 363       entry = getprotobynumber (protonum);
 364     }
 365   if (!entry)
 366     scm_syserror_msg (s_getproto, "no such protocol %s",
 367                       scm_listify (name, SCM_UNDEFINED), errno);
 368   ve[0] = scm_makfromstr (entry->p_name, (scm_sizet) strlen (entry->p_name), 0);
 369   ve[1] = scm_makfromstrs (-1, entry->p_aliases);
 370   ve[2] = SCM_MAKINUM (entry->p_proto + 0L);
 371   return ans;
 372 }
 373 #endif
 374
 375 static SCM scm_return_entry SCM_P ((struct servent *entry));
 376
 377 static SCM
 378 scm_return_entry (entry)
 379      struct servent *entry;
 380 {
 381   SCM ans;
 382   SCM *ve;
 383
 384   ans = scm_make_vector (SCM_MAKINUM (4), SCM_UNSPECIFIED);
 385   ve = SCM_VELTS (ans);
 386   ve[0] = scm_makfromstr (entry->s_name, (scm_sizet) strlen (entry->s_name), 0);
 387   ve[1] = scm_makfromstrs (-1, entry->s_aliases);
 388   ve[2] = SCM_MAKINUM (ntohs (entry->s_port) + 0L);
 389   ve[3] = scm_makfromstr (entry->s_proto, (scm_sizet) strlen (entry->s_proto), 0);
 390   return ans;
 391 }
 392
 393 #ifdef HAVE_GETSERVENT
 394 SCM_PROC (s_getserv, "getserv", 0, 2, 0, scm_getserv);
 395
 396 SCM
 397 scm_getserv (name, proto)
 398      SCM name;
 399      SCM proto;
 400 {
 401   struct servent *entry;
 402   if (SCM_UNBNDP (name))
 403     {
 404       errno = 0;
 405       entry = getservent ();
 406       if (!entry)
 407         {
 408           if (errno)
 409             scm_syserror (s_getserv);
 410           else
 411             return SCM_BOOL_F;
 412         }
 413       return scm_return_entry (entry);
 414     }
 415   SCM_ASSERT (SCM_NIMP (proto) && SCM_ROSTRINGP (proto), proto, SCM_ARG2, s_getserv);
 416   SCM_COERCE_SUBSTR (proto);
 417   if (SCM_NIMP (name) && SCM_ROSTRINGP (name))
 418     {
 419       SCM_COERCE_SUBSTR (name);
 420       entry = getservbyname (SCM_ROCHARS (name), SCM_ROCHARS (proto));
 421     }
 422   else
 423     {
 424       SCM_ASSERT (SCM_INUMP (name), name, SCM_ARG1, s_getserv);
 425       entry = getservbyport (htons (SCM_INUM (name)), SCM_ROCHARS (proto));
 426     }
 427   if (!entry)
 428     scm_syserror_msg (s_getserv, "no such service %s",
 429                       scm_listify (name, SCM_UNDEFINED), errno);
 430   return scm_return_entry (entry);
 431 }
 432 #endif
 433
 434 #if defined(HAVE_SETHOSTENT) && defined(HAVE_ENDHOSTENT)
 435 SCM_PROC (s_sethost, "sethost", 0, 1, 0, scm_sethost);
 436
 437 SCM
 438 scm_sethost (arg)
 439      SCM arg;
 440 {
 441   if (SCM_UNBNDP (arg))
 442     endhostent ();
 443   else
 444     sethostent (SCM_NFALSEP (arg));
 445   return SCM_UNSPECIFIED;
 446 }
 447 #endif
 448
 449 #if defined(HAVE_SETNETENT) && defined(HAVE_ENDNETENT)
 450 SCM_PROC (s_setnet, "setnet", 0, 1, 0, scm_setnet);
 451
 452 SCM
 453 scm_setnet (arg)
 454      SCM arg;
 455 {
 456   if (SCM_UNBNDP (arg))
 457     endnetent ();
 458   else
 459     setnetent (SCM_NFALSEP (arg));
 460   return SCM_UNSPECIFIED;
 461 }
 462 #endif
 463
 464 #if defined(HAVE_SETPROTOENT) && defined(HAVE_ENDPROTOENT)
 465 SCM_PROC (s_setproto, "setproto", 0, 1, 0, scm_setproto);
 466
 467 SCM
 468 scm_setproto (arg)
 469      SCM arg;
 470 {
 471   if (SCM_UNBNDP (arg))
 472     endprotoent ();
 473   else
 474     setprotoent (SCM_NFALSEP (arg));
 475   return SCM_UNSPECIFIED;
 476 }
 477 #endif
 478
 479 #if defined(HAVE_SETSERVENT) && defined(HAVE_ENDSERVENT)
 480 SCM_PROC (s_setserv, "setserv", 0, 1, 0, scm_setserv);
 481
 482 SCM
 483 scm_setserv (arg)
 484      SCM arg;
 485 {
 486   if (SCM_UNBNDP (arg))
 487     endservent ();
 488   else
 489     setservent (SCM_NFALSEP (arg));
 490   return SCM_UNSPECIFIED;
 491 }
 492 #endif
 493
 494
 495 void
 496 scm_init_net_db ()
 497 {
 498 #ifdef INADDR_ANY
 499   scm_sysintern ("INADDR_ANY", scm_ulong2num (INADDR_ANY));
 500 #endif
 501 #ifdef INADDR_BROADCAST
 502   scm_sysintern ("INADDR_BROADCAST", scm_ulong2num (INADDR_BROADCAST));
 503 #endif
 504 #ifdef INADDR_NONE
 505   scm_sysintern ("INADDR_NONE", scm_ulong2num (INADDR_NONE));
 506 #endif
 507 #ifdef INADDR_LOOPBACK
 508   scm_sysintern ("INADDR_LOOPBACK", scm_ulong2num (INADDR_LOOPBACK));
 509 #endif
 510
 511   scm_add_feature ("net-db");
 512 #include "net_db.x"
 513 }