raco pkg create: support "source" and "binary" bundling
Adds `--from-dir' and `--from-install' flags to select the interpretation of the argument as a directory or as the name of an installed package. Relevant to PR 13669 Adds `--as-is' (the default), `--source', and `--binary' flags to select a pruning mode. The `raco setup' tool recognizes a `rendered-scribblings' specification in "info.rkt" to trigger moving rendered documentation into place, registering its tags in the cross-reference database, and fixing up references to "local-redirect.js"; the presence of a "synced.rktd" indicates when those fixups have been performed (since, if the package is installed in a user-specific scope, the documentation doesn't actually move anywhere). Finally, "out<n>.sxref" needs to report paths relative to the documentation's directory, and then the relative-directory references need to be suitably resolved at derserialization; some support for such relative paths was in place, but it wasn't quite general enough before.
This commit is contained in:
Matthew Flatt
parent
7c0ab55cbc
commit
198a65a5fc
|
|
@ -27,6 +27,7 @@
|
|||
syntax/modcollapse
|
||||
"name.rkt"
|
||||
"util.rkt"
|
||||
"strip.rkt"
|
||||
(prefix-in db: "db.rkt"))
|
||||
|
||||
(define current-pkg-scope
|
||||
|
|
@ -164,7 +165,7 @@
|
|||
(equal? (if (path? a) a (string->path a))
|
||||
(if (path? b) b (string->path b))))
|
||||
|
||||
(define (check-dependencies deps)
|
||||
(define ((check-dependencies which) deps)
|
||||
(unless (and (list? deps)
|
||||
(for/and ([dep (in-list deps)])
|
||||
(define (package-source? dep)
|
||||
|
|
@ -199,10 +200,19 @@
|
|||
[else #f])
|
||||
(loop (hash-set saw (car dep) #t)
|
||||
(cddr dep)))]))))))
|
||||
(pkg-error (~a "invalid `deps' specification\n"
|
||||
(pkg-error (~a "invalid `" which "' specification\n"
|
||||
" specification: ~e")
|
||||
deps)))
|
||||
|
||||
(define (get-all-deps metadata-ns pkg-dir)
|
||||
(append
|
||||
(get-metadata metadata-ns pkg-dir
|
||||
'deps (lambda () empty)
|
||||
#:checker (check-dependencies 'deps))
|
||||
(get-metadata metadata-ns pkg-dir
|
||||
'build-deps (lambda () empty)
|
||||
#:checker (check-dependencies 'build-deps))))
|
||||
|
||||
(define (dependency->name dep)
|
||||
(package-source->name
|
||||
(dependency->source dep)))
|
||||
|
|
@ -1024,9 +1034,7 @@
|
|||
[(and
|
||||
(not (eq? dep-behavior 'force))
|
||||
(let ()
|
||||
(define deps (get-metadata metadata-ns pkg-dir
|
||||
'deps (lambda () empty)
|
||||
#:checker check-dependencies))
|
||||
(define deps (get-all-deps metadata-ns pkg-dir ))
|
||||
(define unsatisfied-deps
|
||||
(map dependency->source
|
||||
(filter-not (λ (dep)
|
||||
|
|
@ -1082,9 +1090,7 @@
|
|||
[(and
|
||||
(not (eq? dep-behavior 'force))
|
||||
(let ()
|
||||
(define deps (get-metadata metadata-ns pkg-dir
|
||||
'deps (lambda () empty)
|
||||
#:checker check-dependencies))
|
||||
(define deps (get-all-deps metadata-ns pkg-dir))
|
||||
(define update-deps
|
||||
(filter-map (λ (dep)
|
||||
(define name (dependency->name dep))
|
||||
|
|
@ -1304,9 +1310,7 @@
|
|||
(pkg-desc orig-pkg-source #f pkg-name auto?))]))
|
||||
|
||||
(define ((package-dependencies metadata-ns) pkg-name)
|
||||
(get-metadata metadata-ns (pkg-directory* pkg-name)
|
||||
'deps (lambda () empty)
|
||||
#:checker check-dependencies))
|
||||
(get-all-deps metadata-ns (pkg-directory* pkg-name)))
|
||||
|
||||
(define (pkg-update in-pkgs
|
||||
#:all? [all? #f]
|
||||
|
|
@ -1420,38 +1424,41 @@
|
|||
[_
|
||||
(pkg-error "multiple config keys provided")])]))
|
||||
|
||||
(define (pkg-create create:format maybe-dir
|
||||
#:quiet? [quiet? #f])
|
||||
(define (create-as-is create:format pkg-name dir orig-dir
|
||||
#:quiet? [quiet? #f]
|
||||
#:hide-src? [hide-src? #f]
|
||||
#:dest [dest-dir #f])
|
||||
(begin
|
||||
(define dir (regexp-replace* #rx"/$" maybe-dir ""))
|
||||
(unless (directory-exists? dir)
|
||||
(pkg-error "directory does not exist\n path: ~a" dir))
|
||||
(match create:format
|
||||
['MANIFEST
|
||||
(unless quiet?
|
||||
(printf "creating manifest for ~a\n"
|
||||
dir))
|
||||
(with-output-to-file
|
||||
(build-path dir "MANIFEST")
|
||||
orig-dir))
|
||||
(with-output-to-file (build-path (or dest-dir dir) "MANIFEST")
|
||||
#:exists 'replace
|
||||
(λ ()
|
||||
(for ([f (in-list (parameterize ([current-directory dir])
|
||||
(find-files file-exists?)))])
|
||||
(display f)
|
||||
(newline))))]
|
||||
[else
|
||||
(define pkg (format "~a.~a" dir create:format))
|
||||
[else
|
||||
(define pkg (format "~a.~a" pkg-name create:format))
|
||||
(define actual-dest-dir (or dest-dir
|
||||
(let-values ([(base name dir?) (split-path dir)])
|
||||
(cond
|
||||
[(path? base) (path->complete-path base)]
|
||||
[else (current-directory)]))))
|
||||
(define pkg/complete (path->complete-path pkg actual-dest-dir))
|
||||
(unless quiet?
|
||||
(printf "packing ~a into ~a\n"
|
||||
dir pkg))
|
||||
(define pkg-name
|
||||
(regexp-replace
|
||||
(regexp (format "~a$" (regexp-quote (format ".~a" create:format))))
|
||||
(path->string (file-name-from-path pkg))
|
||||
""))
|
||||
(printf "packing~a into ~a\n"
|
||||
(if hide-src? "" (format " ~a" dir))
|
||||
(if dest-dir
|
||||
pkg/complete
|
||||
pkg)))
|
||||
(match create:format
|
||||
['tgz
|
||||
(define pkg/complete (path->complete-path pkg))
|
||||
(when (file-exists? pkg/complete)
|
||||
(delete-file pkg/complete))
|
||||
(parameterize ([current-directory dir])
|
||||
|
|
@ -1461,7 +1468,6 @@
|
|||
(raise exn))])
|
||||
(apply tar-gzip pkg/complete (directory-list))))]
|
||||
['zip
|
||||
(define pkg/complete (path->complete-path pkg))
|
||||
(when (file-exists? pkg/complete)
|
||||
(delete-file pkg/complete))
|
||||
(parameterize ([current-directory dir])
|
||||
|
|
@ -1471,7 +1477,7 @@
|
|||
(raise exn))])
|
||||
(apply zip pkg/complete (directory-list))))]
|
||||
['plt
|
||||
(define dest (path->complete-path pkg))
|
||||
(define dest pkg/complete)
|
||||
(parameterize ([current-directory dir])
|
||||
(define names (filter std-filter (directory-list)))
|
||||
(define dirs (filter directory-exists? names))
|
||||
|
|
@ -1483,12 +1489,71 @@
|
|||
[x
|
||||
(pkg-error "invalid package format\n format: ~a" x)])
|
||||
(define chk (format "~a.CHECKSUM" pkg))
|
||||
(define chk/complete (path->complete-path chk actual-dest-dir))
|
||||
(unless quiet?
|
||||
(printf "writing package checksum to ~a\n"
|
||||
chk))
|
||||
(with-output-to-file chk
|
||||
(if dest-dir
|
||||
chk/complete
|
||||
chk)))
|
||||
(with-output-to-file chk/complete
|
||||
#:exists 'replace
|
||||
(λ () (display (call-with-input-file pkg sha1))))])))
|
||||
(λ () (display (call-with-input-file pkg/complete sha1))))])))
|
||||
|
||||
(define (stripped-create mode name dir
|
||||
#:format [create:format 'zip]
|
||||
#:quiet? [quiet? #f]
|
||||
#:dest [archive-dest-dir #f])
|
||||
(define tmp-dir (make-temporary-file "create-binary-~a" 'directory))
|
||||
(dynamic-wind
|
||||
void
|
||||
(lambda ()
|
||||
(define dest-dir (build-path tmp-dir name))
|
||||
(make-directory dest-dir)
|
||||
(generate-stripped-directory (eq? mode 'binary) dir dest-dir)
|
||||
(create-as-is create:format name dest-dir dir
|
||||
#:hide-src? #t
|
||||
#:quiet? quiet?
|
||||
#:dest archive-dest-dir))
|
||||
(lambda ()
|
||||
(delete-directory/files tmp-dir))))
|
||||
|
||||
(define (pkg-create create:format dir-or-name
|
||||
#:dest [dest-dir #f]
|
||||
#:source [source 'dir]
|
||||
#:mode [mode 'as-is]
|
||||
#:quiet? [quiet? #f])
|
||||
(define pkg-name
|
||||
(if (eq? source 'dir)
|
||||
(path->string (let-values ([(base name dir?) (split-path dir-or-name)])
|
||||
name))
|
||||
dir-or-name))
|
||||
(define dir
|
||||
(if (eq? source 'dir)
|
||||
dir-or-name
|
||||
(let ()
|
||||
(define (get-dir scope)
|
||||
(parameterize ([current-pkg-scope scope])
|
||||
(with-pkg-lock/read-only
|
||||
(pkg-directory* dir-or-name))))
|
||||
(define dir (or (get-dir 'user)
|
||||
(get-dir 'shared)))
|
||||
(unless dir
|
||||
(pkg-error (~a "package not installed in user or shared scope\n"
|
||||
" package name: ~a"
|
||||
(if (get-dir 'installation)
|
||||
"\n installed in scope: installation"
|
||||
""))
|
||||
dir-or-name))
|
||||
dir)))
|
||||
(case mode
|
||||
[(as-is) (create-as-is create:format pkg-name dir dir
|
||||
#:dest dest-dir
|
||||
#:quiet? quiet?)]
|
||||
[(source binary) (stripped-create mode pkg-name dir
|
||||
#:dest dest-dir
|
||||
#:format create:format
|
||||
#:quiet? quiet?)]))
|
||||
|
||||
|
||||
(define (pkg-catalog-copy srcs dest
|
||||
#:from-config? [from-config? #f]
|
||||
|
|
@ -1683,7 +1748,7 @@
|
|||
(display mod-str)
|
||||
(+ new-col (string-length mod-str)))
|
||||
(newline)))]))
|
||||
|
||||
|
||||
(define (get-all-pkg-names-from-catalogs)
|
||||
(define ht
|
||||
(for*/hash ([i (in-list (pkg-catalogs))]
|
||||
|
|
@ -1768,8 +1833,12 @@
|
|||
(define v (if get-info
|
||||
(get-info 'deps (lambda () empty))
|
||||
empty))
|
||||
(check-dependencies v)
|
||||
v)
|
||||
((check-dependencies 'deps) v)
|
||||
(define v2 (if get-info
|
||||
(get-info 'build-deps (lambda () empty))
|
||||
empty))
|
||||
((check-dependencies 'build-deps) v2)
|
||||
(append v v2))
|
||||
|
||||
(define (get-pkg-content desc
|
||||
#:extract-info [extract-info extract-dependencies])
|
||||
|
|
@ -1942,7 +2011,10 @@
|
|||
[pkg-create
|
||||
(->* ((or/c 'zip 'tgz 'plt 'MANIFEST)
|
||||
path-string?)
|
||||
(#:quiet? boolean?)
|
||||
(#:source (or/c 'dir 'name)
|
||||
#:mode (or/c 'as-is 'source 'binary)
|
||||
#:quiet? boolean?
|
||||
#:dest (or/c (and/c path-string? complete-path?) #f))
|
||||
void?)]
|
||||
[pkg-update
|
||||
(->* ((listof string?))
|
||||
|
|
|
|||
|
|
@ -191,8 +191,37 @@
|
|||
[current-pkg-scope-version (or version (r:version))])
|
||||
(with-pkg-lock/read-only
|
||||
(pkg-show (if only-mode "" " ") #:directory? dir)))))]
|
||||
[create
|
||||
"Bundle a package from a directory or installed package"
|
||||
#:once-any
|
||||
[#:bool from-dir () "Treat <directory-or-package> as a directory (the default)"]
|
||||
[#:bool from-install () "Treat <directory-or-package> as a package name"]
|
||||
#:once-any
|
||||
[(#:sym fmt [zip tgz plt] #f) format ()
|
||||
("Select the format of the package to be created;"
|
||||
"valid <fmt>s are: zip (the default), tgz, plt")]
|
||||
[#:bool manifest () "Creates a manifest file for a directory, rather than an archive"]
|
||||
#:once-any
|
||||
[#:bool as-is () "Bundle the directory/package as-is (the default)"]
|
||||
[#:bool source () "Bundle sources only"]
|
||||
[#:bool binary () "Bundle bytecode and rendered documentation without sources"]
|
||||
#:once-each
|
||||
[(#:str dest-dir #f) dest () "Create output files in <dest-dir>"]
|
||||
#:args (directory-or-package)
|
||||
(parameterize ([current-pkg-error (pkg-error 'create)])
|
||||
(pkg-create (if manifest 'MANIFEST (or format 'zip))
|
||||
directory-or-package
|
||||
#:dest (and dest
|
||||
(path->complete-path dest))
|
||||
#:source (cond
|
||||
[from-install 'name]
|
||||
[else 'dir])
|
||||
#:mode (cond
|
||||
[source 'source]
|
||||
[binary 'binary]
|
||||
[else 'as-is])))]
|
||||
[config
|
||||
"View and modify the package configuration"
|
||||
"View and modify the package manager's configuration"
|
||||
#:once-each
|
||||
[#:bool set () "Completely replace the value"]
|
||||
#:once-any
|
||||
|
|
@ -214,16 +243,6 @@
|
|||
(pkg-config #t key/val))
|
||||
(with-pkg-lock/read-only
|
||||
(pkg-config #f key/val)))))]
|
||||
[create
|
||||
"Bundle a new package"
|
||||
#:once-any
|
||||
[(#:sym fmt [zip tgz plt] #f) format ()
|
||||
("Select the format of the package to be created;"
|
||||
"valid <fmt>s are: zip (the default), tgz, plt")]
|
||||
[#:bool manifest () "Creates a manifest file for a directory, rather than an archive"]
|
||||
#:args (package-directory)
|
||||
(parameterize ([current-pkg-error (pkg-error 'create)])
|
||||
(pkg-create (if manifest 'MANIFEST (or format 'zip)) package-directory))]
|
||||
[catalog-show
|
||||
"Show information about packages as reported by catalog"
|
||||
#:once-any
|
||||
|
|
|
|||
|
|
@ -297,8 +297,9 @@ sub-sub-commands:
|
|||
installed (e.g. it conflicts with another installed package), then
|
||||
this command fails without installing any of the @nonterm{pkg}s
|
||||
(or their dependencies).
|
||||
The @exec{update} sub-command accepts
|
||||
the following @nonterm{option}s:
|
||||
|
||||
The @exec{update} sub-command accepts
|
||||
the following @nonterm{option}s:
|
||||
|
||||
@itemlist[
|
||||
@item{@DFlag{deps} @nonterm{behavior} --- Same as for @command-ref{install}.}
|
||||
|
|
@ -315,7 +316,10 @@ the following @nonterm{option}s:
|
|||
@item{@command/toc{remove} @nonterm{option} ... @nonterm{pkg} ...
|
||||
--- Attempts to remove the given packages. If a package is the dependency
|
||||
of another package that is not listed, this command fails without
|
||||
removing any of the @nonterm{pkg}s. This command accepts the following @nonterm{option}s:
|
||||
removing any of the @nonterm{pkg}s.
|
||||
|
||||
The @exec{remove} sub-command accepts
|
||||
the following @nonterm{option}s:
|
||||
|
||||
@itemlist[
|
||||
@item{@DFlag{force} --- Ignore dependencies when removing packages.}
|
||||
|
|
@ -332,7 +336,9 @@ removing any of the @nonterm{pkg}s. This command accepts the following @nonterm{
|
|||
@item{@command/toc{show} @nonterm{option} ... --- Print information about currently installed packages.
|
||||
By default, packages are shown for all installation modes (installation-wide,
|
||||
user- and Racket-version-specific, and user-specific all-version).
|
||||
The command accepts the following @nonterm{option}s:
|
||||
|
||||
The @exec{show} sub-command accepts
|
||||
the following @nonterm{option}s:
|
||||
|
||||
@itemlist[
|
||||
|
||||
|
|
@ -352,8 +358,60 @@ removing any of the @nonterm{pkg}s. This command accepts the following @nonterm{
|
|||
]
|
||||
}
|
||||
|
||||
@item{@command/toc{create} @nonterm{option} ... @nonterm{directory-or-package}
|
||||
--- Bundles a package into an archive. Bundling
|
||||
is not needed for a package that is provided directly from a
|
||||
GitHub repository or other non-archive formats. The @exec{create}
|
||||
sub-command can create an archive from a directory (the default) or
|
||||
from an installed package. It can also adjust the archive's content
|
||||
to include only sources (which is the recommended mode, although not
|
||||
the default) or as a ``binary'' package (but packages are
|
||||
normally provided as source and converted to binary form by an
|
||||
automatic service, instead of by a package author).
|
||||
|
||||
The @exec{create} sub-command accepts
|
||||
the following @nonterm{option}s:
|
||||
|
||||
@itemlist[
|
||||
@item{@DFlag{from-dir} --- Treat @nonterm{directory-or-package} as a directory path; this is the default mode.}
|
||||
@item{@DFlag{from-install} --- Treat @nonterm{directory-or-package} as the name of an installed package
|
||||
(instead of a directory).}
|
||||
@item{@DFlag{format} @nonterm{format} --- Specifies the archive format.
|
||||
The allowed @nonterm{format}s are: @exec{zip} (the default), @exec{tgz}, and @exec{plt}.
|
||||
This option must be specified if @DFlag{manifest} is not present.}
|
||||
@item{@DFlag{manifest} --- Creates a manifest file for a directory, rather than an archive.}
|
||||
@item{@DFlag{as-is} --- Bundle all content of the package directory as is, with no filtering
|
||||
of sources, compiled files, or repository elements.}
|
||||
@item{@DFlag{source} --- Bundle only sources in the package directory, pruning (by default)
|
||||
@filepath{compiled} directories (that normally hold compiled
|
||||
bytecode), @filepath{doc} directories (that normally hold rendered documentation),
|
||||
directories named @filepath{.svn}, and directories and files whose names start with @filepath{.git}.
|
||||
Override the default pruning rules with @racket[source-omit-files] and/or
|
||||
@racket[source-keep-files] definitions in @filepath{info.rkt} files within the
|
||||
package directory.}
|
||||
@item{@DFlag{binary} --- Bundle compiled bytecode and rendered
|
||||
documentation in the package directory. Normally, this option is sensible for
|
||||
a package that is installed from source in a user-specific scope. Bundling prunes (by default)
|
||||
@filepath{.rkt} and @filepath{.ss} files for which compiled bytecode is present, files with
|
||||
a @filepath{.scrbl} suffix, @filepath{tests} directories, @filepath{scribblings}
|
||||
directories, @filepath{.svn} directories, and directories and files whose names
|
||||
start with @filepath{.git}. For each @filepath{.html} file that
|
||||
refers to a @filepath{local-redirect.js} script, the path to the script is removed.
|
||||
In addition, bundling updates any @filepath{info.rkt} as follows: it
|
||||
adds a @racket[assume-virtual-sources] entry,
|
||||
converts a @racket[scribblings] entry to a @racket[rendered-scribblings] entry,
|
||||
changes a @racket[copy-foreign-libs] entry to a @racket[move-foreign-libs] entry,
|
||||
changes a @racket[copy-man-pages] entry to a @racket[move-man-pages] entry,
|
||||
and removes any @racket[build-deps] entry. Override
|
||||
the default pruning rules with @racket[binary-omit-files]
|
||||
and/or @racket[binary-keep-files] definitions in
|
||||
@filepath{info.rkt} files within the package directory.}
|
||||
@item{@DFlag{dest} @nonterm{dest-dir} --- Writes generated bundles to @nonterm{dest-dir}.}
|
||||
]
|
||||
}
|
||||
|
||||
@item{@command/toc{config} @nonterm{option} ... @nonterm{key} @nonterm{val} ... ---
|
||||
View and modify package configuration options. This command accepts the following @nonterm{option}s:
|
||||
View and modify configuration of the package manager itself, with the following @nonterm{option}s:
|
||||
|
||||
@itemlist[
|
||||
@item{@DFlag{set} --- Sets an option, rather than printing it.}
|
||||
|
|
@ -372,21 +430,13 @@ View and modify package configuration options. This command accepts the followin
|
|||
]
|
||||
}
|
||||
|
||||
@item{@command/toc{create} @nonterm{option} ... @nonterm{package-directory}
|
||||
--- Bundles a package directory into a package archive. This command accepts the following @nonterm{option}s:
|
||||
|
||||
@itemlist[
|
||||
@item{@DFlag{format} @nonterm{format} --- Specifies the archive format.
|
||||
The allowed @nonterm{format}s are: @exec{zip} (the default), @exec{tgz}, and @exec{plt}.
|
||||
This option must be specified if @DFlag{manifest} is not present.}
|
||||
@item{@DFlag{manifest} --- Creates a manifest file for a directory, rather than an archive.}
|
||||
]
|
||||
}
|
||||
|
||||
@item{@command/toc{catalog-show} @nonterm{option} ... @nonterm{package-name} ...
|
||||
--- Consults @tech{package catalogs} for a package (that is not necessarily installed)
|
||||
and displays the catalog's information for the package, such as its source URL and
|
||||
a checksum. This command accepts the following @nonterm{option}s:
|
||||
a checksum.
|
||||
|
||||
The @exec{catalog-show} sub-command accepts
|
||||
the following @nonterm{option}s:
|
||||
|
||||
@itemlist[
|
||||
@item{@DFlag{all} --- Show information for all available packages. When using this flag,
|
||||
|
|
@ -412,7 +462,8 @@ View and modify package configuration options. This command accepts the followin
|
|||
with information from earlier @nonterm{src-catalog}s taking precedence over later
|
||||
@nonterm{src-catalog}s.
|
||||
|
||||
This command accepts the following @nonterm{option}s:
|
||||
The @exec{catalog-copy} sub-command accepts
|
||||
the following @nonterm{option}s:
|
||||
|
||||
@itemlist[
|
||||
@item{@DFlag{from-config} --- Adds the currently configured
|
||||
|
|
@ -695,6 +746,13 @@ The following @filepath{info.rkt} fields are used by the package manager:
|
|||
Use the package name @racket["racket"] to specify a dependency
|
||||
on the version of the Racket installation.}
|
||||
|
||||
@item{@racketidfont{build-deps} --- like @racketidfont{deps}, but for
|
||||
dependencies that can be dropped in a ``binary'' variant of the
|
||||
package that does not include sources. The
|
||||
@racketidfont{build-deps} and @racketidfont{deps} lists are appended,
|
||||
while @command-ref["create"] strips away @racketidfont{build-deps}
|
||||
when converting a package for @DFlag{binary} mode.}
|
||||
|
||||
@item{@racketidfont{setup-collects} --- a list of path strings and/or
|
||||
lists of path strings, which are used as collection names to
|
||||
set up via @exec{raco setup} after the package is installed, or
|
||||
|
|
|
|||
171
collects/pkg/strip.rkt
Normal file
171
collects/pkg/strip.rkt
Normal file
|
|
@ -0,0 +1,171 @@
|
|||
#lang racket/base
|
||||
(require compiler/cm
|
||||
setup/getinfo
|
||||
syntax/modread
|
||||
racket/match
|
||||
racket/file)
|
||||
|
||||
(provide generate-stripped-directory
|
||||
fixup-local-redirect-reference)
|
||||
|
||||
(define (generate-stripped-directory binary? dir dest-dir)
|
||||
(define drop-keep-ns (make-base-namespace))
|
||||
(define (add-drop+keeps dir base drops keeps)
|
||||
(define get-info (get-info/full dir #:namespace drop-keep-ns))
|
||||
(define drop-tag (if binary? 'binary-omit-files 'source-omit-files))
|
||||
(define more-drops (if get-info
|
||||
(get-info drop-tag (lambda () null))
|
||||
null))
|
||||
(define keep-tag (if binary? 'binary-keep-files 'source-keep-files))
|
||||
(define more-keeps (if get-info
|
||||
(get-info keep-tag (lambda () null))
|
||||
null))
|
||||
(define (check tag l)
|
||||
(unless (and (list? l) (andmap (lambda (p)
|
||||
(and (path-string? p)
|
||||
(relative-path? p)))
|
||||
l))
|
||||
(error 'strip "bad ~a value from \"info.rkt\": ~e" tag l)))
|
||||
(check drop-tag more-drops)
|
||||
(check keep-tag more-keeps)
|
||||
|
||||
(define (add ht l)
|
||||
(for/fold ([ht ht]) ([i (in-list l)])
|
||||
(hash-set ht
|
||||
(if (eq? base 'same)
|
||||
(if (path? i) i (string->path i))
|
||||
(build-path base i))
|
||||
#t)))
|
||||
(values (add drops more-drops)
|
||||
(add keeps more-keeps)))
|
||||
|
||||
(define (drop-by-default? path get-p)
|
||||
(define bstr (path->bytes path))
|
||||
(or (regexp-match? #rx#"^(?:[.]git.*|[.]svn)$"
|
||||
bstr)
|
||||
(regexp-match? (if binary?
|
||||
#rx#"^(?:[.]git.*|[.]svn|tests|scribblings|.*[.]scrbl)$"
|
||||
#rx#"^(?:compiled|doc)$")
|
||||
bstr)
|
||||
(and binary?
|
||||
(regexp-match? #rx"[.](?:ss|rkt)$" bstr)
|
||||
(not (equal? #"info.rkt" bstr))
|
||||
(file-exists? (let-values ([(base name dir?) (split-path (get-p))])
|
||||
(build-path base "compiled" (path-add-suffix name #".zo")))))
|
||||
(and binary?
|
||||
(or (equal? #"info_rkt.zo" bstr)
|
||||
(equal? #"info_rkt.dep" bstr)))))
|
||||
|
||||
(define (fixup new-p path)
|
||||
(when binary?
|
||||
(define bstr (path->bytes path))
|
||||
(cond
|
||||
[(regexp-match? #rx"[.]html$" bstr)
|
||||
(fixup-html new-p)]
|
||||
[(equal? #"info.rkt" bstr)
|
||||
(fixup-info new-p)]
|
||||
[else (void)])))
|
||||
|
||||
(define (explore base paths drops keeps)
|
||||
(for ([path (in-list paths)])
|
||||
(define p (if (eq? base 'same)
|
||||
path
|
||||
(build-path base path)))
|
||||
(when (and (not (hash-ref drops p #f))
|
||||
(or (hash-ref keeps p #f)
|
||||
(not (drop-by-default?
|
||||
path
|
||||
(lambda () (build-path dir p))))))
|
||||
(define old-p (build-path dir p))
|
||||
(define new-p (build-path dest-dir p))
|
||||
(cond
|
||||
[(file-exists? old-p)
|
||||
(copy-file old-p new-p)
|
||||
(fixup new-p path)]
|
||||
[(directory-exists? old-p)
|
||||
(define-values (new-drops new-keeps)
|
||||
(add-drop+keeps old-p p drops keeps))
|
||||
(make-directory new-p)
|
||||
(explore p
|
||||
(directory-list old-p)
|
||||
new-drops
|
||||
new-keeps)]
|
||||
[else (error 'strip "file or directory disappeared?")]))))
|
||||
|
||||
(define-values (drops keeps)
|
||||
(add-drop+keeps dir 'same #hash() #hash()))
|
||||
|
||||
(explore 'same (directory-list dir) drops keeps))
|
||||
|
||||
(define (fixup-html new-p)
|
||||
;; strip full path to "local-redirect.js"
|
||||
(fixup-local-redirect-reference new-p ".."))
|
||||
|
||||
(define (fixup-local-redirect-reference p js-path)
|
||||
;; Relying on this HTML pattern (as generated by Scribble's HTML
|
||||
;; renderer) is a little fragile. Any better idea?
|
||||
(define rx #rx"<script type=\"text/javascript\" src=\"([^\"]*)/local-redirect.js\">")
|
||||
(define m (call-with-input-file*
|
||||
p
|
||||
(lambda (i) (regexp-match-positions rx i))))
|
||||
(when m
|
||||
(define start (caadr m))
|
||||
(define end (cdadr m))
|
||||
(define bstr (file->bytes p))
|
||||
(define new-bstr
|
||||
(bytes-append (subbytes bstr 0 start)
|
||||
(string->bytes/utf-8 js-path)
|
||||
(subbytes bstr end)))
|
||||
(call-with-output-file*
|
||||
p
|
||||
#:exists 'truncate/replace
|
||||
(lambda (out) (write-bytes new-bstr out)))))
|
||||
|
||||
(define (fixup-info new-p)
|
||||
(define dir (let-values ([(base name dir?) (split-path new-p)])
|
||||
base))
|
||||
;; check format:
|
||||
(define get-info
|
||||
(get-info/full dir #:namespace (make-base-namespace)))
|
||||
(when get-info
|
||||
;; read in:
|
||||
(define content
|
||||
(call-with-input-file*
|
||||
new-p
|
||||
(lambda (in)
|
||||
(begin0
|
||||
(with-module-reading-parameterization
|
||||
(lambda () (read in)))))))
|
||||
;; convert:
|
||||
(define new-content
|
||||
(match content
|
||||
[`(module info setup/infotab (#%module-begin . ,defns))
|
||||
`(module info setup/infotab
|
||||
(#%module-begin
|
||||
(define assume-virtual-sources '())
|
||||
. ,(filter values
|
||||
(map (fixup-info-definition get-info) defns))))]))
|
||||
;; write updated:
|
||||
(call-with-output-file*
|
||||
new-p
|
||||
#:exists 'truncate
|
||||
(lambda (out)
|
||||
(write new-content out)
|
||||
(newline out)))
|
||||
;; sanity check:
|
||||
(unless (get-info/full dir #:namespace (make-base-namespace))
|
||||
(error 'pkg-binary-create "rewrite failed"))
|
||||
;; compile it:
|
||||
(managed-compile-zo new-p)))
|
||||
|
||||
|
||||
(define ((fixup-info-definition get-info) defn)
|
||||
(match defn
|
||||
[`(define build-deps . ,v) #f]
|
||||
[`(define scribblings . ,v)
|
||||
`(define rendered-scribblings . ,v)]
|
||||
[`(define copy-foreign-libs . ,v)
|
||||
`(define move-foreign-libs . ,v)]
|
||||
[`(define copy-man-pages . ,v)
|
||||
`(define move-man-pages . ,v)]
|
||||
[_ defn]))
|
||||
|
|
@ -264,7 +264,8 @@
|
|||
|
||||
(define/public (root-relative->path p)
|
||||
(if (root-relative? p)
|
||||
(apply build-path (mobile-root-path (car p))
|
||||
(apply build-path (or (mobile-root-path (car p))
|
||||
(current-directory))
|
||||
(map bytes->path-element (cdr p)))
|
||||
p))
|
||||
|
||||
|
|
@ -336,7 +337,13 @@
|
|||
|
||||
(define/public (serialize-one-ht ri ht)
|
||||
(parameterize ([current-serialize-resolve-info ri])
|
||||
(serialize (cons root ht))))
|
||||
(let ([rp (mobile-root-path root)])
|
||||
(when rp
|
||||
(set-mobile-root-path! root #f))
|
||||
(begin0
|
||||
(serialize (cons root ht))
|
||||
(when rp
|
||||
(set-mobile-root-path! root rp))))))
|
||||
|
||||
(define/public (deserialize-info v ci #:root [root-path #f])
|
||||
(let ([root+ht (deserialize v)]
|
||||
|
|
|
|||
|
|
@ -15,7 +15,9 @@
|
|||
xref-tag->path+anchor
|
||||
xref-tag->index-entry
|
||||
xref-transfer-info
|
||||
(struct-out entry))
|
||||
(struct-out entry)
|
||||
make-data+root
|
||||
data+root?)
|
||||
|
||||
(define-struct entry
|
||||
(words ; list of strings: main term, sub-term, etc.
|
||||
|
|
@ -23,6 +25,8 @@
|
|||
tag ; for generating a Scribble link
|
||||
desc)) ; further info that depends on the kind of index entry
|
||||
|
||||
(define-struct data+root (data root))
|
||||
|
||||
;; Private:
|
||||
(define-struct xrefs (renderer ri))
|
||||
|
||||
|
|
@ -44,7 +48,10 @@
|
|||
(namespace-anchor->empty-namespace here)])
|
||||
(let ([vs (src)])
|
||||
(for ([v (in-list (if (procedure? vs) (vs) (list vs)))])
|
||||
(when v (send renderer deserialize-info v ci #:root root-path))))))]
|
||||
(when v
|
||||
(define data (if (data+root? v) (data+root-data v) v))
|
||||
(define root (if (data+root? v) (data+root-root v) root-path))
|
||||
(send renderer deserialize-info data ci #:root root))))))]
|
||||
[ci (send renderer collect null null fp
|
||||
(lambda (key ci)
|
||||
(define src (demand-source key))
|
||||
|
|
|
|||
|
|
@ -28,19 +28,19 @@
|
|||
(truncate (/ (caar l) 10))))])
|
||||
(if sep? (cons (mk-sep lbl) l) l))]))))
|
||||
|
||||
(define (make-start-page all?)
|
||||
(let* ([recs (find-relevant-directory-records '(scribblings) 'all-available)]
|
||||
(define (get-docs all? tag)
|
||||
(let* ([recs (find-relevant-directory-records (list tag) 'all-available)]
|
||||
[infos (map get-info/full (map directory-record-path recs))]
|
||||
[main-dirs (parameterize ([current-library-collection-paths
|
||||
(list (find-collects-dir))])
|
||||
(for/hash ([k (in-list (find-relevant-directories '(scribblings) 'no-planet))])
|
||||
(for/hash ([k (in-list (find-relevant-directories (list tag) 'no-planet))])
|
||||
(values k #t)))]
|
||||
[docs (append-map
|
||||
(lambda (i rec)
|
||||
(define dir (directory-record-path rec))
|
||||
(define s (and (or all? (hash-ref main-dirs dir #f))
|
||||
i
|
||||
(i 'scribblings)))
|
||||
(i tag)))
|
||||
(if (not s)
|
||||
null
|
||||
(filter-map
|
||||
|
|
@ -83,7 +83,12 @@
|
|||
(cdr spec))))))))
|
||||
s)))
|
||||
infos
|
||||
recs)]
|
||||
recs)])
|
||||
docs))
|
||||
|
||||
(define (make-start-page all?)
|
||||
(let* ([docs (append (get-docs all? 'scribblings)
|
||||
(get-docs all? 'rendered-scribblings))]
|
||||
[docs (cons
|
||||
;; Add HtDP
|
||||
(list
|
||||
|
|
|
|||
|
|
@ -513,6 +513,12 @@ Optional @filepath{info.rkt} fields trigger additional actions by
|
|||
case, so it can be provided by the same file that provides the
|
||||
previous two.}
|
||||
|
||||
@item{@indexed-racket[assume-virtual-sources] : @racket[any/c] ---
|
||||
A true value indicates that bytecode files without a corresponding
|
||||
source file should not be removed from @filepath{compiled} directories,
|
||||
and no files should not be removed when the
|
||||
@DFlag{clean} or @Flag{c} flag is passed to @exec{raco setup}.}
|
||||
|
||||
@item{@indexed-racket[clean] : @racket[(listof path-string?)] ---
|
||||
@elemtag["clean"] A list of pathnames to be deleted when the
|
||||
@DFlag{clean} or @Flag{c} flag is passed to @exec{raco setup}. The
|
||||
|
|
|
|||
|
|
@ -19,7 +19,7 @@ Returns @racket[#t] if @racket[v] is a cross-reference record created
|
|||
by @racket[load-xref], @racket[#f] otherwise.}
|
||||
|
||||
|
||||
@defproc[(load-xref [sources (listof (-> any/c))]
|
||||
@defproc[(load-xref [sources (listof (-> (or/c any/c (-> list?))))]
|
||||
[#:demand-source demand-source
|
||||
(tag? -> (or/c (-> any/c) #f))
|
||||
(lambda (_tag) #f)]
|
||||
|
|
@ -28,10 +28,19 @@ by @racket[load-xref], @racket[#f] otherwise.}
|
|||
[#:root root-path (or/c path-string? false/c) #f])
|
||||
xref?]{
|
||||
|
||||
Creates a cross-reference record given a list of functions that each
|
||||
produce a serialized information obtained from @xmethod[render<%>
|
||||
serialize-info]. If a @racket[sources] element produces @racket[#f],
|
||||
its result is ignored.
|
||||
Creates a cross-reference record given a list of functions,
|
||||
@racket[sources].
|
||||
|
||||
Let @racket[_source] be a function in @racket[sources]. The
|
||||
@racket[_source] function normally returns serialized information,
|
||||
@racket[_info], which was formerly obtained from @xmethod[render<%>
|
||||
serialize-info]. The result of @racket[_source] can optionally be
|
||||
another function, which is in turn responsible for returning a list of
|
||||
@racket[_info]s. Finally, each @racket[_info] can be either serialized
|
||||
information, a @racket[#f] to be ignored, or a value produced by
|
||||
@racket[make-data+root] from which @racket[_data] part is used as
|
||||
serialized information and the @racket[_root] part overrides
|
||||
@racket[root-path] for deserialization.
|
||||
|
||||
The @racket[demand-source] function can effectively add a new source
|
||||
to @racket[sources] in response to a search for information on the
|
||||
|
|
@ -46,7 +55,10 @@ Latex/PDF and text).
|
|||
|
||||
If @racket[root-path] is not @racket[#f], then file paths that are
|
||||
serialized as relative to an instantiation-supplied @racket[root-path]
|
||||
are deserialized as relative instead to the given @racket[root-path].
|
||||
are deserialized as relative instead to the given @racket[root-path],
|
||||
but a @racket[make-data+root] result for any @racket[_info] supplies
|
||||
an alternate path for deserialization of the @racket[_info]'s
|
||||
@racket[_data].
|
||||
|
||||
Use @racket[load-collections-xref] from @racketmodname[setup/xref] to
|
||||
get all cross-reference information for installed documentation.}
|
||||
|
|
@ -191,3 +203,13 @@ The @racket[words] list corresponds to
|
|||
corresponds to @racket[index-element-entry-seq]. The @racket[desc]
|
||||
value corresponds to @racket[index-element-desc]. The @racket[tag] is
|
||||
the destination for the index link into the main document.}
|
||||
|
||||
|
||||
@deftogether[(
|
||||
@defproc[(data+root? [v any/c]) boolean?]
|
||||
@defproc[(make-data+root [data any/c] [root (or/c #f path-string?)]) data+root?]
|
||||
)]{
|
||||
|
||||
A value constructed by @racket[make-data+root] can be returned by a
|
||||
source procedure for @racket[load-xref] to specify a path used for
|
||||
deserialization.}
|
||||
|
|
|
|||
|
|
@ -26,6 +26,7 @@
|
|||
unstable/file
|
||||
racket/place
|
||||
pkg/lib
|
||||
pkg/strip
|
||||
(only-in net/url url->string path->url)
|
||||
(prefix-in html: scribble/html-render)
|
||||
(prefix-in latex: scribble/latex-render)
|
||||
|
|
@ -39,7 +40,16 @@
|
|||
|
||||
(define-logger setup)
|
||||
|
||||
(define-serializable-struct doc (src-dir src-spec src-file dest-dir flags under-main? pkg? category out-count)
|
||||
(define-serializable-struct doc (src-dir
|
||||
src-spec
|
||||
src-file
|
||||
dest-dir
|
||||
flags
|
||||
under-main?
|
||||
pkg?
|
||||
category
|
||||
out-count
|
||||
pre-rendered?)
|
||||
#:transparent)
|
||||
(define-serializable-struct info (doc ; doc structure above
|
||||
undef ; unresolved requires
|
||||
|
|
@ -137,8 +147,10 @@
|
|||
(apply validate i)))
|
||||
infos)])
|
||||
(and (not (memq #f infos)) infos))))
|
||||
(define ((get-docs main-dirs) i rec)
|
||||
(let* ([pre-s (and i (i 'scribblings))]
|
||||
(define ((get-docs main-dirs pre-rendered?) i rec)
|
||||
(let* ([pre-s (and i (i (if pre-rendered?
|
||||
'rendered-scribblings
|
||||
'scribblings)))]
|
||||
[s (validate-scribblings-infos pre-s)]
|
||||
[dir (directory-record-path rec)])
|
||||
(if s
|
||||
|
|
@ -151,7 +163,8 @@
|
|||
(or (memq 'main-doc flags)
|
||||
(hash-ref main-dirs dir #f)
|
||||
(pair? (path->main-collects-relative dir))))])
|
||||
(define src (doc-path dir (cadddr d) flags under-main?))
|
||||
(define src (simplify-path (build-path dir (car d)) #f))
|
||||
(define dest (doc-path dir (cadddr d) flags under-main?))
|
||||
(make-doc dir
|
||||
(let ([spec (directory-record-spec rec)])
|
||||
(list* (car spec)
|
||||
|
|
@ -161,25 +174,35 @@
|
|||
(list (directory-record-maj rec)
|
||||
(list '= (directory-record-min rec)))))
|
||||
(cdr spec))))
|
||||
(simplify-path (build-path dir (car d)) #f)
|
||||
src
|
||||
dest
|
||||
flags under-main? (and (path->pkg src) #t)
|
||||
(caddr d)
|
||||
(list-ref d 4))))
|
||||
(list-ref d 4)
|
||||
pre-rendered?)))
|
||||
s)
|
||||
(begin (setup-printf
|
||||
"WARNING"
|
||||
"bad 'scribblings info: ~e from: ~e" pre-s dir)
|
||||
"bad '~ascribblings info: ~e from: ~e"
|
||||
(if pre-rendered? "rendered-" "")
|
||||
pre-s dir)
|
||||
null))))
|
||||
(log-setup-info "getting documents")
|
||||
(define docs
|
||||
(let* ([recs (find-relevant-directory-records '(scribblings) 'all-available)]
|
||||
[r-recs (find-relevant-directory-records '(rendered-scribblings) 'all-available)]
|
||||
[main-dirs (parameterize ([current-library-collection-paths
|
||||
(list (find-collects-dir))])
|
||||
(for/hash ([k (in-list (find-relevant-directories '(scribblings) 'no-planet))])
|
||||
(for/hash ([k (in-list
|
||||
(append
|
||||
(find-relevant-directories '(rendered-scribblings) 'no-planet)
|
||||
(find-relevant-directories '(scribblings) 'no-planet)))])
|
||||
(values k #t)))]
|
||||
[infos (map get-info/full (map directory-record-path recs))])
|
||||
(filter-user-docs (append-map (get-docs main-dirs) infos recs) make-user?)))
|
||||
[infos (map get-info/full (map directory-record-path recs))]
|
||||
[r-infos (map get-info/full (map directory-record-path r-recs))])
|
||||
(filter-user-docs (append (append-map (get-docs main-dirs #f) infos recs)
|
||||
(append-map (get-docs main-dirs #t) r-infos r-recs))
|
||||
make-user?)))
|
||||
(define-values (main-docs user-docs) (partition doc-under-main? docs))
|
||||
|
||||
(when (and (or (not only-dirs) tidy?)
|
||||
|
|
@ -583,6 +606,7 @@
|
|||
(if multi?
|
||||
contract:override-render-mixin-multi
|
||||
contract:override-render-mixin-single)]
|
||||
[bundleable? (and (not main?) (doc-pkg? doc))]
|
||||
[local-redirect-file (build-path (if main?
|
||||
(find-doc-dir)
|
||||
(find-user-doc-dir))
|
||||
|
|
@ -613,11 +637,21 @@
|
|||
(if main?
|
||||
#t
|
||||
(build-path (find-user-doc-dir) "index.html")))]
|
||||
|
||||
;; In cross-reference information, use paths that are relative
|
||||
;; to the target rendering directory for documentation that might
|
||||
;; be moved into a binary package:
|
||||
[root-path (and bundleable? ddir)]
|
||||
|
||||
[search-box? #t]))
|
||||
(when (and (not main?) (doc-pkg? doc))
|
||||
(when bundleable?
|
||||
;; For documentation that might be moved into a binary package,
|
||||
;; use a server indirection for all links external to the
|
||||
;; document, but also install the "local-redirect.js" hook:
|
||||
(send r set-external-tag-path
|
||||
(format "http://pkg-docs.racket-lang.org?version=~a" (version)))
|
||||
(send r add-extra-script-file local-redirect-file))
|
||||
;; Result is the renderer:
|
||||
r)))
|
||||
|
||||
(define (pick-dest latex-dest doc)
|
||||
|
|
@ -724,18 +758,29 @@
|
|||
with-record-error setup-printf workerid
|
||||
only-fast? force-out-of-date? lock)
|
||||
doc)
|
||||
|
||||
;; First, move pre-rendered documentation into place
|
||||
(when (and (doc-pre-rendered? doc)
|
||||
(can-build? only-dirs doc)
|
||||
(or (not (directory-exists? (doc-dest-dir doc)))
|
||||
force-out-of-date?
|
||||
(not (file-exists? (build-path (doc-dest-dir doc) "synced.rktd")))))
|
||||
(move-documentation-into-place doc setup-printf workerid lock))
|
||||
|
||||
(let* ([info-out-files (for/list ([i (add1 (doc-out-count doc))])
|
||||
(sxref-path latex-dest doc (format "out~a.sxref" i)))]
|
||||
[info-in-file (sxref-path latex-dest doc "in.sxref")]
|
||||
[db-file (find-db-file doc latex-dest)]
|
||||
[stamp-file (sxref-path latex-dest doc "stamp.sxref")]
|
||||
[out-file (build-path (doc-dest-dir doc) "index.html")]
|
||||
[src-zo (let-values ([(base name dir?) (split-path (doc-src-file doc))])
|
||||
(define path (build-path base "compiled" (path-add-suffix name ".zo")))
|
||||
(or (for/or ([root (in-list (current-compiled-file-roots))])
|
||||
(define p (reroot-path* path root))
|
||||
(and (file-exists? p) p))
|
||||
path))]
|
||||
[src-zo (and
|
||||
(not (doc-pre-rendered? doc))
|
||||
(let-values ([(base name dir?) (split-path (doc-src-file doc))])
|
||||
(define path (build-path base "compiled" (path-add-suffix name ".zo")))
|
||||
(or (for/or ([root (in-list (current-compiled-file-roots))])
|
||||
(define p (reroot-path* path root))
|
||||
(and (file-exists? p) p))
|
||||
path)))]
|
||||
[renderer (make-renderer latex-dest doc)]
|
||||
[can-run? (can-build? only-dirs doc)]
|
||||
[stamp-time (file-or-directory-modify-seconds stamp-file #f (lambda () -inf.0))]
|
||||
|
|
@ -770,22 +815,25 @@
|
|||
[info-in-time (file-or-directory-modify-seconds info-in-file #f (lambda () #f))]
|
||||
[info-time (min (or info-out-time -inf.0) (or info-in-time -inf.0))]
|
||||
[vers (send renderer get-serialize-version)]
|
||||
[src-time (file-or-directory-modify-seconds/stamp
|
||||
src-zo
|
||||
stamp-time stamp-data 0
|
||||
get-compiled-file-sha1)]
|
||||
[src-time (and (not (doc-pre-rendered? doc))
|
||||
(file-or-directory-modify-seconds/stamp
|
||||
src-zo
|
||||
stamp-time stamp-data 0
|
||||
get-compiled-file-sha1))]
|
||||
[up-to-date?
|
||||
(and (not force-out-of-date?)
|
||||
info-out-time
|
||||
info-in-time
|
||||
(or (not can-run?)
|
||||
;; Need to rebuild if output file is older than input:
|
||||
(my-time . >= . src-time)
|
||||
;; But we can use in/out information if they're already built;
|
||||
;; this is mostly useful if we interrupt setup-plt after
|
||||
;; it runs some documents without rendering them:
|
||||
(info-time . >= . src-time)))]
|
||||
[can-run? (and (or (not latex-dest)
|
||||
(or (doc-pre-rendered? doc)
|
||||
(and (not force-out-of-date?)
|
||||
info-out-time
|
||||
info-in-time
|
||||
(or (not can-run?)
|
||||
;; Need to rebuild if output file is older than input:
|
||||
(my-time . >= . src-time)
|
||||
;; But we can use in/out information if they're already built;
|
||||
;; this is mostly useful if we interrupt setup-plt after
|
||||
;; it runs some documents without rendering them:
|
||||
(info-time . >= . src-time))))]
|
||||
[can-run? (and (not (doc-pre-rendered? doc))
|
||||
(or (not latex-dest)
|
||||
(not (omit? (doc-category doc))))
|
||||
(or can-run?
|
||||
(and auto-main?
|
||||
|
|
@ -907,7 +955,7 @@
|
|||
|
||||
(when (or (stamp-time . < . aux-time)
|
||||
(stamp-time . < . src-time))
|
||||
(let ([data (list (get-compiled-file-sha1 src-zo)
|
||||
(let ([data (list (and src-zo (get-compiled-file-sha1 src-zo))
|
||||
(get-compiled-file-sha1 renderer-path)
|
||||
(get-file-sha1 css-path))])
|
||||
(with-compile-output stamp-file (lambda (out tmp-filename) (write data out)))
|
||||
|
|
@ -918,6 +966,56 @@
|
|||
(lambda () #f))
|
||||
#f))))
|
||||
|
||||
(define (move-documentation-into-place doc setup-printf workerid lock)
|
||||
(define src-dir (let-values ([(base name dir?) (split-path (doc-src-file doc))])
|
||||
(build-path base "doc" (path-replace-suffix name #""))))
|
||||
(define dest-dir (doc-dest-dir doc))
|
||||
(define move? (not (equal? (file-or-directory-identity src-dir)
|
||||
(and (directory-exists? dest-dir)
|
||||
(file-or-directory-identity dest-dir)))))
|
||||
(setup-printf (string-append
|
||||
(if workerid (format "~a " workerid) "")
|
||||
(if move? "moving" "syncing"))
|
||||
"~a"
|
||||
(path->relative-string/setup src-dir))
|
||||
|
||||
(when move?
|
||||
(when (directory-exists? dest-dir)
|
||||
(delete-directory/files dest-dir)
|
||||
(copy-directory/files src-dir dest-dir)
|
||||
(delete-directory/files src-dir)))
|
||||
;; Register provided-tag information with the database:
|
||||
(let ([provides-path (build-path dest-dir "provides.sxref")])
|
||||
(when (file-exists? provides-path)
|
||||
;; register keys provided in "out<n>.sxref" with
|
||||
;; the database
|
||||
(define providess (call-with-input-file*
|
||||
provides-path
|
||||
(lambda (in) (fasl->s-exp in))))
|
||||
(define db-file (find-db-file doc #f))
|
||||
(for ([provides (in-list providess)]
|
||||
[n (in-naturals)])
|
||||
(define filename (sxref-path #f doc (format "out~a.sxref" n)))
|
||||
(call-with-lock
|
||||
lock
|
||||
(lambda ()
|
||||
(doc-db-clear-provides db-file filename)
|
||||
(doc-db-add-provides db-file provides filename))))))
|
||||
;; For each ".html" file, check for a reference to "local-redirect.js",
|
||||
;; and fix up the path if there is a reference:
|
||||
(define js-path (if (doc-under-main? doc)
|
||||
"../local-redirect"
|
||||
(url->string (path->url (build-path (find-user-doc-dir)
|
||||
"local-redirect")))))
|
||||
(for ([p (in-directory dest-dir)])
|
||||
(when (regexp-match? #rx#"[.]html$" (path->bytes p))
|
||||
(fixup-local-redirect-reference p js-path)))
|
||||
;; The existence of "synced.rktd" means that the db is in sync
|
||||
;; with "provides.sxref" and ".html" files have been updated.
|
||||
(let ([provided-path (build-path dest-dir "synced.rktd")])
|
||||
(unless (file-exists? provided-path)
|
||||
(call-with-output-file provided-path (lambda (o) (write '#t o))))))
|
||||
|
||||
(define (read-delayed-in! info latex-dest)
|
||||
(let* ([doc (info-doc info)]
|
||||
[info-in-file (sxref-path latex-dest doc "in.sxref")]
|
||||
|
|
@ -1127,7 +1225,15 @@
|
|||
lock
|
||||
(lambda ()
|
||||
(doc-db-clear-provides db-file filename)
|
||||
(doc-db-add-provides db-file provides filename)))))))
|
||||
(doc-db-add-provides db-file provides filename))))))
|
||||
;; Used for a package is converted to "binary" form:
|
||||
(when (and (doc-pkg? doc)
|
||||
(not (doc-under-main? doc))
|
||||
(not latex-dest))
|
||||
(with-compile-output
|
||||
(sxref-path latex-dest doc "provides.sxref")
|
||||
(lambda (out tmp-filename)
|
||||
(s-exp->fasl providess out)))))
|
||||
|
||||
(define (write-out/info latex-dest info scis providess db-file lock)
|
||||
(write-out latex-dest (info-vers info) (info-doc info) scis providess db-file lock))
|
||||
|
|
|
|||
|
|
@ -597,9 +597,11 @@
|
|||
info
|
||||
'clean
|
||||
(lambda ()
|
||||
(list mode-dir
|
||||
(build-path mode-dir "native")
|
||||
(build-path mode-dir "native" (system-library-subpath))))
|
||||
(if (info 'assume-virtual-sources (lambda () #f))
|
||||
null
|
||||
(list mode-dir
|
||||
(build-path mode-dir "native")
|
||||
(build-path mode-dir "native" (system-library-subpath)))))
|
||||
(lambda (x)
|
||||
(unless (list-of path-string? x)
|
||||
(error name-sym
|
||||
|
|
|
|||
|
|
@ -14,19 +14,19 @@
|
|||
|
||||
(define cached-xref #f)
|
||||
|
||||
(define (get-dests no-user?)
|
||||
(define (get-dests tag no-user?)
|
||||
(define main-dirs
|
||||
(parameterize ([current-library-collection-paths
|
||||
(let ([d (find-collects-dir)])
|
||||
(if d (list d) null))])
|
||||
(for/hash ([k (in-list (find-relevant-directories '(scribblings) 'no-planet))])
|
||||
(for/hash ([k (in-list (find-relevant-directories (list tag) 'no-planet))])
|
||||
(values k #t))))
|
||||
(apply
|
||||
append
|
||||
(for*/list ([dir (find-relevant-directories '(scribblings) 'all-available)]
|
||||
(for*/list ([dir (find-relevant-directories (list tag) 'all-available)]
|
||||
[d (let ([info-proc (get-info/full dir)])
|
||||
(if info-proc
|
||||
(info-proc 'scribblings)
|
||||
(info-proc tag)
|
||||
'()))])
|
||||
(unless (and (list? d) (pair? d))
|
||||
(error 'xref "bad scribblings entry: ~e" d))
|
||||
|
|
@ -63,7 +63,11 @@
|
|||
(exn-message exn)
|
||||
(format "~e" exn)))
|
||||
#f)])
|
||||
(cadr (call-with-input-file* dest fasl->s-exp))))))
|
||||
(make-data+root
|
||||
;; data to deserialize:
|
||||
(cadr (call-with-input-file* dest fasl->s-exp))
|
||||
;; provide a root for deserialization:
|
||||
(path-only dest))))))
|
||||
|
||||
(define (make-key->source db-path no-user?)
|
||||
(define main-db (cons (or db-path
|
||||
|
|
@ -119,7 +123,8 @@
|
|||
|
||||
(define (get-reader-thunks no-user? done-ht)
|
||||
(map (dest->source done-ht)
|
||||
(filter values (get-dests no-user?))))
|
||||
(filter values (append (get-dests 'scribblings no-user?)
|
||||
(get-dests 'rendered-scribblings no-user?)))))
|
||||
|
||||
(define (load-collections-xref [report-loading void])
|
||||
(or cached-xref
|
||||
|
|
|
|||
50
collects/tests/pkg/test-docs.rkt
Normal file
50
collects/tests/pkg/test-docs.rkt
Normal file
|
|
@ -0,0 +1,50 @@
|
|||
#lang racket/base
|
||||
(require setup/xref
|
||||
scribble/xref
|
||||
racket/path
|
||||
net/url
|
||||
rackunit)
|
||||
|
||||
;; The `test-docs-...' functions are meant to be called via "tests-binary.rkt"
|
||||
(provide test-docs-x
|
||||
test-docs-y
|
||||
test-docs-r)
|
||||
|
||||
(define xref (load-collections-xref))
|
||||
|
||||
(define (test here? tag)
|
||||
(check-equal? here? (and tag #t))
|
||||
(when tag
|
||||
(define-values (p a) (xref-tag->path+anchor xref tag))
|
||||
(check-true (path? p))
|
||||
(call-with-input-file*
|
||||
p
|
||||
(lambda (in)
|
||||
(define m (regexp-match #rx"<script [^>]*src=\"([^\"]*)local-redirect.js\"[^>]*>" in))
|
||||
(define ref (url->path
|
||||
(string->url
|
||||
(bytes->string/utf-8
|
||||
(if (equal? (cadr m) #"")
|
||||
#"."
|
||||
(cadr m))))))
|
||||
(define path (if (absolute-path? ref)
|
||||
(build-path ref
|
||||
"local-redirect.js")
|
||||
(build-path (path-only p)
|
||||
ref
|
||||
"local-redirect.js")))
|
||||
(check-true (file-exists? path))))))
|
||||
|
||||
(define (test-docs-x here?)
|
||||
(when (collection-path "x" #:fail (lambda (x) #f))
|
||||
(namespace-require '(for-label x)))
|
||||
(test here? (xref-binding->definition-tag xref (eval '#'x) #f)))
|
||||
|
||||
(define (test-docs-y here?)
|
||||
(when (collection-path "y" #:fail (lambda (x) #f))
|
||||
(namespace-require '(for-label y)))
|
||||
(test here? (xref-binding->definition-tag xref (eval '#'y) #f)))
|
||||
|
||||
(define (test-docs-r here?)
|
||||
(namespace-require '(for-label racket/base))
|
||||
(test here? (xref-binding->definition-tag xref (eval '#'lambda) #f)))
|
||||
1
collects/tests/pkg/test-pkgs/.gitignore
vendored
1
collects/tests/pkg/test-pkgs/.gitignore
vendored
|
|
@ -4,3 +4,4 @@ MANIFEST
|
|||
*plt
|
||||
*CHECKSUM
|
||||
pkg-test1b*
|
||||
/src-pkg/
|
||||
|
|
|
|||
7
collects/tests/pkg/test-pkgs/pkg-x/info.rkt
Normal file
7
collects/tests/pkg/test-pkgs/pkg-x/info.rkt
Normal file
|
|
@ -0,0 +1,7 @@
|
|||
#lang setup/infotab
|
||||
|
||||
(define deps '("pkg-z"))
|
||||
(define build-deps '("pkg-y"))
|
||||
|
||||
(define binary-omit-files '("nobin-top.txt"))
|
||||
(define source-omit-files '("nosrc-top.txt"))
|
||||
0
collects/tests/pkg/test-pkgs/pkg-x/nobin-top.txt
Normal file
0
collects/tests/pkg/test-pkgs/pkg-x/nobin-top.txt
Normal file
0
collects/tests/pkg/test-pkgs/pkg-x/nosrc-top.txt
Normal file
0
collects/tests/pkg/test-pkgs/pkg-x/nosrc-top.txt
Normal file
9
collects/tests/pkg/test-pkgs/pkg-x/x/info.rkt
Normal file
9
collects/tests/pkg/test-pkgs/pkg-x/x/info.rkt
Normal file
|
|
@ -0,0 +1,9 @@
|
|||
#lang setup/infotab
|
||||
|
||||
(define scribblings '(("x.scrbl")))
|
||||
|
||||
(define binary-omit-files '("nobin.txt"))
|
||||
(define source-omit-files '("nosrc.txt"))
|
||||
|
||||
(define binary-keep-files '("keep.scrbl"))
|
||||
(define source-keep-files '("keep/doc"))
|
||||
3
collects/tests/pkg/test-pkgs/pkg-x/x/keep.scrbl
Normal file
3
collects/tests/pkg/test-pkgs/pkg-x/x/keep.scrbl
Normal file
|
|
@ -0,0 +1,3 @@
|
|||
#lang scribble/base
|
||||
|
||||
Keep
|
||||
1
collects/tests/pkg/test-pkgs/pkg-x/x/keep/doc/keep.txt
Normal file
1
collects/tests/pkg/test-pkgs/pkg-x/x/keep/doc/keep.txt
Normal file
|
|
@ -0,0 +1 @@
|
|||
Keep this.
|
||||
7
collects/tests/pkg/test-pkgs/pkg-x/x/main.rkt
Normal file
7
collects/tests/pkg/test-pkgs/pkg-x/x/main.rkt
Normal file
|
|
@ -0,0 +1,7 @@
|
|||
#lang racket/base
|
||||
(require z)
|
||||
|
||||
(provide x)
|
||||
|
||||
(define (x)
|
||||
(if (eq? (z) 'z) 'x 'ouch))
|
||||
0
collects/tests/pkg/test-pkgs/pkg-x/x/nobin.txt
Normal file
0
collects/tests/pkg/test-pkgs/pkg-x/x/nobin.txt
Normal file
0
collects/tests/pkg/test-pkgs/pkg-x/x/nosrc.txt
Normal file
0
collects/tests/pkg/test-pkgs/pkg-x/x/nosrc.txt
Normal file
10
collects/tests/pkg/test-pkgs/pkg-x/x/x.scrbl
Normal file
10
collects/tests/pkg/test-pkgs/pkg-x/x/x.scrbl
Normal file
|
|
@ -0,0 +1,10 @@
|
|||
#lang scribble/manual
|
||||
@(require (for-label x y racket/base))
|
||||
|
||||
@title{X}
|
||||
|
||||
@defmodule[x]
|
||||
|
||||
@defproc[(x) symbol?]{
|
||||
|
||||
The same as @racket[y], but returns @racket['x]}
|
||||
4
collects/tests/pkg/test-pkgs/pkg-y/info.rkt
Normal file
4
collects/tests/pkg/test-pkgs/pkg-y/info.rkt
Normal file
|
|
@ -0,0 +1,4 @@
|
|||
#lang setup/infotab
|
||||
|
||||
(define build-deps '("pkg-x"))
|
||||
|
||||
3
collects/tests/pkg/test-pkgs/pkg-y/y/info.rkt
Normal file
3
collects/tests/pkg/test-pkgs/pkg-y/y/info.rkt
Normal file
|
|
@ -0,0 +1,3 @@
|
|||
#lang setup/infotab
|
||||
|
||||
(define scribblings '(("y.scrbl")))
|
||||
6
collects/tests/pkg/test-pkgs/pkg-y/y/main.rkt
Normal file
6
collects/tests/pkg/test-pkgs/pkg-y/y/main.rkt
Normal file
|
|
@ -0,0 +1,6 @@
|
|||
#lang racket/base
|
||||
|
||||
(provide y)
|
||||
|
||||
(define (y)
|
||||
(if (zero? (random 1)) 'y 'ouch))
|
||||
10
collects/tests/pkg/test-pkgs/pkg-y/y/y.scrbl
Normal file
10
collects/tests/pkg/test-pkgs/pkg-y/y/y.scrbl
Normal file
|
|
@ -0,0 +1,10 @@
|
|||
#lang scribble/manual
|
||||
@(require (for-label y x racket/base))
|
||||
|
||||
@title{Y}
|
||||
|
||||
@defmodule[y]
|
||||
|
||||
@defproc[(y) symbol?]{
|
||||
|
||||
The same as @racket[y], but returns @racket['y]}
|
||||
2
collects/tests/pkg/test-pkgs/pkg-z/info.rkt
Normal file
2
collects/tests/pkg/test-pkgs/pkg-z/info.rkt
Normal file
|
|
@ -0,0 +1,2 @@
|
|||
#lang setup/infotab
|
||||
|
||||
7
collects/tests/pkg/test-pkgs/pkg-z/z/main.rkt
Normal file
7
collects/tests/pkg/test-pkgs/pkg-z/z/main.rkt
Normal file
|
|
@ -0,0 +1,7 @@
|
|||
#lang racket/base
|
||||
(provide z)
|
||||
|
||||
(define z #f)
|
||||
(set! z (lambda () 'z))
|
||||
|
||||
|
||||
|
|
@ -54,4 +54,5 @@
|
|||
"versions"
|
||||
"platform"
|
||||
"raco"
|
||||
"binary"
|
||||
"catalogs")
|
||||
|
|
|
|||
126
collects/tests/pkg/tests-binary.rkt
Normal file
126
collects/tests/pkg/tests-binary.rkt
Normal file
|
|
@ -0,0 +1,126 @@
|
|||
#lang racket/base
|
||||
(require "shelly.rkt"
|
||||
"util.rkt"
|
||||
racket/file
|
||||
file/unzip)
|
||||
|
||||
(pkg-tests
|
||||
|
||||
$ "raco pkg install --deps fail test-pkgs/pkg-x/" =exit> 1
|
||||
$ "raco pkg install --deps fail test-pkgs/pkg-y/" =exit> 1
|
||||
$ "raco pkg install --deps fail test-pkgs/pkg-x/ test-pkgs/pkg-z/" =exit> 1
|
||||
$ "raco pkg install --deps fail test-pkgs/pkg-y/ test-pkgs/pkg-z/" =exit> 1
|
||||
$ "raco pkg install --deps fail test-pkgs/pkg-x/ test-pkgs/pkg-y/" =exit> 1
|
||||
$ "raco pkg install --deps fail test-pkgs/pkg-y/ test-pkgs/pkg-x/" =exit> 1
|
||||
|
||||
$ "raco pkg install --deps fail test-pkgs/pkg-z/" =exit> 0
|
||||
|
||||
(putenv "PLT_PKG_NOSETUP" "")
|
||||
$ "raco pkg install test-pkgs/pkg-x/ test-pkgs/pkg-y/"
|
||||
(putenv "PLT_PKG_NOSETUP" "1")
|
||||
|
||||
$ "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 -t test-docs.rkt -e '(test-docs-x #t)'"
|
||||
$ "racket -l racket/base -t test-docs.rkt -e '(test-docs-y #t)'"
|
||||
|
||||
(make-directory* "test-pkgs/src-pkgs")
|
||||
$ "raco pkg create --from-install --source --dest test-pkgs/src-pkgs pkg-x"
|
||||
$ "raco pkg create --from-install --source --dest test-pkgs/src-pkgs pkg-y"
|
||||
$ "raco pkg create --from-install --source --dest test-pkgs/src-pkgs pkg-z"
|
||||
|
||||
$ "raco pkg create --from-install --binary --dest test-pkgs pkg-x"
|
||||
$ "raco pkg create --from-install --binary --dest test-pkgs pkg-y"
|
||||
$ "raco pkg create --from-install --binary --dest test-pkgs pkg-z"
|
||||
|
||||
(putenv "PLT_PKG_NOSETUP" "")
|
||||
$ "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)'"
|
||||
|
||||
(define tmp-dir (make-temporary-file "unpack-~a" 'directory))
|
||||
(make-directory* tmp-dir)
|
||||
(define (unpack name)
|
||||
(define orig-d (current-directory))
|
||||
(let ([z (path->complete-path (format "test-pkgs/src-pkgs/pkg-~a.zip" name))])
|
||||
(define d (build-path tmp-dir name))
|
||||
(make-directory* d)
|
||||
(parameterize ([current-directory d])
|
||||
(unzip z)
|
||||
(for ([f (in-directory)])
|
||||
(define orig-f (build-path orig-d (format "test-pkgs/pkg-~a" name) f))
|
||||
(unless (if (file-exists? f)
|
||||
(file-exists? orig-f)
|
||||
(directory-exists? orig-f))
|
||||
(error 'diff "extra ~s" f))
|
||||
(when (file-exists? f)
|
||||
(unless (equal? (file->bytes f)
|
||||
(file->bytes orig-f))
|
||||
(error 'diff "file differs ~s" f)))))
|
||||
(parameterize ([current-directory (format "test-pkgs/pkg-~a" name)])
|
||||
(for ([f (in-directory)])
|
||||
(define new-f (build-path d f))
|
||||
(unless (if (file-exists? f)
|
||||
(file-exists? new-f)
|
||||
(directory-exists? new-f))
|
||||
(unless (regexp-match? #rx#"nosrc" (path->bytes f))
|
||||
(error 'diff "missing ~s" new-f)))))))
|
||||
(unpack "x")
|
||||
(unpack "y")
|
||||
(unpack "z")
|
||||
(delete-directory/files tmp-dir)
|
||||
|
||||
(make-directory* tmp-dir)
|
||||
(define (unpack-bin name)
|
||||
(let ([z (path->complete-path (format "test-pkgs/pkg-~a.zip" name))])
|
||||
(define d (build-path tmp-dir name))
|
||||
(make-directory* d)
|
||||
(parameterize ([current-directory d])
|
||||
(unzip z)
|
||||
(for ([f (in-directory)])
|
||||
(when (or (regexp-match? #rx#"[.](?:rkt|scrbl)$" (path->bytes f))
|
||||
(regexp-match? #rx#"nobin" (path->bytes f)))
|
||||
(unless (regexp-match? #rx#"(?:info[.]rkt|keep.scrbl)$" (path->bytes f))
|
||||
(error 'binary "extra ~s" f)))))))
|
||||
(unpack-bin "x")
|
||||
(unpack-bin "y")
|
||||
(unpack-bin "z")
|
||||
(delete-directory/files tmp-dir)
|
||||
|
||||
(shelly-case
|
||||
"source-package dependencies like original"
|
||||
$ "raco pkg install --deps fail test-pkgs/src-pkgs/pkg-x.zip" =exit> 1
|
||||
$ "raco pkg install --deps fail test-pkgs/src-pkgs/pkg-y.zip" =exit> 1
|
||||
$ "raco pkg install --deps fail test-pkgs/src-pkgs/pkg-x.zip test-pkgs/src-pkgs/pkg-z.zip" =exit> 1
|
||||
$ "raco pkg install --deps fail test-pkgs/src-pkgs/pkg-y.zip test-pkgs/src-pkgs/pkg-z.zip" =exit> 1
|
||||
$ "raco pkg install --deps fail test-pkgs/src-pkgs/pkg-x.zip test-pkgs/src-pkgs/pkg-y.zip" =exit> 1
|
||||
$ "raco pkg install --deps fail test-pkgs/src-pkgs/pkg-y.zip test-pkgs/src-pkgs/pkg-x.zip" =exit> 1)
|
||||
|
||||
(shelly-case
|
||||
"binary-package dependencies are less"
|
||||
$ "raco pkg install --deps fail test-pkgs/pkg-x.zip" =exit> 1
|
||||
|
||||
$ "raco pkg install --deps fail test-pkgs/pkg-x.zip test-pkgs/pkg-z.zip"
|
||||
$ "raco pkg remove pkg-x pkg-z"
|
||||
$ "raco pkg install --deps fail test-pkgs/pkg-y.zip"
|
||||
$ "raco pkg remove pkg-y")
|
||||
|
||||
(putenv "PLT_PKG_NOSETUP" "")
|
||||
$ "raco pkg install --deps fail test-pkgs/pkg-y.zip"
|
||||
(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 #t)'"
|
||||
|
||||
(shelly-case
|
||||
"check that cleaning doesn't destroy a binary install"
|
||||
$ "racket -l y"
|
||||
$ "raco setup -c -l y"
|
||||
$ "racket -l y")
|
||||
|
||||
$ "raco pkg remove pkg-y"
|
||||
|
||||
)
|
||||
Loading…
Reference in New Issue
Block a user