libguile/net_db.c

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