tests/serve-event.pure.lisp

   1 ;;;; tests of SERVE-EVENT
   2 ;;;;
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; While most of SBCL is derived from the CMU CL system, the test
   7 ;;;; files (like this one) were written from scratch after the fork
   8 ;;;; from CMU CL.
   9 ;;;;
  10 ;;;; This software is in the public domain and is provided with
  11 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
  12 ;;;; more information.
  13
  14 (when (find-symbol "COMPUTE-POLLFDS" "SB-IMPL")
  15   (push :compute-pollfds-test *features*))
  16 #+compute-pollfds-test
  17 (import '(sb-impl::make-handler
  18           sb-impl::handler-descriptor
  19           sb-impl::handler-bogus
  20           sb-impl::compute-pollfds))
  21
  22 ;; Tests for SERVE-EVENT are somewhat lacking,
  23 ;; although RUN-PROGRAM exercises some multiplexed I/O.
  24 ;; At any rate, this tests that the utility function COMPUTE-POLLFDS is sane.
  25 ;; This can't use :skipped-on because SB-UNIX does not define a POLLFD alien
  26 ;; type nor export the relevant lisp symbols unless the poll() syscall exists.
  27 #+compute-pollfds-test
  28 (test-util:with-test (:name :compute-pollfds)
  29   (labels ((try (list how)
  30              (multiple-value-bind (pollfds count map)
  31                  (compute-pollfds list (length list) how)
  32                (multiple-value-prog1
  33                    (values (alien-to-native pollfds count) map)
  34                  (free-alien pollfds))))
  35            (alien-to-native (pollfds n)
  36              (let ((result (make-list n)))
  37                (dotimes (i n result)
  38                  (setf (elt result i)
  39                        (list (slot (deref pollfds i) 'sb-unix:fd)
  40                              (slot (deref pollfds i) 'sb-unix:events))))))
  41            (bogotify (h)
  42              ;; a handler becomes bogus when the user hasn't removed
  43              ;; it from the list, but the kernel said EBADF on it.
  44              (setf (handler-bogus h) t)
  45              h)
  46            (run-test (&rest list)
  47              (sb-int:binding* (((fds1 map1) (try list nil))
  48                                ((fds2 map2) (try list t)))
  49                #+(or) (format t "~&~D handlers, ~D descriptors, ~D non-bogus~@
  50                                  ~:{(~D #b~b)~:^ ~}~%~S~%"
  51                               (length list)
  52                               (length (remove-duplicates
  53                                        list :key #'handler-descriptor))
  54                               (length (remove-duplicates
  55                                        (remove-if #'handler-bogus list)
  56                                        :key #'handler-descriptor))
  57                               fds1 map1)
  58                (loop for handler in list
  59                      for handler-index from 0
  60                      for fd-index = (svref map1 handler-index)
  61                      do (cond ((handler-bogus handler)
  62                                (assert (null fd-index))) ; isn't in fds[]
  63                               (t
  64                                (assert (eql (car (elt fds1 fd-index))
  65                                             (handler-descriptor handler))))))
  66                ;; the two algorithms for de-duplication of file descriptors
  67                ;; should be equivalent.
  68                (assert (equalp fds1 fds2))
  69                (assert (equalp map1 map2)))))
  70
  71     ;; Basic correctness
  72     (run-test (make-handler :output 1030 #'car)
  73               (make-handler :input 1028 #'car)
  74               (make-handler :input 500 #'car)
  75               (make-handler :output 500 #'car)
  76               (make-handler :input 1028 #'car)
  77               (make-handler :input 1030 #'car))
  78
  79     ;; this test is particularly insidious because descriptor 92
  80     ;; appears as both a bogus descriptor and non-bogus,
  81     ;; which probably can't happen in real life.
  82     (run-test (bogotify (make-handler :output 92 #'car))
  83               (make-handler :output 91 #'car)
  84               (make-handler :output 80 #'car)
  85               (make-handler :input 92 #'car)
  86               (make-handler :input 2 #'car)
  87               (bogotify (make-handler :input 5 #'car))
  88               (make-handler :input 3 #'car)
  89               (make-handler :input 2 #'cadr)
  90               (make-handler :input 1 #'car)
  91               (make-handler :input 2 #'car)
  92               (make-handler :input 9 #'car)
  93               (make-handler :input 55 #'car))))