summaryrefslogtreecommitdiff
path: root/libguile/socket.c
diff options
context:
space:
mode:
Diffstat (limited to 'libguile/socket.c')
-rw-r--r--libguile/socket.c408
1 files changed, 408 insertions, 0 deletions
diff --git a/libguile/socket.c b/libguile/socket.c
new file mode 100644
index 000000000..944609714
--- /dev/null
+++ b/libguile/socket.c
@@ -0,0 +1,408 @@
+/* "socket.c" internet socket support for client/server in SCM
+ Copyright (C) 1994 Aubrey Jaffer.
+ Thanks to Hallvard.Tretteberg@si.sintef.no
+ who credits NCSA httpd software by Rob McCool 3/21/93.
+ Rewritten by Gary Houston to be a closer interface to the C
+ socket library.
+ */
+
+
+#include <stdio.h>
+#include <string.h>
+#include "_scm.h"
+#include <sys/types.h>
+#include <sys/socket.h>
+#include <sys/un.h>
+#include <netinet/in.h>
+#include <netdb.h>
+#include <arpa/inet.h>
+
+
+
+#ifndef STDC_HEADERS
+int close P ((int fd));
+#endif /* STDC_HEADERS */
+
+SCM_PROC (s_sys_inet_aton, "%inet-aton", 1, 0, 0, scm_sys_inet_aton);
+#ifdef __STDC__
+SCM
+scm_sys_inet_aton (SCM address)
+#else
+SCM
+scm_sys_inet_aton (address)
+ SCM address;
+#endif
+{
+ struct in_addr soka;
+ int rv;
+ SCM_ASSERT (SCM_NIMP (address) && SCM_ROSTRINGP (address), address, SCM_ARG1, s_sys_inet_aton);
+ if (SCM_SUBSTRP (address))
+ address = scm_makfromstr (SCM_ROCHARS (address), SCM_ROLENGTH (address), 0);
+ rv = inet_aton (SCM_ROCHARS (address), &soka);
+ return rv ? scm_ulong2num (ntohl (soka.s_addr)) : SCM_BOOL_F;
+}
+
+
+SCM_PROC (s_inet_ntoa, "inet-ntoa", 1, 0, 0, scm_inet_ntoa);
+#ifdef __STDC__
+SCM
+scm_inet_ntoa (SCM inetid)
+#else
+SCM
+scm_inet_ntoa (inetid)
+ SCM inetid;
+#endif
+{
+ struct in_addr addr;
+ char *s;
+ SCM answer;
+ addr.s_addr = htonl (scm_num2ulong (inetid, (char *) SCM_ARG1, s_inet_ntoa));
+ SCM_DEFER_INTS;
+ s = inet_ntoa (addr);
+ answer = scm_makfromstr (s, strlen (s), 0);
+ SCM_ALLOW_INTS;
+ return answer;
+}
+
+SCM_PROC (s_inet_netof, "inet-netof", 1, 0, 0, scm_inet_netof);
+#ifdef __STDC__
+SCM
+scm_inet_netof (SCM address)
+#else
+SCM
+scm_inet_netof (address)
+ SCM address;
+#endif
+{
+ struct in_addr addr;
+ addr.s_addr = htonl (scm_num2ulong (address, (char *) SCM_ARG1, s_inet_netof));
+ return scm_ulong2num ((unsigned long) inet_netof (addr));
+}
+
+SCM_PROC (s_lnaof, "lnaof", 1, 0, 0, scm_lnaof);
+#ifdef __STDC__
+SCM
+scm_lnaof (SCM address)
+#else
+SCM
+scm_lnaof (address)
+ SCM address;
+#endif
+{
+ struct in_addr addr;
+ addr.s_addr = htonl (scm_num2ulong (address, (char *) SCM_ARG1, s_lnaof));
+ return scm_ulong2num ((unsigned long) inet_lnaof (addr));
+}
+
+
+SCM_PROC (s_inet_makeaddr, "inet-makeaddr", 2, 0, 0, scm_inet_makeaddr);
+#ifdef __STDC__
+SCM
+scm_inet_makeaddr (SCM net, SCM lna)
+#else
+SCM
+scm_inet_makeaddr (net, lna)
+ SCM net;
+ SCM lna;
+#endif
+{
+ struct in_addr addr;
+ unsigned long netnum;
+ unsigned long lnanum;
+
+ netnum = scm_num2ulong (net, (char *) SCM_ARG1, s_inet_makeaddr);
+ lnanum = scm_num2ulong (lna, (char *) SCM_ARG2, s_inet_makeaddr);
+ addr = inet_makeaddr (netnum, lnanum);
+ return scm_ulong2num (ntohl (addr.s_addr));
+}
+
+
+/* !!! Doesn't take address format.
+ * Assumes hostent stream isn't reused.
+ */
+
+SCM_PROC (s_sys_gethost, "%gethost", 0, 1, 0, scm_sys_gethost);
+#ifdef __STDC__
+SCM
+scm_sys_gethost (SCM name)
+#else
+SCM
+scm_sys_gethost (name)
+ SCM name;
+#endif
+{
+ SCM ans = scm_make_vector (SCM_MAKINUM (5), SCM_UNSPECIFIED, SCM_BOOL_F);
+ SCM *ve = SCM_VELTS (ans);
+ SCM lst = SCM_EOL;
+ struct hostent *entry;
+ struct in_addr inad;
+ char **argv;
+ int i = 0;
+#ifdef HAVE_GETHOSTENT
+ if (SCM_UNBNDP (name))
+ {
+ SCM_DEFER_INTS;
+ entry = gethostent ();
+ }
+ else
+#endif
+ if (SCM_NIMP (name) && SCM_STRINGP (name))
+ {
+ SCM_DEFER_INTS;
+ entry = gethostbyname (SCM_CHARS (name));
+ }
+ else
+ {
+ inad.s_addr = htonl (scm_num2ulong (name, (char *) SCM_ARG1, s_sys_gethost));
+ SCM_DEFER_INTS;
+ entry = gethostbyaddr ((char *) &inad, sizeof (inad), AF_INET);
+ }
+ SCM_ALLOW_INTS;
+ if (!entry)
+ return SCM_BOOL_F;
+ ve[0] = scm_makfromstr (entry->h_name, (scm_sizet) strlen (entry->h_name), 0);
+ ve[1] = scm_makfromstrs (-1, entry->h_aliases);
+ ve[2] = SCM_MAKINUM (entry->h_addrtype + 0L);
+ ve[3] = SCM_MAKINUM (entry->h_length + 0L);
+ if (sizeof (struct in_addr) != entry->h_length)
+ {
+ ve[4] = SCM_BOOL_F;
+ return ans;
+ }
+ for (argv = entry->h_addr_list; argv[i]; i++);
+ while (i--)
+ {
+ inad = *(struct in_addr *) argv[i];
+ lst = scm_cons (scm_ulong2num (ntohl (inad.s_addr)), lst);
+ }
+ ve[4] = lst;
+ return ans;
+}
+
+
+SCM_PROC (s_sys_getnet, "%getnet", 0, 1, 0, scm_sys_getnet);
+#ifdef __STDC__
+SCM
+scm_sys_getnet (SCM name)
+#else
+SCM
+scm_sys_getnet (name)
+ SCM name;
+#endif
+{
+ SCM ans;
+ SCM *ve;
+ struct netent *entry;
+
+ ans = scm_make_vector (SCM_MAKINUM (4), SCM_UNSPECIFIED, SCM_BOOL_F);
+ ve = SCM_VELTS (ans);
+ if (SCM_UNBNDP (name))
+ {
+ SCM_DEFER_INTS;
+ entry = getnetent ();
+ }
+ else if (SCM_NIMP (name) && SCM_STRINGP (name))
+ {
+ SCM_DEFER_INTS;
+ entry = getnetbyname (SCM_CHARS (name));
+ }
+ else
+ {
+ unsigned long netnum;
+ netnum = scm_num2ulong (name, (char *) SCM_ARG1, s_sys_getnet);
+ SCM_DEFER_INTS;
+ entry = getnetbyaddr (netnum, AF_INET);
+ }
+ SCM_ALLOW_INTS;
+ if (!entry)
+ return SCM_BOOL_F;
+ ve[0] = scm_makfromstr (entry->n_name, (scm_sizet) strlen (entry->n_name), 0);
+ ve[1] = scm_makfromstrs (-1, entry->n_aliases);
+ ve[2] = SCM_MAKINUM (entry->n_addrtype + 0L);
+ ve[3] = scm_ulong2num (entry->n_net + 0L);
+ return ans;
+}
+
+SCM_PROC (s_sys_getproto, "%getproto", 0, 1, 0, scm_sys_getproto);
+#ifdef __STDC__
+SCM
+scm_sys_getproto (SCM name)
+#else
+SCM
+scm_sys_getproto (name)
+ SCM name;
+#endif
+{
+ SCM ans;
+ SCM *ve;
+ struct protoent *entry;
+
+ ans = scm_make_vector (SCM_MAKINUM (3), SCM_UNSPECIFIED, SCM_BOOL_F);
+ ve = SCM_VELTS (ans);
+ if (SCM_UNBNDP (name))
+ {
+ SCM_DEFER_INTS;
+ entry = getprotoent ();
+ }
+ else if (SCM_NIMP (name) && SCM_STRINGP (name))
+ {
+ SCM_DEFER_INTS;
+ entry = getprotobyname (SCM_CHARS (name));
+ }
+ else
+ {
+ unsigned long protonum;
+ protonum = scm_num2ulong (name, (char *) SCM_ARG1, s_sys_getproto);
+ SCM_DEFER_INTS;
+ entry = getprotobynumber (protonum);
+ }
+ SCM_ALLOW_INTS;
+ if (!entry)
+ return SCM_BOOL_F;
+ ve[0] = scm_makfromstr (entry->p_name, (scm_sizet) strlen (entry->p_name), 0);
+ ve[1] = scm_makfromstrs (-1, entry->p_aliases);
+ ve[2] = SCM_MAKINUM (entry->p_proto + 0L);
+ return ans;
+}
+
+#ifdef __STDC__
+static SCM
+scm_return_entry (struct servent *entry)
+#else
+static SCM
+scm_return_entry (entry)
+ struct servent *entry;
+#endif
+{
+ SCM ans;
+ SCM *ve;
+
+ ans = scm_make_vector (SCM_MAKINUM (4), SCM_UNSPECIFIED, SCM_BOOL_F);
+ ve = SCM_VELTS (ans);
+ if (!entry)
+ {
+ SCM_ALLOW_INTS;
+ return SCM_BOOL_F;
+ }
+ ve[0] = scm_makfromstr (entry->s_name, (scm_sizet) strlen (entry->s_name), 0);
+ ve[1] = scm_makfromstrs (-1, entry->s_aliases);
+ ve[2] = SCM_MAKINUM (ntohs (entry->s_port) + 0L);
+ ve[3] = scm_makfromstr (entry->s_proto, (scm_sizet) strlen (entry->s_proto), 0);
+ SCM_ALLOW_INTS;
+ return ans;
+}
+
+SCM_PROC (s_sys_getserv, "%getserv", 0, 2, 0, scm_sys_getserv);
+#ifdef __STDC__
+SCM
+scm_sys_getserv (SCM name, SCM proto)
+#else
+SCM
+scm_sys_getserv (name, proto)
+ SCM name;
+ SCM proto;
+#endif
+{
+ struct servent *entry;
+ if (SCM_UNBNDP (name))
+ {
+ SCM_DEFER_INTS;
+ entry = getservent ();
+ return scm_return_entry (entry);
+ }
+ SCM_ASSERT (SCM_NIMP (proto) && SCM_STRINGP (proto), proto, SCM_ARG2, s_sys_getserv);
+ if (SCM_NIMP (name) && SCM_STRINGP (name))
+ {
+ SCM_DEFER_INTS;
+ entry = getservbyname (SCM_CHARS (name), SCM_CHARS (proto));
+ }
+ else
+ {
+ SCM_ASSERT (SCM_INUMP (name), name, SCM_ARG1, s_sys_getserv);
+ SCM_DEFER_INTS;
+ entry = getservbyport (SCM_INUM (name), SCM_CHARS (proto));
+ }
+ return scm_return_entry (entry);
+}
+
+SCM_PROC (s_sethost, "sethost", 0, 1, 0, scm_sethost);
+#ifdef __STDC__
+SCM
+scm_sethost (SCM arg)
+#else
+SCM
+scm_sethost (arg)
+ SCM arg;
+#endif
+{
+ if (SCM_UNBNDP (arg))
+ endhostent ();
+ else
+ sethostent (SCM_NFALSEP (arg));
+ return SCM_UNSPECIFIED;
+}
+
+SCM_PROC (s_setnet, "setnet", 0, 1, 0, scm_setnet);
+#ifdef __STDC__
+SCM
+scm_setnet (SCM arg)
+#else
+SCM
+scm_setnet (arg)
+ SCM arg;
+#endif
+{
+ if (SCM_UNBNDP (arg))
+ endnetent ();
+ else
+ setnetent (SCM_NFALSEP (arg));
+ return SCM_UNSPECIFIED;
+}
+
+SCM_PROC (s_setproto, "setproto", 0, 1, 0, scm_setproto);
+#ifdef __STDC__
+SCM
+scm_setproto (SCM arg)
+#else
+SCM
+scm_setproto (arg)
+ SCM arg;
+#endif
+{
+ if (SCM_UNBNDP (arg))
+ endprotoent ();
+ else
+ setprotoent (SCM_NFALSEP (arg));
+ return SCM_UNSPECIFIED;
+}
+
+SCM_PROC (s_setserv, "setserv", 0, 1, 0, scm_setserv);
+#ifdef __STDC__
+SCM
+scm_setserv (SCM arg)
+#else
+SCM
+scm_setserv (arg)
+ SCM arg;
+#endif
+{
+ if (SCM_UNBNDP (arg))
+ endservent ();
+ else
+ setservent (SCM_NFALSEP (arg));
+ return SCM_UNSPECIFIED;
+}
+
+#ifdef __STDC__
+void
+scm_init_socket (void)
+#else
+void
+scm_init_socket ()
+#endif
+{
+ scm_add_feature ("socket");
+#include "socket.x"
+}
+
+