diff options
| -rw-r--r-- | modules/language/python/module/os.scm | 262 |
1 files changed, 261 insertions, 1 deletions
diff --git a/modules/language/python/module/os.scm b/modules/language/python/module/os.scm index 6d00d27..f4e1caf 100644 --- a/modules/language/python/module/os.scm +++ b/modules/language/python/module/os.scm @@ -42,6 +42,23 @@ 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) @@ -1327,7 +1344,249 @@ (#: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 '())) @@ -1338,3 +1597,4 @@ (set '())) + |