diff options
Diffstat (limited to 'modules/language/python/module/os')
| -rw-r--r-- | modules/language/python/module/os/path.scm | 182 |
1 files changed, 156 insertions, 26 deletions
diff --git a/modules/language/python/module/os/path.scm b/modules/language/python/module/os/path.scm index d9f2e3b..8846bd5 100644 --- a/modules/language/python/module/os/path.scm +++ b/modules/language/python/module/os/path.scm @@ -1,6 +1,10 @@ (define-module (language python module os path) #:use-module (language python module os) #:use-module (language python module pwd) + #:use-module (language python module errno) + #:use-module (language python for) + #:use-module (language python exceptions) + #:use-module (oop pg-objects) #:export (abspath basename commonpath commonprefix dirname exists lexists expanduser expandvars getatime getmtime getctime getsize isabs isfile isdir islink ismount @@ -8,7 +12,18 @@ samestat split splitdrive splitext splitunc supports_unicode_filenames)) - +(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 OSError x)))) + +(define (path-it path) + (aif it (ref path '__fspath__) + (it) + path)) + (define (abspath path) (let ((path (path-it path))) @@ -16,7 +31,7 @@ (normpath path) (normpath (string-append (getcwd) "/" path))))) -(define (basename path) ((@ (guile) basename) (path-it path))) +(define (basename path) (ca ((@ (guile) basename) (path-it path)))) (define (commonprefix paths) (letrec ((l (for ((p paths)) ((l '())) @@ -69,7 +84,7 @@ (string-join (f l) "/")))) -(define (dirname p) ((@ (guile) dirname) (path-it p))) +(define (dirname p) (ca ((@ (guile) dirname) (path-it p)))) (define (exists p) (if (number? p) (catch #t @@ -112,29 +127,144 @@ (string-join (append (string-split (lookup-self) "/") (cdr (string-split path #\/))))))))) - -(define expandvars) -(define getatime) -(define getmtime) -(define getctime) -(define getsize) -(define isabs) -(define isfile) -(define isdir) -(define islink) -(define ismount) -(define normcase) -(define normpath) -(define realpath) -(define relpath) -(define samefile) -(define sameopenfile) -(define samestat) -(define split) -(define splitdrive) -(define splitext) -(define splitunc) -(define supports_unicode_filenames) +(define f-var (f-mk (f-or! + (f-seq (f-tag! "$") (f+ (f-reg! "[a-zA-Z0-9]"))) + (f-seq (f-tag! "$") (f-tag "{") (f+ (f-not! (f-tag "}"))) + (f-tag "}"))))) +(define (expandvars p) + (let lp ((l (f-split (path-it p) f-var)) (r '())) + (match l + ((a b . l) + (lp l (cons* (getenv b) a r))) + ((a) + (apply string-append (reverse (cons a r)))) + (() + (apply string-append (reverse r)))))) + + +(define (getatime p) + (ca (stat:atime ((@ (guile) stat) (path-it p))))) + +(define (getmtime p) + (ca (stat:mtime ((@ (guile) stat) (path-it p))))) + +(define (getctime p) + (ca (stat:ctime ((@ (guile) stat) (path-it p))))) + +(define (getsize p) + (ca (stat:size ((@ (guile) stat) (path-it p))))) + +(define (isabs p) + (eq? (string-ref (path-it p) 0) #\/)) + + +(define (isfile p) + (ca (S_ISREG (stat:mode ((@ (guile) stat) (path-it p)))))) + +(define (isdir p) + (ca (S_ISDIR (stat:mode ((@ (guile) stat) (path-it p)))))) + +(define (islink p) + (ca (S_ISLNK (stat:mode ((@ (guile) stat) (path-it p)))))) + +(define (ismount p) + (ca + (let* ((p (path-it p)) + (q (string-append p "/.."))) + (not (= (stat:dev ((@ (guile) stat) p)) + (stat:dev ((@ (guile) stat) q))))))) + + + (normpath (string-join (map path-it l) "/"))) + +(define (normcase x) x) + +(define join (@@ (language python module os) path:join)) +(define normpath (@@ (language python module os) path:normpath)) +(define samestat (@@ (language python module os) path:samestat)) + +(define realpath + (let ((free (pointer->procedure void + (dynamic-func "free" (dynamic-link)) + (list '*))) + (f (pointer->procedure '* + (dynamic-func "realpath" (dynamic-link)) + (list '* long)))) + (lambda (p) + (let ((s (ca (f (string->pointer (path-it p)) 0)))) + (if (eq? (pointer-address s) 0) + (raise OSError (format #f "realpath fails with errnp ~a" (errno))) + (let ((ret (pointer->string s))) + (free s) + ret)))))) + +(define* (relpath p #:optional (start curpath)) + (define l1 (string-aplit (realpath (path-it p)) #\/)) + (define l2 (string-split (realpath start)) #\/) + (define red (lambda (x s) (cons ".." s))) + (let lp ((l1 l1) (l2 l2)) + (match (cons l1 l2) + (((x . l1) . (y . l2)) + (if (equal? x y) + (lp l1 l2) + (string-join + (append + (reduce red '() (cons y l2)) + l1) + "/"))) + ((() . l) + (string-join (reduce red '() l) "/")) + ((l) + (string-join l "/"))))) + +(define (samefile p1 p2) + (samestat (stat p1) (stat p2))) + +(define (sameopenfile p1 p2) + (samestat (stat p1) (stat p2))) + +(define (split p) + (let ((l (string-split (path-it p) #\/))) + (match l + ((_ ... "") + (list (path-it p) "")) + ((x) + (list "" x)) + ((l ... x) + (list (string-join (append l (list "")) "/") x))))) + +(define (splitdrive p) + (let* ((l (string-split (path-it p) #\/))) + (let lp ((l l) (r '())) + (let ((p1 (string-join (reverse r) "/"))) + (if (ismount p1) + (list p1 (string-join (cons "" l) "/")) + (if (pair? l) + (lp (cdr l) (cons (car l) r)) + (list "" (string-join (reverse r) "/")))))))) + +(define (splitext p) + (let ((x (string-split (path-it p) #\.))) + (match x + (("" y . l) + (if (pair? l) + (let* ((r (reverse l)) + (e (car r)) + (l (cons* "" y (reverse (cdr l))))) + (list (string-join l ".") (string-append "." e))) + (list x ""))) + ((y . l) + (if (pair? l) + (let* ((r (reverse l)) + (e (car r)) + (l (cons* y (reverse (cdr l))))) + (list (string-join l ".") (string-append "." e))) + (list x "")))))) + + +(define (splitunc p) (splitdrive p)) + +(define supports_unicode_filenames #t) |