planet print, planet structure commands
svn: r9403
This commit is contained in:
Jacob Matthews
parent
8203977a21
commit
c40da0feb8
|
|
@ -212,7 +212,7 @@ If the PLaneT client doesn't have any previous linkage information, it
|
|||
checks its list of already-installed PLaneT packages for one that
|
||||
meets the requirement, and uses it if available. Both PLaneT-installed
|
||||
packages and packages established through a development link
|
||||
(see @secref["devlinks"])
|
||||
(see @secref{devlinks})
|
||||
are checked simultaneously at this stage.
|
||||
|
||||
@subsection{Acceptable Remote Package}
|
||||
|
|
@ -245,18 +245,23 @@ command line as
|
|||
where @italic{command} is a subcommand from the following list, and
|
||||
@exec{arg} is a sequence of arguments determined by that subcommand:
|
||||
|
||||
@(define (cmd name desc)
|
||||
@item{@(seclink name (exec name)): @desc})
|
||||
|
||||
@itemize{
|
||||
@item{@exec{create}: create a PLaneT archive from a directory}
|
||||
@item{@exec{install}: download and install a given package}
|
||||
@item{@exec{remove}: remove the specified package from the local cache}
|
||||
@item{@exec{show}: list the packages installed in the local cache}
|
||||
@item{@exec{clearlinks}: clear the linkage table, allowing upgrades}
|
||||
@item{@exec{fileinject}: install a local file to the planet cache}
|
||||
@item{@exec{link}: create a development link}
|
||||
@item{@exec{unlink}: remove development link associated with the given package}
|
||||
@item{@exec{fetch}: download a package file without installing it}
|
||||
@item{@exec{url}: get a URL for the given package}
|
||||
@item{@exec{open}: unpack the contents of the given package}}
|
||||
@cmd["create"]{create a PLaneT archive from a directory}
|
||||
@cmd["install"]{download and install a given package}
|
||||
@cmd["remove"]{remove the specified package from the local cache}
|
||||
@cmd["show"]{list the packages installed in the local cache}
|
||||
@cmd["clearlinks"]{clear the linkage table, allowing upgrades}
|
||||
@cmd["fileinject"]{install a local file to the planet cache}
|
||||
@cmd["link"]{create a development link}
|
||||
@cmd["unlink"]{remove development link associated with the given package}
|
||||
@cmd["fetch"]{download a package file without installing it}
|
||||
@cmd["url"]{get a URL for the given package}
|
||||
@cmd["open"]{unpack the contents of the given package}
|
||||
@cmd["structure"]{display the structure of a given .plt archive}
|
||||
@cmd["print"]{display a file within of the given .plt archive}}
|
||||
|
||||
Each of these commands is described in more detail below. All the
|
||||
functionality of the command-line tool is also provided with a programmatic interface by
|
||||
|
|
@ -323,14 +328,15 @@ the given file's filename as the its package name, and the given major and minor
|
|||
|
||||
Usage:
|
||||
@commandline{planet link <owner> <pkg> <maj> <min> <path>}
|
||||
Create a development link between the given package specifier and the
|
||||
specified directory name.
|
||||
Create a development link (see @secref{devlinks}) between the given
|
||||
package specifier and the specified directory name.
|
||||
|
||||
@subsection[#:tag "unlink"]{@exec{unlink}}
|
||||
|
||||
Usage:
|
||||
@commandline{planet unlink <owner> <pkg> <maj> <min>}
|
||||
Remove any development link associated with the given package.
|
||||
Remove any development link (see @secref{devlinks}) associated with
|
||||
the given package.
|
||||
|
||||
@subsection[#:tag "fetch"]{@exec{fetch}}
|
||||
|
||||
|
|
@ -357,6 +363,25 @@ installing.
|
|||
This command is not necessary for normal use of planet. It is intended to allow
|
||||
you to inspect package contents offline without needing to install the package.
|
||||
|
||||
@subsection[#:tag "structure"]{@exec{structure}}
|
||||
|
||||
Usage:
|
||||
@commandline{planet structure <plt-file>}
|
||||
Print the structure of the PLaneT archive named by <plt-file> to the standard
|
||||
output port.
|
||||
|
||||
This command does not unpack or install the named .plt file.
|
||||
|
||||
@subsection[#:tag "print"]{@exec{print}}
|
||||
|
||||
Usage:
|
||||
@commandline{planet print <plt-file> <path>}
|
||||
|
||||
Print the contents of the file named by <path>, which must be a relative path
|
||||
within the PLaneT archive named by <plt-file>, to the standard output port.
|
||||
|
||||
This command does not unpack or install the named .plt file.
|
||||
|
||||
@section{Utility Libraries}
|
||||
|
||||
The planet collection provides configuration and utilities for using PLaneT.
|
||||
|
|
@ -477,6 +502,17 @@ into the given directory (creating that path if necessary).}
|
|||
any]{
|
||||
Removes the specified package from the local planet cache.}
|
||||
|
||||
@defproc[(display-plt-file-structure [plt-file (or/c path-string? path?)])
|
||||
any]{
|
||||
Print a tree representing the file and directory structure of the
|
||||
PLaneT archive .plt file named by @scheme[plt-file] to @scheme[(current-output-port)].}
|
||||
|
||||
@defproc[(display-plt-archived-file [plt-file (or/c path-string? path?)]
|
||||
[file-to-print string?])
|
||||
any]{
|
||||
Print the contents of the file named @scheme[file-to-print] within the
|
||||
PLaneT archive .plt file named by @scheme[plt-file] to @scheme[(current-output-port)].}
|
||||
|
||||
@defproc[(unlink-all) any]{
|
||||
Removes the entire linkage table from the system, which will force all
|
||||
modules to relink themselves to PLaneT modules the next time they run.}
|
||||
|
|
|
|||
|
|
@ -98,6 +98,18 @@ This command is not necessary for normal use of planet. It is intended to allow
|
|||
#:args (plt-file target)
|
||||
(do-unpack plt-file target)]
|
||||
|
||||
["structure" "display the structure of a given .plt archive"
|
||||
"\nPrint the structure of the PLaneT archive named by <plt-file> to the standard output port.
|
||||
This command does not unpack or install the named .plt file."
|
||||
#:args (plt-file)
|
||||
(do-structure plt-file)]
|
||||
|
||||
["print" "display a file within of the given .plt archive"
|
||||
"\nPrint the contents of the file named by <path>, which must be a relative path within the PLaneT archive named by <plt-file>, to the standard output port.
|
||||
This command does not unpack or install the named .plt file."
|
||||
#:args (plt-file path)
|
||||
(do-display plt-file path)]
|
||||
|
||||
;; unimplemented so far:
|
||||
#;(("-u" "--unlink")
|
||||
module
|
||||
|
|
@ -246,6 +258,18 @@ This command is not necessary for normal use of planet. It is intended to allow
|
|||
(let ([file (normalize-path plt-file)])
|
||||
(unpack-planet-archive file target)))
|
||||
|
||||
(define (do-structure plt-file)
|
||||
(unless (file-exists? plt-file)
|
||||
(fail (format "The specified file (~a) does not exist" plt-file)))
|
||||
(let ([file (normalize-path plt-file)])
|
||||
(display-plt-file-structure file)))
|
||||
|
||||
(define (do-display plt-file file-to-print)
|
||||
(unless (file-exists? plt-file)
|
||||
(fail (format "The specified file (~a) does not exist" plt-file)))
|
||||
(let ([file (normalize-path plt-file)])
|
||||
(display-plt-archived-file file file-to-print)))
|
||||
|
||||
;; ------------------------------------------------------------
|
||||
;; Utility
|
||||
|
||||
|
|
@ -259,12 +283,6 @@ This command is not necessary for normal use of planet. It is intended to allow
|
|||
[(not ((cadar c) (car a) (car b))) #f]
|
||||
[else (loop (cdr a) (cdr b) (cdr c))])))))
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
;; ============================================================
|
||||
;; start the program
|
||||
|
||||
|
|
|
|||
|
|
@ -1,39 +1,46 @@
|
|||
(module util mzscheme
|
||||
#lang scheme
|
||||
|
||||
(require "config.ss"
|
||||
(require "config.ss"
|
||||
"planet-archives.ss"
|
||||
|
||||
"private/planet-shared.ss"
|
||||
"private/linkage.ss"
|
||||
"resolver.ss"
|
||||
net/url
|
||||
(lib "xml.ss" "xml")
|
||||
xml/xml
|
||||
mzlib/contract
|
||||
mzlib/file
|
||||
mzlib/list
|
||||
(lib "pack.ss" "setup")
|
||||
(lib "plt-single-installer.ss" "setup")
|
||||
(lib "getinfo.ss" "setup")
|
||||
(lib "unpack.ss" "setup")
|
||||
mzlib/etc)
|
||||
mzlib/etc
|
||||
scheme/port
|
||||
scheme/path
|
||||
|
||||
#| The util collection provides a number of useful functions for interacting with the PLaneT system. |#
|
||||
setup/pack
|
||||
setup/plt-single-installer
|
||||
setup/getinfo
|
||||
setup/unpack
|
||||
setup/scribble)
|
||||
|
||||
(provide
|
||||
#| The util collection provides a number of useful functions for interacting with the PLaneT system. |#
|
||||
|
||||
(provide
|
||||
|
||||
current-cache-contents
|
||||
current-linkage
|
||||
make-planet-archive
|
||||
unpack-planet-archive
|
||||
force-package-building?
|
||||
build-scribble-docs?
|
||||
get-installed-planet-archives
|
||||
get-hard-linked-packages
|
||||
unlink-all
|
||||
lookup-package-by-keys
|
||||
resolve-planet-path
|
||||
(struct exn:fail:planet ()))
|
||||
(struct-out exn:fail:planet)
|
||||
display-plt-file-structure
|
||||
display-plt-archived-file)
|
||||
|
||||
(provide/contract
|
||||
(provide/contract
|
||||
[download/install-pkg
|
||||
(-> string? string? natural-number/c natural-number/c (union pkg? false/c))]
|
||||
[add-hard-link
|
||||
|
|
@ -45,8 +52,8 @@
|
|||
[erase-pkg
|
||||
(-> string? string? natural-number/c natural-number/c void?)])
|
||||
|
||||
;; download/install-pkg : string string nat nat -> pkg | #f
|
||||
(define (download/install-pkg owner name maj min)
|
||||
;; download/install-pkg : string string nat nat -> pkg | #f
|
||||
(define (download/install-pkg owner name maj min)
|
||||
(let* ([pspec (pkg-spec->full-pkg-spec (list owner name maj min) #f)]
|
||||
[upkg (get-package-from-server pspec)])
|
||||
(cond
|
||||
|
|
@ -54,24 +61,24 @@
|
|||
(pkg-promise->pkg upkg)]
|
||||
[else #f])))
|
||||
|
||||
;; current-cache-contents : -> ((string ((string ((nat (nat ...)) ...)) ...)) ...)
|
||||
;; returns the packages installed in the local PLaneT cache
|
||||
(define (current-cache-contents)
|
||||
;; current-cache-contents : -> ((string ((string ((nat (nat ...)) ...)) ...)) ...)
|
||||
;; returns the packages installed in the local PLaneT cache
|
||||
(define (current-cache-contents)
|
||||
(cdr (tree->list (repository-tree))))
|
||||
|
||||
;; just so it will be provided
|
||||
(define unlink-all remove-all-linkage!)
|
||||
;; just so it will be provided
|
||||
(define unlink-all remove-all-linkage!)
|
||||
|
||||
;; to remove:
|
||||
;; -- setup-plt -c the package
|
||||
;; -- remove relevant infodomain cache entries
|
||||
;; -- delete files from cache directory
|
||||
;; -- remove any existing linkage for package
|
||||
;; returns void if the removal worked; raises an exception if no package existed.
|
||||
;; to remove:
|
||||
;; -- setup-plt -c the package
|
||||
;; -- remove relevant infodomain cache entries
|
||||
;; -- delete files from cache directory
|
||||
;; -- remove any existing linkage for package
|
||||
;; returns void if the removal worked; raises an exception if no package existed.
|
||||
|
||||
(define-struct (exn:fail:planet exn:fail) ())
|
||||
(define-struct (exn:fail:planet exn:fail) ())
|
||||
|
||||
(define (remove-pkg owner name maj min)
|
||||
(define (remove-pkg owner name maj min)
|
||||
(let ((p (get-installed-package owner name maj min)))
|
||||
(unless p
|
||||
(raise (make-exn:fail:planet "Could not find package" (current-continuation-marks))))
|
||||
|
|
@ -89,18 +96,18 @@
|
|||
(trim-directory (CACHE-DIR) path)
|
||||
(void))))
|
||||
|
||||
;; erase-metadata : pkg -> void
|
||||
;; clears out any references to the given package in planet's metadata files
|
||||
;; (i.e., linkage and info.ss cache; not hard links which are not considered metadata)
|
||||
(define (erase-metadata p)
|
||||
;; erase-metadata : pkg -> void
|
||||
;; clears out any references to the given package in planet's metadata files
|
||||
;; (i.e., linkage and info.ss cache; not hard links which are not considered metadata)
|
||||
(define (erase-metadata p)
|
||||
(remove-infodomain-entries (pkg-path p))
|
||||
(remove-linkage-to! p))
|
||||
|
||||
;; this really should go somewhere else. But what should setup's behavior be
|
||||
;; when a package is cleaned? should it clear info-domain entries out? I think
|
||||
;; no; an uncompiled package isn't necessarily not to be indexed and so on.
|
||||
;; remove-infodomain-entries : path -> void
|
||||
(define (remove-infodomain-entries path)
|
||||
;; this really should go somewhere else. But what should setup's behavior be
|
||||
;; when a package is cleaned? should it clear info-domain entries out? I think
|
||||
;; no; an uncompiled package isn't necessarily not to be indexed and so on.
|
||||
;; remove-infodomain-entries : path -> void
|
||||
(define (remove-infodomain-entries path)
|
||||
(let* ([pathbytes (path->bytes path)]
|
||||
[cache-file (build-path (PLANET-DIR) "cache.ss")])
|
||||
(when (file-exists? cache-file)
|
||||
|
|
@ -118,29 +125,29 @@
|
|||
cache-lines)
|
||||
op)
|
||||
(fprintf op "\n")))
|
||||
'truncate/replace)))))
|
||||
#:exists 'truncate/replace)))))
|
||||
|
||||
;; subpath? : path path -> boolean
|
||||
;; determines if p1 is a subpath of p2. Both paths must actually exist on the filesystem
|
||||
(define (subpath? p1 p2)
|
||||
;; subpath? : path path -> boolean
|
||||
;; determines if p1 is a subpath of p2. Both paths must actually exist on the filesystem
|
||||
(define (subpath? p1 p2)
|
||||
(let ([full-p1 (explode-path (normalize-path p1))]
|
||||
[full-p2 (explode-path (normalize-path p2))])
|
||||
(sublist? full-p1 full-p2 (o2 bytes=? path->bytes))))
|
||||
|
||||
;; o2 : (X X -> Y) (Z -> X) -> (Z Z -> Y)
|
||||
;; "compose-two"
|
||||
(define (o2 a b) (λ (x y) (a (b x) (b y))))
|
||||
;; o2 : (X X -> Y) (Z -> X) -> (Z Z -> Y)
|
||||
;; "compose-two"
|
||||
(define (o2 a b) (λ (x y) (a (b x) (b y))))
|
||||
|
||||
;; sublist? : (listof X) (listof X) (X X -> boolean) -> boolean
|
||||
;; determine if l1 is a sublist of l2, using = as the comparison operator for elements
|
||||
(define (sublist? l1 l2 =)
|
||||
;; sublist? : (listof X) (listof X) (X X -> boolean) -> boolean
|
||||
;; determine if l1 is a sublist of l2, using = as the comparison operator for elements
|
||||
(define (sublist? l1 l2 =)
|
||||
(cond
|
||||
[(null? l1) #t]
|
||||
[(null? l2) #f]
|
||||
[(= (car l1) (car l2)) (sublist? (cdr l1) (cdr l2) =)]
|
||||
[else #f]))
|
||||
|
||||
(define (erase-pkg owner name maj min)
|
||||
(define (erase-pkg owner name maj min)
|
||||
(let* ([uninstalled-pkg-dir
|
||||
(build-path (UNINSTALLED-PACKAGE-CACHE) owner name (number->string maj) (number->string min))]
|
||||
[uninstalled-pkg-file (build-path uninstalled-pkg-dir name)]
|
||||
|
|
@ -155,10 +162,10 @@
|
|||
(raise e)))])
|
||||
(remove-pkg owner name maj min))))
|
||||
|
||||
;; listof X * listof X -> nonempty listof X
|
||||
;; returns de-prefixed version of l2 if l1 is a proper prefix of l2;
|
||||
;; signals an error otherwise.
|
||||
(define (drop-common-base list1 list2)
|
||||
;; listof X * listof X -> nonempty listof X
|
||||
;; returns de-prefixed version of l2 if l1 is a proper prefix of l2;
|
||||
;; signals an error otherwise.
|
||||
(define (drop-common-base list1 list2)
|
||||
(let loop ((l1 list1) (l2 list2))
|
||||
(cond
|
||||
[(null? l2)
|
||||
|
|
@ -168,11 +175,11 @@
|
|||
(error 'drop-common-base "root ~s is not a prefix of stem ~s" list1 list2)]
|
||||
[else (loop (cdr l1) (cdr l2))])))
|
||||
|
||||
;; pathify-list : path (listof path) -> listof path
|
||||
;; given a base and a list of names, interprets each name as a subdirectory
|
||||
;; of the previous, starting with base, and returns a list. (This list
|
||||
;; is in reverse order, so the deepest subdirectory is returned first)
|
||||
(define (pathify-list root dirs)
|
||||
;; pathify-list : path (listof path) -> listof path
|
||||
;; given a base and a list of names, interprets each name as a subdirectory
|
||||
;; of the previous, starting with base, and returns a list. (This list
|
||||
;; is in reverse order, so the deepest subdirectory is returned first)
|
||||
(define (pathify-list root dirs)
|
||||
(let loop ((base root) (dirs dirs) (acc '()))
|
||||
(cond
|
||||
[(null? dirs) acc]
|
||||
|
|
@ -180,14 +187,14 @@
|
|||
(let ((new (build-path base (car dirs))))
|
||||
(loop new (cdr dirs) (cons new acc)))])))
|
||||
|
||||
;; directory-empty? path -> bool
|
||||
;; #t iff the given directory contains no subdirectories of files
|
||||
(define (directory-empty? dir)
|
||||
;; directory-empty? path -> bool
|
||||
;; #t iff the given directory contains no subdirectories of files
|
||||
(define (directory-empty? dir)
|
||||
(null? (directory-list dir)))
|
||||
|
||||
;; trim-directory path path -> void
|
||||
;; deletes nonempty directories starting with stem and working down to root
|
||||
(define (trim-directory root stem)
|
||||
;; trim-directory path path -> void
|
||||
;; deletes nonempty directories starting with stem and working down to root
|
||||
(define (trim-directory root stem)
|
||||
(let* ([rootl (explode-path root)]
|
||||
[steml (explode-path stem)]
|
||||
[extras (cdr (pathify-list root (drop-common-base rootl steml)))])
|
||||
|
|
@ -199,10 +206,10 @@
|
|||
(loop (cdr dirs))]
|
||||
[else (void)]))))
|
||||
|
||||
;; current-linkage : -> ((symbol (package-name nat nat) ...) ...)
|
||||
;; gives the current "linkage table"; a table that links modules to particular versions
|
||||
;; of planet requires that satisfy those linkages
|
||||
(define (current-linkage)
|
||||
;; current-linkage : -> ((symbol (package-name nat nat) ...) ...)
|
||||
;; gives the current "linkage table"; a table that links modules to particular versions
|
||||
;; of planet requires that satisfy those linkages
|
||||
(define (current-linkage)
|
||||
(let* ((links
|
||||
(if (file-exists? (LINKAGE-FILE))
|
||||
(with-input-from-file (LINKAGE-FILE) read-all)
|
||||
|
|
@ -212,23 +219,35 @@
|
|||
(lambda (x) (cons (car x) (map (lambda (y) (drop-last (cadr y))) (cdr x))))
|
||||
buckets)))
|
||||
|
||||
;; regexp->filter : (string | regexp) -> (path -> bool)
|
||||
;; computes a filter that accepts paths that match the given regexps and rejects other paths
|
||||
(define (regexp->filter re-s)
|
||||
;; regexp->filter : (string | regexp) -> (path -> bool)
|
||||
;; computes a filter that accepts paths that match the given regexps and rejects other paths
|
||||
(define (regexp->filter re-s)
|
||||
(let ([re (cond
|
||||
[(string? re-s) (regexp re-s)]
|
||||
[(regexp? re-s) re-s]
|
||||
[else (error 'regexp->filter "not a regular expression")])])
|
||||
(lambda (p) (regexp-match re (path->bytes p)))))
|
||||
|
||||
(define force-package-building? (make-parameter #f))
|
||||
(define force-package-building? (make-parameter #f))
|
||||
(define build-scribble-docs? (make-parameter #t))
|
||||
|
||||
;; make-planet-archive: directory [file] -> file
|
||||
;; Makes a .plt archive file suitable for PLaneT whose contents are
|
||||
;; all files in the given directory and returns that file's name.
|
||||
;; If the optional filename argument is provided, that filename will
|
||||
;; be used as the output file's name.
|
||||
(define make-planet-archive
|
||||
|
||||
;; ---
|
||||
;; documentation stuff
|
||||
;;
|
||||
;; for reasons i do not understand, setup/scribble/setup-scribblings only works
|
||||
;; if you dynamic-require it. I just stole this code from setup/setup-unit.ss .
|
||||
(define-namespace-anchor anchor)
|
||||
(define (doc:setup-scribblings)
|
||||
(parameterize ([current-namespace (namespace-anchor->empty-namespace anchor)])
|
||||
(dynamic-require 'setup/scribble 'setup-scribblings)))
|
||||
|
||||
;; make-planet-archive: directory [file] -> file
|
||||
;; Makes a .plt archive file suitable for PLaneT whose contents are
|
||||
;; all files in the given directory and returns that file's name.
|
||||
;; If the optional filename argument is provided, that filename will
|
||||
;; be used as the output file's name.
|
||||
(define make-planet-archive
|
||||
(case-lambda
|
||||
[(dir)
|
||||
(let-values ([(path name must-be-dir?) (split-path dir)])
|
||||
|
|
@ -241,12 +260,32 @@
|
|||
(let ([announcements '()]
|
||||
[warnings '()]
|
||||
[critical-errors '()])
|
||||
|
||||
(define (build-scribble-docs dir)
|
||||
(setup-scribblings
|
||||
(list dir)
|
||||
#f
|
||||
#f
|
||||
#t
|
||||
(λ (what go alt)
|
||||
(with-handlers ([exn:fail?
|
||||
(lambda (e)
|
||||
(set! critical-errors
|
||||
(cons (format "Error generating scribble documentation: ~a" (exn-message e))
|
||||
critical-errors))
|
||||
(alt))])
|
||||
(go)))))
|
||||
|
||||
(check-info.ss-sanity
|
||||
dir
|
||||
(λ (msg . args) (set! announcements (cons (apply format msg args) announcements)))
|
||||
(λ (bad) (set! warnings (cons bad warnings)))
|
||||
(λ (err) (set! critical-errors (cons err critical-errors))))
|
||||
|
||||
(when (build-scribble-docs?)
|
||||
(printf "Building: ~a\n" dir)
|
||||
(build-scribble-docs dir))
|
||||
|
||||
(unless
|
||||
(or (null? critical-errors)
|
||||
(force-package-building?))
|
||||
|
|
@ -272,18 +311,157 @@
|
|||
|
||||
(normalize-path archive-name))]))
|
||||
|
||||
(define (unpack-planet-archive plt-file target)
|
||||
(define (unpack-planet-archive plt-file target)
|
||||
(parameterize ([current-directory target])
|
||||
(unpack plt-file)))
|
||||
|
||||
;; check-info.ss-sanity : path (string -> void) (string -> void) (string -> void) -> void
|
||||
;; gets all the info.ss fields that planet will use (using the info.ss file
|
||||
;; from the current directory) and calls the announce, warn, and fail functions with strings
|
||||
;; that describe how PLaneT sees the info.ss file. NOTA BENE: if this function calls fail, it may
|
||||
;; also warn on the same field, and the warning may not make sense. This is based on the
|
||||
;; assumption that errors will be turned into some kind of critical failure that obliterates
|
||||
;; all the other information produced.
|
||||
(define (check-info.ss-sanity dir announce warn fail)
|
||||
(define (location->path loc)
|
||||
(match loc
|
||||
['same (build-path 'same)]
|
||||
[(list 'same path) path]
|
||||
[(list other _) (error (format "bad location ~a (illegal in PLaneT packages)" other))]
|
||||
[other (error (format "bad location ~a" other))]))
|
||||
|
||||
(define (foreach-planet-archive plt-file on-dir on-file)
|
||||
(fold-plt-archive plt-file
|
||||
void
|
||||
void
|
||||
(λ (l _) (on-dir (location->path l)))
|
||||
(λ (l fip _) (on-file (location->path l) fip))
|
||||
(void)))
|
||||
|
||||
;; hash-tree ::= (hash-table [string -o> (union string hash-tree)])
|
||||
|
||||
;; chop-path : path -> (listof (union path symbol))
|
||||
;; fully chops up the given path into directory list, without
|
||||
;; accessing the filesystem
|
||||
(define (chop-path path)
|
||||
(let loop ([p path] [acc '()])
|
||||
(cond
|
||||
[(not (path? p)) acc]
|
||||
[else
|
||||
(let-values ([(base name _) (split-path p)])
|
||||
(loop base (cons name acc)))])))
|
||||
|
||||
;; ============================================================
|
||||
;; hash trees
|
||||
|
||||
(define (new-hash-tree)
|
||||
(make-hash))
|
||||
|
||||
(define (hash-tree-get htree pth)
|
||||
(let loop ([pth pth]
|
||||
[htree htree]
|
||||
[route '()])
|
||||
(cond
|
||||
[(null? pth) htree]
|
||||
[(not (hash? htree))
|
||||
(error (format "subpath ~s maps to a value" (reverse route)))]
|
||||
[else
|
||||
(let* ([head (car pth)]
|
||||
[next (hash-ref htree
|
||||
head
|
||||
(λ ()
|
||||
(let ([extension (new-hash-tree)])
|
||||
(hash-set! htree head extension)
|
||||
extension)))])
|
||||
(loop (cdr pth) next (cons (car pth) route)))])))
|
||||
|
||||
(define (hash-tree-put-value htree pth val)
|
||||
(let-values ([(where key) (split-last pth)])
|
||||
(let ([ht (hash-tree-get htree where)])
|
||||
(unless (hash? ht)
|
||||
(error "subpath ~s maps to a value" where))
|
||||
(hash-set! ht key val))))
|
||||
|
||||
(define (split-last l)
|
||||
(let loop ([l l]
|
||||
[front '()])
|
||||
(cond
|
||||
[(null? (cdr l)) (values (reverse front) (car l))]
|
||||
[else
|
||||
(loop (cdr l)
|
||||
(cons (car l) front))])))
|
||||
|
||||
(define (hash-tree->list ht)
|
||||
(let ([lst (hash-map ht
|
||||
(λ (k v)
|
||||
(cons k
|
||||
(if (hash? v)
|
||||
(hash-tree->list v)
|
||||
(list v)))))])
|
||||
(sort lst (λ (a b) (string<? (car a) (car b))))))
|
||||
|
||||
;; a 'a treelist is ::= (list string 'a) | (list string ('a treelist) ...)
|
||||
|
||||
;; ============================================================
|
||||
|
||||
;; print out file treelists (treelists where 'file is the only non-structure
|
||||
;; element)
|
||||
(define (print-tree t depth)
|
||||
(cond
|
||||
[(and (not (null? (cdr t)))
|
||||
(not (pair? (cadr t))))
|
||||
(printf "~a~a\n" (padding depth) (car t))]
|
||||
[else
|
||||
(printf "~a~a:\n" (padding depth) (car t))
|
||||
(print-tree-list (cdr t) (add1 depth))]))
|
||||
|
||||
(define (print-tree-list ts depth)
|
||||
(for-each (λ (t) (print-tree t depth)) ts))
|
||||
|
||||
(define (padding n)
|
||||
(apply string-append (build-list n (λ (_) " "))))
|
||||
|
||||
;; list-plt-file-contents : path-string[.plt-file] -> void
|
||||
;; prints out a manifest of the given plt file
|
||||
(define (display-plt-file-structure plt-file)
|
||||
|
||||
(define root (new-hash-tree))
|
||||
|
||||
(define (gen-put f)
|
||||
(λ (path) (f (chop-path (simplify-path path #f)))))
|
||||
|
||||
(define put-directory
|
||||
(gen-put
|
||||
(λ (ps)
|
||||
(cond
|
||||
[(equal? ps '(same)) (void)]
|
||||
[else (hash-tree-get root (map path->string ps))]))))
|
||||
|
||||
(define put-file
|
||||
(gen-put
|
||||
(λ (ps)
|
||||
(hash-tree-put-value root (map path->string ps) 'file))))
|
||||
|
||||
(foreach-planet-archive
|
||||
plt-file
|
||||
put-directory
|
||||
(λ (p _) (put-file p)))
|
||||
|
||||
(print-tree-list (hash-tree->list root) 0))
|
||||
|
||||
;; display-plt-archived-file : path-string[.plt-file] string -> void
|
||||
(define (display-plt-archived-file plt-file file-to-print)
|
||||
(let/ec finished
|
||||
(let ([target (simplify-path file-to-print #f)])
|
||||
(foreach-planet-archive
|
||||
plt-file
|
||||
void
|
||||
(λ (path fip)
|
||||
(when (equal? (simplify-path path #f) target)
|
||||
(copy-port fip (current-output-port))
|
||||
(finished (void))))))
|
||||
(error 'display-archived-plt-file "The given file was not found in the given package")))
|
||||
|
||||
;; check-info.ss-sanity : path (string -> void) (string -> void) (string -> void) -> void
|
||||
;; gets all the info.ss fields that planet will use (using the info.ss file
|
||||
;; from the current directory) and calls the announce, warn, and fail functions with strings
|
||||
;; that describe how PLaneT sees the info.ss file. NOTA BENE: if this function calls fail, it may
|
||||
;; also warn on the same field, and the warning may not make sense. This is based on the
|
||||
;; assumption that errors will be turned into some kind of critical failure that obliterates
|
||||
;; all the other information produced.
|
||||
(define (check-info.ss-sanity dir announce warn fail)
|
||||
(with-handlers ([exn:fail:read?
|
||||
(λ (e) (fail (format "Package has an unreadable info.ss file. ~a" (exn-message e))))]
|
||||
[exn:fail:syntax?
|
||||
|
|
@ -360,49 +538,49 @@
|
|||
string?
|
||||
(announce "Version description: ~a\n" version)]))]))))
|
||||
|
||||
;; legal-categories : (listof symbol)
|
||||
(define legal-categories
|
||||
;; legal-categories : (listof symbol)
|
||||
(define legal-categories
|
||||
'(devtools net media xml datastructures io scientific
|
||||
system ui metaprogramming planet misc))
|
||||
|
||||
;; legal-category : symbol -> boolean
|
||||
;; determine if the given symbol is a legal category
|
||||
(define (legal-category? x) (memq x legal-categories))
|
||||
;; legal-category : symbol -> boolean
|
||||
;; determine if the given symbol is a legal category
|
||||
(define (legal-category? x) (memq x legal-categories))
|
||||
|
||||
;; illegal-category : symbol -> (union symbol false)
|
||||
;; returns #f if the symbol is a legal category, or the symbol itself if it isn't
|
||||
(define (illegal-category s) (if (legal-category? s) #f s))
|
||||
;; illegal-category : symbol -> (union symbol false)
|
||||
;; returns #f if the symbol is a legal category, or the symbol itself if it isn't
|
||||
(define (illegal-category s) (if (legal-category? s) #f s))
|
||||
|
||||
;; url-string? : string -> boolean
|
||||
;; determines if the given string is a reasonable homepage url
|
||||
(define (url-string? s)
|
||||
;; url-string? : string -> boolean
|
||||
;; determines if the given string is a reasonable homepage url
|
||||
(define (url-string? s)
|
||||
(and (string? s)
|
||||
(let ([u (string->url s)])
|
||||
(and (url-scheme u)
|
||||
(url-host u)))))
|
||||
|
||||
;; file-in-current-directory? : string -> boolean
|
||||
;; determines if the given string represents a file in the current directory
|
||||
(define (file-in-current-directory? f)
|
||||
;; file-in-current-directory? : string -> boolean
|
||||
;; determines if the given string represents a file in the current directory
|
||||
(define (file-in-current-directory? f)
|
||||
(and (string? f) (file-exists? f)))
|
||||
|
||||
;; core-version : string -> boolean
|
||||
;; determines if the given string is something that (version) could've produced
|
||||
(define (core-version? s)
|
||||
;; core-version : string -> boolean
|
||||
;; determines if the given string is something that (version) could've produced
|
||||
(define (core-version? s)
|
||||
(and (string? s)
|
||||
(regexp-match #rx"^[0-9]+(\\.[0-9]*)?$" s)))
|
||||
|
||||
;; checkinfo: syntax
|
||||
;; given an info.ss function, a failure function, and a bunch of fields to check,
|
||||
;; goes through the checklist calling either the success or the failure branch
|
||||
;; of each check as appropriate
|
||||
(define-syntax checkinfo
|
||||
;; checkinfo: syntax
|
||||
;; given an info.ss function, a failure function, and a bunch of fields to check,
|
||||
;; goes through the checklist calling either the success or the failure branch
|
||||
;; of each check as appropriate
|
||||
(define-syntax checkinfo
|
||||
(syntax-rules ()
|
||||
[(checkinfo fn fail clauses ...)
|
||||
(let ([fn* fn] [fail* fail])
|
||||
(checkinfo* () fn* fail* clauses ...))]))
|
||||
|
||||
(define-syntax checkinfo*
|
||||
(define-syntax checkinfo*
|
||||
(syntax-rules ()
|
||||
[(checkinfo* () fn fail) (void)]
|
||||
[(checkinfo* (handler1 handler ...) fn fail) (begin handler1 handler ...)]
|
||||
|
|
@ -422,13 +600,13 @@
|
|||
[else on-fail])))
|
||||
fn fail clauses ...)]))
|
||||
|
||||
;; ============================================================
|
||||
;; HARD LINKS (aka development links)
|
||||
;; ============================================================
|
||||
;; HARD LINKS (aka development links)
|
||||
|
||||
;; add-hard-link : string string num num path -> void
|
||||
;; adds an entry in the hard-links table associating the given
|
||||
;; require spec to the given path
|
||||
(define (add-hard-link owner pkg-name maj min path)
|
||||
;; add-hard-link : string string num num path -> void
|
||||
;; adds an entry in the hard-links table associating the given
|
||||
;; require spec to the given path
|
||||
(define (add-hard-link owner pkg-name maj min path)
|
||||
(unless (directory-exists? path)
|
||||
(if (file-exists? path)
|
||||
(error 'add-hard-link "Hard links must point to directories, not files")
|
||||
|
|
@ -437,9 +615,9 @@
|
|||
(path->string path))))
|
||||
(add-hard-link! pkg-name (list owner) maj min path))
|
||||
|
||||
;; remove-hard-link : string string num num -> void
|
||||
;; removes any development association from the given package spec
|
||||
(define (remove-hard-link owner pkg-name maj min)
|
||||
;; remove-hard-link : string string num num -> void
|
||||
;; removes any development association from the given package spec
|
||||
(define (remove-hard-link owner pkg-name maj min)
|
||||
(filter-link-table!
|
||||
(lambda (row)
|
||||
(not (points-to? row pkg-name (list owner) maj min)))
|
||||
|
|
@ -448,58 +626,58 @@
|
|||
(when p
|
||||
(erase-metadata p))))))
|
||||
|
||||
;; ============================================================
|
||||
;; VERSION INFO
|
||||
;; ============================================================
|
||||
;; VERSION INFO
|
||||
|
||||
(provide this-package-version
|
||||
(provide this-package-version
|
||||
this-package-version-name
|
||||
this-package-version-owner
|
||||
this-package-version-maj
|
||||
this-package-version-min)
|
||||
|
||||
(define-syntax (this-package-version stx)
|
||||
(define-syntax (this-package-version stx)
|
||||
(syntax-case stx ()
|
||||
[(_)
|
||||
#`(this-package-version/proc
|
||||
#,(datum->syntax-object stx `(,#'this-expression-source-directory)))]))
|
||||
#,(datum->syntax stx `(,#'this-expression-source-directory)))]))
|
||||
|
||||
(define-syntax define-getters
|
||||
(define-syntax define-getters
|
||||
(syntax-rules ()
|
||||
[(define-getters (name position) ...)
|
||||
(begin
|
||||
(define-syntax (name stx)
|
||||
(syntax-case stx ()
|
||||
[(name)
|
||||
#`(let ([p #,(datum->syntax-object stx `(,#'this-package-version))])
|
||||
#`(let ([p #,(datum->syntax stx `(,#'this-package-version))])
|
||||
(and p (position p)))]))
|
||||
...)]))
|
||||
|
||||
(define-getters
|
||||
(define-getters
|
||||
(this-package-version-name pd->name)
|
||||
(this-package-version-owner pd->owner)
|
||||
(this-package-version-maj pd->maj)
|
||||
(this-package-version-min pd->min))
|
||||
|
||||
;; ----------------------------------------
|
||||
;; ----------------------------------------
|
||||
|
||||
(define (this-package-version/proc srcdir)
|
||||
(define (this-package-version/proc srcdir)
|
||||
(let* ([package-roots (get-all-planet-packages)]
|
||||
[thepkg (ormap (predicate->projection (contains-dir? srcdir))
|
||||
package-roots)])
|
||||
(and thepkg (archive-retval->simple-retval thepkg))))
|
||||
|
||||
;; predicate->projection : #f \not\in X ==> (X -> boolean) -> (X -> X)
|
||||
(define (predicate->projection pred) (λ (x) (if (pred x) x #f)))
|
||||
;; predicate->projection : #f \not\in X ==> (X -> boolean) -> (X -> X)
|
||||
(define (predicate->projection pred) (λ (x) (if (pred x) x #f)))
|
||||
|
||||
;; contains-dir? : path -> pkg -> boolean
|
||||
(define ((contains-dir? srcdir) alleged-superdir-pkg)
|
||||
;; contains-dir? : path -> pkg -> boolean
|
||||
(define ((contains-dir? srcdir) alleged-superdir-pkg)
|
||||
(let* ([nsrcdir (normalize-path srcdir)]
|
||||
[nsuperdir (normalize-path (car alleged-superdir-pkg))]
|
||||
[nsrclist (explode-path nsrcdir)]
|
||||
[nsuperlist (explode-path nsuperdir)])
|
||||
(list-prefix? nsuperlist nsrclist)))
|
||||
|
||||
(define (list-prefix? sup sub)
|
||||
(define (list-prefix? sup sub)
|
||||
(let loop ([sub sub]
|
||||
[sup sup])
|
||||
(cond
|
||||
|
|
@ -508,11 +686,11 @@
|
|||
(loop (cdr sub) (cdr sup))]
|
||||
[else #f])))
|
||||
|
||||
(define (archive-retval->simple-retval p)
|
||||
(define (archive-retval->simple-retval p)
|
||||
(list-refs p '(1 2 4 5)))
|
||||
|
||||
(define-values (pd->owner pd->name pd->maj pd->min)
|
||||
(define-values (pd->owner pd->name pd->maj pd->min)
|
||||
(apply values (map (λ (n) (λ (l) (list-ref l n))) '(0 1 2 3))))
|
||||
|
||||
(define (list-refs p ns)
|
||||
(map (λ (n) (list-ref p n)) ns)))
|
||||
(define (list-refs p ns)
|
||||
(map (λ (n) (list-ref p n)) ns))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user