From ce3e46b71a81c479bdefc3bb016d13a933d0ebd2 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Fri, 20 May 2011 09:58:40 -0500 Subject: [PATCH] fix a bug in the planet packaging code that could result in the documentation not being included --- collects/planet/planet.rkt | 2 +- collects/planet/util.rkt | 12 ++- collects/tests/planet/cmdline-tool.rkt | 106 +++++++++++++++++++++---- 3 files changed, 98 insertions(+), 22 deletions(-) diff --git a/collects/planet/planet.rkt b/collects/planet/planet.rkt index b0a9c837c0..466e3f2f0d 100644 --- a/collects/planet/planet.rkt +++ b/collects/planet/planet.rkt @@ -5,4 +5,4 @@ (lambda (e) ((error-display-handler) (exn-message e) e) (exit 1))]) - (start #f)) \ No newline at end of file + (void (start #f))) \ No newline at end of file diff --git a/collects/planet/util.rkt b/collects/planet/util.rkt index 36bb036648..2cf13e7705 100644 --- a/collects/planet/util.rkt +++ b/collects/planet/util.rkt @@ -418,15 +418,19 @@ (unless (or (null? critical-errors) (force-package-building?)) - (error '|PLaneT packager| "~a\nRefusing to continue packaging." (car critical-errors))) - + (raise-user-error '|PLaneT packager| "~a\nRefusing to continue packaging." (car critical-errors))) + (pack archive-name "archive" - (list ".") + (list ".") ;; if this changes, the filter (just below) must also change null (if (PLANET-ARCHIVE-FILTER) (regexp->filter (PLANET-ARCHIVE-FILTER)) - std-filter) + (λ (p) + (or (for/and ([always-in (list 'same (string->path "planet-docs"))] + [this-one (explode-path p)]) + (equal? always-in this-one)) + (std-filter p)))) #t 'file #f diff --git a/collects/tests/planet/cmdline-tool.rkt b/collects/tests/planet/cmdline-tool.rkt index 0edea77376..3fa30ffd44 100644 --- a/collects/tests/planet/cmdline-tool.rkt +++ b/collects/tests/planet/cmdline-tool.rkt @@ -1,4 +1,4 @@ -#lang scheme +#lang racket #| @@ -7,12 +7,12 @@ using 'system' to call out to the tool and then reading its results, etc. |# -(require scheme/system +(require racket/system planet/config net/url) (define planet-bin-path - (simplify-path (build-path (collection-path "scheme") 'up 'up "bin" "planet"))) + (simplify-path (build-path (collection-path "racket") 'up 'up "bin" "planet"))) (define test-connection-spec '("planet" "test-connection.plt" "1" "0")) (define test-connection.plt-cache @@ -81,16 +81,16 @@ using 'system' to call out to the tool and then reading its results, etc. ;; planet fetch vs planet url ;; -;; NB: this test leaves behind test-connection.plt, which other test rely on +;; NB: this test leaves behind test-connection.plt, which other tests rely on (define (fetch-vs-url) (define direct-file (format "direct-~a" (list-ref test-connection-spec 1))) - (define stupid-internal-definition-syntax1 - (begin (ensure-not-there direct-file) - (ensure-not-there (list-ref test-connection-spec 1)) - (printf "Downloading test-connection.plt (2 ways) ... ") - (flush-output))) + + (ensure-not-there direct-file) + (ensure-not-there (list-ref test-connection-spec 1)) + (printf "Downloading test-connection.plt (2 ways) ... ") + (flush-output) (define direct-download-thread (thread @@ -137,9 +137,8 @@ using 'system' to call out to the tool and then reading its results, etc. ;; (define (do-structure) - (define stupid-internal-definition-syntax0 - (begin (printf "Running open vs structure & print test ... ") - (flush-output))) + (printf "Running open vs structure & print test ... ") + (flush-output) (define structure-files (filter (λ (x) (not (equal? "" x))) @@ -147,11 +146,9 @@ using 'system' to call out to the tool and then reading its results, etc. (regexp-split #rx"\n" (call-planet "structure" (list-ref test-connection-spec 1))) string<=?))) (define tmp-dir "test-connection-contents") - (define stupid-internal-definition-syntax1 - (when (directory-exists? tmp-dir) - (error 'cmdline-tool.ss "expected the directory ~a to not exist" tmp-dir))) - (define stupid-internal-definition-syntax2 - (call-planet "open" (list-ref test-connection-spec 1) tmp-dir)) + (when (directory-exists? tmp-dir) + (error 'cmdline-tool.ss "expected the directory ~a to not exist" tmp-dir)) + (call-planet "open" (list-ref test-connection-spec 1) tmp-dir) (define open-files (sort (let f/d-loop ([f/d #f] [acc '()]) @@ -194,6 +191,80 @@ using 'system' to call out to the tool and then reading its results, etc. doc.txt-print doc.txt-fetch))) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; planet create +;; + +(define files + '(("info.rkt" + #<<-- +#lang setup/infotab + +(define name "the-name") +(define blurb + (list "the blurb")) +(define primary-file "main.rkt") +(define scribblings '(("doc.scrbl"))) +(define release-notes '("release notes")) +(define categories '(misc)) +(define repositories '("4.x")) +-- + ) + ("doc.scrbl" + #<<-- +#lang scribble/doc +@(require scribble/base) +@title{the docs} +-- + ) + ("main.rkt" "#lang racket\n(provide the-export)\n(define the-export 1)\n"))) + +(define (do-create) + (printf "Running create test ... ") + (flush-output) + (define tmp-root-dir (make-temporary-file "planet-cmdline-tool-test-create-~a" 'directory)) + (define tmp-dir (build-path tmp-root-dir "the-source")) + (define plt-file (build-path tmp-root-dir "the-source.plt")) + (make-directory tmp-dir) + (for ([f (in-list files)]) + (define file (list-ref f 0)) + (define contents (list-ref f 1)) + (call-with-output-file (build-path tmp-dir file) + (λ (port) (display contents port)))) + (define output (parameterize ([current-directory tmp-root-dir]) + (call-planet "create" (path->string tmp-dir)))) + (cond + [(or (regexp-match #rx"[Ee]rror" output) + (regexp-match #rx"Refusing" output) + (regexp-match #rx"=== context ===" output)) + (eprintf "error during planet create test:\n~a" output)] + [(regexp-match #rx"WARNING" output) + (eprintf "warning during planet create test:\n~a" output)] + [else + (define contents + (filter + (λ (x) (not (equal? x ""))) + (sort (regexp-split #rx"\n" (call-planet "structure" (path->string plt-file))) + string<=?))) + (unless (equal? contents + (list " index.html" + " scribble-common.js" + " scribble-style.css" + " scribble.css" + " doc:" + "doc.scrbl" + "info.rkt" + "main.rkt" + "planet-docs:")) + (eprintf "planet create test doesn't contain expected stuff; got:\n ~s\n" + contents))]) + + (delete-directory/files tmp-root-dir) + (printf "done\n")) + + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; util @@ -234,6 +305,7 @@ using 'system' to call out to the tool and then reading its results, etc. (do-remove) (do-fileinject) (do-structure) +(do-create) (delete-file (list-ref test-connection-spec 1)) (printf "Finished tests\n")