diff options
Diffstat (limited to 'modules/language/python/module')
-rw-r--r-- | modules/language/python/module/errno.scm | 9 | ||||
-rw-r--r-- | modules/language/python/module/os.scm | 2 | ||||
-rw-r--r-- | modules/language/python/module/os/path.scm | 142 | ||||
-rw-r--r-- | modules/language/python/module/pwd.scm | 72 |
4 files changed, 224 insertions, 1 deletions
diff --git a/modules/language/python/module/errno.scm b/modules/language/python/module/errno.scm new file mode 100644 index 0000000..fd2f7c9 --- /dev/null +++ b/modules/language/python/module/errno.scm @@ -0,0 +1,9 @@ +(define-module (language python module errno) + #:use-module (system foreign) + #:export (errno)) + + +(define errno + (let ((f (dynamic-pointer "errno" (dynamic-link)))) + (lambda () + (pointer-address (dereference-pointer f))))) diff --git a/modules/language/python/module/os.scm b/modules/language/python/module/os.scm index 1dbe30e..e5b2b79 100644 --- a/modules/language/python/module/os.scm +++ b/modules/language/python/module/os.scm @@ -41,7 +41,7 @@ get_inheritable )) -(define error 'OSError) +(define error OSError) (define errno (let ((f (dynamic-pointer "errno" (dynamic-link)))) (lambda () diff --git a/modules/language/python/module/os/path.scm b/modules/language/python/module/os/path.scm new file mode 100644 index 0000000..d9f2e3b --- /dev/null +++ b/modules/language/python/module/os/path.scm @@ -0,0 +1,142 @@ +(define-module (language python module os path) + #:use-module (language python module os) + #:use-module (language python module pwd) + #:export (abspath basename commonpath commonprefix dirname exists + lexists expanduser expandvars getatime getmtime + getctime getsize isabs isfile isdir islink ismount + normcase normpath realpath relpath samefile sameopenfile + samestat split splitdrive splitext splitunc + supports_unicode_filenames)) + + + +(define (abspath path) + (let ((path (path-it path))) + (if (eq? (string-ref path 0) #\/) + (normpath path) + (normpath (string-append (getcwd) "/" path))))) + +(define (basename path) ((@ (guile) basename) (path-it path))) + +(define (commonprefix paths) + (letrec ((l (for ((p paths)) ((l '())) + (cons (string->list (normpath p)) l) + #:final l)) + (f (lambda (l) + (let lp ((l l)) ((r #f) (d '())) + (match l + ((() . _) '()) + (((x . u) . l) + (if r + (if (equal? r x) + (lp l r (cons u d)) + '()) + (lp l x (cons u d)))) + (() + (if r (cons r (f d)) '()))))))) + (list->string (f l)))) + +(define (commonpath paths) + (define kind + (for ((p paths)) ((e #f)) + (let ((x (if (isabs (path-it p)) 'abs 'rel))) + (if e + (if (eq? e x) + e + (raise ValueError "Not all paths of the same type")) + x)) + #:final e)) + + (if (not kind) (raise ValueError "No paths")) + + (letrec ((l (for ((p paths)) ((l '())) + (cons (string-split (normpath p) #\/) l) + #:final l)) + (f (lambda (l) + (let lp ((l l)) ((r #f) (d '())) + (match l + ((() . _) '()) + (((x . u) . l) + (if r + (if (equal? r x) + (lp l r (cons u d)) + '()) + (lp l x (cons u d)))) + (() + (if r (cons r (f d)) '()))))))) + (if (equal? kind 'abs) + (string-append "/" (string-join (f l) "/")) + (string-join (f l) "/")))) + + +(define (dirname p) ((@ (guile) dirname) (path-it p))) +(define (exists p) + (if (number? p) + (catch #t + (lambda () ((@ (guile) readlink) (format #f "/proc/self/fd/~a" p))) + (lambda x #f)) + (catch #t + (lambda () ((@ (guile) stat) (path-it p)) #t) + (lambda x #f)))) + +(define (lexists p) + (if (number? p) + (catch #t + (lambda () ((@ (guile) readlink) (format #f "/proc/self/fd/~a" p))) + (lambda x #f)) + (catch #t + (lambda () ((@ (guile) lstat) (path-it p)) #t) + (lambda x #f)))) + + +(define (expanduser p) + (define (lookup-user u) + (ref (getpwnam u) 'pw_dir)) + + (define (lookup-self) + (ref (getpwuid (getuid)) 'pw_dir)) + + (define path (path-it p)) + + (if (eq? (string-ref path 0) #\~) + (if (and (> (string-length path) 1) (not (eq? (string-ref path 1) #\/))) + (let* ((l (string-split path "/")) + (a (car l)) + (u (list->string (cdr (string->list a))))) + (string-join (cons (lookup-user u) (cdr l)) "/")) + (let ((pw (getenv "PATH"))) + (if pw + (string-join (append (string-split pw "/") + (cdr (string-split path #\/))) + "/") + (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) + + + + + diff --git a/modules/language/python/module/pwd.scm b/modules/language/python/module/pwd.scm new file mode 100644 index 0000000..0996db3 --- /dev/null +++ b/modules/language/python/module/pwd.scm @@ -0,0 +1,72 @@ +(define-module (language python module pwd) + #:use-module (oop pf-objects) + #:use-module (language python module collections abc) + #:use-module (language python exceptions) + #:use-module (language python yield) + #:export (getpwuid getpwname getpwall)) + +(define-python-class PWD (Sequence) + (define __init__ + (lambda (self a0 a1 a2 a3 a4 a5 a6) + (set self 'pw_name a0) + (set self 'pw_passwd a1) + (set self 'pw_uid a2) + (set self 'pw_gid a3) + (set self 'pw_gecos a4) + (set self 'pw_dir a5) + (set self 'pw_shell a6))) + + (define __len__ + (lambda (self) 7)) + + (define __getitem__ + (lambda (self n) + (case n + ((0) (ref self 'pw_name)) + ((1) (ref self 'pw_passwd)) + ((2) (ref self 'pw_uid)) + ((3) (ref self 'pw_gid)) + ((4) (ref self 'pw_gecos)) + ((5) (ref self 'pw_dir)) + ((6) (ref self 'pw_shell)) + (else + (raise KeyError "only ref 0-6")))))) + +(define-syntax-rule (ca code) + (catch #t + (lambda () code) + (lambda x (raise OSError x)))) + +(define (getpwuid uid) + (ca (apply PWD (vector->list ((@ (guile) getpwuid) uid))))) + +(define (getpwname nm) + (ca (apply PWD (vector->list ((@ (guile) getpwnam) nm))))) + +(define (getpwall) + (define l + (let lp ((l (vector->list ((@ (guile) getgroups)))) (r '())) + (if (pair? l) + (let* ((v (getgrgid (car l))) + (u (vector-ref v 0)) + (w (vector-ref v 3))) + (let lp2 ((w w) (r (if (member u r) r (cons u r)))) + (if (pair? w) + (if (member (car w) r) + (lp2 (cdr w) r) + (lp2 (cdr w) (cons (car w) r))) + (lp (cdr l) r)))) + r))) + ((make-generator () + (lambda (yield) + (let lp ((l l)) + (if (pair? l) + (begin + (catch #t + (lambda () (yield (getpwname (car l)))) + (lambda x #f)) + (lp (cdr l))))))))) + + + + |