X-Git-Url: http://git.hcoop.net/bpt/guile.git/blobdiff_plain/cae7644108b0d3ba1fb6bba52a572fe2cab4d0d6..8f6a429e4726d8dfc9ced5ff767c8611adf86394:/libguile/net_db.c diff --git a/libguile/net_db.c b/libguile/net_db.c dissimilarity index 79% index 5b26ba900..7ae33f037 100644 --- a/libguile/net_db.c +++ b/libguile/net_db.c @@ -1,411 +1,426 @@ -/* "net_db.c" network database support - * Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - -/* Written in 1994 by Aubrey Jaffer. - * Thanks to Hallvard.Tretteberg@si.sintef.no for inspiration and discussion. - * Rewritten by Gary Houston to be a closer interface to the C socket library. - * Split into net_db.c and socket.c. - */ - - -#include -#include "_scm.h" -#include "feature.h" - -#include "net_db.h" - -#ifdef HAVE_STRING_H -#include -#endif - -#include -#include -#include -#include -#include - - - -#ifndef STDC_HEADERS -int close (); -#endif /* STDC_HEADERS */ - -extern int inet_aton (); - -SCM_PROC (s_inet_aton, "inet-aton", 1, 0, 0, scm_inet_aton); - -SCM -scm_inet_aton (address) - SCM address; -{ - struct in_addr soka; - - SCM_ASSERT (SCM_NIMP (address) && SCM_ROSTRINGP (address), address, SCM_ARG1, s_inet_aton); - if (SCM_SUBSTRP (address)) - address = scm_makfromstr (SCM_ROCHARS (address), SCM_ROLENGTH (address), 0); - if (inet_aton (SCM_ROCHARS (address), &soka) == 0) - scm_syserror (s_inet_aton); - return scm_ulong2num (ntohl (soka.s_addr)); -} - - -SCM_PROC (s_inet_ntoa, "inet-ntoa", 1, 0, 0, scm_inet_ntoa); - -SCM -scm_inet_ntoa (inetid) - SCM inetid; -{ - 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); - -SCM -scm_inet_netof (address) - SCM address; -{ - 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); - -SCM -scm_lnaof (address) - SCM address; -{ - 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); - -SCM -scm_inet_makeaddr (net, lna) - SCM net; - SCM lna; -{ - 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_gethost, "gethost", 0, 1, 0, scm_gethost); - -SCM -scm_gethost (name) - SCM name; -{ - 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_gethost)); - SCM_DEFER_INTS; - entry = gethostbyaddr ((char *) &inad, sizeof (inad), AF_INET); - } - SCM_ALLOW_INTS; - if (!entry) - scm_syserror (s_gethost); - 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_getnet, "getnet", 0, 1, 0, scm_getnet); - -SCM -scm_getnet (name) - SCM name; -{ - 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_getnet); - SCM_DEFER_INTS; - entry = getnetbyaddr (netnum, AF_INET); - } - SCM_ALLOW_INTS; - if (!entry) - scm_syserror (s_getnet); - 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_getproto, "getproto", 0, 1, 0, scm_getproto); - -SCM -scm_getproto (name) - SCM name; -{ - 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_getproto); - SCM_DEFER_INTS; - entry = getprotobynumber (protonum); - } - SCM_ALLOW_INTS; - if (!entry) - scm_syserror (s_getproto); - 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; -} - - -static SCM scm_return_entry SCM_P ((struct servent *entry)); - -static SCM -scm_return_entry (entry) - struct servent *entry; -{ - SCM ans; - SCM *ve; - - ans = scm_make_vector (SCM_MAKINUM (4), SCM_UNSPECIFIED, SCM_BOOL_F); - ve = SCM_VELTS (ans); - 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_getserv, "getserv", 0, 2, 0, scm_getserv); - -SCM -scm_getserv (name, proto) - SCM name; - SCM proto; -{ - struct servent *entry; - if (SCM_UNBNDP (name)) - { - SCM_DEFER_INTS; - entry = getservent (); - if (!entry) - scm_syserror (s_getserv); - return scm_return_entry (entry); - } - SCM_ASSERT (SCM_NIMP (proto) && SCM_STRINGP (proto), proto, SCM_ARG2, s_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_getserv); - SCM_DEFER_INTS; - entry = getservbyport (SCM_INUM (name), SCM_CHARS (proto)); - } - if (!entry) - scm_syserror (s_getserv); - return scm_return_entry (entry); -} - -SCM_PROC (s_sethost, "sethost", 0, 1, 0, scm_sethost); - -SCM -scm_sethost (arg) - SCM arg; -{ - if (SCM_UNBNDP (arg)) - endhostent (); - else - sethostent (SCM_NFALSEP (arg)); - return SCM_UNSPECIFIED; -} - -SCM_PROC (s_setnet, "setnet", 0, 1, 0, scm_setnet); - -SCM -scm_setnet (arg) - SCM arg; -{ - if (SCM_UNBNDP (arg)) - endnetent (); - else - setnetent (SCM_NFALSEP (arg)); - return SCM_UNSPECIFIED; -} - -SCM_PROC (s_setproto, "setproto", 0, 1, 0, scm_setproto); - -SCM -scm_setproto (arg) - SCM arg; -{ - if (SCM_UNBNDP (arg)) - endprotoent (); - else - setprotoent (SCM_NFALSEP (arg)); - return SCM_UNSPECIFIED; -} - -SCM_PROC (s_setserv, "setserv", 0, 1, 0, scm_setserv); - -SCM -scm_setserv (arg) - SCM arg; -{ - if (SCM_UNBNDP (arg)) - endservent (); - else - setservent (SCM_NFALSEP (arg)); - return SCM_UNSPECIFIED; -} - - -void -scm_init_net_db () -{ -#ifdef INADDR_ANY - scm_sysintern ("INADDR_ANY", scm_ulong2num (INADDR_ANY)); -#endif -#ifdef INADDR_BROADCAST - scm_sysintern ("INADDR_BROADCAST", scm_ulong2num (INADDR_BROADCAST)); -#endif -#ifdef INADDR_NONE - scm_sysintern ("INADDR_NONE", scm_ulong2num (INADDR_NONE)); -#endif -#ifdef INADDR_LOOPBACK - scm_sysintern ("INADDR_LOOPBACK", scm_ulong2num (INADDR_LOOPBACK)); -#endif - - scm_add_feature ("net-db"); -#include "net_db.x" -} - - +/* "net_db.c" network database support + * Copyright (C) 1995,1996,1997,1998,1999,2000,2001 Free Software Foundation, Inc. + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public + * License as published by the Free Software Foundation; either + * version 2.1 of the License, or (at your option) any later version. + * + * This library is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this library; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + + + +/* Written in 1994 by Aubrey Jaffer. + * Thanks to Hallvard.Tretteberg@si.sintef.no for inspiration and discussion. + * Rewritten by Gary Houston to be a closer interface to the C socket library. + * Split into net_db.c and socket.c. + */ + + +#if HAVE_CONFIG_H +# include +#endif + +#include + +#include "libguile/_scm.h" +#include "libguile/feature.h" +#include "libguile/strings.h" +#include "libguile/vectors.h" + +#include "libguile/validate.h" +#include "libguile/net_db.h" + +#ifdef HAVE_STRING_H +#include +#endif + +#include + +#ifdef HAVE_WINSOCK2_H +#include +#else +#include +#include +#include +#include +#endif + +#ifdef __MINGW32__ +#include "win32-socket.h" +#endif + +#if !defined (HAVE_H_ERRNO) && !defined (__MINGW32__) && !defined (__CYGWIN__) +/* h_errno not found in netdb.h, maybe this will help. */ +extern int h_errno; +#endif + + + +SCM_SYMBOL (scm_host_not_found_key, "host-not-found"); +SCM_SYMBOL (scm_try_again_key, "try-again"); +SCM_SYMBOL (scm_no_recovery_key, "no-recovery"); +SCM_SYMBOL (scm_no_data_key, "no-data"); + +static void scm_resolv_error (const char *subr, SCM bad_value) +{ +#ifdef NETDB_INTERNAL + if (h_errno == NETDB_INTERNAL) + { + /* errno supposedly contains a useful value. */ + scm_syserror (subr); + } + else +#endif + { + SCM key; + const char *errmsg; + + switch (h_errno) + { + case HOST_NOT_FOUND: + key = scm_host_not_found_key; + errmsg = "Unknown host"; + break; + case TRY_AGAIN: + key = scm_try_again_key; + errmsg = "Host name lookup failure"; + break; + case NO_RECOVERY: + key = scm_no_recovery_key; + errmsg = "Unknown server error"; + break; + case NO_DATA: + key = scm_no_data_key; + errmsg = "No address associated with name"; + break; + default: + scm_misc_error (subr, "Unknown resolver error", SCM_EOL); + errmsg = NULL; + } + +#ifdef HAVE_HSTRERROR + errmsg = (const char *) hstrerror (h_errno); +#endif + scm_error (key, subr, errmsg, scm_cons (bad_value, SCM_EOL), SCM_EOL); + } +} + +/* Should take an extra arg for address format (will be needed for IPv6). + Should use reentrant facilities if available. + */ + +SCM_DEFINE (scm_gethost, "gethost", 0, 1, 0, + (SCM host), + "@deffnx {Scheme Procedure} gethostbyname hostname\n" + "@deffnx {Scheme Procedure} gethostbyaddr address\n" + "Look up a host by name or address, returning a host object. The\n" + "@code{gethost} procedure will accept either a string name or an integer\n" + "address; if given no arguments, it behaves like @code{gethostent} (see\n" + "below). If a name or address is supplied but the address can not be\n" + "found, an error will be thrown to one of the keys:\n" + "@code{host-not-found}, @code{try-again}, @code{no-recovery} or\n" + "@code{no-data}, corresponding to the equivalent @code{h_error} values.\n" + "Unusual conditions may result in errors thrown to the\n" + "@code{system-error} or @code{misc_error} keys.") +#define FUNC_NAME s_scm_gethost +{ + SCM result = scm_c_make_vector (5, SCM_UNSPECIFIED); + SCM lst = SCM_EOL; + struct hostent *entry; + struct in_addr inad; + char **argv; + int i = 0; + if (SCM_UNBNDP (host)) + { +#ifdef HAVE_GETHOSTENT + entry = gethostent (); +#else + entry = NULL; +#endif + if (! entry) + { + /* As far as I can tell, there's no good way to tell whether + zero means an error or end-of-file. The trick of + clearing errno before calling gethostent and checking it + afterwards doesn't cut it, because, on Linux, it seems to + try to contact some other server (YP?) and fails, which + is a benign failure. */ + return SCM_BOOL_F; + } + } + else if (SCM_STRINGP (host)) + { + entry = gethostbyname (SCM_STRING_CHARS (host)); + } + else + { + inad.s_addr = htonl (SCM_NUM2ULONG (1, host)); + entry = gethostbyaddr ((char *) &inad, sizeof (inad), AF_INET); + } + if (!entry) + scm_resolv_error (FUNC_NAME, host); + + SCM_VECTOR_SET(result, 0, scm_mem2string (entry->h_name, strlen (entry->h_name))); + SCM_VECTOR_SET(result, 1, scm_makfromstrs (-1, entry->h_aliases)); + SCM_VECTOR_SET(result, 2, SCM_MAKINUM (entry->h_addrtype + 0L)); + SCM_VECTOR_SET(result, 3, SCM_MAKINUM (entry->h_length + 0L)); + if (sizeof (struct in_addr) != entry->h_length) + { + SCM_VECTOR_SET(result, 4, SCM_BOOL_F); + return result; + } + 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); + } + SCM_VECTOR_SET(result, 4, lst); + return result; +} +#undef FUNC_NAME + + +/* In all subsequent getMUMBLE functions, when we're called with no + arguments, we're supposed to traverse the tables entry by entry. + However, there doesn't seem to be any documented way to distinguish + between end-of-table and an error; in both cases the functions + return zero. Gotta love Unix. For the time being, we clear errno, + and if we get a zero and errno is set, we signal an error. This + doesn't seem quite right (what if errno gets set as part of healthy + operation?), but it seems to work okay. We'll see. */ + +#if defined(HAVE_GETNETENT) && defined(HAVE_GETNETBYNAME) && defined(HAVE_GETNETBYADDR) +SCM_DEFINE (scm_getnet, "getnet", 0, 1, 0, + (SCM net), + "@deffnx {Scheme Procedure} getnetbyname net-name\n" + "@deffnx {Scheme Procedure} getnetbyaddr net-number\n" + "Look up a network by name or net number in the network database. The\n" + "@var{net-name} argument must be a string, and the @var{net-number}\n" + "argument must be an integer. @code{getnet} will accept either type of\n" + "argument, behaving like @code{getnetent} (see below) if no arguments are\n" + "given.") +#define FUNC_NAME s_scm_getnet +{ + SCM result = scm_c_make_vector (4, SCM_UNSPECIFIED); + struct netent *entry; + + if (SCM_UNBNDP (net)) + { + entry = getnetent (); + if (! entry) + { + /* There's no good way to tell whether zero means an error + or end-of-file, so we always return #f. See `gethost' + for details. */ + return SCM_BOOL_F; + } + } + else if (SCM_STRINGP (net)) + { + entry = getnetbyname (SCM_STRING_CHARS (net)); + } + else + { + unsigned long netnum; + netnum = SCM_NUM2ULONG (1, net); + entry = getnetbyaddr (netnum, AF_INET); + } + if (!entry) + SCM_SYSERROR_MSG ("no such network ~A", scm_list_1 (net), errno); + SCM_VECTOR_SET(result, 0, scm_mem2string (entry->n_name, strlen (entry->n_name))); + SCM_VECTOR_SET(result, 1, scm_makfromstrs (-1, entry->n_aliases)); + SCM_VECTOR_SET(result, 2, SCM_MAKINUM (entry->n_addrtype + 0L)); + SCM_VECTOR_SET(result, 3, scm_ulong2num (entry->n_net + 0L)); + return result; +} +#undef FUNC_NAME +#endif + +#if defined (HAVE_GETPROTOENT) || defined (__MINGW32__) +SCM_DEFINE (scm_getproto, "getproto", 0, 1, 0, + (SCM protocol), + "@deffnx {Scheme Procedure} getprotobyname name\n" + "@deffnx {Scheme Procedure} getprotobynumber number\n" + "Look up a network protocol by name or by number. @code{getprotobyname}\n" + "takes a string argument, and @code{getprotobynumber} takes an integer\n" + "argument. @code{getproto} will accept either type, behaving like\n" + "@code{getprotoent} (see below) if no arguments are supplied.") +#define FUNC_NAME s_scm_getproto +{ + SCM result = scm_c_make_vector (3, SCM_UNSPECIFIED); + + struct protoent *entry; + if (SCM_UNBNDP (protocol)) + { + entry = getprotoent (); + if (! entry) + { + /* There's no good way to tell whether zero means an error + or end-of-file, so we always return #f. See `gethost' + for details. */ + return SCM_BOOL_F; + } + } + else if (SCM_STRINGP (protocol)) + { + entry = getprotobyname (SCM_STRING_CHARS (protocol)); + } + else + { + unsigned long protonum; + protonum = SCM_NUM2ULONG (1, protocol); + entry = getprotobynumber (protonum); + } + if (!entry) + SCM_SYSERROR_MSG ("no such protocol ~A", scm_list_1 (protocol), errno); + SCM_VECTOR_SET(result, 0, scm_mem2string (entry->p_name, strlen (entry->p_name))); + SCM_VECTOR_SET(result, 1, scm_makfromstrs (-1, entry->p_aliases)); + SCM_VECTOR_SET(result, 2, SCM_MAKINUM (entry->p_proto + 0L)); + return result; +} +#undef FUNC_NAME +#endif + +#if defined (HAVE_GETSERVENT) || defined (__MINGW32__) +static SCM +scm_return_entry (struct servent *entry) +{ + SCM result = scm_c_make_vector (4, SCM_UNSPECIFIED); + + SCM_VECTOR_SET(result, 0, scm_mem2string (entry->s_name, strlen (entry->s_name))); + SCM_VECTOR_SET(result, 1, scm_makfromstrs (-1, entry->s_aliases)); + SCM_VECTOR_SET(result, 2, SCM_MAKINUM (ntohs (entry->s_port) + 0L)); + SCM_VECTOR_SET(result, 3, scm_mem2string (entry->s_proto, strlen (entry->s_proto))); + return result; +} + +SCM_DEFINE (scm_getserv, "getserv", 0, 2, 0, + (SCM name, SCM protocol), + "@deffnx {Scheme Procedure} getservbyname name protocol\n" + "@deffnx {Scheme Procedure} getservbyport port protocol\n" + "Look up a network service by name or by service number, and return a\n" + "network service object. The @var{protocol} argument specifies the name\n" + "of the desired protocol; if the protocol found in the network service\n" + "database does not match this name, a system error is signalled.\n\n" + "The @code{getserv} procedure will take either a service name or number\n" + "as its first argument; if given no arguments, it behaves like\n" + "@code{getservent} (see below).") +#define FUNC_NAME s_scm_getserv +{ + struct servent *entry; + if (SCM_UNBNDP (name)) + { + entry = getservent (); + if (!entry) + { + /* There's no good way to tell whether zero means an error + or end-of-file, so we always return #f. See `gethost' + for details. */ + return SCM_BOOL_F; + } + return scm_return_entry (entry); + } + SCM_VALIDATE_STRING (2, protocol); + if (SCM_STRINGP (name)) + { + entry = getservbyname (SCM_STRING_CHARS (name), SCM_STRING_CHARS (protocol)); + } + else + { + SCM_VALIDATE_INUM (1, name); + entry = getservbyport (htons (SCM_INUM (name)), SCM_STRING_CHARS (protocol)); + } + if (!entry) + SCM_SYSERROR_MSG("no such service ~A", scm_list_1 (name), errno); + return scm_return_entry (entry); +} +#undef FUNC_NAME +#endif + +#if defined(HAVE_SETHOSTENT) && defined(HAVE_ENDHOSTENT) +SCM_DEFINE (scm_sethost, "sethost", 0, 1, 0, + (SCM stayopen), + "If @var{stayopen} is omitted, this is equivalent to @code{endhostent}.\n" + "Otherwise it is equivalent to @code{sethostent stayopen}.") +#define FUNC_NAME s_scm_sethost +{ + if (SCM_UNBNDP (stayopen)) + endhostent (); + else + sethostent (!SCM_FALSEP (stayopen)); + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME +#endif + +#if defined(HAVE_SETNETENT) && defined(HAVE_ENDNETENT) +SCM_DEFINE (scm_setnet, "setnet", 0, 1, 0, + (SCM stayopen), + "If @var{stayopen} is omitted, this is equivalent to @code{endnetent}.\n" + "Otherwise it is equivalent to @code{setnetent stayopen}.") +#define FUNC_NAME s_scm_setnet +{ + if (SCM_UNBNDP (stayopen)) + endnetent (); + else + setnetent (!SCM_FALSEP (stayopen)); + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME +#endif + +#if defined (HAVE_SETPROTOENT) && defined (HAVE_ENDPROTOENT) || defined (__MINGW32__) +SCM_DEFINE (scm_setproto, "setproto", 0, 1, 0, + (SCM stayopen), + "If @var{stayopen} is omitted, this is equivalent to @code{endprotoent}.\n" + "Otherwise it is equivalent to @code{setprotoent stayopen}.") +#define FUNC_NAME s_scm_setproto +{ + if (SCM_UNBNDP (stayopen)) + endprotoent (); + else + setprotoent (!SCM_FALSEP (stayopen)); + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME +#endif + +#if defined (HAVE_SETSERVENT) && defined (HAVE_ENDSERVENT) || defined (__MINGW32__) +SCM_DEFINE (scm_setserv, "setserv", 0, 1, 0, + (SCM stayopen), + "If @var{stayopen} is omitted, this is equivalent to @code{endservent}.\n" + "Otherwise it is equivalent to @code{setservent stayopen}.") +#define FUNC_NAME s_scm_setserv +{ + if (SCM_UNBNDP (stayopen)) + endservent (); + else + setservent (!SCM_FALSEP (stayopen)); + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME +#endif + + +void +scm_init_net_db () +{ + scm_add_feature ("net-db"); +#include "libguile/net_db.x" +} + +/* + Local Variables: + c-file-style: "gnu" + End: +*/