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       entry = gethostent ();
 170     }
 171   else if (SCM_NIMP (name) && SCM_ROSTRINGP (name))
 172     {
 173       SCM_DEFER_INTS;
 174       entry = gethostbyname (SCM_ROCHARS (name));
 175     }
 176   else
 177     {
 178       inad.s_addr = htonl (scm_num2ulong (name, (char *) SCM_ARG1, s_gethost));
 179       SCM_DEFER_INTS;
 180       entry = gethostbyaddr ((char *) &inad, sizeof (inad), AF_INET);
 181     }
 182   SCM_ALLOW_INTS;
 183   if (!entry)
 184     scm_syserror (s_gethost);
 185   ve[0] = scm_makfromstr (entry->h_name, (scm_sizet) strlen (entry->h_name), 0);
 186   ve[1] = scm_makfromstrs (-1, entry->h_aliases);
 187   ve[2] = SCM_MAKINUM (entry->h_addrtype + 0L);
 188   ve[3] = SCM_MAKINUM (entry->h_length + 0L);
 189   if (sizeof (struct in_addr) != entry->h_length)
 190     {
 191       ve[4] = SCM_BOOL_F;
 192       return ans;
 193     }
 194   for (argv = entry->h_addr_list; argv[i]; i++);
 195   while (i--)
 196     {
 197       inad = *(struct in_addr *) argv[i];
 198       lst = scm_cons (scm_ulong2num (ntohl (inad.s_addr)), lst);
 199     }
 200   ve[4] = lst;
 201   return ans;
 202 }
 203
 204
 205 SCM_PROC (s_getnet, "getnet", 0, 1, 0, scm_getnet);
 206
 207 SCM
 208 scm_getnet (name)
 209      SCM name;
 210 {
 211   SCM ans;
 212   SCM *ve;
 213   struct netent *entry;
 214
 215   ans = scm_make_vector (SCM_MAKINUM (4), SCM_UNSPECIFIED, SCM_BOOL_F);
 216   ve = SCM_VELTS (ans);
 217   if (SCM_UNBNDP (name))
 218     {
 219       SCM_DEFER_INTS;
 220       entry = getnetent ();
 221     }
 222   else if (SCM_NIMP (name) && SCM_ROSTRINGP (name))
 223     {
 224       SCM_DEFER_INTS;
 225       entry = getnetbyname (SCM_ROCHARS (name));
 226     }
 227   else
 228     {
 229       unsigned long netnum;
 230       netnum = scm_num2ulong (name, (char *) SCM_ARG1, s_getnet);
 231       SCM_DEFER_INTS;
 232       entry = getnetbyaddr (netnum, AF_INET);
 233     }
 234   SCM_ALLOW_INTS;
 235   if (!entry)
 236     scm_syserror (s_getnet);
 237   ve[0] = scm_makfromstr (entry->n_name, (scm_sizet) strlen (entry->n_name), 0);
 238   ve[1] = scm_makfromstrs (-1, entry->n_aliases);
 239   ve[2] = SCM_MAKINUM (entry->n_addrtype + 0L);
 240   ve[3] = scm_ulong2num (entry->n_net + 0L);
 241   return ans;
 242 }
 243
 244 SCM_PROC (s_getproto, "getproto", 0, 1, 0, scm_getproto);
 245
 246 SCM
 247 scm_getproto (name)
 248      SCM name;
 249 {
 250   SCM ans;
 251   SCM *ve;
 252   struct protoent *entry;
 253
 254   ans = scm_make_vector (SCM_MAKINUM (3), SCM_UNSPECIFIED, SCM_BOOL_F);
 255   ve = SCM_VELTS (ans);
 256   if (SCM_UNBNDP (name))
 257     {
 258       SCM_DEFER_INTS;
 259       entry = getprotoent ();
 260     }
 261   else if (SCM_NIMP (name) && SCM_ROSTRINGP (name))
 262     {
 263       SCM_DEFER_INTS;
 264       entry = getprotobyname (SCM_ROCHARS (name));
 265     }
 266   else
 267     {
 268       unsigned long protonum;
 269       protonum = scm_num2ulong (name, (char *) SCM_ARG1, s_getproto);
 270       SCM_DEFER_INTS;
 271       entry = getprotobynumber (protonum);
 272     }
 273   SCM_ALLOW_INTS;
 274   if (!entry)
 275     scm_syserror (s_getproto);
 276   ve[0] = scm_makfromstr (entry->p_name, (scm_sizet) strlen (entry->p_name), 0);
 277   ve[1] = scm_makfromstrs (-1, entry->p_aliases);
 278   ve[2] = SCM_MAKINUM (entry->p_proto + 0L);
 279   return ans;
 280 }
 281
 282
 283 static SCM scm_return_entry SCM_P ((struct servent *entry));
 284
 285 static SCM
 286 scm_return_entry (entry)
 287      struct servent *entry;
 288 {
 289   SCM ans;
 290   SCM *ve;
 291
 292   ans = scm_make_vector (SCM_MAKINUM (4), SCM_UNSPECIFIED, SCM_BOOL_F);
 293   ve = SCM_VELTS (ans);
 294   ve[0] = scm_makfromstr (entry->s_name, (scm_sizet) strlen (entry->s_name), 0);
 295   ve[1] = scm_makfromstrs (-1, entry->s_aliases);
 296   ve[2] = SCM_MAKINUM (ntohs (entry->s_port) + 0L);
 297   ve[3] = scm_makfromstr (entry->s_proto, (scm_sizet) strlen (entry->s_proto), 0);
 298   SCM_ALLOW_INTS;
 299   return ans;
 300 }
 301
 302 SCM_PROC (s_getserv, "getserv", 0, 2, 0, scm_getserv);
 303
 304 SCM
 305 scm_getserv (name, proto)
 306      SCM name;
 307      SCM proto;
 308 {
 309   struct servent *entry;
 310   if (SCM_UNBNDP (name))
 311     {
 312       SCM_DEFER_INTS;
 313       entry = getservent ();
 314       if (!entry)
 315         scm_syserror (s_getserv);
 316       SCM_ALLOW_INTS;
 317       return scm_return_entry (entry);
 318     }
 319   SCM_ASSERT (SCM_NIMP (proto) && SCM_ROSTRINGP (proto), proto, SCM_ARG2, s_getserv);
 320   if (SCM_NIMP (name) && SCM_ROSTRINGP (name))
 321     {
 322       SCM_DEFER_INTS;
 323       entry = getservbyname (SCM_ROCHARS (name), SCM_ROCHARS (proto));
 324     }
 325   else
 326     {
 327       SCM_ASSERT (SCM_INUMP (name), name, SCM_ARG1, s_getserv);
 328       SCM_DEFER_INTS;
 329       entry = getservbyport (htons (SCM_INUM (name)), SCM_ROCHARS (proto));
 330     }
 331   if (!entry)
 332     scm_syserror (s_getserv);
 333   SCM_ALLOW_INTS;
 334   return scm_return_entry (entry);
 335 }
 336
 337 SCM_PROC (s_sethost, "sethost", 0, 1, 0, scm_sethost);
 338
 339 SCM
 340 scm_sethost (arg)
 341      SCM arg;
 342 {
 343   if (SCM_UNBNDP (arg))
 344     endhostent ();
 345   else
 346     sethostent (SCM_NFALSEP (arg));
 347   return SCM_UNSPECIFIED;
 348 }
 349
 350 SCM_PROC (s_setnet, "setnet", 0, 1, 0, scm_setnet);
 351
 352 SCM
 353 scm_setnet (arg)
 354      SCM arg;
 355 {
 356   if (SCM_UNBNDP (arg))
 357     endnetent ();
 358   else
 359     setnetent (SCM_NFALSEP (arg));
 360   return SCM_UNSPECIFIED;
 361 }
 362
 363 SCM_PROC (s_setproto, "setproto", 0, 1, 0, scm_setproto);
 364
 365 SCM
 366 scm_setproto (arg)
 367      SCM arg;
 368 {
 369   if (SCM_UNBNDP (arg))
 370     endprotoent ();
 371   else
 372     setprotoent (SCM_NFALSEP (arg));
 373   return SCM_UNSPECIFIED;
 374 }
 375
 376 SCM_PROC (s_setserv, "setserv", 0, 1, 0, scm_setserv);
 377
 378 SCM
 379 scm_setserv (arg)
 380      SCM arg;
 381 {
 382   if (SCM_UNBNDP (arg))
 383     endservent ();
 384   else
 385     setservent (SCM_NFALSEP (arg));
 386   return SCM_UNSPECIFIED;
 387 }
 388
 389
 390 void
 391 scm_init_net_db ()
 392 {
 393 #ifdef INADDR_ANY
 394   scm_sysintern ("INADDR_ANY", scm_ulong2num (INADDR_ANY));
 395 #endif
 396 #ifdef INADDR_BROADCAST
 397   scm_sysintern ("INADDR_BROADCAST", scm_ulong2num (INADDR_BROADCAST));
 398 #endif
 399 #ifdef INADDR_NONE
 400   scm_sysintern ("INADDR_NONE", scm_ulong2num (INADDR_NONE));
 401 #endif
 402 #ifdef INADDR_LOOPBACK
 403   scm_sysintern ("INADDR_LOOPBACK", scm_ulong2num (INADDR_LOOPBACK));
 404 #endif
 405
 406   scm_add_feature ("net-db");
 407 #include "net_db.x"
 408 }
 409
 410