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

some more style changes

Browse Source 
svn: r2976
This commit is contained in:
Eli Barzilay 2006-05-18 20:39:41 +00:00
parent 4a258cb9b3
commit 132ff42a1a
2 changed files with 247 additions and 269 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
collects/setup/pack.ss
View File

@ -4,7 +4,6 @@
(lib "base64.ss" "net") (lib "base64.ss" "net")
(lib "process.ss") (lib "process.ss")
(lib "list.ss") (lib "list.ss")
(lib "etc.ss")
(lib "port.ss") (lib "port.ss")
(lib "file.ss") (lib "file.ss")
(lib "kw.ss") (lib "kw.ss")
@ -18,16 +17,12 @@
pack-collections-plt) pack-collections-plt)
(define (x-arg-needs-true-arg who arg1-name v arg2-name) (define (x-arg-needs-true-arg who arg1-name v arg2-name)
(error who (error who (string-append "true value for `~a' argument: ~e "
(string-append
"true value for `~a' argument: ~e "
"requires a true value for `~a' argument") "requires a true value for `~a' argument")
arg1-name v arg1-name v arg2-name))
arg2-name))
(define pack (define/kw (pack dest name paths collections
(opt-lambda (dest name paths collections #:optional [filter std-filter]
[filter std-filter]
[encode? #t] [encode? #t]
[file-mode 'file] [file-mode 'file]
[unpack-unit #f] [unpack-unit #f]
@ -44,7 +39,7 @@
#:plt-relative? plt-relative? #:plt-relative? plt-relative?
#:requires null #:requires null
#:conflicts null #:conflicts null
#:at-plt-home? at-plt-home?))) #:at-plt-home? at-plt-home?))
(define/kw (pack-plt dest name paths (define/kw (pack-plt dest name paths
#:key [collections null] #:key [collections null]

87
collects/setup/unpack.ss
View File

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