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. */
45 /* Written in 1994 by Aubrey Jaffer.
46 * Thanks to Hallvard.Tretteberg@si.sintef.no for inspiration and discussion.
47 * Rewritten by Gary Houston to be a closer interface to the C socket library.
48 * Split into net_db.c and socket.c.
54 #include "libguile/_scm.h"
55 #include "libguile/feature.h"
56 #include "libguile/strings.h"
57 #include "libguile/vectors.h"
59 #include "libguile/validate.h"
60 #include "libguile/net_db.h"
66 #include <sys/types.h>
68 #ifdef HAVE_WINSOCK2_H
71 #include <sys/socket.h>
73 #include <netinet/in.h>
74 #include <arpa/inet.h>
78 #include "win32-socket.h"
81 #if !defined (HAVE_H_ERRNO) && !defined (__MINGW32__) && !defined (__CYGWIN__)
82 /* h_errno not found in netdb.h, maybe this will help. */
88 SCM_SYMBOL (scm_host_not_found_key
, "host-not-found");
89 SCM_SYMBOL (scm_try_again_key
, "try-again");
90 SCM_SYMBOL (scm_no_recovery_key
, "no-recovery");
91 SCM_SYMBOL (scm_no_data_key
, "no-data");
93 static void scm_resolv_error (const char *subr
, SCM bad_value
)
96 if (h_errno
== NETDB_INTERNAL
)
98 /* errno supposedly contains a useful value. */
110 key
= scm_host_not_found_key
;
111 errmsg
= "Unknown host";
114 key
= scm_try_again_key
;
115 errmsg
= "Host name lookup failure";
118 key
= scm_no_recovery_key
;
119 errmsg
= "Unknown server error";
122 key
= scm_no_data_key
;
123 errmsg
= "No address associated with name";
126 scm_misc_error (subr
, "Unknown resolver error", SCM_EOL
);
130 #ifdef HAVE_HSTRERROR
131 errmsg
= (const char *) hstrerror (h_errno
);
133 scm_error (key
, subr
, errmsg
, scm_cons (bad_value
, SCM_EOL
), SCM_EOL
);
137 /* Should take an extra arg for address format (will be needed for IPv6).
138 Should use reentrant facilities if available.
141 SCM_DEFINE (scm_gethost
, "gethost", 0, 1, 0,
143 "@deffnx {Scheme Procedure} gethostbyname hostname\n"
144 "@deffnx {Scheme Procedure} gethostbyaddr address\n"
145 "Look up a host by name or address, returning a host object. The\n"
146 "@code{gethost} procedure will accept either a string name or an integer\n"
147 "address; if given no arguments, it behaves like @code{gethostent} (see\n"
148 "below). If a name or address is supplied but the address can not be\n"
149 "found, an error will be thrown to one of the keys:\n"
150 "@code{host-not-found}, @code{try-again}, @code{no-recovery} or\n"
151 "@code{no-data}, corresponding to the equivalent @code{h_error} values.\n"
152 "Unusual conditions may result in errors thrown to the\n"
153 "@code{system-error} or @code{misc_error} keys.")
154 #define FUNC_NAME s_scm_gethost
156 SCM ans
= scm_c_make_vector (5, SCM_UNSPECIFIED
);
157 SCM
*ve
= SCM_VELTS (ans
);
159 struct hostent
*entry
;
163 if (SCM_UNBNDP (host
))
165 #ifdef HAVE_GETHOSTENT
166 entry
= gethostent ();
172 /* As far as I can tell, there's no good way to tell whether
173 zero means an error or end-of-file. The trick of
174 clearing errno before calling gethostent and checking it
175 afterwards doesn't cut it, because, on Linux, it seems to
176 try to contact some other server (YP?) and fails, which
177 is a benign failure. */
181 else if (SCM_STRINGP (host
))
183 entry
= gethostbyname (SCM_STRING_CHARS (host
));
187 inad
.s_addr
= htonl (SCM_NUM2ULONG (1, host
));
188 entry
= gethostbyaddr ((char *) &inad
, sizeof (inad
), AF_INET
);
191 scm_resolv_error (FUNC_NAME
, host
);
193 ve
[0] = scm_mem2string (entry
->h_name
, strlen (entry
->h_name
));
194 ve
[1] = scm_makfromstrs (-1, entry
->h_aliases
);
195 ve
[2] = SCM_MAKINUM (entry
->h_addrtype
+ 0L);
196 ve
[3] = SCM_MAKINUM (entry
->h_length
+ 0L);
197 if (sizeof (struct in_addr
) != entry
->h_length
)
202 for (argv
= entry
->h_addr_list
; argv
[i
]; i
++);
205 inad
= *(struct in_addr
*) argv
[i
];
206 lst
= scm_cons (scm_ulong2num (ntohl (inad
.s_addr
)), lst
);
214 /* In all subsequent getMUMBLE functions, when we're called with no
215 arguments, we're supposed to traverse the tables entry by entry.
216 However, there doesn't seem to be any documented way to distinguish
217 between end-of-table and an error; in both cases the functions
218 return zero. Gotta love Unix. For the time being, we clear errno,
219 and if we get a zero and errno is set, we signal an error. This
220 doesn't seem quite right (what if errno gets set as part of healthy
221 operation?), but it seems to work okay. We'll see. */
223 #if defined(HAVE_GETNETENT) && defined(HAVE_GETNETBYNAME) && defined(HAVE_GETNETBYADDR)
224 SCM_DEFINE (scm_getnet
, "getnet", 0, 1, 0,
226 "@deffnx {Scheme Procedure} getnetbyname net-name\n"
227 "@deffnx {Scheme Procedure} getnetbyaddr net-number\n"
228 "Look up a network by name or net number in the network database. The\n"
229 "@var{net-name} argument must be a string, and the @var{net-number}\n"
230 "argument must be an integer. @code{getnet} will accept either type of\n"
231 "argument, behaving like @code{getnetent} (see below) if no arguments are\n"
233 #define FUNC_NAME s_scm_getnet
237 struct netent
*entry
;
239 ans
= scm_c_make_vector (4, SCM_UNSPECIFIED
);
240 ve
= SCM_VELTS (ans
);
241 if (SCM_UNBNDP (net
))
243 entry
= getnetent ();
246 /* There's no good way to tell whether zero means an error
247 or end-of-file, so we always return #f. See `gethost'
252 else if (SCM_STRINGP (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 #if defined (HAVE_GETPROTOENT) || defined (__MINGW32__)
274 SCM_DEFINE (scm_getproto
, "getproto", 0, 1, 0,
276 "@deffnx {Scheme Procedure} getprotobyname name\n"
277 "@deffnx {Scheme 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 entry
= getprotobyname (SCM_STRING_CHARS (protocol
));
307 unsigned long protonum
;
308 protonum
= SCM_NUM2ULONG (1, protocol
);
309 entry
= getprotobynumber (protonum
);
312 SCM_SYSERROR_MSG ("no such protocol ~A", scm_list_1 (protocol
), errno
);
313 ve
[0] = scm_mem2string (entry
->p_name
, strlen (entry
->p_name
));
314 ve
[1] = scm_makfromstrs (-1, entry
->p_aliases
);
315 ve
[2] = SCM_MAKINUM (entry
->p_proto
+ 0L);
321 #if defined (HAVE_GETSERVENT) || defined (__MINGW32__)
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 SCM_DEFINE (scm_getserv
, "getserv", 0, 2, 0,
338 (SCM name
, SCM protocol
),
339 "@deffnx {Scheme Procedure} getservbyname name protocol\n"
340 "@deffnx {Scheme Procedure} getservbyport port protocol\n"
341 "Look up a network service by name or by service number, and return a\n"
342 "network service object. The @var{protocol} argument specifies the name\n"
343 "of the desired protocol; if the protocol found in the network service\n"
344 "database does not match this name, a system error is signalled.\n\n"
345 "The @code{getserv} procedure will take either a service name or number\n"
346 "as its first argument; if given no arguments, it behaves like\n"
347 "@code{getservent} (see below).")
348 #define FUNC_NAME s_scm_getserv
350 struct servent
*entry
;
351 if (SCM_UNBNDP (name
))
353 entry
= getservent ();
356 /* There's no good way to tell whether zero means an error
357 or end-of-file, so we always return #f. See `gethost'
361 return scm_return_entry (entry
);
363 SCM_VALIDATE_STRING (2, protocol
);
364 if (SCM_STRINGP (name
))
366 entry
= getservbyname (SCM_STRING_CHARS (name
), SCM_STRING_CHARS (protocol
));
370 SCM_VALIDATE_INUM (1,name
);
371 entry
= getservbyport (htons (SCM_INUM (name
)), SCM_STRING_CHARS (protocol
));
374 SCM_SYSERROR_MSG("no such service ~A", scm_list_1 (name
), errno
);
375 return scm_return_entry (entry
);
380 #if defined(HAVE_SETHOSTENT) && defined(HAVE_ENDHOSTENT)
381 SCM_DEFINE (scm_sethost
, "sethost", 0, 1, 0,
383 "If @var{stayopen} is omitted, this is equivalent to @code{endhostent}.\n"
384 "Otherwise it is equivalent to @code{sethostent stayopen}.")
385 #define FUNC_NAME s_scm_sethost
387 if (SCM_UNBNDP (stayopen
))
390 sethostent (!SCM_FALSEP (stayopen
));
391 return SCM_UNSPECIFIED
;
396 #if defined(HAVE_SETNETENT) && defined(HAVE_ENDNETENT)
397 SCM_DEFINE (scm_setnet
, "setnet", 0, 1, 0,
399 "If @var{stayopen} is omitted, this is equivalent to @code{endnetent}.\n"
400 "Otherwise it is equivalent to @code{setnetent stayopen}.")
401 #define FUNC_NAME s_scm_setnet
403 if (SCM_UNBNDP (stayopen
))
406 setnetent (!SCM_FALSEP (stayopen
));
407 return SCM_UNSPECIFIED
;
412 #if defined (HAVE_SETPROTOENT) && defined (HAVE_ENDPROTOENT) || defined (__MINGW32__)
413 SCM_DEFINE (scm_setproto
, "setproto", 0, 1, 0,
415 "If @var{stayopen} is omitted, this is equivalent to @code{endprotoent}.\n"
416 "Otherwise it is equivalent to @code{setprotoent stayopen}.")
417 #define FUNC_NAME s_scm_setproto
419 if (SCM_UNBNDP (stayopen
))
422 setprotoent (!SCM_FALSEP (stayopen
));
423 return SCM_UNSPECIFIED
;
428 #if defined (HAVE_SETSERVENT) && defined (HAVE_ENDSERVENT) || defined (__MINGW32__)
429 SCM_DEFINE (scm_setserv
, "setserv", 0, 1, 0,
431 "If @var{stayopen} is omitted, this is equivalent to @code{endservent}.\n"
432 "Otherwise it is equivalent to @code{setservent stayopen}.")
433 #define FUNC_NAME s_scm_setserv
435 if (SCM_UNBNDP (stayopen
))
438 setservent (!SCM_FALSEP (stayopen
));
439 return SCM_UNSPECIFIED
;
448 scm_add_feature ("net-db");
449 #include "libguile/net_db.x"