Port to new FFI.
This commit is contained in:
mainzelm
parent
c7be5ed2b1
commit
07f9cbc6c9
170
scsh/network.scm
170
scsh/network.scm
|
|
@ -407,26 +407,18 @@
|
|||
(define (create-socket-pair type)
|
||||
(if (not (integer? type))
|
||||
(error "create-socket-pair: integer argument expected ~s" type)
|
||||
(receive (s1 s2)
|
||||
(%socket-pair type)
|
||||
(apply
|
||||
(lambda (s1 s2)
|
||||
(let* ((in1 (make-input-fdport s1 0))
|
||||
(out1 (dup->outport in1))
|
||||
(in2 (make-input-fdport s2 0))
|
||||
(out2 (dup->outport in2)))
|
||||
(values (make-socket protocol-family/unix in1 out1)
|
||||
(make-socket protocol-family/unix in2 out2))))))
|
||||
(make-socket protocol-family/unix in2 out2))))
|
||||
(%socket-pair type))))
|
||||
|
||||
;; based on pipe in syscalls.scm
|
||||
(define-foreign %socket-pair/errno
|
||||
(scheme_socket_pair (fixnum type))
|
||||
(to-scheme fixnum errno_or_false)
|
||||
fixnum
|
||||
fixnum)
|
||||
(define-stubless-foreign %socket-pair (type) "scheme_socket_pair")
|
||||
|
||||
(define-errno-syscall
|
||||
(%socket-pair type) %socket-pair/errno
|
||||
sockfd1
|
||||
sockfd2)
|
||||
|
||||
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
|
||||
;;; recv syscall
|
||||
|
|
@ -632,64 +624,31 @@
|
|||
(error "socket-option: integer expected ~s ~s" level option))
|
||||
((boolean-option? option)
|
||||
(let ((result (%getsockopt (socket->fdes sock) level option)))
|
||||
(cond ((= result -1)
|
||||
(error "socket-option ~s ~s ~s" sock level option))
|
||||
(else (not (= result 0))))))
|
||||
(not (= result 0))))
|
||||
((value-option? option)
|
||||
(let ((result (%getsockopt (socket->fdes sock) level option)))
|
||||
(cond ((= result -1)
|
||||
(error "socket-option ~s ~s ~s" sock level option))
|
||||
(else result))))
|
||||
(%getsockopt (socket->fdes sock) level option))
|
||||
((linger-option? option)
|
||||
(receive (result/on-off time)
|
||||
(%getsockopt-linger (socket->fdes sock) level option)
|
||||
(cond ((= result/on-off -1)
|
||||
(error "socket-option ~s ~s ~s" sock level option))
|
||||
(else (if (= result/on-off 0) #f time)))))
|
||||
(apply (%getsockopt-linger (socket->fdes sock) level option)
|
||||
(lambda (result/on-off time)
|
||||
(if (= result/on-off 0) #f time))))
|
||||
((timeout-option? option)
|
||||
(receive (result/secs usecs)
|
||||
(%getsockopt-linger (socket->fdes sock) level option)
|
||||
(cond ((= result/secs -1)
|
||||
(error "socket-option ~s ~s ~s" sock level option))
|
||||
(else (+ result/secs (/ usecs 1000))))))
|
||||
(apply (%getsockopt-timeout (socket->fdes sock) level option)
|
||||
(lambda (result/secs usecs)
|
||||
(cond ((= result/secs -1)
|
||||
(error "socket-option ~s ~s ~s" sock level option))
|
||||
(else (+ result/secs (/ usecs 1000)))))))
|
||||
(else
|
||||
"socket-option: unknown option type ~s" option)))
|
||||
|
||||
(define-foreign %getsockopt/errno
|
||||
(scheme_getsockopt (fixnum sockfd)
|
||||
(fixnum level)
|
||||
(fixnum optname))
|
||||
(multi-rep (to-scheme fixnum errno_or_false)
|
||||
fixnum))
|
||||
(define-stubless-foreign %getsockopt (sock level option) "scheme_getsockopt")
|
||||
|
||||
(define-errno-syscall (%getsockopt sock level option) %getsockopt/errno
|
||||
value)
|
||||
;;; returns (list on-off linger)
|
||||
(define-stubless-foreign %getsockopt-linger (sockfd level optname)
|
||||
"scheme_getsockopt_linger")
|
||||
|
||||
(define-foreign %getsockopt-linger/errno
|
||||
(scheme_getsockopt_linger (fixnum sockfd)
|
||||
(fixnum level)
|
||||
(fixnum optname))
|
||||
(multi-rep (to-scheme fixnum errno_or_false)
|
||||
fixnum) ; error/on-off
|
||||
fixnum) ; linger time
|
||||
|
||||
(define-errno-syscall
|
||||
(%getsockopt-linger sock level option) %getsockopt-linger/errno
|
||||
on-off
|
||||
linger)
|
||||
|
||||
(define-foreign %getsockopt-timeout/errno
|
||||
(scheme_getsockopt_timeout (fixnum sockfd)
|
||||
(fixnum level)
|
||||
(fixnum optname))
|
||||
(multi-rep (to-scheme fixnum errno_or_false)
|
||||
fixnum) ; error/secs
|
||||
fixnum) ; usecs
|
||||
|
||||
(define-errno-syscall
|
||||
(%getsockopt-timeout sock level option) %getsockopt-timeout/errno
|
||||
secs
|
||||
usecs)
|
||||
;;; returns (list secs usecs)
|
||||
(define-stubless-foreign %getsockopt-timeout (sockfd level optname)
|
||||
"scheme_getsockopt_timeout")
|
||||
|
||||
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
|
||||
;;; setsockopt syscall
|
||||
|
|
@ -717,38 +676,14 @@
|
|||
(else
|
||||
"set-socket-option: unknown option type")))
|
||||
|
||||
(define-foreign %setsockopt/errno
|
||||
(scheme_setsockopt (fixnum sockfd)
|
||||
(fixnum level)
|
||||
(fixnum optname)
|
||||
(fixnum optval))
|
||||
(to-scheme fixnum errno_or_false))
|
||||
(define-stubless-foreign %setsockopt (sockfd level optname optval)
|
||||
"scheme_setsockopt")
|
||||
|
||||
(define-errno-syscall
|
||||
(%setsockopt sock level option value) %setsockopt/errno)
|
||||
(define-stubless-foreign %setsockopt-linger
|
||||
(sockfd level optname on-off time) "scheme_setsockopt_linger")
|
||||
|
||||
|
||||
(define-foreign %setsockopt-linger/errno
|
||||
(scheme_setsockopt_linger (fixnum sockfd)
|
||||
(fixnum level)
|
||||
(fixnum optname)
|
||||
(fixnum on-off)
|
||||
(fixnum time))
|
||||
(to-scheme fixnum errno_or_false))
|
||||
|
||||
(define-errno-syscall
|
||||
(%setsockopt-linger sock level option on-off time) %setsockopt-linger/errno)
|
||||
|
||||
(define-foreign %setsockopt-timeout/errno
|
||||
(scheme_setsockopt_timeout (fixnum sockfd)
|
||||
(fixnum level)
|
||||
(fixnum optname)
|
||||
(fixnum secs)
|
||||
(fixnum usecs))
|
||||
(to-scheme fixnum errno_or_false))
|
||||
|
||||
(define-errno-syscall
|
||||
(%setsockopt-timeout sock level option secs usecs) %setsockopt-timeout/errno)
|
||||
(define-stubless-foreign %setsockopt-timeout
|
||||
(sockfd level optname secs usecs) "scheme_setsockopt_timeout")
|
||||
|
||||
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
|
||||
;;; socket-option routines
|
||||
|
|
@ -916,52 +851,3 @@
|
|||
(define-stubless-foreign %protocol-name->protocol-info (name)
|
||||
"scheme_proto_name2proto_info")
|
||||
|
||||
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
|
||||
;;; Lowlevel junk
|
||||
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
|
||||
;; Used to pull address list back
|
||||
;; based on C-string-vec->Scheme from cig/libcig.scm
|
||||
(define (C-long-vec->Scheme cvec veclen) ; No free.
|
||||
(let ((vec (make-vector (or veclen (%c-veclen-or-false cvec) 0))))
|
||||
(mapv! (lambda (ignore) (make-string 4)) vec)
|
||||
(%set-long-vector-carriers! vec cvec)
|
||||
(mapv! string->integer vec)))
|
||||
|
||||
(define (integer->string num32)
|
||||
(let* ((str (make-string 4))
|
||||
(num24 (arithmetic-shift num32 -8))
|
||||
(num16 (arithmetic-shift num24 -8))
|
||||
(num08 (arithmetic-shift num16 -8))
|
||||
(byte0 (bitwise-and #b11111111 num08))
|
||||
(byte1 (bitwise-and #b11111111 num16))
|
||||
(byte2 (bitwise-and #b11111111 num24))
|
||||
(byte3 (bitwise-and #b11111111 num32)))
|
||||
(string-set! str 0 (ascii->char byte0))
|
||||
(string-set! str 1 (ascii->char byte1))
|
||||
(string-set! str 2 (ascii->char byte2))
|
||||
(string-set! str 3 (ascii->char byte3))
|
||||
str))
|
||||
|
||||
(define (string->integer str)
|
||||
(+ (arithmetic-shift(char->ascii(string-ref str 0))24)
|
||||
(arithmetic-shift(char->ascii(string-ref str 1))16)
|
||||
(arithmetic-shift(char->ascii(string-ref str 2)) 8)
|
||||
(char->ascii(string-ref str 3))))
|
||||
|
||||
;; also from cig/libcig.scm
|
||||
(define-foreign %c-veclen-or-false
|
||||
(veclen ((C "const long * ~a") c-vec)); redefining can we open cig-aux?
|
||||
desc) ; integer or #f if arg is NULL.
|
||||
|
||||
;; also from cig/libcig.scm
|
||||
(define-foreign %set-long-vector-carriers!
|
||||
(set_longvec_carriers (vector-desc svec)
|
||||
((C "long const * const * ~a") cvec))
|
||||
ignore)
|
||||
|
||||
;; also from cig/libcig.scm
|
||||
(define (mapv! f v)
|
||||
(let ((len (vector-length v)))
|
||||
(do ((i 0 (+ i 1)))
|
||||
((= i len) v)
|
||||
(vector-set! v i (f (vector-ref v i))))))
|
||||
|
|
|
|||
131
scsh/network1.c
131
scsh/network1.c
|
|
@ -174,7 +174,7 @@ s48_value scheme_accept(s48_value sockfd_tagged, s48_value family)
|
|||
s48_raise_out_of_memory_error();
|
||||
return S48_FALSE;
|
||||
}
|
||||
|
||||
|
||||
return(s48_enter_fixnum (newsockfd));
|
||||
break;
|
||||
}
|
||||
|
|
@ -271,15 +271,14 @@ s48_value scheme_socket_name(s48_value sock, s48_value family)
|
|||
}
|
||||
|
||||
/*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-*/
|
||||
int scheme_socket_pair(int type, int *s1, int *s2)
|
||||
s48_value scheme_socket_pair(s48_value type)
|
||||
{
|
||||
int sv[2];
|
||||
if( socketpair(PF_UNIX,type,0,sv) ) {
|
||||
*s1 = 0; *s2 = 0;
|
||||
return errno;
|
||||
}
|
||||
*s1 = sv[0]; *s2 = sv[1];
|
||||
return 0;
|
||||
if( socketpair(PF_UNIX,s48_extract_integer (type),0,sv) )
|
||||
s48_raise_os_error_1(errno, type);
|
||||
|
||||
return s48_cons (s48_enter_fixnum (sv[0]),
|
||||
s48_cons (s48_enter_fixnum (sv[1]), S48_NULL));
|
||||
}
|
||||
|
||||
/*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-*/
|
||||
|
|
@ -390,84 +389,108 @@ s48_value send_substring(s48_value scm_sockfd,
|
|||
|
||||
|
||||
/*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-*/
|
||||
int scheme_getsockopt (int s,
|
||||
int level,
|
||||
int optname)
|
||||
s48_value scheme_getsockopt (s48_value s,
|
||||
s48_value level,
|
||||
s48_value optname)
|
||||
{
|
||||
int optval;
|
||||
int optlen=sizeof(optval);
|
||||
|
||||
if (getsockopt(s,level,optname,(char *)&optval,&optlen) == -1)
|
||||
return(-1);
|
||||
return(optval);
|
||||
if (getsockopt(s48_extract_fixnum (s),
|
||||
s48_extract_fixnum (level),
|
||||
s48_extract_fixnum (optname)
|
||||
,(char *)&optval,
|
||||
&optlen) == -1)
|
||||
s48_raise_os_error_3 (errno, s, level, optname);
|
||||
return(s48_enter_fixnum (optval));
|
||||
|
||||
}
|
||||
|
||||
int scheme_getsockopt_linger (int s,
|
||||
int level,
|
||||
int optname,
|
||||
int *out_time)
|
||||
s48_value scheme_getsockopt_linger (s48_value s,
|
||||
s48_value level,
|
||||
s48_value optname)
|
||||
{
|
||||
struct linger optval;
|
||||
int optlen=sizeof(optval);
|
||||
|
||||
if (getsockopt(s,level,optname,(char *)&optval,&optlen) == -1) {
|
||||
out_time = 0;
|
||||
return(-1);
|
||||
}
|
||||
*out_time=optval.l_linger;
|
||||
return(optval.l_onoff);
|
||||
if (getsockopt(s48_extract_fixnum (s),
|
||||
s48_extract_fixnum (level),
|
||||
s48_extract_fixnum (optname),
|
||||
(char *)&optval,
|
||||
&optlen) == -1) {
|
||||
s48_raise_os_error_3 (errno, s, level, optname);
|
||||
}
|
||||
return s48_cons (s48_enter_fixnum (optval.l_onoff),
|
||||
s48_cons (s48_enter_fixnum (optval.l_linger), S48_NULL));
|
||||
}
|
||||
|
||||
int scheme_getsockopt_timeout (int s,
|
||||
int level,
|
||||
int optname,
|
||||
int *out_usec)
|
||||
s48_value scheme_getsockopt_timeout (s48_value s,
|
||||
s48_value level,
|
||||
s48_value optname)
|
||||
{
|
||||
struct timeval optval;
|
||||
size_t optlen=sizeof(optval);
|
||||
|
||||
if (getsockopt(s,level,optname,(char *)&optval,&optlen) == -1) {
|
||||
out_usec = 0;
|
||||
return(-1);
|
||||
if (getsockopt(s48_extract_fixnum (s),
|
||||
s48_extract_fixnum (level),
|
||||
s48_extract_fixnum (optname),
|
||||
(char *)&optval,
|
||||
&optlen) == -1) {
|
||||
s48_raise_os_error_3 (errno, s, level, optname);
|
||||
}
|
||||
*out_usec=optval.tv_usec;
|
||||
return(optval.tv_sec);
|
||||
return(s48_cons (s48_enter_fixnum (optval.tv_sec),
|
||||
s48_cons (s48_enter_fixnum (optval.tv_usec), S48_NULL)));
|
||||
}
|
||||
/*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-*/
|
||||
int scheme_setsockopt (int s,
|
||||
int level,
|
||||
int optname,
|
||||
int optval)
|
||||
s48_value scheme_setsockopt (s48_value s,
|
||||
s48_value level,
|
||||
s48_value optname,
|
||||
s48_value _optval)
|
||||
{
|
||||
return(setsockopt(s,level,optname,(char *)&optval,sizeof(optval)));
|
||||
int optval = s48_extract_fixnum (_optval);
|
||||
if ((setsockopt(s48_extract_fixnum (s),
|
||||
s48_extract_fixnum (level),
|
||||
s48_extract_fixnum (optname),
|
||||
(char *)&optval,sizeof(optval))) == -1)
|
||||
s48_raise_os_error_4 (errno, s, level, optname, _optval);
|
||||
return S48_UNSPECIFIC;
|
||||
}
|
||||
|
||||
int scheme_setsockopt_linger (int s,
|
||||
int level,
|
||||
int optname,
|
||||
int onoff,
|
||||
int linger)
|
||||
s48_value scheme_setsockopt_linger (s48_value s,
|
||||
s48_value level,
|
||||
s48_value optname,
|
||||
s48_value onoff,
|
||||
s48_value linger)
|
||||
{
|
||||
struct linger optval;
|
||||
|
||||
optval.l_onoff=onoff;
|
||||
optval.l_linger=linger;
|
||||
optval.l_onoff = s48_extract_fixnum (onoff);
|
||||
optval.l_linger = s48_extract_fixnum (linger);
|
||||
|
||||
return(setsockopt(s,level,optname,(char *)&optval,sizeof(optval)));
|
||||
if ((setsockopt(s48_extract_fixnum (s),
|
||||
s48_extract_fixnum (level),
|
||||
s48_extract_fixnum (optname),
|
||||
(char *)&optval,sizeof(optval))) == -1)
|
||||
s48_raise_os_error_5 (errno, s, level, optname, onoff, linger);
|
||||
return S48_UNSPECIFIC;
|
||||
}
|
||||
|
||||
int scheme_setsockopt_timeout (int s,
|
||||
int level,
|
||||
int optname,
|
||||
int sec,
|
||||
int usec)
|
||||
s48_value scheme_setsockopt_timeout (s48_value s,
|
||||
s48_value level,
|
||||
s48_value optname,
|
||||
s48_value sec,
|
||||
s48_value usec)
|
||||
{
|
||||
struct timeval optval;
|
||||
optval.tv_sec=sec;
|
||||
optval.tv_usec=usec;
|
||||
optval.tv_sec = s48_extract_fixnum (sec);
|
||||
optval.tv_usec = s48_extract_fixnum (usec);
|
||||
|
||||
return(setsockopt(s,level,optname,(char *)&optval,sizeof(optval)));
|
||||
if ((setsockopt(s48_extract_fixnum (s),
|
||||
s48_extract_fixnum (level),
|
||||
s48_extract_fixnum (optname),
|
||||
(char *)&optval,sizeof(optval))) == -1)
|
||||
s48_raise_os_error_5 (errno, s, level, optname, sec, usec);
|
||||
return S48_UNSPECIFIC;
|
||||
}
|
||||
|
||||
/*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-*/
|
||||
|
|
|
|||
|
|
@ -11,7 +11,7 @@ s48_value scheme_peer_name(s48_value sockfd, s48_value family);
|
|||
|
||||
s48_value scheme_socket_name(s48_value sockfd, s48_value family);
|
||||
|
||||
int scheme_socket_pair(int type, int *s1, int *s2);
|
||||
s48_value scheme_socket_pair(s48_value type);
|
||||
|
||||
s48_value recv_substring(s48_value s, s48_value flags, s48_value buf,
|
||||
s48_value start, s48_value end);
|
||||
|
|
@ -20,34 +20,34 @@ 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);
|
||||
s48_value scheme_getsockopt (s48_value s, s48_value level, s48_value optname);
|
||||
|
||||
int scheme_getsockopt_linger (int s,
|
||||
int level,
|
||||
int optname,
|
||||
int *out_time);
|
||||
s48_value scheme_getsockopt_linger (s48_value s,
|
||||
s48_value level,
|
||||
s48_value optname);
|
||||
|
||||
|
||||
int scheme_getsockopt_timeout (int s,
|
||||
int level,
|
||||
int optname,
|
||||
int *out_usec);
|
||||
s48_value scheme_getsockopt_timeout (s48_value s,
|
||||
s48_value level,
|
||||
s48_value optname);
|
||||
|
||||
int scheme_setsockopt (int s,
|
||||
int level,
|
||||
int optname,
|
||||
int optval);
|
||||
|
||||
int scheme_setsockopt_linger (int s,
|
||||
int level,
|
||||
int optname,
|
||||
int onoff,
|
||||
int linger);
|
||||
s48_value scheme_setsockopt (s48_value s,
|
||||
s48_value level,
|
||||
s48_value optname,
|
||||
s48_value optval);
|
||||
|
||||
int scheme_setsockopt_timeout (int s,
|
||||
int level,
|
||||
int optname,
|
||||
int sec,
|
||||
int usec);
|
||||
s48_value scheme_setsockopt_linger (s48_value s,
|
||||
s48_value level,
|
||||
s48_value optname,
|
||||
s48_value onoff,
|
||||
s48_value linger);
|
||||
|
||||
s48_value scheme_setsockopt_timeout (s48_value s,
|
||||
s48_value level,
|
||||
s48_value optname,
|
||||
s48_value sec,
|
||||
s48_value usec);
|
||||
|
||||
s48_value scheme_host_address2host_info(s48_value scheme_byte_vector);
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue