suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

undoing change until Matthew commits new version

Browse Source 
svn: r2958
This commit is contained in:
Eli Barzilay 2006-05-17 16:04:05 +00:00
parent d790fbb6f7
commit adb805ad7f
1 changed files with 232 additions and 203 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

435
collects/setup/pack.ss
View File

@ -10,84 +10,98 @@
(lib "getinfo.ss" "setup")) (lib "getinfo.ss" "setup"))
(provide pack mztar std-filter pack-collections) (provide pack mztar std-filter pack-collections)
(define pack (define pack
(opt-lambda (dest name paths collections (opt-lambda (dest name paths collections
[filter std-filter] [filter std-filter]
[encode? #t] [encode? #t]
[file-mode 'file] [file-mode 'file]
[unpack-unit #f] [unpack-unit #f]
[plt-relative? #t] [plt-relative? #t]
[requires null] [requires null]
[conflicts null] [conflicts null]
[plt-home-relative? #f]) [plt-home-relative? #f])
(define file (open-output-file dest 'truncate/replace)) (let*-values ([(file) (open-output-file dest 'truncate/replace)]
(define-values (fileout thd) [(fileout thd)
(if encode? (if encode?
(let-values ([(b64-out b64-in) (make-pipe 4096)] (let-values ([(b64-out b64-in) (make-pipe 4096)]
[(gz-out gz-in) (make-pipe 4096)]) [(gz-out gz-in) (make-pipe 4096)])
(thread (thread
(lambda () (lambda ()
(let ([normal (lambda () (let ([normal (lambda ()
(gzip-through-ports gz-out b64-in #f 0) (gzip-through-ports gz-out b64-in #f 0)
(close-output-port b64-in))] (close-output-port b64-in))]
[gzip (find-executable-path "gzip" #f)]) [gzip (find-executable-path "gzip" #f)])
(if gzip (if gzip
(let ([p (process* gzip "-c")]) (let ([p (process* gzip "-c")])
(if (eq? 'running ((list-ref p 4) 'status)) (if (eq? 'running ((list-ref p 4) 'status))
(begin (begin
;; Use gzip process. ;; Use gzip process.
;; Errors to error port: ;; Errors to error port:
(thread (thread
(lambda () (lambda ()
(dynamic-wind (dynamic-wind
void void
(lambda () (copy-port (cadddr p) (current-error-port))) (lambda ()
(lambda () (close-input-port (cadddr p)))))) (copy-port (cadddr p) (current-error-port)))
;; Copy input to gzip: (lambda ()
(thread (close-input-port (cadddr p))))))
(lambda () ;; Copy input to gzip:
(dynamic-wind (thread
void (lambda ()
(lambda () (copy-port gz-out (cadr p))) (dynamic-wind
(lambda () void
(close-input-port gz-out) (lambda ()
(close-output-port (cadr p)))))) (copy-port gz-out (cadr p)))
;; Copy input to b64: (lambda ()
(dynamic-wind (close-input-port gz-out)
void (close-output-port (cadr p))))))
(lambda () (copy-port (car p) b64-in)) ;; Copy input to b64:
(lambda () (dynamic-wind
(close-input-port (car p)) void
(close-output-port b64-in)))) (lambda ()
(normal))) (copy-port (car p) b64-in))
(normal))))) (lambda ()
(values gz-in (thread (lambda () (close-input-port (car p))
(base64-encode-stream b64-out file) (close-output-port b64-in))))
(close-output-port file))))) (normal)))
(values file (thread void)))) (normal)))))
(fprintf fileout "PLT\n") (values
(write `(lambda (request failure) gz-in
(case request (thread
[(name) ,name] (lambda ()
[(unpacker) 'mzscheme] (base64-encode-stream b64-out file)
[(requires) ',requires] (close-output-port file)))))
[(conflicts) ',conflicts] (values file (thread void)))])
[(plt-relative?) ,plt-relative?] (fprintf fileout "PLT~n")
[(plt-home-relative?) ,(and plt-relative? plt-home-relative?)] (write
[else (failure)])) `(lambda (request failure)
fileout) (case request
(newline fileout) [(name) ,name]
(write (or unpack-unit [(unpacker) 'mzscheme]
`(unit (import main-collects-parent-dir mzuntar) [(requires) ',requires]
(export) [(conflicts) ',conflicts]
(mzuntar void) [(plt-relative?) ,plt-relative?]
(quote ,collections))) [(plt-home-relative?) ,(and plt-relative?
fileout) plt-home-relative?)]
(newline fileout) [else (failure)]))
(for-each (lambda (path) (mztar path fileout filter file-mode)) paths) fileout)
(close-output-port fileout) (newline fileout)
(thread-wait thd))) (write
(or unpack-unit
`(unit
(import main-collects-parent-dir mzuntar)
(export)
(mzuntar void)
(quote ,collections)))
fileout)
(newline fileout)
(for-each
(lambda (path)
(mztar path fileout filter file-mode))
paths)
(close-output-port fileout)
(thread-wait thd))))
(define (element->string x) (define (element->string x)
(if (path? x) (path->string x) x)) (if (path? x) (path->string x) x))
@ -95,135 +109,150 @@
(define (mztar path output filter file-mode) (define (mztar path output filter file-mode)
(define (path->list p) (define (path->list p)
(if (eq? p 'same) (if (eq? p 'same)
null null
(let-values ([(base name dir?) (split-path p)]) (let-values ([(base name dir?) (split-path p)])
(if (path? base) (if (path? base)
(append (path->list base) (list name)) (append (path->list base) (list name))
(list name))))) (list name)))))
(define-values (init-dir init-files) (define-values (init-dir init-files)
(if (file-exists? path) (if (file-exists? path)
(let-values ([(base name dir?) (split-path path)]) (let-values ([(base name dir?) (split-path path)])
(values (if (eq? base 'relative) 'same base) (list name))) (values (if (eq? base 'relative) 'same base) (list name)))
(values (if (string? path) (string->path path) path) #f))) (values (if (string? path) (string->path path) path) #f)))
(let loop ([dir init-dir] [dpath (path->list init-dir)] [files init-files]) (let loop ([dir init-dir][dpath (path->list init-dir)][files init-files])
(printf "MzTarring ~a...\n" (if files (build-path dir (car files)) dir)) (printf "MzTarring ~a...~n"
(fprintf output "~s\n~s\n" 'dir (map element->string dpath)) (path->string
(for-each (lambda (f) (if files
(let* ([p (build-path dir f)] (build-path dir (car files))
[filter-val (filter p)]) dir)))
(when filter-val (fprintf output "~s~n~s~n" 'dir (map element->string dpath))
(if (directory-exists? p) (for-each
(loop p (append dpath (list f)) #f) (lambda (f)
(let ([len (file-size p)]) (let* ([p (build-path dir f)]
;; (printf "MzTarring ~a~n" p) [filter-val (filter p)])
(fprintf output "~s~n~s~n~s~n*" (when filter-val
(case filter-val (if (directory-exists? p)
[(file) 'file] (loop p (append dpath (list f)) #f)
[(file-replace) 'file-replace] (let ([len (file-size p)])
[else file-mode]) ;; (printf "MzTarring ~a~n" p)
(map element->string (append dpath (list f))) (fprintf output "~s~n~s~n~s~n*"
len) (case filter-val
(call-with-input-file* p [(file) 'file]
(lambda (p) (copy-port p output)))))))) [(file-replace) 'file-replace]
(or files [else file-mode])
(sort (map path->string (directory-list dir)) string<?))))) (map element->string (append dpath (list f)))
len)
(call-with-input-file* p
(lambda (p)
(copy-port p output))))))))
(or files (directory-list dir)))))
(define (std-filter path) (define (std-filter path)
(let ([name (path->bytes (let-values ([(_1 name _2) (split-path path)]) (let-values ([(base name dir?) (split-path path)])
name))]) (let ([name (path->bytes name)])
(not (or (regexp-match #rx#"^(?:compiled|CVS|[.]svn|[.]cvsignore)$" name) (not (or (regexp-match #rx#"^CVS$" name)
(regexp-match #rx#"(?:~$|^#.*#$|[.]plt$|^[.]#)" name))))) (regexp-match #rx#"^[.]svn$" name)
(regexp-match #rx#"^[.]cvsignore$" name)
(regexp-match #rx#"^compiled$" name)
(regexp-match #rx#"~$" name)
(regexp-match #rx#"^#.*#$" name)
(regexp-match #rx#"[.]plt$" name)
(regexp-match #rx#"^[.]#" name))))))
(define pack-collections (define pack-collections
(opt-lambda (output name collections replace? extra-setup-collections (opt-lambda (output name collections replace? extra-setup-collections [file-filter std-filter] [plt-home-relative? #f])
[file-filter std-filter] [plt-home-relative? #f]) (let-values ([(dir source-files requires conflicts name)
(let-values (let ([dirs (map (lambda (cp) (apply collection-path cp)) collections)])
([(output) (path->complete-path output)] ;; Figure out the base path:
[(dir source-files requires conflicts name) (let* ([base-path #f]
(let ([dirs (map (lambda (cp) (apply collection-path cp)) collections)]) [base-path-setter #f]
;; Figure out the base path: [rel-paths
(let* ([base-path #f] (map (lambda (dir coll)
[base-path-setter #f] (let-values ([(base c-name dir?) (split-path dir)])
[rel-paths (let-values ([(base subdir)
(map (lambda (dir coll) (let loop ([l (cdr coll)][base base])
(let*-values (let-values ([(base x-name dir?) (split-path base)])
([(base c-name dir?) (split-path dir)] (if (null? l)
[(base subdir) (values base x-name)
(let loop ([l (cdr coll)] [base base]) (let-values ([(base subdir) (loop (cdr l) base)])
(let-values ([(base x-name dir?) (split-path base)]) (values base (build-path subdir x-name))))))])
(if (null? l) (if base-path
(values base x-name) (unless (equal? base base-path)
(let-values ([(base subdir) (loop (cdr l) base)]) (error
(values base (build-path subdir x-name))))))]) 'mzc
(if base-path "cannot combine collections that live in different directories: \"~a\" and: \"~a\""
(unless (equal? base base-path) base-path-setter
(error 'mzc dir))
"cannot combine collections that live in different directories: \"~a\" and: \"~a\"" (begin
base-path-setter (set! base-path-setter dir)
dir)) (set! base-path base)))
(begin (set! base-path-setter dir) (build-path 'same subdir c-name))))
(set! base-path base))) dirs collections)]
(build-path 'same subdir c-name))) [infos (map (lambda (cp) (get-info cp))
dirs collections)] collections)]
[infos (map (lambda (cp) (get-info cp)) [coll-list? (lambda (cl)
collections)] (and (list? cl)
[coll-list? (lambda (cl) (andmap (lambda (c)
(and (list? cl) (and (list? c)
(andmap (lambda (c) (andmap string? c)
(and (list? c) (andmap relative-path? c)))
(andmap string? c) cl)))]
(andmap relative-path? c))) [get-dep-coll (lambda (which)
cl)))] (apply append (map (lambda (i src-cp)
[get-dep-coll (lambda (which) (let ([rl (if i
(apply append (map (lambda (i src-cp) (i which (lambda () null))
(let ([rl (if i null)])
(i which (lambda () null)) (unless (coll-list? rl)
null)]) (error
(unless (coll-list? rl) 'mzc
(error "bad ~a specification in info.ss for collection ~s"
'mzc which
"bad ~a specification in info.ss for collection ~s" src-cp))
which rl))
src-cp)) infos collections)))])
rl)) (values base-path
infos collections)))]) rel-paths
(values base-path (get-dep-coll 'requires)
rel-paths (append
(get-dep-coll 'requires) (if replace? null collections)
(append (if replace? null collections) (get-dep-coll 'conflicts))
(get-dep-coll 'conflicts)) (or name
(or name ((or (car infos)
((or (car infos) (lambda (n f) (caar collections)))
(lambda (n f) (caar collections))) 'name
'name (lambda () (caar collections)))))))])
(lambda () (caar collections)))))))]) (let ([output (path->complete-path output)])
(parameterize ([current-directory dir]) (parameterize ([current-directory dir])
(pack output name (pack output name
source-files source-files
(append extra-setup-collections (filter get-info collections)) (append
file-filter #t extra-setup-collections
(if replace? 'file-replace 'file) (filter get-info collections))
#f file-filter #t
#t ; plt-relative (if replace?
;; For each require, get current version 'file-replace
(map (lambda (r) 'file)
(let ([i (get-info r)]) #f
(let ([v (and i (i 'version (lambda () #f)))]) #t ; plt-relative
(if v ;; For each require, get current version
(begin (map (lambda (r)
(unless (and (list? v) (let ([i (get-info r)])
(andmap (lambda (x) (let ([v (and i (i 'version (lambda () #f)))])
(and (number? v) (if v
(exact? v) (begin
(integer? v))) (unless (and (list? v)
v)) (andmap number? v)
(error (andmap exact? v)
'mzc (andmap integer? v))
"bad version specification in info.ss for collection ~s" (error
r)) 'mzc
(list r v)) "bad version specification in info.ss for collection ~s"
(list r null))))) r))
(cons '("mzscheme") requires)) (list r v))
conflicts (list r null)))))
plt-home-relative?)))))) (cons
'("mzscheme")
requires))
conflicts
plt-home-relative?)))))))