pwd module

5 files changed, 226 insertions, 1 deletions

diff --git a/modules/language/python/exceptions.scm b/modules/language/python/exceptions.scm
index 51928b9..2922f3f 100644
--- a/modules/language/python/exceptions.scm
+++ b/modules/language/python/exceptions.scm
@@ -5,6 +5,7 @@
                           Exception ValueError TypeError
                           IndexError KeyError AttributeError
                           SyntaxError SystemException
+                          OSError
                           None))
 
 (define-syntax-rule (aif it p x y) (let ((it p)) (if it x y)))
@@ -20,6 +21,7 @@
 (define TypeError        'TypeError)
 (define AttributeError   'AttributeError)
 (define SyntaxError      'SyntaxError)
+(define OSError          'OSError)
 
 (define-python-class Exception ()
   (define __init__
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)))))))))
+           
+           
+                     
+