select module added
authorStefan Israelsson Tampe <stefan.itampe@gmail.com>
Wed, 25 Jul 2018 18:29:07 +0000 (20:29 +0200)
committerStefan Israelsson Tampe <stefan.itampe@gmail.com>
Wed, 25 Jul 2018 18:29:07 +0000 (20:29 +0200)
modules/language/python/module/select.scm [new file with mode: 0644]

diff --git a/modules/language/python/module/select.scm b/modules/language/python/module/select.scm
new file mode 100644 (file)
index 0000000..ae2f9e6
--- /dev/null
@@ -0,0 +1,284 @@
+(define-module (languge 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 (oop pf-objects)
+  #:use-module (system foreign)
+  #:use-module (rnrs bytevectors)
+  
+  #:export (select poll epoll devpoll kqueue kevent 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-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 select)
+
+(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-i32-set! 0 event (native-endianness))
+            (bytevector-i64-set! 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-i32-ref v (* i 12)
+                                              (nativ-endianness)))
+                      (fd (bytevector-i64-ref v (+ (* i 12) 4)
+                                              (nativ-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 ((= timeout -1) (= maxevents -1))
+         (epoll-wait
+          (ref self '__fd)
+          maxevents
+          (if (< timeout 0)
+              -1
+              (inexact->exact (floor (* 1000 timeout))))))))
+      
+
+(define PIPE_BUF 1024)
+(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 timespac))))))))
+
+
+(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
+               (errno_set 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* (#: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-i32-set! v (* i k)    (caar l)
+                                         (native-endianness))
+                    (bytevector-i16-set! v (+ (* i k) 4) (cdar l)
+                                         (native-endianness))
+                    (bytevector-i16-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 lp ((i 0)) 
+              (if (< i n)
+                  (let ((fd (bytevector-i32-ref v (* i k)
+                                                (nativ-endianness)))
+                        (y  (bytevector-i16-ref v (+ (* i k) 6)
+                                                (nativ-endianness))))
+                    (if (not (= y 0))
+                        (cons (list fd y) (lp (+ i 1)))
+                        (lp (+ i 1))))
+                  '()))))))))
+
+  
+(define* (select rl wl xl #:optional (timout 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)))
+
+