;;; filesystem.scm

;; Copyright (C) 2000, 2001, 2002, 2003, 2004,
;;   2005, 2006, 2007, 2009, 2010, 2011 Thien-Thi Nguyen
;;
;; This file is part of ttn-do, released under the terms of the
;; GNU General Public License as published by the Free Software
;; Foundation; either version 3, or (at your option) any later
;; version.  There is NO WARRANTY.  See file COPYING for details.

;;; Code:

(define-module (ttn-do zzz filesystem)
  #:export (safe-rewind
            temporary-file-port
            directory-vicinity
            dir-exists?
            mkdir-p
            directory-files
            filtered-files
            filtered-files-in-vicinity
            not-dot-not-dotdot
            extract-stem-proc
            filename-sans-end-sep-proc
            file-newer-than-file?
            save-cwd
            with-cwd
            filename-absolute-or-in-vicinity
            filename-sans-end-slash
            filename-components
            filename-components-append
            expand-file-name
            reset-tilde-cache!
            substitute-env-vars
            expand-file-name-substituting-env-vars)
  #:autoload (ttn-do zzz 0gx temporary-file) (temporary-file)
  #:use-module ((ice-9 common-list) #:select (pick-mappings))
  #:use-module ((srfi srfi-14) #:select (char-set-complement
                                         char-set))
  #:use-module ((srfi srfi-13) #:select (string-suffix?
                                         substring/shared
                                         string-take
                                         string-drop-right
                                         string-join
                                         string-tokenize))
  #:use-module ((ice-9 regex) #:select (match:start
                                        match:substring
                                        match:end)))

(define subs substring/shared)

;; Flush @var{port} (with @code{force-output}) if an output port,
;; then @code{seek} to its initial position (zero).  Return @var{port}.
;;
(define (safe-rewind port)
  (and (output-port? port) (force-output port))
  (seek port 0 SEEK_SET)
  port)

;; Return a new read/write @dfn{temporary file} port,
;; i.e., one backed by the filesystem, and automatically
;; deleted on process exit.
;;
(define (temporary-file-port)
  (temporary-file))

