libguile/socket.c

   1 /* "socket.c" internet socket support for client/server in SCM
   2     Copyright (C) 1994 Aubrey Jaffer.
   3     Thanks to Hallvard.Tretteberg@si.sintef.no
   4     who credits NCSA httpd software by Rob McCool 3/21/93.
   5     Rewritten by Gary Houston to be a closer interface to the C
   6     socket library.
   7     */
   8 \f
   9
  10 #include <stdio.h>
  11 #include <string.h>
  12 #include "_scm.h"
  13 #include <sys/types.h>
  14 #include <sys/socket.h>
  15 #include <sys/un.h>
  16 #include <netinet/in.h>
  17 #include <netdb.h>
  18 #include <arpa/inet.h>
  19
  20 \f
  21
  22 #ifndef STDC_HEADERS
  23 int close P ((int fd));
  24 #endif /* STDC_HEADERS */
  25
  26 SCM_PROC (s_sys_inet_aton, "%inet-aton", 1, 0, 0, scm_sys_inet_aton);
  27 #ifdef __STDC__
  28 SCM
  29 scm_sys_inet_aton (SCM address)
  30 #else
  31 SCM
  32 scm_sys_inet_aton (address)
  33      SCM address;
  34 #endif
  35 {
  36   struct in_addr soka;
  37   int rv;
  38   SCM_ASSERT (SCM_NIMP (address) && SCM_ROSTRINGP (address), address, SCM_ARG1, s_sys_inet_aton);
  39   if (SCM_SUBSTRP (address))
  40     address = scm_makfromstr (SCM_ROCHARS (address), SCM_ROLENGTH (address), 0);
  41   rv = inet_aton (SCM_ROCHARS (address), &soka);
  42   return rv ? scm_ulong2num (ntohl (soka.s_addr)) : SCM_BOOL_F;
  43 }
  44
  45
  46 SCM_PROC (s_inet_ntoa, "inet-ntoa", 1, 0, 0, scm_inet_ntoa);
  47 #ifdef __STDC__
  48 SCM
  49 scm_inet_ntoa (SCM inetid)
  50 #else
  51 SCM
  52 scm_inet_ntoa (inetid)
  53      SCM inetid;
  54 #endif
  55 {
  56   struct in_addr addr;
  57   char *s;
  58   SCM answer;
  59   addr.s_addr = htonl (scm_num2ulong (inetid, (char *) SCM_ARG1, s_inet_ntoa));
  60   SCM_DEFER_INTS;
  61   s = inet_ntoa (addr);
  62   answer = scm_makfromstr (s, strlen (s), 0);
  63   SCM_ALLOW_INTS;
  64   return answer;
  65 }
  66
  67 SCM_PROC (s_inet_netof, "inet-netof", 1, 0, 0, scm_inet_netof);
  68 #ifdef __STDC__
  69 SCM
  70 scm_inet_netof (SCM address)
  71 #else
  72 SCM
  73 scm_inet_netof (address)
  74      SCM address;
  75 #endif
  76 {
  77   struct in_addr addr;
  78   addr.s_addr = htonl (scm_num2ulong (address, (char *) SCM_ARG1, s_inet_netof));
  79   return scm_ulong2num ((unsigned long) inet_netof (addr));
  80 }
  81
  82 SCM_PROC (s_lnaof, "lnaof", 1, 0, 0, scm_lnaof);
  83 #ifdef __STDC__
  84 SCM
  85 scm_lnaof (SCM address)
  86 #else
  87 SCM
  88 scm_lnaof (address)
  89      SCM address;
  90 #endif
  91 {
  92   struct in_addr addr;
  93   addr.s_addr = htonl (scm_num2ulong (address, (char *) SCM_ARG1, s_lnaof));
  94   return scm_ulong2num ((unsigned long) inet_lnaof (addr));
  95 }
  96
  97
  98 SCM_PROC (s_inet_makeaddr, "inet-makeaddr", 2, 0, 0, scm_inet_makeaddr);
  99 #ifdef __STDC__
 100 SCM
 101 scm_inet_makeaddr (SCM net, SCM lna)
 102 #else
 103 SCM
 104 scm_inet_makeaddr (net, lna)
 105      SCM net;
 106      SCM lna;
 107 #endif
 108 {
 109   struct in_addr addr;
 110   unsigned long netnum;
 111   unsigned long lnanum;
 112
 113   netnum = scm_num2ulong (net, (char *) SCM_ARG1, s_inet_makeaddr);
 114   lnanum = scm_num2ulong (lna, (char *) SCM_ARG2, s_inet_makeaddr);
 115   addr = inet_makeaddr (netnum, lnanum);
 116   return scm_ulong2num (ntohl (addr.s_addr));
 117 }
 118
 119
 120 /* !!! Doesn't take address format.
 121  * Assumes hostent stream isn't reused.
 122  */
 123
 124 SCM_PROC (s_sys_gethost, "%gethost", 0, 1, 0, scm_sys_gethost);
 125 #ifdef __STDC__
 126 SCM
 127 scm_sys_gethost (SCM name)
 128 #else
 129 SCM
 130 scm_sys_gethost (name)
 131      SCM name;
 132 #endif
 133 {
 134   SCM ans = scm_make_vector (SCM_MAKINUM (5), SCM_UNSPECIFIED, SCM_BOOL_F);
 135   SCM *ve = SCM_VELTS (ans);
 136   SCM lst = SCM_EOL;
 137   struct hostent *entry;
 138   struct in_addr inad;
 139   char **argv;
 140   int i = 0;
 141 #ifdef HAVE_GETHOSTENT
 142   if (SCM_UNBNDP (name))
 143     {
 144       SCM_DEFER_INTS;
 145       entry = gethostent ();
 146     }
 147   else
 148 #endif
 149   if (SCM_NIMP (name) && SCM_STRINGP (name))
 150     {
 151       SCM_DEFER_INTS;
 152       entry = gethostbyname (SCM_CHARS (name));
 153     }
 154   else
 155     {
 156       inad.s_addr = htonl (scm_num2ulong (name, (char *) SCM_ARG1, s_sys_gethost));
 157       SCM_DEFER_INTS;
 158       entry = gethostbyaddr ((char *) &inad, sizeof (inad), AF_INET);
 159     }
 160   SCM_ALLOW_INTS;
 161   if (!entry)
 162     return SCM_BOOL_F;
 163   ve[0] = scm_makfromstr (entry->h_name, (scm_sizet) strlen (entry->h_name), 0);
 164   ve[1] = scm_makfromstrs (-1, entry->h_aliases);
 165   ve[2] = SCM_MAKINUM (entry->h_addrtype + 0L);
 166   ve[3] = SCM_MAKINUM (entry->h_length + 0L);
 167   if (sizeof (struct in_addr) != entry->h_length)
 168     {
 169       ve[4] = SCM_BOOL_F;
 170       return ans;
 171     }
 172   for (argv = entry->h_addr_list; argv[i]; i++);
 173   while (i--)
 174     {
 175       inad = *(struct in_addr *) argv[i];
 176       lst = scm_cons (scm_ulong2num (ntohl (inad.s_addr)), lst);
 177     }
 178   ve[4] = lst;
 179   return ans;
 180 }
 181
 182
 183 SCM_PROC (s_sys_getnet, "%getnet", 0, 1, 0, scm_sys_getnet);
 184 #ifdef __STDC__
 185 SCM
 186 scm_sys_getnet (SCM name)
 187 #else
 188 SCM
 189 scm_sys_getnet (name)
 190      SCM name;
 191 #endif
 192 {
 193   SCM ans;
 194   SCM *ve;
 195   struct netent *entry;
 196
 197   ans = scm_make_vector (SCM_MAKINUM (4), SCM_UNSPECIFIED, SCM_BOOL_F);
 198   ve = SCM_VELTS (ans);
 199   if (SCM_UNBNDP (name))
 200     {
 201       SCM_DEFER_INTS;
 202       entry = getnetent ();
 203     }
 204   else if (SCM_NIMP (name) && SCM_STRINGP (name))
 205     {
 206       SCM_DEFER_INTS;
 207       entry = getnetbyname (SCM_CHARS (name));
 208     }
 209   else
 210     {
 211       unsigned long netnum;
 212       netnum = scm_num2ulong (name, (char *) SCM_ARG1, s_sys_getnet);
 213       SCM_DEFER_INTS;
 214       entry = getnetbyaddr (netnum, AF_INET);
 215     }
 216   SCM_ALLOW_INTS;
 217   if (!entry)
 218     return SCM_BOOL_F;
 219   ve[0] = scm_makfromstr (entry->n_name, (scm_sizet) strlen (entry->n_name), 0);
 220   ve[1] = scm_makfromstrs (-1, entry->n_aliases);
 221   ve[2] = SCM_MAKINUM (entry->n_addrtype + 0L);
 222   ve[3] = scm_ulong2num (entry->n_net + 0L);
 223   return ans;
 224 }
 225
 226 SCM_PROC (s_sys_getproto, "%getproto", 0, 1, 0, scm_sys_getproto);
 227 #ifdef __STDC__
 228 SCM
 229 scm_sys_getproto (SCM name)
 230 #else
 231 SCM
 232 scm_sys_getproto (name)
 233      SCM name;
 234 #endif
 235 {
 236   SCM ans;
 237   SCM *ve;
 238   struct protoent *entry;
 239
 240   ans = scm_make_vector (SCM_MAKINUM (3), SCM_UNSPECIFIED, SCM_BOOL_F);
 241   ve = SCM_VELTS (ans);
 242   if (SCM_UNBNDP (name))
 243     {
 244       SCM_DEFER_INTS;
 245       entry = getprotoent ();
 246     }
 247   else if (SCM_NIMP (name) && SCM_STRINGP (name))
 248     {
 249       SCM_DEFER_INTS;
 250       entry = getprotobyname (SCM_CHARS (name));
 251     }
 252   else
 253     {
 254       unsigned long protonum;
 255       protonum = scm_num2ulong (name, (char *) SCM_ARG1, s_sys_getproto);
 256       SCM_DEFER_INTS;
 257       entry = getprotobynumber (protonum);
 258     }
 259   SCM_ALLOW_INTS;
 260   if (!entry)
 261     return SCM_BOOL_F;
 262   ve[0] = scm_makfromstr (entry->p_name, (scm_sizet) strlen (entry->p_name), 0);
 263   ve[1] = scm_makfromstrs (-1, entry->p_aliases);
 264   ve[2] = SCM_MAKINUM (entry->p_proto + 0L);
 265   return ans;
 266 }
 267
 268 #ifdef __STDC__
 269 static SCM
 270 scm_return_entry (struct servent *entry)
 271 #else
 272 static SCM
 273 scm_return_entry (entry)
 274      struct servent *entry;
 275 #endif
 276 {
 277   SCM ans;
 278   SCM *ve;
 279
 280   ans = scm_make_vector (SCM_MAKINUM (4), SCM_UNSPECIFIED, SCM_BOOL_F);
 281   ve = SCM_VELTS (ans);
 282   if (!entry)
 283     {
 284       SCM_ALLOW_INTS;
 285       return SCM_BOOL_F;
 286     }
 287   ve[0] = scm_makfromstr (entry->s_name, (scm_sizet) strlen (entry->s_name), 0);
 288   ve[1] = scm_makfromstrs (-1, entry->s_aliases);
 289   ve[2] = SCM_MAKINUM (ntohs (entry->s_port) + 0L);
 290   ve[3] = scm_makfromstr (entry->s_proto, (scm_sizet) strlen (entry->s_proto), 0);
 291   SCM_ALLOW_INTS;
 292   return ans;
 293 }
 294
 295 SCM_PROC (s_sys_getserv, "%getserv", 0, 2, 0, scm_sys_getserv);
 296 #ifdef __STDC__
 297 SCM
 298 scm_sys_getserv (SCM name, SCM proto)
 299 #else
 300 SCM
 301 scm_sys_getserv (name, proto)
 302      SCM name;
 303      SCM proto;
 304 #endif
 305 {
 306   struct servent *entry;
 307   if (SCM_UNBNDP (name))
 308     {
 309       SCM_DEFER_INTS;
 310       entry = getservent ();
 311       return scm_return_entry (entry);
 312     }
 313   SCM_ASSERT (SCM_NIMP (proto) && SCM_STRINGP (proto), proto, SCM_ARG2, s_sys_getserv);
 314   if (SCM_NIMP (name) && SCM_STRINGP (name))
 315     {
 316       SCM_DEFER_INTS;
 317       entry = getservbyname (SCM_CHARS (name), SCM_CHARS (proto));
 318     }
 319   else
 320     {
 321       SCM_ASSERT (SCM_INUMP (name), name, SCM_ARG1, s_sys_getserv);
 322       SCM_DEFER_INTS;
 323       entry = getservbyport (SCM_INUM (name), SCM_CHARS (proto));
 324     }
 325   return scm_return_entry (entry);
 326 }
 327
 328 SCM_PROC (s_sethost, "sethost", 0, 1, 0, scm_sethost);
 329 #ifdef __STDC__
 330 SCM
 331 scm_sethost (SCM arg)
 332 #else
 333 SCM
 334 scm_sethost (arg)
 335      SCM arg;
 336 #endif
 337 {
 338   if (SCM_UNBNDP (arg))
 339     endhostent ();
 340   else
 341     sethostent (SCM_NFALSEP (arg));
 342   return SCM_UNSPECIFIED;
 343 }
 344
 345 SCM_PROC (s_setnet, "setnet", 0, 1, 0, scm_setnet);
 346 #ifdef __STDC__
 347 SCM
 348 scm_setnet (SCM arg)
 349 #else
 350 SCM
 351 scm_setnet (arg)
 352      SCM arg;
 353 #endif
 354 {
 355   if (SCM_UNBNDP (arg))
 356     endnetent ();
 357   else
 358     setnetent (SCM_NFALSEP (arg));
 359   return SCM_UNSPECIFIED;
 360 }
 361
 362 SCM_PROC (s_setproto, "setproto", 0, 1, 0, scm_setproto);
 363 #ifdef __STDC__
 364 SCM
 365 scm_setproto (SCM arg)
 366 #else
 367 SCM
 368 scm_setproto (arg)
 369      SCM arg;
 370 #endif
 371 {
 372   if (SCM_UNBNDP (arg))
 373     endprotoent ();
 374   else
 375     setprotoent (SCM_NFALSEP (arg));
 376   return SCM_UNSPECIFIED;
 377 }
 378
 379 SCM_PROC (s_setserv, "setserv", 0, 1, 0, scm_setserv);
 380 #ifdef __STDC__
 381 SCM
 382 scm_setserv (SCM arg)
 383 #else
 384 SCM
 385 scm_setserv (arg)
 386      SCM arg;
 387 #endif
 388 {
 389   if (SCM_UNBNDP (arg))
 390     endservent ();
 391   else
 392     setservent (SCM_NFALSEP (arg));
 393   return SCM_UNSPECIFIED;
 394 }
 395
 396 #ifdef __STDC__
 397 void
 398 scm_init_socket (void)
 399 #else
 400 void
 401 scm_init_socket ()
 402 #endif
 403 {
 404   scm_add_feature ("socket");
 405 #include "socket.x"
 406 }
 407
 408