From 6391fe4ed0a9e3e0a2e26d2298a4650e764ea61f Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Tue, 3 Sep 2013 19:35:22 -0600
Subject: [PATCH] raco pkg create: extend `--from-install` mode so it can
 unmove files

This adjustment to packing allows a native-library package to
be converted back from installed to installable.
---
 .../racket-doc/pkg/scribblings/strip.scrbl    | 22 ++++++++++---
 racket/collects/pkg/lib.rkt                   |  7 ++--
 racket/collects/pkg/strip.rkt                 | 32 ++++++++++++++++++-
 3 files changed, 52 insertions(+), 9 deletions(-)

diff --git a/pkgs/racket-pkgs/racket-doc/pkg/scribblings/strip.scrbl b/pkgs/racket-pkgs/racket-doc/pkg/scribblings/strip.scrbl
index ea4193a7f3..3f6e7037bc 100644
--- a/pkgs/racket-pkgs/racket-doc/pkg/scribblings/strip.scrbl
+++ b/pkgs/racket-pkgs/racket-doc/pkg/scribblings/strip.scrbl
@@ -1,6 +1,7 @@
 #lang scribble/manual
 @(require "common.rkt"
-          (for-label pkg/strip))
+          (for-label pkg/strip
+                     setup/dirs))
 
 @title[#:tag "strip"]{Source, Binary, and Built Packages}
 
@@ -125,17 +126,28 @@ Creating a @tech{binary package} further adjusts the following files:
  @item{each @filepath{info.rkt} is adjusted as follows: an
        @racket[assume-virtual-sources] definition is added, any
        @racket[copy-foreign-libs] definition is changed to
-       @racket[move-foreign-libs], any @racket[copy-man-pages]
-       definition is changed to @racket[move-man-pages] entry, and any
+       @racket[move-foreign-libs], any
+       @racket[copy-shared-files] definition is changed to
+       @racket[move-shared-files], any @racket[copy-man-pages]
+       definition is changed to @racket[move-man-pages], and any
        @racket[build-deps] definition is removed.}
 
 ]
 
-Finally, creating a @tech{built package} removes any file or directory
-that would be removed for a @tech{source package} and @tech{binary
+Creating a @tech{built package} removes any file or directory that
+would be removed for a @tech{source package} and @tech{binary
 package}, and it performs the @filepath{.html} file updating of a
 @tech{binary package}.
 
+Finally, creating @tech{built package} or @tech{source package}
+``unmoves'' files that were installed via @racket[move-foreign-libs],
+@racket[move-shared-files], or @racket[move-man-pages] definitions in
+an @filepath{info.rkt} file, retrieving them if they are not present
+at referenced location but are present in a user-specific target
+directory (i.e., the directory reported by @racket[find-user-lib-dir],
+@racket[find-user-share-dir], or @racket[find-user-man-dir],
+respectively).
+
 @defmodule[pkg/strip]{The @racketmodname[pkg/strip] module provides
 support for copying a package-style directory to a given destination
 with the same file/directory omissions and updates as
diff --git a/racket/collects/pkg/lib.rkt b/racket/collects/pkg/lib.rkt
index de5277e3b3..88c399a04a 100644
--- a/racket/collects/pkg/lib.rkt
+++ b/racket/collects/pkg/lib.rkt
@@ -2214,9 +2214,10 @@
                        dir-or-name))
           dir)))
   (case mode
-    [(as-is) (create-as-is create:format pkg-name dir dir
-                           #:dest dest-dir
-                           #:quiet? quiet?)]
+    [(as-is)
+     (create-as-is create:format pkg-name dir dir
+                   #:dest dest-dir
+                   #:quiet? quiet?)]
     [else (stripped-create mode pkg-name dir
                            #:dest dest-dir
                            #:format create:format
diff --git a/racket/collects/pkg/strip.rkt b/racket/collects/pkg/strip.rkt
index 3935e035ca..0dbc6075cc 100644
--- a/racket/collects/pkg/strip.rkt
+++ b/racket/collects/pkg/strip.rkt
@@ -1,6 +1,7 @@
 #lang racket/base
 (require compiler/cm
          setup/getinfo
+         setup/dirs
          syntax/modread
          racket/match
          racket/file
@@ -122,7 +123,10 @@
   (define-values (drops keeps)
     (add-drop+keeps dir 'same #hash() #hash()))
   
-  (explore 'same (directory-list dir) drops keeps))
+  (explore 'same (directory-list dir) drops keeps)
+  (case mode
+    [(binary built) (unmove-files dir dest-dir drop-keep-ns)]
+    [else (void)]))
 
 (define (fixup-html new-p)
   ;; strip full path to "local-redirect.js"
@@ -231,3 +235,29 @@
     [`(define copy-man-pages . ,v)
      `(define move-man-pages . ,v)]
     [_ defn]))
+
+(define (unmove-files dir dest-dir metadata-ns)
+  ;; Determine whether any files slated for movement by
+  ;; `move-foreign-libs', etc., have been installed
+  ;; and need to be uninstalled, and copies moved files
+  ;; to `dest-dir'.
+  (define (unmove-in dir dest-dir)
+    (for ([f (in-list (directory-list dir))])
+      (define d (build-path dir f))
+      (when (directory-exists? d)
+        (unmove d (build-path dest-dir f)))))
+  (define (unmove dir dest-dir)
+    (define info (get-info/full dir #:namespace metadata-ns))
+    (define (unmove-tag tag find-dir)
+      (when info
+        (define l (info tag (lambda () null)))
+        (for ([f (in-list l)])
+          (when (and (not (file-exists? (build-path dir f)))
+                     (file-exists? (build-path (find-dir) f)))
+            (copy-file (build-path (find-dir) f) 
+                       (build-path dest-dir f))))))
+    (unmove-tag 'move-foreign-libs find-user-lib-dir)
+    (unmove-tag 'move-shared-files find-user-share-dir)
+    (unmove-tag 'move-man-pages find-user-man-dir)
+    (unmove-in dir dest-dir))
+  (unmove dir dest-dir))