210 lines
6.5 KiB
Scheme
210 lines
6.5 KiB
Scheme
;;; 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)
|
|
(lambda args
|
|
(cons (begin
|
|
(display ";;; rule : ")
|
|
(display target)
|
|
(newline)
|
|
(thunk))
|
|
(last args))))
|
|
|
|
(define (make-md5-build-func target prereqs thunk)
|
|
(lambda args
|
|
(cons (begin
|
|
(display ";;; md5 : ")
|
|
(display target)
|
|
(newline)
|
|
(thunk))
|
|
(last args))))
|
|
|
|
(define (make-always-build-func target prereqs thunk)
|
|
(lambda args
|
|
(cons (begin
|
|
(display ";;; always : ")
|
|
(display target)
|
|
(newline)
|
|
(thunk))
|
|
(last args))))
|
|
|
|
(define (make-once-build-func target prereqs thunk)
|
|
(lambda args
|
|
(cons (begin
|
|
(display ";;; once : ")
|
|
(display target)
|
|
(newline)
|
|
(thunk))
|
|
(last args))))
|
|
|
|
(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))))
|
|
|
|
(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))))
|
|
|
|
(define (make-is-out-of-date? target . prereqs)
|
|
(lambda args
|
|
(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)))))))
|
|
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))))))))
|
|
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 (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 (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 (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))
|
|
|
|
(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))))))
|