.

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

@@ -192,25 +192,75 @@ an appropriate subdirectory.
   (define (the-version-cache)    (namespace-variable-value VER-CACHE-NAME))
   (define (pkg->diamond-key pkg) (cons (pkg-name pkg) (pkg-route pkg)))
   
-  (define (add-pkg-to-diamond-registry! pkg)
+  (define (pkg-matches-bounds? pkg bound-info)
-    (let ((orig (hash-table-get (the-version-cache)
+    (match-let ([(maj lo hi) bound-info])
-                                (pkg->diamond-key pkg)
+      (and (= maj (pkg-maj pkg))
-                                (lambda () #f))))
+           (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
-        [(not orig) (hash-table-put! (the-version-cache) (pkg->diamond-key pkg) pkg)]
+      [(pkg> pkg1 pkg2) (can-be-loaded-together? pkg2 pkg1)]
-        [(and (eq? (pkg-maj pkg) (pkg-maj orig))
+      [(pkg= pkg1 pkg2) #t]
-              (eq? (pkg-min pkg) (pkg-min orig)))
+      [(pkg< pkg1 pkg2)
-         (void)]
+       (let* ([info (pkg->info pkg2)]
-        [else (raise (make-exn:fail (string->immutable-string
+              [compat? (build-compatibility-fn (info 'can-be-loaded-with (lambda () 'none)))])
+         (compat? pkg1))]))
+  
+  
+  (define (add-pkg-to-diamond-registry! pkg)
+    (let ((loaded-packages (hash-table-get (the-version-cache)
+                                           (pkg->diamond-key pkg)
+                                           (lambda () '()))))
+      (begin
+        (for-each
+         (lambda (already-loaded-pkg)
+           (unless (can-be-loaded-together? pkg already-loaded-pkg)
+             (raise (make-exn:fail (string->immutable-string
                                     (format 
-                                      "Package ~a loaded twice with multiple versions: 
+                                     "Package ~a loaded twice with multiple incompatible versions: 
 attempted to load version ~a.~a while version ~a.~a was already loaded" 
                                      (pkg-name pkg) 
                                      (pkg-maj 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
@@ -258,18 +308,36 @@ 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