path: root/modules/language/python/module/os.scm

(define-module (language python module os)
  #:use-module (system foreign)
  #:use-module (oop pf-objects)
  #:use-module (oop goops)
  #:use-module (rnrs bytevectors)
  #:use-module (language python for)
  #:use-module ((language python module python) #:select (open))
  #:use-module (language python try)
  #:use-module (language python exceptions)
  #:use-module (language python yield)
  #:use-module (language python string)
  #:use-module (language python bytes)
  #:use-module (language python list)
  #:export (error name ctermid environ environb chdir fchdir getcwd
                  fsencode fdencode fspath PathLike getenv getenvb
                  get_exec_path getgid getegid geteuid
                  getgroups getgrouplist getlogin getpgid getpgrp getpid
                  getppid PRIO_PROCESS PRIO_PRGRP PRIO_USER getpriority
                  getresgid getuid initgroups putenv setegid seteuid
                  setgid setgroups setpgrp setpgid setpriority setregid
                  setresgid setreuid setresuid getsid setsid setuid strerr
                  umask  uname  unsetenv

                  dopen close closerange device_encoding dup dup2 fchmod fchown
                  fdatasync fpathconf fstat fstatvfs fsynch ftruncate isatty
                  F_LOCK F_TLOCK F_ULOCK F_TEST lockf
                  SEEK_SET SEEK_CUR SEEK_END SEEK_DATA SEEK_HOLE lseek
                  open O_RDONLY O_WRONLY O_RDWR O_APPEND O_CREAT O_EXCL
                  O_TRUNC O_SYNC O_NDELAY O_NONBLOCK O_NOCTTY O_LARGEFILE
                  O_NOTRANS O_DSYNC O_RSYNC O_CLOEXEC O_PATH O_DIRECTORY
                  O_NOFOLLOW O_DIRECT O_NOATIME O_ASYNC O_TMPFILE
                  openpty pipe pipe2 posix_fallocate
                  posix_fadvise POSIX_FADV_NORMAL POSIX_FADV_RANDOM
                  POSIX_FADV_SEQUENTIAL POSIX_FADV_WILLNEED
                  POSIX_FADV_DONTNEED POSIX_FADV_NOREUSE
                  pread pwrite read sendfile set_blocking get_blocking
                  set_blocking readv write writev set_inheritable
                  get_inheritable
                  ))

(define error 'OSError)

(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 error x))))
(define-syntax-rule (rm code)
  (let ((r (ca code)))
    (if (< r 0)
        (raise error)
        (values))))

(define-syntax guile
  (syntax-rules ()
    ((_ (x ...) code)        (guile (x ...) code code))
    ((_ (x ...) code1 code2)
     (define code1 (lambda (x ...) (ca ((@ (guile) code2 x ...))))))
    ((_ code) (guile code code))
    ((_ code1 code2)
     (define code1 (lambda x (ca (apply (@ (guile) code2 x))))))))
    
(define name  "posix")
(guile ctermid)

