asdf version proposal

--- asdf.lisp	2006-07-24 16:04:04.000000000 +0200
+++ asdf-version.lisp	2006-07-24 16:08:50.000000000 +0200
@@ -91,7 +91,7 @@ (defpackage #:asdf
 	   #:*asdf-revision*
 	   
 	   #:operation-error #:compile-failed #:compile-warned #:compile-error
-	   #:error-component #:error-operation
+           #:version-conflict-error #:error-component #:error-operation
 	   #:system-definition-error 
 	   #:missing-component
 	   #:missing-dependency
@@ -103,6 +103,12 @@ (defpackage #:asdf
 	   
            #:preference-file-for-system/operation
            #:load-preferences
+
+           ;;versioning
+           #:make-sysdef-dir-searcher
+           #:deregister-system
+           #:print-versions
+           #:probe-system
 	   )
   (:use :cl))
 
@@ -158,6 +164,14 @@ (define-condition formatted-system-defin
   (:report (lambda (c s)
 	     (apply #'format s (format-control c) (format-arguments c)))))
 
+(define-condition version-conflict-error (system-definition-error)
+  ((name :initarg :name :reader name)
+   (current-version :initarg :current-version :reader current-version)
+   (want-version :initarg :want-version :reader want-version))
+  (:report (lambda (c s)
+             (format s "Want to register version ~A of system ~A, but version ~A is already in this image"
+                     (want-version c) (name c) (current-version c)))))
+
 (define-condition circular-dependency (system-definition-error)
   ((components :initarg :components :reader circular-dependency-components)))
 
@@ -178,6 +192,7 @@ (define-condition operation-error (error
   (:report (lambda (c s)
 	     (format s "~@<erred while invoking ~A on ~A~@:>"
 		     (error-operation c) (error-component c)))))
+
 (define-condition compile-error (operation-error) ())
 (define-condition compile-failed (compile-error) ())
 (define-condition compile-warned (compile-error) ())
@@ -185,7 +200,7 @@ (define-condition compile-warned (compil
 (defclass component ()
   ((name :accessor component-name :initarg :name :documentation
 	 "Component name: designator for a string composed of portable pathname characters")
-   (version :accessor component-version :initarg :version)
+   (version :accessor component-version :initarg :version :initform :unspecific)
    (in-order-to :initform nil :initarg :in-order-to)
    ;;; XXX crap name
    (do-first :initform nil :initarg :do-first)
@@ -197,6 +212,7 @@ (defclass component ()
    ;; no direct accessor for pathname, we do this as a method to allow
    ;; it to default in funky ways if not supplied
    (relative-pathname :initarg :pathname)
+   (loaded-from :initarg :loaded-from :accessor loaded-from)
    (operation-times :initform (make-hash-table )
 		    :accessor component-operation-times)
    ;; XXX we should provide some atomic interface for updating the
@@ -204,6 +220,13 @@ (defclass component ()
    (properties :accessor component-properties :initarg :properties
 	       :initform nil)))
 
+(defmethod initialize-instance :after ((instance component) &rest initargs)
+  (declare (ignore initargs))
+  (assert (typep (component-version instance)
+                 '(or string (eql :unspecific)))
+      nil "~A is an invalid version specifier (must be a string of form \"x.y.z\")."
+    (component-version instance)))
+
 ;;;; methods: conditions
 
 (defmethod print-object ((c missing-dependency) s)
@@ -307,23 +330,146 @@ (defun split (string &optional max (ws '
 	(unless end (return list))
 	(setf start (1+ end)))))))
 
-(defgeneric version-satisfies (component version))
+(deftype version-specifier ()
+  `(or null (eql :max) (eql :current) string))
+
+(defgeneric version-satisfies (component version)
+  (:method ((c component) version)
+   (cond ((and version (slot-boundp c 'version)) 
+          (version-satisfies (component-version c) version))
+         ((null version) t)
+         (t nil)))
+  (:method ((version sequence) (against sequence))
+   (every #'(lambda (test) (funcall test version))
+          (create-tests (coerce-version against))))
+  (:method ((version sequence) (against (eql :unspecific)))
+   (declare (ignore version against))
+   t)
+  (:method (version (against (eql :current)))
+   (declare (ignore version against))
+   t)
+  (:method ((version (eql :unspecific)) (against sequence))
+   (declare (ignore version))
+   (version-satisfies "0" against))
+  (:method ((version (eql :unspecific)) (against (eql :unspecific)))
+   (declare (ignore version against))
+   t)
+  (:documentation "Tests specific version TEST against a version specifier AGAINST"))
+
+;; Version testing
+(defun coerce-to-version-numbers (version)
+  "Changes string version into a list containing version elements"
+  (mapcar (lambda (x)
+            (or (parse-integer x :junk-allowed t) -1))
+          (split version nil '(#\.))))
+
+(defun create-comparable-versions (version1 version2)
+  (let* ((v1 (coerce-to-version-numbers version1))
+         (v2 (coerce-to-version-numbers version2))
+         (max (max (length v1) (length v2))))
+    (list (map-into (make-list max :initial-element 0) 'identity v1)
+          (map-into (make-list max :initial-element 0) 'identity v2))))
+
+(defun version= (test against)
+  (if (or (symbolp test) (symbolp against))
+      (eql test against)
+      (apply #'every #'= (create-comparable-versions test against))))
+
+(defun version> (test against)
+  ;; handle unspecific as the version
+  (when (eql test :unspecific)
+    (return-from version> nil))
+  (when (eql against :unspecific)
+    (return-from version> t))
+  (destructuring-bind (v1 v2)
+      (create-comparable-versions test against)
+    (loop :for v1-component :in v1 
+          :for v2-component :in v2
+          :when (< v1-component v2-component)
+          :do (return nil)
+          :when (> v1-component v2-component)
+          :do (return t))))
+
+(defun version>= (test against)
+  (or (version> test against)
+      (version= test against)))
+
+(defun version< (test against)
+  (not (version>= test against)))
+
+(defun version<= (test against)
+  (not (version> test against)))
+
+
+(defun version-after (string)
+  (cond ((search "?<=" string)
+         (list 'version<= (subseq string (+ 3 (search "?<=" string)))))
+        ((search "?<" string)
+         (list 'version< (subseq string (+ 2 (search "?<" string)))))))
+
+(defun version-before (string)
+  (cond ((search "<=?" string)
+         (list 'version>= (subseq string 0 (search "<=?" string))))
+        ((search "<?" string)
+         (list 'version> (subseq string 0 (search "<?" string))))))
+
+
+(defun create-tests (string)
+  (unless (find #\? string) ;; simple version spec
+    (return-from create-tests 
+      (list (lambda (x) (version= x string)))))
+
+  (let ((tests ()))
+    (let ((test (version-after string)))
+      (when test
+        (push #'(lambda (version)
+                  (funcall (car test) version (second test)))
+              tests)))
+    (let ((test (version-before string)))
+      (when test
+        (push #'(lambda (version)
+                  (funcall (car test) version (second test)))
+              tests)))
+    tests))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; extracting versions from asd files
+
+(defun make-temporary-package ()
+  (flet ((try (counter)
+           (ignore-errors
+                   (make-package (format nil "ASDF~D" counter)
+                                 :use '(:cl :asdf)))))
+    (do* ((counter 0 (+ counter 1))
+          (package (try counter) (try counter)))
+         (package package))))
 
-(defmethod version-satisfies ((c component) version)
-  (unless (and version (slot-boundp c 'version))
-    (return-from version-satisfies t))
-  (let ((x (mapcar #'parse-integer
-		   (split (component-version c) nil '(#\.))))
-	(y (mapcar #'parse-integer
-		   (split version nil '(#\.)))))
-    (labels ((bigger (x y)
-	       (cond ((not y) t)
-		     ((not x) nil)
-		     ((> (car x) (car y)) t)
-		     ((= (car x) (car y))
-		      (bigger (cdr x) (cdr y))))))
-      (and (= (car x) (car y))
-	   (or (not (cdr y)) (bigger (cdr x) (cdr y)))))))
+;; version extractors
+(defmacro with-temp-package ((bind-to) &body body)
+  (let ((gpackage (gensym "temp-package")))
+    `(let ((,gpackage (make-temporary-package)))
+       (unwind-protect 
+           (let ((,bind-to ,gpackage))
+             (progn ,@body))
+         (delete-package ,gpackage)))))
+
+(defun extract-asdf-version (path system)
+  "Extracts the version of the system specified by PATH and SYSTEM.
+Uses functions listed in *asdf-version-extractors*"
+  (with-open-file (stream path)
+    (with-temp-package (*package*)
+      (labels ((process-form (form)
+                 (cond ((atom form) nil)
+                       ((and (eql (car form) 'asdf:defsystem)
+                             ;; make sure it's for this system
+                             (string= (string-upcase (second form))
+                                      (string-upcase system)))
+                        (getf (cddr form) :version))
+                       (t (some #'process-form (cdr form))))))
+        (loop :for form = (ignore-errors (read stream nil #1="EOF"))
+              :until (eq form #1#)
+              :thereis (process-form form)
+              :finally (return :unspecific))))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; finding systems
@@ -342,10 +488,6 @@ (defun coerce-name (name)
 (defvar *system-definition-search-functions*
   '(sysdef-central-registry-search))
 
-(defun system-definition-pathname (system)
-  (some (lambda (x) (funcall x system))
-	*system-definition-search-functions*))
-	
 (defvar *central-registry*
   '(*default-pathname-defaults*
     #+nil "/home/dan/src/sourceforge/cclan/asdf/systems/"
@@ -363,45 +505,174 @@ (defun sysdef-central-registry-search (s
 	  (if (and file (probe-file file))
 	      (return file)))))))
 
-(defun make-temporary-package ()
-  (flet ((try (counter)
-           (ignore-errors
-                   (make-package (format nil "ASDF~D" counter)
-                                 :use '(:cl :asdf)))))
-    (do* ((counter 0 (+ counter 1))
-          (package (try counter) (try counter)))
-         (package package))))
-
-(defun find-system (name &optional (error-p t))
-  (let* ((name (coerce-name name))
-	 (in-memory (gethash name *defined-systems*))
-	 (on-disk (system-definition-pathname name)))	 
-    (when (and on-disk
-	       (or (not in-memory)
-		   (< (car in-memory) (file-write-date on-disk))))
-      (let ((package (make-temporary-package)))
-        (unwind-protect
-             (let ((*package* package))
-               (format 
-                *verbose-out*
-                "~&~@<; ~@;loading system definition from ~A into ~A~@:>~%"
-                ;; FIXME: This wants to be (ENOUGH-NAMESTRING
-                ;; ON-DISK), but CMUCL barfs on that.
-		on-disk
-		*package*)
-               (load on-disk))
-          (delete-package package))))
-    (let ((in-memory (gethash name *defined-systems*)))
-      (if in-memory
-	  (progn (if on-disk (setf (car in-memory) (file-write-date on-disk)))
-		 (cdr in-memory))
-	  (if error-p (error 'missing-component :requires name))))))
+(defun get-asd-files (system)
+  (delete-duplicates (loop :for loader :in *system-definition-search-functions*
+                           :for possible = (funcall loader system)
+                           :if (listp possible) :append possible
+                           :else :collect possible)
+                     :test #'equal))
+
+(defun list-versions (system)
+  (sort 
+   (loop :for sys :in (get-asd-files system)
+         :collect (list sys (extract-asdf-version sys system)))
+   #'version>
+   :key 'second))
+
+
+(defun print-versions (system)
+  (format t "~&~A~%~{~{~,12T~A~^ ~}~%~}" system
+          (mapcar 'nreverse (list-versions system))))
+
+(defun ends-with (string with)
+  (let ((search (search with string :from-end t)))
+    (and search (= (+ (length with) search)
+                   (length string)))))
+
+(defun wild-version-p (version)
+  "Is version of the form 1.2.*"
+  (and (stringp version)
+       (ends-with version ".*")))
+
+(defun coerce-to-normal-version (version)
+  "Convert VERSION from a format like 1.3.* to 1.3<=?<1.4"
+  (let ((version-nums (coerce-to-version-numbers
+                       (subseq version 0 (- (length version) 2)))))
+    (with-output-to-string (s)
+      (format s "~{~A~^.~}<=?<" version-nums)
+      (incf (car (last version-nums)))
+      (format s "~{~A~^.~}" version-nums))))
+
+(defun coerce-version (version)
+  (cond ((or (null version) (eql version :max)) "0<=?")
+        ((wild-version-p version) (coerce-to-normal-version version))
+        (t version)))
+
+(defun probe-system (sys-name &optional (version :max))
+  (check-type version version-specifier "a valid version specifier")
+  (delete-if-not (lambda (x) (version-satisfies x (coerce-version version)))
+                 (list-versions sys-name) :key 'second))
+
+(defun system-definition-pathname (system &optional (version :max))
+  (check-type version version-specifier "a valid version specifier")
+  (values-list (first (probe-system system version))))
+
+(defun make-sysdef-dir-searcher (path)
+  #'(lambda (system)
+      (let* ((name (coerce-name system))
+             (search-path (merge-pathnames (translate-logical-pathname path)
+                                           (make-pathname :name name :type "asd"
+                                                          :version :newest
+                                                          :case :local))))
+        (remove-if-not #'probe-file (directory search-path)))))
+
+(defun load-system-definition (file)
+  (with-temp-package (*package*)
+    (format 
+     *verbose-out*
+     "~&~@<; ~@;loading system definition from ~A into ~A~@:>~%"
+     ;; FIXME: This wants to be (ENOUGH-NAMESTRING
+     ;; ON-DISK), but CMUCL barfs on that.
+     file
+     *package*)
+    (load file)))
+
+(defun reload-current (name in-memory &optional backup)
+  "Reloads system NAME that is currently loaded if it is necessary.
+If the file that it was loaded from no longer exists then
+a. Use BACKUP instead.
+b. Use the second value returned from system-definition-pathname"  
+  (with-slots (loaded-from version) (cdr in-memory)
+    ;; this check is for when find-component is called before
+    ;; the system is initialized (call happens in parse-component-form)
+    (when (slot-boundp (cdr in-memory) 'loaded-from)
+      (cond ((or (not loaded-from) (not (probe-file loaded-from)))
+             (warn "System ~A (~A) was loaded from ~A but it no longer exists."
+                   name version loaded-from)
+             ;; use backup if loaded-from no longer exists or try and
+             ;; find another system of that version on the file-system
+             (unless (eql version :unspecific) ;; ignore unspecific
+               (let ((path (or backup
+                               (system-definition-pathname name version))))
+                 (when path
+                   (warn "Using file ~A as new system definition." path)
+                   (setf loaded-from     path
+                         (car in-memory) (file-write-date path))
+                   (load-system-definition path)))))
+            ((and loaded-from (probe-file loaded-from)
+                  (< (car in-memory) (file-write-date loaded-from)))
+             (setf (car in-memory) (file-write-date loaded-from))
+             (load-system-definition loaded-from))))))
+
+(defun load-one-of (name in-memory on-disk on-disk-version test-version)
+  (let ((sys-version (component-version (cdr in-memory))))
+    (cond ((version= on-disk-version sys-version) 
+           (reload-current name in-memory on-disk))
+          ((version> on-disk-version sys-version) 
+           (labels ((in-memory-restart ()
+                      (restart-case (on-disk-restart)
+                        (use-existing-system ()
+                          :report "Use existing system."
+                          (reload-current name in-memory))))
+                    (on-disk-restart ()
+                      (restart-case (error 'version-conflict-error
+                                           :name name
+                                           :want-version on-disk-version
+                                           :current-version sys-version)
+                        (use-system-on-disk ()
+                          :report "Load system on disk (Note. this may break your image)"
+                           (deregister-system name)
+                           (load-system-definition on-disk)))))
+             (if (version-satisfies sys-version test-version)
+                 (in-memory-restart)
+                 (on-disk-restart))))
+          ((version< on-disk-version sys-version)
+           (if (version-satisfies sys-version test-version)
+               (reload-current name in-memory)
+               (progn (cerror "Replace existing system definition. (Note. This may break your image)"
+                              'version-conflict-error
+                              :name name
+                              :want-version on-disk-version
+                              :current-version sys-version)
+                 (deregister-system name)
+                 (load-system-definition on-disk)))))))
+
+(defun find-system (name &optional (error-p t) (version :current))
+  (check-type version version-specifier "a valid version specifier")
+  (let ((in-memory (system-registered-p name))
+        (version (or version :current))) ;in case nil explicitly passed
+    (cond ((eql version :current) (if in-memory
+                                      (reload-current name in-memory)
+                                      (return-from find-system
+                                        (find-system name error-p :max))))
+          (t (multiple-value-bind (on-disk on-disk-version)
+                 (system-definition-pathname name (coerce-version version))
+               (cond ((and (not in-memory) on-disk)
+                      (load-system-definition on-disk))
+                     ((and in-memory (not on-disk))
+                      (when (version-satisfies (cdr in-memory)
+                                               (coerce-version version))
+                        (reload-current name in-memory)))
+                     ((and in-memory on-disk)
+                      (load-one-of name in-memory on-disk on-disk-version
+                                   (coerce-version version))))))))
+  (let ((in-memory (system-registered-p name)))
+    (if (and in-memory (version-satisfies (cdr in-memory)
+                                          (coerce-version version)))
+        (cdr in-memory)
+        (when error-p
+          (error 'missing-component :requires name
+                 :version (if (eql version :max) nil version))))))
 
 (defun register-system (name system)
   (format *verbose-out* "~&~@<; ~@;registering ~A as ~A~@:>~%" system name)
   (setf (gethash (coerce-name  name) *defined-systems*)
 	(cons (get-universal-time) system)))
 
+(defun deregister-system (name)
+  (format *verbose-out* "~&~@<; ~@;deregistering ~A~@:>~%" name)
+  (remhash (coerce-name name) *defined-systems*))
+
 (defun system-registered-p (name)
   (gethash (coerce-name name) *defined-systems*))
 
@@ -422,7 +693,7 @@ (defmethod find-component ((module modul
 
 ;;; a component with no parent is a system
 (defmethod find-component ((module (eql nil)) name &optional version)
-  (let ((m (find-system name nil)))
+  (let ((m (find-system name nil version)))
     (if (and m (version-satisfies m version)) m)))
 
 ;;; component subclasses
@@ -869,13 +1140,12 @@ (defmethod preference-file-for-system/op
 
 (defun operate (operation-class system &rest args &key (verbose t) version 
                                 &allow-other-keys)
+  (check-type version version-specifier "a valid version specifier")
   (let* ((op (apply #'make-instance operation-class
 		    :original-initargs args
 		    args))
 	 (*verbose-out* (if verbose *trace-output* (make-broadcast-stream)))
-	 (system (if (typep system 'component) system (find-system system))))
-    (unless (version-satisfies system version)
-      (error 'missing-component :requires system :version version))
+	 (system (if (typep system 'component) system (find-system system t version))))
     (let ((steps (traverse op system)))
       (with-compilation-unit ()
 	(loop for (op . component) in steps do
@@ -927,9 +1197,9 @@ (defmacro defsystem (name &body options)
 	  (cond ((and s (eq (type-of (cdr s)) ',class))
 		 (setf (car s) (get-universal-time)))
 		(s
-		 #+clisp
+		 #+(and clisp (not mop))
 		 (sysdef-error "Cannot redefine the existing system ~A with a different class" s)
-		 #-clisp
+		 #-(and clisp (not mop))
 		 (change-class (cdr s) ',class))
 		(t
 		 (register-system (quote ,name)
@@ -1030,6 +1300,7 @@ (defun parse-component-form (parent opti
 	     ret
 	     :name (coerce-name name)
 	     :pathname pathname
+             :loaded-from *load-truename*
 	     :parent parent
 	     other-args)
       (when (typep ret 'module)