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:
parent
fc82492a99
commit
6391fe4ed0
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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))
|
||||
|
|
Loading…
Reference in New Issue
Block a user