;;;
;;; file related utility functions.  to be autoloaded.
;;;  
;;;   Copyright (c) 2000-2007  Shiro Kawai  <shiro@acm.org>
;;;   
;;;   Redistribution and use in source and binary forms, with or without
;;;   modification, are permitted provided that the following conditions
;;;   are met:
;;;   
;;;   1. Redistributions of source code must retain the above copyright
;;;      notice, this list of conditions and the following disclaimer.
;;;  
;;;   2. Redistributions in binary form must reproduce the above copyright
;;;      notice, this list of conditions and the following disclaimer in the
;;;      documentation and/or other materials provided with the distribution.
;;;  
;;;   3. Neither the name of the authors nor the names of its contributors
;;;      may be used to endorse or promote products derived from this
;;;      software without specific prior written permission.
;;;  
;;;   THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
;;;   "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
;;;   LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
;;;   A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
;;;   OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
;;;   SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
;;;   TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
;;;   PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
;;;   LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;;   NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;;   SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
;;;  
;;;  $Id: fileutil.scm,v 1.8 2007/12/08 03:24:30 shirok Exp $
;;;

(define-module gauche.fileutil
  (export file-exists? file-is-regular? file-is-directory?
          glob glob-fold glob-component->regexp make-glob-fs-fold
          sys-stat->file-type sys-stat->mode sys-stat->ino
          sys-stat->dev sys-stat->rdev sys-stat->nlink
          sys-stat->size sys-stat->uid sys-stat->gid
          sys-stat->atime sys-stat->mtime sys-stat->ctime sys-stat->type
          sys-tm->alist)
  )
(select-module gauche.fileutil)

(define (file-exists? path)
  (sys-access path |F_OK|))
