170 lines
5.4 KiB
Scheme
170 lines
5.4 KiB
Scheme
(define digest-extensions (list ".md5" ".fp" ".digest"))
|
|
|
|
(define (same-mtime? target prereqs)
|
|
(if (file-not-exists? target)
|
|
#t
|
|
(if (null? prereqs)
|
|
#f
|
|
(let ((target-mtime (file-last-mod target)))
|
|
(let for-each-prereq ((prereq (car prereqs))
|
|
(todo (cdr prereqs)))
|
|
(cond
|
|
((and (file-exists? prereq)
|
|
(> (file-last-mod prereq) target-mtime)) #t)
|
|
((null? todo) #f)
|
|
(else (for-each-prereq (car todo) (cdr todo)))))))))
|
|
|
|
(define (all-same-mtime? target prereqs)
|
|
(if (file-not-exists? target)
|
|
#t
|
|
(if (null? prereqs)
|
|
#f
|
|
(let ((target-mtime (file-last-mod target)))
|
|
(let for-each-prereq ((prereq (car prereqs))
|
|
(todo (cdr prereqs)))
|
|
(cond
|
|
((and (file-exists? prereq) (null? todo))
|
|
(> (file-last-mod prereq) target-mtime))
|
|
(else (and (and (file-exists? prereq)
|
|
(> (file-last-mod prereq) target-mtime))
|
|
(for-each-prereq (car todo) (cdr todo))))))))))
|
|
|
|
(define (same-perms? target prereqs)
|
|
(if (file-not-exists? target)
|
|
#t
|
|
(if (null? prereqs)
|
|
(error "no prerequisite in perms clause")
|
|
(cond
|
|
((file-not-exists? (car prereqs))
|
|
(error "nonexistent prerequisite" (car prereqs)))
|
|
(else (= (file-mode target) (file-mode (car prereqs))))))))
|
|
|
|
(define (checksum-from-file basename extension)
|
|
(let* ((bname (string-append basename extension))
|
|
(file (expand-file-name bname (cwd))))
|
|
(if (file-exists? file)
|
|
(let* ((inport (open-input-file file))
|
|
(strls (port->string-list inport)))
|
|
;; (display ";;; using : ") (display bname) (newline)
|
|
(if (null? strls)
|
|
#f
|
|
(string->number (car strls))))
|
|
#f)))
|
|
|
|
(define (checksum-into-file basename extension checksum)
|
|
(let* ((bname (string-append basename extension))
|
|
(file (expand-file-name bname (cwd)))
|
|
(outport (open-output-file file))
|
|
(str (number->string checksum)))
|
|
;; (display ";;; update : ") (display bname) (newline)
|
|
(with-current-output-port outport (begin (display str) (newline)))
|
|
(close outport)))
|
|
|
|
(define (checksum-for-file fname)
|
|
(let ((file (expand-file-name fname (cwd))))
|
|
(if (file-exists? file)
|
|
(md5-digest->number (md5-digest-for-port (open-input-file file)))
|
|
(error "checksum-for-file: file does not exist" file))))
|
|
|
|
;;; optimizations possible: global variable with known checksums
|
|
(define (get-file-checksum fname)
|
|
(checksum-for-file fname))
|
|
|
|
(define (same-checksum? target extensions prereqs)
|
|
(if (null? prereqs)
|
|
(error "same-checksum?: target has no prerequisites" target)
|
|
(let for-each-prereq ((current-prereq (car prereqs))
|
|
(previous-total 0)
|
|
(todo-prereqs (cdr prereqs)))
|
|
(let* ((current-file-sum (get-file-checksum current-prereq))
|
|
(current-total (if current-file-sum
|
|
(+ current-file-sum previous-total)
|
|
previous-total)))
|
|
(cond
|
|
((not (null? todo-prereqs))
|
|
(for-each-prereq (car todo-prereqs)
|
|
current-total
|
|
(cdr todo-prereqs)))
|
|
((not (null? extensions))
|
|
(let for-each-ext ((ext (car extensions))
|
|
(todo-exts (cdr extensions)))
|
|
(let ((known-sum (checksum-from-file target ext))
|
|
(target-name (string-append target ext)))
|
|
(cond
|
|
((and (file-not-exists? target-name) known-sum)
|
|
(begin
|
|
(checksum-into-file target ext current-total)
|
|
#f))
|
|
((and (file-not-exists? target-name) (null? todo-exts))
|
|
(begin
|
|
(checksum-into-file target
|
|
(last (reverse extensions))
|
|
current-total)
|
|
#f))
|
|
((and known-sum (= current-total known-sum)) #t)
|
|
((and known-sum (not (= current-total known-sum)))
|
|
(begin
|
|
(checksum-into-file target ext current-total)
|
|
#f))
|
|
((and (not known-sum) (not (null? todo-exts)))
|
|
(for-each-ext (car todo-exts) (cdr todo-exts)))
|
|
((and (not known-sum) (null? todo-exts))
|
|
(begin
|
|
(checksum-into-file target ext current-total)
|
|
#f))
|
|
(else (error "no match in same-checksum?"))))))
|
|
(else (error "no match in same-checksum?")))))))
|
|
|
|
(define (head target prereqs)
|
|
(if (file-not-exists? target)
|
|
#t
|
|
(if (null? prereqs)
|
|
#f
|
|
(let ((prereq (car prereqs)))
|
|
(if (file-not-exists? prereq)
|
|
(error "nonexistent prerequisite" prereq)
|
|
(> (file-last-mod prereq) (file-last-mod target)))))))
|
|
|
|
(define (tail target prereqs)
|
|
(if (file-not-exists? target)
|
|
#t
|
|
(if (null? prereqs)
|
|
#f
|
|
(if (null? (cdr prereqs))
|
|
#f
|
|
(let ((target-mtime (file-last-mod target)))
|
|
(let for-each-prereq ((prereq (cadr prereqs))
|
|
(todo (cddr prereqs)))
|
|
(cond
|
|
((and (file-exists? prereq)
|
|
(> (file-last-mod prereq) target-mtime)) #t)
|
|
((null? todo) #f)
|
|
(else (for-each-prereq (car todo) (cdr todo))))))))))
|
|
|
|
(define (always target prereqs) #t)
|
|
|
|
(define (once target prereqs)
|
|
(file-not-exists? target))
|
|
|
|
(define (file target prereqs)
|
|
(same-mtime? target prereqs))
|
|
|
|
(define (all target prereqs)
|
|
(all-same-mtime? target prereqs))
|
|
|
|
(define (md5 target prereqs)
|
|
(not (same-checksum? target digest-extensions prereqs)))
|
|
|
|
(define (perms target prereqs)
|
|
(not (same-perms? target prereqs)))
|
|
|
|
(define (md5-perms target prereqs)
|
|
(or (not (same-perms? target prereqs))
|
|
(not (same-checksum? target digest-extensions prereqs))))
|
|
|
|
(define (paranoid target prereqs)
|
|
(or (not (same-perms? target prereqs))
|
|
(same-mtime? target prereqs)
|
|
(not (same-checksum? target digest-extensions prereqs))))
|
|
|