From 891ba76c8476bb95951c4049e7c20d5895cb2233 Mon Sep 17 00:00:00 2001 From: Andreas Fuchs Date: Sun, 25 Jul 2004 11:31:36 +0000 Subject: [PATCH] 0.8.12.54: Various rather urgent sb-grovel and sb-bsd-sockets fixes. * sb-grovel uses WITH-ALIEN now for the WITH-* macros, to allow use of SB-ALIEN:ADDR on variables allocated that way. * sb-bsd-sockets: name-service code now return addresses as vectors again. * sb-bsd-sockets: fix socket-receive into relative workingness again: use (deref (deref array) i) instead of (deref array i); type-convert the results --- contrib/sb-bsd-sockets/constants.lisp | 5 ++++- contrib/sb-bsd-sockets/name-service.lisp | 6 ++++-- contrib/sb-bsd-sockets/sockets.lisp | 20 +++++++++++++++----- contrib/sb-bsd-sockets/tests.lisp | 17 +++++++++++++++++ contrib/sb-grovel/foreign-glue.lisp | 2 +- version.lisp-expr | 2 +- 6 files changed, 42 insertions(+), 10 deletions(-) diff --git a/contrib/sb-bsd-sockets/constants.lisp b/contrib/sb-bsd-sockets/constants.lisp index e8004f4..22f6793 100644 --- a/contrib/sb-bsd-sockets/constants.lisp +++ b/contrib/sb-bsd-sockets/constants.lisp @@ -94,6 +94,9 @@ (:integer msg-trunc "MSG_TRUNC") (:integer msg-waitall "MSG_WAITALL") + ;; for socket-receive + (:type socklen-t "socklen_t") + #| ;;; stat is nothing to do with sockets, but I keep it around for testing ;;; the ffi glue @@ -166,7 +169,7 @@ (len integer) (flags integer) (sockaddr (* t)) ; KLUDGE: sockaddr-in or sockaddr-un? - (socklen (* integer)))) + (socklen (* socklen-t)))) (:function gethostbyname ("gethostbyname" (* hostent) (name c-string))) (:function gethostbyaddr ("gethostbyaddr" (* hostent) (addr (* t)) diff --git a/contrib/sb-bsd-sockets/name-service.lisp b/contrib/sb-bsd-sockets/name-service.lisp index 8015908..ab5b81e 100644 --- a/contrib/sb-bsd-sockets/name-service.lisp +++ b/contrib/sb-bsd-sockets/name-service.lisp @@ -40,8 +40,10 @@ eventually, so that we can do DNS lookups in parallel with other things until (sb-alien:null-alien ad) collect (ecase (sockint::hostent-type h) (#.sockint::af-inet - (loop for i from 0 below length - collect (sb-alien:deref ad i))) + (assert (= length 4)) + (let ((addr (make-array 4 :element-type '(unsigned-byte 8)))) + (loop for i from 0 below length + do (setf (elt addr i) (sb-alien:deref ad i))))) (#.sockint::af-local (sb-alien:cast ad sb-alien:c-string)))))) (make-instance 'host-ent diff --git a/contrib/sb-bsd-sockets/sockets.lisp b/contrib/sb-bsd-sockets/sockets.lisp index 384ca10..03b6344 100644 --- a/contrib/sb-bsd-sockets/sockets.lisp +++ b/contrib/sb-bsd-sockets/sockets.lisp @@ -173,24 +173,34 @@ small")) (error "Must supply at least one of BUFFER or LENGTH")) (unless length (setf length (length buffer))) + (when buffer (setf element-type (array-element-type buffer))) + (unless (or (subtypep element-type 'character) + (subtypep element-type 'integer)) + (error "Buffer element-type must be either a character or an integer subtype.")) (unless buffer (setf buffer (make-array length :element-type element-type))) - (let ((copy-buffer (sb-alien:make-alien (array sb-alien:unsigned 1) length))) + ;; really big FIXME: This whole copy-buffer thing is broken. + ;; doesn't support characters more than 8 bits wide, or integer + ;; types that aren't (unsigned-byte 8). + (let ((copy-buffer (sb-alien:make-alien (array (sb-alien:unsigned 8) 1) length))) (unwind-protect - (sb-alien:with-alien ((sa-len (array (sb-alien:unsigned 32) 2))) - (setf (sb-alien:deref sa-len 0) (size-of-sockaddr socket)) + (sb-alien:with-alien ((sa-len sockint::socklen-t (size-of-sockaddr socket))) (let ((len (sockint::recvfrom (socket-file-descriptor socket) copy-buffer length flags sockaddr - (sb-alien:cast sa-len (* integer))))) + (sb-alien:addr sa-len)))) (cond ((and (= len -1) (= sockint::EAGAIN (sb-unix::get-errno))) nil) ((= len -1) (socket-error "recvfrom")) (t (loop for i from 0 below len - do (setf (elt buffer i) (sb-alien:deref copy-buffer i))) + do (setf (elt buffer i) + (cond + ((or (eql element-type 'character) (eql element-type 'base-char)) + (code-char (sb-alien:deref (sb-alien:deref copy-buffer) i))) + (t (sb-alien:deref (sb-alien:deref copy-buffer) i))))) (apply #'values buffer len (multiple-value-list (bits-of-sockaddr socket sockaddr))))))) (sb-alien:free-alien copy-buffer)))))) diff --git a/contrib/sb-bsd-sockets/tests.lisp b/contrib/sb-bsd-sockets/tests.lisp index 5d15ab0..3fec556 100644 --- a/contrib/sb-bsd-sockets/tests.lisp +++ b/contrib/sb-bsd-sockets/tests.lisp @@ -102,6 +102,11 @@ Tests are in the file tests.lisp and also make good examples. ((or (>= i (length buffer)) (not c) (eq c eof)) i) (setf (elt buffer i) c)))) +#+internet-available +(deftest name-service-return-type + (vectorp (host-ent-address (get-host-by-address #(127 0 0 1)))) + t) + ;;; these require that the echo services are turned on in inetd #+internet-available (deftest simple-tcp-client @@ -116,6 +121,18 @@ Tests are in the file tests.lisp and also make good examples. t) #+internet-available +(deftest sockaddr-return-type + (let ((s (make-instance 'inet-socket :type :stream :protocol :tcp))) + (unwind-protect + (progn + (socket-connect s #(127 0 0 1) 7) + (multiple-value-bind (host port) (socket-peername s) + (and (vectorp host) + (numberp port)))) + (socket-close s))) + t) + +#+internet-available (deftest simple-udp-client (let ((s (make-instance 'inet-socket :type :datagram :protocol (get-protocol-by-name "udp"))) (data (make-string 200))) diff --git a/contrib/sb-grovel/foreign-glue.lisp b/contrib/sb-grovel/foreign-glue.lisp index 457e453..a98cca1 100644 --- a/contrib/sb-grovel/foreign-glue.lisp +++ b/contrib/sb-grovel/foreign-glue.lisp @@ -365,7 +365,7 @@ deeply nested structures." (symbol-name ',name) "-" (symbol-name x)) ,(symbol-package name)))) - `(let ((,var ,'(,(intern (format nil "ALLOCATE-~A" name))))) + `(sb-alien:with-alien ((,var (* ,',name) ,'(,(intern (format nil "ALLOCATE-~A" name))))) (unwind-protect (progn (progn ,@(mapcar (lambda (pair) diff --git a/version.lisp-expr b/version.lisp-expr index 1c77f5b..5ffaf57 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.8.12.53" +"0.8.12.54" -- 1.7.10.4