some more style changes
svn: r2976
This commit is contained in:
Eli Barzilay
parent
4a258cb9b3
commit
132ff42a1a
|
|
@ -4,7 +4,6 @@
|
|||
(lib "base64.ss" "net")
|
||||
(lib "process.ss")
|
||||
(lib "list.ss")
|
||||
(lib "etc.ss")
|
||||
(lib "port.ss")
|
||||
(lib "file.ss")
|
||||
(lib "kw.ss")
|
||||
|
|
@ -18,16 +17,12 @@
|
|||
pack-collections-plt)
|
||||
|
||||
(define (x-arg-needs-true-arg who arg1-name v arg2-name)
|
||||
(error who
|
||||
(string-append
|
||||
"true value for `~a' argument: ~e "
|
||||
(error who (string-append "true value for `~a' argument: ~e "
|
||||
"requires a true value for `~a' argument")
|
||||
arg1-name v
|
||||
arg2-name))
|
||||
arg1-name v arg2-name))
|
||||
|
||||
(define pack
|
||||
(opt-lambda (dest name paths collections
|
||||
[filter std-filter]
|
||||
(define/kw (pack dest name paths collections
|
||||
#:optional [filter std-filter]
|
||||
[encode? #t]
|
||||
[file-mode 'file]
|
||||
[unpack-unit #f]
|
||||
|
|
@ -44,7 +39,7 @@
|
|||
#:plt-relative? plt-relative?
|
||||
#:requires null
|
||||
#:conflicts null
|
||||
#:at-plt-home? at-plt-home?)))
|
||||
#:at-plt-home? at-plt-home?))
|
||||
|
||||
(define/kw (pack-plt dest name paths
|
||||
#:key [collections null]
|
||||
|
|
|
|||
|
|
@ -18,39 +18,29 @@
|
|||
(thread (lambda ()
|
||||
(dynamic-wind
|
||||
void
|
||||
(lambda ()
|
||||
(base64-decode-stream p64gz base64-in))
|
||||
(lambda ()
|
||||
(close-output-port base64-in)))))]
|
||||
(lambda () (base64-decode-stream p64gz base64-in))
|
||||
(lambda () (close-output-port base64-in)))))]
|
||||
[gzt
|
||||
(thread (lambda ()
|
||||
(dynamic-wind
|
||||
void
|
||||
(lambda ()
|
||||
(gunzip-through-ports base64-out guz-in))
|
||||
(lambda ()
|
||||
(close-output-port guz-in)))))])
|
||||
(values guz-out
|
||||
(lambda ()
|
||||
(kill-thread 64t)
|
||||
(kill-thread gzt))))))
|
||||
(lambda () (gunzip-through-ports base64-out guz-in))
|
||||
(lambda () (close-output-port guz-in)))))])
|
||||
(values guz-out (lambda () (kill-thread 64t) (kill-thread gzt))))))
|
||||
|
||||
(define (pretty-name f)
|
||||
(with-handlers ([void (lambda (x) f)])
|
||||
(let-values ([(base name dir?) (split-path f)])
|
||||
(format "~a in ~a" (path->string name) (if (path? base)
|
||||
(path->string base)
|
||||
base)))))
|
||||
(format "~a in ~a"
|
||||
(path->string name)
|
||||
(if (path? base) (path->string base) base)))))
|
||||
|
||||
(define (shuffle-path parent-dir get-dir shuffle? v)
|
||||
(if shuffle?
|
||||
;; Re-arrange for "collects', etc.
|
||||
(cond
|
||||
[(null? v) (values #f 'same)]
|
||||
[else
|
||||
(let ([dir
|
||||
(cond
|
||||
[(string=? (car v) "collects")
|
||||
(if (null? v)
|
||||
(values #f 'same)
|
||||
(let ([dir (cond [(string=? (car v) "collects")
|
||||
(get-dir find-collects-dir find-user-collects-dir)]
|
||||
[(string=? (car v) "doc")
|
||||
(get-dir find-doc-dir find-user-doc-dir)]
|
||||
|
|
@ -63,11 +53,8 @@
|
|||
(if (null? (cdr v))
|
||||
(values dir 'same)
|
||||
(values dir (apply build-path (cdr v))))
|
||||
(values parent-dir (apply build-path v))))])
|
||||
(values parent-dir
|
||||
(if (null? v)
|
||||
'same
|
||||
(apply build-path v)))))
|
||||
(values parent-dir (apply build-path v)))))
|
||||
(values parent-dir (if (null? v) 'same (apply build-path v)))))
|
||||
|
||||
(define (unmztar p filter parent-dir get-dir shuffle? print-status)
|
||||
(define bufsize 4096)
|
||||
|
|
@ -76,7 +63,8 @@
|
|||
(let ([kind (read p)])
|
||||
(unless (eof-object? kind)
|
||||
(case kind
|
||||
[(dir) (let-values ([(target-dir s) (shuffle-path parent-dir get-dir shuffle? (read p))])
|
||||
[(dir) (let-values ([(target-dir s)
|
||||
(shuffle-path parent-dir get-dir shuffle? (read p))])
|
||||
(unless (or (eq? s 'same) (relative-path? s))
|
||||
(error "expected a directory name relative path string, got" s))
|
||||
(when (or (eq? s 'same) (filter 'dir s target-dir))
|
||||
|
|
@ -86,7 +74,8 @@
|
|||
(format " making directory ~a" (pretty-name d)))
|
||||
(make-directory* d)))))]
|
||||
[(file file-replace)
|
||||
(let-values ([(target-dir s) (shuffle-path parent-dir get-dir shuffle? (read p))])
|
||||
(let-values ([(target-dir s)
|
||||
(shuffle-path parent-dir get-dir shuffle? (read p))])
|
||||
(unless (relative-path? s)
|
||||
(error "expected a file name relative path string, got" s))
|
||||
(let ([len (read p)])
|
||||
|
|
@ -107,13 +96,11 @@
|
|||
;; Find starting *
|
||||
(let loop ()
|
||||
(let ([c (read-char p)])
|
||||
(cond
|
||||
[(char=? c #\*) (void)] ; found it
|
||||
(cond [(char=? c #\*) (void)] ; found it
|
||||
[(char-whitespace? c) (loop)]
|
||||
[(eof-object? c) (void)] ; signal the error below
|
||||
[else (error
|
||||
(format
|
||||
"unexpected character setting up ~a, looking for *"
|
||||
(format "unexpected character setting up ~a, looking for *"
|
||||
path)
|
||||
c)])))
|
||||
;; Copy file data
|
||||
|
|
@ -126,25 +113,25 @@
|
|||
(if out "unpacking" "skipping")
|
||||
path
|
||||
(- len n -1) len)))
|
||||
(when out
|
||||
(write-bytes buffer out 0 l))
|
||||
(when out (write-bytes buffer out 0 l))
|
||||
(loop (- n l)))))
|
||||
(when out
|
||||
(close-output-port out))))))]
|
||||
(when out (close-output-port out))))))]
|
||||
[else (error "unknown file tag" kind)])
|
||||
(loop)))))
|
||||
|
||||
(define (call-info info flag mk-default test)
|
||||
(if info
|
||||
(let ([v (info flag mk-default)])
|
||||
(test v)
|
||||
v)
|
||||
(let ([v (info flag mk-default)]) (test v) v)
|
||||
(mk-default)))
|
||||
|
||||
(define unpack
|
||||
(opt-lambda (archive [main-collects-parent-dir (current-directory)] [print-status (lambda (x) (printf "~a~n" x))]
|
||||
[get-target-directory (lambda () (current-directory))] [force? #f]
|
||||
[get-target-plt-directory (lambda (preferred main-collects-parent-dir options) preferred)])
|
||||
(opt-lambda (archive [main-collects-parent-dir (current-directory)]
|
||||
[print-status (lambda (x) (printf "~a\n" x))]
|
||||
[get-target-directory (lambda () (current-directory))]
|
||||
[force? #f]
|
||||
[get-target-plt-directory
|
||||
(lambda (preferred main-collects-parent-dir options)
|
||||
preferred)])
|
||||
(let*-values ([(p64gz) (open-input-file archive)]
|
||||
[(p kill) (port64gz->port p64gz)])
|
||||
(dynamic-wind
|
||||
|
|
@ -184,7 +171,8 @@
|
|||
(not (void? not-user-rel?))
|
||||
;; Non-user optional if test-dirs are writable
|
||||
(or (not test-dirs)
|
||||
(andmap (lambda (p)
|
||||
(andmap
|
||||
(lambda (p)
|
||||
(and (string? p)
|
||||
(let ([dir (let-values ([(base dir)
|
||||
(shuffle-path main-collects-parent-dir
|
||||
|
|
@ -228,8 +216,7 @@
|
|||
(if force?
|
||||
(print-status "warning: archive is for an older version of PLT Scheme")
|
||||
(error "cannot install; archive is for an older version of PLT Scheme")))
|
||||
(unless (or (list? l)
|
||||
(and force? (void? l)))
|
||||
(unless (or (list? l) (and force? (void? l)))
|
||||
(bad))
|
||||
;; Check each dependency:
|
||||
(when (list? l)
|
||||
|
|
@ -279,8 +266,7 @@
|
|||
(lambda (l)
|
||||
(define (bad)
|
||||
(error "`conflicts' info is corrupt:" l))
|
||||
(unless (or (list? l)
|
||||
(and force? (void? l)))
|
||||
(unless (or (list? l) (and force? (void? l)))
|
||||
(bad))
|
||||
(when (list? l)
|
||||
(for-each
|
||||
|
|
@ -297,8 +283,7 @@
|
|||
|
||||
(unless (and name unpacker)
|
||||
(error "bad name or unpacker"))
|
||||
(print-status
|
||||
(format "Unpacking ~a from ~a" name archive))
|
||||
(print-status (format "Unpacking ~a from ~a" name archive))
|
||||
(let ([u (eval (read p) n)])
|
||||
(unless (eval `(unit? ,u) n)
|
||||
(error "expected a unit, got" u))
|
||||
|
|
@ -314,8 +299,6 @@
|
|||
|
||||
;; Cancelled: no collections
|
||||
null))))
|
||||
(lambda ()
|
||||
(kill)
|
||||
(close-input-port p64gz))))))
|
||||
(lambda () (kill) (close-input-port p64gz))))))
|
||||
|
||||
(provide unpack))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user