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

Shifted receive/send-message to non-blocking sockets.

This commit is contained in:
marting 2000-07-14 16:30:02 +00:00
parent 1154aad830
commit 27bafee1bc
3 changed files with 188 additions and 156 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

162
scsh/network.scm
View File

@ -38,7 +38,9 @@
(byte-vector-set! bv 3 (bitwise-and (arithmetic-shift number -24) #xff)) (byte-vector-set! bv 3 (bitwise-and (arithmetic-shift number -24) #xff))
bv)) 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 ;;; High Level Prototypes
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- ;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
@ -221,13 +223,6 @@
(socket-address:address name))))))) (socket-address:address name)))))))
(define-stubless-foreign %bind (sockfd family name) "scheme_bind") (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 ;;; connect syscall
@ -264,7 +259,7 @@
(define (handle-EINPROGRESS sock) (define (handle-EINPROGRESS sock)
(let ((val (socket-option sock level/socket socket/error))) (let ((val (socket-option sock level/socket socket/error)))
(if (not (zero? val)) (if (not (zero? val))
(errno-error val "scheme_connnect")))) (errno-error val "scheme_connect"))))
(define-stubless-foreign %connect (sockfd family name) "scheme_connect") (define-stubless-foreign %connect (sockfd family name) "scheme_connect")
@ -296,7 +291,6 @@
(let ((family (socket:family sock))) (let ((family (socket:family sock)))
(let loop () (let loop ()
((structure-ref interrupts disable-interrupts!)) ((structure-ref interrupts disable-interrupts!))
(display (socket->fdes sock) (current-error-port))
(let ((fd-addr (%accept (socket->fdes sock) family))) (let ((fd-addr (%accept (socket->fdes sock) family)))
(cond ((pair? fd-addr) (cond ((pair? fd-addr)
(let ((fd (car fd-addr)) (let ((fd (car fd-addr))
@ -420,32 +414,28 @@
(error "receive-message!: integer expected ~s ~s ~s" (error "receive-message!: integer expected ~s ~s ~s"
flags start end)) flags start end))
(else (else
(generic-receive-message! (socket->fdes socket) flags (generic-receive-message! socket flags
s start end s start end
recv-substring!/errno recv-substring!
(socket:family socket))))))) (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) (if (bogus-substring-spec? s start end)
(error "Bad substring indices" (error "Bad substring indices"
reader sockfd flags reader socket flags
s start end from)) s start end family))
(let ((addr (make-addr from))) (let loop ((i start) (remote #f))
(let loop ((i start)) (if (>= i end)
(if (>= i end) (- i start) (values (- i start) (make-socket-address family remote))
(receive (err nread) (let* ((res (reader socket flags s i end)))
(reader sockfd flags s i end addr) (apply (lambda (nread from)
(cond (err (if (= err errno/intr) (loop i) (cond ((zero? nread) ; EOF
;; Give info on partially-read data in error packet. (values
(errno-error err reader sockfd flags (let ((result (- i start)))
s start i end addr))) (and (not (zero? result)) result))
(make-socket-address family from)))
((zero? nread) ; EOF (else (loop (+ i nread) from))))
(values res)))))
(let ((result (- i start)))
(and (not (zero? result)) result))
from))
(else (loop (+ i nread)))))))))
(define (receive-message/partial socket len . maybe-flags) (define (receive-message/partial socket len . maybe-flags)
(let ((flags (:optional maybe-flags 0))) (let ((flags (:optional maybe-flags 0)))
@ -475,46 +465,41 @@
(error "receive-message!/partial: integer expected ~s" (error "receive-message!/partial: integer expected ~s"
flags)) flags))
(else (else
(generic-receive-message!/partial (socket->fdes socket) (generic-receive-message!/partial socket
flags flags
s start end s start end
recv-substring!/errno recv-substring!
(socket:family socket))))))) (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) (if (bogus-substring-spec? s start end)
(error "Bad substring indices" reader s start end)) (error "Bad substring indices" reader s start end))
(if (= start end) 0 ; Vacuous request. (if (= start end) 0 ; Vacuous request.
(let ((addr (make-addr from)))
(let loop () (let loop ()
(receive (err nread) (apply (lambda (nread addr)
(reader sockfd flags s start end addr)
(cond ((not err)
(values (and (not (zero? nread)) nread) (values (and (not (zero? nread)) nread)
(make-socket-address from addr))) (make-socket-address from addr)))
(reader socket flags s start end)))))
((= err errno/intr) (loop)) (define (recv-substring! socket flags buf start end)
(let loop ()
; No forward-progess here. ((structure-ref interrupts disable-interrupts!))
((or (= err errno/wouldblock) (let ((maybe-size-addr
(= err errno/again)) (%recv-substring! (socket->fdes socket)
0) flags buf start end)))
(cond (maybe-size-addr
(else (errno-error err reader sockfd flags ((structure-ref interrupts
s start start end addr)))))))) enable-interrupts!))
maybe-size-addr)
(define-foreign recv-substring!/errno (else (wait-for-channel
(recv_substring (fixnum sockfd) (fdport-data:channel
(fixnum flags) (fdport-data (socket:inport socket))))
(string-desc buf) (loop))))))
(size_t start)
(size_t end)
(string-desc name))
(multi-rep (to-scheme ssize_t errno_or_false)
ssize_t))
(define-stubless-foreign %recv-substring! (sockfd flags buf start end)
"recv_substring")
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- ;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
;;; send syscall ;;; send syscall
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- ;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
@ -530,24 +515,19 @@
(else (else
(generic-send-message (socket->fdes socket) flags (generic-send-message (socket->fdes socket) flags
s start end s start end
send-substring/errno send-substring
(if addr (socket-address:family addr) 0) (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) (define (generic-send-message sockfd flags s start end writer family addr)
(if (bogus-substring-spec? s start end) (if (bogus-substring-spec? s start end)
(error "Bad substring indices" (error "Bad substring indices"
sockfd flags family addr sockfd flags family addr
s start end writer)) s start end writer))
(let ((addr (if addr (make-addr family) "")))
(let loop ((i start)) (let loop ((i start))
(if (< i end) (if (< i end)
(receive (err nwritten) (loop (+ i (writer sockfd flags s i end family addr))))))
(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))))))))
(define (send-message/partial socket s . args) (define (send-message/partial socket s . args)
@ -561,36 +541,38 @@
(else (else
(generic-send-message/partial (socket->fdes socket) flags (generic-send-message/partial (socket->fdes socket) flags
s start end s start end
send-substring/errno send-substring
(if addr (socket-address:family addr) 0) (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) (if (bogus-substring-spec? s start end)
(error "Bad substring indices" (error "Bad substring indices"
sockfd flags family addr sockfd flags family addr
s start end writer)) 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 () (let loop ()
(receive (err nwritten) ((structure-ref interrupts disable-interrupts!))
(writer sockfd flags s start end family addr) (cond ((%send-substring sockfd flags buf start end family name)
(cond ((not err) nwritten) => (lambda (nwritten)
((= err errno/intr) (loop)) ((structure-ref interrupts
((or (= err errno/again) (= err errno/wouldblock)) 0) enable-interrupts!))
(else (errno-error err sockfd flags family addr nwritten))
s start start end writer))))))) (else (wait-for-channel
(fdport-data:channel
(fdport-data (socket:inport socket))))
(loop)))))
(define-foreign send-substring/errno (define-stubless-foreign
(send_substring (fixnum sockfd) %send-substring (sockfd flags buf start end family name)
(fixnum flags) "send_substring")
(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))
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- ;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
;;; getsockopt syscall ;;; getsockopt syscall

173
scsh/network1.c
View File

@ -22,6 +22,12 @@
#include "scheme48.h" #include "scheme48.h"
//extern int h_errno; //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 long2byte_vector (long number)
{ {
s48_value bv = s48_make_byte_vector (4, 0); 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, s48_value
int flags, recv_substring(s48_value scm_sockfd, s48_value flags, s48_value buf,
s48_value buf, s48_value scm_start, s48_value scm_end)
size_t start,
size_t end,
s48_value scheme_name)
{ {
struct sockaddr_in name;
switch(S48_STRING_LENGTH(scheme_name)) int namelen=sizeof(name);
{ int sockfd = s48_extract_fixnum (scm_sockfd);
#ifdef NOTUSED int start = s48_extract_fixnum (scm_start);
/* no longer used. always return remote socket info */ int end = s48_extract_fixnum (scm_end);
case 0: /* only with connected sockets */ char* buf_part = s48_extract_string (buf) + start;
{
return recv(s, StrByte(buf,start), end-start, flags); int cc=recvfrom(sockfd,
} buf_part, end-start,
#endif s48_extract_fixnum (flags),
case 8: /* AF_INET */ (struct sockaddr *)&name, &namelen);
{ s48_value result;
struct sockaddr_in name;
int namelen=sizeof(name); if (cc >= 0)
int cc=recvfrom(s, return (s48_cons (s48_enter_fixnum (cc),
StrByte(buf,start), end-start, s48_cons (make_addr (name.sin_addr.s_addr,
flags, htonl((u_long)ntohs(name.sin_port))),
(struct sockaddr *)&name, &namelen); S48_NULL)));
s48_value result;
S48_DECLARE_GC_PROTECT(1);
if (cc < 0) s48_raise_os_error (errno); if ((errno != EWOULDBLOCK) && (errno != EINTR) && (errno != EAGAIN))
s48_raise_os_error(errno);
result = make_addr (name.sin_addr.s_addr, if (! s48_add_pending_fd(sockfd, 1))// 1 for is_input
htonl((u_long)ntohs(name.sin_port))); s48_raise_out_of_memory_error();
S48_GC_PROTECT_1 (result); return S48_FALSE;
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 */
}
} }
/*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-*/ /*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-*/
ssize_t send_substring(int s, s48_value send_substring(s48_value scm_sockfd,
int flags, s48_value scm_flags,
s48_value buf, s48_value buf,
size_t start, s48_value scm_start,
size_t end, s48_value scm_end,
int family, s48_value scm_family,
s48_value scheme_name) s48_value scheme_name)
{ {
int n;
switch(family) 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(s48_extract_fixnum (scm_family))
{ {
case 0: /* only with connected sockets */ 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: case AF_UNIX:
{ {
@ -349,31 +350,45 @@ ssize_t send_substring(int s,
s48_extract_string(scheme_name), s48_extract_string(scheme_name),
scheme_length); /* copy to c string */ scheme_length); /* copy to c string */
name.sun_path[scheme_length]='\0'; /* add null */ name.sun_path[scheme_length]='\0'; /* add null */
return(sendto(s, n = sendto(s,
StrByte(buf,start), end-start, buf_part, end-start,
flags, flags,
(struct sockaddr *)&name, sizeof(name))); (struct sockaddr *)&name, sizeof(name));
break; break;
} }
case AF_INET: case AF_INET:
{ {
struct sockaddr_in name; struct sockaddr_in name;
u_long addr=GET_LONG(scheme_name,0); u_long addr = htonl (byte_vector2long (S48_CAR (scheme_name)));
u_short port=htons((u_short)ntohl(GET_LONG(scheme_name,1))); u_short port = htons(s48_extract_fixnum (S48_CDR (scheme_name)));
name.sin_family=AF_INET; name.sin_family=AF_INET;
name.sin_addr.s_addr=addr; name.sin_addr.s_addr=addr;
name.sin_port=port; name.sin_port=port;
return(sendto(s, n = sendto(s,
StrByte(buf,start), end-start, buf_part, end-start,
flags, flags,
(struct sockaddr *)&name, sizeof(name))); (struct sockaddr *)&name, sizeof(name));
break; break;
} }
default: 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 scheme_getsockopt (int s,
@ -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);
}

9
scsh/network1.h
View File

@ -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); int scheme_socket_pair(int type, int *s1, int *s2);
ssize_t recv_substring(int s, int flags, s48_value buf, s48_value recv_substring(s48_value s, s48_value flags, s48_value buf,
size_t start, size_t end, s48_value scheme_name); s48_value start, s48_value end);
ssize_t send_substring(int s, int flags, s48_value buf, size_t start, size_t end, s48_value send_substring(s48_value s, s48_value flags, s48_value buf,
int family, s48_value scheme_name); s48_value start, s48_value end, s48_value family,
s48_value scheme_name);
int scheme_getsockopt (int s, int level, int optname); int scheme_getsockopt (int s, int level, int optname);