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

reformatting, and always sort the list of files in a directory

Browse Source 
svn: r2955
This commit is contained in:
Eli Barzilay 2006-05-17 05:22:13 +00:00
parent 0ea1b98548
commit 11ac73a653
1 changed files with 203 additions and 232 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

435
collects/setup/pack.ss
View File

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