Re: asdf version proposal
Gary King <[email protected]>
| Newsgroups | gmane.lisp.cclan.general |
|---|---|
| Message-ID | <[email protected]> |
Hi Sean,
Sorry for the delayed response, I missed this email last week.
I think this sounds like a great step forward. Without giving it much
thought, I'd suggest adding a parameter to control whether "1.2.3" is
exact or not and the like. Something like *asdf-version-match-exact-
p* (I'm sure that there is a better name but I just woke up <smile>).
Another idea would be to have ASDF support a list of compatible
versions. Initially, this list could be maintained only by ASDF and
would be written to when the user elected to continue past a version
mismatch error (e.g., there would be two restarts, one would be to
load the version anyways and the other would be to load the version
anyways and not make the check again -- I hope that makes sense).
(FWIW, I'm imaging something similar to the trusted providers list in
ASDF-Install). At some unspecified point in the ever churning future,
system authors could specify this information themselves in the
properties and/or ASDF-Install could also help maintain things.
I'll start testing your patch later today and let you know if
anything goes awry.
thanks
On Jul 24, 2006, at 10:15 AM, Sean Ross wrote:
> Hi all,
>
> I've been working on more comprehensive version support in
> asdf and i think it's finally ready for public consumption.
>
> This patch adds full support for version specifiers with asdf although
> a couple of extra changes had to be made to make the feature useful.
> First on this list is allowing the functions in
> asdf:*system-definition-search-functions* to return either a single
> pathname or a list of pathnames, this allows
> system-definition-pathname to choose the 'best version' to load out of
> the asdf files found. Second is to add
> asdf:make-sysdef-dir-searcher. As it currently stands
> sysdef-central-registry-search only returns a single dot asdf file
> which doesn't help us much.
>
> make-sysdef-dir-searcher is a function of 1 argument which returns a
> closure which is suitable to be pushed onto
> asdf:*system-definition-search-functions* The argument is a pathname,
> with some sort of wild entry in the directory component (eg
> "/share/lisp/asdf-install/site/*/"). This also sorts the 'lack of soft
> link' problem that people have experienced on Windows.
>
> When requesting a version you give an exact version or a version range
> examples.
> - "?<=1.0" max version less than or equal to 1.0
> - "?<1.0" max version less than 1.0
> - "3.0<?" max version greater than 3.0
> - "1.0<?<2.0" largest version greater than 1.0 and less than 2.0
> - "1.3" the version 1.3 (1.3.0 will match)
>
> Wildcard versions like "1.2.*" are also supported. These are
> transformed into an appropriate ranged version like "1.2<=?<1.3".
>
> These versions are then compared to the version extracted from the
> .asd files (this seems to be the only way to get a version, loading
> multiple system definition could cause all sorts of problems), or
> :unspecific if no version is specified.
>
> The patch is (almost) fully non-intrusive, people upgrading to this
> version and not using the new features shouldn't experience anything
> different.
>
> Now about that 'almost'. On of the possible points of annoyance is
> that when specifying a specific version eg "1.2.3" the new version of
> version-satisfies will take it to mean the 'EXACT' version 1.2.3 while
> currently it means anything greater than or equal to 1.2.3.
>
> The other is that the :version argument to defsystem must be a string
> (this gets caught in a 'initialize-instance :after' method on
> component) or the symbol :unspecific. I haven't seen a system that
> doesn't conform to this, but that doesn't mean they don't exist.
>
> I've been running this for the last month or so and haven't run into
> any problems (asdf is still able to register and load the 80 odd
> systems on my machine) and handle multiple versions of systems and
> systems without versions.
>
> This patch does not address the concept of compatible versions but
> I feel that
> that can be added at a later date.
>
> There is also a small change of the read time conditional for clisp
> in defsystem
> which caters for more recent versions with a mop.
>
> The patch is against the latest downloaded asdf.lisp file (revision
> 100),
> sorry I'm currently firewalled off :(
>
> Thoughts, comments?
>
> Cheers
> Sean.
>
> --- 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 :n
> ewest
> + :case :loca
> l))))
> + (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)
>
> ----------------------------------------------------------------------
> ---
> Take Surveys. Earn Cash. Influence the Future of IT
> Join SourceForge.net's Techsay panel and you'll get the chance to
> share your
> opinions on IT & business topics through brief surveys -- and earn
> cash
> http://www.techsay.com/default.php?
> page=join.php&p=sourceforge&CID=DEVDEV________________________________
> _______________
> cclan-list mailing list
> [email protected]
> https://lists.sourceforge.net/lists/listinfo/cclan-list
--
Gary Warren King
metabang.com [http://www.metabang.com/]
(413) 885 9127 * (206) 338-4052 [Fax]
gwking on #lisp (occasionally)
-------------------------------------------------------------------------
Take Surveys. Earn Cash. Influence the Future of IT
Join SourceForge.net's Techsay panel and you'll get the chance to share your
opinions on IT & business topics through brief surveys -- and earn cash
http://www.techsay.com/default.php?page=join.php&p=sourceforge&CID=DEVDEV