From 251c4964e9c80cdce0363e0902d0fd3e65b3ca96 Mon Sep 17 00:00:00 2001 From: Stefan Israelsson Tampe Date: Tue, 6 Mar 2018 19:53:03 +0100 Subject: further improvements of os module --- modules/language/python/module/os.scm | 712 +++++++++++++++++++++++++++++++++- 1 file changed, 704 insertions(+), 8 deletions(-) (limited to 'modules') diff --git a/modules/language/python/module/os.scm b/modules/language/python/module/os.scm index b5b8a18..f12f1c5 100644 --- a/modules/language/python/module/os.scm +++ b/modules/language/python/module/os.scm @@ -2,18 +2,68 @@ #:use-module (system foreign) #:use-module (oop pf-objects) #:use-module (oop goops) + #:use-module (rnrs bytevectors) #:use-module (language python for) + #:use-module ((language python module python) #:select (open)) + #:use-module (language python try) + #:use-module (language python exceptions) #:use-module (language python yield) #:use-module (language python string) - #:export (error name ctermid environ)) + #:use-module (language python bytes) + #:use-module (language python list) + #:export (error name ctermid environ environb chdir fchdir getcwd + fsencode fdencode fspath PathLike getenv getenvb + get_exec_path getgid getegid geteuid + getgroups getgrouplist getlogin getpgid getpgrp getpid + getppid PRIO_PROCESS PRIO_PRGRP PRIO_USER getpriority + getresgid getuid initgroups putenv setegid seteuid + setgid setgroups setpgrp setpgid setpriority setregid + setresgid setreuid setresuid getsid setsid setuid strerr + umask uname unsetenv + + dopen close closerange device_encoding dup dup2 fchmod fchown + fdatasync fpathconf fstat fstatvfs fsynch ftruncate isatty + F_LOCK F_TLOCK F_ULOCK F_TEST lockf + SEEK_SET SEEK_CUR SEEK_END SEEK_DATA SEEK_HOLE lseek + open O_RDONLY O_WRONLY O_RDWR O_APPEND O_CREAT O_EXCL + O_TRUNC O_SYNC O_NDELAY O_NONBLOCK O_NOCTTY O_LARGEFILE + O_NOTRANS O_DSYNC O_RSYNC O_CLOEXEC O_PATH O_DIRECTORY + O_NOFOLLOW O_DIRECT O_NOATIME O_ASYNC O_TMPFILE + openpty pipe pipe2 posix_fallocate + posix_fadvise POSIX_FADV_NORMAL POSIX_FADV_RANDOM + POSIX_FADV_SEQUENTIAL POSIX_FADV_WILLNEED + POSIX_FADV_DONTNEED POSIX_FADV_NOREUSE + pread pwrite read sendfile set_blocking get_blocking + set_blocking readv write writev set_inheritable + get_inheritable + )) (define error 'OSError) -(define name "posix") -(define ctermid - (@ (guile) ctermid)) + +(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) + (values)))) + +(define-syntax guile + (syntax-rules () + ((_ (x ...) code) (guile (x ...) code code)) + ((_ (x ...) code1 code2) + (define code1 (lambda (x ...) (ca ((@ (guile) code2 x ...)))))) + ((_ code) (guile code code)) + ((_ code1 code2) + (define code1 (lambda x (ca (apply (@ (guile) code2 x)))))))) +(define name "posix") +(guile ctermid) -(define environ +(define-values (environ environb) (let () (define e (dereference-pointer (dynamic-pointer "environ" (dynamic-link)))) (define (get-envs) @@ -40,7 +90,8 @@ (define __getitem__ (lambda (self k) - (getenv (slot-ref (pystring k) 'str)))) + (let ((r ((@ (guile) getenv) (slot-ref (pystring k) 'str)))) + (if r r (raise IndexError))))) (define __setitem__ (lambda (self k v) @@ -56,8 +107,653 @@ (lambda (yield) (for ((x : (getkw))) () (yield (car x) (cdr x))))))))) + + (define-python-class Envb () + (define __init__ + (lambda (self) (values))) + + (define __getitem__ + (lambda (self k) + (let ((r (bytes ((@ (guile) getenv) (slot-ref (string k) 'str))))) + (if r r (raise IndexError))))) + + (define __setitem__ + (lambda (self k v) + (putenv (slot-ref (string (+ k "=" v)) 'str)))) + + (define __delitem__ + (lambda (self k) + (putenv (slot-ref (string k) 'str)))) + + (define __iter__ + (lambda (self) + ((make-generator () + (lambda (yield) + (for ((x : (getkw))) () + (yield (car x) (cdr x))))))))) + + (values (Env) (Envb)))) + + +(guile (path) chdir) + +(define (fchdir fd) + (error "not implemented")) + +(guile () getcwd) + +(define (fsencode fn) + (error "not implemented")) +(define (fsdecode fn) + (error "not implemented")) + +(define-method (fspath (pth )) pth) +(define-method (fspath (pth )) pth) +(define-method (fspath (pth )) pth) +(define-method (fspath (pth )) pth) +(define-method (fspath (pth

)) + (aif it (ref pth '__fspath__) + (it) + (next-method))) + +(define-python-class PathLike () + (define __fspath__ + (lambda (self) (error "not implemented")))) + + +(define* (getenv key #:key (default None)) + (try + (lambda () + (pylist-ref environ key)) + (#:except IndexError => (lambda x default)))) + +(define* (getenvb key #:key (default None)) + (try + (lambda () + (pylist-ref environb key)) + (#:except IndexError => (lambda x default)))) + +(define* (get_exec_path #:key (env #f)) + (define (f s) + (let ((s (slot-ref (string s) 'str))) + (string-split str ":"))) + (if env + (f (pylist-ref env "PATH")) + (f (pylist-ref environ "PATH")))) + +(guile () getgid) +(guile () getegid) +(guile () geteuid) + +(define (getgrouplist user group) + (error "not impllemeneted")) + +(guile () getgroups) + +(guile getlogin) + +(define getpgid + (let ((f (pointer->procedure int + (dynamic-func "getpgid" (dynamic-link)) + (list int)))) + (lambda (pid) + (rm (f pid))))) + + +(guile getpgrp) +(guile getpid) +(guile getppid) + +(define PRIO_PROCESS (@ (guile) PRIO_PROCESS)) +(define PRIO_PRGRP (@ (guile) PRIO_PRGRP)) +(define PRIO_USER (@ (guile) PRIO_USER)) + +(guile getpriority) + +(define getresgid + (let* ((f (pointer->procedure + void + (dynamic-func "getresgid" (dynamic-link)) + '(* * *)))) + + (lambda () + (let* ((a (make-bytevector 8)) + (ap (bytevector->pointer a)) + (b (make-bytevector 8)) + (bp (bytevector->pointer b)) + (c (make-bytevector 8)) + (cp (bytevector->pointer c))) + (rm (f ap bp cp)) + (list + (bytevector-u16-ref a 0 (native-endianness)) + (bytevector-u16-ref b 0 (native-endianness)) + (bytevector-u16-ref c 0 (native-endianness))))))) + +(guile getuid) + +(define initgroup + (let ((f (pointer->procedure + 'int + (dynamic-func "initgroups" (dynamic-link)) + '(* int)))) + + (lambda (user group) + (rm (string->pointer user) group)))) + +(define (putenv key value) + (pylist-set! environ key value)) + +(guile setegid) +(guile seteuid) +(guile setgid) + +(guile setgroups) +(define setpgrp + (let ((f (pointer->procedure 'int + (dynamic-func "setpgrp" (dynamic-link)) + '()))) + (lambda () + (rm (f))))) + +(guile setpgid) +(guile setpriority) + +(define setregid + (let ((f (pointer->procedure 'int + (dynamic-func "setregid" (dynamic-link)) + '(int int)))) + (lambda (a b) + (rm (f a b))))) + +(define setresgid + (let ((f (pointer->procedure 'int + (dynamic-func "setresgid" (dynamic-link)) + '(int int int)))) + (lambda (a b c) + (rm (f a b c))))) + +(define setreuid + (let ((f (pointer->procedure 'int + (dynamic-func "setreuid" (dynamic-link)) + '(int int)))) + (lambda (a b) + (rm (f a b))))) + +(define setresuid + (let ((f (pointer->procedure 'int + (dynamic-func "setresuid" (dynamic-link)) + '(int int int)))) + (lambda (a b c) + (rm (f a b c))))) + +(guile getsid) +(guile setsid) +(guile setuid) +(guile strerror) +(guile umask) +(guile uname) +(guile unsetenv) + +;; File descriptor operations +(define fdopen open) + +(define close + (lambda (fd) + (ca (close-fd fd)))) + +(define (closerange fd_low fd_high) + (for ((i : (range low high))) () + (try: + (lambda () (close i)) + (#:except OSError => (lambda (x) (values)))))) + +(define device_encoding (lambda (fd) (error "not implemented"))) + +(guile (fd) dup) + +(define dup2 + (let ((f (pointer->procedure 'int + (dynamic-func "dup3" (dynamic-link)) + '(int int int)))) + (lambda* (fd fd2 #:optional (inheritable? #t)) + (if inheritable? + (rm (f fd fd2 O_CLOEXEC)) + (ca ((@ (guile) dup2) fd fd2)))))) + +(guile (fd mode) fchmod) +(guile (fd uid gid) fchown) + + +(define (fdatasync fd) (error "not implemented")) +(define (fpathconf fd name) (error "not implemented")) + +(define (concat a ... stx) + (datum->syntax + stx + (symbol->string + (string-append + a ... + (symbol->string + (syntax->datum stx)))))) + +(define-syntax statset + (lambda (x) + (syntax-case x () + ((_ (m ...) self scm) + (begin + (statset m self scm) ...)) + ((_ m self scm) + (with-syntax ((mem (concat "st_" #'m)) + (smem (concat "stat;" #'m))) + #'(set self 'mem (smem scm))))))) + +(define-python-class stat_result () + (define __init__ + (lambda (self scm) + (ca + (statset (mode ino dev nlink uid gid size atime mtime ctime) + self scm))))) +(name-object stat_result) + +(define (fstat fd) + (stat_result (stat fd))) + +(define (fstatvfs fd) (error "not implemented")) + +(guile (fd) fsynch fsync) + +(guil (fd len) ftruncate truncate-file) + +(guile (fd) isatty isatty?) + +(define F_LOCK 1) +(define F_TLOCK 2) +(define F_ULOCK 0) +(define F_TEST 3) +(define lockf + (let ((f (pointer->procedure 'int + (dynamic-func "lockf" (dynamic-link)) + '(int int long)))) + (lambda (fd op len) + (rm (f fd op len))))) + + + +(define SEEK_SET #x0) +(define SEEK_CUR #x1) +(define SEEK_END #x2) +(define SEEK_DATA #x3) +(define SEEK_HOLE #x4) + +(define lseek + (let ((f (pointer->procedure 'int + (dynamic-func "lseek" (dynamic-link)) + '(int long int)))) + (lambda (fd pos how) + (rm (f fd pos how))))) + +(define open + (let ((f (pointer->procedure 'int + (dynamic-func "openat" (dynamic-link)) + '(int * int int)))) + + (lambda* (path flags mode #:optional (dir_fd None)) + (if (eq? dir_fd None) + (ca (open-fdes path flags mode)) + (rm (f dir_fd (string->pointer path) flags mode)))))) + + +(define-syntax-rule (mko O) (define O (@ (guile) O))) +(mko O_RDONLY) +(mko O_WRONLY) +(mko O_RDWR) +(mko O_APPEND) +(mko O_CREAT) +(mko O_EXCL) +(mko O_TRUNC) + +;;unix +(mko O_SYNC) +(mko O_NDELAY) +(mko O_NONBLOCK) +(mko O_NOCTTY) + +;; +(mko O_LARGEFILE) +(mko O_NOTRANS) + +(define O_DSYNC #o10000) +(define O_RSYNC O_SYNC) +(define O_CLOEXEC #o2000000) +(define O_PATH #o10000000) +(define O_DIRECTORY #o200000) +(define O_NOFOLLOW #o400000) +(define O_DIRECT #o40000) +(define O_NOATIME #o1000000) +(define O_ASYNC #o20000) +(define O_TMPFILE (logior #o20000000 O_DIRECTORY)) + +(define openpty (lambda x (error "not implemented"))) + +(define pipe + (let ((x (ca (@ (guile) pipe)))) + (values (car x) (cdr x)))) + +(define pipe2 + (let ((f (pointer->procedure 'int + (dynamic-func "pipe2" (dynamic-link)) + '(int * int)))) + (lambda (flags) + (let* ((a (make-bytevector 16)) + (ap (bytevector->pointer a))) + (rm (f ap flags)) + (values (bytevector-s32-ref a 0) + (bytevector-s32-ref a 1)))))) + + +(define posix_fallocate + (let ((f (pointer->procedure 'int + (dynamic-func "posix_fallocate" (dynamic-link)) + '(int long long)))) + (lambda (fd off len) + (rm (f fd off len))))) + +(define posix_fadvise + (let ((f (pointer->procedure 'int + (dynamic-func "posix_fadvise" (dynamic-link)) + '(int long long int)))) + (lambda (fd off len advice) + (rm (f fd off len advice))))) + +(define POSIX_FADV_NORMAL 0) +(define POSIX_FADV_RANDOM 1) +(define POSIX_FADV_SEQUENTIAL 2) +(define POSIX_FADV_WILLNEED 3) +(define POSIX_FADV_DONTNEED 4) +(define POSIX_FADV_NOREUSE 5) + +(define pread + (let ((f (pointer->procedure 'int + (dynamic-func "pread" (dynamic-link)) + '(int * long long)))) + (lambda (fd size offset) + (let* ((a (make-bytevector size)) + (ap (bytevector->pointer a))) + (let ((n (rm (f fd ap size offset)))) + (if (= n 0) + (make-bytevector 0) + (let ((o (make ))) + (slot-set! o 'n (size)) + (slot-set! o 'size n) + (slot-set! o 'bv a) + o))))))) + +(define pwrite + (let ((f (pointer->procedure 'int + (dynamic-func "pwrite" (dynamic-link)) + '(int * long long)))) + + (lambda (fd a offset) + (let* ((ap (bytevector->pointer a))) + (rm (f fd ap size offset)))))) + +(define read + (let ((f (pointer->procedure 'int + (dynamic-func "read" (dynamic-link)) + '(int * long)))) + (lambda (fd size) + (let* ((a (make-bytevector size)) + (ap (bytevector->pointer a))) + (let ((n (rm (f fd ap size)))) + (if (= n 0) + (make-bytevector 0) + (let ((o (make ))) + (slot-set! o 'n (size)) + (slot-set! o 'size n) + (slot-set! o 'bv a) + o))))))) + +(define (sendfile out in offset count) + (ca + (if (eq? count None) + ((@ (guile) sendfile out in count)) + ((@ (guile) sendfile out in count offset))))) + +(define F_GETFL 3) +(define fcntl2 (pointer->procedure 'int + (dynamic-func "fcntl" (dynamic-link)) + '(int int))) +(define fcntl3 (pointer->procedure 'int + (dynamic-func "fcntl" (dynamic-link)) + '(int int INT))) + +(define (set_blocking fd is-blocking?) + (let ((o (rm (fcntl2 fd F_GETFL)))) + (if is-blocking? + (rm (fcntl3 fd F_GETFL (logior o O_NONBLOCK))) + (rm (fcntl3 fd F_GETFL (logand o (lognot O_NONBLOCK))))))) + +(define (get_blocking fd) + (if (= (logand O_NONBLOCK (rm (fcntl2 fd F_GETFL))) 0) + #f + #t)) + +(define (readv fd buffers) (error "not implemented")) + +(guile (fd pg) tcsetpgrp) +(guile (fd) ttyname) + +(define write + (let ((f (pointer->procedure 'int + (dynamic-func "write" (dynamic-link)) + '(int * long)))) + + (lambda (fd a) + (let* ((ap (bytevector->pointer a))) + (rm (f fd ap size)))))) + +(define (writev fd buffers) (error "not implemented")) - (Env))) -(for ((k v : environ)) () (pk k)) +(define (set_inheritable fd is-inh?) + (let ((o (rm (fcntl2 fd F_GETFL)))) + (if is-inh? + (rm (fcntl3 fd F_GETFL (logior o O_CLOEXEC))) + (rm (fcntl3 fd F_GETFL (logand o (lognot O_CLOEXEC))))))) + +(define (get_inheritable fd) + (if (= (logand O_CLOEXEC (rm (fcntl2 fd F_GETFL))) 0) + #f + #t)) + + +;; Files and dir +(define AT_EACCESS #x200) +(define AT_SYMLINK_NOFOLLOW #x100) + +(define F_OK (@ (guile) F_OK)) +(define W_OK (@ (guile) W_OK)) +(define R_OK (@ (guile) R_OK)) +(define X_OK (@ (guile) X_OK)) + +(define access + (let ((f (pointer->procedure 'int + (dynamic-func "access" (dynamic-link)) + '(* int))) + (fa (pointer->procedure 'int + (dynamic-func "faccessat" (dynamic-link)) + '(* int int int)))) + + (lambda* (path mode #:key + (dir_fd None) + (effective_ids #f) + (follow_symlinks #t)) + (if (eq? dir_fd None) + (rm (f (string->pointer path) mode)) + (rm (fa (string->pointer path) mode dir_fd + (logior (if effective_ids AT_EACCESS 0) + (if follow_symlinks 0 AT_SYMLINK_NOFOLLOW)))))))) + + + +(define chdir + (let ((f (pointer->procedure 'int + (dynamic-func "access" (dynamic-link)) + '(*)))) + (lambda (pth) + (let ((pth (aif it (ref pth '__fspath__) + (it) + pth))) + (if (int? pth) + (rm (f pth)) + (ca ((@ (guile) chdir) pth))))))) + + +(define chflags + (lambda x (error "Not implemented"))) + +(define chmod + (let ((f (pointer->procedure 'int + (dynamic-func "chmod" (dynamic-link)) + '(* int))) + (ff (pointer->procedure 'int + (dynamic-func "fchmod" (dynamic-link)) + '(int int))) + (fat (pointer->procedure 'int + (dynamic-func "fchmodat" (dynamic-link)) + '(* int int int)))) + (lambda* (path mode #:key (dir_fd None) (follow_symlinks #t)) + (if (int? path) + (rm (ff path mode)) + (let ((path (aif it (ref path '__fspath__) + (it) + path))) + (if (eq? dir_fd None) + (rm (f (string->pointer path) mode)) + (rm (fat (string->pointer path) mode + dir_fd + (if follow_symlinks + 0 + AT_SYMLINK_NOFOLLOW))))))))) + + + +(define (path-it path) + (aif it (ref path '__fspath__) + (it) + path)) + +(define chown + (let ((f (pointer->procedure 'int + (dynamic-func "chown" (dynamic-link)) + '(* int int))) + (ff (pointer->procedure 'int + (dynamic-func "fchown" (dynamic-link)) + '(int int int))) + (lf (pointer->procedure 'int + (dynamic-func "lchow" (dynamic-link)) + '(* int int))) + (fat (pointer->procedure 'int + (dynamic-func "fchownat" (dynamic-link)) + '(* int int int int)))) + (lambda* (path uid gid #:key (dir_fd None) (follow_symlinks #t)) + (if (int? path) + (rm (ff path uid gid)) + (let ((path (path-it path))) + (if (eq? dir_fd None) + (if follow_symlinks + (rm (f (string->pointer path) uid gid)) + (rm (lf (string->pointer path) uid gid))) + (rm (fat (string->pointer path) uid gid dir_fd + (if follow_symlinks + 0 + AT_SYMLINK_NOFOLLOW))))))))) + +(guile ((x)) chroot) + +(define fchdir chdir) + +(guile () getcwd) + +(define (getcwdb) + (byte (getcwd))) + +(define lchflags (lambda x (error "not implemented"))) + +(define (lchmod path mode) + (chmod path mode #:follow_symlinks #f)) + +(define (lchown path uid gid) + (chown path uid gid #:follow_symlinks #f)) + +(define link + (let ((f (pointer->procedure 'int + (dynamic-func "linkat" (dynamic-link)) + '(* * int int int)))) + (lambda* (src dst #:key + (src_dir_fd None) + (dst_dir_fd None), + (follow_symlinks #t)) + (let ((src (path-it src)) + (dst (path-it dst)) + (src_dir_fd (if (eq? src_dir_fd None) AT_FDCWD src_dir_fd)) + (dst_dir_fd (if (eq? dst_dir_fd None) AT_FDCWD dst_dir_fd))) + (rm (f (string->pointer src) + (string->pointer dst) + src_dir_fd + dst_dir_fd + (if follow_symlinks + 0 + AT_SYMLINK_NOFOLLOW))))))) + +(define listdir + (lambda* (#:optional (pth ".")) + (let ((pth (if (number? pth) + (read-link (format #f "/proc/self/fd/~a" pth)) + (path-it pth)))) + (let ((o (ca (opendir pth)))) + (dynamic-wind + (lambda x #f) + (lambda () + (let lp ((o ) (l '())) + (let ((w (ca (readdir o)))) + (if (eof-object? w) + '() + (cons w (lp o)))))) + (lambda x (closedir o))))))) + +(define stat + (let ((f (pointer->procedure 'int + (dynamic-func "fstatat" (dynamic-link)) + '(int * * int))) + (g (pointer->procedure '* + (dynamic-func "scm_stat2scm_" (dynamic-link)) + '(*)))) + (lambda* (path #:key (dir_fd None) (follow_symlinks #t)) + (if (number? path) + (stat_result ((@ (guile) stat) path)) + (let ((path (get-path path))) + (if (eq? dir_fd None) + (if follow_symlinks + (stat_result ((@ (guile) stat) path)) + (stat_result ((@ (guile) lstat) path))) + (let ((bv (make-bytevector 80)) + (bvp (bytevector->pointer bv))) + (rm (f dir_fd + (string->pointer path) + bvp + (if follow_symlinks + 0 + AT_SYMLINK_NOFOLLOW))) + (stat_result (ca (pointer->scm (g bvp))))))))))) + +(define lstat + (lambda* (path #:key (dir_fd None)) + (stat path #:dir_fd dir_fd #:follow_symlinks #f))) + + + + + + -- cgit v1.2.3