;; Return a procedure @var{p} that returns, given @var{filename},
;; a string constructed from appending @var{directory} and
;; @var{filename}, adding an intervening @code{#\/} (slash)
;; if @var{directory} does not end with one.
;;
;; @example
;; (map (directory-vicinity "foo")
;;      '("bar" "baz" "/qux"))
;; @result{} ("foo/bar" "foo/baz" "foo//qux")
;;
;; (map (directory-vicinity "dir/")
;;      '("a" "/b"))
;; @result{} ("dir/a" "dir//b")
;; @end example
;;
;; NB: If @var{filename} is absolute, the result has two slashes.
;;
(define ((directory-vicinity directory) filename)
  (in-vicinity directory filename))

;; Return @code{#t} iff directory @var{name} exists.
;;
(define (dir-exists? name)
  (and (file-exists? name)
       (file-is-directory? name)))

;; Create a directory @var{dir}, as well as any missing parent dirs.
;;
(define (mkdir-p dir)
  (let ((parent (dirname dir)))
    (or (dir-exists? parent)
        (mkdir-p parent)))
  (or (dir-exists? dir)
      (mkdir dir)))

;; Return list of file names in directory @var{dir}.
;;
(define (directory-files dir)
  (let ((dir-stream (opendir dir)))
    (let loop ((new (readdir dir-stream))
               (acc '()))
      (if (eof-object? new)
          acc
          (loop (readdir dir-stream) (cons new acc))))))

;; Apply @var{filter} to filenames in @var{dir}; return list of non-#f values.
;; @var{filter} is a procedure applied to each file name -- it should return #f
;; if that file name is to be omitted from the overall list, or a value
;; to be collected.  The file name list is not sorted.
;;
(define (filtered-files filter dir)
  (pick-mappings filter (directory-files dir)))

;; In @var{dir}, apply @var{filter} to each file name; return list of non-#f
;; values.  @var{filter} is a procedure applied to to each filename -- it
;; should return #f if that file name is to be omitted from the overall list.
;; Otherwise, its return value can be a string, or #t which is synonymous with
;; the filename with the @var{dir} prefixed.  The file name list is not sorted.
;; @var{options} are zero or more keywords that modify the behavior:
;;
;; @table @code
;; @item #:filter-prefixed
;; Pass to @var{filter} each file with @var{dir} already prefixed.
;; @item #:collect-nodir
;; For the case when @var{filter} returns @code{#t}, collect the filename
;; without the @var{dir} prefix.
;; @end table
;;
;; NB: The argument order is opposite that of @code{filtered-files}.
;;
(define (filtered-files-in-vicinity dir filter . options)
  (let* ((bef? (memq #:filter-prefixed options))
         (aft? (not (memq #:collect-nodir options)))
         (w/dir (directory-vicinity dir))
         (check (if bef?
                    (lambda (file) (filter (w/dir file)))
                    filter))
         (collect (if aft? w/dir identity)))
    (filtered-files (lambda (file)
                      (let ((val (check file)))
                        (and val (if (eq? #t val)
                                     (collect file)
                                     val))))
                    dir)))

;; Return #f if @var{file} is "." or "..", otherwise return @var{file}.
;; The directory component (prefix up to and including the @code{/}, if any)
;; is ignored.
;;
(define (not-dot-not-dotdot file)
  (let ((base (cond ((string-rindex file #\/)
                     => (lambda (cut)
                          (subs file (1+ cut))))
                    (else file))))
    (and (not (string=? "." base))
         (not (string=? ".." base))
         file)))

;; Return a procedure that filters based on @var{ext}, a string.
;; The procedure takes a filename and if it ends in @file{.EXT} (note dot),
;; returns the portion of the filename before the dot, otherwise #f.
;; Optional arg @var{transform} controls precisely how the returned
;; filename is to be processed.  If @var{transform} is omitted or #f,
;; the extension is discarded.  If it is #t, the extension is left alone.
;; If it is a string, the stem is concatenated with it.
;; If it is a procedure, that procedure is applied to the stem,
;; and it's return value, which need not be a string, is collected.
;;
;;-args: (- 1 0)
;;
(define (extract-stem-proc ext . transform)
  (let* ((full-ext (string-append "." ext))
         (fe-len (string-length full-ext))
         (ret (cond ((or (null? transform) (not (car transform)))
                     subs)
                    ((eq? #t (car transform))
                     (lambda args (car args)))
                    ((string? (car transform))
                     (set! transform (car transform))
                     (lambda args (string-append (apply subs args) transform)))
                    ((procedure? (car transform))
                     (set! transform (car transform))
                     (lambda args (transform (apply subs args)))))))
    (lambda (filename)
      (let ((cut (- (string-length filename) fe-len)))
        (and (< 0 cut)
             (string-suffix? full-ext filename 0 fe-len cut)
             (ret filename 0 cut))))))

;; Take @var{sep-char} and return a procedure that, given @var{filename},
;; returns a copy of it w/o the ending @var{sep-char}.
;;
(define (filename-sans-end-sep-proc sep-char)
  (lambda (filename)
    (let* ((len (string-length filename))
           (new (1- len)))
      (if (and (positive? new) (char=? sep-char (string-ref filename new)))
          (string-take filename new)
          filename))))

;; Return #t if file @var{file1} is newer than file @var{file2}.
;; If @var{file1} does not exist, the answer is #f;
;; otherwise, if @var{file2} does not exist, the answer is #t.
;;
(define (file-newer-than-file? file1 file2)
  (cond ((not (file-exists? file1)) #f)
        ((not (file-exists? file2)) #t)
        (else (let ((m1 (stat:mtime (stat file1)))
                    (m2 (stat:mtime (stat file2))))
                (> m1 m2)))))

;; Evaluate @var{body} and restore the original cwd afterward.
;; It is an error to specify a null @var{body}.
;;
(define-macro (save-cwd . body)
  (and (null? body)
       (error "save-cwd: Null body"))
  (let ((sym (gensym)))
    `(let ((,sym (list (getcwd))))
       (set-cdr! ,sym (let () ,@body))
       (chdir (car ,sym))
       (cdr ,sym))))

;; Change directory to @var{dir}, evaluate @var{body} and restore cwd.
;; Return what @var{body} returns.
;; It is an error to specify a null @var{body}.
;;
(define-macro (with-cwd dir . body)
  (and (null? body)
       (error "with-cwd: Null body"))
  (let ((sym (gensym)))
    `(let ((,sym (list (getcwd))))
       (chdir ,dir)
       (set-cdr! ,sym (let () ,@body))
       (chdir (car ,sym))
       (cdr ,sym))))

;; If @var{name} begins with "/", return it.  Otherwise, return a new string
;; composed by taking @var{name} in vicinity of @var{dir}.
;;
(define (filename-absolute-or-in-vicinity name dir)
  (or (and (not (string-null? name))
           (char=? #\/ (string-ref name 0))
           name)
      (in-vicinity dir name)))

;; Return @var{name}, a string, stripping the terminating "/" character.
;; If there is no "/", just return @var{name}.
;;
(define (filename-sans-end-slash name)
  (if (string-suffix? "/" name)
      (string-drop-right name 1)
      name))

;; Return a list of filename components parsed from @var{string}.
;; Components are delimited by "/", which is discarded.
;; Null string components are also discarded.
;;
(define filename-components
  (let ((split (char-set-complement (char-set #\/))))
    (lambda (string)
      (string-tokenize string split))))

;; Return a string composed by prefixing each element of @var{ls} with "/".
;;
(define (filename-components-append ls)
  (string-join ls "/" 'prefix))

(define (elide-dot-and-dot-dots abs-name need-trailing-sep?)
  (let loop ((comps (reverse! (filename-components abs-name)))
             (omit 0)
             (acc (if need-trailing-sep? ; blech
                      (list "")
                      (list))))
    (if (null? comps)
        (filename-components-append acc)
        (cond ((string=? "." (car comps))
               (loop (cdr comps) omit acc))
              ((string=? ".." (car comps))
               (loop (cdr comps) (1+ omit) acc))
              ((< 0 omit)
               (loop (cdr comps) (1- omit) acc))
              (else
               (loop (cdr comps) omit (cons (car comps) acc)))))))

(define *tilde-cache* 7)

;; Convert filename @var{name} to absolute, and canonicalize it.
;; Second arg @var{default-directory} is directory to start with if @var{name}
;; is relative (does not start with slash); if @var{default-directory} is #f
;; or missing, @code{(getcwd)} is used.
;; File name components that are @file{.} are removed, and so are file name
;; components followed by @file{..}, along with the @file{..} itself;
;; note that these simplifications are done without checking the resulting
;; file names in the file system.
;; An initial @file{~/} expands to your home directory.
;; An initial @file{~USER/} expands to USER's home directory.
;;
;;-args: (- 1 0)
;;
(define (expand-file-name name . default-directory)
  (and (number? *tilde-cache*)
       (set! *tilde-cache* (make-hash-table *tilde-cache*)))
  (let* ((~? (lambda (key pw-ent-thunk)
               (or (hash-ref *tilde-cache* key)
                   (let ((val (passwd:dir (pw-ent-thunk))))
                     (hash-set! *tilde-cache* key val)
                     val))))
         (dd (or (and (pair? default-directory)
                      (car default-directory))
                 (getcwd)))
         (under-dd (directory-vicinity dd))
         (len (string-length name)))
    (elide-dot-and-dot-dots
     (case (string-ref name 0)
       ((#\/) name)
       ((#\~) (let ((end (or (string-index name #\/) len)))
                (string-append
                 (cond ((= 1 end)
                        (~? "~" (lambda () (getpwuid (getuid)))))
                       ((false-if-exception
                         (let ((user (subs name 1 end)))
                           (~? user (lambda () (getpwnam user))))))
                       (else
                        (under-dd (string-take name end))))
                 (subs name end len))))
       (else (under-dd name)))
     (char=? #\/ (string-ref name (1- len))))))

;; Reset the cache @code{expand-file-name} uses for the results
;; of expanding @code{~} and @code{~USER}.  Optional arg @var{size}
;; specifies the hash table bucket count to use (default is 7).
;;
;;-args: (- 1 0)
;;
(define (reset-tilde-cache! . size)
  (set! *tilde-cache* (or (and (pair? size)
                               (number? (car size))
                               (car size))
                          7)))

;; Substitute environment variables referred to in @var{string}.
;; @code{$FOO} where FOO is an environment variable name means to substitute
;; the value of that variable.  The variable name should be terminated
;; with a character not a letter, digit or underscore; otherwise, enclose
;; the entire variable name in braces.  For instance, in @code{ab$cd-x},
;; @code{$cd} is treated as an environment variable.
;;
;; Use @code{$$} to insert a single dollar sign.
;;
(define substitute-env-vars
  (let ((double (make-regexp "[$][$]"))
        (rx (make-regexp "[$][{]*([A-Za-z0-9_][A-Za-z0-9_]*)[}]*")))
    (lambda (string)
      (let ((answer (list #f)))
        (let loop ((start 0) (tp answer))
          (define (hang! . x)
            (append! tp x))
          (cond ((regexp-exec double string start)
                 => (lambda (m)
                      (let ((one (1+ (match:start m))))
                        (loop (1+ one)
                              (cdr (hang! (subs string start one)))))))
                ((regexp-exec rx string start)
                 => (lambda (m)
                      (let ((var (match:substring m 1)))
                        (loop (match:end m)
                              (cddr (hang! (subs string start (match:start m))
                                           (or (getenv var) "")))))))
                (else
                 (append! tp (list (subs string start))))))
        (apply string-append (cdr answer))))))

;; Substitute env vars in @var{string} then expand it as a filename.
;; See @code{substitute-env-vars} and @code{expand-file-name}.
;;
;;-args: (- 1 0 default-directory)
;;
(define (expand-file-name-substituting-env-vars name . rest)
  (apply expand-file-name (substitute-env-vars name) rest))

;;; filesystem.scm ends here