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

Strip package-content-state from info files when stripping to source

Browse Source
This commit is contained in:
Spencer Florence 2020-05-21 13:48:02 -05:00 committed by Matthew Flatt
parent 22069faebc
commit 7538011f5f
2 changed files with 38 additions and 26 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
pkgs/racket-test/tests/pkg/tests-api.rkt
View File

@ -2,6 +2,7 @@
(require rackunit (require rackunit
racket/file racket/file
pkg/strip pkg/strip
setup/getinfo
"util.rkt") "util.rkt")
(this-test-is-run-by-the-main-test) (this-test-is-run-by-the-main-test)
@ -12,7 +13,9 @@
(define tmp-dir (path->directory-path (make-temporary-file "tmp~a" 'directory))) (define tmp-dir (path->directory-path (make-temporary-file "tmp~a" 'directory)))
(define pkg-path (build-path "test-pkgs" "pkg-strip")) (define pkg-path (build-path "test-pkgs" "pkg-strip"))
(define pkg-dest-path (build-path tmp-dir "pkg-strip")) (define pkg-dest-path (build-path tmp-dir "pkg-strip"))
(define pkg-dest-path-for-built (build-path tmp-dir "pkg-strip-built"))
(make-directory pkg-dest-path) (make-directory pkg-dest-path)
(make-directory pkg-dest-path-for-built)
(define rx:does-not-exist #rx"directory does not exist") (define rx:does-not-exist #rx"directory does not exist")
@ -49,4 +52,15 @@
;; Paths to existing src and dest directories should succeed. ;; Paths to existing src and dest directories should succeed.
(check-not-exn (lambda () (generate-stripped-directory 'source pkg-path pkg-dest-path))) (check-not-exn (lambda () (generate-stripped-directory 'source pkg-path pkg-dest-path)))
;; check that stripping from built to source correctly changes pkg type
(check-equal?
(begin
(generate-stripped-directory 'source pkg-path pkg-dest-path-for-built)
(generate-stripped-directory 'built pkg-dest-path-for-built pkg-dest-path-for-built)
(generate-stripped-directory 'source pkg-dest-path-for-built pkg-dest-path-for-built)
((get-info/full pkg-dest-path-for-built)
'package-content-state
(lambda () 'no-package-content-state)))
'no-package-content-state)
)) ))

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

@ -181,28 +181,26 @@
[else #f])) [else #f]))
(define (fixup new-p path src-base level) (define (fixup new-p path src-base level)
(case mode (define bstr (path->bytes path))
[(binary binary-lib built) (cond
(define bstr (path->bytes path)) [(and (not (eq? mode 'source)) (regexp-match? #rx"[.]html$" bstr))
(cond (fixup-html new-p)]
[(regexp-match? #rx"[.]html$" bstr) [else
(fixup-html new-p)] (case mode
[else [(binary binary-lib)
(case mode (cond
[(binary binary-lib) [(equal? #"info.rkt" bstr)
(fixup-info new-p src-base level mode)]
[(regexp-match? #rx"[.]zo$" bstr)
(fixup-zo new-p)])]
[(built source)
(when (or (eq? level 'package)
(eq? level 'package+collection))
(cond (cond
[(equal? #"info.rkt" bstr) [(equal? #"info.rkt" bstr)
(fixup-info new-p src-base level mode)] (fixup-info new-p src-base level mode)]
[(regexp-match? #rx"[.]zo$" bstr) [else (void)]))]
(fixup-zo new-p)])] [else (void)])]))
[(built)
(when (or (eq? level 'package)
(eq? level 'package+collection))
(cond
[(equal? #"info.rkt" bstr)
(fixup-info new-p src-base level mode)]
[else (void)]))]
[else (void)])])]))
(define (explore base ; containing directory relative to `dir`, 'base at start (define (explore base ; containing directory relative to `dir`, 'base at start
paths ; paths in `base' paths ; paths in `base'
@ -269,9 +267,7 @@
[else 'package]))) [else 'package])))
(explore 'same (directory-list dir) drops keeps #f level) (explore 'same (directory-list dir) drops keeps #f level)
(case mode (unmove-files dir dest-dir drop-keep-ns)
[(binary binary-lib built) (unmove-files dir dest-dir drop-keep-ns)]
[else (void)])
(case mode (case mode
[(built binary binary-lib) [(built binary binary-lib)
(create-info-as-needed mode dest-dir level)] (create-info-as-needed mode dest-dir level)]
@ -373,7 +369,9 @@
[(binary binary-lib) [(binary binary-lib)
`((define assume-virtual-sources #t))] `((define assume-virtual-sources #t))]
[else '()]) [else '()])
(define package-content-state '(,mode ,(version))) ,@(case mode
[(source) '()]
[else `((define package-content-state '(,mode ,(version))))])
. ,(filter values . ,(filter values
(map (fixup-info-definition get-info mode) defns))))) (map (fixup-info-definition get-info mode) defns)))))
(define new-content (define new-content
@ -403,7 +401,7 @@
[`(define package-content-state . ,v) #f] [`(define package-content-state . ,v) #f]
[_ [_
(case mode (case mode
[(built) defn] [(built source) defn]
[else [else
(match defn (match defn
[`(define build-deps . ,v) #f] [`(define build-deps . ,v) #f]