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

fixes for binary-package stripping

Browse Source 
Avoid duplicate `assume-virtual-sources` definitions, add
`assume-virtual-sources` as needed in top-level collections
within a package.
This commit is contained in:
Matthew Flatt 2013-09-17 12:41:19 -06:00
parent 007f7d5992
commit b2f76bd8cc
4 changed files with 78 additions and 19 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
pkgs/racket-pkgs/racket-test/tests/pkg/test-docs.rkt
View File

@ -20,7 +20,7 @@
(call-with-input-file*
p
(lambda (in)
(define m (regexp-match #rx"<script [^>]*src=\"([^\"]*)local-redirect.js\"[^>]*>" in))
(define m (regexp-match #rx"<script [^>]*src=\"(?:file://)?([^\"]*)local-redirect.js\"[^>]*>" in))
(define ref (url->path
(string->url
(bytes->string/utf-8

2
pkgs/racket-pkgs/racket-test/tests/pkg/test-pkgs/pkg-y/y/info.rkt
View File

@ -1,3 +1,5 @@
#lang info
(define scribblings '(("y.scrbl")))
(define assume-virtual-sources #f)

35
pkgs/racket-pkgs/racket-test/tests/pkg/tests-binary.rkt
View File

@ -26,8 +26,8 @@
$ "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)'"
$ "racket -l racket/base -t test-docs.rkt -e '(test-docs-x #t)'" =stderr> ""
$ "racket -l racket/base -t test-docs.rkt -e '(test-docs-y #t)'" =stderr> ""
(make-directory* "test-pkgs/src-pkgs")
(make-directory* "test-pkgs/built-pkgs")
@ -47,8 +47,8 @@
$ "raco pkg remove pkg-x pkg-y pkg-z"
(putenv "PLT_PKG_NOSETUP" "1")
$ "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 #f)'"
$ "racket -l racket/base -t test-docs.rkt -e '(test-docs-x #f)'" =stderr> ""
$ "racket -l racket/base -t test-docs.rkt -e '(test-docs-y #f)'" =stderr> ""
(define tmp-dir (make-temporary-file "unpack-~a" 'directory))
@ -146,10 +146,27 @@
(unless (file-exists? (build-path td f))
(error 'built "missing source ~s" f)))))
(parameterize ([current-directory bd])
(define (extra-info? p)
;; A binary package can have extra "info.rkt" files in collections
;; to set `assume-virtual-sources` to #t.
(let-values ([(base name dir?) (split-path p)])
(define s (path->string name))
(and (or (equal? "info.rkt" s)
(equal? "info_rkt.zo" s)
(equal? "info_rkt.dep" s))
(or (eq? base 'relative)
(and (path? base)
(let-values ([(base name dir?) (split-path base)])
(or (eq? base 'relative)
(and (path? name)
(equal? (path->string name) "compiled")
(let-values ([(base name dir?) (split-path base)])
(eq? base 'relative))))))))))
(for ([f (in-directory)])
(when (file-exists? f)
(unless (file-exists? (build-path td f))
(error 'built "missing binary ~s" f)))))))
(unless (extra-info? f)
(error 'built "missing binary ~s" f))))))))
(unpack-built "x")
(unpack-built "y")
(unpack-built "z")
@ -180,8 +197,8 @@
$ "racket -l racket/base -l y -e '(y)'" =stdout> "'y\n"
$ "racket -l racket/base -l y/sub/s -e '(s)'" =stdout> "'s\n"
$ "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 -t test-docs.rkt -e '(test-docs-x #f)'" =stderr> ""
$ "racket -l racket/base -t test-docs.rkt -e '(test-docs-y #t)'" =stderr> ""
$ "racket -l racket/base -e '(require (submod x test))'" =exit> 1
$ "racket -l racket/base -e '(require (submod y/other doc))'" =exit> 1
@ -205,8 +222,8 @@
=stdout> #rx"syncing: [^\n]*x\n[^\n]*syncing: [^\n]*y"
(putenv "PLT_PKG_NOSETUP" "1")
$ "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)'"
$ "racket -l racket/base -t test-docs.rkt -e '(test-docs-x #t)'" =stderr> ""
$ "racket -l racket/base -t test-docs.rkt -e '(test-docs-y #t)'" =stderr> ""
$ "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 -l y/sub/s -e '(s)'" =stdout> "'s\n"

58
racket/collects/pkg/strip.rkt
View File

@ -87,7 +87,7 @@
[(built)
(immediate-doc/css-or-doc/js?)])))
(define (fixup new-p path src-base)
(define (fixup new-p path src-base level)
(unless (eq? mode 'source)
(define bstr (path->bytes path))
(cond
@ -95,12 +95,19 @@
(fixup-html new-p)]
[(and (eq? mode 'binary)
(equal? #"info.rkt" bstr))
(fixup-info new-p src-base)]
(fixup-info new-p src-base level)]
[(and (eq? mode 'binary)
(regexp-match? #rx"[.]zo$" bstr))
(fixup-zo new-p)])))
(define (explore base paths drops keeps)
(define (explore base ; containing directory relative to `dir`, 'base at start
paths ; paths in `base'
drops ; hash table of paths (relative to start) to drop
keeps ; hash table of paths (relative to start) to keep
level) ; 'package, 'collection, or 'subcollection
(define next-level (case level
[(package) 'collection]
[else 'subcollection]))
(for ([path (in-list paths)])
(define p (if (eq? base 'same)
path
@ -118,7 +125,7 @@
(file-or-directory-modify-seconds
new-p
(file-or-directory-modify-seconds old-p))
(fixup new-p path base)]
(fixup new-p path base level)]
[(directory-exists? old-p)
(define-values (new-drops new-keeps)
(add-drop+keeps old-p p drops keeps))
@ -126,15 +133,27 @@
(explore p
(directory-list old-p)
new-drops
new-keeps)]
new-keeps
next-level)]
[else (error 'strip "file or directory disappeared?")]))))
(define-values (drops keeps)
(add-drop+keeps dir 'same #hash() #hash()))
(explore 'same (directory-list dir) drops keeps)
(define level
(let ([i (get-info/full dir #:namespace drop-keep-ns)])
(cond
[(or (not get-info)
(not (eq? 'multi (i 'collection (lambda () #t)))))
'collection] ; single-collection package
[else 'package])))
(explore 'same (directory-list dir) drops keeps level)
(case mode
[(binary built) (unmove-files dir dest-dir drop-keep-ns)]
[else (void)])
(case mode
[(binary) (assume-virtual dest-dir (eq? level 'collection))]
[else (void)]))
(define (fixup-html new-p)
@ -195,7 +214,8 @@
#:exists 'truncate/replace
(lambda (out) (write-bytes new-bstr out)))))
(define (fixup-info new-p src-base)
;; Used in binary mode:
(define (fixup-info new-p src-base level)
(define dir (let-values ([(base name dir?) (split-path new-p)])
base))
;; check format:
@ -216,7 +236,7 @@
[`(module info ,info-lib (#%module-begin . ,defns))
`(module info ,info-lib
(#%module-begin
(define assume-virtual-sources '())
(define assume-virtual-sources #t)
. ,(filter values
(map (fixup-info-definition get-info) defns))))]))
;; write updated:
@ -231,12 +251,13 @@
(error 'pkg-binary-create "rewrite failed"))
;; compile it, if not top level:
(when (strip-binary-compile-info)
(unless (eq? src-base 'same)
(unless (eq? level 'package)
(managed-compile-zo new-p)))))
(define ((fixup-info-definition get-info) defn)
(match defn
[`(define build-deps . ,v) #f]
[`(define assume-virtual-sources . ,v) #f]
[`(define copy-foreign-libs . ,v)
`(define move-foreign-libs . ,v)]
[`(define copy-shared-files . ,v)
@ -272,3 +293,22 @@
(unmove-tag 'move-man-pages find-user-man-dir)
(unmove-in dir dest-dir))
(unmove dir dest-dir))
(define (assume-virtual dest-dir in-collection?)
;; If an "info.rkt" file doesn't exists in a collection,
;; add one so that `assume-virtual-sources` is defined.
(cond
[in-collection?
(define info-path (build-path dest-dir "info.rkt"))
(unless (file-exists? info-path)
(call-with-output-file*
info-path
(lambda (o)
(write `(module info setup/infotab (define assume-virtual-sources #t)) o)
(newline o)))
(when (strip-binary-compile-info)
(managed-compile-zo info-path)))]
[else
(for ([f (in-list (directory-list dest-dir #:build? #t))])
(when (directory-exists? f)
(assume-virtual f #t)))]))