scsh-conservatory
/
scsh-make
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

md5 works now. (rule ...) is now called (file ...).

This commit is contained in:
jottbee 2005-02-14 07:41:34 +00:00
parent 7115ec2769
commit b7ba049edd
1 changed files with 122 additions and 175 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

297
templates.scm
View File

@ -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 digest-extensions (list ".md5" ".fp" ".digest"))
(define (make-rule-build-func target prereqs thunk) (define (make-file-build-func target prereqs thunk)
(lambda args (lambda args
(cons (begin ; (breakpoint "make-file-build-func")
(display ";;; rule : ") (let ((cooked-state (last args))
(display target) (prereqs-results (cdr (reverse (cdr args)))))
(newline) (cons (begin
(thunk)) (display ";;; rule : ")
(last args)))) (display target)
(newline)
(bind-fluids-gnu target prereqs prereqs-results thunk))
cooked-state))))
(define (make-md5-build-func target prereqs thunk) (define (make-md5-build-func target prereqs thunk)
(lambda args (lambda args
(cons (begin ; (breakpoint "make-md5-build-func")
(display ";;; md5 : ") (let ((cooked-state (last args))
(display target) (prereqs-results (cdr (reverse (cdr args)))))
(newline) (cons (begin
(thunk)) (display ";;; md5 : ")
(last args)))) (display target)
(newline)
(bind-fluids-gnu target prereqs prereqs-results thunk))
cooked-state))))
(define (make-always-build-func target prereqs thunk) (define (make-always-build-func target prereqs thunk)
(lambda args (lambda args
(cons (begin ; (breakpoint "make-always-build-func")
(display ";;; always : ") (let ((cooked-state (last args))
(display target) (prereqs-results (cdr (reverse (cdr args)))))
(newline) (cons (begin
(thunk)) (display ";;; always : ")
(last args)))) (display target)
(newline)
(bind-fluids-gnu target prereqs prereqs-results thunk))
cooked-state))))
(define (make-once-build-func target prereqs thunk) (define (make-once-build-func target prereqs thunk)
(lambda args (lambda args
(cons (begin ; (breakpoint "make-once-build-func")
(display ";;; once : ") (let ((cooked-state (last args))
(display target) (prereqs-results (cdr (reverse (cdr args)))))
(newline) (cons (begin
(thunk)) (display ";;; once : ")
(last args)))) (display target)
(newline)
(bind-fluids-gnu target prereqs prereqs-results thunk))
cooked-state))))
(define (make-is-out-of-date! target . prereqs) (define (make-is-out-of-date! target . prereqs)
;; init-state is the last arg (lambda args
;; pass it untouched to the result ; (breakpoint "make-is-out-of-date!")
(lambda args (cons #t (last args)))) (let ((init-state (last args)))
(cons #t init-state))))
(define (make-once target . prereqs) (define (make-once target . prereqs)
;; init-state is the last arg (lambda args
;; pass it untouched to the result ; (breakpoint "make-once")
(lambda args (cons (file-not-exists? target) (last args)))) (let ((init-state (last args)))
(cons (file-not-exists? target) init-state))))
(define (make-is-out-of-date? target . prereqs) (define (make-is-out-of-date? target . prereqs)
(lambda args (lambda args
; (breakpoint "make-is-out-of-date?")
(let ((init-state (last args))) (let ((init-state (last args)))
(cons (or (file-not-exists? target) (cons (or (file-not-exists? target)
(and (not (null? prereqs)) (and (not (null? prereqs))
(let for-each-prereq ((prereq (car prereqs)) (let for-each-prereq ((prereq (car prereqs))
(todo (cdr prereqs))) (todo (cdr prereqs)))
(and (file-exists? prereq) (cond
(> (file-last-mod prereq) ((file-not-exists? prereq) #t)
(file-last-mod target)) ((> (file-last-mod prereq) (file-last-mod target)) #t)
(or (null? todo) ((null? todo) #f)
(for-each-prereq (car todo) (cdr todo))))))) (else (for-each-prereq (car todo) (cdr todo)))))))
init-state)))) init-state))))
(define (make-md5-sum-changed? target . prereqs) (define (make-md5-sum-changed? target . prereqs)
(lambda args (lambda args
(let ((init-state (last args)) ; (breakpoint "make-md5-sum-changed?")
(tfname (expand-file-name target (cwd)))) (let ((init-state (last args)))
(cons (or (file-not-exists? tfname) (cons (not (same-checksum? target digest-extensions prereqs))
(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)))) init-state))))
(define (check-files-target+extensions target checksum) (define (checksum-from-file basename extension)
(map (lambda (digest-file) (let* ((bname (string-append basename extension))
(lambda () (file (expand-file-name bname (cwd))))
(let ((dfile (expand-file-name digest-file (cwd)))) (if (file-exists? file)
(or (file-not-exists? dfile) (let* ((outport (open-input-file file))
(let ((strls (port->string-list (open-input-file dfile)))) (strls (port->string-list outport)))
(= checksum ;; (display ";;; using : ") (display bname) (newline)
(string->number (if (null? strls) "" (car strls))))))))) (if (null? strls)
(map (lambda (ext) #f
(string-append target ext)) (string->number (car strls))))
digest-extensions))) #f)))
(define (update-files-target+extensions target checksum) (define (checksum-into-file basename extension checksum)
(map (lambda (digest-file) (let* ((bname (string-append basename extension))
(lambda () (file (expand-file-name bname (cwd)))
(let ((dfile (expand-file-name digest-file (cwd)))) (outport (open-output-file file))
(and (file-exists? dfile) (str (number->string checksum)))
(let ((outport (open-output-file dfile))) ;; (display ";;; update : ") (display bname) (newline)
(display ";;; update : ") (display target) (newline) (with-current-output-port outport (begin (display str) (newline)))
(with-current-output-port (close outport)))
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) (define (checksum-for-file fname)
(let* ((inport (open-input-file (expand-file-name digest-fname (cwd)))) (let ((file (expand-file-name fname (cwd))))
(strls (map (lambda (str) (and (file-exists? file)
(let ((ls (string-tokenize str))) (md5-digest->number (md5-digest-for-port (open-input-file file))))))
(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) ;;; optimizations possible: global variable with known checksums
(map (lambda (digest-file) (define (get-file-checksum fname)
(lambda () (checksum-for-file fname))
(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) (define (same-checksum? target extensions prereqs)
(let ((outport (open-output-file (expand-file-name dfname (cwd)))) (or (null? prereqs)
(names (if (or (null? strls) (null? (car strls))) '() (map car strls))) (let for-each-prereq ((current-prereq (car prereqs))
(sums (if (or (null? strls) (null? (car strls))) '() (map cdr strls)))) (previous-total 0)
(display ";;; update : ") (display dfname) (newline) (todo-prereqs (cdr prereqs)))
(for-each (lambda (name fp) (let* ((current-file-sum (get-file-checksum current-prereq))
(with-current-output-port outport (current-total (if current-file-sum
(for-each display (list fp " " name)) (+ current-file-sum previous-total)
(newline))) previous-total)))
names sums) (cond
(close outport) ((and (not (null? todo-prereqs)))
#t)) (for-each-prereq (car todo-prereqs)
current-total
(define (update-digest-files target checksum) (cdr todo-prereqs)))
(map (lambda (digest-file) ((and (null? todo-prereqs) (not (null? extensions)))
(lambda () (let for-each-ext ((ext (car extensions))
(let ((dfile (expand-file-name digest-file (cwd))) (todo-exts (cdr extensions)))
(tname (file-name-nondirectory target))) (let ((known-sum (checksum-from-file target ext)))
(and (file-exists? dfile) (cond
(let* ((*fname-md5* (digest-file->string-list dfile)) ((and (file-not-exists? target) known-sum)
(cleaned-table (if (or (null? *fname-md5*) (begin
(null? (car *fname-md5*))) (checksum-into-file target ext current-total)
(list) #f))
(alist-delete tname *fname-md5*)))) ((and (file-not-exists? target) (null? todo-exts))
(string-list->digest-file (begin
dfile (checksum-into-file target
(alist-cons tname checksum cleaned-table))))))) (last (reverse extensions))
digest-files)) current-total)
#f))
(define (checksum-changed? target) ((and known-sum (= current-total known-sum)) #t)
(let* ((inport (open-input-file target)) ((and known-sum (not (= current-total known-sum)))
(checksum (md5-digest->number (md5-digest-for-port inport))) (begin
(result-funcs (append (check-files-target+extensions target checksum) (checksum-into-file target ext current-total)
(check-digest-files target checksum)))) #f))
(close inport) ((and (not known-sum) (not (null? todo-exts)))
(not (let each-result-and ((current (car result-funcs)) (for-each-ext (car todo-exts) (cdr todo-exts)))
(todo (cdr result-funcs))) ((and (not known-sum) (null? todo-exts))
(let ((res (current))) (begin
(and res (checksum-into-file target ext current-total)
(or (null? todo) #f))
(each-result-and (car todo) (cdr todo))))))))) (else (error "no match in same-checksum?"))))))
(else (error "no match in same-checksum?")))))))
(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))))))