.Added support for creating and deleting development links to the planet cmd-line tool.

svn: r1906

collects/planet/config.ss

@@ -4,12 +4,15 @@
     (PLANET-SERVER-NAME       "planet.plt-scheme.org")
     (PLANET-SERVER-PORT       270)
     (PLANET-CODE-VERSION      "300")
-    (PLANET-DIR               (if (getenv "PLTPLANETDIR")
+    (PLANET-BASE-DIR         (if (getenv "PLTPLANETDIR")
-                                  (string->path (getenv "PLTPLANETDIR"))
+                                 (string->path (getenv "PLTPLANETDIR"))
-                                  (build-path (find-system-path 'addon-dir) "planet" (PLANET-CODE-VERSION) (version))))
+                                 (build-path (find-system-path 'addon-dir)
+                                             "planet"
+                                             (PLANET-CODE-VERSION))))
+    (PLANET-DIR               (build-path (PLANET-BASE-DIR) (version)))
     (CACHE-DIR                (build-path (PLANET-DIR) "cache"))
     (LINKAGE-FILE             (build-path (PLANET-DIR) "LINKAGE"))
-    (HARD-LINK-FILE           (build-path (PLANET-DIR) "HARD-LINKS"))
+    (HARD-LINK-FILE           (build-path (PLANET-BASE-DIR) "HARD-LINKS"))
     (LOGGING-ENABLED?         #t)
     (LOG-FILE                 (build-path (PLANET-DIR) "INSTALL-LOG"))
     (DEFAULT-PACKAGE-LANGUAGE (version))

collects/planet/doc.txt

@@ -166,9 +166,11 @@ and are stored in a user-specific table called the linkage table.
 
 2. Acceptable local package
 
-If the PLaneT client doesn't have any previous linkage information,
+If the PLaneT client doesn't have any previous linkage information, it
-it checks its list of already-installed PLaneT packages for one that
+checks its list of already-installed PLaneT packages for one that
-meets the requirement, and uses it if available.
+meets the requirement, and uses it if available. Both PLaneT-installed
+packages and packages established through a development link are
+checked simultaneously at this stage.
 
 3. Acceptable remote package
 
@@ -226,6 +228,42 @@ List the current linkage table
 
 Clear the linkage table, unlinking all packages and allowing upgrades.
 
+-a, --associate <owner> <pkg> <maj> <min> <dir>
+
+Create a development link from the given package specifier
+to the given directory, clearing any previous development
+links that may have been in place. (See below for an explanation
+of what development links are.)
+
+-u, --unassociate <owner> <pkg> <maj> <min>
+
+Remove any development links from the given package specifier.
+
+
+_Development links_
+-------------------
+
+To aid development, PLaneT allows users to establish direct
+associations between a particular planet package (e.g. myname
+myfirstpackage.plt 1 0) with an arbitrary directory on the filesystem
+(e.g., /home/myname/svn/mypackages/devel/). These associations are
+intended to allow developers to use their own directory structures,
+version control systems, etc. while developing PLaneT packages while
+still being able to use the packages they create as though they were
+distributed directly by PLaneT. Development links are local to a
+particular user and repository (but not to a particular MzScheme minor
+revision).
+
+To establish a development link, use the planet command-line tool:
+
+$ planet --associate myname mypackage.plt 1 0 ~/svn/mypackages/devel
+
+Once you are finished developing a package, you should remove any
+development links you have established for it, again using the planet
+command-line tool:
+
+$ planet --unassociate myname mypackage.plt 1 0
+
 _Distributing Packages with PLaneT_
 -----------------------------------
 

collects/planet/planet.ss

@@ -72,6 +72,20 @@ PLANNED FEATURES:
        ""
        "List the current linkage table"
        (set! actions (cons show-linkage actions)))
+      
+      (("-a" "--associate")
+       owner pkg maj min path
+       ""
+       "Create a development link between the specified package specifier "
+       "and the specified directory name"
+       (set! actions (cons (lambda () (add-hard-link-cmd owner pkg maj min path)) actions)))
+      
+      (("-u" "--unassociate")
+       owner pkg maj min
+       ""
+       "Remove any development link associated with the specified package"
+       (set! actions (cons (lambda () (remove-hard-link-cmd owner pkg maj min)) actions)))
+           
       ;; unimplemented so far:
       #;(("-u" "--unlink")
          module
@@ -156,8 +170,17 @@ PLANNED FEATURES:
       (current-linkage)
       (lambda (a b) (string<? (symbol->string a) (symbol->string b))))))
   
+  (define (add-hard-link-cmd ownerstr pkgstr majstr minstr pathstr)
+    (let* ([maj (read-from-string majstr)]
+           [min (read-from-string minstr)]
+           [path (string->path pathstr)])
+      (add-hard-link ownerstr pkgstr maj min path)))
   
-  
+  (define (remove-hard-link-cmd ownerstr pkgstr majstr minstr)
+    (let* ([maj (read-from-string majstr)]
+           [min (read-from-string minstr)])
+      (remove-hard-link ownerstr pkgstr maj min)))
+      
   
   ;; ------------------------------------------------------------
   ;; Utility

collects/planet/private/planet-shared.ss

@@ -9,8 +9,6 @@ Various common pieces of code that both the client and server need to access
   (require (lib "list.ss")
            (lib "etc.ss")
            (lib "port.ss")
-           (prefix srfi1: (lib "1.ss" "srfi"))
-           (lib "match.ss")
            (lib "file.ss")
            "../config.ss")
   
@@ -83,37 +81,96 @@ Various common pieces of code that both the client and server need to access
   
   ; hard-links : FULL-PKG-SPEC -> (listof assoc-table-row)
   (define (hard-links pkg)
-    
+    (filter
+     (λ (row)
+       (and (equal? (assoc-table-row->name row) (pkg-spec-name pkg))
+            (equal? (assoc-table-row->path row) (pkg-spec-path pkg))))
+     (get-hard-link-table)))
+  
+  ;; verify-well-formed-hard-link-parameter! : -> void
+  ;; pitches a fit if the hard link table parameter isn't set right
+  (define (verify-well-formed-hard-link-parameter!)
     (unless (and (absolute-path? (HARD-LINK-FILE)) (path-only (HARD-LINK-FILE)))
       (raise (make-exn:fail:contract 
               (string->immutable-string
                (format 
                 "The HARD-LINK-FILE setting must be an absolute path name specifying a file; given ~s" 
                 (HARD-LINK-FILE)))
-              (current-continuation-marks))))
+              (current-continuation-marks)))))
+  
+  ;; get-hard-link-table : -> assoc-table
+  (define (get-hard-link-table)
+    (verify-well-formed-hard-link-parameter!)
+    (if (file-exists? (HARD-LINK-FILE))
+        (map 
+         (lambda (item) (update-element 4 bytes->path item))
+         (with-input-from-file (HARD-LINK-FILE) read-all))
+        '()))
+
+  ;; row-for-package? : row string (listof string) num num -> boolean
+  ;; determines if the row associates the given package with a dir
+  (define (points-to? row name path maj min)
+    (and (equal? name (assoc-table-row->name row))
+         (equal? path (assoc-table-row->path row))
+         (equal? maj  (assoc-table-row->maj row))
+         (equal? min  (assoc-table-row->min row))))
+  
+  ;; save-hard-link-table : assoc-table -> void
+  ;; saves the given table, overwriting any file that might be there
+  (define (save-hard-link-table table)
+    (verify-well-formed-hard-link-parameter!)
+    (with-output-to-file (HARD-LINK-FILE)
+      (lambda ()
+        (display "")
+        (for-each 
+         (lambda (row)
+           (write (update-element 4 path->bytes row))
+           (newline))
+         table))
+      'truncate))
+  
+  ;; add-hard-link! string (listof string) num num path -> void
+  ;; adds the given hard link, clearing any previous ones already in place
+  ;; for the same package
+  (define (add-hard-link! name path maj min dir)
+    (let* ([original-table (get-hard-link-table)]
+           [new-table (cons
+                       (list name path maj min dir)
+                       (filter
+                        (lambda (row) (not (points-to? row name path maj min)))
+                        original-table))])
+      (save-hard-link-table new-table)))
+  
+  ;; filter-link-table! : (row -> boolean) -> void
+  ;; removes all rows from the link table that don't match the given predicate
+  (define (filter-link-table! f)
+    (save-hard-link-table (filter f (get-hard-link-table))))
+
+  ;; update-element : number (x -> y) (listof any [x in position number]) -> (listof any [y in position number])
+  (define (update-element n f l)
+    (cond
+      [(null? l) (error 'update-element "Index too large")]
+      [(zero? n) (cons (f (car l)) (cdr l))]
+      [else (cons (car l) (update-element (sub1 n) f (cdr l)))]))
     
-    (let ((link-table 
-           (if (file-exists? (HARD-LINK-FILE))
-               (with-input-from-file (HARD-LINK-FILE) read)
-               '())))
-      (srfi1:filter-map
-       (λ (row)
-         (match row
-           [`(,(? (λ (name) (equal? name (pkg-spec-name pkg))))
-              ,(? (λ (path) (equal? path (pkg-spec-path pkg))))
-              ,maj ,min ,(? bytes? dir))
-             (list maj min (bytes->path dir))]
-           [_ #f]))
-       link-table)))
-       
   ; add-to-table assoc-table (listof assoc-table-row) -> assoc-table
   (define add-to-table append) 
   
-  ; assoc-table-row->{maj,min,dir} : assoc-table-row -> {num,num,path}
+  ;; first-n-list-selectors : number -> (values (listof x -> x) ...)
-  ; retrieve the {major version, minor version, directory} of the given row
+  ;; returns n list selectors for the first n elements of a list
-  (define assoc-table-row->maj car)
+  ;; (useful for defining meaningful names to list-structured data)
-  (define assoc-table-row->min cadr)
+  (define (first-n-list-selectors n)
-  (define assoc-table-row->dir caddr)
+    (apply values (build-list n (lambda (m) (lambda (row) (list-ref row m))))))
+  
+  ;; assoc-table-row->{name,path,maj,min,dir} : assoc-table-row -> {string,(listof string),num,num,path}
+  ;; retrieve the {package name, "package path", major version, minor version, directory}
+  ;; of the given row
+  (define-values (assoc-table-row->name
+                  assoc-table-row->path
+                  assoc-table-row->maj
+                  assoc-table-row->min
+                  assoc-table-row->dir)
+    (first-n-list-selectors 5))
   
   ; get-best-match/t : assoc-table FULL-PKG-SPEC -> PKG | #f
   (define (get-best-match/t table spec)

collects/planet/util.ss

@@ -20,7 +20,9 @@
    make-planet-archive
    get-installed-planet-archives
    remove-pkg
-   unlink-all)
+   unlink-all
+   add-hard-link
+   remove-hard-link)
 
   ;; current-cache-contents : -> ((string ((string ((nat (nat ...)) ...)) ...)) ...)
   ;; returns the packages installed in the local PLaneT cache
@@ -148,4 +150,22 @@
                'file
                #f
                #f))
-       (normalize-path archive-name)])))
+       (normalize-path archive-name)]))
+  
+  ;; 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")
+          (fprintf (current-error-port) 
+                   "Warning: directory ~a does not exist\n"
+                   (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)
+    (filter-link-table!
+     (lambda (row) (not (points-to? row pkg-name (list owner) maj min))))))