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

sort directory lists and reformat

Browse Source 
svn: r2975
This commit is contained in:
Eli Barzilay 2006-05-18 20:18:14 +00:00
parent 202bec1be4
commit 4a258cb9b3
1 changed files with 222 additions and 251 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

473
collects/setup/pack.ss
View File

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