libguile/net_db.c

   1 /* "net_db.c" network database support
   2  *      Copyright (C) 1995,1996 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, 675 Mass Ave, Cambridge, MA 02139, USA.
  17  *
  18  * As a special exception, the Free Software Foundation gives permission
  19  * for additional uses of the text contained in its release of GUILE.
  20  *
  21  * The exception is that, if you link the GUILE library with other files
  22  * to produce an executable, this does not by itself cause the
  23  * resulting executable to be covered by the GNU General Public License.
  24  * Your use of that executable is in no way restricted on account of
  25  * linking the GUILE library code into it.
  26  *
  27  * This exception does not however invalidate any other reasons why
  28  * the executable file might be covered by the GNU General Public License.
  29  *
  30  * This exception applies only to the code released by the
  31  * Free Software Foundation under the name GUILE.  If you copy
  32  * code from other Free Software Foundation releases into a copy of
  33  * GUILE, as the General Public License permits, the exception does
  34  * not apply to the code that you add in this way.  To avoid misleading
  35  * anyone as to the status of such modified files, you must delete
  36  * this exception notice from them.
  37  *
  38  * If you write modifications of your own for GUILE, it is your choice
  39  * whether to permit this exception to apply to your modifications.
  40  * If you do not wish that, delete this exception notice.
  41  */
  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 SCM_PROC (s_inet_netof, "inet-netof", 1, 0, 0, scm_inet_netof);
 113
 114 SCM
 115 scm_inet_netof (address)
 116      SCM address;
 117 {
 118   struct in_addr addr;
 119   addr.s_addr = htonl (scm_num2ulong (address, (char *) SCM_ARG1, s_inet_netof));
 120   return scm_ulong2num ((unsigned long) inet_netof (addr));
 121 }
 122
 123 SCM_PROC (s_lnaof, "inet-lnaof", 1, 0, 0, scm_lnaof);
 124
 125 SCM
 126 scm_lnaof (address)
 127      SCM address;
 128 {
 129   struct in_addr addr;
 130   addr.s_addr = htonl (scm_num2ulong (address, (char *) SCM_ARG1, s_lnaof));
 131   return scm_ulong2num ((unsigned long) inet_lnaof (addr));
 132 }
 133
 134
 135 SCM_PROC (s_inet_makeaddr, "inet-makeaddr", 2, 0, 0, scm_inet_makeaddr);
 136
 137 SCM
 138 scm_inet_makeaddr (net, lna)
 139      SCM net;
 140      SCM lna;
 141 {
 142   struct in_addr addr;
 143   unsigned long netnum;
 144   unsigned long lnanum;
 145
 146   netnum = scm_num2ulong (net, (char *) SCM_ARG1, s_inet_makeaddr);
 147   lnanum = scm_num2ulong (lna, (char *) SCM_ARG2, s_inet_makeaddr);
 148   addr = inet_makeaddr (netnum, lnanum);
 149   return scm_ulong2num (ntohl (addr.s_addr));
 150 }
 151
 152
 153 /* !!! Doesn't take address format.
 154  * Assumes hostent stream isn't reused.
 155  */
 156
 157 SCM_PROC (s_gethost, "gethost", 0, 1, 0, scm_gethost);
 158
 159 SCM
 160 scm_gethost (name)
 161      SCM name;
 162 {
 163   SCM ans = scm_make_vector (SCM_MAKINUM (5), SCM_UNSPECIFIED, SCM_BOOL_F);
 164   SCM *ve = SCM_VELTS (ans);
 165   SCM lst = SCM_EOL;
 166   struct hostent *entry;
 167   struct in_addr inad;
 168   char **argv;
 169   int i = 0;
 170   if (SCM_UNBNDP (name))
 171     {
 172       SCM_DEFER_INTS;
 173 #ifdef HAVE_GETHOSTENT
 174       entry = gethostent ();
 175 #else
 176       entry = NULL;
 177 #endif
 178     }
 179   else if (SCM_NIMP (name) && SCM_ROSTRINGP (name))
 180     {
 181       SCM_COERCE_SUBSTR (name);
 182       SCM_DEFER_INTS;
 183       entry = gethostbyname (SCM_ROCHARS (name));
 184     }
 185   else
 186     {
 187       inad.s_addr = htonl (scm_num2ulong (name, (char *) SCM_ARG1, s_gethost));
 188       SCM_DEFER_INTS;
 189       entry = gethostbyaddr ((char *) &inad, sizeof (inad), AF_INET);
 190     }
 191   SCM_ALLOW_INTS;
 192   if (!entry)
 193     {
 194       char *errmsg;
 195       SCM args;
 196       if (SCM_UNBNDP (name))
 197         args = SCM_BOOL_F;
 198       else
 199         args = scm_listify (name, SCM_UNDEFINED);
 200       switch (h_errno)
 201         {
 202         case HOST_NOT_FOUND: errmsg = "host %s not found"; break;
 203         case TRY_AGAIN:      errmsg = "nameserver failure (try later)"; break;
 204         case NO_RECOVERY:    errmsg = "non-recoverable error"; break;
 205         case NO_DATA:        errmsg = "no address associated with %s"; break;
 206         default:             errmsg = "undefined error"; break;
 207         }
 208       scm_syserror_msg (s_gethost, errmsg, args, h_errno);
 209     }
 210   ve[0] = scm_makfromstr (entry->h_name, (scm_sizet) strlen (entry->h_name), 0);
 211   ve[1] = scm_makfromstrs (-1, entry->h_aliases);
 212   ve[2] = SCM_MAKINUM (entry->h_addrtype + 0L);
 213   ve[3] = SCM_MAKINUM (entry->h_length + 0L);
 214   if (sizeof (struct in_addr) != entry->h_length)
 215     {
 216       ve[4] = SCM_BOOL_F;
 217       return ans;
 218     }
 219   for (argv = entry->h_addr_list; argv[i]; i++);
 220   while (i--)
 221     {
 222       inad = *(struct in_addr *) argv[i];
 223       lst = scm_cons (scm_ulong2num (ntohl (inad.s_addr)), lst);
 224     }
 225   ve[4] = lst;
 226   return ans;
 227 }
 228
 229
 230 SCM_PROC (s_getnet, "getnet", 0, 1, 0, scm_getnet);
 231
 232 SCM
 233 scm_getnet (name)
 234      SCM name;
 235 {
 236   SCM ans;
 237   SCM *ve;
 238   struct netent *entry;
 239
 240   ans = scm_make_vector (SCM_MAKINUM (4), SCM_UNSPECIFIED, SCM_BOOL_F);
 241   ve = SCM_VELTS (ans);
 242   if (SCM_UNBNDP (name))
 243     {
 244       SCM_DEFER_INTS;
 245       entry = getnetent ();
 246     }
 247   else if (SCM_NIMP (name) && SCM_ROSTRINGP (name))
 248     {
 249       SCM_COERCE_SUBSTR (name);
 250       SCM_DEFER_INTS;
 251       entry = getnetbyname (SCM_ROCHARS (name));
 252     }
 253   else
 254     {
 255       unsigned long netnum;
 256       netnum = scm_num2ulong (name, (char *) SCM_ARG1, s_getnet);
 257       SCM_DEFER_INTS;
 258       entry = getnetbyaddr (netnum, AF_INET);
 259     }
 260   SCM_ALLOW_INTS;
 261   if (!entry)
 262     {
 263       if (SCM_UNBNDP (name))
 264         scm_syserror (s_getnet);
 265       else
 266         scm_syserror_msg (s_getnet, "no such network %s",
 267                           scm_listify (name, SCM_UNDEFINED), errno);
 268     }
 269   ve[0] = scm_makfromstr (entry->n_name, (scm_sizet) strlen (entry->n_name), 0);
 270   ve[1] = scm_makfromstrs (-1, entry->n_aliases);
 271   ve[2] = SCM_MAKINUM (entry->n_addrtype + 0L);
 272   ve[3] = scm_ulong2num (entry->n_net + 0L);
 273   return ans;
 274 }
 275
 276 SCM_PROC (s_getproto, "getproto", 0, 1, 0, scm_getproto);
 277
 278 SCM
 279 scm_getproto (name)
 280      SCM name;
 281 {
 282   SCM ans;
 283   SCM *ve;
 284   struct protoent *entry;
 285
 286   ans = scm_make_vector (SCM_MAKINUM (3), SCM_UNSPECIFIED, SCM_BOOL_F);
 287   ve = SCM_VELTS (ans);
 288   if (SCM_UNBNDP (name))
 289     {
 290       SCM_DEFER_INTS;
 291       entry = getprotoent ();
 292     }
 293   else if (SCM_NIMP (name) && SCM_ROSTRINGP (name))
 294     {
 295       SCM_COERCE_SUBSTR (name);
 296       SCM_DEFER_INTS;
 297       entry = getprotobyname (SCM_ROCHARS (name));
 298     }
 299   else
 300     {
 301       unsigned long protonum;
 302       protonum = scm_num2ulong (name, (char *) SCM_ARG1, s_getproto);
 303       SCM_DEFER_INTS;
 304       entry = getprotobynumber (protonum);
 305     }
 306   SCM_ALLOW_INTS;
 307   if (!entry)
 308     {
 309       if (SCM_UNBNDP (name))
 310         scm_syserror (s_getproto);
 311       else
 312         scm_syserror_msg (s_getproto, "no such protocol %s",
 313                           scm_listify (name, SCM_UNDEFINED), errno);
 314     }
 315   ve[0] = scm_makfromstr (entry->p_name, (scm_sizet) strlen (entry->p_name), 0);
 316   ve[1] = scm_makfromstrs (-1, entry->p_aliases);
 317   ve[2] = SCM_MAKINUM (entry->p_proto + 0L);
 318   return ans;
 319 }
 320
 321
 322 static SCM scm_return_entry SCM_P ((struct servent *entry));
 323
 324 static SCM
 325 scm_return_entry (entry)
 326      struct servent *entry;
 327 {
 328   SCM ans;
 329   SCM *ve;
 330
 331   ans = scm_make_vector (SCM_MAKINUM (4), SCM_UNSPECIFIED, SCM_BOOL_F);
 332   ve = SCM_VELTS (ans);
 333   ve[0] = scm_makfromstr (entry->s_name, (scm_sizet) strlen (entry->s_name), 0);
 334   ve[1] = scm_makfromstrs (-1, entry->s_aliases);
 335   ve[2] = SCM_MAKINUM (ntohs (entry->s_port) + 0L);
 336   ve[3] = scm_makfromstr (entry->s_proto, (scm_sizet) strlen (entry->s_proto), 0);
 337   SCM_ALLOW_INTS;
 338   return ans;
 339 }
 340
 341 SCM_PROC (s_getserv, "getserv", 0, 2, 0, scm_getserv);
 342
 343 SCM
 344 scm_getserv (name, proto)
 345      SCM name;
 346      SCM proto;
 347 {
 348   struct servent *entry;
 349   if (SCM_UNBNDP (name))
 350     {
 351       SCM_DEFER_INTS;
 352       entry = getservent ();
 353       if (!entry)
 354         scm_syserror (s_getserv);
 355       SCM_ALLOW_INTS;
 356       return scm_return_entry (entry);
 357     }
 358   SCM_ASSERT (SCM_NIMP (proto) && SCM_ROSTRINGP (proto), proto, SCM_ARG2, s_getserv);
 359   SCM_COERCE_SUBSTR (proto);
 360   if (SCM_NIMP (name) && SCM_ROSTRINGP (name))
 361     {
 362       SCM_COERCE_SUBSTR (name);
 363       SCM_DEFER_INTS;
 364       entry = getservbyname (SCM_ROCHARS (name), SCM_ROCHARS (proto));
 365     }
 366   else
 367     {
 368       SCM_ASSERT (SCM_INUMP (name), name, SCM_ARG1, s_getserv);
 369       SCM_DEFER_INTS;
 370       entry = getservbyport (htons (SCM_INUM (name)), SCM_ROCHARS (proto));
 371     }
 372   if (!entry)
 373     scm_syserror_msg (s_getserv, "no such service %s",
 374                       scm_listify (name, SCM_UNDEFINED), errno);
 375   SCM_ALLOW_INTS;
 376   return scm_return_entry (entry);
 377 }
 378
 379 SCM_PROC (s_sethost, "sethost", 0, 1, 0, scm_sethost);
 380
 381 SCM
 382 scm_sethost (arg)
 383      SCM arg;
 384 {
 385   if (SCM_UNBNDP (arg))
 386     endhostent ();
 387   else
 388     sethostent (SCM_NFALSEP (arg));
 389   return SCM_UNSPECIFIED;
 390 }
 391
 392 SCM_PROC (s_setnet, "setnet", 0, 1, 0, scm_setnet);
 393
 394 SCM
 395 scm_setnet (arg)
 396      SCM arg;
 397 {
 398   if (SCM_UNBNDP (arg))
 399     endnetent ();
 400   else
 401     setnetent (SCM_NFALSEP (arg));
 402   return SCM_UNSPECIFIED;
 403 }
 404
 405 SCM_PROC (s_setproto, "setproto", 0, 1, 0, scm_setproto);
 406
 407 SCM
 408 scm_setproto (arg)
 409      SCM arg;
 410 {
 411   if (SCM_UNBNDP (arg))
 412     endprotoent ();
 413   else
 414     setprotoent (SCM_NFALSEP (arg));
 415   return SCM_UNSPECIFIED;
 416 }
 417
 418 SCM_PROC (s_setserv, "setserv", 0, 1, 0, scm_setserv);
 419
 420 SCM
 421 scm_setserv (arg)
 422      SCM arg;
 423 {
 424   if (SCM_UNBNDP (arg))
 425     endservent ();
 426   else
 427     setservent (SCM_NFALSEP (arg));
 428   return SCM_UNSPECIFIED;
 429 }
 430
 431
 432 void
 433 scm_init_net_db ()
 434 {
 435 #ifdef INADDR_ANY
 436   scm_sysintern ("INADDR_ANY", scm_ulong2num (INADDR_ANY));
 437 #endif
 438 #ifdef INADDR_BROADCAST
 439   scm_sysintern ("INADDR_BROADCAST", scm_ulong2num (INADDR_BROADCAST));
 440 #endif
 441 #ifdef INADDR_NONE
 442   scm_sysintern ("INADDR_NONE", scm_ulong2num (INADDR_NONE));
 443 #endif
 444 #ifdef INADDR_LOOPBACK
 445   scm_sysintern ("INADDR_LOOPBACK", scm_ulong2num (INADDR_LOOPBACK));
 446 #endif
 447
 448   scm_add_feature ("net-db");
 449 #include "net_db.x"
 450 }
 451
 452