stat module added and further work on the os layer
authorStefan Israelsson Tampe <stefan.itampe@gmail.com>
Fri, 9 Mar 2018 17:22:57 +0000 (18:22 +0100)
committerStefan Israelsson Tampe <stefan.itampe@gmail.com>
Fri, 9 Mar 2018 17:22:57 +0000 (18:22 +0100)
modules/language/python/module/os.scm
modules/language/python/module/stat.scm [new file with mode: 0644]

index f12f1c511a025b623007f9d2126b4b0107dd3557..193bf4bb5d53305481195b58fbf26489a98f10c6 100644 (file)
@@ -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)
                   ))
 
 (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
 (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
   (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)
        
 (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
           (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
   (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)))))
+         
 
-               
 
 
+
+  
+             
diff --git a/modules/language/python/module/stat.scm b/modules/language/python/module/stat.scm
new file mode 100644 (file)
index 0000000..cb314b7
--- /dev/null
@@ -0,0 +1,38 @@
+(define-module (language python module stat)
+  #:export ())
+
+
+(define S_ISUID  #o04000)
+(define S_ISGID  #o02000)
+(define S_ENFMT  "error")
+(define S_ISVTX  #o01000)
+(define S_IREAD  #o00400)
+(define S_IWRITE #o00200)
+(define S_IEXEC  #o00100)
+(define S_IRWXU  (logior S_IEXEC S_IWRITE S_IREAD))
+(define S_IRUSR  S_IREAD)
+(define S_IWUSR  S_IWRITE)
+(define S_IXUSR  S_IEXEC)
+(define S_IRGRP  #o00040)
+(define S_IWGRP  #o00020)
+(define S_IXGRP  #o00010)
+(define S_IRWXG  (logior S_IXGRP S_IWGRP S_IRGRP))
+(define S_IROTH  #o00004)
+(define S_IWOTH  #o00002)
+(define S_IXOTH  #o00001)
+(define S_IRWXO  (logior S_IXOTH S_IWOTH S_IROTH))
+
+(define S_IFDIR   #o040000)
+(define S_IFMT    #o170000)
+(define S_IFREG   #o100000)
+(define S_IFLNK   #o120000)
+(define S_IFCHR   #o020000)
+(define S_IFBLK   #o060000)
+(define S_IFIFO   #o010000)
+    
+(define (is-dir? x) (= (logand x S_IFMT) S_IFDIR))
+(define (is-reg? x) (= (logand x S_IFMT) S_IFREG))
+(define (is-lnk? x) (= (logand x S_IFMT) S_IFLNK))
+(define (is-chr? x) (= (logand x S_IFMT) S_IFCHR))
+(define (is-blk? x) (= (logand x S_IFMT) S_IFBLK))
+(define (is-fif? x) (= (logand x S_IFMT) S_IFIFO))