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

139
collects/setup/pack.ss
View File

@ -46,10 +46,8 @@
#: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
[collections null]
[filter std-filter] [filter std-filter]
[encode? #t] [encode? #t]
[file-mode 'file] [file-mode 'file]
@ -59,12 +57,10 @@
[conflicts null] [conflicts null]
[at-plt-home? #f] [at-plt-home? #f]
[test-plt-dirs #f]) [test-plt-dirs #f])
(when at-plt-home? (when (and at-plt-home? (not plt-relative?))
(unless plt-relative? (x-arg-needs-true-arg 'pack-plt 'at-plt-home? at-plt-home? '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?))
(when test-plt-dirs (x-arg-needs-true-arg 'pack-plt 'test-plt-dirs test-plt-dirs 'at-plt-home?))
(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)] (let*-values ([(file) (open-output-file dest 'truncate/replace)]
[(fileout thd) [(fileout thd)
(if encode? (if encode?
@ -110,45 +106,36 @@
(close-output-port b64-in)))) (close-output-port b64-in))))
(normal))) (normal)))
(normal))))) (normal)))))
(values (values gz-in
gz-in
(thread (thread
(lambda () (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 (write `(lambda (request failure)
`(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?) ,(and plt-relative? at-plt-home?)]
at-plt-home?)] [(test-plt-dirs)
[(test-plt-dirs) ,(and plt-relative? ,(and plt-relative? at-plt-home? `',test-plt-dirs)]
at-plt-home?
`',test-plt-dirs)]
[else (failure)])) [else (failure)]))
fileout) fileout)
(newline fileout) (newline fileout)
(write (write (or unpack-unit
(or unpack-unit `(unit (import main-collects-parent-dir mzuntar) (export)
`(unit
(import main-collects-parent-dir mzuntar)
(export)
(mzuntar void) (mzuntar void)
(quote ,collections))) (quote ,collections)))
fileout) fileout)
(newline fileout) (newline fileout)
(for-each (for-each (lambda (path) (mztar path fileout filter file-mode))
(lambda (path)
(mztar path fileout filter file-mode))
paths) 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))
@ -168,12 +155,12 @@
(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)]
@ -182,8 +169,8 @@
(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]
@ -191,47 +178,42 @@
(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
#:optional [file-filter std-filter] at-plt-home?)
(pack-collections-plt output name collections (pack-collections-plt output name collections
#:replace? replace? #:replace? replace?
#:extra-setup-collections extra-setup-collections #:extra-setup-collections extra-setup-collections
#:filter file-filter #:filter file-filter
#:at-plt-home? at-plt-home?))) #: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
[replace? #f]
[extra-setup-collections null] [extra-setup-collections null]
[file-filter std-filter] [file-filter std-filter]
[at-plt-home? #f] [at-plt-home? #f]
[test-plt-collects? #t]) [test-plt-collects? #t])
(let-values ([(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)]
(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)
@ -240,47 +222,42 @@
(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 (error 'mzc
'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 (begin (set! base-path-setter dir)
(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)] [coll-list?
[coll-list? (lambda (cl) (lambda (cl)
(and (list? cl) (and (list? cl)
(andmap (lambda (c) (andmap (lambda (c)
(and (list? c) (and (list? c)
(andmap string? c) (andmap string? c)
(andmap relative-path? c))) (andmap relative-path? c)))
cl)))] cl)))]
[get-dep-coll (lambda (which) [get-dep-coll
(apply append (map (lambda (i src-cp) (lambda (which)
(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 (error 'mzc "bad ~a specification in info.ss for collection ~s"
'mzc which src-cp))
"bad ~a specification in info.ss for collection ~s"
which
src-cp))
rl)) rl))
infos collections)))]) infos collections)))])
(values base-path (values base-path
rel-paths rel-paths
(get-dep-coll 'requires) (get-dep-coll 'requires)
(append (append (if replace? null collections)
(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)]) (let ([output (path->complete-path output)])
@ -288,13 +265,10 @@
(pack-plt (pack-plt
output name output name
source-files source-files
#:collections (append #:collections (append extra-setup-collections
extra-setup-collections
(filter get-info collections)) (filter get-info collections))
#:filter file-filter #:filter file-filter
#:file-mode (if replace? #:file-mode (if replace? 'file-replace 'file)
'file-replace
'file)
#:plt-relative? #t #:plt-relative? #t
#:requires #:requires
;; For each require, get current version ;; For each require, get current version
@ -313,11 +287,8 @@
r)) r))
(list r v)) (list r v))
(list r null))))) (list r null)))))
(cons (cons '("mzscheme") requires))
'("mzscheme")
requires))
#:conflicts conflicts #:conflicts conflicts
#:at-plt-home? at-plt-home? #:at-plt-home? at-plt-home?
#:test-plt-dirs (and at-plt-home? #:test-plt-dirs (and at-plt-home? test-plt-collects?
test-plt-collects? '("collects"))))))))
'("collects")))))))))