tree その２

少し改良？した。でも相変わらず参考にしたruby版の5倍遅い。

(use srfi-1)
(use srfi-13)
(use file.util)
(use text.tree)
(use gauche.parseopt)
(use gauche.parameter)

(define *version*  "0.0.1")
;;--------------------------------------------------
;; global variable
;; option
(define *dir-only?* (make-parameter #f))
(define *level*     (make-parameter #f))
(define *all*       (make-parameter #f))
;; total
(define *dir-total*  0)
(define *file-total* 0)

(define (inc-*dir-total*!) (inc! *dir-total*))
(define (inc-*file-total*!) (inc! *file-total*))

(define-constant *branch*   "|")
(define-constant *dummy*    " ")
(define-constant *dir-pre*  "-+ ")
(define-constant *file-pre* "-- ")

(define (dir-list dirname)
  (let ((dir (lambda (dir)
	       (if (*dir-only?*)
		   (file-is-directory? dir)
		   #t)))
	(all (lambda (dir)
	       (if (*all*) #t
		   (not (string= "."
				 (string-take (sys-basename dir) 1)))))))
    (let1 dirs (directory-list dirname :add-path? #t :children? #t)
      (filter all (filter dir dirs)))))

(define (print-tree prefix children level)
  (when (and (or (not (*level*))
		 (> (*level*) level))
	     (not (null? children)))
    (let loop ((child (car children))
	       (rest (cdr children)))
      (cond ((file-is-directory? child)
	     (cond ((file-is-symlink? child)
		    (print-file prefix child))
		   (else
		    (print-dir prefix child)
		    (print-tree (new-prefix prefix rest)
				(dir-list child)
				(+ 1 level)))))
	    (else
	     (print-file prefix child)))
      (unless (null? rest)
	(loop (car rest) (cdr rest))))))

(define (new-prefix prefix rest)
  (cons *branch*
	(cons *dummy* 
	      (if (null? rest)
		  (cons *dummy* (cdr prefix)) ; swap *branch* *dummy*
		  prefix))))

(define (cook-filename file)
  (if (file-is-symlink? file)
      (list (sys-basename file) " -> " (sys-readlink file))
      (sys-basename file)))

(define (print-leaf inc! pre)
  (lambda (prefix leaf)
    (inc!)
    (write-tree (list (reverse prefix)
		      pre 
		      (cook-filename leaf)))
    (newline)))

(define print-dir  (print-leaf inc-*dir-total*!  *dir-pre*))
(define print-file (print-leaf inc-*file-total*! *file-pre*))

(define (print-result)
  (newline)
  (when (> *dir-total* 0)
    (let1 suffix (if (> *dir-total* 1) "es" "y")
    (format #t "~d director~a"
	    *dir-total*
	    suffix))
  (when (and (> *dir-total* 0) (> *file-total* 0))
    (display " "))
  (when (> *file-total* 0)
    (let1 suffix (if (> *file-total* 1) "s" "")
      (format #t "~d file~a"
	      *file-total*
	      suffix)))
  (newline)))

(define (usage)
  (display
"usage: #$0 [-ad] [l=number] [directory_name]
 -a     all files(include .file)
 -d     directory only
 -l=num depth of directores"
)
  (newline)
  (exit 0))

;;--------------------------------------------------  
;; Entry point
(define (main args) 
  (let-args (cdr args)
      ((d "d"   #f)
       (l "l=i" #f)
       (a "a"   #f)
       (#f "h|help" => usage)
       . args)
    (when d (*dir-only?* d))
    (when l (*level* l))
    (when a (*all* a))
    (let ((prefix (list *branch*))
	  (dir (if (null? args)
		   "."
		   (car args))))
      (print (tree->string (list (reverse prefix)
				 *dir-pre*
				 (sys-basename dir))))
      (print-tree (new-prefix prefix '())
		  (dir-list dir)
		  0))
    (print-result)
    (exit 0)))