[CL]Windowsでselect

CCL + CFFIでWindows上でselectしてみます。

(asdf:load-system :usocket)
(asdf:load-system :bordeaux-threads)
(asdf:load-system :cffi)

(defconstant FD-SETSIZE 64)

(cffi:defcstruct timeval
  (tv-sec :ulong)
  (tv-usec :ulong))

(cffi:defcstruct fd-set
  (fd-count :uint)
  (fd-array :uint :count 64))

(cffi:defcfun ("select" win-select) :int
  (nfds :int)
  (readfds :pointer)
  (writefds :pointer)
  (exceptfds :pointer)
  (timeout :pointer))

(defun fd-zero (set)
  (setf (cffi:foreign-slot-value set 'fd-set 'fd-count) 0))

(defun fd-set (fd set)
  (when (< (cffi:foreign-slot-value set 'fd-set 'fd-count) FD-SETSIZE)
    (setf (cffi:mem-aref (cffi:foreign-slot-pointer set 'fd-set 'fd-array)
    :uint
    (cffi:foreign-slot-value set 'fd-set 'fd-count))
   fd)
    (incf (cffi:foreign-slot-value set 'fd-set 'fd-count))))

(defun fd-isset (fd set)
  (cffi:foreign-funcall "__WSAFDIsSet" :uint fd ::pointer set :int))

(defun fd-clr (fd set)
  (loop
     :with count = (cffi:foreign-slot-value set 'fd-set 'fd-count)
     :with i = 0
     :while (<  i count)
     :if (= (cffi:mem-aref (cffi:foreign-slot-pointer set 'fd-set 'fd-array) :uint i) fd)
     :do (loop :while (< i (1- count))
     :do
     (setf (cffi:mem-aref (cffi:foreign-slot-pointer set 'fd-set 'fd-array) :uint i)
    (cffi:mem-aref (cffi:foreign-slot-pointer set 'fd-set 'fd-array) :uint (1+ i)))
     (incf i))
     (decf count)
     :else
     :do (incf i)
     :finally (setf (cffi:foreign-slot-value set 'fd-set 'fd-count) count)))


(defun test ()
  (let* ((listener (usocket:socket-listen "localhost" 8888 :reuse-address t))
  (listener-fd (ccl:socket-os-fd (usocket:socket listener)))
  (fds (list listener-fd))
  (fd-obj `((,listener-fd ,listener))))
    (format t "Listener Fd:~A~%" listener-fd)
  (cffi:with-foreign-object (set 'fd-set)
    (loop
       (fd-zero set)
       (dolist (fd fds) (fd-set fd set))
       (unless (= 0 (win-select
       (apply #'max fds)
       set
    (cffi:null-pointer) (cffi:null-pointer) (cffi:null-pointer)))
  (dolist (fd fds)
    (when (fd-isset fd set)
      (if (= fd listener-fd)
   (let* ((sock (usocket:socket-accept listener))
   (sock-fd (ccl:socket-os-fd (usocket:socket sock))))
     (format t "Accept~%")
     (force-output t)
     (push sock-fd fds)
     (push (list sock-fd sock) fd-obj))
   (progn
     (format t "ReadLine:~A~%"
      (read-line (usocket:socket-stream (second (assoc fd fd-obj)))))
     (force-output t))))))))))


;; (defparameter th (bordeaux-threads:make-thread #'test))
;; (defparameter *con* (usocket:socket-connect "localhost" 8888))
;; (format (usocket:socket-stream *con*) "Hello, World~%")
;; (force-output (usocket:socket-stream *con*))
;; (bordeaux-threads:destroy-thread th)