From 4a258cb9b347ef2621602bf387244d7512827017 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Thu, 18 May 2006 20:18:14 +0000 Subject: [PATCH] sort directory lists and reformat svn: r2975 --- collects/setup/pack.ss | 473 +++++++++++++++++++---------------------- 1 file changed, 222 insertions(+), 251 deletions(-) diff --git a/collects/setup/pack.ss b/collects/setup/pack.ss index 0771eed96c..43503bf792 100644 --- a/collects/setup/pack.ss +++ b/collects/setup/pack.ss @@ -46,109 +46,96 @@ #:conflicts null #:at-plt-home? at-plt-home?))) - (define pack-plt - (lambda/kw (dest name paths - #:key - [collections null] - [filter std-filter] - [encode? #t] - [file-mode 'file] - [unpack-unit #f] - [plt-relative? #t] - [requires null] - [conflicts null] - [at-plt-home? #f] - [test-plt-dirs #f]) - (when at-plt-home? - (unless plt-relative? - (x-arg-needs-true-arg 'pack-plt 'at-plt-home? at-plt-home? 'plt-relative?))) - (when test-plt-dirs - (unless 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 '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 path fileout filter file-mode)) - paths) - (close-output-port fileout) - (thread-wait thd)))) + (define/kw (pack-plt dest name paths + #:key [collections null] + [filter std-filter] + [encode? #t] + [file-mode 'file] + [unpack-unit #f] + [plt-relative? #t] + [requires null] + [conflicts null] + [at-plt-home? #f] + [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 '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 path fileout filter file-mode)) + paths) + (close-output-port fileout) + (thread-wait thd))) (define (element->string x) (if (path? x) (path->string x) x)) @@ -156,168 +143,152 @@ (define (mztar path output 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))))) + 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" + (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)) + (fprintf output "~s\n~s\n" 'dir (map element->string 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]) - (map element->string (append dpath (list f))) - len) - (call-with-input-file* p - (lambda (p) - (copy-port p output)))))))) - (or files (directory-list dir))))) - + (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)) stringbytes name)]) - (not (or (regexp-match #rx#"^CVS$" 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)))))) + (not (or (regexp-match #rx#"^(?:CVS|[.]svn|[.]cvsignore|compiled)$" + name) + (regexp-match #rx#"~$|^#.*#$|^[.]#" name) + (regexp-match #rx#"[.]plt$" name)))))) - (define pack-collections - (opt-lambda (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 - #:filter file-filter - #:at-plt-home? at-plt-home?))) + (define/kw (pack-collections + output name collections replace? extra-setup-collections + #:optional [file-filter std-filter] at-plt-home?) + (pack-collections-plt output name collections + #:replace? replace? + #:extra-setup-collections extra-setup-collections + #:filter file-filter + #:at-plt-home? at-plt-home?)) - (define pack-collections-plt - (lambda/kw (output name collections - #:key - [replace? #f] - [extra-setup-collections null] - [file-filter std-filter] - [at-plt-home? #f] - [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)]) - (let-values ([(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)) - #: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"))))))))) + (define/kw (pack-collections-plt output name collections + #:key [replace? #f] + [extra-setup-collections null] + [file-filter std-filter] + [at-plt-home? #f] + [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)) + #: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"))))))))