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

125
collects/setup/pack.ss
View File

@ -21,8 +21,8 @@
[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)])
@ -42,52 +42,66 @@
(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)))
(lambda ()
(close-input-port (cadddr p))))))
;; Copy input to gzip: ;; Copy input to gzip:
(thread (thread
(lambda () (lambda ()
(dynamic-wind (dynamic-wind
void void
(lambda () (copy-port gz-out (cadr p))) (lambda ()
(copy-port gz-out (cadr p)))
(lambda () (lambda ()
(close-input-port gz-out) (close-input-port gz-out)
(close-output-port (cadr p)))))) (close-output-port (cadr p))))))
;; Copy input to b64: ;; Copy input to b64:
(dynamic-wind (dynamic-wind
void void
(lambda () (copy-port (car p) b64-in)) (lambda ()
(copy-port (car p) b64-in))
(lambda () (lambda ()
(close-input-port (car p)) (close-input-port (car p))
(close-output-port b64-in)))) (close-output-port b64-in))))
(normal))) (normal)))
(normal))))) (normal)))))
(values gz-in (thread (lambda () (values
gz-in
(thread
(lambda ()
(base64-encode-stream b64-out file) (base64-encode-stream b64-out file)
(close-output-port file))))) (close-output-port file)))))
(values file (thread void)))) (values file (thread void)))])
(fprintf fileout "PLT\n") (fprintf fileout "PLT~n")
(write `(lambda (request failure) (write
`(lambda (request failure)
(case request (case request
[(name) ,name] [(name) ,name]
[(unpacker) 'mzscheme] [(unpacker) 'mzscheme]
[(requires) ',requires] [(requires) ',requires]
[(conflicts) ',conflicts] [(conflicts) ',conflicts]
[(plt-relative?) ,plt-relative?] [(plt-relative?) ,plt-relative?]
[(plt-home-relative?) ,(and plt-relative? plt-home-relative?)] [(plt-home-relative?) ,(and plt-relative?
plt-home-relative?)]
[else (failure)])) [else (failure)]))
fileout) fileout)
(newline fileout) (newline fileout)
(write (or unpack-unit (write
`(unit (import main-collects-parent-dir mzuntar) (or unpack-unit
`(unit
(import main-collects-parent-dir mzuntar)
(export) (export)
(mzuntar void) (mzuntar void)
(quote ,collections))) (quote ,collections)))
fileout) fileout)
(newline fileout) (newline fileout)
(for-each (lambda (path) (mztar path fileout filter file-mode)) paths) (for-each
(lambda (path)
(mztar path fileout filter file-mode))
paths)
(close-output-port fileout) (close-output-port fileout)
(thread-wait thd))) (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))
@ -106,10 +120,15 @@
(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
(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)] (let* ([p (build-path dir f)]
[filter-val (filter p)]) [filter-val (filter p)])
(when filter-val (when filter-val
@ -125,32 +144,34 @@
(map element->string (append dpath (list f))) (map element->string (append dpath (list f)))
len) len)
(call-with-input-file* p (call-with-input-file* p
(lambda (p) (copy-port p output)))))))) (lambda (p)
(or files (copy-port p output))))))))
(sort (map path->string (directory-list dir)) string<?))))) (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
([(output) (path->complete-path output)]
[(dir source-files requires conflicts name)
(let ([dirs (map (lambda (cp) (apply collection-path cp)) collections)]) (let ([dirs (map (lambda (cp) (apply collection-path cp)) collections)])
;; Figure out the base path: ;; Figure out the base path:
(let* ([base-path #f] (let* ([base-path #f]
[base-path-setter #f] [base-path-setter #f]
[rel-paths [rel-paths
(map (lambda (dir coll) (map (lambda (dir coll)
(let*-values (let-values ([(base c-name dir?) (split-path dir)])
([(base c-name dir?) (split-path dir)] (let-values ([(base subdir)
[(base subdir) (let loop ([l (cdr coll)][base base])
(let loop ([l (cdr coll)] [base base])
(let-values ([(base x-name dir?) (split-path base)]) (let-values ([(base x-name dir?) (split-path base)])
(if (null? l) (if (null? l)
(values base x-name) (values base x-name)
@ -158,13 +179,15 @@
(values base (build-path subdir x-name))))))]) (values base (build-path subdir x-name))))))])
(if base-path (if base-path
(unless (equal? base base-path) (unless (equal? base base-path)
(error 'mzc (error
'mzc
"cannot combine collections that live in different directories: \"~a\" and: \"~a\"" "cannot combine collections that live in different directories: \"~a\" and: \"~a\""
base-path-setter base-path-setter
dir)) dir))
(begin (set! base-path-setter dir) (begin
(set! base-path-setter dir)
(set! base-path base))) (set! base-path base)))
(build-path 'same subdir c-name))) (build-path 'same subdir c-name))))
dirs collections)] dirs collections)]
[infos (map (lambda (cp) (get-info cp)) [infos (map (lambda (cp) (get-info cp))
collections)] collections)]
@ -191,19 +214,25 @@
(values base-path (values base-path
rel-paths rel-paths
(get-dep-coll 'requires) (get-dep-coll 'requires)
(append (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
extra-setup-collections
(filter get-info collections))
file-filter #t file-filter #t
(if replace? 'file-replace 'file) (if replace?
'file-replace
'file)
#f #f
#t ; plt-relative #t ; plt-relative
;; For each require, get current version ;; For each require, get current version
@ -213,17 +242,17 @@
(if v (if v
(begin (begin
(unless (and (list? v) (unless (and (list? v)
(andmap (lambda (x) (andmap number? v)
(and (number? v) (andmap exact? v)
(exact? v) (andmap integer? v))
(integer? v)))
v))
(error (error
'mzc 'mzc
"bad version specification in info.ss for collection ~s" "bad version specification in info.ss for collection ~s"
r)) r))
(list r v)) (list r v))
(list r null))))) (list r null)))))
(cons '("mzscheme") requires)) (cons
'("mzscheme")
requires))
conflicts conflicts
plt-home-relative?)))))) plt-home-relative?)))))))