Shifted receive/send-message to non-blocking sockets.
This commit is contained in:
marting
parent
1154aad830
commit
27bafee1bc
150
scsh/network.scm
150
scsh/network.scm
|
|
@ -38,7 +38,9 @@
|
|||
(byte-vector-set! bv 3 (bitwise-and (arithmetic-shift number -24) #xff))
|
||||
bv))
|
||||
|
||||
|
||||
(set! internet-address/any (integer->byte-vector internet-address/any ))
|
||||
(set! internet-address/loopback (integer->byte-vector internet-address/loopback ))
|
||||
(set! internet-address/broadcast (integer->byte-vector internet-address/broadcast ))
|
||||
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
|
||||
;;; High Level Prototypes
|
||||
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
|
||||
|
|
@ -221,13 +223,6 @@
|
|||
(socket-address:address name)))))))
|
||||
|
||||
(define-stubless-foreign %bind (sockfd family name) "scheme_bind")
|
||||
;(define-foreign %bind/errno
|
||||
; (scheme_bind (fixnum sockfd) ; socket fdes
|
||||
; (fixnum family) ; address family
|
||||
; (string-desc name)) ; scheme descriptor
|
||||
; (to-scheme fixnum errno_or_false))
|
||||
|
||||
;(define-errno-syscall (%bind sockfd family name) %bind/errno)
|
||||
|
||||
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
|
||||
;;; connect syscall
|
||||
|
|
@ -264,7 +259,7 @@
|
|||
(define (handle-EINPROGRESS sock)
|
||||
(let ((val (socket-option sock level/socket socket/error)))
|
||||
(if (not (zero? val))
|
||||
(errno-error val "scheme_connnect"))))
|
||||
(errno-error val "scheme_connect"))))
|
||||
|
||||
(define-stubless-foreign %connect (sockfd family name) "scheme_connect")
|
||||
|
||||
|
|
@ -296,7 +291,6 @@
|
|||
(let ((family (socket:family sock)))
|
||||
(let loop ()
|
||||
((structure-ref interrupts disable-interrupts!))
|
||||
(display (socket->fdes sock) (current-error-port))
|
||||
(let ((fd-addr (%accept (socket->fdes sock) family)))
|
||||
(cond ((pair? fd-addr)
|
||||
(let ((fd (car fd-addr))
|
||||
|
|
@ -420,32 +414,28 @@
|
|||
(error "receive-message!: integer expected ~s ~s ~s"
|
||||
flags start end))
|
||||
(else
|
||||
(generic-receive-message! (socket->fdes socket) flags
|
||||
(generic-receive-message! socket flags
|
||||
s start end
|
||||
recv-substring!/errno
|
||||
recv-substring!
|
||||
(socket:family socket)))))))
|
||||
|
||||
(define (generic-receive-message! sockfd flags s start end reader from)
|
||||
(define (generic-receive-message! socket flags s start end reader family)
|
||||
(if (bogus-substring-spec? s start end)
|
||||
(error "Bad substring indices"
|
||||
reader sockfd flags
|
||||
s start end from))
|
||||
(let ((addr (make-addr from)))
|
||||
(let loop ((i start))
|
||||
(if (>= i end) (- i start)
|
||||
(receive (err nread)
|
||||
(reader sockfd flags s i end addr)
|
||||
(cond (err (if (= err errno/intr) (loop i)
|
||||
;; Give info on partially-read data in error packet.
|
||||
(errno-error err reader sockfd flags
|
||||
s start i end addr)))
|
||||
|
||||
((zero? nread) ; EOF
|
||||
reader socket flags
|
||||
s start end family))
|
||||
(let loop ((i start) (remote #f))
|
||||
(if (>= i end)
|
||||
(values (- i start) (make-socket-address family remote))
|
||||
(let* ((res (reader socket flags s i end)))
|
||||
(apply (lambda (nread from)
|
||||
(cond ((zero? nread) ; EOF
|
||||
(values
|
||||
(let ((result (- i start)))
|
||||
(and (not (zero? result)) result))
|
||||
from))
|
||||
(else (loop (+ i nread)))))))))
|
||||
(make-socket-address family from)))
|
||||
(else (loop (+ i nread) from))))
|
||||
res)))))
|
||||
|
||||
(define (receive-message/partial socket len . maybe-flags)
|
||||
(let ((flags (:optional maybe-flags 0)))
|
||||
|
|
@ -475,46 +465,41 @@
|
|||
(error "receive-message!/partial: integer expected ~s"
|
||||
flags))
|
||||
(else
|
||||
(generic-receive-message!/partial (socket->fdes socket)
|
||||
(generic-receive-message!/partial socket
|
||||
flags
|
||||
s start end
|
||||
recv-substring!/errno
|
||||
recv-substring!
|
||||
(socket:family socket)))))))
|
||||
|
||||
(define (generic-receive-message!/partial sockfd flags s start end reader from)
|
||||
(define (generic-receive-message!/partial socket flags s start end reader from)
|
||||
(if (bogus-substring-spec? s start end)
|
||||
(error "Bad substring indices" reader s start end))
|
||||
|
||||
(if (= start end) 0 ; Vacuous request.
|
||||
(let ((addr (make-addr from)))
|
||||
(let loop ()
|
||||
(receive (err nread)
|
||||
(reader sockfd flags s start end addr)
|
||||
|
||||
(cond ((not err)
|
||||
(apply (lambda (nread addr)
|
||||
(values (and (not (zero? nread)) nread)
|
||||
(make-socket-address from addr)))
|
||||
(reader socket flags s start end)))))
|
||||
|
||||
((= err errno/intr) (loop))
|
||||
|
||||
; No forward-progess here.
|
||||
((or (= err errno/wouldblock)
|
||||
(= err errno/again))
|
||||
0)
|
||||
|
||||
(else (errno-error err reader sockfd flags
|
||||
s start start end addr))))))))
|
||||
|
||||
(define-foreign recv-substring!/errno
|
||||
(recv_substring (fixnum sockfd)
|
||||
(fixnum flags)
|
||||
(string-desc buf)
|
||||
(size_t start)
|
||||
(size_t end)
|
||||
(string-desc name))
|
||||
(multi-rep (to-scheme ssize_t errno_or_false)
|
||||
ssize_t))
|
||||
(define (recv-substring! socket flags buf start end)
|
||||
(let loop ()
|
||||
((structure-ref interrupts disable-interrupts!))
|
||||
(let ((maybe-size-addr
|
||||
(%recv-substring! (socket->fdes socket)
|
||||
flags buf start end)))
|
||||
(cond (maybe-size-addr
|
||||
((structure-ref interrupts
|
||||
enable-interrupts!))
|
||||
maybe-size-addr)
|
||||
(else (wait-for-channel
|
||||
(fdport-data:channel
|
||||
(fdport-data (socket:inport socket))))
|
||||
(loop))))))
|
||||
|
||||
(define-stubless-foreign %recv-substring! (sockfd flags buf start end)
|
||||
"recv_substring")
|
||||
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
|
||||
;;; send syscall
|
||||
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
|
||||
|
|
@ -530,24 +515,19 @@
|
|||
(else
|
||||
(generic-send-message (socket->fdes socket) flags
|
||||
s start end
|
||||
send-substring/errno
|
||||
send-substring
|
||||
(if addr (socket-address:family addr) 0)
|
||||
(and addr (socket-address:address addr)))))))
|
||||
(if addr (socket-address:address addr) #f))))))
|
||||
|
||||
(define (generic-send-message sockfd flags s start end writer family addr)
|
||||
(if (bogus-substring-spec? s start end)
|
||||
(error "Bad substring indices"
|
||||
sockfd flags family addr
|
||||
s start end writer))
|
||||
(let ((addr (if addr (make-addr family) "")))
|
||||
|
||||
(let loop ((i start))
|
||||
(if (< i end)
|
||||
(receive (err nwritten)
|
||||
(writer sockfd flags s i end family addr)
|
||||
(cond ((not err) (loop (+ i nwritten)))
|
||||
((= err errno/intr) (loop i))
|
||||
(else (errno-error err sockfd flags family addr
|
||||
s start i end writer))))))))
|
||||
(loop (+ i (writer sockfd flags s i end family addr))))))
|
||||
|
||||
|
||||
(define (send-message/partial socket s . args)
|
||||
|
|
@ -561,36 +541,38 @@
|
|||
(else
|
||||
(generic-send-message/partial (socket->fdes socket) flags
|
||||
s start end
|
||||
send-substring/errno
|
||||
send-substring
|
||||
(if addr (socket-address:family addr) 0)
|
||||
(if addr (socket-address:address addr)))))))
|
||||
(if addr
|
||||
(socket-address:address addr)
|
||||
#f))))))
|
||||
|
||||
(define (generic-send-message/partial sockfd flags s start end writer family addr)
|
||||
(define (generic-send-message/partial sockfd flags s start end writer family
|
||||
addr)
|
||||
(if (bogus-substring-spec? s start end)
|
||||
(error "Bad substring indices"
|
||||
sockfd flags family addr
|
||||
s start end writer))
|
||||
(if (= start end)
|
||||
0 ; Vacuous request.
|
||||
(writer sockfd flags s start end family addr)))
|
||||
|
||||
(if (= start end) 0 ; Vacuous request.
|
||||
(define (send-substring sockfd flags buf start end family name)
|
||||
(let loop ()
|
||||
(receive (err nwritten)
|
||||
(writer sockfd flags s start end family addr)
|
||||
(cond ((not err) nwritten)
|
||||
((= err errno/intr) (loop))
|
||||
((or (= err errno/again) (= err errno/wouldblock)) 0)
|
||||
(else (errno-error err sockfd flags family addr
|
||||
s start start end writer)))))))
|
||||
((structure-ref interrupts disable-interrupts!))
|
||||
(cond ((%send-substring sockfd flags buf start end family name)
|
||||
=> (lambda (nwritten)
|
||||
((structure-ref interrupts
|
||||
enable-interrupts!))
|
||||
nwritten))
|
||||
(else (wait-for-channel
|
||||
(fdport-data:channel
|
||||
(fdport-data (socket:inport socket))))
|
||||
(loop)))))
|
||||
|
||||
(define-foreign send-substring/errno
|
||||
(send_substring (fixnum sockfd)
|
||||
(fixnum flags)
|
||||
(string-desc buf)
|
||||
(size_t start)
|
||||
(size_t end)
|
||||
(fixnum family)
|
||||
(string-desc name))
|
||||
(multi-rep (to-scheme ssize_t errno_or_false)
|
||||
ssize_t))
|
||||
(define-stubless-foreign
|
||||
%send-substring (sockfd flags buf start end family name)
|
||||
"send_substring")
|
||||
|
||||
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
|
||||
;;; getsockopt syscall
|
||||
|
|
|
|||
149
scsh/network1.c
149
scsh/network1.c
|
|
@ -22,6 +22,12 @@
|
|||
#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);
|
||||
|
|
@ -278,64 +284,59 @@ int scheme_socket_pair(int type, int *s1, int *s2)
|
|||
}
|
||||
|
||||
/*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-*/
|
||||
ssize_t recv_substring(int s,
|
||||
int flags,
|
||||
s48_value buf,
|
||||
size_t start,
|
||||
size_t end,
|
||||
s48_value scheme_name)
|
||||
{
|
||||
|
||||
switch(S48_STRING_LENGTH(scheme_name))
|
||||
{
|
||||
#ifdef NOTUSED
|
||||
/* no longer used. always return remote socket info */
|
||||
case 0: /* only with connected sockets */
|
||||
{
|
||||
return recv(s, StrByte(buf,start), end-start, flags);
|
||||
}
|
||||
#endif
|
||||
case 8: /* AF_INET */
|
||||
s48_value
|
||||
recv_substring(s48_value scm_sockfd, s48_value flags, s48_value buf,
|
||||
s48_value scm_start, s48_value scm_end)
|
||||
{
|
||||
struct sockaddr_in name;
|
||||
int namelen=sizeof(name);
|
||||
int cc=recvfrom(s,
|
||||
StrByte(buf,start), end-start,
|
||||
flags,
|
||||
int sockfd = s48_extract_fixnum (scm_sockfd);
|
||||
int start = s48_extract_fixnum (scm_start);
|
||||
int end = s48_extract_fixnum (scm_end);
|
||||
char* buf_part = s48_extract_string (buf) + start;
|
||||
|
||||
int cc=recvfrom(sockfd,
|
||||
buf_part, end-start,
|
||||
s48_extract_fixnum (flags),
|
||||
(struct sockaddr *)&name, &namelen);
|
||||
s48_value result;
|
||||
S48_DECLARE_GC_PROTECT(1);
|
||||
if (cc < 0) s48_raise_os_error (errno);
|
||||
|
||||
result = make_addr (name.sin_addr.s_addr,
|
||||
htonl((u_long)ntohs(name.sin_port)));
|
||||
S48_GC_PROTECT_1 (result);
|
||||
if (cc >= 0)
|
||||
return (s48_cons (s48_enter_fixnum (cc),
|
||||
s48_cons (make_addr (name.sin_addr.s_addr,
|
||||
htonl((u_long)ntohs(name.sin_port))),
|
||||
S48_NULL)));
|
||||
|
||||
result = (s48_cons (s48_enter_fixnum (cc), result));
|
||||
S48_GC_UNPROTECT();
|
||||
return result;
|
||||
break;
|
||||
}
|
||||
default:
|
||||
s48_raise_argtype_error (s48_enter_fixnum (-1)); /* error unknown address family */
|
||||
}
|
||||
|
||||
if ((errno != EWOULDBLOCK) && (errno != EINTR) && (errno != EAGAIN))
|
||||
s48_raise_os_error(errno);
|
||||
if (! s48_add_pending_fd(sockfd, 1))// 1 for is_input
|
||||
s48_raise_out_of_memory_error();
|
||||
return S48_FALSE;
|
||||
}
|
||||
|
||||
/*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-*/
|
||||
ssize_t send_substring(int s,
|
||||
int flags,
|
||||
s48_value send_substring(s48_value scm_sockfd,
|
||||
s48_value scm_flags,
|
||||
s48_value buf,
|
||||
size_t start,
|
||||
size_t end,
|
||||
int family,
|
||||
s48_value scm_start,
|
||||
s48_value scm_end,
|
||||
s48_value scm_family,
|
||||
s48_value scheme_name)
|
||||
{
|
||||
int n;
|
||||
int s = s48_extract_fixnum (scm_sockfd);
|
||||
int flags = s48_extract_fixnum (scm_flags);
|
||||
int start = s48_extract_fixnum (scm_start);
|
||||
int end = s48_extract_fixnum (scm_end);
|
||||
char* buf_part = s48_extract_string (buf) + start;
|
||||
|
||||
switch(family)
|
||||
switch(s48_extract_fixnum (scm_family))
|
||||
{
|
||||
case 0: /* only with connected sockets */
|
||||
{
|
||||
return send(s, StrByte(buf,start), end-start, flags);
|
||||
n = send(s, buf_part, end-start, flags);
|
||||
break;
|
||||
}
|
||||
case AF_UNIX:
|
||||
{
|
||||
|
|
@ -349,32 +350,46 @@ ssize_t send_substring(int s,
|
|||
s48_extract_string(scheme_name),
|
||||
scheme_length); /* copy to c string */
|
||||
name.sun_path[scheme_length]='\0'; /* add null */
|
||||
return(sendto(s,
|
||||
StrByte(buf,start), end-start,
|
||||
n = sendto(s,
|
||||
buf_part, end-start,
|
||||
flags,
|
||||
(struct sockaddr *)&name, sizeof(name)));
|
||||
(struct sockaddr *)&name, sizeof(name));
|
||||
break;
|
||||
}
|
||||
case AF_INET:
|
||||
{
|
||||
struct sockaddr_in name;
|
||||
u_long addr=GET_LONG(scheme_name,0);
|
||||
u_short port=htons((u_short)ntohl(GET_LONG(scheme_name,1)));
|
||||
u_long addr = htonl (byte_vector2long (S48_CAR (scheme_name)));
|
||||
u_short port = htons(s48_extract_fixnum (S48_CDR (scheme_name)));
|
||||
name.sin_family=AF_INET;
|
||||
name.sin_addr.s_addr=addr;
|
||||
name.sin_port=port;
|
||||
|
||||
return(sendto(s,
|
||||
StrByte(buf,start), end-start,
|
||||
n = sendto(s,
|
||||
buf_part, end-start,
|
||||
flags,
|
||||
(struct sockaddr *)&name, sizeof(name)));
|
||||
(struct sockaddr *)&name, sizeof(name));
|
||||
break;
|
||||
}
|
||||
default:
|
||||
s48_raise_argtype_error (family); /* error unknown address family */
|
||||
s48_raise_argtype_error (s48_extract_fixnum (scm_family));
|
||||
/* error unknown address family */
|
||||
}
|
||||
|
||||
if (n >= 0)
|
||||
return s48_enter_fixnum (n);
|
||||
|
||||
if ((errno != EWOULDBLOCK) && (errno != EINTR) && (errno != EAGAIN))
|
||||
s48_raise_os_error(errno);
|
||||
|
||||
if (! s48_add_pending_fd(s, 0))// 0 for is_input
|
||||
s48_raise_out_of_memory_error();
|
||||
|
||||
return S48_FALSE;
|
||||
}
|
||||
|
||||
|
||||
|
||||
/*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-*/
|
||||
int scheme_getsockopt (int s,
|
||||
int level,
|
||||
|
|
@ -742,4 +757,38 @@ s48_value scheme_proto_name2proto_info(s48_value in_name)
|
|||
}
|
||||
|
||||
|
||||
/*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-*/
|
||||
/* 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);
|
||||
}
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -13,11 +13,12 @@ s48_value scheme_socket_name(s48_value sockfd, s48_value family);
|
|||
|
||||
int scheme_socket_pair(int type, int *s1, int *s2);
|
||||
|
||||
ssize_t recv_substring(int s, int flags, s48_value buf,
|
||||
size_t start, size_t end, s48_value scheme_name);
|
||||
s48_value recv_substring(s48_value s, s48_value flags, s48_value buf,
|
||||
s48_value start, s48_value end);
|
||||
|
||||
ssize_t send_substring(int s, int flags, s48_value buf, size_t start, size_t end,
|
||||
int family, s48_value scheme_name);
|
||||
s48_value send_substring(s48_value s, s48_value flags, s48_value buf,
|
||||
s48_value start, s48_value end, s48_value family,
|
||||
s48_value scheme_name);
|
||||
|
||||
int scheme_getsockopt (int s, int level, int optname);
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue