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

raco pkg create --binary: strip ".dep" files, ertain submodules, ~ files

Browse Source
This commit is contained in:
Matthew Flatt 2013-05-21 18:26:15 -06:00
parent 6178f2312f
commit 4603315474
6 changed files with 79 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
collects/pkg/scribblings/pkg.scrbl
View File

@ -385,7 +385,8 @@ removing any of the @nonterm{pkg}s.
@item{@DFlag{source} --- Bundle only sources in the package directory, pruning (by default)
@filepath{compiled} directories (that normally hold compiled
bytecode), @filepath{doc} directories (that normally hold rendered documentation),
directories named @filepath{.svn}, and directories and files whose names start with @filepath{.git}.
directories named @filepath{.svn}, directories and files whose names start with @filepath{.git},
and files whose name ends with @litchar{~} or starts and ends with @litchar{#}.
Override the default pruning rules with @racket[source-omit-files] and/or
@racket[source-keep-files] definitions in @filepath{info.rkt} files within the
package directory.}
@ -393,9 +394,12 @@ removing any of the @nonterm{pkg}s.
documentation in the package directory. Normally, this option is sensible for
a package that is installed from source in a user-specific scope. Bundling prunes (by default)
@filepath{.rkt} and @filepath{.ss} files for which compiled bytecode is present, files with
a @filepath{.scrbl} suffix, @filepath{tests} directories, @filepath{scribblings}
directories, @filepath{.svn} directories, and directories and files whose names
start with @filepath{.git}. For each @filepath{.html} file that
a @filepath{.scrbl} suffix and their compiled files, files with a @filepath{.dep} suffix,
@filepath{tests} directories, @filepath{scribblings}
directories, @filepath{.svn} directories, directories and files whose names
start with @filepath{.git}, and files whose name ends with @litchar{~} or starts and ends
with @litchar{#}. For each @filepath{.zo} file, submodules named @racketidfont{test},
@racketidfont{doc}, or @racketidfont{srcdoc} are removed. For each @filepath{.html} file that
refers to a @filepath{local-redirect.js} script, the path to the script is removed.
In addition, bundling updates any @filepath{info.rkt} as follows: it
adds a @racket[assume-virtual-sources] entry,

63
collects/pkg/strip.rkt
View File

@ -3,7 +3,8 @@
setup/getinfo
syntax/modread
racket/match
racket/file)
racket/file
racket/list)
(provide generate-stripped-directory
fixup-local-redirect-reference)
@ -41,10 +42,10 @@
(define (drop-by-default? path get-p)
(define bstr (path->bytes path))
(or (regexp-match? #rx#"^(?:[.]git.*|[.]svn)$"
(or (regexp-match? #rx#"^(?:[.]git.*|[.]svn|.*~|#.*#)$"
bstr)
(regexp-match? (if binary?
#rx#"^(?:[.]git.*|[.]svn|tests|scribblings|.*[.]scrbl)$"
#rx#"^(?:tests|scribblings|.*(?:[.]scrbl|[.]dep|_scrbl[.]zo))$"
#rx#"^(?:compiled|doc)$")
bstr)
(and binary?
@ -53,17 +54,21 @@
(file-exists? (let-values ([(base name dir?) (split-path (get-p))])
(build-path base "compiled" (path-add-suffix name #".zo")))))
(and binary?
(or (equal? #"info_rkt.zo" bstr)
(equal? #"info_rkt.dep" bstr)))))
;; drop these, because they're recreated on fixup:
(or
(equal? #"info_rkt.zo" bstr)
(equal? #"info_rkt.dep" bstr)))))
(define (fixup new-p path)
(define (fixup new-p path src-base)
(when binary?
(define bstr (path->bytes path))
(cond
[(regexp-match? #rx"[.]html$" bstr)
(fixup-html new-p)]
[(equal? #"info.rkt" bstr)
(fixup-info new-p)]
(fixup-info new-p src-base)]
[(regexp-match? #rx"[.]zo$" bstr)
(fixup-zo new-p)]
[else (void)])))
(define (explore base paths drops keeps)
@ -81,7 +86,7 @@
(cond
[(file-exists? old-p)
(copy-file old-p new-p)
(fixup new-p path)]
(fixup new-p path base)]
[(directory-exists? old-p)
(define-values (new-drops new-keeps)
(add-drop+keeps old-p p drops keeps))
@ -101,6 +106,40 @@
;; strip full path to "local-redirect.js"
(fixup-local-redirect-reference new-p ".."))
(define (fixup-zo new-p)
;; strip `test', `srcdoc', and `doc' submodules:
(define mod
(call-with-input-file*
new-p
(lambda (in)
(parameterize ([read-accept-compiled #t])
(read in)))))
(define (filter-mods l)
(filter (lambda (m)
(not (memq (last (module-compiled-name m))
'(test doc srcdoc))))
l))
(define new-mod
(let loop ([mod mod])
(define mod-subs (module-compiled-submodules mod #f))
(define mod*-subs (module-compiled-submodules mod #t))
(define new-mod-subs (map loop (filter-mods mod-subs)))
(define new-mod*-subs (map loop (filter-mods mod*-subs)))
(if (and (equal? mod-subs new-mod-subs)
(equal? mod*-subs new-mod*-subs))
mod
(module-compiled-submodules
(module-compiled-submodules mod
#f
mod-subs)
#t
mod*-subs))))
(unless (eq? mod new-mod)
(call-with-output-file*
new-p
#:exists 'truncate/replace
(lambda (out) (write new-mod out)))))
(define (fixup-local-redirect-reference p js-path)
;; Relying on this HTML pattern (as generated by Scribble's HTML
;; renderer) is a little fragile. Any better idea?
@ -121,7 +160,7 @@
#:exists 'truncate/replace
(lambda (out) (write-bytes new-bstr out)))))
(define (fixup-info new-p)
(define (fixup-info new-p src-base)
(define dir (let-values ([(base name dir?) (split-path new-p)])
base))
;; check format:
@ -155,9 +194,9 @@
;; sanity check:
(unless (get-info/full dir #:namespace (make-base-namespace))
(error 'pkg-binary-create "rewrite failed"))
;; compile it:
(managed-compile-zo new-p)))
;; compile it, if not top level:
(unless (eq? src-base 'same)
(managed-compile-zo new-p))))
(define ((fixup-info-definition get-info) defn)
(match defn

6
collects/tests/pkg/test-pkgs/pkg-x/x/main.rkt
View File

@ -5,3 +5,9 @@
(define (x)
(if (eq? (z) 'z) 'x 'ouch))
(module+ test
(require y)
(provide y-test)
(define (y-test)
(if (eq? (y) 'y) 'y 'ouch)))

2
collects/tests/pkg/test-pkgs/pkg-y/y/main.rkt
View File

@ -3,4 +3,4 @@
(provide y)
(define (y)
(if (zero? (random 1)) 'y 'ouch))
(if (zero? (random 1)) 'y 'ouch))

5
collects/tests/pkg/test-pkgs/pkg-y/y/other.rkt Normal file
View File

@ -0,0 +1,5 @@
#lang racket/base
(module doc scribble/doclang2
(require x)
(symbol->string (x)))

9
collects/tests/pkg/tests-binary.rkt
View File

@ -22,6 +22,9 @@
$ "racket -l racket/base -l x -e '(x)'" =stdout> "'x\n"
$ "racket -l racket/base -l y -e '(y)'" =stdout> "'y\n"
$ "racket -l racket/base -e '(require (submod x test))'"
$ "racket -l racket/base -e '(require (submod y/other doc))'"
$ "racket -l racket/base -t test-docs.rkt -e '(test-docs-x #t)'"
$ "racket -l racket/base -t test-docs.rkt -e '(test-docs-y #t)'"
@ -81,7 +84,8 @@
(parameterize ([current-directory d])
(unzip z)
(for ([f (in-directory)])
(when (or (regexp-match? #rx#"[.](?:rkt|scrbl)$" (path->bytes f))
(when (or (and (regexp-match? #rx#"(?:[.](?:rkt|scrbl|dep)|_scrbl[.]zo)$" (path->bytes f))
(not (regexp-match? #rx#"(?:info_rkt[.]dep)$" (path->bytes f))))
(regexp-match? #rx#"nobin" (path->bytes f)))
(unless (regexp-match? #rx#"(?:info[.]rkt|keep.scrbl)$" (path->bytes f))
(error 'binary "extra ~s" f)))))))
@ -115,6 +119,9 @@
$ "racket -l racket/base -t test-docs.rkt -e '(test-docs-x #f)'"
$ "racket -l racket/base -t test-docs.rkt -e '(test-docs-y #t)'"
$ "racket -l racket/base -e '(require (submod x test))'" =exit> 1
$ "racket -l racket/base -e '(require (submod y/other doc))'" =exit> 1
(shelly-case
"check that cleaning doesn't destroy a binary install"
$ "racket -l y"