/* -*-C-*-
$Id: pruxsock.c,v 1.20 2001/06/02 01:06:01 cph Exp $
Copyright (c) 1990-2001 Massachusetts Institute of Technology
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 of the License, 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 program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
USA.
*/
/* Primitives for socket control. */
#include "scheme.h"
#include "prims.h"
/* This obtains the HAVE_SOCKETS definition. */
#ifdef __unix__
# include "ux.h"
#endif
/* Under OS/2, socket support is the default but can be disabled. */
#ifdef __OS2__
# ifndef DISABLE_SOCKET_SUPPORT
# define HAVE_SOCKETS 1
# define HAVE_UNIX_SOCKETS 1
# endif
#endif
/* Under Win32, socket support is the default but can be disabled. */
#ifdef __WIN32__
# ifndef DISABLE_SOCKET_SUPPORT
# define HAVE_SOCKETS 1
# undef HAVE_UNIX_SOCKETS
# endif
#endif
#ifdef HAVE_SOCKETS
#include "uxsock.h"
#define SOCKET_CODE(code) code
static PTR
DEFUN (arg_host, (arg), unsigned int arg)
{
CHECK_ARG (arg, STRING_P);
if ((STRING_LENGTH (ARG_REF (arg))) != (OS_host_address_length ()))
error_bad_range_arg (arg);
return (STRING_LOC ((ARG_REF (arg)), 0));
}
static Tchannel
DEFUN (arg_server_socket, (arg), unsigned int arg)
{
Tchannel server_socket = (arg_nonnegative_integer (arg));
if ((OS_channel_type (server_socket)) != channel_type_tcp_server_socket)
error_bad_range_arg (arg);
return (server_socket);
}
#else /* not HAVE_SOCKETS */
#define SOCKET_CODE(code) \
{ \
signal_error_from_primitive (ERR_UNIMPLEMENTED_PRIMITIVE); \
PRIMITIVE_RETURN (UNSPECIFIC); \
}
#endif /* not HAVE_SOCKETS */
DEFINE_PRIMITIVE ("GET-SERVICE-BY-NAME", Prim_get_service_by_name, 2, 2,
"Given SERVICE-NAME and PROTOCOL-NAME, return a port number.\n\
The result is a nonnegative integer, or #F if no such service exists.")
{
PRIMITIVE_HEADER (2);
SOCKET_CODE
({
int result
= (OS_get_service_by_name ((STRING_ARG (1)), (STRING_ARG (2))));
PRIMITIVE_RETURN ((result < 0) ? SHARP_F : (long_to_integer (result)));
});
}
DEFINE_PRIMITIVE ("GET-SERVICE-BY-NUMBER", Prim_get_service_by_number, 1, 1,
"Given PORT-NUMBER, return it in the network encoding.")
{
PRIMITIVE_HEADER (1);
SOCKET_CODE
({
PRIMITIVE_RETURN
(ulong_to_integer (OS_get_service_by_number (arg_ulong_integer (1))));
});
}
DEFINE_PRIMITIVE ("HOST-ADDRESS-LENGTH", Prim_host_address_length, 0, 0,
"The length of a host address string, in characters.")
{
PRIMITIVE_HEADER (0);
SOCKET_CODE
({
PRIMITIVE_RETURN (long_to_integer (OS_host_address_length ()));
});
}
DEFINE_PRIMITIVE ("GET-HOST-BY-NAME", Prim_get_host_by_name, 1, 1,
"Given HOST-NAME, return its internet host numbers.\n\
The result is a vector of strings, or #F if no such host exists.")
{
PRIMITIVE_HEADER (1);
SOCKET_CODE
({
char ** addresses = (OS_get_host_by_name (STRING_ARG (1)));
if (addresses == 0)
PRIMITIVE_RETURN (SHARP_F);
{
char ** end = addresses;
while ((*end++) != 0) ;
end -= 1;
{
SCHEME_OBJECT result =
(allocate_marked_vector (TC_VECTOR, (end - addresses), 1));
SCHEME_OBJECT * scan_result = (VECTOR_LOC (result, 0));
unsigned int length = (OS_host_address_length ());
while (addresses < end)
(*scan_result++) =
(memory_to_string (length, ((unsigned char *) (*addresses++))));
PRIMITIVE_RETURN (result);
}
}
});
}
DEFINE_PRIMITIVE ("GET-HOST-NAME", Prim_get_host_name, 0, 0, 0)
{
PRIMITIVE_HEADER (0);
SOCKET_CODE
({
CONST char * host_name = (OS_get_host_name ());
if (host_name == 0)
PRIMITIVE_RETURN (SHARP_F);
{
SCHEME_OBJECT result
= (char_pointer_to_string ((unsigned char *) host_name));
OS_free ((PTR) host_name);
PRIMITIVE_RETURN (result);
}
});
}
DEFINE_PRIMITIVE ("CANONICAL-HOST-NAME", Prim_canonical_host_name, 1, 1, 0)
{
PRIMITIVE_HEADER (1);
SOCKET_CODE
({
CONST char * host_name = (OS_canonical_host_name (STRING_ARG (1)));
if (host_name == 0)
PRIMITIVE_RETURN (SHARP_F);
{
SCHEME_OBJECT result
= (char_pointer_to_string ((unsigned char *) host_name));
OS_free ((PTR) host_name);
PRIMITIVE_RETURN (result);
}
});
}
DEFINE_PRIMITIVE ("GET-HOST-BY-ADDRESS", Prim_get_host_by_address, 1, 1, 0)
{
PRIMITIVE_HEADER (1);
SOCKET_CODE
({
CONST char * host_name = (OS_get_host_by_address (STRING_ARG (1)));
if (host_name == 0)
PRIMITIVE_RETURN (SHARP_F);
{
SCHEME_OBJECT result
= (char_pointer_to_string ((unsigned char *) host_name));
OS_free ((PTR) host_name);
PRIMITIVE_RETURN (result);
}
});
}
DEFINE_PRIMITIVE ("HOST-ADDRESS-ANY", Prim_host_address_any, 0, 0, 0)
{
PRIMITIVE_HEADER (0);
SOCKET_CODE
({
SCHEME_OBJECT result = (allocate_string (OS_host_address_length ()));
OS_host_address_any (STRING_LOC (result, 0));
PRIMITIVE_RETURN (result);
});
}
DEFINE_PRIMITIVE ("HOST-ADDRESS-LOOPBACK", Prim_host_address_loopback, 0, 0, 0)
{
PRIMITIVE_HEADER (0);
SOCKET_CODE
({
SCHEME_OBJECT result = (allocate_string (OS_host_address_length ()));
OS_host_address_loopback (STRING_LOC (result, 0));
PRIMITIVE_RETURN (result);
});
}
DEFINE_PRIMITIVE ("NEW-OPEN-TCP-STREAM-SOCKET", Prim_new_open_tcp_stream_socket, 3, 3,
"Given HOST-ADDRESS and PORT-NUMBER, open a TCP stream socket.\n\
The opened socket is stored in the cdr of WEAK-PAIR.")
{
PRIMITIVE_HEADER (3);
CHECK_ARG (3, WEAK_PAIR_P);
SOCKET_CODE
({
SET_PAIR_CDR
((ARG_REF (3)),
(long_to_integer
(OS_open_tcp_stream_socket ((arg_host (1)),
(arg_nonnegative_integer (2))))));
PRIMITIVE_RETURN (SHARP_T);
});
}
DEFINE_PRIMITIVE ("NEW-OPEN-UNIX-STREAM-SOCKET", Prim_new_open_unix_stream_socket, 2, 2,
"Open the unix stream socket FILENAME.\n\
The opened socket is stored in the cdr of WEAK-PAIR.")
{
PRIMITIVE_HEADER (2);
CHECK_ARG (2, WEAK_PAIR_P);
#ifdef HAVE_UNIX_SOCKETS
SET_PAIR_CDR
((ARG_REF (2)),
(long_to_integer (OS_open_unix_stream_socket (STRING_ARG (1)))));
#else
signal_error_from_primitive (ERR_UNIMPLEMENTED_PRIMITIVE);
#endif
PRIMITIVE_RETURN (SHARP_T);
}
DEFINE_PRIMITIVE ("NEW-OPEN-TCP-SERVER-SOCKET", Prim_new_open_tcp_server_socket, 2, 2,
"Given PORT-NUMBER, open TCP server socket.\n\
The opened socket is stored in the cdr of WEAK-PAIR.")
{
PRIMITIVE_HEADER (2);
CHECK_ARG (2, WEAK_PAIR_P);
SOCKET_CODE
({
Tchannel channel = (OS_create_tcp_server_socket ());
PTR address = (OS_malloc (OS_host_address_length ()));
OS_host_address_any (address);
OS_bind_tcp_server_socket
(channel, address, (arg_nonnegative_integer (1)));
OS_free (address);
OS_listen_tcp_server_socket (channel);
SET_PAIR_CDR ((ARG_REF (2)), (long_to_integer (channel)));
PRIMITIVE_RETURN (SHARP_T);
});
}
DEFINE_PRIMITIVE ("CREATE-TCP-SERVER-SOCKET", Prim_create_tcp_server_socket, 0, 0, 0)
{
PRIMITIVE_HEADER (0);
SOCKET_CODE
({
PRIMITIVE_RETURN (long_to_integer (OS_create_tcp_server_socket ()));
});
}
DEFINE_PRIMITIVE ("BIND-TCP-SERVER-SOCKET", Prim_bind_tcp_server_socket, 3, 3, 0)
{
PRIMITIVE_HEADER (3);
SOCKET_CODE
({
OS_bind_tcp_server_socket ((arg_server_socket (1)),
(arg_host (2)),
(arg_nonnegative_integer (3)));
PRIMITIVE_RETURN (UNSPECIFIC);
});
}
DEFINE_PRIMITIVE ("LISTEN-TCP-SERVER-SOCKET", Prim_listen_tcp_server_socket, 1, 1, 0)
{
PRIMITIVE_HEADER (1);
SOCKET_CODE
({
OS_listen_tcp_server_socket (arg_server_socket (1));
PRIMITIVE_RETURN (UNSPECIFIC);
});
}
DEFINE_PRIMITIVE ("NEW-TCP-SERVER-CONNECTION-ACCEPT", Prim_new_tcp_server_connection_accept, 3, 3,
"Poll SERVER-SOCKET for a connection.\n\
If a connection is available, it is opened and #T is returned;\n\
the opened socket is stored in the cdr of WEAK-PAIR.\n\
Otherwise, if SERVER-SOCKET is non-blocking, returns #F.\n\
Second argument PEER-ADDRESS, if not #F, must be a host address string.\n\
It is filled with the peer's address if given.")
{
PRIMITIVE_HEADER (3);
CHECK_ARG (3, WEAK_PAIR_P);
SOCKET_CODE
({
Tchannel server_socket = (arg_server_socket (1));
PTR peer_host = (((ARG_REF (2)) == SHARP_F) ? 0 : (arg_host (2)));
Tchannel connection =
(OS_server_connection_accept (server_socket, peer_host, 0));
if (connection == NO_CHANNEL)
PRIMITIVE_RETURN (SHARP_F);
SET_PAIR_CDR ((ARG_REF (3)), (long_to_integer (connection)));
PRIMITIVE_RETURN (SHARP_T);
});
}
syntax highlighted by Code2HTML, v. 0.9.1