.

svn: r2887

collects/planet/doc.txt

@@ -363,6 +363,46 @@ ignored. If you put no legal symbols in the categories field or do not
 include this field in your info.ss file, your package will be
 categorized as "Miscellaneous."
 
+The _'can-be-loaded-with field_
+
+If present, the can-be-loaded-with field should be a quoted datum of
+one of the following forms:
+   
+can-be-loaded-with = 'all
+                   | 'none
+                   | (list 'all-except VER-SPEC ...)
+                   | (list 'only VER-SPEC ...)
+
+where VER-SPEC is a quoted instance of the VER-SPEC form defined at the
+beginning of this document. 
+
+Depending on your package's behavior, it may or may not be okay for
+multiple versions of the same package to be loaded at one time on the
+entire system --- for instance, if your package relies on writing to a
+particular file and assumes that nothing else writes to that same
+file, then multiple versions of the same package being loaded
+simultaneously may be a problem. This field allows you to specify
+whether your package can be loaded simultaneously with older versions
+of itself. If its value is 'all, then the package may be loaded with
+any older version. If it is 'none, then it may not be loaded with
+older versions at all. If it is (list 'all-except VER-SPEC ...) then
+any package except those that match one of the given VER-SPEC forms
+may be loaded with this package; if it is (list 'only VER-SPEC ...)
+then only packages that match one of the given VER-SPEC forms may be
+loaded with this package.
+
+When checking to see if a package may be loaded, PLaneT compares it to
+all other currently-loaded instances of the same package with any
+version: for each comparison, it checks to see if the newer package's
+can-be-loaded-with field allows the older package to be loaded. If all
+such comparisons succeed then the new package may be loaded; otherwise
+PLaneT signals an error.
+
+The default for this field is 'none as a conservative protection
+measure. For many packages it is safe to set this field to
+'any.
+
+
 The _'doc.txt field_
 
 If present, the doc.txt field should be a string corresponding to the

collects/planet/private/planet-shared.ss

@@ -219,6 +219,19 @@ Various common pieces of code that both the client and server need to access
         (and (= (mz-version-major a) (mz-version-major b))
              (<= (mz-version-minor a) (mz-version-minor b)))))
   
+  ;; pkg< : pkg pkg -> boolean
+  ;; determines if a is an earlier version than b
+  ;; [only sensical if a and b are versions of the same package]
+  (define (pkg< a b)
+    (or (< (pkg-maj a) (pkg-maj b))
+        (and (= (pkg-maj a) (pkg-maj b))
+             (< (pkg-min a) (pkg-min b)))))
+  
+  (define (pkg> a b) 
+    (pkg< b a))
+  (define (pkg= a b) 
+    (not (or (pkg< a b) (pkg> a b))))
+  
   ;; compatible-version? : assoc-table-row FULL-PKG-SPEC -> boolean
   ;; determines if the given package constrint verstr can support the given package
   (define (compatible-version? row spec)
@@ -266,7 +279,7 @@ Various common pieces of code that both the client and server need to access
   
   ; FULL-PKG-SPEC : (make-pkg-spec string (Nat | #f) (Nat | #f) (Nat | #f) (listof string) (syntax | #f)) string
   (define-struct pkg-spec (name maj minor-lo minor-hi path stx core-version) (make-inspector))
-  ; PKG : string Nat Nat path
+  ; PKG : string (listof string) Nat Nat path
   (define-struct pkg (name route maj min path))
   
   ; ==========================================================================================
@@ -392,6 +405,15 @@ Various common pieces of code that both the client and server need to access
       (parameterize ([current-output-port outport])
         (f))))
   
+  
+  ;; pkg->info : PKG -> (symbol (-> TST) -> TST)
+  ;; get an info.ss thunk for the given package
+  (define (pkg->info p)
+    (or
+     (with-handlers ([exn:fail? (lambda (e) #f)])
+       (get-info/full (pkg-path p)))
+     (lambda (s thunk) (thunk))))
+  
   ;; ============================================================
   ;; TREE STUFF
   ;; ============================================================

collects/planet/resolver.ss

@@ -158,7 +158,7 @@ an appropriate subdirectory.
            "config.ss"
            "private/planet-shared.ss"
            "private/linkage.ss")
-
+  
   (provide (rename resolver planet-module-name-resolver)
            pkg-spec->full-pkg-spec
            get-package-from-cache
@@ -166,9 +166,9 @@ an appropriate subdirectory.
            download-package
            install-pkg
            get-planet-module-path/pkg)
-
+  
   (define install? (make-parameter #t)) ;; if #f, will not install packages and instead give an error
-
+  
   (define (resolver spec module-path stx)
     ;; ensure these directories exist
     (make-directory* (PLANET-DIR))
@@ -188,30 +188,80 @@ an appropriate subdirectory.
     (unless VER-CACHE-NAME (set! VER-CACHE-NAME (gensym)))
     (unless (namespace-variable-value VER-CACHE-NAME #t (lambda () #f))
       (namespace-set-variable-value! VER-CACHE-NAME (make-hash-table 'equal))))
-      
+  
   (define (the-version-cache)    (namespace-variable-value VER-CACHE-NAME))
   (define (pkg->diamond-key pkg) (cons (pkg-name pkg) (pkg-route pkg)))
   
+  (define (pkg-matches-bounds? pkg bound-info)
+    (match-let ([(maj lo hi) bound-info])
+      (and (= maj (pkg-maj pkg))
+           (or (not lo) (>= (pkg-min pkg) lo))
+           (or (not hi) (<= (pkg-min pkg) hi)))))
+  
+  ;; COMPAT ::= 'none | 'all | `(all-except ,VER-SPEC ...) | `(only ,VER-SPEC ...)
+  ;; build-compatibility-fn : COMPAT -> PKG -> bool
+  (define (build-compatibility-fn compat-data)
+    (define pre-fn
+      (match compat-data
+        [`none (lambda (_) #f)]
+        [`all (lambda (_) #t)]
+        [`(all-except ,vspec ...)
+          (let ((bounders (map version->bounds vspec)))
+            (if (andmap (lambda (x) x) bounders)
+                (lambda (v)
+                  (not 
+                   (ormap
+                    (lambda (bounder)
+                      (pkg-matches-bounds? v bounder))
+                    bounders)))
+                #f))]
+        [`(only ,vspec ...)
+          (let ((bounders (map version->bounds vspec)))
+            (if (andmap (lambda (x) x) bounders)
+                (lambda (v)
+                  (andmap
+                   (lambda (bounder)
+                     (pkg-matches-bounds? v bounder))
+                   bounders)))
+            #f)]
+        [_ #f]))
+    (or pre-fn (lambda (x) #f)))
+  
+  ;; can-be-loaded-together? : pkg pkg -> boolean
+  ;; side constraint: pkg1 and pkg2 are versions of the same package
+  ;; assumption: pkg1 and pkg2 are versions of the same package
+  ;; determines if the two versions are side-by-side compatible
+  (define (can-be-loaded-together? pkg1 pkg2)
+    (cond
+      [(pkg> pkg1 pkg2) (can-be-loaded-together? pkg2 pkg1)]
+      [(pkg= pkg1 pkg2) #t]
+      [(pkg< pkg1 pkg2)
+       (let* ([info (pkg->info pkg2)]
+              [compat? (build-compatibility-fn (info 'can-be-loaded-with (lambda () 'none)))])
+         (compat? pkg1))]))
+  
+  
   (define (add-pkg-to-diamond-registry! pkg)
-    (let ((orig (hash-table-get (the-version-cache)
+    (let ((loaded-packages (hash-table-get (the-version-cache)
-                                (pkg->diamond-key pkg)
+                                           (pkg->diamond-key pkg)
-                                (lambda () #f))))
+                                           (lambda () '()))))
-      (cond
+      (begin
-        [(not orig) (hash-table-put! (the-version-cache) (pkg->diamond-key pkg) pkg)]
+        (for-each
-        [(and (eq? (pkg-maj pkg) (pkg-maj orig))
+         (lambda (already-loaded-pkg)
-              (eq? (pkg-min pkg) (pkg-min orig)))
+           (unless (can-be-loaded-together? pkg already-loaded-pkg)
-         (void)]
+             (raise (make-exn:fail (string->immutable-string
-        [else (raise (make-exn:fail (string->immutable-string
+                                    (format 
-                                     (format 
+                                     "Package ~a loaded twice with multiple incompatible versions: 
-                                      "Package ~a loaded twice with multiple versions: 
 attempted to load version ~a.~a while version ~a.~a was already loaded" 
-                                      (pkg-name pkg) 
+                                     (pkg-name pkg) 
-                                      (pkg-maj pkg)
+                                     (pkg-maj pkg)
-                                      (pkg-min pkg)
+                                     (pkg-min pkg)
-                                      (pkg-maj orig)
+                                     (pkg-maj already-loaded-pkg)
-                                      (pkg-min orig)))
+                                     (pkg-min already-loaded-pkg)))
-                                    (current-continuation-marks)))])))
+                                   (current-continuation-marks)))))
-    
+         loaded-packages)
+        (hash-table-put! (the-version-cache) (pkg->diamond-key pkg) (cons pkg loaded-packages)))))
+  
   ; ==========================================================================================
   ; MAIN LOGIC
   ; Handles the overall functioning of the resolver
@@ -258,24 +308,42 @@ attempted to load version ~a.~a while version ~a.~a was already loaded"
   ; pkg-spec->full-pkg-spec : PKG-SPEC syntax -> FULL-PKG-SPEC
   (define (pkg-spec->full-pkg-spec spec stx)
     (define (pkg name maj lo hi path) (make-pkg-spec name maj lo hi path stx (version)))
+    (define (fail)
+      (raise-syntax-error 'require (format "Invalid PLaneT package specifier: ~e" spec) stx))
+    
     (match spec
-      [((? string? path) ...) (pkg (last path) #f 0 #f (drop-last path))]
+      [((? string? path) ... ver-spec ...)
-      [((? string? path) ... (? number? maj)) (pkg (last path) maj 0 #f (drop-last path))]
+       (match (version->bounds ver-spec)
-      [((? string? path) ... (? number? maj) min-spec)
+         [(maj min-lo min-hi)
-       (let ((pkg (lambda (min max) (pkg (last path) maj min max (drop-last path)))))
+          (pkg (last path) maj min-lo min-hi (drop-last path))]
+         [#f (fail)])]
+      [_ (fail)]))
+  
+  ;; version->bounds : VER-SPEC -> (list (number | #f) number (number | #f)) | #f
+  ;; determines the bounds for a given version-specifier
+  ;; [technically this handles a slightly extended version of VER-SPEC where MAJ may
+  ;;  be in a list by itself, because that's slightly more convenient for the above fn]
+  (define (version->bounds spec-list)
+    (match spec-list
+      [() (list #f 0 #f)]
+      [(? number? maj) (version->bounds (list maj))]
+      [((? number? maj)) (list maj 0 #f)]
+      [((? number? maj) min-spec)
+       (let ((pkg (lambda (min max) (list maj min max))))
          (match min-spec
            [(? number? min)                 (pkg min #f)]
            [((? number? lo) (? number? hi)) (pkg lo  hi)]
            [('= (? number? min))            (pkg min min)]
            [('+ (? number? min))            (pkg min #f)]
            [('- (? number? min))            (pkg 0   min)]))]
-      [_ (raise-syntax-error 'require (format "Invalid PLaneT package specifier: ~e" spec) stx)]))
+      [_ #f]))
-
+  
+  
   ; ==========================================================================================
   ; PHASE 2: CACHE SEARCH
   ; If there's no linkage, there might still be an appropriate cached module.
   ; ==========================================================================================
-
+  
   ; get-package-from-cache : FULL-PKG-SPEC -> PKG | #f
   (define (get-package-from-cache pkg-spec) 
     (lookup-package pkg-spec))
@@ -284,7 +352,7 @@ attempted to load version ~a.~a while version ~a.~a was already loaded"
   ; PHASE 3: SERVER RETRIEVAL
   ; Ask the PLaneT server for an appropriate package if we don't have one locally.
   ; ==========================================================================================
-                 
+  
   ; get-package-from-server : FULL-PKG-SPEC -> PKG | #f
   ; downloads and installs the given package from the PLaneT server and installs it in the cache,
   ; then returns a path to it 
@@ -343,7 +411,7 @@ attempted to load version ~a.~a while version ~a.~a was already loaded"
                  ((dynamic-require '(lib "plt-single-installer.ss" "setup") 'install-planet-package)
                   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)))))
-         
+  
   ; download-package : FULL-PKG-SPEC -> RESPONSE
   ; RESPONSE ::= (list #f string) | (list #t path[file] Nat Nat)
   ; downloads the given package and returns (list bool string): if bool is #t,
@@ -351,9 +419,9 @@ attempted to load version ~a.~a while version ~a.~a was already loaded"
   ; didn't exist and the string is the server's informative message.
   ; raises an exception if some protocol failure occurs in the download process
   (define (download-package/planet pkg)
-  
+    
     (define-values (ip op) (tcp-connect (PLANET-SERVER-NAME) (PLANET-SERVER-PORT)))
-
+    
     (define (close-ports)
       (close-input-port ip)
       (close-output-port op))
@@ -361,13 +429,13 @@ attempted to load version ~a.~a while version ~a.~a was already loaded"
     (define (request-pkg-list pkgs)
       (for-each/n (lambda (pkg seqno) 
                     (write-line (list* seqno 'get 
-                                   (DEFAULT-PACKAGE-LANGUAGE)    
+                                       (DEFAULT-PACKAGE-LANGUAGE)    
-                                   (pkg-spec-name pkg) 
+                                       (pkg-spec-name pkg) 
-                                   (pkg-spec-maj pkg) 
+                                       (pkg-spec-maj pkg) 
-                                   (pkg-spec-minor-lo pkg)
+                                       (pkg-spec-minor-lo pkg)
-                                   (pkg-spec-minor-hi pkg)
+                                       (pkg-spec-minor-hi pkg)
-                                   (pkg-spec-path pkg))
+                                       (pkg-spec-path pkg))
-                             op))
+                                op))
                   pkgs)
       (write-line 'end op)
       (flush-output op))
@@ -379,11 +447,11 @@ attempted to load version ~a.~a while version ~a.~a was already loaded"
         ['ok                        (state:send-pkg-request)]
         [('invalid (? string? msg)) (state:abort (string-append "protocol version error: " msg))]
         [bad-msg                    (state:abort (format "server protocol error (received invalid response): ~a" bad-msg))]))
-         
+    
     (define (state:send-pkg-request)
       (request-pkg-list (list pkg))
       (state:receive-package))
-        
+    
     (define (state:receive-package)
       (match (read ip)
         [(_ 'get 'ok (? nat? maj) (? nat? min) (? nat? bytes))
@@ -483,7 +551,7 @@ attempted to load version ~a.~a while version ~a.~a was already loaded"
                                      [else (list* line "\n" (loop))]))))))]
         [else
          (abort (format "Internal error (unknown HTTP response code ~a)" response-code))])))
-
+  
   ; ==========================================================================================
   ; MODULE MANAGEMENT
   ; Handles interaction with the module system
@@ -497,11 +565,11 @@ attempted to load version ~a.~a while version ~a.~a was already loaded"
        file-path
        module-path
        stx)))
-
+  
   ; ============================================================
   ; UTILITY
   ; A few small utility functions
-
+  
   (define (last l) (car (last-pair l)))
   
   ;; make-directory*/paths : path -> (listof path)