1 /* "net_db.c" network database support
2 * Copyright (C) 1995,1996,1997,1998,1999,2000,2001 Free Software Foundation, Inc.
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)
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.
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, Inc., 59 Temple Place, Suite 330,
17 * Boston, MA 02111-1307 USA
19 * As a special exception, the Free Software Foundation gives permission
20 * for additional uses of the text contained in its release of GUILE.
22 * The exception is that, if you link the GUILE library with other files
23 * to produce an executable, this does not by itself cause the
24 * resulting executable to be covered by the GNU General Public License.
25 * Your use of that executable is in no way restricted on account of
26 * linking the GUILE library code into it.
28 * This exception does not however invalidate any other reasons why
29 * the executable file might be covered by the GNU General Public License.
31 * This exception applies only to the code released by the
32 * Free Software Foundation under the name GUILE. If you copy
33 * code from other Free Software Foundation releases into a copy of
34 * GUILE, as the General Public License permits, the exception does
35 * not apply to the code that you add in this way. To avoid misleading
36 * anyone as to the status of such modified files, you must delete
37 * this exception notice from them.
39 * If you write modifications of your own for GUILE, it is your choice
40 * whether to permit this exception to apply to your modifications.
41 * If you do not wish that, delete this exception notice. */
43 /* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
44 gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
47 /* Written in 1994 by Aubrey Jaffer.
48 * Thanks to Hallvard.Tretteberg@si.sintef.no for inspiration and discussion.
49 * Rewritten by Gary Houston to be a closer interface to the C socket library.
50 * Split into net_db.c and socket.c.
56 #include "libguile/_scm.h"
57 #include "libguile/feature.h"
58 #include "libguile/strings.h"
59 #include "libguile/vectors.h"
61 #include "libguile/validate.h"
62 #include "libguile/net_db.h"
68 #include <sys/types.h>
70 #ifdef HAVE_WINSOCK2_H
73 #include <sys/socket.h>
75 #include <netinet/in.h>
76 #include <arpa/inet.h>
79 #if !defined (HAVE_H_ERRNO) && !defined (__MINGW32__)
80 /* h_errno not found in netdb.h, maybe this will help. */
86 SCM_SYMBOL (scm_host_not_found_key
, "host-not-found");
87 SCM_SYMBOL (scm_try_again_key
, "try-again");
88 SCM_SYMBOL (scm_no_recovery_key
, "no-recovery");
89 SCM_SYMBOL (scm_no_data_key
, "no-data");
91 static void scm_resolv_error (const char *subr
, SCM bad_value
)
94 if (h_errno
== NETDB_INTERNAL
)
96 /* errno supposedly contains a useful value. */
108 key
= scm_host_not_found_key
;
109 errmsg
= "Unknown host";
112 key
= scm_try_again_key
;
113 errmsg
= "Host name lookup failure";
116 key
= scm_no_recovery_key
;
117 errmsg
= "Unknown server error";
120 key
= scm_no_data_key
;
121 errmsg
= "No address associated with name";
124 scm_misc_error (subr
, "Unknown resolver error", SCM_EOL
);
128 #ifdef HAVE_HSTRERROR
129 errmsg
= (const char *) hstrerror (h_errno
);
131 scm_error (key
, subr
, errmsg
, scm_cons (bad_value
, SCM_EOL
), SCM_EOL
);
135 /* Should take an extra arg for address format (will be needed for IPv6).
136 Should use reentrant facilities if available.
139 SCM_DEFINE (scm_gethost
, "gethost", 0, 1, 0,
141 "@deffnx procedure gethostbyname hostname\n"
142 "@deffnx procedure gethostbyaddr address\n"
143 "Look up a host by name or address, returning a host object. The\n"
144 "@code{gethost} procedure will accept either a string name or an integer\n"
145 "address; if given no arguments, it behaves like @code{gethostent} (see\n"
146 "below). If a name or address is supplied but the address can not be\n"
147 "found, an error will be thrown to one of the keys:\n"
148 "@code{host-not-found}, @code{try-again}, @code{no-recovery} or\n"
149 "@code{no-data}, corresponding to the equivalent @code{h_error} values.\n"
150 "Unusual conditions may result in errors thrown to the\n"
151 "@code{system-error} or @code{misc_error} keys.")
152 #define FUNC_NAME s_scm_gethost
154 SCM ans
= scm_c_make_vector (5, SCM_UNSPECIFIED
);
155 SCM
*ve
= SCM_VELTS (ans
);
157 struct hostent
*entry
;
161 if (SCM_UNBNDP (host
))
163 #ifdef HAVE_GETHOSTENT
164 entry
= gethostent ();
170 /* As far as I can tell, there's no good way to tell whether
171 zero means an error or end-of-file. The trick of
172 clearing errno before calling gethostent and checking it
173 afterwards doesn't cut it, because, on Linux, it seems to
174 try to contact some other server (YP?) and fails, which
175 is a benign failure. */
179 else if (SCM_STRINGP (host
))
181 SCM_STRING_COERCE_0TERMINATION_X (host
);
182 entry
= gethostbyname (SCM_STRING_CHARS (host
));
186 inad
.s_addr
= htonl (SCM_NUM2ULONG (1, host
));
187 entry
= gethostbyaddr ((char *) &inad
, sizeof (inad
), AF_INET
);
190 scm_resolv_error (FUNC_NAME
, host
);
192 ve
[0] = scm_mem2string (entry
->h_name
, strlen (entry
->h_name
));
193 ve
[1] = scm_makfromstrs (-1, entry
->h_aliases
);
194 ve
[2] = SCM_MAKINUM (entry
->h_addrtype
+ 0L);
195 ve
[3] = SCM_MAKINUM (entry
->h_length
+ 0L);
196 if (sizeof (struct in_addr
) != entry
->h_length
)
201 for (argv
= entry
->h_addr_list
; argv
[i
]; i
++);
204 inad
= *(struct in_addr
*) argv
[i
];
205 lst
= scm_cons (scm_ulong2num (ntohl (inad
.s_addr
)), lst
);
213 /* In all subsequent getMUMBLE functions, when we're called with no
214 arguments, we're supposed to traverse the tables entry by entry.
215 However, there doesn't seem to be any documented way to distinguish
216 between end-of-table and an error; in both cases the functions
217 return zero. Gotta love Unix. For the time being, we clear errno,
218 and if we get a zero and errno is set, we signal an error. This
219 doesn't seem quite right (what if errno gets set as part of healthy
220 operation?), but it seems to work okay. We'll see. */
222 #if defined(HAVE_GETNETENT) && defined(HAVE_GETNETBYNAME) && defined(HAVE_GETNETBYADDR)
223 SCM_DEFINE (scm_getnet
, "getnet", 0, 1, 0,
225 "@deffnx procedure getnetbyname net-name\n"
226 "@deffnx procedure getnetbyaddr net-number\n"
227 "Look up a network by name or net number in the network database. The\n"
228 "@var{net-name} argument must be a string, and the @var{net-number}\n"
229 "argument must be an integer. @code{getnet} will accept either type of\n"
230 "argument, behaving like @code{getnetent} (see below) if no arguments are\n"
232 #define FUNC_NAME s_scm_getnet
236 struct netent
*entry
;
238 ans
= scm_c_make_vector (4, SCM_UNSPECIFIED
);
239 ve
= SCM_VELTS (ans
);
240 if (SCM_UNBNDP (net
))
242 entry
= getnetent ();
245 /* There's no good way to tell whether zero means an error
246 or end-of-file, so we always return #f. See `gethost'
251 else if (SCM_STRINGP (net
))
253 SCM_STRING_COERCE_0TERMINATION_X (net
);
254 entry
= getnetbyname (SCM_STRING_CHARS (net
));
258 unsigned long netnum
;
259 netnum
= SCM_NUM2ULONG (1, net
);
260 entry
= getnetbyaddr (netnum
, AF_INET
);
263 SCM_SYSERROR_MSG ("no such network ~A", scm_list_1 (net
), errno
);
264 ve
[0] = scm_mem2string (entry
->n_name
, strlen (entry
->n_name
));
265 ve
[1] = scm_makfromstrs (-1, entry
->n_aliases
);
266 ve
[2] = SCM_MAKINUM (entry
->n_addrtype
+ 0L);
267 ve
[3] = scm_ulong2num (entry
->n_net
+ 0L);
273 #ifdef HAVE_GETPROTOENT
274 SCM_DEFINE (scm_getproto
, "getproto", 0, 1, 0,
276 "@deffnx procedure getprotobyname name\n"
277 "@deffnx procedure getprotobynumber number\n"
278 "Look up a network protocol by name or by number. @code{getprotobyname}\n"
279 "takes a string argument, and @code{getprotobynumber} takes an integer\n"
280 "argument. @code{getproto} will accept either type, behaving like\n"
281 "@code{getprotoent} (see below) if no arguments are supplied.")
282 #define FUNC_NAME s_scm_getproto
286 struct protoent
*entry
;
288 ans
= scm_c_make_vector (3, SCM_UNSPECIFIED
);
289 ve
= SCM_VELTS (ans
);
290 if (SCM_UNBNDP (protocol
))
292 entry
= getprotoent ();
295 /* There's no good way to tell whether zero means an error
296 or end-of-file, so we always return #f. See `gethost'
301 else if (SCM_STRINGP (protocol
))
303 SCM_STRING_COERCE_0TERMINATION_X (protocol
);
304 entry
= getprotobyname (SCM_STRING_CHARS (protocol
));
308 unsigned long protonum
;
309 protonum
= SCM_NUM2ULONG (1, protocol
);
310 entry
= getprotobynumber (protonum
);
313 SCM_SYSERROR_MSG ("no such protocol ~A", scm_list_1 (protocol
), errno
);
314 ve
[0] = scm_mem2string (entry
->p_name
, strlen (entry
->p_name
));
315 ve
[1] = scm_makfromstrs (-1, entry
->p_aliases
);
316 ve
[2] = SCM_MAKINUM (entry
->p_proto
+ 0L);
323 scm_return_entry (struct servent
*entry
)
328 ans
= scm_c_make_vector (4, SCM_UNSPECIFIED
);
329 ve
= SCM_VELTS (ans
);
330 ve
[0] = scm_mem2string (entry
->s_name
, strlen (entry
->s_name
));
331 ve
[1] = scm_makfromstrs (-1, entry
->s_aliases
);
332 ve
[2] = SCM_MAKINUM (ntohs (entry
->s_port
) + 0L);
333 ve
[3] = scm_mem2string (entry
->s_proto
, strlen (entry
->s_proto
));
337 #ifdef HAVE_GETSERVENT
338 SCM_DEFINE (scm_getserv
, "getserv", 0, 2, 0,
339 (SCM name
, SCM protocol
),
340 "@deffnx procedure getservbyname name protocol\n"
341 "@deffnx procedure getservbyport port protocol\n"
342 "Look up a network service by name or by service number, and return a\n"
343 "network service object. The @var{protocol} argument specifies the name\n"
344 "of the desired protocol; if the protocol found in the network service\n"
345 "database does not match this name, a system error is signalled.\n\n"
346 "The @code{getserv} procedure will take either a service name or number\n"
347 "as its first argument; if given no arguments, it behaves like\n"
348 "@code{getservent} (see below).")
349 #define FUNC_NAME s_scm_getserv
351 struct servent
*entry
;
352 if (SCM_UNBNDP (name
))
354 entry
= getservent ();
357 /* There's no good way to tell whether zero means an error
358 or end-of-file, so we always return #f. See `gethost'
362 return scm_return_entry (entry
);
364 SCM_VALIDATE_STRING (2, protocol
);
365 SCM_STRING_COERCE_0TERMINATION_X (protocol
);
366 if (SCM_STRINGP (name
))
368 SCM_STRING_COERCE_0TERMINATION_X (name
);
369 entry
= getservbyname (SCM_STRING_CHARS (name
), SCM_STRING_CHARS (protocol
));
373 SCM_VALIDATE_INUM (1,name
);
374 entry
= getservbyport (htons (SCM_INUM (name
)), SCM_STRING_CHARS (protocol
));
377 SCM_SYSERROR_MSG("no such service ~A", scm_list_1 (name
), errno
);
378 return scm_return_entry (entry
);
383 #if defined(HAVE_SETHOSTENT) && defined(HAVE_ENDHOSTENT)
384 SCM_DEFINE (scm_sethost
, "sethost", 0, 1, 0,
386 "If @var{stayopen} is omitted, this is equivalent to @code{endhostent}.\n"
387 "Otherwise it is equivalent to @code{sethostent stayopen}.")
388 #define FUNC_NAME s_scm_sethost
390 if (SCM_UNBNDP (stayopen
))
393 sethostent (!SCM_FALSEP (stayopen
));
394 return SCM_UNSPECIFIED
;
399 #if defined(HAVE_SETNETENT) && defined(HAVE_ENDNETENT)
400 SCM_DEFINE (scm_setnet
, "setnet", 0, 1, 0,
402 "If @var{stayopen} is omitted, this is equivalent to @code{endnetent}.\n"
403 "Otherwise it is equivalent to @code{setnetent stayopen}.")
404 #define FUNC_NAME s_scm_setnet
406 if (SCM_UNBNDP (stayopen
))
409 setnetent (!SCM_FALSEP (stayopen
));
410 return SCM_UNSPECIFIED
;
415 #if defined(HAVE_SETPROTOENT) && defined(HAVE_ENDPROTOENT)
416 SCM_DEFINE (scm_setproto
, "setproto", 0, 1, 0,
418 "If @var{stayopen} is omitted, this is equivalent to @code{endprotoent}.\n"
419 "Otherwise it is equivalent to @code{setprotoent stayopen}.")
420 #define FUNC_NAME s_scm_setproto
422 if (SCM_UNBNDP (stayopen
))
425 setprotoent (!SCM_FALSEP (stayopen
));
426 return SCM_UNSPECIFIED
;
431 #if defined(HAVE_SETSERVENT) && defined(HAVE_ENDSERVENT)
432 SCM_DEFINE (scm_setserv
, "setserv", 0, 1, 0,
434 "If @var{stayopen} is omitted, this is equivalent to @code{endservent}.\n"
435 "Otherwise it is equivalent to @code{setservent stayopen}.")
436 #define FUNC_NAME s_scm_setserv
438 if (SCM_UNBNDP (stayopen
))
441 setservent (!SCM_FALSEP (stayopen
));
442 return SCM_UNSPECIFIED
;
451 scm_add_feature ("net-db");
452 #ifndef SCM_MAGIC_SNARFER
453 #include "libguile/net_db.x"