suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

planet print, planet structure commands

Browse Source 
svn: r9403
This commit is contained in:
Jacob Matthews 2008-04-22 21:32:23 +00:00
parent 8203977a21
commit c40da0feb8
3 changed files with 757 additions and 525 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

66
collects/planet/planet.scrbl
View File

@ -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.}

30
collects/planet/planet.ss
View File

@ -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

202
collects/planet/util.ss
View File

@ -1,4 +1,4 @@
(module util mzscheme
#lang scheme
(require "config.ss"
"planet-archives.ss"
@ -7,15 +7,19 @@
"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
setup/pack
setup/plt-single-installer
setup/getinfo
setup/unpack
setup/scribble)
#| The util collection provides a number of useful functions for interacting with the PLaneT system. |#
@ -26,12 +30,15 @@
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
[download/install-pkg
@ -118,7 +125,7 @@
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
@ -222,6 +229,18 @@
(lambda (p) (regexp-match re (path->bytes p)))))
(define force-package-building? (make-parameter #f))
(define build-scribble-docs? (make-parameter #t))
;; ---
;; 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
@ -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?))
@ -276,6 +315,145 @@
(parameterize ([current-directory target])
(unpack plt-file)))
(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
@ -461,7 +639,7 @@
(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
(syntax-rules ()
@ -470,7 +648,7 @@
(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)))]))
...)]))
@ -515,4 +693,4 @@
(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)))
(map (λ (n) (list-ref p n)) ns))