planet print, planet structure commands

svn: r9403

collects/planet/planet.scrbl

@@ -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}
+  @cmd["create"]{create a PLaneT archive from a directory}
-  @item{@exec{install}:     download and install a given package}
+  @cmd["install"]{download and install a given package}
-  @item{@exec{remove}:      remove the specified package from the local cache}
+  @cmd["remove"]{remove the specified package from the local cache}
-  @item{@exec{show}:        list the packages installed in the local cache}
+  @cmd["show"]{list the packages installed in the local cache}
-  @item{@exec{clearlinks}:  clear the linkage table, allowing upgrades}
+  @cmd["clearlinks"]{clear the linkage table, allowing upgrades}
-  @item{@exec{fileinject}:  install a local file to the planet cache}
+  @cmd["fileinject"]{install a local file to the planet cache}
-  @item{@exec{link}:        create a development link}
+  @cmd["link"]{create a development link}
-  @item{@exec{unlink}:      remove development link associated with the given package}
+  @cmd["unlink"]{remove development link associated with the given package}
-  @item{@exec{fetch}:       download a package file without installing it}
+  @cmd["fetch"]{download a package file without installing it}
-  @item{@exec{url}:         get a URL for the given package}
+  @cmd["url"]{get a URL for the given package}
-  @item{@exec{open}:        unpack the contents of 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
+Create a development link (see @secref{devlinks}) between the given
-specified directory name.
+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.}

collects/planet/planet.ss

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

collects/planet/util.ss

@@ -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")
+         mzlib/etc
-           (lib "plt-single-installer.ss" "setup")
+         scheme/port
-           (lib "getinfo.ss" "setup")
+         scheme/path
-           (lib "unpack.ss" "setup")
+         
-           mzlib/etc)
+         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))