diff --git a/collects/scribblings/raco/unpack.scrbl b/collects/scribblings/raco/unpack.scrbl index 23da1a5865..5338a3a272 100644 --- a/collects/scribblings/raco/unpack.scrbl +++ b/collects/scribblings/raco/unpack.scrbl @@ -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]).} diff --git a/collects/setup/unpack.rkt b/collects/setup/unpack.rkt index 5120182228..290b9f97c8 100644 --- a/collects/setup/unpack.rkt +++ b/collects/setup/unpack.rkt @@ -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 diff --git a/collects/tests/racket/pack.rktl b/collects/tests/racket/pack.rktl index f1691cf831..a32c8cdad1 100644 --- a/collects/tests/racket/pack.rktl +++ b/collects/tests/racket/pack.rktl @@ -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)