scsh-make/templates.scm

210 lines
6.5 KiB
Scheme
Raw Normal View History

;;; 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))))))