some more style changes
svn: r2976
This commit is contained in:
Eli Barzilay
parent
4a258cb9b3
commit
132ff42a1a
|
|
@ -4,47 +4,42 @@
|
||||||
(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")
|
||||||
(lib "getinfo.ss" "setup"))
|
(lib "getinfo.ss" "setup"))
|
||||||
|
|
||||||
(provide pack
|
(provide pack
|
||||||
pack-plt
|
pack-plt
|
||||||
mztar
|
mztar
|
||||||
std-filter
|
std-filter
|
||||||
pack-collections
|
pack-collections
|
||||||
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
|
(define/kw (pack dest name paths collections
|
||||||
arg2-name))
|
#:optional [filter std-filter]
|
||||||
|
[encode? #t]
|
||||||
(define pack
|
[file-mode 'file]
|
||||||
(opt-lambda (dest name paths collections
|
[unpack-unit #f]
|
||||||
[filter std-filter]
|
[plt-relative? #t]
|
||||||
[encode? #t]
|
[requires null]
|
||||||
[file-mode 'file]
|
[conflicts null]
|
||||||
[unpack-unit #f]
|
[at-plt-home? #f])
|
||||||
[plt-relative? #t]
|
(pack-plt dest name paths
|
||||||
[requires null]
|
#:collections collections
|
||||||
[conflicts null]
|
#:filter filter
|
||||||
[at-plt-home? #f])
|
#:encode? encode?
|
||||||
(pack-plt dest name paths
|
#:file-mode file-mode
|
||||||
#:collections collections
|
#:unpack-unit unpack-unit
|
||||||
#:filter filter
|
#:plt-relative? plt-relative?
|
||||||
#:encode? encode?
|
#:requires null
|
||||||
#:file-mode file-mode
|
#:conflicts null
|
||||||
#:unpack-unit unpack-unit
|
#:at-plt-home? at-plt-home?))
|
||||||
#:plt-relative? plt-relative?
|
|
||||||
#:requires null
|
|
||||||
#:conflicts null
|
|
||||||
#: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]
|
||||||
|
|
|
||||||
|
|
@ -15,59 +15,46 @@
|
||||||
(let-values ([(base64-out base64-in) (make-pipe 4096)]
|
(let-values ([(base64-out base64-in) (make-pipe 4096)]
|
||||||
[(guz-out guz-in) (make-pipe 4096)])
|
[(guz-out guz-in) (make-pipe 4096)])
|
||||||
(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:
|
|
||||||
(if (car target-dir-info)
|
|
||||||
|
|
||||||
;; Check declared dependencies (none means v103)
|
;; Stop if no target directory:
|
||||||
(begin
|
(if (car target-dir-info)
|
||||||
(call-info info 'requires (lambda () null)
|
|
||||||
(lambda (l)
|
|
||||||
(define (bad)
|
|
||||||
(error "`requires' info is corrupt:" l))
|
|
||||||
(when (void? l)
|
|
||||||
(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)))
|
|
||||||
(bad))
|
|
||||||
;; Check each dependency:
|
|
||||||
(when (list? l)
|
|
||||||
(for-each
|
|
||||||
(lambda (d)
|
|
||||||
(unless (and (list? d) (= 2 (length d)))
|
|
||||||
(bad))
|
|
||||||
(let ([coll-path (car d)]
|
|
||||||
[version (cadr d)])
|
|
||||||
(unless (and (pair? coll-path)
|
|
||||||
(list? coll-path)
|
|
||||||
(andmap string? coll-path)
|
|
||||||
(list? version)
|
|
||||||
(andmap number? version))
|
|
||||||
(bad))
|
|
||||||
(with-handlers ([exn:fail:filesystem?
|
|
||||||
(lambda (x)
|
|
||||||
(if force?
|
|
||||||
(print-status
|
|
||||||
(format "warning: missing required collection ~s" coll-path))
|
|
||||||
(error "cannot install; missing required collection" coll-path)))])
|
|
||||||
(apply collection-path coll-path))
|
|
||||||
(let ([inst-version
|
|
||||||
(with-handlers ([void (lambda (x)
|
|
||||||
(if (exn:break? x)
|
|
||||||
(raise x)
|
|
||||||
null))])
|
|
||||||
(let ([info (get-info coll-path)])
|
|
||||||
(info 'version (lambda () null))))])
|
|
||||||
(let loop ([v version][iv inst-version])
|
|
||||||
(unless (null? v)
|
|
||||||
(when (or (null? iv)
|
|
||||||
(not (= (car v) (car iv))))
|
|
||||||
(let ([msg (format "version ~a of collection ~s is required, but version ~a is installed"
|
|
||||||
version coll-path
|
|
||||||
(if (null? inst-version)
|
|
||||||
'<unknown>
|
|
||||||
inst-version))])
|
|
||||||
(if force?
|
|
||||||
(print-status (format "warning: ~a" msg))
|
|
||||||
(error (format "cannot install; ~a" msg)))))
|
|
||||||
(loop (cdr v) (cdr iv)))))))
|
|
||||||
l))))
|
|
||||||
|
|
||||||
;; Check for conflicts:
|
;; Check declared dependencies (none means v103)
|
||||||
(call-info info 'conflicts (lambda () null)
|
(begin
|
||||||
(lambda (l)
|
(call-info info 'requires (lambda () null)
|
||||||
(define (bad)
|
(lambda (l)
|
||||||
(error "`conflicts' info is corrupt:" l))
|
(define (bad)
|
||||||
(unless (or (list? l)
|
(error "`requires' info is corrupt:" l))
|
||||||
(and force? (void? l)))
|
(when (void? l)
|
||||||
(bad))
|
(if force?
|
||||||
(when (list? l)
|
(print-status "warning: archive is for an older version of PLT Scheme")
|
||||||
(for-each
|
(error "cannot install; archive is for an older version of PLT Scheme")))
|
||||||
(lambda (coll-path)
|
(unless (or (list? l) (and force? (void? l)))
|
||||||
(unless (and (pair? coll-path)
|
(bad))
|
||||||
(list? coll-path)
|
;; Check each dependency:
|
||||||
(andmap string? coll-path))
|
(when (list? l)
|
||||||
(bad))
|
(for-each
|
||||||
(when (with-handlers ([exn:fail? (lambda (x) #f)])
|
(lambda (d)
|
||||||
(apply collection-path coll-path))
|
(unless (and (list? d) (= 2 (length d)))
|
||||||
(error "cannot install; conflict with installed collection"
|
(bad))
|
||||||
coll-path)))
|
(let ([coll-path (car d)]
|
||||||
l))))
|
[version (cadr d)])
|
||||||
|
(unless (and (pair? coll-path)
|
||||||
|
(list? coll-path)
|
||||||
|
(andmap string? coll-path)
|
||||||
|
(list? version)
|
||||||
|
(andmap number? version))
|
||||||
|
(bad))
|
||||||
|
(with-handlers ([exn:fail:filesystem?
|
||||||
|
(lambda (x)
|
||||||
|
(if force?
|
||||||
|
(print-status
|
||||||
|
(format "warning: missing required collection ~s" coll-path))
|
||||||
|
(error "cannot install; missing required collection" coll-path)))])
|
||||||
|
(apply collection-path coll-path))
|
||||||
|
(let ([inst-version
|
||||||
|
(with-handlers ([void (lambda (x)
|
||||||
|
(if (exn:break? x)
|
||||||
|
(raise x)
|
||||||
|
null))])
|
||||||
|
(let ([info (get-info coll-path)])
|
||||||
|
(info 'version (lambda () null))))])
|
||||||
|
(let loop ([v version][iv inst-version])
|
||||||
|
(unless (null? v)
|
||||||
|
(when (or (null? iv)
|
||||||
|
(not (= (car v) (car iv))))
|
||||||
|
(let ([msg (format "version ~a of collection ~s is required, but version ~a is installed"
|
||||||
|
version coll-path
|
||||||
|
(if (null? inst-version)
|
||||||
|
'<unknown>
|
||||||
|
inst-version))])
|
||||||
|
(if force?
|
||||||
|
(print-status (format "warning: ~a" msg))
|
||||||
|
(error (format "cannot install; ~a" msg)))))
|
||||||
|
(loop (cdr v) (cdr iv)))))))
|
||||||
|
l))))
|
||||||
|
|
||||||
(unless (and name unpacker)
|
;; Check for conflicts:
|
||||||
(error "bad name or unpacker"))
|
(call-info info 'conflicts (lambda () null)
|
||||||
(print-status
|
(lambda (l)
|
||||||
(format "Unpacking ~a from ~a" name archive))
|
(define (bad)
|
||||||
(let ([u (eval (read p) n)])
|
(error "`conflicts' info is corrupt:" l))
|
||||||
(unless (eval `(unit? ,u) n)
|
(unless (or (list? l) (and force? (void? l)))
|
||||||
(error "expected a unit, got" u))
|
(bad))
|
||||||
(make-directory* (car target-dir-info))
|
(when (list? l)
|
||||||
(let ([unmztar (lambda (filter)
|
(for-each
|
||||||
(unmztar p filter
|
(lambda (coll-path)
|
||||||
(car target-dir-info)
|
(unless (and (pair? coll-path)
|
||||||
(lambda (a b)
|
(list? coll-path)
|
||||||
((cadr target-dir-info) a b))
|
(andmap string? coll-path))
|
||||||
((length target-dir-info) . > . 1)
|
(bad))
|
||||||
print-status))])
|
(when (with-handlers ([exn:fail? (lambda (x) #f)])
|
||||||
(eval `(invoke-unit ,u ,(car target-dir-info) ,unmztar) n))))
|
(apply collection-path coll-path))
|
||||||
|
(error "cannot install; conflict with installed collection"
|
||||||
|
coll-path)))
|
||||||
|
l))))
|
||||||
|
|
||||||
;; Cancelled: no collections
|
(unless (and name unpacker)
|
||||||
null))))
|
(error "bad name or unpacker"))
|
||||||
(lambda ()
|
(print-status (format "Unpacking ~a from ~a" name archive))
|
||||||
(kill)
|
(let ([u (eval (read p) n)])
|
||||||
(close-input-port p64gz))))))
|
(unless (eval `(unit? ,u) n)
|
||||||
|
(error "expected a unit, got" u))
|
||||||
|
(make-directory* (car target-dir-info))
|
||||||
|
(let ([unmztar (lambda (filter)
|
||||||
|
(unmztar p filter
|
||||||
|
(car target-dir-info)
|
||||||
|
(lambda (a b)
|
||||||
|
((cadr target-dir-info) a b))
|
||||||
|
((length target-dir-info) . > . 1)
|
||||||
|
print-status))])
|
||||||
|
(eval `(invoke-unit ,u ,(car target-dir-info) ,unmztar) n))))
|
||||||
|
|
||||||
|
;; Cancelled: no collections
|
||||||
|
null))))
|
||||||
|
(lambda () (kill) (close-input-port p64gz))))))
|
||||||
|
|
||||||
(provide unpack))
|
(provide unpack))
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue
Block a user