md5 works now. (rule ...) is now called (file ...).
This commit is contained in:
jottbee
parent
7115ec2769
commit
b7ba049edd
297
templates.scm
297
templates.scm
|
|
@ -1,209 +1,156 @@
|
|||
;;; TODO:
|
||||
;;;
|
||||
;;; (update-md-sum ...) is (due to history) not very lucky
|
||||
;;;
|
||||
(define digest-files (list "checksums.md5"
|
||||
"fingerprints.md5"
|
||||
"digests.md5"))
|
||||
|
||||
(define digest-extensions (list ".md5" ".fp" ".digest"))
|
||||
|
||||
(define (make-rule-build-func target prereqs thunk)
|
||||
(define (make-file-build-func target prereqs thunk)
|
||||
(lambda args
|
||||
(cons (begin
|
||||
(display ";;; rule : ")
|
||||
(display target)
|
||||
(newline)
|
||||
(thunk))
|
||||
(last args))))
|
||||
; (breakpoint "make-file-build-func")
|
||||
(let ((cooked-state (last args))
|
||||
(prereqs-results (cdr (reverse (cdr args)))))
|
||||
(cons (begin
|
||||
(display ";;; rule : ")
|
||||
(display target)
|
||||
(newline)
|
||||
(bind-fluids-gnu target prereqs prereqs-results thunk))
|
||||
cooked-state))))
|
||||
|
||||
(define (make-md5-build-func target prereqs thunk)
|
||||
(lambda args
|
||||
(cons (begin
|
||||
(display ";;; md5 : ")
|
||||
(display target)
|
||||
(newline)
|
||||
(thunk))
|
||||
(last args))))
|
||||
; (breakpoint "make-md5-build-func")
|
||||
(let ((cooked-state (last args))
|
||||
(prereqs-results (cdr (reverse (cdr args)))))
|
||||
(cons (begin
|
||||
(display ";;; md5 : ")
|
||||
(display target)
|
||||
(newline)
|
||||
(bind-fluids-gnu target prereqs prereqs-results thunk))
|
||||
cooked-state))))
|
||||
|
||||
(define (make-always-build-func target prereqs thunk)
|
||||
(lambda args
|
||||
(cons (begin
|
||||
(display ";;; always : ")
|
||||
(display target)
|
||||
(newline)
|
||||
(thunk))
|
||||
(last args))))
|
||||
; (breakpoint "make-always-build-func")
|
||||
(let ((cooked-state (last args))
|
||||
(prereqs-results (cdr (reverse (cdr args)))))
|
||||
(cons (begin
|
||||
(display ";;; always : ")
|
||||
(display target)
|
||||
(newline)
|
||||
(bind-fluids-gnu target prereqs prereqs-results thunk))
|
||||
cooked-state))))
|
||||
|
||||
(define (make-once-build-func target prereqs thunk)
|
||||
(lambda args
|
||||
(cons (begin
|
||||
(display ";;; once : ")
|
||||
(display target)
|
||||
(newline)
|
||||
(thunk))
|
||||
(last args))))
|
||||
; (breakpoint "make-once-build-func")
|
||||
(let ((cooked-state (last args))
|
||||
(prereqs-results (cdr (reverse (cdr args)))))
|
||||
(cons (begin
|
||||
(display ";;; once : ")
|
||||
(display target)
|
||||
(newline)
|
||||
(bind-fluids-gnu target prereqs prereqs-results thunk))
|
||||
cooked-state))))
|
||||
|
||||
(define (make-is-out-of-date! target . prereqs)
|
||||
;; init-state is the last arg
|
||||
;; pass it untouched to the result
|
||||
(lambda args (cons #t (last args))))
|
||||
(lambda args
|
||||
; (breakpoint "make-is-out-of-date!")
|
||||
(let ((init-state (last args)))
|
||||
(cons #t init-state))))
|
||||
|
||||
(define (make-once target . prereqs)
|
||||
;; init-state is the last arg
|
||||
;; pass it untouched to the result
|
||||
(lambda args (cons (file-not-exists? target) (last args))))
|
||||
(lambda args
|
||||
; (breakpoint "make-once")
|
||||
(let ((init-state (last args)))
|
||||
(cons (file-not-exists? target) init-state))))
|
||||
|
||||
(define (make-is-out-of-date? target . prereqs)
|
||||
(lambda args
|
||||
; (breakpoint "make-is-out-of-date?")
|
||||
(let ((init-state (last args)))
|
||||
(cons (or (file-not-exists? target)
|
||||
(and (not (null? prereqs))
|
||||
(let for-each-prereq ((prereq (car prereqs))
|
||||
(todo (cdr prereqs)))
|
||||
(and (file-exists? prereq)
|
||||
(> (file-last-mod prereq)
|
||||
(file-last-mod target))
|
||||
(or (null? todo)
|
||||
(for-each-prereq (car todo) (cdr todo)))))))
|
||||
(cond
|
||||
((file-not-exists? prereq) #t)
|
||||
((> (file-last-mod prereq) (file-last-mod target)) #t)
|
||||
((null? todo) #f)
|
||||
(else (for-each-prereq (car todo) (cdr todo)))))))
|
||||
init-state))))
|
||||
|
||||
(define (make-md5-sum-changed? target . prereqs)
|
||||
(lambda args
|
||||
(let ((init-state (last args))
|
||||
(tfname (expand-file-name target (cwd))))
|
||||
(cons (or (file-not-exists? tfname)
|
||||
(or (null? prereqs)
|
||||
(let for-each-prereq ((prereq (car prereqs))
|
||||
(todo (cdr prereqs)))
|
||||
(let ((pname (expand-file-name prereq (cwd))))
|
||||
(or (and (file-exists? pname)
|
||||
(> (file-last-mod pname)
|
||||
(file-last-mod tfname))
|
||||
(checksum-changed? pname)
|
||||
(or (md5-sum-update pname) #t))
|
||||
(and (not (null? todo))
|
||||
(for-each-prereq (car todo) (cdr todo))))))))
|
||||
; (breakpoint "make-md5-sum-changed?")
|
||||
(let ((init-state (last args)))
|
||||
(cons (not (same-checksum? target digest-extensions prereqs))
|
||||
init-state))))
|
||||
|
||||
(define (check-files-target+extensions target checksum)
|
||||
(map (lambda (digest-file)
|
||||
(lambda ()
|
||||
(let ((dfile (expand-file-name digest-file (cwd))))
|
||||
(or (file-not-exists? dfile)
|
||||
(let ((strls (port->string-list (open-input-file dfile))))
|
||||
(= checksum
|
||||
(string->number (if (null? strls) "" (car strls)))))))))
|
||||
(map (lambda (ext)
|
||||
(string-append target ext))
|
||||
digest-extensions)))
|
||||
(define (checksum-from-file basename extension)
|
||||
(let* ((bname (string-append basename extension))
|
||||
(file (expand-file-name bname (cwd))))
|
||||
(if (file-exists? file)
|
||||
(let* ((outport (open-input-file file))
|
||||
(strls (port->string-list outport)))
|
||||
;; (display ";;; using : ") (display bname) (newline)
|
||||
(if (null? strls)
|
||||
#f
|
||||
(string->number (car strls))))
|
||||
#f)))
|
||||
|
||||
(define (update-files-target+extensions target checksum)
|
||||
(map (lambda (digest-file)
|
||||
(lambda ()
|
||||
(let ((dfile (expand-file-name digest-file (cwd))))
|
||||
(and (file-exists? dfile)
|
||||
(let ((outport (open-output-file dfile)))
|
||||
(display ";;; update : ") (display target) (newline)
|
||||
(with-current-output-port
|
||||
outport
|
||||
(lambda ()
|
||||
(display (number->string checksum)) (newline)))
|
||||
(close outport)
|
||||
#t)))))
|
||||
(map (lambda (ext)
|
||||
(string-append target ext))
|
||||
digest-extensions)))
|
||||
(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 (digest-file->string-list digest-fname)
|
||||
(let* ((inport (open-input-file (expand-file-name digest-fname (cwd))))
|
||||
(strls (map (lambda (str)
|
||||
(let ((ls (string-tokenize str)))
|
||||
(if (not (null? ls))
|
||||
(let ((fp (car ls))
|
||||
(name (cadr ls)))
|
||||
(cons name fp))
|
||||
'())))
|
||||
(port->string-list inport))))
|
||||
(close inport)
|
||||
strls))
|
||||
(define (checksum-for-file fname)
|
||||
(let ((file (expand-file-name fname (cwd))))
|
||||
(and (file-exists? file)
|
||||
(md5-digest->number (md5-digest-for-port (open-input-file file))))))
|
||||
|
||||
(define (check-digest-files target checksum)
|
||||
(map (lambda (digest-file)
|
||||
(lambda ()
|
||||
(let ((dfile (expand-file-name digest-file (cwd)))
|
||||
(tname (file-name-nondirectory target)))
|
||||
(or (file-not-exists? dfile)
|
||||
(let* ((*fname-md5* (digest-file->string-list dfile))
|
||||
(maybe-md5 (if (or (null? *fname-md5*)
|
||||
(null? (car *fname-md5*)))
|
||||
#f
|
||||
(assoc tname *fname-md5*))))
|
||||
(or (not maybe-md5)
|
||||
(= checksum
|
||||
(string->number (cdr maybe-md5)))))))))
|
||||
digest-files))
|
||||
;;; optimizations possible: global variable with known checksums
|
||||
(define (get-file-checksum fname)
|
||||
(checksum-for-file fname))
|
||||
|
||||
(define (string-list->digest-file dfname strls)
|
||||
(let ((outport (open-output-file (expand-file-name dfname (cwd))))
|
||||
(names (if (or (null? strls) (null? (car strls))) '() (map car strls)))
|
||||
(sums (if (or (null? strls) (null? (car strls))) '() (map cdr strls))))
|
||||
(display ";;; update : ") (display dfname) (newline)
|
||||
(for-each (lambda (name fp)
|
||||
(with-current-output-port outport
|
||||
(for-each display (list fp " " name))
|
||||
(newline)))
|
||||
names sums)
|
||||
(close outport)
|
||||
#t))
|
||||
|
||||
(define (update-digest-files target checksum)
|
||||
(map (lambda (digest-file)
|
||||
(lambda ()
|
||||
(let ((dfile (expand-file-name digest-file (cwd)))
|
||||
(tname (file-name-nondirectory target)))
|
||||
(and (file-exists? dfile)
|
||||
(let* ((*fname-md5* (digest-file->string-list dfile))
|
||||
(cleaned-table (if (or (null? *fname-md5*)
|
||||
(null? (car *fname-md5*)))
|
||||
(list)
|
||||
(alist-delete tname *fname-md5*))))
|
||||
(string-list->digest-file
|
||||
dfile
|
||||
(alist-cons tname checksum cleaned-table)))))))
|
||||
digest-files))
|
||||
|
||||
(define (checksum-changed? target)
|
||||
(let* ((inport (open-input-file target))
|
||||
(checksum (md5-digest->number (md5-digest-for-port inport)))
|
||||
(result-funcs (append (check-files-target+extensions target checksum)
|
||||
(check-digest-files target checksum))))
|
||||
(close inport)
|
||||
(not (let each-result-and ((current (car result-funcs))
|
||||
(todo (cdr result-funcs)))
|
||||
(let ((res (current)))
|
||||
(and res
|
||||
(or (null? todo)
|
||||
(each-result-and (car todo) (cdr todo)))))))))
|
||||
|
||||
(define (md5-sum-update target)
|
||||
(let* ((tname (expand-file-name target (cwd)))
|
||||
(inport (open-input-file tname))
|
||||
(checksum (md5-digest->number (md5-digest-for-port inport)))
|
||||
(update-funcs (append (update-files-target+extensions target checksum)
|
||||
(update-digest-files target checksum))))
|
||||
(close inport)
|
||||
(let ((update-ok? (lambda ()
|
||||
(let each-update-and ((current (car update-funcs))
|
||||
(todo (cdr update-funcs)))
|
||||
(or (current)
|
||||
(and (not (null? todo))
|
||||
(each-update-and (car todo) (cdr todo))))))))
|
||||
;; the default is to use the filename with .md5 extension
|
||||
(if (not (update-ok?))
|
||||
(let ((outport (open-output-file (string-append tname ".md5"))))
|
||||
(with-current-output-port outport
|
||||
(begin
|
||||
(display checksum)
|
||||
(newline)))
|
||||
(close outport))))))
|
||||
(define (same-checksum? target extensions prereqs)
|
||||
(or (null? prereqs)
|
||||
(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
|
||||
((and (not (null? todo-prereqs)))
|
||||
(for-each-prereq (car todo-prereqs)
|
||||
current-total
|
||||
(cdr todo-prereqs)))
|
||||
((and (null? todo-prereqs) (not (null? extensions)))
|
||||
(let for-each-ext ((ext (car extensions))
|
||||
(todo-exts (cdr extensions)))
|
||||
(let ((known-sum (checksum-from-file target ext)))
|
||||
(cond
|
||||
((and (file-not-exists? target) known-sum)
|
||||
(begin
|
||||
(checksum-into-file target ext current-total)
|
||||
#f))
|
||||
((and (file-not-exists? target) (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?")))))))
|
||||
|
|
|
|||
Loading…
Reference in New Issue