diff options
Diffstat (limited to 'modules/language/python/module/os.scm')
| -rw-r--r-- | modules/language/python/module/os.scm | 299 |
1 files changed, 280 insertions, 19 deletions
diff --git a/modules/language/python/module/os.scm b/modules/language/python/module/os.scm index f12f1c5..193bf4b 100644 --- a/modules/language/python/module/os.scm +++ b/modules/language/python/module/os.scm @@ -1,4 +1,6 @@ (define-module (language python module os) + #:use-module (ice-9 match) + #:use-module (ice-9 ftw) #:use-module (system foreign) #:use-module (oop pf-objects) #:use-module (oop goops) @@ -6,6 +8,7 @@ #:use-module (language python for) #:use-module ((language python module python) #:select (open)) #:use-module (language python try) + #:use-module (language python module stat) #:use-module (language python exceptions) #:use-module (language python yield) #:use-module (language python string) @@ -39,7 +42,11 @@ )) (define error 'OSError) - +(define errno + (let ((f (dynamic-pointer "errno" (dynamic-link)))) + (lambda () + (pointer-address (dereference-pointer f))))) + (define-syntax-rule (aif it p x y) (let ((it p)) (if it x y))) (define-syntax-rule (ca code) (catch #t @@ -48,7 +55,7 @@ (define-syntax-rule (rm code) (let ((r (ca code))) (if (< r 0) - (raise error) + (raise error (errno) ((@ (guile) strerror) (errno))) (values)))) (define-syntax guile @@ -328,10 +335,10 @@ (define (fdatasync fd) (error "not implemented")) (define (fpathconf fd name) (error "not implemented")) -(define (concat a ... stx) +(define-syntax-rule (concat a ... stx) (datum->syntax stx - (symbol->string + (string->symbol (string-append a ... (symbol->string @@ -341,18 +348,23 @@ (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))) + #'(begin (statset 1 m self scm) ...)) + ((_ 1 (m mm) self scm) + (with-syntax ((mem (concat "st_" #'mm)) + (smem (concat "stat:" #'m))) #'(set self 'mem (smem scm))))))) + ((_ 1 m self scm) + (statset 1 (m m) self scm)))) (define-python-class stat_result () (define __init__ (lambda (self scm) (ca - (statset (mode ino dev nlink uid gid size atime mtime ctime) + (statset (mode ino dev nlink uid gid size atime mtime ctime + (atimensec atime_ns) + (mtimensec mtime_ns) + (ctimensec ctime_ns) + blksize blocks perms rdev type) self scm))))) (name-object stat_result) @@ -710,7 +722,7 @@ (define listdir (lambda* (#:optional (pth ".")) (let ((pth (if (number? pth) - (read-link (format #f "/proc/self/fd/~a" pth)) + ((@ (guile) read-link) (format #f "/proc/self/fd/~a" pth)) (path-it pth)))) (let ((o (ca (opendir pth)))) (dynamic-wind @@ -724,23 +736,23 @@ (lambda x (closedir o))))))) (define stat - (let ((f (pointer->procedure 'int - (dynamic-func "fstatat" (dynamic-link)) - '(int * * int))) + (let ((f (pointer->procedure int + (dynamic-func "__fxstatat" (dynamic-link)) + (list int 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))) + (let ((path (path-it 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 + (let* ((bv (make-bytevector 80)) + (bvp (bytevector->pointer bv))) + (rm (f 1 ;Special linux flag (string->pointer path) bvp (if follow_symlinks @@ -752,8 +764,257 @@ (lambda* (path #:key (dir_fd None)) (stat path #:dir_fd dir_fd #:follow_symlinks #f))) +(define mkdir + (let ((fat (pointer->procedure int + (dynamic-func "mkdirat" (dynamic-link)) + (list int * int)))) + (lambda* (path mode #:key (dir_fd None)) + (rm (fat (if (eq? dir_fd None) AT_FDCWD dir_fd) + (string->pointer (path-it path)) + mode))))) + +(define* (mkdirs name mode #:key (exist_ok #f)) + (let lp ((pre "") (l (string-split (path-it name) #\/))) + (match l + (() (values)) + ((x) (let ((s (string-append pre "/" x))) + (catch #t + (lambda () + ((@ (guile) stat) s) + (if exist_ok + (values) + (raise error + (format #f "dir ~a in mkdirs already exist" s)))) + (lambda x + (mkdir s mode))))) + ((x . l) + (let ((s (string-append pre "/" x))) + (catch #t + (lambda () + ((@ (guile) stat) s)) + (lambda x + (mkdir s mode))) + (lp s l)))))) + +(define mkfifo + (let ((fat (pointer->procedure int + (dynamic-func "mkfifoat" (dynamic-link)) + (list int * int)))) + (lambda* (path mode #:key (dir_fd None)) + (rm (fat (if (eq? dir_fd None) AT_FDCWD dir_fd) + (string->pointer (path-it path)) + mode))))) + +(define mknod + (let ((fat (pointer->procedure int + (dynamic-func "mknodat" (dynamic-link)) + (list int * int)))) + (lambda* (path mode #:optional (device 0) #:key (dir_fd None)) + (rm (fat (if (eq? dir_fd None) AT_FDCWD dir_fd) + (string->pointer (path-it path)) + mode + device))))) + +(define major + (let ((f (pointer->procedure int + (dynamic-func "gnu_dev_major" (dynamic-link)) + (list int64)))) + (lambda (device) + (ca (f device))))) +(define minor + (let ((f (pointer->procedure int + (dynamic-func "gnu_dev_minor" (dynamic-link)) + (list int64)))) + (lambda (device) + (ca (f device))))) + +(define makedev + (let ((f (pointer->procedure int64 + (dynamic-func "gnu_dev_makedev" (dynamic-link)) + (list int int)))) + (lambda (major minor) + (ca (f major minor))))) + +(define pathconf_names (dict)) +(pylist-set! pathconf_names "PC_LINK_MAX" 0) +(pylist-set! pathconf_names "PC_MAX_CANON" 1) +(pylist-set! pathconf_names "PC_MAX_INPUT" 2) +(pylist-set! pathconf_names "PC_NAME_MAX" 3) +(pylist-set! pathconf_names "PC_PATH_MAX" 4) +(pylist-set! pathconf_names "PC_PIPE_BUF" 5) +(pylist-set! pathconf_names "PC_CHOWN_RESTRICTED" 6) +(pylist-set! pathconf_names "PC_NO_TRUNC" 7) +(pylist-set! pathconf_names "PC_VDISABLE" 8) + +(define-syntax-rule (rmp code) + (let ((e (errno)) + (r (ca code))) + (if (>= r 0) + r + (let ((e2 (errno))) + (if (eq? e e2) + (error "Bug could not find pathcond name endex") + (rm e2)))))) + + +(define pathconf + (let ((f (pointer->procedure long + (dynamic-func "pathconf" (dynamic-link)) + (list '* int))) + (ff (pointer->procedure long + (dynamic-func "fpathconf" (dynamic-link)) + (list int int)))) + (lambda (path name) + (let ((ni (pylist-ref pathconf_names name))) + (if (number? path) + (rmp (ff path ni)) + (let ((path (path-it path))) + (rmp (f (string->pointer path) ni)))))))) + +(define readlink + (let ((fat (pointer->procedure int + (dynamic-func "readlinkat" (dynamic-link)) + (list int * * long)))) + (lambda* (path #:key (dir_fd None)) + (let* ((n 10000) + (bv (make-bytevector 10000)) + (bvp (bytevector->pointer bv))) + (rm (fat (if (eq? dir_fd None) AT_FDCWD dir_fd) + (string->pointer (path-it path)) + bvp + n)) + (bytevector-u8-set! bv (- n 1) 0) + (pointer->string bvp))))) + + +(define remove + (let ((fat (pointer->procedure int + (dynamic-func "unlinkat" (dynamic-link)) + (list int * int)))) + (lambda* (path #:key (dir_fd None)) + (rm (fat (if (eq? dir_fd None) AT_FDCWD dir_fd) + (string->pointer (path-it path)) + 0))))) + +(define unlink remove) + +(define rmdir + (lambda (path #:key (dir_fd None)) + (let ((path (path-it path))) + (if (eq? dir_fd None) + ((@ (guile) rmdir) path) + (let* ((fd (open path O_DIRECTORY #:dir_fd dir_fd)) + (path ((@ (guile) read-link) ' + (format #f "/proc/self/fd/~a" fd)))) + (close fd) + ((@ (guile) rmdir) path)))))) + +(define (removedirs name) + (let ((name (path-it name))) + (let lp ((l (reverse (string-split name #\/)))) + (if (pair? l) + (let ((path (string-join (reverse l) "/"))) + (catch #t + (lambda () (rmdir path)) + (lambda x (values))) + (lp (cdr l))))))) + +(define rename + (let ((fat (pointer->procedure int + (dynamic-func "renameat" (dynamic-link)) + (list int * int *)))) + (lambda* (src dst #:key (src_dir_fd None) (dst_dir_fd None)) + (rm (fat (if (eq? src_dir_fd None) AT_FDCWD src_dir_fd) + (string->pointer (path-it src)) + (if (eq? dst_dir_fd None) AT_FDCWD dst_dir_fd) + (string->pointer (path-it src))))))) + + +(define replace rename) + +(define (renames old new) + (let ((old (path-it old)) + (new (path-it new))) + (let lp ((l (string-split new #\/)) (d '())) + (match l + (() #t) + ((x) #t) + (("" . l) + (lp l (cons "" d))) + ((x . l) + (if (pair? d) + (let ((path (string-join (reverse d) "/"))) + (catch #t + (lambda () (stat path)) + (lambda x (mkdir path))) + (lp l (cons x d))) + (lp l (cons x d)))))) + (rename old new) + (let ((l (split old #\/))) + (if (> (length l) 1) + (if (= (length l) 2) + (removedirs (string-concat (car l) "/")) + (removedirs (string-join (reverse (cdr (reverse l))) "/"))))) + (values))) + + + +(define-python-class DirEntry () + (define __init__ + (lambda (self path stat errno) + (set self 'name (basename path)) + (set self 'path path) + (set self '__errno errno) + (set self '__stat stat))) + + (define inode + (lambda (self) + (let ((stat (ref self '__stat))) + (if stat + (stat:ino stat) + (raise error (ref self '__errno)))))) + + (define is_dir + (lambda* (self #:key (follow_symlinks #t)) + (let ((s (stat (ref self 'path) #:follow_symlink follow_symlink))) + ((@ (stat) is-dir?) (ref s '_st_mode))))) + + (define is_file + (lambda* (self #:key (follow_symlinks #t)) + (let ((s (stat (ref self 'path) #:follow_symlink follow_symlink))) + ((@ (stat) is-reg?) (ref s '_st_mode))))) + + (define is_symlink + (lambda (self) + (let ((s (stat (ref self 'path)))) + ((@ (stat) is-lnk?) (ref s '_st_mode))))) + + (define stat + (lambda* (self #:key (follow_symlinks #t)) + (stat (ref self 'path) #:follow_symlinks follow_symlinks)))) + +(define* (scandir #:optional (path ".")) + (make-generator () + (lambda (yield) + (file-system-fold + (lambda x #t) + (lambda (path stat errno r) + (yield (DirEntry path stat errno))) + (lambda (path stat res) + (yield (DirEntry path stat 0))) + (lambda (path stat res) + (values)) + (lambda (path stat res) + (values)) + (lambda (path stat errno res) + (values)) + #f + (path-it path))))) + - + + + |