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,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")
+         mzlib/etc
-           (lib "plt-single-installer.ss" "setup")
+         scheme/port
-           (lib "getinfo.ss" "setup")
+         scheme/path
-           (lib "unpack.ss" "setup")
-           mzlib/etc)
          
-  #| 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
+;; download/install-pkg : string string nat nat -> pkg | #f
-  (define (download/install-pkg owner name maj min)
+(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 ...)) ...)) ...)) ...)
+;; current-cache-contents : -> ((string ((string ((nat (nat ...)) ...)) ...)) ...)
-  ;; returns the packages installed in the local PLaneT cache
+;; returns the packages installed in the local PLaneT cache
-  (define (current-cache-contents)
+(define (current-cache-contents)
   (cdr (tree->list (repository-tree))))
 
-  ;; just so it will be provided
+;; just so it will be provided
-  (define unlink-all remove-all-linkage!)
+(define unlink-all remove-all-linkage!)
 
-  ;; to remove:
+;; to remove:
-  ;;   -- setup-plt -c the package
+;;   -- setup-plt -c the package
-  ;;   -- remove relevant infodomain cache entries
+;;   -- remove relevant infodomain cache entries
-  ;;   -- delete files from cache directory
+;;   -- delete files from cache directory
-  ;;   -- remove any existing linkage for package
+;;   -- remove any existing linkage for package
-  ;; returns void if the removal worked; raises an exception if no package existed.
+;; 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
+;; erase-metadata : pkg -> void
-  ;; clears out any references to the given package in planet's metadata files
+;; 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)
+;; (i.e., linkage and info.ss cache; not hard links which are not considered metadata)
-  (define (erase-metadata p)
+(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
+;; 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
+;; 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.
+;; no; an uncompiled package isn't necessarily not to be indexed and so on.
-  ;; remove-infodomain-entries : path -> void
+;; remove-infodomain-entries : path -> void
-  (define (remove-infodomain-entries path)
+(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
+;; subpath? : path path -> boolean
-  ;; determines if p1 is a subpath of p2. Both paths must actually exist on the filesystem
+;; determines if p1 is a subpath of p2. Both paths must actually exist on the filesystem
-  (define (subpath? p1 p2)
+(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)
+;; o2 : (X X -> Y) (Z -> X) -> (Z Z -> Y)
-  ;; "compose-two"
+;; "compose-two"
-  (define (o2 a b) (λ (x y) (a (b x) (b y))))
+(define (o2 a b) (λ (x y) (a (b x) (b y))))
 
-  ;; sublist? : (listof X) (listof X) (X X -> boolean) -> boolean
+;; sublist? : (listof X) (listof X) (X X -> boolean) -> boolean
-  ;; determine if l1 is a sublist of l2, using = as the comparison operator for elements
+;; determine if l1 is a sublist of l2, using = as the comparison operator for elements
-  (define (sublist? l1 l2 =)
+(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
+;; listof X * listof X -> nonempty listof X
-  ;; returns de-prefixed version of l2 if l1 is a proper prefix of l2; 
+;; returns de-prefixed version of l2 if l1 is a proper prefix of l2; 
-  ;; signals an error otherwise.
+;; signals an error otherwise.
-  (define (drop-common-base list1 list2)
+(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
+;; pathify-list : path (listof path) -> listof path
-  ;; given a base and a list of names, interprets each name as a subdirectory
+;; 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
+;; of the previous, starting with base, and returns a list. (This list
-  ;; is in reverse order, so the deepest subdirectory is returned first)
+;; is in reverse order, so the deepest subdirectory is returned first)
-  (define (pathify-list root dirs)
+(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
+;; directory-empty? path -> bool
-  ;; #t iff the given directory contains no subdirectories of files
+;; #t iff the given directory contains no subdirectories of files
-  (define (directory-empty? dir)
+(define (directory-empty? dir)
   (null? (directory-list dir)))
 
-  ;; trim-directory path path -> void
+;; trim-directory path path -> void
-  ;; deletes nonempty directories starting with stem and working down to root
+;; deletes nonempty directories starting with stem and working down to root
-  (define (trim-directory root stem)
+(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) ...) ...)
+;; current-linkage : -> ((symbol (package-name nat nat) ...) ...)
-  ;; gives the current "linkage table"; a table that links modules to particular versions
+;; gives the current "linkage table"; a table that links modules to particular versions
-  ;; of planet requires that satisfy those linkages
+;; of planet requires that satisfy those linkages
-  (define (current-linkage)
+(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)
+;; regexp->filter : (string | regexp) -> (path -> bool)
-  ;; computes a filter that accepts paths that match the given regexps and rejects other paths
+;; computes a filter that accepts paths that match the given regexps and rejects other paths
-  (define (regexp->filter re-s)
+(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.
+;; documentation stuff
-  ;; If the optional filename argument is provided, that filename will 
+;;
-  ;; be used as the output file's name.
+;; for reasons i do not understand, setup/scribble/setup-scribblings only works
-  (define make-planet-archive
+;; 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
+(define (location->path loc)
-  ;; gets all the info.ss fields that planet will use (using the info.ss file
+  (match loc
-  ;; from the current directory) and calls the announce, warn, and fail functions with strings
+    ['same (build-path 'same)]
-  ;; that describe how PLaneT sees the info.ss file. NOTA BENE: if this function calls fail, it may 
+    [(list 'same path) path]
-  ;; also warn on the same field, and the warning may not make sense. This is based on the
+    [(list other _) (error (format "bad location ~a (illegal in PLaneT packages)" other))]
-  ;; assumption that errors will be turned into some kind of critical failure that obliterates
+    [other (error (format "bad location ~a" other))]))
-  ;; all the other information produced.
+
-  (define (check-info.ss-sanity dir announce warn fail)
+(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)
+;; legal-categories : (listof symbol)
-  (define legal-categories
+(define legal-categories
   '(devtools net media xml datastructures io scientific
              system ui metaprogramming planet misc))
 
-  ;; legal-category : symbol -> boolean
+;; legal-category : symbol -> boolean
-  ;; determine if the given symbol is a legal category
+;; determine if the given symbol is a legal category
-  (define (legal-category? x) (memq x legal-categories))
+(define (legal-category? x) (memq x legal-categories))
 
-  ;; illegal-category : symbol -> (union symbol false)
+;; illegal-category : symbol -> (union symbol false)
-  ;; returns #f if the symbol is a legal category, or the symbol itself if it isn't
+;; 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)) 
+(define (illegal-category s) (if (legal-category? s) #f s)) 
 
-  ;; url-string? : string -> boolean
+;; url-string? : string -> boolean
-  ;; determines if the given string is a reasonable homepage url
+;; determines if the given string is a reasonable homepage url
-  (define (url-string? s)
+(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
+;; file-in-current-directory? : string -> boolean
-  ;; determines if the given string represents a file in the current directory
+;; determines if the given string represents a file in the current directory
-  (define (file-in-current-directory? f)
+(define (file-in-current-directory? f)
   (and (string? f) (file-exists? f)))
 
-  ;; core-version : string -> boolean
+;; core-version : string -> boolean
-  ;; determines if the given string is something that (version) could've produced
+;; determines if the given string is something that (version) could've produced
-  (define (core-version? s)
+(define (core-version? s)
   (and (string? s)
        (regexp-match #rx"^[0-9]+(\\.[0-9]*)?$" s)))
 
-  ;; checkinfo: syntax
+;; checkinfo: syntax
-  ;; given an info.ss function, a failure function, and a bunch of fields to check,
+;; 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
+;; goes through the checklist calling either the success or the failure branch
-  ;; of each check as appropriate
+;; of each check as appropriate
-  (define-syntax checkinfo
+(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
+;; add-hard-link : string string num num path -> void
-  ;; adds an entry in the hard-links table associating the given
+;; adds an entry in the hard-links table associating the given
-  ;; require spec to the given path
+;; require spec to the given path
-  (define (add-hard-link owner pkg-name maj min 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
+;; remove-hard-link : string string num num -> void
-  ;; removes any development association from the given package spec
+;; removes any development association from the given package spec
-  (define (remove-hard-link owner pkg-name maj min)
+(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)
+;; predicate->projection : #f \not\in X ==> (X -> boolean) -> (X -> X)
-  (define (predicate->projection pred) (λ (x) (if (pred x) x #f)))
+(define (predicate->projection pred) (λ (x) (if (pred x) x #f)))
 
-  ;; contains-dir? : path -> pkg -> boolean
+;; contains-dir? : path -> pkg -> boolean
-  (define ((contains-dir? srcdir) alleged-superdir-pkg)
+(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)
+(define (list-refs p ns)
-    (map (λ (n) (list-ref p n)) ns)))
+  (map (λ (n) (list-ref p n)) ns))