101 lines
2.7 KiB
Scheme
101 lines
2.7 KiB
Scheme
|
|
;; Utilities for creating a .plt package, relies on gzip and mmencode
|
|
|
|
(define pack
|
|
(case-lambda
|
|
[(dest name paths collections)
|
|
(pack dest name paths collections std-filter #t 'file)]
|
|
[(dest name paths collections filter)
|
|
(pack dest name paths collections filter #t 'file)]
|
|
[(dest name paths collections filter encode?)
|
|
(pack dest name paths collections filter encode? 'file)]
|
|
[(dest name paths collections filter encode? file-mode)
|
|
(let* ([p (if encode?
|
|
(process (format "gzip -c | mmencode > ~s" dest))
|
|
#f)]
|
|
[stdin (if p
|
|
(cadr p)
|
|
(open-output-file dest 'truncate/replace))]
|
|
[echo (lambda (p)
|
|
(thread
|
|
(lambda ()
|
|
(let loop ()
|
|
(let ([l (read-line p 'any)])
|
|
(unless (eof-object? l)
|
|
(printf "~a~n" l)
|
|
(loop)))))))]
|
|
[t1 (and p (echo (car p)))]
|
|
[t2 (and p (echo (list-ref p 3)))])
|
|
(fprintf stdin "PLT~n")
|
|
(write
|
|
`(lambda (request failure)
|
|
(case request
|
|
[(name) ,name]
|
|
[(unpacker) 'mzscheme]))
|
|
stdin)
|
|
(newline stdin)
|
|
(write
|
|
`(unit
|
|
(import plthome mzuntar)
|
|
(export)
|
|
(mzuntar void)
|
|
(quote ,collections))
|
|
stdin)
|
|
(newline stdin)
|
|
(for-each
|
|
(lambda (path)
|
|
(mztar path stdin filter file-mode))
|
|
paths)
|
|
(close-output-port stdin)
|
|
(when p
|
|
(thread-wait t1)
|
|
(thread-wait t2)))]))
|
|
|
|
(define (mztar path output filter file-mode)
|
|
(define (path->list p)
|
|
(let-values ([(base name dir?) (split-path p)])
|
|
(if (string? base)
|
|
(append (path->list base) (list name))
|
|
(list name))))
|
|
(define-values (init-dir init-files)
|
|
(if (file-exists? path)
|
|
(let-values ([(base name dir?) (split-path path)])
|
|
(values base (list name)))
|
|
(values path #f)))
|
|
|
|
(let loop ([dir init-dir][dpath (path->list init-dir)][files init-files])
|
|
(printf "MzTarring ~a~a...~n" dir
|
|
(if files (car files) ""))
|
|
(fprintf output "~s~n~s~n" 'dir dpath)
|
|
(for-each
|
|
(lambda (f)
|
|
(let* ([p (build-path dir f)]
|
|
[filter-val (filter p)])
|
|
(when filter-val
|
|
(if (directory-exists? p)
|
|
(loop p (append dpath (list f)) #f)
|
|
(let ([len (file-size p)])
|
|
; (printf "MzTarring ~a~n" p)
|
|
(fprintf output "~s~n~s~n~s~n*"
|
|
(case filter-val
|
|
[(file) 'file]
|
|
[(file-replace) 'file-replace]
|
|
[else file-mode])
|
|
(append dpath (list f))
|
|
len)
|
|
(with-input-from-file p
|
|
(lambda ()
|
|
(let loop ()
|
|
(let ([c (read-char)])
|
|
(unless (eof-object? c)
|
|
(write-char c output)
|
|
(loop)))))))))))
|
|
(or files (directory-list dir)))))
|
|
|
|
(define (std-filter path)
|
|
(not (or (regexp-match "CVS$" path)
|
|
(regexp-match "compiled$" path)
|
|
(regexp-match "~$" path)
|
|
(regexp-match "^#.*#$" path))))
|
|
|