1 /* "net_db.c" network database support
2 * Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2006, 2009 Free Software Foundation, Inc.
4 * This library is free software; you can redistribute it and/or
5 * modify it under the terms of the GNU Lesser General Public License
6 * as published by the Free Software Foundation; either version 3 of
7 * the License, or (at your option) any later version.
9 * This library is distributed in the hope that it will be useful, but
10 * WITHOUT ANY WARRANTY; without even the implied warranty of
11 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12 * Lesser General Public License for more details.
14 * You should have received a copy of the GNU Lesser General Public
15 * License along with this library; if not, write to the Free Software
16 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
22 /* Written in 1994 by Aubrey Jaffer.
23 * Thanks to Hallvard.Tretteberg@si.sintef.no for inspiration and discussion.
24 * Rewritten by Gary Houston to be a closer interface to the C socket library.
25 * Split into net_db.c and socket.c.
35 #include "libguile/_scm.h"
36 #include "libguile/feature.h"
37 #include "libguile/strings.h"
38 #include "libguile/vectors.h"
39 #include "libguile/dynwind.h"
41 #include "libguile/validate.h"
42 #include "libguile/net_db.h"
48 #include <sys/types.h>
50 #ifdef HAVE_WINSOCK2_H
53 #include <sys/socket.h>
55 #include <netinet/in.h>
56 #include <arpa/inet.h>
60 #include "win32-socket.h"
63 #if !defined (HAVE_H_ERRNO) && !defined (__MINGW32__) && !defined (__CYGWIN__)
64 /* h_errno not found in netdb.h, maybe this will help. */
68 #if defined HAVE_HSTRERROR && !HAVE_DECL_HSTRERROR \
69 && !defined __MINGW32__ && !defined __CYGWIN__
70 /* Some OSes, such as Tru64 5.1b, lack a declaration for hstrerror(3). */
71 extern const char *hstrerror (int);
76 SCM_SYMBOL (scm_host_not_found_key
, "host-not-found");
77 SCM_SYMBOL (scm_try_again_key
, "try-again");
78 SCM_SYMBOL (scm_no_recovery_key
, "no-recovery");
79 SCM_SYMBOL (scm_no_data_key
, "no-data");
81 static void scm_resolv_error (const char *subr
, SCM bad_value
)
84 if (h_errno
== NETDB_INTERNAL
)
86 /* errno supposedly contains a useful value. */
98 key
= scm_host_not_found_key
;
99 errmsg
= "Unknown host";
102 key
= scm_try_again_key
;
103 errmsg
= "Host name lookup failure";
106 key
= scm_no_recovery_key
;
107 errmsg
= "Unknown server error";
110 key
= scm_no_data_key
;
111 errmsg
= "No address associated with name";
114 scm_misc_error (subr
, "Unknown resolver error", SCM_EOL
);
118 #ifdef HAVE_HSTRERROR
119 errmsg
= (const char *) hstrerror (h_errno
);
121 scm_error (key
, subr
, errmsg
, SCM_BOOL_F
, SCM_EOL
);
125 /* Should take an extra arg for address format (will be needed for IPv6).
126 Should use reentrant facilities if available.
129 SCM_DEFINE (scm_gethost
, "gethost", 0, 1, 0,
131 "@deffnx {Scheme Procedure} gethostbyname hostname\n"
132 "@deffnx {Scheme Procedure} gethostbyaddr address\n"
133 "Look up a host by name or address, returning a host object. The\n"
134 "@code{gethost} procedure will accept either a string name or an integer\n"
135 "address; if given no arguments, it behaves like @code{gethostent} (see\n"
136 "below). If a name or address is supplied but the address can not be\n"
137 "found, an error will be thrown to one of the keys:\n"
138 "@code{host-not-found}, @code{try-again}, @code{no-recovery} or\n"
139 "@code{no-data}, corresponding to the equivalent @code{h_error} values.\n"
140 "Unusual conditions may result in errors thrown to the\n"
141 "@code{system-error} or @code{misc_error} keys.")
142 #define FUNC_NAME s_scm_gethost
144 SCM result
= scm_c_make_vector (5, SCM_UNSPECIFIED
);
146 struct hostent
*entry
;
151 if (SCM_UNBNDP (host
))
153 #ifdef HAVE_GETHOSTENT
154 entry
= gethostent ();
160 /* As far as I can tell, there's no good way to tell whether
161 zero means an error or end-of-file. The trick of
162 clearing errno before calling gethostent and checking it
163 afterwards doesn't cut it, because, on Linux, it seems to
164 try to contact some other server (YP?) and fails, which
165 is a benign failure. */
169 else if (scm_is_string (host
))
171 char *str
= scm_to_locale_string (host
);
172 entry
= gethostbyname (str
);
177 inad
.s_addr
= htonl (scm_to_ulong (host
));
178 entry
= gethostbyaddr ((char *) &inad
, sizeof (inad
), AF_INET
);
182 scm_resolv_error (FUNC_NAME
, host
);
184 SCM_SIMPLE_VECTOR_SET(result
, 0, scm_from_locale_string (entry
->h_name
));
185 SCM_SIMPLE_VECTOR_SET(result
, 1, scm_makfromstrs (-1, entry
->h_aliases
));
186 SCM_SIMPLE_VECTOR_SET(result
, 2, scm_from_int (entry
->h_addrtype
));
187 SCM_SIMPLE_VECTOR_SET(result
, 3, scm_from_int (entry
->h_length
));
188 if (sizeof (struct in_addr
) != entry
->h_length
)
190 SCM_SIMPLE_VECTOR_SET(result
, 4, SCM_BOOL_F
);
193 for (argv
= entry
->h_addr_list
; argv
[i
]; i
++);
196 inad
= *(struct in_addr
*) argv
[i
];
197 lst
= scm_cons (scm_from_ulong (ntohl (inad
.s_addr
)), lst
);
199 SCM_SIMPLE_VECTOR_SET(result
, 4, lst
);
205 /* In all subsequent getMUMBLE functions, when we're called with no
206 arguments, we're supposed to traverse the tables entry by entry.
207 However, there doesn't seem to be any documented way to distinguish
208 between end-of-table and an error; in both cases the functions
209 return zero. Gotta love Unix. For the time being, we clear errno,
210 and if we get a zero and errno is set, we signal an error. This
211 doesn't seem quite right (what if errno gets set as part of healthy
212 operation?), but it seems to work okay. We'll see. */
214 #if defined(HAVE_GETNETENT) && defined(HAVE_GETNETBYNAME) && defined(HAVE_GETNETBYADDR)
215 SCM_DEFINE (scm_getnet
, "getnet", 0, 1, 0,
217 "@deffnx {Scheme Procedure} getnetbyname net-name\n"
218 "@deffnx {Scheme Procedure} getnetbyaddr net-number\n"
219 "Look up a network by name or net number in the network database. The\n"
220 "@var{net-name} argument must be a string, and the @var{net-number}\n"
221 "argument must be an integer. @code{getnet} will accept either type of\n"
222 "argument, behaving like @code{getnetent} (see below) if no arguments are\n"
224 #define FUNC_NAME s_scm_getnet
226 SCM result
= scm_c_make_vector (4, SCM_UNSPECIFIED
);
227 struct netent
*entry
;
230 if (SCM_UNBNDP (net
))
232 entry
= getnetent ();
235 /* There's no good way to tell whether zero means an error
236 or end-of-file, so we always return #f. See `gethost'
241 else if (scm_is_string (net
))
243 char *str
= scm_to_locale_string (net
);
244 entry
= getnetbyname (str
);
250 unsigned long netnum
= scm_to_ulong (net
);
251 entry
= getnetbyaddr (netnum
, AF_INET
);
256 SCM_SYSERROR_MSG ("no such network ~A", scm_list_1 (net
), eno
);
258 SCM_SIMPLE_VECTOR_SET(result
, 0, scm_from_locale_string (entry
->n_name
));
259 SCM_SIMPLE_VECTOR_SET(result
, 1, scm_makfromstrs (-1, entry
->n_aliases
));
260 SCM_SIMPLE_VECTOR_SET(result
, 2, scm_from_int (entry
->n_addrtype
));
261 SCM_SIMPLE_VECTOR_SET(result
, 3, scm_from_ulong (entry
->n_net
));
267 #if defined (HAVE_GETPROTOENT) || defined (__MINGW32__)
268 SCM_DEFINE (scm_getproto
, "getproto", 0, 1, 0,
270 "@deffnx {Scheme Procedure} getprotobyname name\n"
271 "@deffnx {Scheme Procedure} getprotobynumber number\n"
272 "Look up a network protocol by name or by number. @code{getprotobyname}\n"
273 "takes a string argument, and @code{getprotobynumber} takes an integer\n"
274 "argument. @code{getproto} will accept either type, behaving like\n"
275 "@code{getprotoent} (see below) if no arguments are supplied.")
276 #define FUNC_NAME s_scm_getproto
278 SCM result
= scm_c_make_vector (3, SCM_UNSPECIFIED
);
279 struct protoent
*entry
;
282 if (SCM_UNBNDP (protocol
))
284 entry
= getprotoent ();
287 /* There's no good way to tell whether zero means an error
288 or end-of-file, so we always return #f. See `gethost'
293 else if (scm_is_string (protocol
))
295 char *str
= scm_to_locale_string (protocol
);
296 entry
= getprotobyname (str
);
302 unsigned long protonum
= scm_to_ulong (protocol
);
303 entry
= getprotobynumber (protonum
);
308 SCM_SYSERROR_MSG ("no such protocol ~A", scm_list_1 (protocol
), eno
);
310 SCM_SIMPLE_VECTOR_SET(result
, 0, scm_from_locale_string (entry
->p_name
));
311 SCM_SIMPLE_VECTOR_SET(result
, 1, scm_makfromstrs (-1, entry
->p_aliases
));
312 SCM_SIMPLE_VECTOR_SET(result
, 2, scm_from_int (entry
->p_proto
));
318 #if defined (HAVE_GETSERVENT) || defined (__MINGW32__)
320 scm_return_entry (struct servent
*entry
)
322 SCM result
= scm_c_make_vector (4, SCM_UNSPECIFIED
);
324 SCM_SIMPLE_VECTOR_SET(result
, 0, scm_from_locale_string (entry
->s_name
));
325 SCM_SIMPLE_VECTOR_SET(result
, 1, scm_makfromstrs (-1, entry
->s_aliases
));
326 SCM_SIMPLE_VECTOR_SET(result
, 2, scm_from_uint16 (ntohs (entry
->s_port
)));
327 SCM_SIMPLE_VECTOR_SET(result
, 3, scm_from_locale_string (entry
->s_proto
));
331 SCM_DEFINE (scm_getserv
, "getserv", 0, 2, 0,
332 (SCM name
, SCM protocol
),
333 "@deffnx {Scheme Procedure} getservbyname name protocol\n"
334 "@deffnx {Scheme Procedure} getservbyport port protocol\n"
335 "Look up a network service by name or by service number, and return a\n"
336 "network service object. The @var{protocol} argument specifies the name\n"
337 "of the desired protocol; if the protocol found in the network service\n"
338 "database does not match this name, a system error is signalled.\n\n"
339 "The @code{getserv} procedure will take either a service name or number\n"
340 "as its first argument; if given no arguments, it behaves like\n"
341 "@code{getservent} (see below).")
342 #define FUNC_NAME s_scm_getserv
344 struct servent
*entry
;
348 if (SCM_UNBNDP (name
))
350 entry
= getservent ();
353 /* There's no good way to tell whether zero means an error
354 or end-of-file, so we always return #f. See `gethost'
358 return scm_return_entry (entry
);
361 scm_dynwind_begin (0);
363 protoname
= scm_to_locale_string (protocol
);
364 scm_dynwind_free (protoname
);
366 if (scm_is_string (name
))
368 char *str
= scm_to_locale_string (name
);
369 entry
= getservbyname (str
, protoname
);
375 entry
= getservbyport (htons (scm_to_int (name
)), protoname
);
380 SCM_SYSERROR_MSG("no such service ~A", scm_list_1 (name
), eno
);
383 return scm_return_entry (entry
);
388 #if defined(HAVE_SETHOSTENT) && defined(HAVE_ENDHOSTENT)
389 SCM_DEFINE (scm_sethost
, "sethost", 0, 1, 0,
391 "If @var{stayopen} is omitted, this is equivalent to @code{endhostent}.\n"
392 "Otherwise it is equivalent to @code{sethostent stayopen}.")
393 #define FUNC_NAME s_scm_sethost
395 if (SCM_UNBNDP (stayopen
))
398 sethostent (scm_is_true (stayopen
));
399 return SCM_UNSPECIFIED
;
404 #if defined(HAVE_SETNETENT) && defined(HAVE_ENDNETENT)
405 SCM_DEFINE (scm_setnet
, "setnet", 0, 1, 0,
407 "If @var{stayopen} is omitted, this is equivalent to @code{endnetent}.\n"
408 "Otherwise it is equivalent to @code{setnetent stayopen}.")
409 #define FUNC_NAME s_scm_setnet
411 if (SCM_UNBNDP (stayopen
))
414 setnetent (scm_is_true (stayopen
));
415 return SCM_UNSPECIFIED
;
420 #if defined (HAVE_SETPROTOENT) && defined (HAVE_ENDPROTOENT) || defined (__MINGW32__)
421 SCM_DEFINE (scm_setproto
, "setproto", 0, 1, 0,
423 "If @var{stayopen} is omitted, this is equivalent to @code{endprotoent}.\n"
424 "Otherwise it is equivalent to @code{setprotoent stayopen}.")
425 #define FUNC_NAME s_scm_setproto
427 if (SCM_UNBNDP (stayopen
))
430 setprotoent (scm_is_true (stayopen
));
431 return SCM_UNSPECIFIED
;
436 #if defined (HAVE_SETSERVENT) && defined (HAVE_ENDSERVENT) || defined (__MINGW32__)
437 SCM_DEFINE (scm_setserv
, "setserv", 0, 1, 0,
439 "If @var{stayopen} is omitted, this is equivalent to @code{endservent}.\n"
440 "Otherwise it is equivalent to @code{setservent stayopen}.")
441 #define FUNC_NAME s_scm_setserv
443 if (SCM_UNBNDP (stayopen
))
446 setservent (scm_is_true (stayopen
));
447 return SCM_UNSPECIFIED
;
456 scm_add_feature ("net-db");
457 #include "libguile/net_db.x"