processes
authorStefan Israelsson Tampe <stefan.itampe@gmail.com>
Wed, 14 Mar 2018 22:17:16 +0000 (23:17 +0100)
committerStefan Israelsson Tampe <stefan.itampe@gmail.com>
Wed, 14 Mar 2018 22:17:16 +0000 (23:17 +0100)
modules/language/python/module/os.scm

index 6d00d27b2bb61239b95c367db91eefd5d1b10542..f4e1caf9090d519c552d8205bfd05fc786fb0a6b 100644 (file)
                   pread pwrite read sendfile set_blocking get_blocking
                   set_blocking readv write writev set_inheritable
                   get_inheritable
+
+                  getxattr listxattr removexattr setxattr XATTR_SIZE_MAX
+                  XATTR_CREATE XATTR_REPLACE
+
+                  abort
+                  excl excle execlp execlpe excv excve execvp execvpe
+
+                  _exit
+                  EX_OK EX_USAGE EX_DATAERR EX_NOINPUT EX_NOUSER EX_NOHOST
+                  EX_UNAVAILABLE EX_SOFTWARE EX_OSERR EX_OSFILE EX_CANTCREAT
+                  EX_IOERR EX_TEMPFAIL EX_PROTOCOL
+
+                  spawnl spawnle spawnlp spawnlpe spawnv spawnve spawnvp
+                  spawnvpe
+
+                  P_WAIT P_NOWAIT P_NOWAIT0
+
                   ))
 
 (define error OSError)
       (#:finally:
        (close topfd)))))))
 
