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

121
collects/setup/pack.ss
View File

@ -21,8 +21,8 @@
[requires null]
[conflicts null]
[plt-home-relative? #f])
(define file (open-output-file dest 'truncate/replace))
(define-values (fileout thd)
(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)])
@ -42,52 +42,66 @@
(lambda ()
(dynamic-wind
void
(lambda () (copy-port (cadddr p) (current-error-port)))
(lambda () (close-input-port (cadddr p))))))
(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 ()
(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 ()
(copy-port (car p) b64-in))
(lambda ()
(close-input-port (car p))
(close-output-port b64-in))))
(normal)))
(normal)))))
(values gz-in (thread (lambda ()
(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)
(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? plt-home-relative?)]
[(plt-home-relative?) ,(and plt-relative?
plt-home-relative?)]
[else (failure)]))
fileout)
(newline fileout)
(write (or unpack-unit
`(unit (import main-collects-parent-dir mzuntar)
(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)
(for-each
(lambda (path)
(mztar path fileout filter file-mode))
paths)
(close-output-port fileout)
(thread-wait thd)))
(thread-wait thd))))
(define (element->string x)
(if (path? x) (path->string x) x))
@ -107,9 +121,14 @@
(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" (if files (build-path dir (car files)) dir))
(fprintf output "~s\n~s\n" 'dir (map element->string dpath))
(for-each (lambda (f)
(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))
(for-each
(lambda (f)
(let* ([p (build-path dir f)]
[filter-val (filter p)])
(when filter-val
@ -125,31 +144,33 @@
(map element->string (append dpath (list f)))
len)
(call-with-input-file* p
(lambda (p) (copy-port p output))))))))
(or files
(sort (map path->string (directory-list dir)) string<?)))))
(lambda (p)
(copy-port p output))))))))
(or files (directory-list dir)))))
(define (std-filter path)
(let ([name (path->bytes (let-values ([(_1 name _2) (split-path path)])
name))])
(not (or (regexp-match #rx#"^(?:compiled|CVS|[.]svn|[.]cvsignore)$" name)
(regexp-match #rx#"(?:~$|^#.*#$|[.]plt$|^[.]#)" name)))))
(let-values ([(base name dir?) (split-path path)])
(let ([name (path->bytes 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))))))
(define pack-collections
(opt-lambda (output name collections replace? extra-setup-collections
[file-filter std-filter] [plt-home-relative? #f])
(let-values
([(output) (path->complete-path output)]
[(dir source-files requires conflicts name)
(opt-lambda (output name collections replace? extra-setup-collections [file-filter std-filter] [plt-home-relative? #f])
(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-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)
@ -158,13 +179,15 @@
(values base (build-path subdir x-name))))))])
(if base-path
(unless (equal? base base-path)
(error 'mzc
(error
'mzc
"cannot combine collections that live in different directories: \"~a\" and: \"~a\""
base-path-setter
dir))
(begin (set! base-path-setter dir)
(begin
(set! base-path-setter dir)
(set! base-path base)))
(build-path 'same subdir c-name)))
(build-path 'same subdir c-name))))
dirs collections)]
[infos (map (lambda (cp) (get-info cp))
collections)]
@ -191,19 +214,25 @@
(values base-path
rel-paths
(get-dep-coll 'requires)
(append (if replace? null collections)
(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 output name
source-files
(append extra-setup-collections (filter get-info collections))
(append
extra-setup-collections
(filter get-info collections))
file-filter #t
(if replace? 'file-replace 'file)
(if replace?
'file-replace
'file)
#f
#t ; plt-relative
;; For each require, get current version
@ -213,17 +242,17 @@
(if v
(begin
(unless (and (list? v)
(andmap (lambda (x)
(and (number? v)
(exact? v)
(integer? v)))
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))
(cons
'("mzscheme")
requires))
conflicts
plt-home-relative?))))))
plt-home-relative?)))))))