[[project @ 1997-01-08 07:51:36 by ghouston] ghouston**19970108075139 Ignore-this: 4f636c51c0039d6b01597b817d720fa * init.scm (ascii->char, char->ascii) defined. * netconst.scm (maybe-define-so): new macro. use it to define socket option constants. remove a few SO_ types which don't appear in SCSH's netconst.scm. define variables options/boolean etc. * network.scm: socket-address->list: new procedure. (generic-send-message, generic-send-message/partial, socket-option, set-socket-option, address->host-info, name->host-info, address->network-info, name->network-info, port->service-info, name->service-info, number->protocol-info, name->protocol-info): use guile primitives. (send-message, send-message/partial): minor modifications. comment out C-long-vec->Scheme, integer->string, string->integer. ] hunk ./ChangeLog 1 +Wed Jan 8 02:32:56 1997 Gary Houston + + * init.scm (ascii->char, char->ascii) defined. + + * netconst.scm (maybe-define-so): new macro. use it to define + socket option constants. + remove a few SO_ types which don't appear in SCSH's netconst.scm. + define variables options/boolean etc. + + * network.scm: socket-address->list: new procedure. + (generic-send-message, generic-send-message/partial, socket-option, + set-socket-option, address->host-info, name->host-info, + address->network-info, name->network-info, port->service-info, + name->service-info, number->protocol-info, name->protocol-info): + use guile primitives. + (send-message, send-message/partial): minor modifications. + comment out C-long-vec->Scheme, integer->string, string->integer. + hunk ./INCOMPAT 13 +network-info works when its argument is a socket address (bug in SCSH?) + hunk ./init.scm 10 +(define ascii->char integer->char) +(define char->ascii char->integer) hunk ./netconst.scm 5 +(defmacro maybe-define-so (name value type) + (let ((type-var (string->symbol (string-append "options/" + (symbol->string type))))) + `(if (defined? ',value) + (begin + (define ,name ,value) + (set! ,type-var (cons ,value ,type-var)))))) + hunk ./netconst.scm 31 -(maybe-define socket/debug SO_DEBUG) -(maybe-define socket/reuse-address SO_REUSEADDR) -(maybe-define socket/style SO_STYLE) -(maybe-define socket/type SO_TYPE) -(maybe-define socket/error SO_ERROR) -(maybe-define socket/dont-route SO_DONTROUTE) -(maybe-define socket/broadcast SO_BROADCAST) -(maybe-define socket/send-buffer SO_SNDBUF) -(maybe-define socket/receive-buffer SO_RCVBUF) -(maybe-define socket/keep-alive SO_KEEPALIVE) -(maybe-define socket/no-check SO_NO_CHECK) -(maybe-define socket/priority SO_PRIORITY) -(maybe-define socket/linger SO_LINGER) +(define options/boolean ()) +(define options/value ()) +(define options/linger ()) + +(maybe-define-so socket/debug SO_DEBUG boolean) +(maybe-define-so socket/reuse-address SO_REUSEADDR boolean) +(maybe-define-so socket/type SO_TYPE value) +(maybe-define-so socket/error SO_ERROR value) +(maybe-define-so socket/dont-route SO_DONTROUTE boolean) +(maybe-define-so socket/broadcast SO_BROADCAST boolean) +(maybe-define-so socket/send-buffer SO_SNDBUF value) +(maybe-define-so socket/receive-buffer SO_RCVBUF value) +(maybe-define-so socket/keep-alive SO_KEEPALIVE boolean) +(maybe-define-so socket/linger SO_LINGER linger) hunk ./network.scm 146 +(define (socket-address->list addr) + (let ((family (socket-address:family addr))) + (cond ((= family address-family/unix) + (list (socket-address->unix-address addr))) + ((= family address-family/internet) + (receive (address port) + (socket-address->internet-address addr) + (list address port))) + (else + (error "Unrecognised address family: " family))))) + hunk ./network.scm 500 - (generic-send-message (socket->fdes socket) flags + (generic-send-message (socket->port socket) flags hunk ./network.scm 502 - send-substring/errno + 'dummy hunk ./network.scm 511 - (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)))))))) - + (let loop ((i start)) + (if (< i end) + (let ((nwritten + (if (eq? family 0) + (send sockfd (substring s i end) flags) + (apply sendto (append (list sockfd (substring s i end) + family) + (socket-address->list addr) + (list flags)))))) + (loop (+ i nwritten)))))) hunk ./network.scm 531 - (generic-send-message/partial (socket->fdes socket) flags + (generic-send-message/partial (socket->port socket) flags hunk ./network.scm 533 - send-substring/errno + 'dummy hunk ./network.scm 542 - hunk ./network.scm 543 - (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))))))) + (if (eq? family 0) + (send sockfd (substring s start end) flags) + (apply sendto (append (list sockfd (substring s start end) family) + (socket-address->list addr) + (list flags)))))) hunk ./network.scm 570 - (let ((result (%getsockopt (socket->fdes sock) level option))) - (cond ((= result -1) - (error "socket-option ~s ~s ~s" sock level option)) - (else (not (= result 0)))))) + (let ((result (getsockopt (socket->port sock) level option))) + (not (= result 0)))) hunk ./network.scm 573 - (let ((result (%getsockopt (socket->fdes sock) level option))) - (cond ((= result -1) - (error "socket-option ~s ~s ~s" sock level option)) - (else result)))) + (getsockopt (socket->port sock) level option)) hunk ./network.scm 575 - (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))))) - ((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)))))) + (let ((result (getsockopt (socket->port sock) level option))) + (if (= (car result) 0) + #f + (cdr result)))) + ;; ((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)))))) hunk ./network.scm 634 - (%setsockopt (socket->fdes sock) level option (if value 1 0))) + (setsockopt (socket->port sock) level option (if value 1 0))) hunk ./network.scm 636 - (%setsockopt (socket->fdes sock) level option value)) + (setsockopt (socket->port sock) level option value)) hunk ./network.scm 638 - (%setsockopt-linger (socket->fdes sock) - level option - (if value 1 0) - (if value value 0))) - ((timeout-option? option) - (let ((secs (truncate value))) - (%setsockopt-timeout (socket->fdes sock) level option - secs - (truncate (* (- value secs) 1000))))) + (setsockopt(socket->port sock) level option + (if value (cons 1 value) (cons 0 0)))) + ;;((timeout-option? option) + ;; (let ((secs (truncate value))) + ;; (%setsockopt-timeout (socket->fdes sock) level option + ;; secs + ;; (truncate (* (- value secs) 1000))))) hunk ./network.scm 717 - (receive (herrno name aliases addresses) - (%host-address->host-info/h-errno - (socket-address:address name)) - (if herrno - (error "address->host-info: non-zero herrno ~s ~s" name herrno) - (make-host-info name - (vector->list - (C-string-vec->Scheme aliases #f)) - (vector->list - (C-string-vec->Scheme addresses #f))))))) + (let* ((vec (gethostbyaddr (car (socket-address:address name)))) + (name (vector-ref vec 0)) + (aliases (vector-ref vec 1)) + (addresses (vector-ref vec 4))) + (make-host-info name aliases addresses)))) hunk ./network.scm 733 - (receive (herrno name aliases addresses) - (%host-name->host-info/h-errno name) - (if herrno - (error "name->host-info: non-zero herrno ~s ~s" herrno name) - (make-host-info name - (vector->list - (C-string-vec->Scheme aliases #f)) - (vector->list - (C-long-vec->Scheme addresses #f))))))) + (let* ((vec (gethostbyname name)) + (name (vector-ref vec 0)) + (aliases (vector-ref vec 1)) + (addresses (vector-ref vec 4))) + (make-host-info name aliases addresses)))) hunk ./network.scm 762 - (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)))))) + (if (not (socket-address? name)) + (error "address->network-info: socket-address expected ~s" name) + (let* ((vec (getnetbyaddr (car (socket-address:address name)))) + (name (vector-ref vec 0)) + (aliases (vector-ref vec 1)) + (net (vector-ref vec 3))) + (make-network-info name aliases net)))) hunk ./network.scm 780 - (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)))))) + (let* ((vec (getnetbyname name)) + (name (vector-ref vec 0)) + (aliases (vector-ref vec 1)) + (net (vector-ref vec 3))) + (make-network-info name aliases net)))) hunk ./network.scm 814 - (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)))))) + (let* ((vec (getservbyport name proto)) + (name (vector-ref vec 0)) + (aliases (vector-ref vec 1)) + (port (vector-ref vec 2)) + (proto (vector-ref vec 3))) + (make-service-info name aliases port proto)))))) hunk ./network.scm 831 - (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))) + (let* ((vec (getservbyname name (optional maybe-proto ""))) + (name (vector-ref vec 0)) + (aliases (vector-ref vec 1)) + (port (vector-ref vec 2)) + (proto (vector-ref vec 3))) + (make-service-info name aliases port proto))) hunk ./network.scm 862 - (receive (result name aliases protocol) - (%protocol-port->protocol-info name) - (make-protocol-info name - (vector->list - (C-string-vec->Scheme aliases #f)) - protocol)))) + (let* ((vec (getprotobynumber name)) + (name (vector-ref vec 0)) + (aliases (vector-ref vec 1)) + (number (vector-ref vec 2))) + (make-protocol-info name aliases number)))) hunk ./network.scm 878 - (receive (result name aliases protocol) - (%protocol-name->protocol-info name) - (make-protocol-info name - (vector->list - (C-string-vec->Scheme aliases #f)) - protocol)))) + (let* ((vec (getprotobyname name)) + (name (vector-ref vec 0)) + (aliases (vector-ref vec 1)) + (number (vector-ref vec 2))) + (make-protocol-info name aliases number)))) hunk ./network.scm 896 -(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 (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))) hunk ./network.scm 902 -(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 (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)) hunk ./network.scm 917 -(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)))) +;(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))))