scsh-conservatory
/
scsh-0.6
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Moved host/network/service/protocol-info to new FFI. Fixed some bugs 

in the old implementation.
This commit is contained in:
marting 2000-07-13 13:45:00 +00:00
parent 86fa3f59a4
commit 1154aad830
3 changed files with 229 additions and 279 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

127
scsh/network.scm
View File

@ -787,48 +787,30 @@
aliases ; Alternative names
net) ; Network number
(define-exported-binding "network-info-type" type/network-info)
(define (network-info arg)
(cond ((string? arg) (name->network-info arg))
((socket-address? arg) (address->network-info arg))
((socket-address? arg) (car (socket-address:address arg)))
(else
(error "network-info: string or socket-address expected ~s" arg))))
(define (address->network-info name)
(if (not (integer? name))
(error "address->network-info: integer expected ~s" name)
(let ((name (integer->string name))
(net (make-string 4)))
(receive (result name aliases)
(%net-address->network-info name net)
(make-network-info name
(vector->list
(C-string-vec->Scheme aliases #f))
(string->integer net))))))
(define-foreign %net-address->network-info
(scheme_net_address2net_info (string-desc name) (string-desc net))
(to-scheme fixnum "False_on_zero")
static-string ; net name
(C char**)) ; alias list
(define (address->network-info addr)
(if (not (byte-vector? addr))
(error "address->network-info: byte-vector expected ~s" addr)
(%net-address->network-info addr)))
(define-stubless-foreign %net-address->network-info (addr)
"scheme_net_address2net_info")
(define (name->network-info name)
(if (not (string? name))
(error "name->network-info: string expected ~s" name)
(let ((net (make-string 4)))
(receive (result name aliases)
(%net-name->network-info name net)
(make-network-info name
(vector->list
(C-string-vec->Scheme aliases #f))
(string->integer net))))))
(define-foreign %net-name->network-info
(scheme_net_name2net_info (string name) (string-desc net))
(to-scheme fixnum "False_on_zero")
static-string ; net name
(C char**)) ; alias list
(%net-name->network-info name)))
(define-stubless-foreign %net-name->network-info (name)
"scheme_net_name2net_info")
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
;;; service lookup
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
@ -838,6 +820,8 @@
port ; Port number
protocol) ; Protocol name
(define-exported-binding "service-info-type" type/service-info)
(define (service-info . args)
(apply (cond ((string? (car args)) name->service-info)
((integer? (car args)) port->service-info)
@ -851,35 +835,26 @@
((not (string? proto))
(error "port->service-info: string expected ~s" proto))
(else
(receive (result name aliases port protocol)
(%service-port->service-info name proto)
(make-service-info name
(vector->list (C-string-vec->Scheme aliases #f))
port
protocol))))))
(define-foreign %service-port->service-info
(scheme_serv_port2serv_info (fixnum name) (string proto))
(to-scheme fixnum "False_on_zero")
static-string ; service name
(C char**) ; alias list
fixnum ; port number
static-string) ; protocol name
(%service-port->service-info name (if (equal? "" proto)
#f
proto))))))
(define-stubless-foreign %service-port->service-info (port proto)
"scheme_serv_port2serv_info")
(define (name->service-info name . maybe-proto)
(receive (result name aliases port protocol)
(%service-name->service-info name (:optional maybe-proto ""))
(make-service-info name (vector->list (C-string-vec->Scheme aliases #f))
port protocol)))
(define-foreign %service-name->service-info
(scheme_serv_name2serv_info (string name) (string proto))
(to-scheme fixnum "False_on_zero")
static-string ; service name
(C char**) ; alias list
fixnum ; port number
static-string) ; protocol name
(let ((proto (:optional maybe-proto "")))
(cond ((not (string? name))
(error "name->service-info: integer expected ~s" name))
((not (string? proto))
(error "name->service-info: string expected ~s" proto))
(else
(%service-name->service-info name (if (equal? "" proto)
#f
proto))))))
(define-stubless-foreign %service-name->service-info (name proto)
"scheme_serv_name2serv_info")
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
;;; protocol lookup
@ -889,6 +864,8 @@
aliases ; Alternative names
number) ; Protocol number
(define-exported-binding "protocol-info-type" type/protocol-info)
(define (protocol-info arg)
(cond ((string? arg) (name->protocol-info arg))
((integer? arg) (number->protocol-info arg))
@ -897,36 +874,18 @@
(define (number->protocol-info name)
(if (not (integer? name))
(error "number->protocol-info: integer expected ~s" name)
(receive (result name aliases protocol)
(%protocol-port->protocol-info name)
(make-protocol-info name
(vector->list
(C-string-vec->Scheme aliases #f))
protocol))))
(%protocol-port->protocol-info name)))
(define-foreign %protocol-port->protocol-info
(scheme_proto_num2proto_info (fixnum name))
(to-scheme fixnum "False_on_zero")
static-string ; protocol name
(C char**) ; alias list
fixnum) ; protocol number
(define-stubless-foreign %protocol-port->protocol-info (name)
"scheme_proto_num2proto_info")
(define (name->protocol-info name)
(if (not (string? name))
(error "name->protocol-info: string expected ~s" name)
(receive (result name aliases protocol)
(%protocol-name->protocol-info name)
(make-protocol-info name
(vector->list
(C-string-vec->Scheme aliases #f))
protocol))))
(define-foreign %protocol-name->protocol-info
(scheme_proto_name2proto_info (string name))
(to-scheme fixnum "False_on_zero")
static-string ; protocol name
(C char**) ; alias list
fixnum) ; protocol number
(%protocol-name->protocol-info name)))
(define-stubless-foreign %protocol-name->protocol-info (name)
"scheme_proto_name2proto_info")
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
;;; Lowlevel junk

344
scsh/network1.c
View File

@ -22,12 +22,6 @@
#include "scheme48.h"
//extern int h_errno;
/* to extract a 4 byte long value from a scheme string */
#define GET_LONG(x,n) (*((u_long *)(S48_ADDRESS_AFTER_HEADER((x),unsigned char)+(n*4))))
#define SET_LONG(x,n,v) GET_LONG((x),(n))=(u_long)(v);
s48_value long2byte_vector (long number)
{
s48_value bv = s48_make_byte_vector (4, 0);
@ -75,17 +69,17 @@ s48_value scheme_bind(s48_value sock, s48_value family, s48_value scheme_name)
u_long addr = htonl(byte_vector2long (S48_CAR (scheme_name)));
u_short port = htons(s48_extract_fixnum (S48_CDR (scheme_name)));
fprintf(stderr, "binding to %d %d %d \n", port, addr,s48_extract_fixnum(S48_CDR (scheme_name)));
name.sin_family=AF_INET;
name.sin_addr.s_addr=addr;
name.sin_port=port;
if (bind(sockfd,(struct sockaddr *)&name,sizeof(name)) < 0)
s48_raise_os_error (errno);
fprintf(stderr, "bound to %d\n", port);
return S48_UNSPECIFIC;
}
default:
return(-1); /* error unknown address family */
s48_raise_argtype_error (family);
}
}
@ -151,7 +145,7 @@ s48_value scheme_connect(s48_value sock, s48_value family, s48_value scheme_name
}
default:
return(-1); /* error unknown address family */
s48_raise_argtype_error (family); /* error unknown address family */
}
}
@ -377,7 +371,7 @@ ssize_t send_substring(int s,
break;
}
default:
return(-1); /* error unknown address family */
s48_raise_argtype_error (family); /* error unknown address family */
}
}
@ -471,7 +465,7 @@ static s48_value host_info_type_binding = S48_FALSE;
s48_value host_ent2host_info (struct hostent * host)
{
s48_value host_info = S48_FALSE;
s48_value temp_vector = S48_FALSE;
s48_value list = S48_FALSE;
long * ptr;
int i;
S48_DECLARE_GC_PROTECT (2);
@ -487,36 +481,36 @@ s48_value host_ent2host_info (struct hostent * host)
host_info_type_binding = s48_get_imported_binding ("host-info-type");
}
S48_GC_PROTECT_2 (host_info, temp_vector);
S48_GC_PROTECT_2 (host_info, list);
host_info = s48_make_record (host_info_type_binding);
S48_RECORD_SET (host_info, 0, s48_enter_string (host->h_name));
ptr = (long *)host->h_aliases;
temp_vector = S48_NULL;
list = S48_NULL;
i = 0;
while (*ptr)
{
temp_vector = s48_cons (s48_enter_string (host->h_aliases[i]), temp_vector);
list = s48_cons (s48_enter_string (host->h_aliases[i]), list);
ptr++;
i ++;
}
S48_RECORD_SET (host_info, 1, temp_vector);
S48_RECORD_SET (host_info, 1, list);
ptr = (long *)host->h_addr_list;
temp_vector = S48_NULL;
list = S48_NULL;
i = 0;
while (*ptr)
{
temp_vector =
list =
s48_cons (long2byte_vector (ntohl (*(long *)(host->h_addr_list[i]))),
temp_vector);
list);
ptr++;
i++;
}
S48_RECORD_SET (host_info, 2, temp_vector);
S48_RECORD_SET (host_info, 2, list);
S48_GC_UNPROTECT ();
return host_info;
@ -552,182 +546,200 @@ s48_value scheme_host_name2host_info(s48_value s_name)
/*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-*/
/* Routines for looking up networks */
/*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-*/
int scheme_net_address2net_info(s48_value scheme_name,
s48_value scheme_net,
char** netname,
char*** aliases)
{
struct netent *net;
static s48_value network_info_type_binding = S48_FALSE;
net=getnetbyaddr(ntohl(GET_LONG(scheme_name,0)),AF_INET);
if(net==NULL)
{
*netname=NULL;
*aliases=NULL;
return(-1);
}
*netname=net->n_name;
*aliases=net->n_aliases;
SET_LONG(scheme_net,0,net->n_net);
return(0);
s48_value netent2net_info(struct netent *net)
{
s48_value network_info = S48_FALSE;
s48_value list = S48_FALSE;
long * ptr;
int i;
S48_DECLARE_GC_PROTECT (2);
if (net==NULL) return S48_FALSE;
if (network_info_type_binding == S48_FALSE)
{
S48_GC_PROTECT_GLOBAL(network_info_type_binding);
network_info_type_binding =
s48_get_imported_binding ("network-info-type");
}
S48_GC_PROTECT_2 (network_info, list);
network_info = s48_make_record (network_info_type_binding);
S48_RECORD_SET (network_info, 0, s48_enter_string (net->n_name));
ptr = (long *)net->n_aliases;
list = S48_NULL;
i = 0;
while (*ptr)
{
list = s48_cons (s48_enter_string (net->n_aliases[i]), list);
ptr++;
i++;
}
S48_RECORD_SET (network_info, 1, list);
S48_RECORD_SET (network_info, 2, long2byte_vector (net->n_net));
S48_GC_UNPROTECT ();
return network_info;
}
int scheme_net_name2net_info(const char* scheme_name,
s48_value scheme_net,
char** netname,
char*** aliases)
s48_value scheme_net_address2net_info(s48_value net_addr)
{
struct netent *net=getnetbyname(scheme_name);
struct netent *net;
// expects host byte order :
net=getnetbyaddr(byte_vector2long (net_addr),AF_INET);
if(net==NULL)
{
*netname=NULL;
*aliases=NULL;
return(-1);
}
*netname=net->n_name;
*aliases=net->n_aliases;
SET_LONG(scheme_net,0,net->n_net); /* ??? -Olin */
return(0);
return netent2net_info (net);
}
s48_value scheme_net_name2net_info(s48_value scheme_name)
{
struct netent *net = getnetbyname(s48_extract_string (scheme_name));
return netent2net_info (net);
}
/*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-*/
/* Routines for looking up services */
/*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-*/
/* in_port should be declared u_short, but cig doesn't know about them. */
int scheme_serv_port2serv_info(int in_port,
const char* in_proto,
char** out_servname,
char*** out_aliases,
int* out_port,
char** out_protocol)
{
struct servent *serv;
serv=getservbyport(ntohs(in_port),in_proto);
if(serv==NULL)
{
*out_servname=NULL;
*out_aliases=NULL;
*out_port=0;
*out_protocol=NULL;
return(-1);
}
*out_servname=serv->s_name;
*out_aliases =serv->s_aliases;
*out_port =(int)ntohs(serv->s_port);
*out_protocol=serv->s_proto;
return(0);
static s48_value service_info_type_binding = S48_FALSE;
s48_value servent2service_info(struct servent *serv)
{
s48_value service_info = S48_FALSE;
s48_value list = S48_FALSE;
long * ptr;
int i;
S48_DECLARE_GC_PROTECT (2);
if (serv==NULL) return S48_FALSE;
if (service_info_type_binding == S48_FALSE)
{
S48_GC_PROTECT_GLOBAL(service_info_type_binding);
service_info_type_binding =
s48_get_imported_binding ("service-info-type");
}
S48_GC_PROTECT_2 (service_info, list);
service_info = s48_make_record (service_info_type_binding);
S48_RECORD_SET (service_info, 0, s48_enter_string (serv->s_name));
ptr = (long *)serv->s_aliases;
list = S48_NULL;
i = 0;
while (*ptr)
{
list = s48_cons (s48_enter_string (serv->s_aliases[i]), list);
ptr++;
i++;
}
S48_RECORD_SET (service_info, 1, list);
S48_RECORD_SET (service_info, 2, s48_enter_fixnum (ntohs (serv->s_port)));
S48_RECORD_SET (service_info, 3, s48_enter_string (serv->s_proto));
S48_GC_UNPROTECT ();
return service_info;
}
int scheme_serv_name2serv_info(const char* in_name,
const char* in_proto,
char** out_servname,
char*** out_aliases,
int* out_port,
char** out_protocol)
s48_value scheme_serv_port2serv_info(s48_value in_port,
s48_value in_proto)
{
struct servent *serv=getservbyname(in_name,in_proto);
struct servent *serv;
char * proto;
if (in_proto == S48_FALSE) proto = NULL;
else proto = s48_extract_string (in_proto);
if(serv==NULL)
{
*out_servname=NULL;
*out_aliases=NULL;
*out_port=0;
*out_protocol=NULL;
return(-1);
}
serv = getservbyport(ntohs(s48_extract_fixnum (in_port)),
proto);
*out_servname=serv->s_name;
*out_aliases =serv->s_aliases;
*out_port =(int)ntohs(serv->s_port);
*out_protocol=serv->s_proto;
return(0);
return servent2service_info (serv);
}
s48_value scheme_serv_name2serv_info(s48_value in_name,
s48_value in_proto)
{
struct servent *serv;
char * proto;
if (in_proto == S48_FALSE) proto = NULL;
else proto = s48_extract_string (in_proto);
serv = getservbyname(s48_extract_string (in_name),
proto);
return servent2service_info (serv);
}
/*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-*/
/* Routines for looking up protocols */
/*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-*/
int scheme_proto_num2proto_info(int in_proto,
char** out_protoname,
char*** out_aliases,
int* out_protocol)
static s48_value protocol_info_type_binding = S48_FALSE;
s48_value protoent2protocol_info(struct protoent *proto)
{
s48_value protocol_info = S48_FALSE;
s48_value list = S48_FALSE;
long * ptr;
int i;
S48_DECLARE_GC_PROTECT (2);
if (proto==NULL) return S48_FALSE;
if (protocol_info_type_binding == S48_FALSE)
{
S48_GC_PROTECT_GLOBAL(protocol_info_type_binding);
protocol_info_type_binding =
s48_get_imported_binding ("protocol-info-type");
}
S48_GC_PROTECT_2 (protocol_info, list);
protocol_info = s48_make_record (protocol_info_type_binding);
S48_RECORD_SET (protocol_info, 0, s48_enter_string (proto->p_name));
ptr = (long *)proto->p_aliases;
list = S48_NULL;
i = 0;
while (*ptr)
{
list = s48_cons (s48_enter_string (proto->p_aliases[i]), list);
ptr++;
i++;
}
S48_RECORD_SET (protocol_info, 1, list);
S48_RECORD_SET (protocol_info, 2, s48_enter_fixnum (proto->p_proto));
S48_GC_UNPROTECT ();
return protocol_info;
}
s48_value scheme_proto_num2proto_info(s48_value in_proto)
{
struct protoent *proto;
proto=getprotobynumber(in_proto);
proto=getprotobynumber(s48_extract_fixnum (in_proto));
if(proto==NULL)
{
*out_protoname=NULL;
*out_aliases=NULL;
*out_protocol=0;
return(-1);
}
*out_protoname=proto->p_name;
*out_aliases =proto->p_aliases;
*out_protocol =proto->p_proto;
return(0);
return protoent2protocol_info (proto);
}
int scheme_proto_name2proto_info(const char* in_name,
char** out_protoname,
char*** out_aliases,
int* out_protocol)
s48_value scheme_proto_name2proto_info(s48_value in_name)
{
struct protoent *proto=getprotobyname(in_name);
if(proto==NULL)
{
*out_protoname=NULL;
*out_aliases=NULL;
*out_protocol=0;
return(-1);
}
*out_protoname=proto->p_name;
*out_aliases =proto->p_aliases;
*out_protocol =proto->p_proto;
return(0);
struct protoent *proto=getprotobyname(s48_extract_string (in_name));
return protoent2protocol_info (proto);
}
/*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-*/
/* Low Level Junk */
/*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-*/
/* svec is a Scheme vector of C carriers. Scan over the C longs
** in cvec, and initialise the corresponding carriers in svec.
*/
void set_longvec_carriers(s48_value svec, long const * const * cvec)
{
int svec_len = S48_VECTOR_LENGTH(svec);
long const * const *cv = cvec;
s48_value s = S48_VECTOR_REF(svec,0); //JMG hack
s48_value *sv = &s;
for(; svec_len > 0; cv++, sv++, svec_len-- ) {
/* *sv is a (make-string 4) */
s48_value carrier = *sv;
(*((u_long *)(S48_ADDRESS_AFTER_HEADER(carrier,unsigned char))))
=(long)**cv;
}
}
/* One arg, a zero-terminated C word vec. Returns length.
** The terminating null is not counted. Returns #f on NULL.
*/
s48_value veclen(const long *vec)
{
const long *vptr = vec;
if( !vptr ) return S48_FALSE;
while( *vptr ) vptr++;
return s48_enter_fixnum(vptr - vec);
}

37
scsh/network1.h
View File

@ -52,42 +52,21 @@ s48_value scheme_host_address2host_info(s48_value scheme_byte_vector);
s48_value scheme_host_name2host_info(s48_value scheme_name);
int scheme_net_address2net_info(s48_value scheme_name,
s48_value scheme_net,
char** netname,
char*** aliases);
int scheme_net_name2net_info(const char* scheme_name,
s48_value scheme_net,
char** netname,
char*** aliases);
s48_value scheme_net_address2net_info(s48_value net_addr);
s48_value scheme_net_name2net_info(s48_value scheme_name);
/* in_port should be declared u_short, but cig doesn't know about them. */
int scheme_serv_port2serv_info(int in_port,
const char* in_proto,
char** out_servname,
char*** out_aliases,
int* out_port,
char** out_protocol);
s48_value scheme_serv_port2serv_info(s48_value in_port,
s48_value in_proto);
int scheme_serv_name2serv_info(const char* in_name,
const char* in_proto,
char** out_servname,
char*** out_aliases,
int* out_port,
char** out_protocol);
s48_value scheme_serv_name2serv_info(s48_value in_name,
s48_value in_proto);
int scheme_proto_num2proto_info(int in_proto,
char** out_protoname,
char*** out_aliases,
int* out_protocol);
s48_value scheme_proto_num2proto_info(s48_value in_proto);
int scheme_proto_name2proto_info(const char* in_name,
char** out_protoname,
char*** out_aliases,
int* out_protocol);
s48_value scheme_proto_name2proto_info(s48_value name);
void set_longvec_carriers(s48_value svec, long const * const * cvec);