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

(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 module stat)
  #:use-module (language python for)
  #:use-module (language python try)
  #:use-module (system foreign)
  #:use-module (parser stis-parser)
  #:use-module (language python exceptions)
  #:use-module (oop pf-objects)
  #:use-module (ice-9 match)
  #: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-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)))
    (if (eq? (string-ref path 0) #\/)
        (normpath path)
        (normpath (string-append (getcwd) "/" path)))))
    
(define (basename path) (ca ((@ (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) (ca ((@ (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 f-var (mk-token
               (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 f-other (mk-token (f* (f-not! f-var))))

(define f-f (f-cons f-other (ff* (f-seq f-var f-other))))

(define (expandvars p)
  (let lp ((l (parse (path-it p) f-f)) (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 (ismount p)
  (ca 
   (let* ((p (path-it p))
          (q (string-append p "/..")))
     (not (= (stat:dev ((@ (guile) stat) p))
             (stat:dev ((@ (guile) stat) q)))))))


(define (normcase x) x)

(define islink   (@@ (language python module os) path:islink))
(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 curdir))
  (define (reduce f s l)
    (if (pair? l)
        (reduce f (f (car l) s) (cdr l))
        s))
  (define l1 (string-split (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)