Fix error reported by Sam

svn: r7580

collects/planet/planet.ss

@@ -179,16 +179,16 @@ PLANNED FEATURES:
           (min (string->number minstr)))
       (unless (and (integer? maj) (integer? min) (> maj 0) (>= min 0))
         (fail "Invalid major/minor version"))
-      (unless (remove-pkg owner pkg maj min)
+      (with-handlers ([exn:fail:planet? (λ (e) (fail (exn-message e)))]) 
-        (fail "Could not find package"))))
+        (remove-pkg owner pkg maj min))))
   
   (define (erase owner pkg majstr minstr)
     (let ((maj (string->number majstr))
           (min (string->number minstr)))
       (unless (and (integer? maj) (integer? min) (> maj 0) (>= min 0))
         (fail "Invalid major/minor version"))
-      (unless (erase-pkg owner pkg maj min)
+      (with-handlers ([exn:fail:planet? (λ (e) (fail (exn-message e)))])
-        (fail "Could not find package"))))
+        (erase-pkg owner pkg maj min))))
         
   (define (show-installed-packages)
     (let ([normal-packages (get-installed-planet-archives)]

collects/planet/private/planet-shared.ss

@@ -36,14 +36,21 @@ Various common pieces of code that both the client and server need to access
      core-version   ; string
      )
     (make-inspector))
-  ; PKG : string (listof string) Nat Nat path
+  ; PKG : string (listof string) Nat Nat path ORIGIN
-  (define-struct pkg (name route maj min path))
+  (define-struct pkg (name route maj min path origin))
   ; UNINSTALLED-PKG : path FULL-PKG-SPEC Nat Nat
   (define-struct uninstalled-pkg (path spec maj min))
   ; PKG-PROMISE : PKG | UNINSTALLED-PKG
+  ; ORIGIN : 'normal | 'development-link
   
   (define (pkg-promise? p) (or (pkg? p) (uninstalled-pkg? p)))
 
+  (define (normally-installed-pkg? p)
+    (eq? (pkg-origin p) 'normal))
+  
+  (define (development-link-pkg? p)
+    (eq? (pkg-origin p) 'development-link))
+  
   ; ==========================================================================================
   ; CACHE LOGIC
   ; Handles checking the cache for an appropriate module
@@ -140,7 +147,8 @@ Various common pieces of code that both the client and server need to access
                (pkg-spec-path pkg)
                maj min
                the-path
-               min-core-version))
+               min-core-version
+               'normal))
             #f)))
     
     (if (directory-exists? path)
@@ -176,7 +184,7 @@ Various common pieces of code that both the client and server need to access
   (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))
+        (map (lambda (item) (update/create-element 6 (λ (_) 'development-link) (update-element 4 bytes->path item)))
              (with-input-from-file (HARD-LINK-FILE) read-all))
         '()))
   
@@ -217,7 +225,7 @@ Various common pieces of code that both the client and server need to access
     (let ([complete-dir (path->complete-path dir)])
       (let* ([original-table (get-hard-link-table)]
              [new-table (cons
-                         (make-assoc-table-row name path maj min complete-dir #f)
+                         (make-assoc-table-row name path maj min complete-dir #f 'development-link)
                          (filter
                           (lambda (row) (not (points-to? row name path maj min)))
                           original-table))])
@@ -239,6 +247,17 @@ Various common pieces of code that both the client and server need to access
       [(zero? n) (cons (f (car l)) (cdr l))]
       [else (cons (car l) (update-element (sub1 n) f (cdr l)))]))
   
+  (define (update/create-element n f l)
+    (cond
+      [(and (null? l) (zero? n))
+       (list (f #f))]
+      [(and (null? l) (not (zero? n)))
+       (error 'update/create-element "Index too large")]
+      [(and (not (null? l)) (zero? n))
+       (cons (f (car l)) (cdr l))]
+      [else (cons (car l) (update/create-element (sub1 n) f (cdr l)))]))
+       
+  
   ; add-to-table assoc-table (listof assoc-table-row) -> assoc-table
   (define add-to-table append) 
   
@@ -258,11 +277,12 @@ Various common pieces of code that both the client and server need to access
                   assoc-table-row->maj
                   assoc-table-row->min
                   assoc-table-row->dir
-                  assoc-table-row->required-version)
+                  assoc-table-row->required-version
-    (first-n-list-selectors 6))
+                  assoc-table-row->type)
+    (first-n-list-selectors 7))
   
-  (define (make-assoc-table-row name path maj min dir required-version)
+  (define (make-assoc-table-row name path maj min dir required-version type)
-    (list name path maj min dir required-version))
+    (list name path maj min dir required-version type))
   
   (define-struct mz-version (major minor))
   
@@ -342,7 +362,8 @@ Various common pieces of code that both the client and server need to access
                  (pkg-spec-path spec)
                  (assoc-table-row->maj best-row)
                  (assoc-table-row->min best-row)
-                 (assoc-table-row->dir best-row)))))))
+                 (assoc-table-row->dir best-row)
+                 (assoc-table-row->type best-row)))))))
   
    
   ;; get-installed-package : string string nat nat -> PKG | #f

