9c352f5704
Some mentions of svn/subversion are replaced with git, and some patterns for paths to ignore include ".git*". (Note ".mailmap" not added, might need to.)
288 lines
13 KiB
Racket
288 lines
13 KiB
Racket
;; Utilities for creating a .plt package
|
|
(module pack scheme/base
|
|
(require file/gzip
|
|
net/base64
|
|
scheme/system
|
|
scheme/port
|
|
scheme/file
|
|
setup/getinfo)
|
|
|
|
(provide pack
|
|
pack-plt
|
|
mztar
|
|
std-filter
|
|
pack-collections
|
|
pack-collections-plt)
|
|
|
|
(define (x-arg-needs-true-arg who arg1-name v arg2-name)
|
|
(error who (string-append "true value for `~a' argument: ~e "
|
|
"requires a true value for `~a' argument")
|
|
arg1-name v arg2-name))
|
|
|
|
(define (pack dest name paths collections
|
|
[file-filter std-filter]
|
|
[encode? #t]
|
|
[file-mode 'file]
|
|
[unpack-unit #f]
|
|
[plt-relative? #t]
|
|
[requires null]
|
|
[conflicts null]
|
|
[at-plt-home? #f])
|
|
(pack-plt dest name paths
|
|
#:collections collections
|
|
#:file-filter file-filter
|
|
#:encode? encode?
|
|
#:file-mode file-mode
|
|
#:unpack-unit unpack-unit
|
|
#:plt-relative? plt-relative?
|
|
#:requires null
|
|
#:conflicts null
|
|
#:at-plt-home? at-plt-home?))
|
|
|
|
(define (pack-plt dest name paths
|
|
#:collections [collections null]
|
|
#:file-filter [file-filter std-filter]
|
|
#:encode? [encode? #t]
|
|
#:file-mode [file-mode 'file]
|
|
#:unpack-unit [unpack-unit #f]
|
|
#:plt-relative? [plt-relative? #t]
|
|
#:requires [requires null]
|
|
#:conflicts [conflicts null]
|
|
#:at-plt-home? [at-plt-home? #f]
|
|
#:test-plt-dirs [test-plt-dirs #f])
|
|
(when (and at-plt-home? (not plt-relative?))
|
|
(x-arg-needs-true-arg 'pack-plt 'at-plt-home? at-plt-home? 'plt-relative?))
|
|
(when (and test-plt-dirs (not at-plt-home?))
|
|
(x-arg-needs-true-arg 'pack-plt 'test-plt-dirs test-plt-dirs 'at-plt-home?))
|
|
(let*-values ([(file) (open-output-file dest #:exists 'truncate/replace)]
|
|
[(fileout thd)
|
|
(if encode?
|
|
(let-values ([(b64-out b64-in) (make-pipe 4096)]
|
|
[(gz-out gz-in) (make-pipe 4096)])
|
|
(thread
|
|
(lambda ()
|
|
(let ([normal (lambda ()
|
|
(gzip-through-ports gz-out b64-in #f 0)
|
|
(close-output-port b64-in))]
|
|
[gzip (find-executable-path "gzip" #f)])
|
|
(if gzip
|
|
(let ([p (process* gzip "-c")])
|
|
(if (eq? 'running ((list-ref p 4) 'status))
|
|
(begin
|
|
;; Use gzip process.
|
|
;; Errors to error port:
|
|
(thread
|
|
(lambda ()
|
|
(dynamic-wind
|
|
void
|
|
(lambda ()
|
|
(copy-port (cadddr p) (current-error-port)))
|
|
(lambda ()
|
|
(close-input-port (cadddr p))))))
|
|
;; Copy input to gzip:
|
|
(thread
|
|
(lambda ()
|
|
(dynamic-wind
|
|
void
|
|
(lambda ()
|
|
(copy-port gz-out (cadr p)))
|
|
(lambda ()
|
|
(close-input-port gz-out)
|
|
(close-output-port (cadr p))))))
|
|
;; Copy input to b64:
|
|
(dynamic-wind
|
|
void
|
|
(lambda ()
|
|
(copy-port (car p) b64-in))
|
|
(lambda ()
|
|
(close-input-port (car p))
|
|
(close-output-port b64-in))))
|
|
(normal)))
|
|
(normal)))))
|
|
(values gz-in
|
|
(thread
|
|
(lambda ()
|
|
(base64-encode-stream b64-out file)
|
|
(close-output-port file)))))
|
|
(values file (thread void)))])
|
|
(fprintf fileout "PLT\n")
|
|
(write `(lambda (request failure)
|
|
(case request
|
|
[(name) ,name]
|
|
[(unpacker) 'mzscheme]
|
|
[(requires) ',requires]
|
|
[(conflicts) ',conflicts]
|
|
[(plt-relative?) ,plt-relative?]
|
|
[(plt-home-relative?) ,(and plt-relative? at-plt-home?)]
|
|
[(test-plt-dirs)
|
|
,(and plt-relative? at-plt-home? `',test-plt-dirs)]
|
|
[else (failure)]))
|
|
fileout)
|
|
(newline fileout)
|
|
(write (or unpack-unit
|
|
`(unit (import main-collects-parent-dir mzuntar) (export)
|
|
(mzuntar void)
|
|
(quote ,collections)))
|
|
fileout)
|
|
(newline fileout)
|
|
(for-each (lambda (path)
|
|
(mztar (simplify-path path #f) fileout file-filter file-mode))
|
|
paths)
|
|
(close-output-port fileout)
|
|
(thread-wait thd)))
|
|
|
|
(define (element->string x)
|
|
(if (path? x) (path->string x) x))
|
|
|
|
(define (mztar path output file-filter file-mode)
|
|
(define (path->list p)
|
|
(if (eq? p 'same)
|
|
null
|
|
(let-values ([(base name dir?) (split-path p)])
|
|
(if (path? 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 (if (eq? base 'relative) 'same base) (list name)))
|
|
(values (if (string? path) (string->path path) path) #f)))
|
|
|
|
(let loop ([dir init-dir] [dpath (path->list init-dir)] [files init-files])
|
|
(printf "MzTarring ~a...\n"
|
|
(path->string
|
|
(if files
|
|
(build-path dir (car files))
|
|
dir)))
|
|
(fprintf output "~s\n~s\n" 'dir (map element->string dpath))
|
|
(for-each
|
|
(lambda (f)
|
|
(let* ([p (build-path dir f)]
|
|
[filter-val (file-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])
|
|
(map element->string (append dpath (list f)))
|
|
len)
|
|
(call-with-input-file* p
|
|
(lambda (p) (copy-port p output))))))))
|
|
(or files (sort (map element->string (directory-list dir)) string<?)))))
|
|
|
|
(define (std-filter path)
|
|
(let-values ([(base name dir?) (split-path path)])
|
|
(let ([name (path->bytes name)])
|
|
(not (or (regexp-match? #rx#"^(?:[.](?:git.*|svn|cvsignore)|CVS|compiled|doc)$"
|
|
name)
|
|
(regexp-match? #rx#"~$|^#.*#$|^[.]#" name)
|
|
(regexp-match? #rx#"[.]plt$" name))))))
|
|
|
|
(define (pack-collections output name collections replace? extra-setup-collections
|
|
[file-filter std-filter] [at-plt-home? #f])
|
|
(pack-collections-plt output name collections
|
|
#:replace? replace?
|
|
#:extra-setup-collections extra-setup-collections
|
|
#:file-filter file-filter
|
|
#:at-plt-home? at-plt-home?))
|
|
|
|
(define (pack-collections-plt output name collections
|
|
#:replace? [replace? #f]
|
|
#:extra-setup-collections [extra-setup-collections null]
|
|
#:file-filter [file-filter std-filter]
|
|
#:at-plt-home? [at-plt-home? #f]
|
|
#:test-plt-collects? [test-plt-collects? #t])
|
|
(let-values
|
|
([(dir source-files requires conflicts name)
|
|
(let ([dirs (map (lambda (cp) (apply collection-path cp)) collections)])
|
|
;; Figure out the base path:
|
|
(let* ([base-path #f]
|
|
[base-path-setter #f]
|
|
[rel-paths
|
|
(map (lambda (dir coll)
|
|
(let*-values ([(base c-name dir?) (split-path dir)]
|
|
[(base subdir)
|
|
(let loop ([l (cdr coll)][base base])
|
|
(let-values ([(base x-name dir?) (split-path base)])
|
|
(if (null? l)
|
|
(values base x-name)
|
|
(let-values ([(base subdir) (loop (cdr l) base)])
|
|
(values base (build-path subdir x-name))))))])
|
|
(if base-path
|
|
(unless (equal? base base-path)
|
|
(error 'mzc
|
|
"cannot combine collections that live in different directories: \"~a\" and: \"~a\""
|
|
base-path-setter
|
|
dir))
|
|
(begin (set! base-path-setter dir)
|
|
(set! base-path base)))
|
|
(build-path 'same subdir c-name)))
|
|
dirs collections)]
|
|
[infos (map (lambda (cp) (get-info cp)) collections)]
|
|
[coll-list?
|
|
(lambda (cl)
|
|
(and (list? cl)
|
|
(andmap (lambda (c)
|
|
(and (list? c)
|
|
(andmap string? c)
|
|
(andmap relative-path? c)))
|
|
cl)))]
|
|
[get-dep-coll
|
|
(lambda (which)
|
|
(apply append
|
|
(map (lambda (i src-cp)
|
|
(let ([rl (if i
|
|
(i which (lambda () null))
|
|
null)])
|
|
(unless (coll-list? rl)
|
|
(error 'mzc "bad ~a specification in info.ss for collection ~s"
|
|
which src-cp))
|
|
rl))
|
|
infos collections)))])
|
|
(values base-path
|
|
rel-paths
|
|
(get-dep-coll 'requires)
|
|
(append (if replace? null collections)
|
|
(get-dep-coll 'conflicts))
|
|
(or name
|
|
((or (car infos) (lambda (n f) (caar collections)))
|
|
'name
|
|
(lambda () (caar collections)))))))])
|
|
(let ([output (path->complete-path output)])
|
|
(parameterize ([current-directory dir])
|
|
(pack-plt
|
|
output name
|
|
source-files
|
|
#:collections (append extra-setup-collections
|
|
(filter get-info collections))
|
|
#:file-filter file-filter
|
|
#:file-mode (if replace? 'file-replace 'file)
|
|
#:plt-relative? #t
|
|
#:requires
|
|
;; For each require, get current version
|
|
(map (lambda (r)
|
|
(let ([i (get-info r)])
|
|
(let ([v (and i (i 'version (lambda () #f)))])
|
|
(if v
|
|
(begin
|
|
(unless (and (list? v)
|
|
(andmap number? v)
|
|
(andmap exact? v)
|
|
(andmap integer? v))
|
|
(error
|
|
'mzc
|
|
"bad version specification in info.ss for collection ~s"
|
|
r))
|
|
(list r v))
|
|
(list r null)))))
|
|
(cons '("mzscheme") requires))
|
|
#:conflicts conflicts
|
|
#:at-plt-home? at-plt-home?
|
|
#:test-plt-dirs (and at-plt-home? test-plt-collects?
|
|
'("collects"))))))))
|