(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))
(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 ()
(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
(: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)
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"))))
;;; to look at /etc/syslog.conf or local equivalent to find out where
;;; the message ended up
+#-win32
(deftest simple-local-client
- #-win32
(progn
;; SunOS (Solaris) and Darwin systems don't have a socket at
;; /dev/log. We might also be building in a chroot or
(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)
+
+(defmacro with-client-and-server ((server-socket-var client-socket-var) &body body)
+ (let ((listen-socket (gensym "LISTEN-SOCKET")))
+ `(let ((,listen-socket (make-instance 'inet-socket
+ :type :stream
+ :protocol :tcp))
+ (,client-socket-var (make-instance 'inet-socket
+ :type :stream
+ :protocol :tcp))
+ (,server-socket-var))
+ (unwind-protect
+ (progn
+ (setf (sockopt-reuse-address ,listen-socket) t)
+ (socket-bind ,listen-socket (make-inet-address "127.0.0.1") 0)
+ (socket-listen ,listen-socket 5)
+ (socket-connect ,client-socket-var (make-inet-address "127.0.0.1")
+ (nth-value 1 (socket-name ,listen-socket)))
+ (setf ,server-socket-var (socket-accept ,listen-socket))
+ ,@body)
+ (socket-close ,client-socket-var)
+ (socket-close ,listen-socket)
+ (when ,server-socket-var
+ (socket-close ,server-socket-var))))))
+
+;; For stream sockets, make sure a shutdown of the output direction
+;; translates into an END-OF-FILE on the other end, no matter which
+;; end performs the shutdown and independent of the element-type of
+;; the stream.
+(macrolet
+ ((define-shutdown-test (name who-shuts-down who-reads element-type direction)
+ `(deftest ,name
+ (with-client-and-server (client server)
+ (socket-shutdown ,who-shuts-down :direction ,direction)
+ (handler-case
+ (sb-ext:with-timeout 2
+ (,(if (eql element-type 'character)
+ 'read-char 'read-byte)
+ (socket-make-stream
+ ,who-reads :input t :output t
+ :element-type ',element-type)))
+ (end-of-file ()
+ :ok)
+ (sb-ext:timeout () :timeout)))
+ :ok))
+ (define-shutdown-tests (direction)
+ (flet ((make-name (name)
+ (intern (concatenate
+ 'string (string name) "." (string direction)))))
+ `(progn
+ (define-shutdown-test ,(make-name 'shutdown.server.character)
+ server client character ,direction)
+ (define-shutdown-test ,(make-name 'shutdown.server.ub8)
+ server client (unsigned-byte 8) ,direction)
+ (define-shutdown-test ,(make-name 'shutdown.client.character)
+ client server character ,direction)
+ (define-shutdown-test ,(make-name 'shutdown.client.ub8)
+ client server (unsigned-byte 8) ,direction)))))
+
+ (define-shutdown-tests :output)
+ (define-shutdown-tests :io))