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_syserror (s_inet_aton);
  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
 158 /* !!! Doesn't take address format.
 159  * Assumes hostent stream isn't reused.
 160  */
 161
 162 SCM_PROC (s_gethost, "gethost", 0, 1, 0, scm_gethost);
 163
 164 SCM
 165 scm_gethost (name)
 166      SCM name;
 167 {
 168   SCM ans = scm_make_vector (SCM_MAKINUM (5), SCM_UNSPECIFIED);
 169   SCM *ve = SCM_VELTS (ans);
 170   SCM lst = SCM_EOL;
 171   struct hostent *entry;
 172   struct in_addr inad;
 173   char **argv;
 174   int i = 0;
 175   if (SCM_UNBNDP (name))
 176     {
 177 #ifdef HAVE_GETHOSTENT
 178       entry = gethostent ();
 179 #else
 180       entry = NULL;
 181 #endif
 182       if (! entry)
 183         {
 184           /* As far as I can tell, there's no good way to tell whether
 185              zero means an error or end-of-file.  The trick of
 186              clearing errno before calling gethostent and checking it
 187              afterwards doesn't cut it, because, on Linux, it seems to
 188              try to contact some other server (YP?) and fails, which
 189              is a benign failure.  */
 190           return SCM_BOOL_F;
 191         }
 192     }
 193   else if (SCM_NIMP (name) && SCM_ROSTRINGP (name))
 194     {
 195       SCM_COERCE_SUBSTR (name);
 196       entry = gethostbyname (SCM_ROCHARS (name));
 197     }
 198   else
 199     {
 200       inad.s_addr = htonl (scm_num2ulong (name, (char *) SCM_ARG1, s_gethost));
 201       entry = gethostbyaddr ((char *) &inad, sizeof (inad), AF_INET);
 202     }
 203   if (!entry)
 204     {
 205       char *errmsg;
 206       SCM args;
 207       args = scm_listify (name, SCM_UNDEFINED);
 208       switch (h_errno)
 209         {
 210         case HOST_NOT_FOUND: errmsg = "host %s not found"; break;
 211         case TRY_AGAIN:      errmsg = "nameserver failure (try later)"; break;
 212         case NO_RECOVERY:    errmsg = "non-recoverable error"; break;
 213         case NO_DATA:        errmsg = "no address associated with %s"; break;
 214         default:             errmsg = "undefined error"; break;
 215         }
 216       scm_syserror_msg (s_gethost, errmsg, args, h_errno);
 217     }
 218   ve[0] = scm_makfromstr (entry->h_name, (scm_sizet) strlen (entry->h_name), 0);
 219   ve[1] = scm_makfromstrs (-1, entry->h_aliases);
 220   ve[2] = SCM_MAKINUM (entry->h_addrtype + 0L);
 221   ve[3] = SCM_MAKINUM (entry->h_length + 0L);
 222   if (sizeof (struct in_addr) != entry->h_length)
 223     {
 224       ve[4] = SCM_BOOL_F;
 225       return ans;
 226     }
 227   for (argv = entry->h_addr_list; argv[i]; i++);
 228   while (i--)
 229     {
 230       inad = *(struct in_addr *) argv[i];
 231       lst = scm_cons (scm_ulong2num (ntohl (inad.s_addr)), lst);
 232     }
 233   ve[4] = lst;
 234   return ans;
 235 }
 236
 237
 238 /* In all subsequent getMUMBLE functions, when we're called with no
 239    arguments, we're supposed to traverse the tables entry by entry.
 240    However, there doesn't seem to be any documented way to distinguish
 241    between end-of-table and an error; in both cases the functions
 242    return zero.  Gotta love Unix.  For the time being, we clear errno,
 243    and if we get a zero and errno is set, we signal an error.  This
 244    doesn't seem quite right (what if errno gets set as part of healthy
 245    operation?), but it seems to work okay.  We'll see.  */
 246
 247 #if defined(HAVE_GETNETENT) && defined(HAVE_GETNETBYNAME) && defined(HAVE_GETNETBYADDR)
 248 SCM_PROC (s_getnet, "getnet", 0, 1, 0, scm_getnet);
 249
 250 SCM
 251 scm_getnet (name)
 252      SCM name;
 253 {
 254   SCM ans;
 255   SCM *ve;
 256   struct netent *entry;
 257
 258   ans = scm_make_vector (SCM_MAKINUM (4), SCM_UNSPECIFIED);
 259   ve = SCM_VELTS (ans);
 260   if (SCM_UNBNDP (name))
 261     {
 262       errno = 0;
 263       entry = getnetent ();
 264       if (! entry)
 265         {
 266           if (errno)
 267             scm_syserror (s_getnet);
 268           else
 269             return SCM_BOOL_F;
 270         }
 271     }
 272   else if (SCM_NIMP (name) && SCM_ROSTRINGP (name))
 273     {
 274       SCM_COERCE_SUBSTR (name);
 275       entry = getnetbyname (SCM_ROCHARS (name));
 276     }
 277   else
 278     {
 279       unsigned long netnum;
 280       netnum = scm_num2ulong (name, (char *) SCM_ARG1, s_getnet);
 281       entry = getnetbyaddr (netnum, AF_INET);
 282     }
 283   if (!entry)
 284     scm_syserror_msg (s_getnet, "no such network %s",
 285                       scm_listify (name, SCM_UNDEFINED), errno);
 286   ve[0] = scm_makfromstr (entry->n_name, (scm_sizet) strlen (entry->n_name), 0);
 287   ve[1] = scm_makfromstrs (-1, entry->n_aliases);
 288   ve[2] = SCM_MAKINUM (entry->n_addrtype + 0L);
 289   ve[3] = scm_ulong2num (entry->n_net + 0L);
 290   return ans;
 291 }
 292 #endif
 293
 294 #ifdef HAVE_GETPROTOENT
 295 SCM_PROC (s_getproto, "getproto", 0, 1, 0, scm_getproto);
 296
 297 SCM
 298 scm_getproto (name)
 299      SCM name;
 300 {
 301   SCM ans;
 302   SCM *ve;
 303   struct protoent *entry;
 304
 305   ans = scm_make_vector (SCM_MAKINUM (3), SCM_UNSPECIFIED);
 306   ve = SCM_VELTS (ans);
 307   if (SCM_UNBNDP (name))
 308     {
 309       errno = 0;
 310       entry = getprotoent ();
 311       if (! entry)
 312         {
 313           if (errno)
 314             scm_syserror (s_getproto);
 315           else
 316             return SCM_BOOL_F;
 317         }
 318     }
 319   else if (SCM_NIMP (name) && SCM_ROSTRINGP (name))
 320     {
 321       SCM_COERCE_SUBSTR (name);
 322       entry = getprotobyname (SCM_ROCHARS (name));
 323     }
 324   else
 325     {
 326       unsigned long protonum;
 327       protonum = scm_num2ulong (name, (char *) SCM_ARG1, s_getproto);
 328       entry = getprotobynumber (protonum);
 329     }
 330   if (!entry)
 331     scm_syserror_msg (s_getproto, "no such protocol %s",
 332                       scm_listify (name, SCM_UNDEFINED), errno);
 333   ve[0] = scm_makfromstr (entry->p_name, (scm_sizet) strlen (entry->p_name), 0);
 334   ve[1] = scm_makfromstrs (-1, entry->p_aliases);
 335   ve[2] = SCM_MAKINUM (entry->p_proto + 0L);
 336   return ans;
 337 }
 338 #endif
 339
 340 static SCM scm_return_entry SCM_P ((struct servent *entry));
 341
 342 static SCM
 343 scm_return_entry (entry)
 344      struct servent *entry;
 345 {
 346   SCM ans;
 347   SCM *ve;
 348
 349   ans = scm_make_vector (SCM_MAKINUM (4), SCM_UNSPECIFIED);
 350   ve = SCM_VELTS (ans);
 351   ve[0] = scm_makfromstr (entry->s_name, (scm_sizet) strlen (entry->s_name), 0);
 352   ve[1] = scm_makfromstrs (-1, entry->s_aliases);
 353   ve[2] = SCM_MAKINUM (ntohs (entry->s_port) + 0L);
 354   ve[3] = scm_makfromstr (entry->s_proto, (scm_sizet) strlen (entry->s_proto), 0);
 355   return ans;
 356 }
 357
 358 #ifdef HAVE_GETSERVENT
 359 SCM_PROC (s_getserv, "getserv", 0, 2, 0, scm_getserv);
 360
 361 SCM
 362 scm_getserv (name, proto)
 363      SCM name;
 364      SCM proto;
 365 {
 366   struct servent *entry;
 367   if (SCM_UNBNDP (name))
 368     {
 369       errno = 0;
 370       entry = getservent ();
 371       if (!entry)
 372         {
 373           if (errno)
 374             scm_syserror (s_getserv);
 375           else
 376             return SCM_BOOL_F;
 377         }
 378       return scm_return_entry (entry);
 379     }
 380   SCM_ASSERT (SCM_NIMP (proto) && SCM_ROSTRINGP (proto), proto, SCM_ARG2, s_getserv);
 381   SCM_COERCE_SUBSTR (proto);
 382   if (SCM_NIMP (name) && SCM_ROSTRINGP (name))
 383     {
 384       SCM_COERCE_SUBSTR (name);
 385       entry = getservbyname (SCM_ROCHARS (name), SCM_ROCHARS (proto));
 386     }
 387   else
 388     {
 389       SCM_ASSERT (SCM_INUMP (name), name, SCM_ARG1, s_getserv);
 390       entry = getservbyport (htons (SCM_INUM (name)), SCM_ROCHARS (proto));
 391     }
 392   if (!entry)
 393     scm_syserror_msg (s_getserv, "no such service %s",
 394                       scm_listify (name, SCM_UNDEFINED), errno);
 395   return scm_return_entry (entry);
 396 }
 397 #endif
 398
 399 #if defined(HAVE_SETHOSTENT) && defined(HAVE_ENDHOSTENT)
 400 SCM_PROC (s_sethost, "sethost", 0, 1, 0, scm_sethost);
 401
 402 SCM
 403 scm_sethost (arg)
 404      SCM arg;
 405 {
 406   if (SCM_UNBNDP (arg))
 407     endhostent ();
 408   else
 409     sethostent (SCM_NFALSEP (arg));
 410   return SCM_UNSPECIFIED;
 411 }
 412 #endif
 413
 414 #if defined(HAVE_SETNETENT) && defined(HAVE_ENDNETENT)
 415 SCM_PROC (s_setnet, "setnet", 0, 1, 0, scm_setnet);
 416
 417 SCM
 418 scm_setnet (arg)
 419      SCM arg;
 420 {
 421   if (SCM_UNBNDP (arg))
 422     endnetent ();
 423   else
 424     setnetent (SCM_NFALSEP (arg));
 425   return SCM_UNSPECIFIED;
 426 }
 427 #endif
 428
 429 #if defined(HAVE_SETPROTOENT) && defined(HAVE_ENDPROTOENT)
 430 SCM_PROC (s_setproto, "setproto", 0, 1, 0, scm_setproto);
 431
 432 SCM
 433 scm_setproto (arg)
 434      SCM arg;
 435 {
 436   if (SCM_UNBNDP (arg))
 437     endprotoent ();
 438   else
 439     setprotoent (SCM_NFALSEP (arg));
 440   return SCM_UNSPECIFIED;
 441 }
 442 #endif
 443
 444 #if defined(HAVE_SETSERVENT) && defined(HAVE_ENDSERVENT)
 445 SCM_PROC (s_setserv, "setserv", 0, 1, 0, scm_setserv);
 446
 447 SCM
 448 scm_setserv (arg)
 449      SCM arg;
 450 {
 451   if (SCM_UNBNDP (arg))
 452     endservent ();
 453   else
 454     setservent (SCM_NFALSEP (arg));
 455   return SCM_UNSPECIFIED;
 456 }
 457 #endif
 458
 459
 460 void
 461 scm_init_net_db ()
 462 {
 463 #ifdef INADDR_ANY
 464   scm_sysintern ("INADDR_ANY", scm_ulong2num (INADDR_ANY));
 465 #endif
 466 #ifdef INADDR_BROADCAST
 467   scm_sysintern ("INADDR_BROADCAST", scm_ulong2num (INADDR_BROADCAST));
 468 #endif
 469 #ifdef INADDR_NONE
 470   scm_sysintern ("INADDR_NONE", scm_ulong2num (INADDR_NONE));
 471 #endif
 472 #ifdef INADDR_LOOPBACK
 473   scm_sysintern ("INADDR_LOOPBACK", scm_ulong2num (INADDR_LOOPBACK));
 474 #endif
 475
 476   scm_add_feature ("net-db");
 477 #include "net_db.x"
 478 }