(define (file-is-regular? path)
  (and (sys-access path |F_OK|)
       (eq? (slot-ref (sys-stat path) 'type) 'regular)))
(define (file-is-directory? path)
  (and (sys-access path |F_OK|)
       (eq? (slot-ref (sys-stat path) 'type) 'directory)))


;; system object accessors (for backward compatibility)
(define (sys-stat->file-type s)  (slot-ref s 'type))
(define (sys-stat->mode s)  (slot-ref s 'mode))
(define (sys-stat->ino s)   (slot-ref s 'ino))
(define (sys-stat->dev s)   (slot-ref s 'dev))
(define (sys-stat->rdev s)  (slot-ref s 'rdev))
(define (sys-stat->nlink s) (slot-ref s 'nlink))
(define (sys-stat->size s)  (slot-ref s 'size))
(define (sys-stat->uid s)   (slot-ref s 'uid))
(define (sys-stat->gid s)   (slot-ref s 'gid))
(define (sys-stat->atime s) (slot-ref s 'atime))
(define (sys-stat->mtime s) (slot-ref s 'mtime))
(define (sys-stat->ctime s) (slot-ref s 'ctime))
(define (sys-stat->type s)  (slot-ref s 'type))

(define (sys-tm->alist tm)
  (map (lambda (n s) (cons n (slot-ref tm s)))
       '(tm_sec tm_min tm_hour tm_mday tm_mon tm_year tm_wday tm_yday tm_isdst)
       '(sec min hour mday mon year wday yday isdst)))

;;;
;;; globbing.
;;;

;; glob-fold provides the fundamental logic of glob.  It does not
;; depend on filesystems---any tree structure that has "pathname"
;; will do.
;;
;; <glob-pattern> : [<separator>] (<selector> <separator>)* [<separator>]
;; <selector>     : '**' | <element>*
;; <element>      : <ordinary> | '*' | '?' | <char-range>
;; <char-range>   : '[' <char-set-spec> ']'
;; <ordinary>     : characters except #[,*?\{\}\[\]\\] and <separator>
;;                  | '\\' <character>
;;
;; <separator> splits the components in the path.

(define (glob patterns . opts)
  (apply glob-fold patterns cons '() opts))

(define sys-glob glob) ;; backward compatibility

(define (glob-fold patterns proc seed . opts)
  (fold (cut glob-fold-1 <> proc <> opts) seed
        (fold glob-expand-braces '()
              (if (list? patterns) patterns (list patterns)))))

;; NB: we avoid util.match due to the hairy dependency problem.
(define (glob-fold-1 pattern proc seed opts)
  (let-keywords opts ((separator #[/])
                      (folder glob-fs-folder))
    (define (rec node matcher seed)
      (cond [(null? matcher) (proc seed)]
            [(eq? (car matcher) '**)
             (rec* node (cdr matcher) seed)]
            [(null? (cdr matcher))
             (folder proc seed node (car matcher) #f)]
            [else
             (folder (lambda (node seed) (rec node (cdr matcher) seed))
                     seed node (car matcher) #t)]))
    (define (rec* node matcher seed)
      (fold (cut rec* <> matcher <>)
            (rec node matcher seed)
            (folder cons '() node #/^[^.].*$/ #t)))
    (let1 p (glob-prepare-pattern pattern separator)
      (rec (car p) (cdr p) seed))))

(define (glob-prepare-pattern pattern separator)
  (define (f comp)
    (cond [(equal? comp "") 'dir?]    ; pattern ends with '/'
          [(equal? comp "**") '**]
          [else (glob-component->regexp comp)]))
  (let1 comps (string-split pattern separator)
    (if (equal? (car comps) "")
      (cons #t (map f (cdr comps)))
      (cons #f (map f comps)))))

;; */*.{c,scm} -> '(*/*.c */*.scm)
;;
;; NB: we first expand the braces to separate patterns.  This is how
;; zsh and tcsh handles {...}.  However, it is not good in terms of
;; performance, since the common prefix are searched mulitple times.
;; Hopefully we'll put some optimization here, making single traversal
;; for the common prefix.
;;
;; The treatment of backslashes is tricky. 
;;
(define (glob-expand-braces pattern seed)
  (define (parse str pres level)
    (let loop ((str str)
               (segs pres))
      (cond
       [(rxmatch #/[{}]/ str) =>
        (lambda (m)
          (cond [(equal? (m 0) "{")
                 (receive (ins post) (parse (m'after) '("") (+ level 1))
                   (loop post
                         (fold (lambda (seg seed)
                                 (fold (lambda (in seed)
                                         (cons (string-append seg in) seed))
                                       seed ins))
                               '()
                               (map (cute string-append <> (m'before)) segs))))]
                [(= level 0)
                 (error "extra closing curly-brace in glob pattern:" pattern)]
                [else         ; closing curly-brace
                 (values (fold expand '()
                               (map (cute string-append <> (m'before)) segs))
                         (m'after))]))]
       [(= level 0) (values (map (cute string-append <> str) segs) #f)]
       [else (error "unclosed curly-brace in glob pattern:" pattern)])))
  (define (expand pat seed)
    (let1 segs (string-split pat #\,)
      (if (null? seed) segs (append segs seed))))
  (if (string-scan pattern #\{)
    (append (values-ref (parse pattern '("") 0) 0) seed)
    (cons pattern seed)))

(define (glob-component->regexp pattern) ; "**" is already excluded
  (define n read-char)
  (define nd '(comp . #[.]))
  (define ra '(rep 0 #f any))
  (regexp-compile
   (regexp-optimize
    (with-input-from-string pattern
      (lambda ()
        (define (element0 ch ct)
          (case ch
            [(#\*) (element0* (n) ct)]
            [(#\?) `(,nd ,@(element1 (n) ct))]
            [else (element1 ch ct)]))
        (define (element0* ch ct)
          (case ch
            [(#\*) (element0* (n) ct)]
            [(#\?) `(,nd ,ra ,@(element1 (n) ct))]
            [(#\.) `(,nd ,ra #\. ,@(element1 (n) ct))]
            [else `((rep 0 1 (seq ,nd ,ra))
                    ,@(element1 ch ct))]))
        (define (element1 ch ct)
          (cond [(eof-object? ch) '(eol)]
                [(eqv? ch #\*) `(,ra ,@(element1* (n) ct))]
                [(eqv? ch #\?) `(any ,@(element1 (n) ct))]
                [(eqv? ch #\[)
                 (case (peek-char)
                   ;; we have to treat [!...] as [^...]
                   [(#\!) (n)
                    (let1 cs (read-char-set (current-input-port))
                      (cons (%char-set-complement! cs) (element1 (n) ct)))]
                   [else
                    (let1 cs (read-char-set (current-input-port))
                      (cons cs (element1 (n) ct)))])]
                [else (cons ch (element1 (n) ct))]))
        (define (element1* ch ct)
          (case ch
            [(#\*) (element1* (n) ct)]
            [else  (element1 ch ct)]))
        `(seq bol ,@(element0 (n) '())))))))

(define (make-glob-fs-fold . args)
  (let-keywords* args ((root-path #f)
                       (current-path #f))
    (let ((separ (cond-expand
                  (gauche.os.windows "\\")
                  (else "/"))))
      (define (ensure-dirname s)
        (and s
             (or (and-let* ([len (string-length s)]
                            [ (> len 0) ]
                            [ (not (eqv? (string-ref s (- len 1))
                                         (string-ref separ 0))) ])
                   (string-append s separ))
                 s)))
      (define root-path/    (ensure-dirname root-path))
      (define current-path/ (ensure-dirname current-path))
      (lambda (proc seed node regexp non-leaf?)
        (let1 prefix (case node
                       [(#t) (or root-path/ separ)]
                       [(#f) (or current-path/ "")]
                       [else (string-append node separ)])
          ;; NB: we can't use filter, for it is not built-in.
          ;; also we can't use build-path, from the same reason.
          (if (eq? regexp 'dir?)
            (proc prefix seed)
            (fold (lambda (child seed)
                    (or (and-let* ([ (regexp child) ]
                                   [full (string-append prefix child)]
                                   [ (or (not non-leaf?)
                                         (file-is-directory? full)) ])
                          (proc full seed))
                        seed))
                  seed
                  (sys-readdir (case node
                                 [(#t) (or root-path/ "/")]
                                 [(#f) (or current-path/ ".")]
                                 [else node]))))))
      )))

(define glob-fs-folder (make-glob-fs-fold))

(provide "gauche/fileutil")
