Skip to content
GitLab
Menu
Projects
Groups
Snippets
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Menu
Open sidebar
Didier Verna
asdf
Commits
ab797258
Commit
ab797258
authored
Jan 28, 2013
by
Francois-Rene Rideau
Browse files
2.26.162: improve the upgrade cleanup mechanism
Make it run even if ASDF wasn't upgraded via upgrade-asdf.
parent
64b4399e
Changes
13
Hide whitespace changes
Inline
Side-by-side
asdf.asd
View file @
ab797258
...
...
@@ -62,7 +62,7 @@
:licence
"MIT"
:description
"Another System Definition Facility"
:long-description
"ASDF builds Common Lisp software organized into defined systems."
:version
"2.26.16
1
"
;; to be automatically updated by make bump-version
:version
"2.26.16
2
"
;; to be automatically updated by make bump-version
:depends-on
()
#+
asdf3
:encoding
#+
asdf3
:utf-8
;; For most purposes, asdf itself specially counts as a builtin system.
...
...
backward-internals.lisp
View file @
ab797258
...
...
@@ -69,7 +69,7 @@
:when
(
eq
feature?
'feature
)
:do
(
setf
(
component-if-feature
c
)
feature
)))))
(
when-upgrad
e
(
:when
(
fboundp
'make-sub-operation
))
(
when-upgrad
ing
(
:when
(
fboundp
'make-sub-operation
))
(
defun*
make-sub-operation
(
c
o
dep-c
dep-o
)
(
declare
(
ignore
c
o
dep-c
dep-o
))
(
asdf-upgrade-error
)))
...
...
component.lisp
View file @
ab797258
...
...
@@ -57,7 +57,7 @@ another pathname in a degenerate way."))
;;; TODO: find users, have them stop using that.
(
defgeneric*
(
source-file-type
)
(
component
system
))
(
when-upgrad
e
(
:when
(
find-class
'component
nil
))
(
when-upgrad
ing
(
:when
(
find-class
'component
nil
))
(
defmethod
reinitialize-instance
:after
((
c
component
)
&rest
initargs
&key
)
(
declare
(
ignorable
c
initargs
))
(
values
)))
...
...
@@ -168,7 +168,7 @@ another pathname in a degenerate way."))
(
setf
(
gethash
name
hash
)
c
))
hash
))))
(
when-upgrad
e
(
:when
(
find-class
'module
nil
))
(
when-upgrad
ing
(
:when
(
find-class
'module
nil
))
(
defmethod
reinitialize-instance
:after
((
m
module
)
&rest
initargs
&key
)
(
declare
(
ignorable
m
initargs
))
(
values
))
(
defmethod
update-instance-for-redefined-class
:after
...
...
configuration.lisp
View file @
ab797258
...
...
@@ -15,7 +15,7 @@
#:report-invalid-form
#:invalid-configuration
#:*ignored-configuration-form*
#:*clear-configuration-hook*
#:clear-configuration
#:register-clear-configuration-hook
#:resolve-location
#:location-designator-p
#:location-function-p
#:*here-directory*
#:resolve-relative-location
#:resolve-absolute-location
))
#:resolve-relative-location
#:resolve-absolute-location
#:upgrade-configuration
))
(
in-package
:asdf/configuration
)
(
define-condition
invalid-configuration
()
...
...
@@ -286,3 +286,11 @@ directive.")
(
call-functions
*clear-configuration-hook*
))
(
register-image-dump-hook
'clear-configuration
)
;; If a previous version of ASDF failed to read some configuration, try again.
(
defun*
upgrade-configuration
()
(
when
*ignored-configuration-form*
(
clear-configuration
)
(
setf
*ignored-configuration-form*
nil
)))
find-system.lisp
View file @
ab797258
...
...
@@ -56,16 +56,18 @@
(
error
'formatted-system-definition-error
:format-control
format
:format-arguments
arguments
))
(
defun*
make-defined-systems-table
()
(
make-hash-table
:test
'equal
))
(
defvar
*defined-systems*
(
make-defined-systems-table
)
(
defvar
*defined-systems*
(
make-hash-table
:test
'equal
)
"This is a hash table whose keys are strings, being the
names of the systems, and whose values are pairs, the first
element of which is a universal-time indicating when the
system definition was last updated, and the second element
of which is a system object."
)
(
defun*
clear-defined-systems
()
(
setf
*defined-systems*
(
make-hash-table
:test
'equal
)))
(
register-hook-function
'*post-upgrade-cleanup-hook*
'clear-defined-systems
nil
)
(
defun*
coerce-name
(
name
)
(
typecase
name
(
component
(
component-name
name
))
...
...
footer.lisp
View file @
ab797258
...
...
@@ -40,15 +40,6 @@
(
values-list
l
))))))
;;;; Cleanups after hot-upgrade.
;; Things to do in case we're upgrading from a previous version of ASDF.
;; See https://bugs.launchpad.net/asdf/+bug/485687
;;
;; If a previous version of ASDF failed to read some configuration, try again.
(
when
*ignored-configuration-form*
(
clear-configuration
)
(
setf
*ignored-configuration-form*
nil
))
;;;; Done!
#+
allegro
...
...
@@ -60,6 +51,9 @@
(
provide
:asdf
)
;;;; Cleanups after hot-upgrade.
(
cleanup-upgraded-asdf
)
(
when
*load-verbose*
(
asdf-message
";; ASDF, version ~a~%"
(
asdf-version
)))
...
...
header.lisp
View file @
ab797258
;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
;;; This is ASDF 2.26.16
1
: Another System Definition Facility.
;;; This is ASDF 2.26.16
2
: Another System Definition Facility.
;;;
;;; Feedback, bug reports, and patches are all welcome:
;;; please mail to <asdf-devel@common-lisp.net>.
...
...
operate.lisp
View file @
ab797258
...
...
@@ -157,14 +157,6 @@ for how to load or compile stuff")
;;;; Some upgrade magic
(
defun*
reset-asdf-systems
()
(
let
((
asdf
(
find-system
:asdf
)))
(
setf
(
component-version
asdf
)
(
asdf-version
))
;; Invalidate all systems but ASDF itself.
(
setf
*defined-systems*
(
make-defined-systems-table
))
(
register-system
asdf
)
(
load-system
asdf
)))
;; re-load ourselves the right way
(
defun*
restart-upgraded-asdf
()
;; If we're in the middle of something, restart it.
(
when
*systems-being-defined*
...
...
@@ -172,5 +164,4 @@ for how to load or compile stuff")
(
clrhash
*systems-being-defined*
)
(
dolist
(
s
l
)
(
find-system
s
nil
)))))
(
pushnew
'reset-asdf-systems
*post-upgrade-cleanup-hook*
)
(
pushnew
'restart-upgraded-asdf
*post-upgrade-restart-hook*
)
operation.lisp
View file @
ab797258
...
...
@@ -15,7 +15,7 @@
;;; Operation Classes
(
when-upgrad
e
(
:when
(
find-class
'operation
nil
))
(
when-upgrad
ing
(
:when
(
find-class
'operation
nil
))
(
defmethod
shared-initialize
:after
((
o
operation
)
slot-names
&rest
initargs
&key
)
(
declare
(
ignorable
o
slot-names
initargs
))
(
values
)))
...
...
output-translations.lisp
View file @
ab797258
...
...
@@ -22,7 +22,7 @@
))
(
in-package
:asdf/output-translations
)
(
when-upgrad
e
()
(
undefine-function
'
(
setf
output-translations
)))
(
when-upgrad
ing
()
(
undefine-function
'
(
setf
output-translations
)))
(
define-condition
invalid-output-translation
(
invalid-configuration
warning
)
((
format
:initform
(
compatfmt
"~@<Invalid asdf output-translation ~S~@[ in ~S~]~@{ ~@?~}~@:>"
))))
...
...
upgrade.lisp
View file @
ab797258
...
...
@@ -4,13 +4,12 @@
(
asdf/package:define-package
:asdf/upgrade
(
:recycle
:asdf/upgrade
:asdf
)
(
:use
:asdf/common-lisp
:asdf/
package
:asdf/utility
)
(
:use
:asdf/common-lisp
:asdf/
driver
)
(
:export
#:upgrade-asdf
#:asdf-upgrade-error
#:when-upgrade
#:*asdf-upgrade-already-attempted*
#:*post-upgrade-cleanup-hook*
#:*post-upgrade-restart-hook*
#:cleanup-upgraded-asdf
#:asdf-version
#:*upgraded-p*
#:*asdf-version*
#:asdf-version
#:*previous-asdf-versions*
#:*asdf-version*
#:asdf-message
#:*asdf-verbose*
#:*verbose-out*
#:upgrading-p
#:when-upgrading
#:upgrade-asdf
#:asdf-upgrade-error
#:*post-upgrade-cleanup-hook*
#:*post-upgrade-restart-hook*
#:cleanup-upgraded-asdf
;; There will be no symbol left behind!
#:intern*
)
(
:import-from
:asdf/package
#:intern*
#:find-symbol*
))
...
...
@@ -19,30 +18,57 @@
;;; Special magic to detect if this is an upgrade
(
eval-when
(
:load-toplevel
:compile-toplevel
:execute
)
(
defun
asdf-version
()
"Exported interface to the version of ASDF currently installed. A string.
You can compare this string with e.g.: (ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSION) \"3.4.5.67\")."
(
when
(
find-package
:asdf
)
(
or
(
symbol-value
(
find-symbol
(
string
:*asdf-version*
)
:asdf
))
(
let
((
ver
(
symbol-value
(
find-symbol
(
string
:*asdf-revision*
)
:asdf
))))
(
etypecase
ver
(
string
ver
)
(
cons
(
format
nil
"~{~D~^.~}"
ver
))
(
null
"1.0"
))))))
(
defvar
*asdf-version*
nil
)
(
defvar
*
upgraded-p
*
nil
)
(
defvar
*
previous-asdf-versions
*
nil
)
(
defvar
*asdf-verbose*
nil
)
; was t from 2.000 to 2.014.12.
(
defvar
*verbose-out*
nil
)
(
defun*
asdf-message
(
format-string
&rest
format-args
)
(
apply
'format
*verbose-out*
format-string
format-args
)))
(
apply
'format
*verbose-out*
format-string
format-args
))
(
defvar
*post-upgrade-cleanup-hook*
())
(
defvar
*post-upgrade-restart-hook*
())
(
defun*
upgrading-p
()
(
and
*previous-asdf-versions*
(
not
(
equal
*asdf-version*
(
first
*previous-asdf-versions*
)))))
(
defmacro
when-upgrading
((
&key
(
upgrading-p
'
(
upgrading-p
))
when
)
&body
body
)
`
(
eval-when
(
:compile-toplevel
:load-toplevel
:execute
)
(
when
(
and
,
upgrading-p
,@
(
when
when
`
(
,
when
)))
(
handler-bind
((
style-warning
#'
muffle-warning
))
(
eval
'
(
progn
,@
body
)))))))
(
eval-when
(
:load-toplevel
:compile-toplevel
:execute
)
(
let*
(
;; For bug reporting sanity, please always bump this version when you modify this file.
;; Please also modify asdf.asd to reflect this change. make bump-version
;; Please also modify asdf.asd to reflect this change. make bump-version
v=3.4.5.67.8
;; can help you do these changes in synch (look at the source for documentation).
;; Relying on its automation, the version is now redundantly present on top of this file.
;; "2.345" would be an official release
;; "2.345.6" would be a development version in the official upstream
;; "2.345.0.7" would be your seventh local modification of official release 2.345
;; "2.345.6.7" would be your seventh local modification of development version 2.345.6
(
asdf-version
"2.26.161"
)
(
existing-asdf
(
find-class
(
find-symbol*
:component
:asdf
nil
)
nil
))
(
existing-version
*asdf-version*
)
(
already-there
(
equal
asdf-version
existing-version
))
(
redefined-functions
;; gf signature and/or semantics changed incompatibly. Oops.
'
(
#:component-relative-pathname
#:component-parent-pathname
;; component
#:source-file-type
#:find-system
#:system-source-file
#:system-relative-pathname
;; system
;; "3.4" would be the general branch for major version 3, minor version 4.
;; "3.4.5" would be an official release in the 3.4 branch.
;; "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.67.8" would be your eighth local modification of development version 3.4.5.67
(
asdf-version
"2.26.162"
)
(
existing-version
(
asdf-version
)))
(
when
(
and
existing-version
(
not
(
equal
asdf-version
existing-version
)))
(
push
existing-version
*previous-asdf-versions*
)
(
when
*asdf-verbose*
(
format
*trace-output*
(
compatfmt
"~&~@<; ~@;Upgrading ASDF ~@[from version ~A ~]to version ~A~@:>~%"
)
existing-version
asdf-version
)))
(
setf
*asdf-version*
asdf-version
)))
(
when-upgrading
()
(
let
((
redefined-functions
;; gf signature and/or semantics changed incompatibly. Oops.
'
(
#:component-relative-pathname
#:component-parent-pathname
;; component
#:source-file-type
#:find-system
#:system-source-file
#:system-relative-pathname
;; system
#:find-component
;; find-component
#:explain
#:perform
#:perform-with-restarts
#:input-files
#:output-files
;; action
#:component-depends-on
#:component-self-dependencies
#:operation-done-p
...
...
@@ -51,7 +77,7 @@
#:apply-output-translations
;; output-translations
#:process-output-translations-directive
#:inherit-source-registry
#:process-source-registry
;; source-registry
#:process-source-registry-directive
#:process-source-registry-directive
#:trivial-system-p
;; bundle
;; NB: it's too late to do anything about asdf-driver functions!
))
...
...
@@ -61,93 +87,57 @@
#:resolve-relative-location-component
#:resolve-absolute-location-component
#:output-files-for-system-and-operation
)))
; obsolete ASDF-BINARY-LOCATION function
(
declare
(
ignorable
redefined-functions
uninterned-symbols
))
(
setf
*asdf-version*
asdf-version
)
(
when
(
and
existing-asdf
(
not
already-there
))
(
push
existing-version
*upgraded-p*
)
(
when
*asdf-verbose*
(
format
*trace-output*
(
compatfmt
"~&~@<; ~@;Upgrading ASDF ~@[from version ~A ~]to version ~A~@:>~%"
)
existing-version
asdf-version
))
(
loop
:for
name
:in
(
append
#-
(
or
clisp
ecl
)
redefined-functions
)
:for
sym
=
(
find-symbol*
name
:asdf
nil
)
:do
(
when
sym
;;(format t "Undefining ~S~%" sym);XXX
(
fmakunbound
sym
)))
(
loop
:with
asdf
=
(
find-package
:asdf
)
:for
name
:in
(
append
#+
(
or
clisp
ecl
)
redefined-functions
uninterned-symbols
)
;XXX
:for
sym
=
(
find-symbol*
name
:asdf
nil
)
:for
base-pkg
=
(
and
sym
(
symbol-package
sym
))
:do
(
when
sym
;;(format t "frobbing symbol ~S~%" sym);XXX
(
cond
((
or
(
eq
base-pkg
asdf
)
(
not
base-pkg
))
(
unintern*
sym
asdf
)
(
intern*
sym
asdf
))
(
t
(
unintern*
sym
base-pkg
)
(
let
((
new
(
intern*
sym
base-pkg
)))
(
shadowing-import
new
asdf
))))))
;; Note that this massive package destruction makes it impossible
;; to use asdf/driver on top of an old ASDF on these implementations
#+
(
or
xcl
)
(
let
((
p
(
find-package
:asdf
)))
(
when
p
(
do-symbols
(
s
p
)
(
when
(
home-package-p
s
p
)
(
nuke-symbol
s
)))
(
rename-package-away
p
:prefix
(
format
nil
"~A-~A"
:asdf
(
or
existing-version
:1.x
))
:index
0
:separator
"-"
))))))
(
loop
:for
name
:in
(
append
#-
(
or
clisp
ecl
)
redefined-functions
)
:for
sym
=
(
find-symbol*
name
:asdf
nil
)
:do
(
when
sym
(
fmakunbound
sym
)))
(
loop
:with
asdf
=
(
find-package
:asdf
)
:for
name
:in
(
append
#+
(
or
clisp
ecl
)
redefined-functions
uninterned-symbols
)
;XXX
:for
sym
=
(
find-symbol*
name
:asdf
nil
)
:for
base-pkg
=
(
and
sym
(
symbol-package
sym
))
:do
(
when
sym
(
cond
((
or
(
eq
base-pkg
asdf
)
(
not
base-pkg
))
(
unintern*
sym
asdf
)
(
intern*
sym
asdf
))
(
t
(
unintern*
sym
base-pkg
)
(
let
((
new
(
intern*
sym
base-pkg
)))
(
shadowing-import
new
asdf
))))))))
;;;
U
pgrade
interface
;;;
Self-u
pgrade
functions
(
defun*
asdf-upgrade-error
()
;; Important notice for whom it concerns. The crux of the matter is that
;; TRAVERSE can be completely refactored, and so after the find-system returns, it's too late.
(
error
"When a system transitively depends on ASDF, it must :defsystem-depends-on (:asdf)~%~
Otherwise, when you upgrade ASDF, you must do it before you operate on any system.~%"
))
(
defmacro
when-upgrade
((
&key
(
upgraded-p
'*upgraded-p*
)
when
)
&body
body
)
`
(
eval-when
(
:compile-toplevel
:load-toplevel
:execute
)
(
when
(
and
,
upgraded-p
,@
(
when
when
`
(
,
when
)))
(
handler-bind
((
style-warning
#'
muffle-warning
))
(
eval
'
(
progn
,@
body
))))))
(
defun*
asdf-version
()
"Exported interface to the version of ASDF currently installed. A string.
You can compare this string with e.g.:
(ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSION) \"2.345.67\")."
*asdf-version*
)
Otherwise, when you upgrade from ASDF 2, you must do it before you operate on any system.~%"
))
;;; Self-upgrade functions
(
defvar
*post-upgrade-cleanup-hook*
())
(
defvar
*post-upgrade-restart-hook*
())
(
defun*
cleanup-upgraded-asdf
(
old-version
)
(
defun*
cleanup-upgraded-asdf
(
&optional
(
old-version
(
first
*previous-asdf-versions*
)))
(
let
((
new-version
(
asdf-version
)))
(
unless
(
equal
old-version
new-version
)
(
cond
((
version-compatible-p
new-version
old-version
)
(
asdf-message
(
compatfmt
"~&~@<; ~@;Upgraded ASDF from version ~A to version ~A~@:>~%"
)
old-version
new-version
))
((
version-compatible-p
old-version
new-version
)
(
warn
(
compatfmt
"~&~@<; ~@;Downgraded ASDF from version ~A to version ~A~@:>~%"
)
old-version
new-version
))
(
t
(
asdf-message
(
compatfmt
"~&~@<; ~@;Changed ASDF from version ~A to incompatible version ~A~@:>~%"
)
old-version
new-version
)))
(
dolist
(
h
(
reverse
*post-upgrade-cleanup-hook*
))
(
funcall
(
ensure-function
h
)))
(
dolist
(
h
*post-upgrade-restart-hook*
)
(
funcall
(
ensure-function
h
)))
t
)))
(
push
new-version
*previous-asdf-versions*
)
(
when
old-version
(
cond
((
version-compatible-p
new-version
old-version
)
(
asdf-message
(
compatfmt
"~&~@<; ~@;Upgraded ASDF from version ~A to version ~A~@:>~%"
)
old-version
new-version
))
((
version-compatible-p
old-version
new-version
)
(
warn
(
compatfmt
"~&~@<; ~@;Downgraded ASDF from version ~A to version ~A~@:>~%"
)
old-version
new-version
))
(
t
(
asdf-message
(
compatfmt
"~&~@<; ~@;Changed ASDF from version ~A to incompatible version ~A~@:>~%"
)
old-version
new-version
)))
(
call-functions
(
reverse
*post-upgrade-cleanup-hook*
))
t
))))
(
defun*
upgrade-asdf
()
"Try to upgrade of ASDF. If a different version was used, return T.
We need do that before we operate on anything that may possibly depend on ASDF."
(
let
((
version
(
asdf-version
))
(
*load-print*
nil
)
(
let
((
*load-print*
nil
)
(
*compile-print*
nil
))
(
handler-bind
(((
or
style-warning
warning
)
#'
muffle-warning
))
(
symbol-call
:asdf
:load-system
:asdf
:verbose
nil
))
(
cleanup-upgraded-asdf
version
)))
(
symbol-call
:asdf
:load-system
:asdf
:verbose
nil
))))
(
register-hook-function
'*post-upgrade-cleanup-hook*
'upgrade-configuration
)
utility.lisp
View file @
ab797258
...
...
@@ -308,7 +308,7 @@ instead of a list."
(
defun*
call-functions
(
function-specs
)
(
map
()
'call-function
function-specs
))
(
defun*
register-hook-function
(
variable
hook
&optional
(
call-now-p
t
)
)
(
defun*
register-hook-function
(
variable
hook
&optional
call-now-p
)
(
pushnew
hook
(
symbol-value
variable
))
(
when
call-now-p
(
call-function
hook
)))
...
...
@@ -372,8 +372,8 @@ with later being determined by a lexicographical comparison of minor numbers."
#+
allegro
'excl::format-control
#+
clisp
'system::$format-control
#+
clozure
'ccl::format-control
#+
ecl
'si::format-control
#+
(
or
cmu
scl
)
'conditions::format-control
#+
ecl
'si::format-control
#+
(
or
gcl
lispworks
)
'conditions::format-string
#+
sbcl
'sb-kernel:format-control
#-
(
or
abcl
allegro
clisp
clozure
cmu
ecl
gcl
lispworks
sbcl
scl
)
nil
...
...
version.lisp-expr
View file @
ab797258
"2.26.16
1
"
"2.26.16
2
"
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment