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

49
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,33 +17,29 @@
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 "requires a true value for `~a' argument")
"true value for `~a' argument: ~e " arg1-name v arg2-name))
"requires a true value for `~a' argument")
arg1-name v
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] [plt-relative? #t]
[plt-relative? #t] [requires null]
[requires null] [conflicts null]
[conflicts null] [at-plt-home? #f])
[at-plt-home? #f]) (pack-plt dest name paths
(pack-plt dest name paths #:collections collections
#:collections collections #:filter filter
#:filter filter #:encode? encode?
#:encode? encode? #:file-mode file-mode
#:file-mode file-mode #:unpack-unit unpack-unit
#:unpack-unit unpack-unit #: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]

447
collects/setup/unpack.ss
View File

@ -17,57 +17,44 @@
(let ([64t (let ([64t
(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 (get-dir find-collects-dir find-user-collects-dir)]
(cond [(string=? (car v) "doc")
[(string=? (car v) "collects") (get-dir find-doc-dir find-user-doc-dir)]
(get-dir find-collects-dir find-user-collects-dir)] [(string=? (car v) "lib")
[(string=? (car v) "doc") (get-dir find-lib-dir find-user-lib-dir)]
(get-dir find-doc-dir find-user-doc-dir)] [(string=? (car v) "include")
[(string=? (car v) "lib") (get-dir find-include-dir find-user-include-dir)]
(get-dir find-lib-dir find-user-lib-dir)] [else #f])])
[(string=? (car v) "include") (if dir
(get-dir find-include-dir find-user-include-dir)] (if (null? (cdr v))
[else #f])]) (values dir 'same)
(if dir (values dir (apply build-path (cdr v))))
(if (null? (cdr v)) (values parent-dir (apply build-path v)))))
(values dir 'same) (values parent-dir (if (null? v) 'same (apply build-path v)))))
(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)))))
(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,17 +63,19 @@
(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))
(let ([d (build-path target-dir s)]) (let ([d (build-path target-dir s)])
(unless (directory-exists? d) (unless (directory-exists? d)
(print-status (print-status
(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)])
@ -96,10 +85,10 @@
[path (build-path target-dir s)]) [path (build-path target-dir s)])
(let ([out (and write? (let ([out (and write?
(if (file-exists? path) (if (file-exists? path)
(if (eq? kind 'file) (if (eq? kind 'file)
#f #f
(open-output-file path 'truncate)) (open-output-file path 'truncate))
(open-output-file path)))]) (open-output-file path)))])
(when (and write? (not out)) (when (and write? (not out))
(print-status (format " skipping ~a; already exists" (pretty-name path)))) (print-status (format " skipping ~a; already exists" (pretty-name path))))
(when out (when out
@ -107,15 +96,13 @@
;; 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 "unexpected character setting up ~a, looking for *"
(format path)
"unexpected character setting up ~a, looking for *" c)])))
path)
c)])))
;; Copy file data ;; Copy file data
(let loop ([n len]) (let loop ([n len])
(unless (zero? n) (unless (zero? n)
@ -126,196 +113,192 @@
(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) (mk-default)))
v)
(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
void void
(lambda () (lambda ()
(unless (and (eq? #\P (read-char p)) (unless (and (eq? #\P (read-char p))
(eq? #\L (read-char p)) (eq? #\L (read-char p))
(eq? #\T (read-char p))) (eq? #\T (read-char p)))
(error "not an unpackable distribution archive")) (error "not an unpackable distribution archive"))
(let* ([n (make-namespace)] (let* ([n (make-namespace)]
[info (let ([orig (current-namespace)]) [info (let ([orig (current-namespace)])
(parameterize ([current-namespace n]) (parameterize ([current-namespace n])
(namespace-require '(lib "unit.ss")) (namespace-require '(lib "unit.ss"))
(eval (read p))))]) (eval (read p))))])
(unless (and (procedure? info) (unless (and (procedure? info)
(procedure-arity-includes? info 2)) (procedure-arity-includes? info 2))
(error "expected a procedure of arity 2, got" info)) (error "expected a procedure of arity 2, got" info))
(let ([name (call-info info 'name (lambda () #f) (let ([name (call-info info 'name (lambda () #f)
(lambda (n) (lambda (n)
(unless (string? n) (unless (string? n)
(if n (if n
(error "couldn't find the package name") (error "couldn't find the package name")
(error "expected a string")))))] (error "expected a string")))))]
[unpacker (call-info info 'unpacker (lambda () #f) [unpacker (call-info info 'unpacker (lambda () #f)
(lambda (n) (lambda (n)
(unless (eq? n 'mzscheme) (unless (eq? n 'mzscheme)
(error "unpacker isn't mzscheme:" n))))] (error "unpacker isn't mzscheme:" n))))]
[target-dir-info [target-dir-info
(let ([rel? (call-info info 'plt-relative? (lambda () #f) values)] (let ([rel? (call-info info 'plt-relative? (lambda () #f) values)]
[not-user-rel? (call-info info 'plt-home-relative? (lambda () #f) values)] [not-user-rel? (call-info info 'plt-home-relative? (lambda () #f) values)]
[test-dirs (call-info info 'test-plt-dirs (lambda () #f) values)]) [test-dirs (call-info info 'test-plt-dirs (lambda () #f) values)])
(if rel? (if rel?
;; Shuffling... ;; Shuffling...
(if (and not-user-rel? (if (and not-user-rel?
;; Check for void because old unpacker didn't use ;; Check for void because old unpacker didn't use
;; the failure thunk. ;; the failure thunk.
(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
(and (string? p) (lambda (p)
(let ([dir (let-values ([(base dir) (and (string? p)
(shuffle-path main-collects-parent-dir (let ([dir (let-values ([(base dir)
(lambda (a b) (a)) (shuffle-path main-collects-parent-dir
#t (list p))]) (lambda (a b) (a))
(build-path base dir))]) #t (list p))])
(memq 'write (build-path base dir))])
(with-handlers ([exn:fail:filesystem? (lambda (x) null)]) (memq 'write
(file-or-directory-permissions dir)))))) (with-handlers ([exn:fail:filesystem? (lambda (x) null)])
test-dirs))) (file-or-directory-permissions dir))))))
;; Shuffle to main directory always: test-dirs)))
(let ([dir (get-target-plt-directory main-collects-parent-dir ;; Shuffle to main directory always:
main-collects-parent-dir (let ([dir (get-target-plt-directory main-collects-parent-dir
(list main-collects-parent-dir))]) main-collects-parent-dir
(list dir (lambda (sys user) (list main-collects-parent-dir))])
(let ([a (sys)]) (list dir (lambda (sys user)
(get-target-plt-directory a a (list a)))))) (let ([a (sys)])
;; Prefer to shuffle to user directory: (get-target-plt-directory a a (list a))))))
(let ([addons (find-user-collects-dir)]) ;; Prefer to shuffle to user directory:
(let ([dir (get-target-plt-directory (let ([addons (find-user-collects-dir)])
addons (let ([dir (get-target-plt-directory
main-collects-parent-dir addons
(list addons main-collects-parent-dir))]) main-collects-parent-dir
(list dir (lambda (sys user) (list addons main-collects-parent-dir))])
(let ([a (sys)] (list dir (lambda (sys user)
[b (user)]) (let ([a (sys)]
(get-target-plt-directory b a (list b a)))))))) [b (user)])
;; No shuffling --- install to target directory: (get-target-plt-directory b a (list b a))))))))
(list (get-target-directory))))]) ;; No shuffling --- install to target directory:
(list (get-target-directory))))])
;; Stop if no target directory: ;; Stop if no target directory:
(if (car target-dir-info) (if (car target-dir-info)
;; Check declared dependencies (none means v103) ;; Check declared dependencies (none means v103)
(begin (begin
(call-info info 'requires (lambda () null) (call-info info 'requires (lambda () null)
(lambda (l) (lambda (l)
(define (bad) (define (bad)
(error "`requires' info is corrupt:" l)) (error "`requires' info is corrupt:" l))
(when (void? l) (when (void? l)
(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) (for-each
(for-each (lambda (d)
(lambda (d) (unless (and (list? d) (= 2 (length d)))
(unless (and (list? d) (= 2 (length d))) (bad))
(bad)) (let ([coll-path (car d)]
(let ([coll-path (car d)] [version (cadr d)])
[version (cadr d)]) (unless (and (pair? coll-path)
(unless (and (pair? coll-path) (list? coll-path)
(list? coll-path) (andmap string? coll-path)
(andmap string? coll-path) (list? version)
(list? version) (andmap number? version))
(andmap number? version)) (bad))
(bad)) (with-handlers ([exn:fail:filesystem?
(with-handlers ([exn:fail:filesystem? (lambda (x)
(lambda (x) (if force?
(if force? (print-status
(print-status (format "warning: missing required collection ~s" coll-path))
(format "warning: missing required collection ~s" coll-path)) (error "cannot install; missing required collection" coll-path)))])
(error "cannot install; missing required collection" coll-path)))]) (apply collection-path coll-path))
(apply collection-path coll-path)) (let ([inst-version
(let ([inst-version (with-handlers ([void (lambda (x)
(with-handlers ([void (lambda (x) (if (exn:break? x)
(if (exn:break? x) (raise x)
(raise x) null))])
null))]) (let ([info (get-info coll-path)])
(let ([info (get-info coll-path)]) (info 'version (lambda () null))))])
(info 'version (lambda () null))))]) (let loop ([v version][iv inst-version])
(let loop ([v version][iv inst-version]) (unless (null? v)
(unless (null? v) (when (or (null? iv)
(when (or (null? iv) (not (= (car v) (car iv))))
(not (= (car v) (car iv)))) (let ([msg (format "version ~a of collection ~s is required, but version ~a is installed"
(let ([msg (format "version ~a of collection ~s is required, but version ~a is installed" version coll-path
version coll-path (if (null? inst-version)
(if (null? inst-version) '<unknown>
'<unknown> inst-version))])
inst-version))]) (if force?
(if force? (print-status (format "warning: ~a" msg))
(print-status (format "warning: ~a" msg)) (error (format "cannot install; ~a" msg)))))
(error (format "cannot install; ~a" msg))))) (loop (cdr v) (cdr iv)))))))
(loop (cdr v) (cdr iv))))))) l))))
l))))
;; Check for conflicts: ;; Check for conflicts:
(call-info info 'conflicts (lambda () null) (call-info info 'conflicts (lambda () null)
(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 (lambda (coll-path)
(lambda (coll-path) (unless (and (pair? coll-path)
(unless (and (pair? coll-path) (list? coll-path)
(list? coll-path) (andmap string? coll-path))
(andmap string? coll-path)) (bad))
(bad)) (when (with-handlers ([exn:fail? (lambda (x) #f)])
(when (with-handlers ([exn:fail? (lambda (x) #f)]) (apply collection-path coll-path))
(apply collection-path coll-path)) (error "cannot install; conflict with installed collection"
(error "cannot install; conflict with installed collection" coll-path)))
coll-path))) l))))
l))))
(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)) (make-directory* (car target-dir-info))
(make-directory* (car target-dir-info)) (let ([unmztar (lambda (filter)
(let ([unmztar (lambda (filter) (unmztar p filter
(unmztar p filter (car target-dir-info)
(car target-dir-info) (lambda (a b)
(lambda (a b) ((cadr target-dir-info) a b))
((cadr target-dir-info) a b)) ((length target-dir-info) . > . 1)
((length target-dir-info) . > . 1) print-status))])
print-status))]) (eval `(invoke-unit ,u ,(car target-dir-info) ,unmztar) n))))
(eval `(invoke-unit ,u ,(car target-dir-info) ,unmztar) n))))
;; Cancelled: no collections ;; Cancelled: no collections
null)))) null))))
(lambda () (lambda () (kill) (close-input-port p64gz))))))
(kill)
(close-input-port p64gz))))))
(provide unpack)) (provide unpack))