From b2f76bd8cc6de52bfcacffa8de0a661d2354a54f Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Tue, 17 Sep 2013 12:41:19 -0600
Subject: [PATCH] fixes for binary-package stripping

Avoid duplicate `assume-virtual-sources` definitions, add
`assume-virtual-sources` as needed in top-level collections
within a package.
---
 .../racket-test/tests/pkg/test-docs.rkt       |  2 +-
 .../tests/pkg/test-pkgs/pkg-y/y/info.rkt      |  2 +
 .../racket-test/tests/pkg/tests-binary.rkt    | 35 ++++++++---
 racket/collects/pkg/strip.rkt                 | 58 ++++++++++++++++---
 4 files changed, 78 insertions(+), 19 deletions(-)

diff --git a/pkgs/racket-pkgs/racket-test/tests/pkg/test-docs.rkt b/pkgs/racket-pkgs/racket-test/tests/pkg/test-docs.rkt
index 36ca1a2716..3e5e04e0a3 100644
--- a/pkgs/racket-pkgs/racket-test/tests/pkg/test-docs.rkt
+++ b/pkgs/racket-pkgs/racket-test/tests/pkg/test-docs.rkt
@@ -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
diff --git a/pkgs/racket-pkgs/racket-test/tests/pkg/test-pkgs/pkg-y/y/info.rkt b/pkgs/racket-pkgs/racket-test/tests/pkg/test-pkgs/pkg-y/y/info.rkt
index 2099969e26..1a629d1f73 100644
--- a/pkgs/racket-pkgs/racket-test/tests/pkg/test-pkgs/pkg-y/y/info.rkt
+++ b/pkgs/racket-pkgs/racket-test/tests/pkg/test-pkgs/pkg-y/y/info.rkt
@@ -1,3 +1,5 @@
 #lang info
 
 (define scribblings '(("y.scrbl")))
+
+(define assume-virtual-sources #f)
diff --git a/pkgs/racket-pkgs/racket-test/tests/pkg/tests-binary.rkt b/pkgs/racket-pkgs/racket-test/tests/pkg/tests-binary.rkt
index 1f3f03a0a3..6999f00560 100644
--- a/pkgs/racket-pkgs/racket-test/tests/pkg/tests-binary.rkt
+++ b/pkgs/racket-pkgs/racket-test/tests/pkg/tests-binary.rkt
@@ -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"
diff --git a/racket/collects/pkg/strip.rkt b/racket/collects/pkg/strip.rkt
index ce88ed0491..739f28bc71 100644
--- a/racket/collects/pkg/strip.rkt
+++ b/racket/collects/pkg/strip.rkt
@@ -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()))
+
+  (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)
+  (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)))]))