Gauche:gdumpfs
gdumpfs
satoruさんのpdumpfsをGaucheで書いてみました。直訳ではないので比べにくいかもしれませんが元祖Ruby版と見比べてみると楽しいかもしれません。「Gaucherならこう書け」的なアドバイスがあればうれしいです。コメントがWiLiKiっぽいのは、これを整形するWiLiKiを妄想しているためですので、どうかお気になさらぬよう。--hira
- 最終更新： (2004/04/18 08:34:09 PDT)
(use srfi-1) ;iota
(use srfi-19) ;current-date date->string time-utc->date date->time-utc
(use file.util) ;directory-list make-directory*
#|
* メイン
|#
(define (main args)
#|
- 引数をパースする
|#
(define (parse-options args)
(define (usage name)
(format #t "Usage: ~a <source directory> <destination directory>"
" [destination basename]" name)
(exit 0))
(define (nodir dir)
(print "No directory: " dir)
(exit 1))
(if (< (length args) 2) (usage (car args)))
(let ((src (rxmatch-before (#/\/+$/ (second args))))
(dest (third args) ))
(unless src (set! src (second args)))
(unless (file-is? 'directory src ) (nodir src ))
(unless (file-is? 'directory dest) (nodir dest))
(values src dest (if (< 3 (length args)) (fourth args) ""))))
#|
- スナップショットディレクトリのパス(dest/YYYY/MM/DD/base)を作成する
|#
(define (make-snapshot-path dest date base)
(define (date-dir)
(date->string (time-utc->date (date->time-utc date))
"~Y/~m/~d" ))
(format "~a/~a/~a" dest (date-dir) base))
#|
- 最新のスナップショットを31日前まで遡って探す。
|#
(define (latest-snapshot src dest base)
(define (date-dec! date before)
(set! (ref date 'day) (- (ref date 'day) before))
date)
(define dir #f)
(define (find-file before)
(set! dir (make-snapshot-path dest (date-dec! (current-date) before) base))
(file-is? 'directory dir))
(if (find find-file (iota 31 1)) dir #f))
#|
- 最新スナップショットが無い（初めて起動した）場合、ソースを丸ごとコピーする。
- そうでないなら、差分コピーとハードリンクで済ます。
- umaskを0077にして、オーナー以外読み書き実行禁止にする。
|#
(receive (src dest base) (parse-options args)
(let ((latest (latest-snapshot src dest base))
(today (make-snapshot-path dest (current-date) base)))
(sys-umask #o0077)
(make-directory* today)
(if latest
(update-snapshot src latest today)
(recursive-copy src today))))
0)
#|
* ディレクトリを再帰的にコピーする。
|#
(define (recursive-copy src dest)
(define dirs '())
(define (dir-copy s)
(let* ((r (rxmatch-after ((string->regexp (format "^~a\/?" src)) s)))
(t (format "~a/~a" dest r)))
(case (ref (sys-lstat s) 'type)
((directory) (make-directory* t))
((regular ) (copy s t))
((symlink ) (sys-symlink (sys-readlink s) t)))
(if (file-is? 'directory s)
(set! dirs (acons t (sys-stat s) dirs)))))
(directory-for-each dir-copy src)
(restore-dir-attributes dirs))
#|
* 最新スナップショットからの差分コピーとハードリンクよって、新しいスナップショットを作成する。
|#
(define (update-snapshot src latest today)
#|
- ファイルの更新状態を最新スナップショットと比較して、適切な更新方法を次の順で選択する。
## ソースがディレクトリならディレクトリを作成する
## 最新スナップショットが通常ファイルでソースと同じならハードリンクする
## 最新スナップショットが通常ファイルでソースと違うならコピーする
## ソースが通常ファイルならコピーする
## ソースがシンボリックリンクなら、ソースではなくそのリンク先にシンボリックリンクする。
|#
(define (update-file s l t)
#|
-- どちらのファイルもsymlinkではなく、同じタイプ・サイズ・更新日時なら#t
|#
(define (same-file? f1 f2)
(and (not (file-is? 'symlink f1))
(not (file-is? 'symlink f2))
(let ((s1 (sys-stat f1))
(s2 (sys-stat f2)))
(and (eq? 'regular (ref s1 'type))
(eq? 'regular (ref s2 'type))
(eq? (ref s1 'size ) (ref s2 'size ))
(eqv? (ref s1 'mtime) (ref s2 'mtime))))))
#|
-- 既存のリンクを消すことで、一日に何度も起動出来るようにする。
|#
(define (sys-link* src dest)
(if (file-exists? dest)
(sys-unlink dest))
(sys-link src dest))
#|
-- lchownは0.7.4.2 以下ではサポートされていないのでチェックしておく
|#
(define has-lchown? (symbol-bound? 'sys-lchown))
(define (root?) (eq? 0 (sys-getuid)))
(define type "unsupported")
(if (and (not (file-is? 'symlink s))
(file-is? 'directory s))
(begin (set! type "directory")
(make-directory* t))
(if (and (not (file-is? 'symlink s))
(file-is? 'regular l))
(if (same-file? s l)
(begin (set! type "unchanged")
(sys-link* l t))
(begin (set! type "updated")
(copy s t)))
(case (slot-ref (sys-lstat s) 'type)
((regular) (set! type "new file") (copy s t))
((symlink) (set! type "symlink" ) (sys-symlink (sys-readlink s) t)))))
#|
-- rootがこのプログラムを起動した場合、スナップショットのownerをソースと同じにする。
|#
(if (and (root?)
(not (eq? type "unsupported")))
(if (eq? type "symlink")
(if has-lchown?
(let1 stat (sys-lstat s)
(sys-lchown t (ref stat 'uid) (ref stat 'gid))))
(let1 stat (sys-stat s)
(sys-chown t (ref stat 'uid) (ref stat 'gid)))))
(format #t "~10,a ~a\n" type s))
(define dirs '())
(define (update s)
(let* ((r (rxmatch-after ((string->regexp (format "^~a\/?" src)) s)))
(l (format "~a/~a" latest r))
(t (format "~a/~a" today r)))
(update-file s l t) ;エラー処理はどうしよう
(if (file-is? 'directory s)
(set! dirs (acons t (sys-stat s) dirs)))))
(directory-for-each update src)
(restore-dir-attributes dirs))
#| * ユーティリティー関数 |#
#|
** directory-for-each
ディレクトリを幅優先で下降する。ディレクトリがsymlinkなら下降しない。
|#
(define (directory-for-each proc path)
(define (down dir)
(if (file-is? 'directory dir) (directory-for-each proc dir)))
(let1 ls (directory-list path :add-path? #t :children? #t)
(for-each proc ls)
(for-each down ls)))
#|
** restore-dir-attributes
スナップショットのディレクトリの属性をソースと同じにする。
復元した後でディレクトリ配下にアクセスすると更新時間が狂ってしまうため、
ディレクトリ配下のスナップショットを作成し終わった後でないとこの関数は意味を成さない。
|#
(define (restore-dir-attributes dirs)
(for-each (lambda (x)
(let ((dir (car x))
(stat(cdr x)))
(sys-utime dir (ref stat 'atime) (ref stat 'mtime))
(sys-chmod dir (ref stat 'mode))))
dirs))
#|
** copy
ファイルのコピー。属性(utime, atime, mode)もコピーする
|#
(define (copy src dest)
(let1 stat (sys-stat src)
(copy-file src dest :if-exists :backup)
(sys-utime dest (ref stat 'atime) (ref stat 'mtime))
(sys-chmod dest (ref stat 'mode)) ; not necessary. just to make sure
))
#|
** file-is?
ファイルタイプ判定 sys-lstatを元にファイルタイプを判定する。
ファイルが存在しなかったときは#f。
|#
(define (file-is? type file)
(if (file-exists? file)
(eq? (ref (sys-lstat file) 'type) type)
#f))