X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=contrib%2Fsb-bsd-sockets%2Ftests.lisp;h=7ce9d39ae5e717e4ac355864ab4fc84a2a202cac;hb=a37b7e2a4c93398af954c3f03c5412ead1c1c828;hp=c9954b5af91b1356646c7d253ed59ec1f89ed692;hpb=5eb1bc45f5bd68638ae861dd8bd81c33ae6cd14d;p=sbcl.git diff --git a/contrib/sb-bsd-sockets/tests.lisp b/contrib/sb-bsd-sockets/tests.lisp index c9954b5..7ce9d39 100644 --- a/contrib/sb-bsd-sockets/tests.lisp +++ b/contrib/sb-bsd-sockets/tests.lisp @@ -3,6 +3,12 @@ (in-package :sb-bsd-sockets-test) +(defmacro deftest* ((name &key fails-on) form &rest results) + `(progn + (when (sb-impl::featurep ',fails-on) + (pushnew ',name sb-rt::*expected-failures*)) + (deftest ,name ,form ,@results))) + ;;; a real address (deftest make-inet-address (equalp (make-inet-address "127.0.0.1") #(127 0 0 1)) @@ -20,6 +26,10 @@ (integerp (get-protocol-by-name "udp")) t) +;;; See https://bugs.launchpad.net/sbcl/+bug/659857 +;;; Apparently getprotobyname_r on FreeBSD says -1 and EINTR +;;; for unknown protocols... +#-(and freebsd sb-thread) (deftest get-protocol-by-name/error (handler-case (get-protocol-by-name "nonexistent-protocol") (unknown-protocol () @@ -40,56 +50,66 @@ (and (> (socket-file-descriptor s) 1) t)) t) -(deftest make-inet-socket-wrong +(deftest* (make-inet-socket-wrong) ;; fail to make a socket: check correct error return. There's no nice ;; way to check the condition stuff on its own, which is a shame (handler-case (make-instance 'inet-socket :type :stream :protocol (get-protocol-by-name "udp")) - ((or socket-type-not-supported-error protocol-not-supported-error) (c) + ;; CLH FIXME! some versions of darwin just return a socket error + ;; here, not socket-type-not-supported-error or + ;; protocol-not-supported-error. + ((or #+darwin socket-error + socket-type-not-supported-error + protocol-not-supported-error) + (c) (declare (ignorable c)) t) (:no-error nil)) t) -(deftest make-inet-socket-keyword-wrong +(deftest* (make-inet-socket-keyword-wrong) ;; same again with keywords (handler-case (make-instance 'inet-socket :type :stream :protocol :udp) - ((or protocol-not-supported-error socket-type-not-supported-error) (c) + ;; CLH FIXME! some versions of darwin just return a socket error + ;; here, not socket-type-not-supported-error or + ;; protocol-not-supported-error. + ((or + #+darwin socket-error + protocol-not-supported-error + socket-type-not-supported-error) + (c) (declare (ignorable c)) t) (:no-error nil)) t) -(deftest non-block-socket +(deftest* (non-block-socket) (let ((s (make-instance 'inet-socket :type :stream :protocol :tcp))) (setf (non-blocking-mode s) t) (non-blocking-mode s)) t) -(defun do-gc-portably () - ;; cmucl on linux has generational gc with a keyword argument, - ;; sbcl GC function takes same arguments no matter what collector is in - ;; use - #+(or sbcl gencgc) (SB-EXT:gc :full t) - ;; other platforms have full gc or nothing - #-(or sbcl gencgc) (sb-ext:gc)) - (deftest inet-socket-bind - (let ((s (make-instance 'inet-socket :type :stream :protocol (get-protocol-by-name "tcp")))) - ;; Given the functions we've got so far, if you can think of a - ;; better way to make sure the bind succeeded than trying it - ;; twice, let me know - ;; 1974 has no special significance, unless you're the same age as me - (do-gc-portably) ;gc should clear out any old sockets bound to this port - (socket-bind s (make-inet-address "127.0.0.1") 1974) - (handler-case - (let ((s2 (make-instance 'inet-socket :type :stream :protocol (get-protocol-by-name "tcp")))) - (socket-bind s2 (make-inet-address "127.0.0.1") 1974) - nil) - (address-in-use-error () t))) + (let* ((tcp (get-protocol-by-name "tcp")) + (address (make-inet-address "127.0.0.1")) + (s1 (make-instance 'inet-socket :type :stream :protocol tcp)) + (s2 (make-instance 'inet-socket :type :stream :protocol tcp))) + (unwind-protect + ;; Given the functions we've got so far, if you can think of a + ;; better way to make sure the bind succeeded than trying it + ;; twice, let me know + (progn + (socket-bind s1 address 0) + (handler-case + (let ((port (nth-value 1 (socket-name s1)))) + (socket-bind s2 address port) + nil) + (address-in-use-error () t))) + (socket-close s1) + (socket-close s2))) t) -(deftest simple-sockopt-test +(deftest* (simple-sockopt-test) ;; test we can set SO_REUSEADDR on a socket and retrieve it, and in ;; the process that all the weird macros in sockopt happened right. (let ((s (make-instance 'inet-socket :type :stream :protocol (get-protocol-by-name "tcp")))) @@ -154,6 +174,7 @@ ;;; to look at /etc/syslog.conf or local equivalent to find out where ;;; the message ended up +#-win32 (deftest simple-local-client (progn ;; SunOS (Solaris) and Darwin systems don't have a socket at @@ -161,9 +182,13 @@ ;; something, so don't fail this test just because the file is ;; unavailable, or if it's a symlink to some weird character ;; device. - (when (and (probe-file "/dev/log") - (sb-posix:s-issock - (sb-posix::stat-mode (sb-posix:stat "/dev/log")))) + (when (block nil + (handler-bind ((sb-posix:syscall-error + (lambda (e) + (declare (ignore e)) + (return nil)))) + (sb-posix:s-issock + (sb-posix::stat-mode (sb-posix:stat "/dev/log"))))) (let ((s (make-instance 'local-socket :type :datagram))) (format t "Connecting ~A... " s) (finish-output) @@ -195,6 +220,10 @@ (host-ent-name (get-host-by-address #(198 41 0 4))) "a.root-servers.net") +;;; These days lots of people seem to be using DNS servers that don't +;;; report resolving failures for non-existing domains. This test +;;; will fail there, so we've disabled it. +#+nil (deftest get-host-by-name-wrong (handler-case (get-host-by-name "foo.tninkpad.telent.net.") @@ -279,4 +308,57 @@ (format t "Received ~A bytes from ~A:~A - ~A ~%" len address port (subseq buf 0 (min 10 len))))))) - +#+sb-thread +(deftest interrupt-io + (let (result) + (labels + ((client (port) + (setf result + (let ((s (make-instance 'inet-socket + :type :stream + :protocol :tcp))) + (socket-connect s #(127 0 0 1) port) + (let ((stream (socket-make-stream s + :input t + :output t + :buffering :none))) + (handler-case + (prog1 + (catch 'stop + (progn + (read-char stream) + (sleep 0.1) + (sleep 0.1) + (sleep 0.1))) + (close stream)) + (error (c) + c)))))) + (server () + (let ((s (make-instance 'inet-socket + :type :stream + :protocol :tcp))) + (setf (sockopt-reuse-address s) t) + (socket-bind s (make-inet-address "127.0.0.1") 0) + (socket-listen s 5) + (multiple-value-bind (* port) + (socket-name s) + (let* ((client (sb-thread:make-thread + (lambda () (client port)))) + (r (socket-accept s)) + (stream (socket-make-stream r + :input t + :output t + :buffering :none)) + (ok :ok)) + (socket-close s) + (sleep 5) + (sb-thread:interrupt-thread client + (lambda () (throw 'stop ok))) + (sleep 5) + (setf ok :not-ok) + (write-char #\x stream) + (close stream) + (socket-close r)))))) + (server)) + result) + :ok)