94 lines
4.0 KiB
Scheme
Executable File
94 lines
4.0 KiB
Scheme
Executable File
#!/bin/sh
|
|
#| -*- mode: scheme -*-
|
|
if [ -x "$PLTHOME/bin/mzscheme" ]; then
|
|
exec "$PLTHOME/bin/mzscheme" -rm "$0" "$@"
|
|
else
|
|
exec "mzscheme" -rm "$0" "$@"
|
|
fi
|
|
|#
|
|
|
|
(define begin-pattern #"<!-- begin: __XXX__ -->\n")
|
|
(define end-pattern #"\n<!-- end: __XXX__ -->")
|
|
|
|
(define begin-re (regexp-replace #"XXX" begin-pattern #"([^<> ]+)"))
|
|
(define end-re (regexp-replace #"XXX" end-pattern #"([^<> ]+)"))
|
|
|
|
(define (regexp-match1 rx inp . disp?)
|
|
(cond [(if (and (pair? disp?) (car disp?))
|
|
(regexp-match rx inp 0 #f (current-output-port))
|
|
(regexp-match rx inp))
|
|
=> cadr]
|
|
[else #f]))
|
|
|
|
(define (eprintf fmt . args)
|
|
(apply fprintf (current-error-port) fmt args))
|
|
|
|
(define (patch-file skeleton html)
|
|
(let ([skeleton (open-input-file skeleton)]
|
|
[html (open-input-file html)])
|
|
(let loop ()
|
|
(let ([begin-tag (regexp-match1 begin-re skeleton #t)])
|
|
;; (eprintf ">>> skeleton: ~a begin\n" begin-tag)
|
|
(if begin-tag
|
|
(let ([begin-tag* (regexp-match1 begin-re html)])
|
|
;; (eprintf ">>> html: ~a begin\n" begin-tag*)
|
|
(unless (equal? begin-tag begin-tag*)
|
|
(error 'patch-html
|
|
"mismatched input begin-tags, expecting ~a got ~a"
|
|
begin-tag begin-tag*))
|
|
;; leave tags in, so it is possible to run this script again
|
|
(display (regexp-replace #"XXX" begin-pattern begin-tag))
|
|
(let ([end-tag (regexp-match1 end-re html #t)])
|
|
;; (eprintf ">>> html: ~a end\n" end-tag)
|
|
(unless (equal? end-tag begin-tag)
|
|
(error 'patch-html "bad end tag (~a) for begin tag (~a)"
|
|
end-tag begin-tag))
|
|
(let ([end-tag* (regexp-match1 end-re skeleton)])
|
|
;; (eprintf ">>> skeleton: ~a end\n" end-tag*)
|
|
(unless (equal? end-tag end-tag*)
|
|
(error 'patch-html
|
|
"mismatched input end-tags, expecting ~a got ~a"
|
|
end-tag end-tag*))
|
|
;; leave tags in, so it is possible to run this script again
|
|
(display (regexp-replace #"XXX" end-pattern end-tag))
|
|
(loop))))
|
|
(cond [(regexp-match1 begin-re html) =>
|
|
(lambda (tag)
|
|
(error 'patch-html
|
|
"mismatched input tags, extraneous tag in target: ~a"
|
|
tag))]))))
|
|
(close-input-port skeleton)
|
|
(close-input-port html)))
|
|
|
|
(define (patch-dir skeleton-dir)
|
|
(printf "patching directory: ~a\n" (current-directory))
|
|
(for-each (lambda (p)
|
|
(if (cdr p)
|
|
(begin
|
|
(unless (directory-exists? (car p)) (make-directory (car p)))
|
|
(parameterize ([current-directory (car p)])
|
|
(patch-dir (build-path skeleton-dir (car p)))))
|
|
(let ([skeleton (build-path skeleton-dir (car p))])
|
|
(if (file-exists? (car p))
|
|
(let ([tmp "/tmp/patch-html-file"])
|
|
(printf "patching file: ~a\n"
|
|
(build-path (current-directory) (car p)))
|
|
(with-output-to-file tmp
|
|
(lambda () (patch-file skeleton (car p)))
|
|
#:exists 'truncate)
|
|
(delete-file (car p))
|
|
(copy-file tmp (car p))
|
|
(delete-file tmp))
|
|
(begin (printf "copying file: ~a/~a\n"
|
|
(current-directory) (car p))
|
|
(copy-file skeleton (car p)))))))
|
|
(parameterize ([current-directory skeleton-dir])
|
|
(map (lambda (p)
|
|
(cons p (cond [(file-exists? p) #f]
|
|
[(directory-exists? p) #t]
|
|
[else (error "internal-error")])))
|
|
(directory-list)))))
|
|
|
|
(define (main arg)
|
|
(patch-dir (path->complete-path arg)))
|