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 \f
  67
  68 #ifndef STDC_HEADERS
  69 int close ();
  70 #endif /* STDC_HEADERS */
  71
  72 extern int inet_aton ();
  73
  74 SCM_PROC (s_inet_aton, "inet-aton", 1, 0, 0, scm_inet_aton);
  75
  76 SCM
  77 scm_inet_aton (address)
  78      SCM address;
  79 {
  80   struct in_addr soka;
  81
  82   SCM_ASSERT (SCM_NIMP (address) && SCM_ROSTRINGP (address), address, SCM_ARG1, s_inet_aton);
  83   if (SCM_SUBSTRP (address))
  84     address = scm_makfromstr (SCM_ROCHARS (address), SCM_ROLENGTH (address), 0);
  85   if (inet_aton (SCM_ROCHARS (address), &soka) == 0)
  86     scm_syserror (s_inet_aton);
  87   return scm_ulong2num (ntohl (soka.s_addr));
  88 }
  89
  90
  91 SCM_PROC (s_inet_ntoa, "inet-ntoa", 1, 0, 0, scm_inet_ntoa);
  92
  93 SCM
  94 scm_inet_ntoa (inetid)
  95      SCM inetid;
  96 {
  97   struct in_addr addr;
  98   char *s;
  99   SCM answer;
 100   addr.s_addr = htonl (scm_num2ulong (inetid, (char *) SCM_ARG1, s_inet_ntoa));
 101   SCM_DEFER_INTS;
 102   s = inet_ntoa (addr);
 103   answer = scm_makfromstr (s, strlen (s), 0);
 104   SCM_ALLOW_INTS;
 105   return answer;
 106 }
 107
 108 SCM_PROC (s_inet_netof, "inet-netof", 1, 0, 0, scm_inet_netof);
 109
 110 SCM
 111 scm_inet_netof (address)
 112      SCM address;
 113 {
 114   struct in_addr addr;
 115   addr.s_addr = htonl (scm_num2ulong (address, (char *) SCM_ARG1, s_inet_netof));
 116   return scm_ulong2num ((unsigned long) inet_netof (addr));
 117 }
 118
 119 SCM_PROC (s_lnaof, "inet-lnaof", 1, 0, 0, scm_lnaof);
 120
 121 SCM
 122 scm_lnaof (address)
 123      SCM address;
 124 {
 125   struct in_addr addr;
 126   addr.s_addr = htonl (scm_num2ulong (address, (char *) SCM_ARG1, s_lnaof));
 127   return scm_ulong2num ((unsigned long) inet_lnaof (addr));
 128 }
 129
 130
 131 SCM_PROC (s_inet_makeaddr, "inet-makeaddr", 2, 0, 0, scm_inet_makeaddr);
 132
 133 SCM
 134 scm_inet_makeaddr (net, lna)
 135      SCM net;
 136      SCM lna;
 137 {
 138   struct in_addr addr;
 139   unsigned long netnum;
 140   unsigned long lnanum;
 141
 142   netnum = scm_num2ulong (net, (char *) SCM_ARG1, s_inet_makeaddr);
 143   lnanum = scm_num2ulong (lna, (char *) SCM_ARG2, s_inet_makeaddr);
 144   addr = inet_makeaddr (netnum, lnanum);
 145   return scm_ulong2num (ntohl (addr.s_addr));
 146 }
 147
 148
 149 /* !!! Doesn't take address format.
 150  * Assumes hostent stream isn't reused.
 151  */
 152
 153 SCM_PROC (s_gethost, "gethost", 0, 1, 0, scm_gethost);
 154
 155 SCM
 156 scm_gethost (name)
 157      SCM name;
 158 {
 159   SCM ans = scm_make_vector (SCM_MAKINUM (5), SCM_UNSPECIFIED, SCM_BOOL_F);
 160   SCM *ve = SCM_VELTS (ans);
 161   SCM lst = SCM_EOL;
 162   struct hostent *entry;
 163   struct in_addr inad;
 164   char **argv;
 165   int i = 0;
 166   if (SCM_UNBNDP (name))
 167     {
 168       SCM_DEFER_INTS;
 169 #ifdef HAVE_GETHOSTENT
 170       entry = gethostent ();
 171 #else
 172       entry = NULL;
 173 #endif
 174     }
 175   else if (SCM_NIMP (name) && SCM_ROSTRINGP (name))
 176     {
 177       SCM_COERCE_SUBSTR (name);
 178       SCM_DEFER_INTS;
 179       entry = gethostbyname (SCM_ROCHARS (name));
 180     }
 181   else
 182     {
 183       inad.s_addr = htonl (scm_num2ulong (name, (char *) SCM_ARG1, s_gethost));
 184       SCM_DEFER_INTS;
 185       entry = gethostbyaddr ((char *) &inad, sizeof (inad), AF_INET);
 186     }
 187   SCM_ALLOW_INTS;
 188   if (!entry)
 189     {
 190       char *errmsg;
 191       SCM args;
 192       if (SCM_UNBNDP (name))
 193         args = SCM_BOOL_F;
 194       else
 195         args = scm_listify (name, SCM_UNDEFINED);
 196       switch (h_errno)
 197         {
 198         case HOST_NOT_FOUND: errmsg = "host %s not found"; break;
 199         case TRY_AGAIN:      errmsg = "nameserver failure (try later)"; break;
 200         case NO_RECOVERY:    errmsg = "non-recoverable error"; break;
 201         case NO_DATA:        errmsg = "no address associated with %s"; break;
 202         default:             errmsg = "undefined error"; break;
 203         }
 204       scm_syserror_msg (s_gethost, errmsg, args, h_errno);
 205     }
 206   ve[0] = scm_makfromstr (entry->h_name, (scm_sizet) strlen (entry->h_name), 0);
 207   ve[1] = scm_makfromstrs (-1, entry->h_aliases);
 208   ve[2] = SCM_MAKINUM (entry->h_addrtype + 0L);
 209   ve[3] = SCM_MAKINUM (entry->h_length + 0L);
 210   if (sizeof (struct in_addr) != entry->h_length)
 211     {
 212       ve[4] = SCM_BOOL_F;
 213       return ans;
 214     }
 215   for (argv = entry->h_addr_list; argv[i]; i++);
 216   while (i--)
 217     {
 218       inad = *(struct in_addr *) argv[i];
 219       lst = scm_cons (scm_ulong2num (ntohl (inad.s_addr)), lst);
 220     }
 221   ve[4] = lst;
 222   return ans;
 223 }
 224
 225
 226 SCM_PROC (s_getnet, "getnet", 0, 1, 0, scm_getnet);
 227
 228 SCM
 229 scm_getnet (name)
 230      SCM name;
 231 {
 232   SCM ans;
 233   SCM *ve;
 234   struct netent *entry;
 235
 236   ans = scm_make_vector (SCM_MAKINUM (4), SCM_UNSPECIFIED, SCM_BOOL_F);
 237   ve = SCM_VELTS (ans);
 238   if (SCM_UNBNDP (name))
 239     {
 240       SCM_DEFER_INTS;
 241       entry = getnetent ();
 242     }
 243   else if (SCM_NIMP (name) && SCM_ROSTRINGP (name))
 244     {
 245       SCM_COERCE_SUBSTR (name);
 246       SCM_DEFER_INTS;
 247       entry = getnetbyname (SCM_ROCHARS (name));
 248     }
 249   else
 250     {
 251       unsigned long netnum;
 252       netnum = scm_num2ulong (name, (char *) SCM_ARG1, s_getnet);
 253       SCM_DEFER_INTS;
 254       entry = getnetbyaddr (netnum, AF_INET);
 255     }
 256   SCM_ALLOW_INTS;
 257   if (!entry)
 258     {
 259       if (SCM_UNBNDP (name))
 260         scm_syserror (s_getnet);
 261       else
 262         scm_syserror_msg (s_getnet, "no such network %s",
 263                           scm_listify (name, SCM_UNDEFINED), errno);
 264     }
 265   ve[0] = scm_makfromstr (entry->n_name, (scm_sizet) strlen (entry->n_name), 0);
 266   ve[1] = scm_makfromstrs (-1, entry->n_aliases);
 267   ve[2] = SCM_MAKINUM (entry->n_addrtype + 0L);
 268   ve[3] = scm_ulong2num (entry->n_net + 0L);
 269   return ans;
 270 }
 271
 272 SCM_PROC (s_getproto, "getproto", 0, 1, 0, scm_getproto);
 273
 274 SCM
 275 scm_getproto (name)
 276      SCM name;
 277 {
 278   SCM ans;
 279   SCM *ve;
 280   struct protoent *entry;
 281
 282   ans = scm_make_vector (SCM_MAKINUM (3), SCM_UNSPECIFIED, SCM_BOOL_F);
 283   ve = SCM_VELTS (ans);
 284   if (SCM_UNBNDP (name))
 285     {
 286       SCM_DEFER_INTS;
 287       entry = getprotoent ();
 288     }
 289   else if (SCM_NIMP (name) && SCM_ROSTRINGP (name))
 290     {
 291       SCM_COERCE_SUBSTR (name);
 292       SCM_DEFER_INTS;
 293       entry = getprotobyname (SCM_ROCHARS (name));
 294     }
 295   else
 296     {
 297       unsigned long protonum;
 298       protonum = scm_num2ulong (name, (char *) SCM_ARG1, s_getproto);
 299       SCM_DEFER_INTS;
 300       entry = getprotobynumber (protonum);
 301     }
 302   SCM_ALLOW_INTS;
 303   if (!entry)
 304     {
 305       if (SCM_UNBNDP (name))
 306         scm_syserror (s_getproto);
 307       else
 308         scm_syserror_msg (s_getproto, "no such protocol %s",
 309                           scm_listify (name, SCM_UNDEFINED), errno);
 310     }
 311   ve[0] = scm_makfromstr (entry->p_name, (scm_sizet) strlen (entry->p_name), 0);
 312   ve[1] = scm_makfromstrs (-1, entry->p_aliases);
 313   ve[2] = SCM_MAKINUM (entry->p_proto + 0L);
 314   return ans;
 315 }
 316
 317
 318 static SCM scm_return_entry SCM_P ((struct servent *entry));
 319
 320 static SCM
 321 scm_return_entry (entry)
 322      struct servent *entry;
 323 {
 324   SCM ans;
 325   SCM *ve;
 326
 327   ans = scm_make_vector (SCM_MAKINUM (4), SCM_UNSPECIFIED, SCM_BOOL_F);
 328   ve = SCM_VELTS (ans);
 329   ve[0] = scm_makfromstr (entry->s_name, (scm_sizet) strlen (entry->s_name), 0);
 330   ve[1] = scm_makfromstrs (-1, entry->s_aliases);
 331   ve[2] = SCM_MAKINUM (ntohs (entry->s_port) + 0L);
 332   ve[3] = scm_makfromstr (entry->s_proto, (scm_sizet) strlen (entry->s_proto), 0);
 333   SCM_ALLOW_INTS;
 334   return ans;
 335 }
 336
 337 SCM_PROC (s_getserv, "getserv", 0, 2, 0, scm_getserv);
 338
 339 SCM
 340 scm_getserv (name, proto)
 341      SCM name;
 342      SCM proto;
 343 {
 344   struct servent *entry;
 345   if (SCM_UNBNDP (name))
 346     {
 347       SCM_DEFER_INTS;
 348       entry = getservent ();
 349       if (!entry)
 350         scm_syserror (s_getserv);
 351       SCM_ALLOW_INTS;
 352       return scm_return_entry (entry);
 353     }
 354   SCM_ASSERT (SCM_NIMP (proto) && SCM_ROSTRINGP (proto), proto, SCM_ARG2, s_getserv);
 355   SCM_COERCE_SUBSTR (proto);
 356   if (SCM_NIMP (name) && SCM_ROSTRINGP (name))
 357     {
 358       SCM_COERCE_SUBSTR (name);
 359       SCM_DEFER_INTS;
 360       entry = getservbyname (SCM_ROCHARS (name), SCM_ROCHARS (proto));
 361     }
 362   else
 363     {
 364       SCM_ASSERT (SCM_INUMP (name), name, SCM_ARG1, s_getserv);
 365       SCM_DEFER_INTS;
 366       entry = getservbyport (htons (SCM_INUM (name)), SCM_ROCHARS (proto));
 367     }
 368   if (!entry)
 369     scm_syserror_msg (s_getserv, "no such service %s",
 370                       scm_listify (name, SCM_UNDEFINED), errno);
 371   SCM_ALLOW_INTS;
 372   return scm_return_entry (entry);
 373 }
 374
 375 SCM_PROC (s_sethost, "sethost", 0, 1, 0, scm_sethost);
 376
 377 SCM
 378 scm_sethost (arg)
 379      SCM arg;
 380 {
 381   if (SCM_UNBNDP (arg))
 382     endhostent ();
 383   else
 384     sethostent (SCM_NFALSEP (arg));
 385   return SCM_UNSPECIFIED;
 386 }
 387
 388 SCM_PROC (s_setnet, "setnet", 0, 1, 0, scm_setnet);
 389
 390 SCM
 391 scm_setnet (arg)
 392      SCM arg;
 393 {
 394   if (SCM_UNBNDP (arg))
 395     endnetent ();
 396   else
 397     setnetent (SCM_NFALSEP (arg));
 398   return SCM_UNSPECIFIED;
 399 }
 400
 401 SCM_PROC (s_setproto, "setproto", 0, 1, 0, scm_setproto);
 402
 403 SCM
 404 scm_setproto (arg)
 405      SCM arg;
 406 {
 407   if (SCM_UNBNDP (arg))
 408     endprotoent ();
 409   else
 410     setprotoent (SCM_NFALSEP (arg));
 411   return SCM_UNSPECIFIED;
 412 }
 413
 414 SCM_PROC (s_setserv, "setserv", 0, 1, 0, scm_setserv);
 415
 416 SCM
 417 scm_setserv (arg)
 418      SCM arg;
 419 {
 420   if (SCM_UNBNDP (arg))
 421     endservent ();
 422   else
 423     setservent (SCM_NFALSEP (arg));
 424   return SCM_UNSPECIFIED;
 425 }
 426
 427
 428 void
 429 scm_init_net_db ()
 430 {
 431 #ifdef INADDR_ANY
 432   scm_sysintern ("INADDR_ANY", scm_ulong2num (INADDR_ANY));
 433 #endif
 434 #ifdef INADDR_BROADCAST
 435   scm_sysintern ("INADDR_BROADCAST", scm_ulong2num (INADDR_BROADCAST));
 436 #endif
 437 #ifdef INADDR_NONE
 438   scm_sysintern ("INADDR_NONE", scm_ulong2num (INADDR_NONE));
 439 #endif
 440 #ifdef INADDR_LOOPBACK
 441   scm_sysintern ("INADDR_LOOPBACK", scm_ulong2num (INADDR_LOOPBACK));
 442 #endif
 443
 444   scm_add_feature ("net-db");
 445 #include "net_db.x"
 446 }
 447
 448