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

setup/pack: fix internal and contract errors

Browse Source 
Part of the contract-error fix is an implementation change, and part
is a documentation change.

Closes PR 12904
This commit is contained in:
Matthew Flatt 2012-08-08 14:26:33 -06:00
parent 5f120373f1
commit 9d6cb8e50e
3 changed files with 100 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

53
collects/scribblings/raco/unpack.scrbl
View File

@ -2,7 +2,8 @@
@(require scribble/manual
"common.rkt"
(for-label racket/base
setup/unpack))
setup/unpack
setup/dirs))
@title[#:tag "unpack"]{@exec{raco unpack}: Unpacking Library Collections}
@ -76,9 +77,23 @@ while the second will refer to the main installation.}
@defproc[(fold-plt-archive [archive path-string?]
[on-config-fn (any/c any/c . -> . any/c)]
[on-setup-unit (any/c input-port? any/c . -> . any/c)]
[on-directory (path-string? any/c . -> . any/c)]
[on-file (or/c (path-string? input-port? any/c . -> . any/c)
(path-string? input-port? (one-of/c 'file 'file-replace) any/c
[on-directory ((or/c path-string?
(list/c (or/c 'collects 'doc 'lib 'include)
path-string?))
any/c
. -> . any/c)]
[on-file (or/c ((or/c path-string?
(list/c (or/c 'collects 'doc 'lib 'include)
path-string?))
input-port?
any/c
. -> . any/c)
((or/c path-string?
(list/c (or/c 'collects 'doc 'lib 'include)
path-string?))
input-port?
(one-of/c 'file 'file-replace)
any/c
. -> . any/c))]
[initial-value any/c])
any/c]{
@ -109,15 +124,25 @@ not checked by anything, and therefore could cause an error.)
The result of @racket[on-setup-unit] becomes the new accumulated value.
For each directory that would be created by the archive when unpacking
normally, @racket[on-directory] is called with the directory path and the
accumulated value up to that point, and its result is the new
accumulated value.
normally, @racket[on-directory] is called with the directory
path (described more below) and the accumulated value up to that
point, and its result is the new accumulated value.
For each file that would be created by the archive when unpacking
normally, @racket[on-file] is called with the file path, an input port
containing the contents of the file, an optional mode symbol indicating
whether the file should be replaced, and the accumulated value up to
that point; its result is the new accumulated value. The input port
can be used or ignored, and parsing of the rest of the file continues
the same either way. After @racket[on-file] returns control, however,
the input port is drained of its content.}
normally, @racket[on-file] is called with the file path (described
more below), an input port containing the contents of the file, an
optional mode symbol indicating whether the file should be replaced,
and the accumulated value up to that point; its result is the new
accumulated value. The input port can be used or ignored, and parsing
of the rest of the file continues the same either way. After
@racket[on-file] returns control, however, the input port is drained
of its content.
A directory or file path can be a plain path, or it can be a list
containing @racket['collects], @racket['doc], @racket['lib], or
@racket['include] and a relative path. The latter case corresponds to
a directory or file relative to a target installation's collection
directory (in the sense of @racket[find-collects-dir]), documentation
directory (in the sense of @racket[find-doc-dir]), library
directory (in the sense of @racket[find-lib-dir]), or ``include''
directory (in the sense of @racket[find-include-dir]).}

5
collects/setup/unpack.rkt
View File

@ -114,7 +114,7 @@
(cond
[(null? v) 'same]
[(and (pair? v) (symbol? (car v)) (symbol=? (car v) 'same))
(list 'same (apply build-path 'same (cdr v)))]
(apply build-path 'same (cdr v))]
[(and (pair? v) (string? (car v)))
(let ([location (string->loc (car v))])
(if (eq? location 'relative)
@ -198,7 +198,8 @@
(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))
(when (and target-dir
(or (eq? s 'same) (filter 'dir s target-dir)))
(let ([d (build-path target-dir s)])
(unless (directory-exists? d)
(print-status

58
collects/tests/racket/pack.rktl
View File

@ -100,4 +100,62 @@
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(let ()
(define tmp-src-dir
(make-temporary-file "example~a" 'directory))
(write-to-file 0 (build-path tmp-src-dir "foo"))
(write-to-file 1 (build-path tmp-src-dir "bar"))
(make-directory (build-path tmp-src-dir "zog"))
(write-to-file 2 (build-path tmp-src-dir "zog" "zip"))
;; The structure is...
;; root
;; + foo => 0
;; + bar => 1
;; - zog
;; + zip => 2
;; Turn it into a .plt archive
(define tmp-plt
(make-temporary-file "example~a.plt"))
(pack-plt tmp-plt "example" (list tmp-src-dir)
#:as-paths (list "."))
;; Now unpack it
(define tmp-dest-dir
(make-temporary-file "example~a" 'directory))
;; This errors because #f is given to build-path, because target-dir
;; is bound to #f at some point, because of the (values #f 'same) is
;; the result when v is just '(same) to shuffle-path
(parameterize ([current-directory tmp-dest-dir])
(unpack tmp-plt (current-directory) void))
(fold-plt-archive
tmp-plt
void
void
(λ (dir _)
;; Each of these fails because the values are actually `(same
;; ,path), despite the contract claiming to give path-string?
;; values (same with below)
;;
;; The code calls expr->path-descriptor which returns this and
;; another list'd value
;;
;; The only use of fold-plt-archive in the tree, planet/util,
;; works around this by just pulling out the path component or
;; erroring.
(test #t path-string? dir))
(λ (file content-p _1 [_2 #f])
(test #t path-string? file))
#f)
(delete-directory/files tmp-plt)
(delete-directory/files tmp-dest-dir))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(report-errs)