tests/autoclose-stream.impure.lisp

   1 ;;; This is in its own file to avoid being the recipient
   2 ;;; of unanticipated effects on the file descriptor space
   3 ;;; due to co-located tests.
   4
   5 ;;; don't know how to check validity of a HANDLE in the win32 api
   6 #-unix (invoke-restart 'run-tests::skip-file)
   7
   8 (defun fd-has-finalizer-p (fd)
   9   (labels
  10       ((checkit (thing)
  11            ;; Return T if THING is a closure created in MAKE-FD-STREAM
  12            ;; (which is assumed to be a stream finalizer) whose payload
  13            ;; contains the integer FD.
  14            (when (and (sb-kernel:closurep thing)
  15                       (eql (sb-kernel:%closure-index-ref thing 0) fd))
  16              (let ((underlying (sb-kernel:%closure-fun thing)))
  17                (when (and (sb-kernel:simple-fun-p underlying)
  18                           (equal (sb-kernel:%simple-fun-name underlying)
  19                                  '(lambda () :in sb-sys:make-fd-stream)))
  20                  (return-from fd-has-finalizer-p t)))))
  21        (scan-actions (actions)
  22          (dolist (f (sb-int:ensure-list actions))
  23            (checkit (if (functionp f) f (sb-kernel:value-cell-ref f))))))
  24     #+weak-vector-readbarrier
  25     (dolist (cell sb-impl::**finalizer-store**)
  26       (scan-actions (cdr cell)))
  27     #-weak-vector-readbarrier
  28     (sb-lockless:so-maplist
  29      (lambda (node) (scan-actions (sb-lockless:so-data node)))
  30      sb-impl::**finalizer-store**)))
  31
  32 (defvar *fds*)
  33 (defun make-streams ()
  34   (let (streams)
  35     (dotimes (i 6)
  36       (push (open "autoclose-stream.impure.lisp") streams))
  37     (dolist (stream streams)
  38       (assert (fd-has-finalizer-p (sb-impl::fd-stream-fd stream))))
  39     (setq *fds*
  40           (mapcar (lambda (x)
  41                     (cons (sb-impl::fd-stream-fd x) (make-weak-pointer x)))
  42                   streams))
  43     (dolist (fd *fds*)
  44       (let ((errno (nth-value 1 (sb-unix:unix-lseek (car fd) 0 sb-unix:l_incr))))
  45         (assert (zerop errno))))))
  46
  47 (defun assert-invalid-file-descriptor (fd)
  48   (let ((errno (nth-value 1 (sb-unix:unix-lseek fd 0 sb-unix:l_incr))))
  49     (assert (= errno sb-unix:ebadf))))
  50
  51 (compile 'make-streams)
  52
  53 (with-test (:name :finalizer-closes-fdstream)
  54   (make-streams)
  55   (gc)
  56   (sb-kernel:run-pending-finalizers)
  57   (sb-sys:scrub-control-stack)
  58   (let ((nsmashed 0))
  59     (dolist (entry *fds*)
  60       (let ((fd (car entry))
  61             (wp (cdr entry)))
  62         (unless (weak-pointer-value wp)
  63           (incf nsmashed)
  64           (assert-invalid-file-descriptor fd))))
  65     (format t "::: INFO: ~d streams closed~%" nsmashed)))