(define-values (environ environb)
  (let ()
    (define e (dereference-pointer (dynamic-pointer "environ" (dynamic-link))))
    (define (get-envs)
      (let lp ((e e))
        (let ((*e  (dereference-pointer e)))
          (if (null-pointer? *e)
              '()
              (cons
               (pointer->string *e)
               (lp (make-pointer (+ (pointer-address e) 8))))))))
    
    (define (getkw)
      (let lp ((es (get-envs)))
        (if (pair? es)
            (let ((x (string-split (car es) #\=)))
              (let ((k (car x))
                    (v (string-join (cdr x) "=")))
                (cons (cons k v) (lp (cdr es)))))
            '())))

    (define-python-class Env ()
      (define __init__
        (lambda (self) (values)))

      (define __getitem__
        (lambda (self k)
          (let ((r ((@ (guile) getenv) (slot-ref (pystring k) 'str))))
            (if r r (raise IndexError)))))

      (define __setitem__
        (lambda (self k v) 
          (putenv (slot-ref (pystring (+ k "=" v)) 'str))))

      (define __delitem__
        (lambda (self k)
          (putenv (slot-ref (pystring k) 'str))))
      
      (define __iter__
        (lambda (self)
          ((make-generator ()
             (lambda (yield)
               (for ((x : (getkw))) ()
                    (yield (car x) (cdr x)))))))))

    (define-python-class Envb ()
      (define __init__
        (lambda (self) (values)))

      (define __getitem__
        (lambda (self k)
          (let ((r (bytes ((@ (guile) getenv) (slot-ref (string k) 'str)))))
            (if r r (raise IndexError)))))

      (define __setitem__
        (lambda (self k v) 
          (putenv (slot-ref (string (+ k "=" v)) 'str))))

      (define __delitem__
        (lambda (self k)
          (putenv (slot-ref (string k) 'str))))
      
      (define __iter__
        (lambda (self)
          ((make-generator ()
             (lambda (yield)
               (for ((x : (getkw))) ()
                    (yield (car x) (cdr x)))))))))
    
    
    (values (Env) (Envb))))


(guile (path) chdir)

(define (fchdir fd)
  (error "not implemented"))

(guile () getcwd)

(define (fsencode fn)
  (error "not implemented"))
(define (fsdecode fn)
  (error "not implemented"))

(define-method (fspath (pth <string>      )) pth)
(define-method (fspath (pth <py-string>   )) pth)
(define-method (fspath (pth <py-bytes>    )) pth)
(define-method (fspath (pth <py-bytearray>)) pth)
(define-method (fspath (pth <p>           ))
  (aif it (ref pth '__fspath__)
       (it)
       (next-method)))

(define-python-class PathLike ()
  (define __fspath__
    (lambda (self) (error "not implemented"))))


(define* (getenv key #:key (default None))
  (try
   (lambda ()
     (pylist-ref environ key))
   (#:except IndexError => (lambda x default))))

(define* (getenvb key #:key (default None))
  (try
   (lambda ()
     (pylist-ref environb key))
   (#:except IndexError => (lambda x default))))

(define* (get_exec_path #:key (env #f))
  (define (f s)
    (let ((s (slot-ref (string s) 'str)))
      (string-split str ":")))      
  (if env
      (f (pylist-ref env     "PATH"))
      (f (pylist-ref environ "PATH"))))
      
(guile () getgid)
(guile () getegid)
(guile () geteuid)
  
(define (getgrouplist user group)
  (error "not impllemeneted"))

(guile () getgroups)

(guile getlogin)

(define getpgid
  (let ((f (pointer->procedure int
                               (dynamic-func "getpgid" (dynamic-link))
                               (list int))))
    (lambda (pid)
      (rm (f pid)))))

  
(guile getpgrp)
(guile getpid)
(guile getppid)

(define PRIO_PROCESS (@ (guile) PRIO_PROCESS))
(define PRIO_PRGRP   (@ (guile) PRIO_PRGRP))
(define PRIO_USER    (@ (guile) PRIO_USER))

(guile getpriority)

(define getresgid
  (let* ((f  (pointer->procedure
              void
              (dynamic-func "getresgid" (dynamic-link))
              '(* * *))))
         
    (lambda ()
      (let* ((a  (make-bytevector 8))
             (ap (bytevector->pointer a)) 
             (b (make-bytevector 8))
             (bp (bytevector->pointer b)) 
             (c (make-bytevector 8))
             (cp (bytevector->pointer c)))
        (rm (f ap bp cp))
        (list
         (bytevector-u16-ref a 0 (native-endianness))
         (bytevector-u16-ref b 0 (native-endianness))
         (bytevector-u16-ref c 0 (native-endianness)))))))

(guile getuid)

(define initgroup
  (let ((f (pointer->procedure
            'int
            (dynamic-func "initgroups" (dynamic-link))
            '(* int))))
         
    (lambda (user group)
      (rm (string->pointer user) group))))

(define (putenv key value)
  (pylist-set! environ key value))

(guile setegid)
(guile seteuid)
(guile setgid)

(guile setgroups)
(define setpgrp
  (let ((f (pointer->procedure 'int
                               (dynamic-func "setpgrp" (dynamic-link))
                               '())))
    (lambda ()
      (rm (f)))))

(guile setpgid)
(guile setpriority)

(define setregid
  (let ((f (pointer->procedure 'int
                               (dynamic-func "setregid" (dynamic-link))
                               '(int int))))
    (lambda (a b)
      (rm (f a b)))))

(define setresgid
  (let ((f (pointer->procedure 'int
                               (dynamic-func "setresgid" (dynamic-link))
                               '(int int int))))
    (lambda (a b c)
      (rm (f a b c)))))

(define setreuid
  (let ((f (pointer->procedure 'int
                               (dynamic-func "setreuid" (dynamic-link))
                               '(int int))))
    (lambda (a b)
      (rm (f a b)))))

(define setresuid
  (let ((f (pointer->procedure 'int
                               (dynamic-func "setresuid" (dynamic-link))
                               '(int int int))))
    (lambda (a b c)
      (rm (f a b c)))))

(guile getsid)
(guile setsid)
(guile setuid)
(guile strerror)
(guile umask)
(guile uname)
(guile unsetenv)

;; File descriptor operations
(define fdopen open)

(define close
  (lambda (fd)
    (ca (close-fd fd))))

(define (closerange fd_low fd_high)
  (for ((i : (range low high))) ()
       (try:
        (lambda () (close i))
        (#:except OSError => (lambda (x) (values))))))

(define device_encoding (lambda (fd) (error "not implemented")))

(guile (fd) dup)

(define dup2
  (let ((f (pointer->procedure 'int
                               (dynamic-func "dup3" (dynamic-link))
                               '(int int int))))
    (lambda* (fd fd2 #:optional (inheritable? #t))
      (if inheritable?
          (rm (f fd fd2 O_CLOEXEC))
          (ca ((@ (guile) dup2) fd fd2))))))
      
(guile (fd mode) fchmod)
(guile (fd uid gid) fchown)


(define (fdatasync fd) (error "not implemented"))
(define (fpathconf fd name) (error "not implemented"))

(define (concat a ... stx)
  (datum->syntax
   stx
   (symbol->string
    (string-append
     a ...
     (symbol->string
      (syntax->datum stx))))))

(define-syntax statset
  (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)))
         #'(set self 'mem (smem scm)))))))

(define-python-class stat_result ()
  (define __init__
     (lambda (self scm)
       (ca
        (statset (mode ino dev nlink uid gid size atime mtime ctime)
                 self scm)))))
(name-object stat_result)
       
(define (fstat fd)
  (stat_result (stat fd)))

(define (fstatvfs fd) (error "not implemented"))

(guile (fd) fsynch fsync)

(guil (fd len) ftruncate truncate-file)

(guile (fd) isatty isatty?)

(define F_LOCK  1)
(define F_TLOCK 2)
(define F_ULOCK 0)
(define F_TEST  3)
(define lockf
  (let ((f (pointer->procedure 'int
                               (dynamic-func "lockf" (dynamic-link))
                               '(int int long))))
    (lambda (fd op len)
      (rm (f fd op len)))))



(define SEEK_SET  #x0)
(define SEEK_CUR  #x1)
(define SEEK_END  #x2)
(define SEEK_DATA #x3)
(define SEEK_HOLE #x4)

(define lseek 
  (let ((f (pointer->procedure 'int
                               (dynamic-func "lseek" (dynamic-link))
                               '(int long int))))
    (lambda (fd pos how)      
      (rm (f fd pos how)))))

(define open
  (let ((f (pointer->procedure 'int
                               (dynamic-func "openat" (dynamic-link))
                               '(int * int int))))

    (lambda* (path flags mode #:optional (dir_fd None))
      (if (eq? dir_fd None)
          (ca (open-fdes path flags mode))
          (rm (f dir_fd (string->pointer path) flags mode))))))
        

(define-syntax-rule (mko O) (define O (@ (guile) O)))
(mko O_RDONLY)
(mko O_WRONLY)
(mko O_RDWR)
(mko O_APPEND)
(mko O_CREAT)
(mko O_EXCL)
(mko O_TRUNC)

;;unix
(mko O_SYNC)
(mko O_NDELAY)
(mko O_NONBLOCK)
(mko O_NOCTTY)

;;
(mko O_LARGEFILE)
(mko O_NOTRANS)

(define O_DSYNC     #o10000)
(define O_RSYNC     O_SYNC)
(define O_CLOEXEC   #o2000000)
(define O_PATH      #o10000000)
(define O_DIRECTORY #o200000)
(define O_NOFOLLOW  #o400000)
(define O_DIRECT    #o40000)
(define O_NOATIME   #o1000000)
(define O_ASYNC     #o20000)
(define O_TMPFILE   (logior #o20000000 O_DIRECTORY))

(define openpty (lambda x (error "not implemented")))

(define pipe
  (let ((x (ca (@ (guile) pipe))))
    (values (car x) (cdr x))))

(define pipe2
  (let ((f (pointer->procedure 'int
                               (dynamic-func "pipe2" (dynamic-link))
                               '(int * int))))
    (lambda (flags)
      (let* ((a  (make-bytevector 16))
             (ap (bytevector->pointer a)))
        (rm (f ap flags))
        (values (bytevector-s32-ref a 0)
                (bytevector-s32-ref a 1))))))


(define posix_fallocate
  (let ((f (pointer->procedure 'int
                               (dynamic-func "posix_fallocate" (dynamic-link))
                               '(int long long))))
    (lambda (fd off len)
      (rm (f fd off len)))))

(define posix_fadvise
   (let ((f (pointer->procedure 'int
                               (dynamic-func "posix_fadvise" (dynamic-link))
                               '(int long long int))))
    (lambda (fd off len advice)
      (rm (f fd off len advice)))))

(define POSIX_FADV_NORMAL     0)
(define POSIX_FADV_RANDOM     1)
(define POSIX_FADV_SEQUENTIAL 2)
(define POSIX_FADV_WILLNEED   3)
(define POSIX_FADV_DONTNEED   4)
(define POSIX_FADV_NOREUSE    5)

(define pread
  (let ((f (pointer->procedure 'int
                               (dynamic-func "pread" (dynamic-link))
                               '(int * long long))))
    (lambda (fd size offset)
      (let* ((a  (make-bytevector size))
             (ap (bytevector->pointer a)))
        (let ((n (rm (f fd ap size offset))))
          (if (= n 0)
              (make-bytevector 0)
              (let ((o (make <bytevector>)))
                (slot-set! o 'n (size))
                (slot-set! o 'size n)
                (slot-set! o 'bv   a)
                o)))))))

(define pwrite
  (let ((f (pointer->procedure 'int
                               (dynamic-func "pwrite" (dynamic-link))
                               '(int * long long))))
  
    (lambda (fd a offset)
      (let* ((ap (bytevector->pointer a)))
        (rm (f fd ap size offset))))))

(define read
  (let ((f (pointer->procedure 'int
                               (dynamic-func "read" (dynamic-link))
                               '(int * long))))
    (lambda (fd size)
      (let* ((a  (make-bytevector size))
             (ap (bytevector->pointer a)))
        (let ((n (rm (f fd ap size))))
          (if (= n 0)
              (make-bytevector 0)
              (let ((o (make <bytevector>)))
                (slot-set! o 'n (size))
                (slot-set! o 'size n)
                (slot-set! o 'bv   a)
                o)))))))

(define (sendfile out in offset count)
  (ca
   (if (eq? count None)
       ((@ (guile) sendfile out in count))
       ((@ (guile) sendfile out in count offset)))))

(define F_GETFL 3)
(define fcntl2 (pointer->procedure 'int
                                   (dynamic-func "fcntl" (dynamic-link))
                                   '(int int)))
(define fcntl3 (pointer->procedure 'int
                                   (dynamic-func "fcntl" (dynamic-link))
                                   '(int int INT)))

(define (set_blocking fd is-blocking?)
  (let ((o (rm (fcntl2 fd F_GETFL))))
    (if is-blocking?
        (rm (fcntl3 fd F_GETFL (logior o O_NONBLOCK)))
        (rm (fcntl3 fd F_GETFL (logand o (lognot O_NONBLOCK)))))))

(define (get_blocking fd)
  (if (= (logand O_NONBLOCK (rm (fcntl2 fd F_GETFL))) 0)
      #f
      #t))

(define (readv fd buffers) (error "not implemented"))

(guile (fd pg) tcsetpgrp)
(guile (fd)    ttyname)

(define write
  (let ((f (pointer->procedure 'int
                               (dynamic-func "write" (dynamic-link))
                               '(int * long))))
  
    (lambda (fd a)
      (let* ((ap (bytevector->pointer a)))
        (rm (f fd ap size))))))

(define (writev fd buffers) (error "not implemented"))
    

(define (set_inheritable fd is-inh?)
  (let ((o (rm (fcntl2 fd F_GETFL))))
    (if is-inh?
        (rm (fcntl3 fd F_GETFL (logior o O_CLOEXEC)))
        (rm (fcntl3 fd F_GETFL (logand o (lognot O_CLOEXEC)))))))

(define (get_inheritable fd)
  (if (= (logand O_CLOEXEC (rm (fcntl2 fd F_GETFL))) 0)
      #f
      #t))


;; Files and dir
(define AT_EACCESS          #x200)
(define AT_SYMLINK_NOFOLLOW #x100)

(define F_OK (@ (guile) F_OK))
(define W_OK (@ (guile) W_OK))
(define R_OK (@ (guile) R_OK))
(define X_OK (@ (guile) X_OK))

(define access
  (let ((f  (pointer->procedure 'int
                               (dynamic-func "access" (dynamic-link))
                               '(* int)))
        (fa (pointer->procedure 'int
                                (dynamic-func "faccessat" (dynamic-link))
                                '(* int int int))))

    (lambda* (path mode #:key
                   (dir_fd None)
                   (effective_ids #f)
                   (follow_symlinks #t))
      (if (eq? dir_fd None)
          (rm (f  (string->pointer path) mode))
          (rm (fa (string->pointer path) mode dir_fd
                  (logior (if effective_ids AT_EACCESS 0)
                          (if follow_symlinks 0 AT_SYMLINK_NOFOLLOW))))))))



(define chdir
  (let ((f (pointer->procedure 'int
                               (dynamic-func "access" (dynamic-link))
                               '(*))))
    (lambda (pth)
      (let ((pth (aif it (ref pth '__fspath__)
                      (it)
                      pth)))
        (if (int? pth)
            (rm (f pth))
            (ca ((@ (guile) chdir) pth)))))))


(define chflags
  (lambda x (error "Not implemented")))

(define chmod
  (let ((f   (pointer->procedure 'int
                                 (dynamic-func "chmod" (dynamic-link))
                                 '(* int)))
        (ff  (pointer->procedure 'int
                                 (dynamic-func "fchmod" (dynamic-link))
                                 '(int int)))
        (fat (pointer->procedure 'int
                                 (dynamic-func "fchmodat" (dynamic-link))
                                 '(* int int int))))
  (lambda* (path mode #:key (dir_fd None) (follow_symlinks #t))
    (if (int? path)
        (rm (ff path mode))
        (let ((path (aif it (ref path '__fspath__)
                         (it)
                         path)))
          (if (eq? dir_fd None)
              (rm (f   (string->pointer path) mode))
              (rm (fat (string->pointer path) mode
                       dir_fd
                       (if follow_symlinks
                           0
                           AT_SYMLINK_NOFOLLOW)))))))))



(define (path-it path)
  (aif it (ref path '__fspath__)
       (it)
       path))

(define chown
  (let ((f   (pointer->procedure 'int
                                 (dynamic-func "chown" (dynamic-link))
                                 '(* int int)))
        (ff  (pointer->procedure 'int
                                 (dynamic-func "fchown" (dynamic-link))
                                 '(int int int)))
        (lf  (pointer->procedure 'int
                                 (dynamic-func "lchow" (dynamic-link))
                                 '(* int int)))
        (fat (pointer->procedure 'int
                                 (dynamic-func "fchownat" (dynamic-link))
                                 '(* int int int int))))
    (lambda* (path uid gid #:key (dir_fd None) (follow_symlinks #t))
      (if (int? path)
          (rm (ff path uid gid))
          (let ((path (path-it path)))
            (if (eq? dir_fd None)
                (if follow_symlinks
                    (rm (f  (string->pointer path) uid gid))
                    (rm (lf (string->pointer path) uid gid)))
                (rm (fat (string->pointer path) uid gid dir_fd
                         (if follow_symlinks
                             0
                             AT_SYMLINK_NOFOLLOW)))))))))

(guile ((x)) chroot)

(define fchdir chdir)

(guile () getcwd)

(define (getcwdb)
  (byte (getcwd)))

(define lchflags (lambda x (error "not implemented")))

(define (lchmod path mode)
  (chmod path mode #:follow_symlinks #f))

(define (lchown path uid gid)
  (chown path uid gid #:follow_symlinks #f))

(define link
  (let ((f (pointer->procedure 'int
                                 (dynamic-func "linkat" (dynamic-link))
                                 '(* * int int int))))
    (lambda* (src dst #:key
                  (src_dir_fd None)
                  (dst_dir_fd None),
                  (follow_symlinks #t))
      (let ((src (path-it src))
            (dst (path-it dst))
            (src_dir_fd (if (eq? src_dir_fd None) AT_FDCWD src_dir_fd))
            (dst_dir_fd (if (eq? dst_dir_fd None) AT_FDCWD dst_dir_fd)))
        (rm (f (string->pointer src)
               (string->pointer dst)
               src_dir_fd
               dst_dir_fd
               (if follow_symlinks
                   0
                   AT_SYMLINK_NOFOLLOW)))))))

(define listdir
  (lambda* (#:optional (pth "."))
    (let ((pth (if (number? pth)
                   (read-link (format #f "/proc/self/fd/~a" pth))
                   (path-it pth))))
      (let ((o (ca (opendir pth))))
        (dynamic-wind
          (lambda x #f)
          (lambda ()
            (let lp ((o ) (l '()))
              (let ((w (ca (readdir o))))
                (if (eof-object? w)
                    '()
                    (cons w (lp o))))))
          (lambda x (closedir o)))))))

(define stat
  (let ((f (pointer->procedure 'int
                               (dynamic-func "fstatat" (dynamic-link))
                               '(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)))
            (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
                         (string->pointer path)
                         bvp
                         (if follow_symlinks
                             0
                             AT_SYMLINK_NOFOLLOW)))
                  (stat_result (ca (pointer->scm (g bvp)))))))))))

(define lstat
  (lambda* (path #:key (dir_fd None))
    (stat path #:dir_fd dir_fd #:follow_symlinks #f)))