path: root/modules/language/python/module/select.scm

(define-module (language python module select)
  #:use-module (language python module errno)
  #:use-module ((language python module os) #:prefix os:)
  #:use-module (language python exceptions)
  #:use-module (language python list)
  #:use-module (language python try)
  #:use-module (language python def)
  #:use-module (oop pf-objects)
  #:use-module (system foreign)
  #:use-module (rnrs bytevectors)
  
  #:export (select poll epoll error PIPE_BUF
                   EPOLLIN EPOLLOUT EPOLLPRI EPOLLERR EPOLLHUP EPOLLET
                   EPOLLONESHOT EPOLLWAKEUP EPOLLEXCLUSIVE EPOLLRDHUP
                   EPOLLRDNORM EPOLLRDBAND EPOLLWRNORM EPOLLWRBAND EPOLLMSG
                   POLLERR POLLHUP POLLNVAL POLLIN POLLOUT POLLRDHUP
                   POLLPRI POLLREMOVE POLLMSG))

(define PIPE_BUF 1024)
  
(define-syntax-rule (aif it p x y) (let ((it p)) (if it x y)))

(define-syntax-rule (ca code)
  (catch #t
    (lambda () code)
    (lambda x (raise error x))))

(define-syntax-rule (rm code)
  (let ((r (ca code)))
    (if (< r 0)
        (raise error (errno) ((@ (guile) strerror) (errno)))
        r)))

(define-syntax-rule (defineu f x)
  (begin
    (define f
      (catch #t
        (lambda () x)
        (lambda z
          (let ((message (format #f "could not define ~a" 'f)))
            (warn message)
            (lambda z (error message))))))))

(define error OSError)

(define devpoll
  (lambda () (error "devpoll not supported")))

(define kqueue
  (lambda () (error "kqueue not supported")))

(define kevent
  (lambda x (error "kevent not supported")))

(define EPOLL_CTL_ADD 1)
(define EPOLL_CTL_MOD 3)
(define EPOLL_CTL_DEL 2)

(defineu epoll-create
  (let* ((f  (pointer->procedure
              int
              (dynamic-func "epoll_create" (dynamic-link))
              (list int))))
    (lambda () (f 0))))

(defineu epoll-ctl
  (let* ((f  (pointer->procedure
              int
              (dynamic-func "epoll_ctl" (dynamic-link))
              (list int int int '*))))
    (lambda (efd op fd event)
      (rm (let ((v (make-bytevector 16)))
            (bytevector-s32-set! v 0 event (native-endianness))
            (bytevector-s64-set! v 4 fd    (native-endianness))
            (f efd op fd (bytevector->pointer v)))))))

(defineu epoll-wait
  (let* ((f  (pointer->procedure
              int
              (dynamic-func "epoll_wait" (dynamic-link))
              (list '* int int))))
    (lambda (efd max timout)
      (let ((v (make-pointer 0)))
        (let* ((n (f efd v max timout))
               (v (pointer->bytevector v (* n 12))))
          (let lp ((i 0) (l '()))
            (if (< i n)
                (let ((op (bytevector-s32-ref v (* i 12)
                                              (native-endianness)))
                      (fd (bytevector-s64-ref v (+ (* i 12) 4)
                                              (native-endianness))))
                  (lp (+ i 1) (cons (list op fd) l)))
                (reverse l))))))))
                

                
            
            

(define-python-class epoll ()
  (define __init__
    (lam (self (= sizehint -1) (= flags 0) (= fd #f))
         (if fd
             (set self '__fd fd)
             (set self '__fd (epoll-create)))
         (set self '__closed #f)))

  (define close
    (lambda (self)
      (when (not (ref self '__closed))
        (os:close (ref self '__fd))
        (set self '__closed #t))))

  (define closed
    (lambda (self) (ref self '__closed)))

  (define fileno
    (lambda (self) (ref self '__fd)))

  (define fromfd
    (lambda (fd)
      (epoll #:fd fd)))

  (define __enter__
    (lambda (self) #t))

  (define __exit__ close)
      
  (define register
    (lambda* (self fd #:optional (eventmask 0))
      (if (not (closed self))
          (epoll-ctl (ref self '__fd)
                     EPOLL_CTL_ADD
                     fd
                     eventmask))))

  (define modify
    (lambda (self fd eventmask)
      (if (not (closed self))
          (epoll-ctl (ref self '__fd)
                     EPOLL_CTL_MOD
                     fd
                     eventmask))))

  (define unregister
    (lambda (self fd)
      (if (not (closed self))
          (epoll-ctl (ref self '__fd)
                     EPOLL_CTL_DEL
                     fd
                     0))))

  (define poll
    (lam (self (= timeout -1) (= maxevents -1))
         (epoll-wait
          (ref self '__fd)
          maxevents
          (if (< timeout 0)
              -1
              (inexact->exact (floor (* 1000 timeout))))))))
      
(define EPOLLIN  #x1)
(define EPOLLOUT #x4)
(define EPOLLPRI #x2)
(define EPOLLERR #x8)
(define EPOLLHUP #x10)
(define EPOLLET        (ash 1 31))
(define EPOLLONESHOT   (ash 1 30))
(define EPOLLWAKEUP    (ash 1 29))
(define EPOLLEXCLUSIVE (ash 1 28))
(define EPOLLRDHUP  #x2000)
(define EPOLLRDNORM #x40)
(define EPOLLRDBAND #x80)
(define EPOLLWRNORM #x100)
(define EPOLLWRBAND #x200)
(define EPOLLMSG    #x400)


(define POLLERR    #x8)
(define POLLMSG    #x400)
(define POLLREMOVE #x1000)
(define POLLHUP    #x10)
(define POLLNVAL   #x20)
(define POLLIN     #x1)
(define POLLPRI    #x2)
(define POLLOUT    #x4)
(define POLLRDHUP  #x2000)


(defineu pollf
  (let* ((f  (pointer->procedure
              int
              (dynamic-func "poll" (dynamic-link))
              (list '* int int))))
    (lambda (fds n timespec)
      (rm (f fds n (inexact->exact (floor (* 1000 timespec))))))))


(define-python-class poll ()
  (define __init__
    (lambda (self)
      (set self '__data '())))

  (define register
    (lambda* (self fd #:optional (eventmask 0))
      (set self '__cache #f)
      (let ((data (ref self '__data)))
        (if (assoc fd data)
            (raise (error "poll registering of already registered fd"))
            (set self '__data (cons (cons fd eventmask) data))))))

  (define modify
    (lambda (self fd eventmask)
      (set self '__cache #f)
      (let ((data (ref self '__data)))
        (aif it (assoc fd data)
             (set-cdr! it eventmask)
             (begin
               (set_errno ENOENT)
               (raise (error "modifying non existant fd")))))))

  (define unregister
    (lambda (self fd)
      (set self '__cache #f)
      (set self '__data
           (let lp ((l (ref self '__data)))
             (if (pair? l)
                 (let ((x (car l)))
                   (if (= (car x) fd)
                       (cdr l)
                       (cons x (lp (cdr l)))))
                 '())))))

  (define poll
    (let ((k 8))
      (lambda* (self #:optional (timeout -1))
        (define (make-data-pt data n)
          (let ((v (make-bytevector (* n k))))
            (let lp ((i 0) (l data))
              (if (pair? l)
                  (begin
                    (bytevector-s32-set! v (* i k)    (caar l)
                                         (native-endianness))
                    (bytevector-s16-set! v (+ (* i k) 4) (cdar l)
                                         (native-endianness))
                    (bytevector-s16-set! v (+ (* i k) 6) 0
                                         (native-endianness))
                    (lp (+ i 1) (cdr l)))
                  (bytevector->pointer v)))))

        (call-with-values
            (lambda ()
              (aif it (ref self '__cache)
                   (let ((n (ref self '__n)))
                     (pollf it n timeout)
                     (values it n))
                   (let* ((data (ref self '__data))
                          (n    (length data))
                          (x    (make-data-pt data n)))
                     (set self '__cache x)
                     (set self '__n     n)
                     (pollf x n timeout)
                     (values x n))))
          
          (lambda (x n)
            (let ((v (pointer->bytevector x (* k n))))
              (let lp ((i 0)) 
                (if (< i n)
                    (let ((fd (bytevector-s32-ref v (* i k)
                                                  (native-endianness)))
                          (y  (bytevector-s16-ref v (+ (* i k) 6)
                                                  (native-endianness))))
                      (if (not (= y 0))
                          (cons (list fd y) (lp (+ i 1)))
                          (lp (+ i 1))))
                    '())))))))))

  
(define* (select rl wl xl #:optional (timeout 0))
  (let ((m (inexact->exact (floor timeout)))
        (n (modulo (inexact->exact (floor (* 1000000 timeout))) 1000000)))
    ((@ (guile) select) (to-list rl) (to-list wl) (to-list xl) m n)))