tree

Perlで実装したtreeコマンドを紛失したので実装してみた。参考にしたのはRuby: directory tree (Japanese)
参考にしたので、一応互換性がある。
引数を処理するところのset!の連続がなんともいえない。なんか手続き的。

#!/usr/bin/env gosh
;; -*- scheme -*- -*- utf-8 -*- 
;; coding: utf-8
;;--------------------------------------------------
(use srfi-1)
(use srfi-13)
(use file.util)
(use text.tree)
(use gauche.parseopt)

;; global variable
(define *number-of-dir*  0)
(define *number-of-file* 0)
(define *dir-only?* #f)
(define *level*     #f)
(define *all*       #f)

(define (inc-*number-of-file*!) (inc! *number-of-file*))
(define (inc-*number-of-dir*!) (inc! *number-of-dir*))

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

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

(define (print-tree prefix childrens level)
  (when (and (or (not *level*)
		 (> *level* level))
	     (not (null? childrens)))
    (let* ((child (car childrens))
	   (rest (cdr childrens)))
      (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)))))
	    (*dir-only?* )
	    (else
	     (print-file prefix child)))
      (unless (null? rest)
	(print-tree prefix rest level)))))

(define (new-prefix prefix rest)
  ((lambda (p) (cons *branch* (cons *dummy* p)))
   (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-dir prefix dir)
  (inc-*number-of-dir*!)
  (write-tree (list (reverse prefix) *dir-pre* (cook-filename dir)))
  (newline))
(define (print-file prefix file)
  (inc-*number-of-file*!)
  (write-tree (list (reverse prefix) *file-pre* (cook-filename file)))
  (newline))

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

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