Commit 5187114d authored by Francois-Rene Rideau's avatar Francois-Rene Rideau

2.31.3: ensure upgrade before find-system. Also tweak primary/secondary output.

If you let find-system inside with-system-definitions before you upgrade ASDF,
you might have bad surprises when you upgrade then a previous definition survives.
parent feadbfaf
...@@ -74,7 +74,7 @@ ...@@ -74,7 +74,7 @@
:licence "MIT" :licence "MIT"
:description "Another System Definition Facility" :description "Another System Definition Facility"
:long-description "ASDF builds Common Lisp software organized into defined systems." :long-description "ASDF builds Common Lisp software organized into defined systems."
:version "2.31.2" ;; to be automatically updated by make bump-version :version "2.31.3" ;; to be automatically updated by make bump-version
:depends-on () :depends-on ()
#+asdf3 :encoding #+asdf3 :utf-8 #+asdf3 :encoding #+asdf3 :utf-8
;; For most purposes, asdf itself specially counts as a builtin system. ;; For most purposes, asdf itself specially counts as a builtin system.
......
...@@ -147,24 +147,33 @@ ...@@ -147,24 +147,33 @@
;;;; compatfmt: avoid fancy format directives when unsupported ;;;; compatfmt: avoid fancy format directives when unsupported
(eval-when (:load-toplevel :compile-toplevel :execute) (eval-when (:load-toplevel :compile-toplevel :execute)
(defun remove-substrings (substrings string) (defun frob-substrings (string substrings &optional frob)
(declare (optimize (speed 0) (safety 3) (debug 3)))
(let ((length (length string)) (stream nil)) (let ((length (length string)) (stream nil))
(labels ((emit (start end) (labels ((emit-string (x &optional (start 0) (end (length x)))
(when (and (zerop start) (= end length))
(return-from remove-substrings string))
(when (< start end) (when (< start end)
(unless stream (setf stream (make-string-output-stream))) (unless stream (setf stream (make-string-output-stream)))
(write-string string stream :start start :end end))) (write-string x stream :start start :end end)))
(emit-substring (start end)
(when (and (zerop start) (= end length))
(return-from frob-substrings string))
(emit-string string start end))
(recurse (substrings start end) (recurse (substrings start end)
(cond (cond
((>= start end)) ((>= start end))
((null substrings) (emit start end)) ((null substrings) (emit-substring start end))
(t (let* ((sub (first substrings)) (t (let* ((sub-spec (first substrings))
(sub (if (consp sub-spec) (car sub-spec) sub-spec))
(fun (if (consp sub-spec) (cdr sub-spec) frob))
(found (search sub string :start2 start :end2 end)) (found (search sub string :start2 start :end2 end))
(more (rest substrings))) (more (rest substrings)))
(cond (cond
(found (found
(recurse more start found) (recurse more start found)
(etypecase fun
(null)
(string (emit-string fun))
(function (funcall fun sub #'emit-string)))
(recurse substrings (+ found (length sub)) end)) (recurse substrings (+ found (length sub)) end))
(t (t
(recurse more start end)))))))) (recurse more start end))))))))
...@@ -173,7 +182,7 @@ ...@@ -173,7 +182,7 @@
(defmacro compatfmt (format) (defmacro compatfmt (format)
#+(or gcl genera) #+(or gcl genera)
(remove-substrings `("~3i~_" #+(or genera gcl2.6) ,@'("~@<" "~@;" "~@:>" "~:>")) format) (frob-substrings format `("~3i~_" #+(or genera gcl2.6) ,@'("~@<" "~@;" "~@:>" "~:>")))
#-(or gcl genera) format)) #-(or gcl genera) format))
...@@ -7,7 +7,7 @@ ...@@ -7,7 +7,7 @@
:asdf/component :asdf/system :asdf/cache) :asdf/component :asdf/system :asdf/cache)
(:export (:export
#:remove-entry-from-registry #:coerce-entry-to-directory #:remove-entry-from-registry #:coerce-entry-to-directory
#:coerce-name #:primary-system-name #:coerce-name #:primary-system-name #:coerce-filename
#:find-system #:locate-system #:load-asd #:with-system-definitions #:find-system #:locate-system #:load-asd #:with-system-definitions
#:system-registered-p #:register-system #:registered-systems #:clear-system #:map-systems #:system-registered-p #:register-system #:registered-systems #:clear-system #:map-systems
#:system-definition-error #:missing-component #:missing-requires #:missing-parent #:system-definition-error #:missing-component #:missing-requires #:missing-parent
...@@ -69,6 +69,9 @@ ...@@ -69,6 +69,9 @@
;; the first of the slash-separated components. ;; the first of the slash-separated components.
(first (split-string (coerce-name name) :separator "/"))) (first (split-string (coerce-name name) :separator "/")))
(defun coerce-filename (name)
(frob-substrings (coerce-name name) '("/" ":" "\\") "--"))
(defvar *defined-systems* (make-hash-table :test 'equal) (defvar *defined-systems* (make-hash-table :test 'equal)
"This is a hash table whose keys are strings, being the "This is a hash table whose keys are strings, being the
names of the systems, and whose values are pairs, the first names of the systems, and whose values are pairs, the first
...@@ -272,6 +275,12 @@ Going forward, we recommend new users should be using the source-registry. ...@@ -272,6 +275,12 @@ Going forward, we recommend new users should be using the source-registry.
(let ((*systems-being-defined* (make-hash-table :test 'equal))) (let ((*systems-being-defined* (make-hash-table :test 'equal)))
(call-with-asdf-cache thunk)))) (call-with-asdf-cache thunk))))
(defun clear-systems-being-defined ()
(when *systems-being-defined*
(clrhash *systems-being-defined*)))
(register-hook-function '*post-upgrade-cleanup-hook* 'clear-systems-being-defined)
(defmacro with-system-definitions ((&optional) &body body) (defmacro with-system-definitions ((&optional) &body body)
`(call-with-system-definitions #'(lambda () ,@body))) `(call-with-system-definitions #'(lambda () ,@body)))
......
;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*- ;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
;;; This is ASDF 2.31.2: Another System Definition Facility. ;;; This is ASDF 2.31.3: Another System Definition Facility.
;;; ;;;
;;; Feedback, bug reports, and patches are all welcome: ;;; Feedback, bug reports, and patches are all welcome:
;;; please mail to <asdf-devel@common-lisp.net>. ;;; please mail to <asdf-devel@common-lisp.net>.
......
...@@ -5,7 +5,8 @@ ...@@ -5,7 +5,8 @@
(:recycle :asdf/lisp-action :asdf) (:recycle :asdf/lisp-action :asdf)
(:intern #:proclamations #:flags) (:intern #:proclamations #:flags)
(:use :asdf/common-lisp :asdf/driver :asdf/upgrade (:use :asdf/common-lisp :asdf/driver :asdf/upgrade
:asdf/cache :asdf/component :asdf/system :asdf/find-component :asdf/operation :asdf/action) :asdf/cache :asdf/component :asdf/system :asdf/find-component :asdf/find-system
:asdf/operation :asdf/action)
(:export (:export
#:try-recompiling #:try-recompiling
#:cl-source-file #:cl-source-file.cl #:cl-source-file.lsp #:cl-source-file #:cl-source-file.cl #:cl-source-file.lsp
...@@ -159,7 +160,7 @@ ...@@ -159,7 +160,7 @@
(defmethod output-files ((o compile-op) (c system)) (defmethod output-files ((o compile-op) (c system))
(when (and *warnings-file-type* (not (builtin-system-p c))) (when (and *warnings-file-type* (not (builtin-system-p c)))
(if-let ((pathname (component-pathname c))) (if-let ((pathname (component-pathname c)))
(list (subpathname pathname (component-name c) :type "build-report")))))) (list (subpathname pathname (coerce-filename c) :type "build-report"))))))
;;; load-op ;;; load-op
(with-upgradability () (with-upgradability ()
......
...@@ -16,30 +16,9 @@ ...@@ -16,30 +16,9 @@
(in-package :asdf/operate) (in-package :asdf/operate)
(with-upgradability () (with-upgradability ()
(defgeneric* (operate) (operation component &key &allow-other-keys)) (defgeneric* (operate) (operation component &key &allow-other-keys)
(define-convenience-action-methods (:documentation
operate (operation component &key) "Operate does three things:
:operation-initargs t ;; backward-compatibility with ASDF1. Yuck.
:if-no-component (error 'missing-component :requires component))
(defvar *systems-being-operated* nil
"A boolean indicating that some systems are being operated on")
(defmethod operate :around (operation component
&key verbose
(on-warnings *compile-file-warnings-behaviour*)
(on-failure *compile-file-failure-behaviour*) &allow-other-keys)
(declare (ignorable operation component))
;; Setup proper bindings around any operate call.
(with-system-definitions ()
(let* ((*verbose-out* (and verbose *standard-output*))
(*compile-file-warnings-behaviour* on-warnings)
(*compile-file-failure-behaviour* on-failure))
(call-next-method))))
(defmethod operate ((operation operation) (component component)
&rest args &key version &allow-other-keys)
"Operate does three things:
1. It creates an instance of OPERATION-CLASS using any keyword parameters as initargs. 1. It creates an instance of OPERATION-CLASS using any keyword parameters as initargs.
2. It finds the asdf-system specified by SYSTEM (possibly loading it from disk). 2. It finds the asdf-system specified by SYSTEM (possibly loading it from disk).
...@@ -57,30 +36,60 @@ The :FORCE or :FORCE-NOT argument to OPERATE can be: ...@@ -57,30 +36,60 @@ The :FORCE or :FORCE-NOT argument to OPERATE can be:
without recursively forcing the other systems we depend on. without recursively forcing the other systems we depend on.
:ALL to force all systems including other systems we depend on to be rebuilt (resp. not). :ALL to force all systems including other systems we depend on to be rebuilt (resp. not).
(SYSTEM1 SYSTEM2 ... SYSTEMN) to force systems named in a given list (SYSTEM1 SYSTEM2 ... SYSTEMN) to force systems named in a given list
:FORCE has precedence over :FORCE-NOT; builtin systems cannot be forced." :FORCE has precedence over :FORCE-NOT; builtin systems cannot be forced."))
(let* (;; I'd like to remove-plist-keys :force :force-not :verbose,
;; but swank.asd relies on :force (!). (define-convenience-action-methods
(systems-being-operated *systems-being-operated*) operate (operation component &key)
;; I'd like to at least remove-plist-keys :force :force-not :verbose,
;; but swank.asd relies on :force (!).
:operation-initargs t ;; backward-compatibility with ASDF1. Yuck.
:if-no-component (error 'missing-component :requires component))
(defvar *systems-being-operated* nil
"A boolean indicating that some systems are being operated on")
(defmethod operate :around (operation component &rest keys
&key verbose
(on-warnings *compile-file-warnings-behaviour*)
(on-failure *compile-file-failure-behaviour*) &allow-other-keys)
(declare (ignorable operation component))
(let* ((systems-being-operated *systems-being-operated*)
(*systems-being-operated* (or systems-being-operated (make-hash-table :test 'equal))) (*systems-being-operated* (or systems-being-operated (make-hash-table :test 'equal)))
(system (component-system component))) (operation-name (reify-symbol (etypecase operation
(operation (type-of operation))
(symbol operation))))
(component-path (typecase component
(component (component-find-path component))
(t component))))
;; Before we operate on any system, make sure ASDF is up-to-date, ;; Before we operate on any system, make sure ASDF is up-to-date,
;; for if an upgrade is ever attempted at any later time, there may be BIG trouble. ;; for if an upgrade is ever attempted at any later time, there may be BIG trouble.
(unless systems-being-operated (unless systems-being-operated
(let ((operation-name (reify-symbol (type-of operation))) (when (upgrade-asdf)
(component-path (component-find-path component))) ;; If we were upgraded, restart OPERATE the hardest of ways, for
(when (upgrade-asdf) ;; its function may have been redefined, its symbol uninterned, its package deleted.
;; If we were upgraded, restart OPERATE the hardest of ways, for (return-from operate
;; its function may have been redefined, its symbol uninterned, its package deleted. (apply (find-symbol* 'operate :asdf)
(return-from operate (unreify-symbol operation-name)
(apply (find-symbol* 'operate :asdf) component-path keys))))
(unreify-symbol operation-name) ;; Setup proper bindings around any operate call.
component-path args))))) (with-system-definitions ()
(setf (gethash (coerce-name system) *systems-being-operated*) system) (let* ((*verbose-out* (and verbose *standard-output*))
(unless (version-satisfies component version) (*compile-file-warnings-behaviour* on-warnings)
(error 'missing-component-of-version :requires component :version version)) (*compile-file-failure-behaviour* on-failure))
(let ((plan (apply 'traverse operation system args))) (call-next-method)))))
(perform-plan plan)
(values operation plan)))) (defmethod operate :before ((operation operation) (component component)
&key version &allow-other-keys)
(let ((system (component-system component)))
(setf (gethash (coerce-name system) *systems-being-operated*) system))
(unless (version-satisfies component version)
(error 'missing-component-of-version :requires component :version version)))
(defmethod operate ((operation operation) (component component)
&rest keys &key &allow-other-keys)
(let ((plan (apply 'traverse operation component keys)))
(perform-plan plan)
(values operation plan)))
(defun oos (operation component &rest args &key &allow-other-keys) (defun oos (operation component &rest args &key &allow-other-keys)
(apply 'operate operation component args)) (apply 'operate operation component args))
......
...@@ -52,7 +52,7 @@ You can compare this string with e.g.: (ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSIO ...@@ -52,7 +52,7 @@ You can compare this string with e.g.: (ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSIO
;; "3.4.5.67" would be a development version in the official upstream of 3.4.5. ;; "3.4.5.67" would be a development version in the official upstream of 3.4.5.
;; "3.4.5.0.8" would be your eighth local modification of official release 3.4.5 ;; "3.4.5.0.8" would be your eighth local modification of official release 3.4.5
;; "3.4.5.67.8" would be your eighth local modification of development version 3.4.5.67 ;; "3.4.5.67.8" would be your eighth local modification of development version 3.4.5.67
(asdf-version "2.31.2") (asdf-version "2.31.3")
(existing-version (asdf-version))) (existing-version (asdf-version)))
(setf *asdf-version* asdf-version) (setf *asdf-version* asdf-version)
(when (and existing-version (not (equal asdf-version existing-version))) (when (and existing-version (not (equal asdf-version existing-version)))
......
...@@ -5,9 +5,9 @@ ...@@ -5,9 +5,9 @@
(:recycle :asdf/utility :asdf) (:recycle :asdf/utility :asdf)
(:use :asdf/common-lisp :asdf/package) (:use :asdf/common-lisp :asdf/package)
;; import and reexport a few things defined in :asdf/common-lisp ;; import and reexport a few things defined in :asdf/common-lisp
(:import-from :asdf/common-lisp #:compatfmt #:loop* #:remove-substrings (:import-from :asdf/common-lisp #:compatfmt #:loop* #:frob-substrings
#+ecl #:use-ecl-byte-compiler-p #+mcl #:probe-posix) #+ecl #:use-ecl-byte-compiler-p #+mcl #:probe-posix)
(:export #:compatfmt #:loop* #:remove-substrings #:compatfmt (:export #:compatfmt #:loop* #:frob-substrings #:compatfmt
#+ecl #:use-ecl-byte-compiler-p #+mcl #:probe-posix) #+ecl #:use-ecl-byte-compiler-p #+mcl #:probe-posix)
(:export (:export
;; magic helper to define debugging functions: ;; magic helper to define debugging functions:
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment