(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)))