collects/planet/resolver.ss

@@ -599,7 +599,7 @@ an appropriate subdirectory.
                (parameterize ((current-namespace (make-namespace)))
                  (let ([ipp (dynamic-require '(lib "plt-single-installer.ss" "setup") 'install-planet-package)])
                    (ipp path the-dir (list owner (pkg-spec-name pkg) extra-path maj min))))))
-            (make-pkg (pkg-spec-name pkg) (pkg-spec-path pkg) maj min the-dir)))))
+            (make-pkg (pkg-spec-name pkg) (pkg-spec-path pkg) maj min the-dir 'normal)))))
   
   ; download-package : FULL-PKG-SPEC -> RESPONSE
   ; RESPONSE ::= (list #f string) | (list #t path[file] Nat Nat)

collects/planet/util.ss

@@ -28,11 +28,10 @@
    force-package-building?
    get-installed-planet-archives
    get-hard-linked-packages
-   remove-pkg
    unlink-all
    lookup-package-by-keys
-   
+   resolve-planet-path
-   resolve-planet-path)
+   (struct exn:fail:planet ()))
   
   (provide/contract
    [download/install-pkg
@@ -41,8 +40,10 @@
     (-> string? string? natural-number/c natural-number/c path? void?)]
    [remove-hard-link 
     (-> string? string? natural-number/c natural-number/c void?)]
+   [remove-pkg
+    (-> string? string? natural-number/c natural-number/c void?)]
    [erase-pkg
-    (-> string? string? natural-number/c natural-number/c boolean?)])
+    (-> 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)
@@ -66,20 +67,27 @@
   ;;   -- remove relevant infodomain cache entries
   ;;   -- delete files from cache directory
   ;;   -- remove any existing linkage for package
-  ;; returns #t if the removal worked; #f 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 (remove-pkg owner name maj min)
     (let ((p (get-installed-package owner name maj min)))
-      (and p
+      (unless p
-           (let ((path (pkg-path p)))
+        (raise (make-exn:fail:planet "Could not find package" (current-continuation-marks))))
-             (with-logging 
+      (unless (normally-installed-pkg? p)
-              (LOG-FILE)
+        (raise (make-exn:fail:planet "Not a normally-installed package, can't remove" (current-continuation-marks))))
-              (lambda () 
+
-                (printf "\n============= Removing ~a =============\n" (list owner name maj min))
+      (let ((path (pkg-path p)))
-                (clean-planet-package path (list owner name '() maj min))))
+        (with-logging 
-             (erase-metadata p)
+         (LOG-FILE)
-             (delete-directory/files path)
+         (lambda () 
-             (trim-directory (CACHE-DIR) path)
+           (printf "\n============= Removing ~a =============\n" (list owner name maj min))
-             #t))))
+           (clean-planet-package path (list owner name '() maj min))))
+        (erase-metadata p)
+        (delete-directory/files path)
+        (trim-directory (CACHE-DIR) path)
+        (void))))
   
   ;; erase-metadata : pkg -> void
   ;; clears out any references to the given package in planet's metadata files
@@ -135,16 +143,17 @@
   (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)])
+           [uninstalled-pkg-file (build-path uninstalled-pkg-dir name)]
-      (let ([removed-something? (remove-pkg owner name maj min)]
+           [uninstalled-file-exists? (file-exists? uninstalled-pkg-file)])
-            [erased-something?
+      (when uninstalled-file-exists?
-             (if (file-exists? uninstalled-pkg-file)
+        (delete-file uninstalled-pkg-file)
-                 (begin
+        (trim-directory (UNINSTALLED-PACKAGE-CACHE) uninstalled-pkg-dir))
-                   (delete-file uninstalled-pkg-file)
+      (with-handlers ([exn:fail:planet? 
-                   (trim-directory (UNINSTALLED-PACKAGE-CACHE) uninstalled-pkg-dir)
+                       (λ (e) (if uninstalled-file-exists? 
-                   #t)
+                                  ;; not really a failure, just return
-                 #f)])
+                                  (void)
-        (or removed-something? erased-something?))))
+                                  (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;