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.
This commit is contained in:
Matthew Flatt 2013-09-03 19:35:22 -06:00
parent fc82492a99
commit 6391fe4ed0
3 changed files with 52 additions and 9 deletions

View File

@ -1,6 +1,7 @@
#lang scribble/manual #lang scribble/manual
@(require "common.rkt" @(require "common.rkt"
(for-label pkg/strip)) (for-label pkg/strip
setup/dirs))
@title[#:tag "strip"]{Source, Binary, and Built Packages} @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 @item{each @filepath{info.rkt} is adjusted as follows: an
@racket[assume-virtual-sources] definition is added, any @racket[assume-virtual-sources] definition is added, any
@racket[copy-foreign-libs] definition is changed to @racket[copy-foreign-libs] definition is changed to
@racket[move-foreign-libs], any @racket[copy-man-pages] @racket[move-foreign-libs], any
definition is changed to @racket[move-man-pages] entry, and 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.} @racket[build-deps] definition is removed.}
] ]
Finally, creating a @tech{built package} removes any file or directory Creating a @tech{built package} removes any file or directory that
that would be removed for a @tech{source package} and @tech{binary would be removed for a @tech{source package} and @tech{binary
package}, and it performs the @filepath{.html} file updating of a package}, and it performs the @filepath{.html} file updating of a
@tech{binary package}. @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 @defmodule[pkg/strip]{The @racketmodname[pkg/strip] module provides
support for copying a package-style directory to a given destination support for copying a package-style directory to a given destination
with the same file/directory omissions and updates as with the same file/directory omissions and updates as

View File

@ -2214,9 +2214,10 @@
dir-or-name)) dir-or-name))
dir))) dir)))
(case mode (case mode
[(as-is) (create-as-is create:format pkg-name dir dir [(as-is)
#:dest dest-dir (create-as-is create:format pkg-name dir dir
#:quiet? quiet?)] #:dest dest-dir
#:quiet? quiet?)]
[else (stripped-create mode pkg-name dir [else (stripped-create mode pkg-name dir
#:dest dest-dir #:dest dest-dir
#:format create:format #:format create:format

View File

@ -1,6 +1,7 @@
#lang racket/base #lang racket/base
(require compiler/cm (require compiler/cm
setup/getinfo setup/getinfo
setup/dirs
syntax/modread syntax/modread
racket/match racket/match
racket/file racket/file
@ -122,7 +123,10 @@
(define-values (drops keeps) (define-values (drops keeps)
(add-drop+keeps dir 'same #hash() #hash())) (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) (define (fixup-html new-p)
;; strip full path to "local-redirect.js" ;; strip full path to "local-redirect.js"
@ -231,3 +235,29 @@
[`(define copy-man-pages . ,v) [`(define copy-man-pages . ,v)
`(define move-man-pages . ,v)] `(define move-man-pages . ,v)]
[_ defn])) [_ 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))