-      
+;; Extended attributes
+(define getxattr
+  (let ((f   (pointer->procedure int
+                                (dynamic-func "getxattr" (dynamic-link))
+                                ('* '* '* int)))
+        (lf  (pointer->procedure int
+                                (dynamic-func "lgetxattr" (dynamic-link))
+                                ('* '* '* int)))
+        (ff  (pointer->procedure int
+                                (dynamic-func "fgetxattr" (dynamic-link))
+                                ('* '* '* int))))
+    (lambda (path attribute #:key (follow_symlink #t))
+      (let ((path (ca (if (number? path)
+                          path
+                          (string->pointer (path-it path)))))
+             (k   (ca (string->pointer attribute))))
+         (let lp ((size 128))
+           (let ((v  (make-bytevector size))
+                 (pv (bytevector->pointer v)))
+             (let ((n (rm (if (number? path)
+                              (ff path k pv size)
+                              (if follow_symlink
+                                  (f path k pv size)
+                                  (lf path k pv size))))))
+               (if (> n (- size 2))
+                   (lp (* 2 size))
+                   (pointer->string pv)))))))))
+
+(define listxattr
+  (let ((f  (pointer->procedure int
+                                (dynamic-func "listxattr" (dynamic-link))
+                                ('* '* int)))
+        (lf (pointer->procedure int
+                                (dynamic-func "llistxattr" (dynamic-link))
+                                ('* '* int)))
+        (ff (pointer->procedure int
+                                (dynamic-func "flistxattr" (dynamic-link))
+                                ('* '* int))))
+    (define (mk l)
+      (define v  (make-bytevector (+ (length l) 1)))
+      (define vp (bytevector->pointer))
+      (let lp ((i 0) (l l))
+        (if (pair? l)
+            (begin
+              (bytevector-u8-set! v i (car l))
+              (lp (+ i 1) (cdr l)))
+            (begin
+              (bytevector-u8-set! v i 0)
+              (pointer->string vp)))))
+    
+    (lambda (path attribute #:key (follow_symlink #t))
+      (let ((path (if (number? path) path (string->pointer (path-it path)))))
+        (let lp ((size 128))
+          (let ((v  (make-bytevector size))
+                (pv (bytevector->pointer v)))
+            (let ((n (rm (if (number? path)
+                             (ff path pv size)
+                             (if follow_symlink
+                                 (f path pv size)
+                                 (lf path pv size))))))
+              (if (> n (- size 2))
+                  (lp (* 2 size))
+                  (let lp ((i 0) (l '()))
+                    (if (< i n)
+                        (let lp2 ((j i) (r '()))
+                          (if (< j n)
+                              (let ((x (bytevector-u8-ref v j)))
+                                (if (= x 0)
+                                    (if (null? r)
+                                        (lp  (+ j 1) l)
+                                        (lp  (+ j 1) (cons (mk (reverse r))
+                                                           l)))
+                                    (lp2 (+ j 1) (cons x r))))
+                              (if (null? r)
+                                  (lp j l)
+                                  (lp j (cons (mk (reverse r) l))))))
+                        (pylist (reverse l)))))))))))))
+
+(define removexattr
+  (let ((f  (pointer->procedure int
+                                (dynamic-func "removexattr" (dynamic-link))
+                                ('* '*)))
+        (lf (pointer->procedure int
+                                (dynamic-func "lremovexattr" (dynamic-link))
+                                ('* '*)))
+        (ff (pointer->procedure int
+                                (dynamic-func "fremovexattr" (dynamic-link))
+                                (int '*))))
+    (lambda (path attribute #:key (follow_symlink #t))
+      (let ((path (if (number? path)
+                      path
+                      (string->pointer (path-it path))))
+            (k    (ca (string->pointer attribute))))
+        (rm (if (number? path)
+                (ff path k)
+                (if follow_symlink
+                    (f  path k)
+                    (lf path k))))))))
+
+(define setxattr
+  (let ((f  (pointer->procedure int
+                                (dynamic-func "setxattr" (dynamic-link))
+                                ('* '* '* int int)))
+        (lf (pointer->procedure int
+                                (dynamic-func "lsetxattr" (dynamic-link))
+                                ('* '* '* int int)))
+        (ff (pointer->procedure int
+                                (dynamic-func "fsetxattr" (dynamic-link))
+                                (int '* '* int int))))
+    (lambda (path attribute value flags #:key (follow_symlink #t))
+      (let ((path (if (number? path) path (string->pointer (path-it path))))
+            (val  (ca (string->pointer value)))
+            (s    (string-length val))
+            (k    (ca (string->pointer attribute))))
+        (rm (if (number? path)
+                (ff path k val s flags)
+                (if follow_symlink
+                    (f  path k val s flags)
+                    (lf path k val s flags))))))))
+  
+(define XATTR_SIZE_MAX (ash 1 16))
+(define XATTR_CREATE  1)
+(define XATTR_REPLACE 2)
+
+;; Processes
+(define (abort) ((@ (guile) raise) (@ (guile) SIGABRT)))
+
+(define (comp e pth)
+  (if (eq? (string-ref pth 0) #\/)
+      pth
+      (let ((r (pylist-get e "PATH")))
+        (if r
+            (let lp ((l (string-split r #\:)))
+              (match l
+                ((pp . l)
+                 (let ((newpath (join pp p)))
+                   (if (exists newpath)
+                       newpath
+                       (lp l))))
+                (()
+                 pth)))
+            pth))))
+                 
+
+(define (compe e)
+  (for ((k v : e)) ((l '()))
+       (cons (string-append k "=" v) l)
+       #:final (reverse l)))
+
+(define (execl  path . args) (apply (@ (guile) execl) (path-it path) args))
+(define (execle path . args) (apply (@ (guile) execl) (path-it path)
+                                    (let* ((a (reverse args))
+                                           (e (compe (car args)))
+                                           (l (reverse (cdr args))))
+                                      (cons e l))))
+(define (execlpe path . args)      
+  (let* ((a (reverse args))
+         (e (compe (car args)))
+         (l (cons e (reverse (cdr args))))))
+  (apply (@ (guile) execle) (comp e (path-it path)) l)
+
+(define (execlp path . args) (apply (@ (guile) execlp) (path-it path) args))
+
+(define (execv path args)
+  (apply execl path (for ((a : args)) ((l '()))
+                         (cons a l)
+                         #:final (reverse l))))
+
+(define (execve path args env )
+  (apply execle path (for ((a : args)) ((l (list env)))
+                          (cons a l)
+                          #:final (reverse l))))
+
+(define (execvp path args)
+  (apply execlp path (for ((a : args)) ((l '()))
+                          (cons a l)
+                          #:final (reverse l))))
+
+(define (execvp path args env)
+  (apply execlpe path (for ((a : args)) ((l (list env)))
+                         (cons a l)
+                         #:final (reverse l))))
+
+
+
+(define (_exit n) (primitive-_exit n))
+
+(define EX_OK           0)
+(define EX_USAGE        64)
+(define EX_DATAERR      65)
+(define  EX_NOINPUT     66)
+(define EX_NOUSER       67)
+(define EX_NOHOST       68)
+(define EX_UNAVAILABLE  69)
+(define EX_SOFTWARE     70)
+(define EX_OSERR        71)
+(define EX_OSFILE       72)
+(define EX_CANTCREAT    73)
+(define EX_IOERR        74)
+(define EX_TEMPFAIL     75)
+(define EX_PROTOCOL     76)
+
+(define fork primitive-fork)
+
+(define (kill pid sig) (ca ((@ (guile) kill) pid sig)))
+
+(define (nice i) (ca ((@ (guile) nice) i)))
+
+(define killpg
+  (let ((f))
+    (lambda (pgid sig)
+      (rm (f pgid sig)))))
+
+(define (plock . l) (error "not implemented"))
+
+(define popen)
+
+(define P_WAIT 0)
+(define P_NOWAIT  1)
+(define P_NOWAIT0 1)
+
+(define-syntax-rule (mk-spawn f ff)
+  (define (f mode . l)
+    (let ((pid (primitive-fork)))
+      (if (= l 0)
+          (apply ff l)
+          (cond
+           ((= mode P_WAIT)
+            (cdr ((@ (guile) waitpid) pid)))
+           ((= mode P_NOWAIT)
+            pid)
+           (else
+            (raise ValueError "wrong mode specified in spawn command")))))))
+
+(mk-spawn spawnl    execl)
+(mk-spawn spawnle   execle)
+(mk-spawn spawnlp   execlp)
+(mk-spawn spawnlpe  execlpe)
+(mk-spawn spawnv    execv)
+(mk-spawn spawnve   execve)
+(mk-spawn spawnvp   execvp)
+(mk-spawn spawnvpe  execvpe)
+
 (define supprts_dir_fs
   (set '()))
 
   (set '()))
 
 
+