Commit cc32dbf7 authored by Robert Goldman's avatar Robert Goldman

Merge branch 'bad-system-name' into 'master'

Bad system name

Signal a WARNING when a system is defined with a bad name that will make asdf fail to find it, e.g. foo-test in foo.asd instead of e.g. foo/test.

See merge request !51
parents ec88be65 05a0280f
......@@ -124,7 +124,7 @@
#:missing-dependency
#:missing-dependency-of-version
#:circular-dependency ; errors
#:duplicate-names #:non-toplevel-system #:non-system-system
#:duplicate-names #:non-toplevel-system #:non-system-system #:bad-system-name
#:package-inferred-system-missing-package-error
#:operation-definition-warning #:operation-definition-error
......
......@@ -12,7 +12,7 @@
#:defsystem #:register-system-definition
#:class-for-type #:*default-component-class*
#:determine-system-directory #:parse-component-form
#:non-toplevel-system #:non-system-system
#:non-toplevel-system #:non-system-system #:bad-system-name
#:sysdef-error-component #:check-component-input))
(in-package :asdf/parse-defsystem)
......@@ -73,6 +73,17 @@
(format s (compatfmt "~@<Error while defining system: component ~S claims to have a system ~S as a child~@:>")
(non-toplevel-system-parent c) (non-toplevel-system-name c)))))
(define-condition bad-system-name (warning)
((name :initarg :name :reader component-name)
(source-file :initarg :source-file :reader system-source-file))
(:report (lambda (c s)
(let* ((file (system-source-file c))
(name (component-name c))
(asd (pathname-name file)))
(format s (compatfmt "~@<System definition file ~S contains definition for system ~S. ~
Please only define ~S and secondary systems with a name starting with ~S (e.g. ~S) in that file.~@:>")
file name asd (strcat asd "/") (strcat asd "/test"))))))
(defun sysdef-error-component (msg type name value)
(sysdef-error (strcat msg (compatfmt "~&~@<The value specified for ~(~A~) ~A is ~S~@:>"))
type name value))
......@@ -276,45 +287,49 @@ system names contained using COERCE-NAME. Return the result."
;; To avoid infinite recursion in cases where you defsystem a system
;; that is registered to a different location to find-system,
;; we also need to remember it in the asdf-cache.
(with-asdf-cache ()
(let* ((name (coerce-name name))
(source-file (if sfp source-file (resolve-symlinks* (load-pathname))))
;; NB: handle defsystem-depends-on BEFORE to create the system object,
;; so that in case it fails, there is no incomplete object polluting the build.
(checked-defsystem-depends-on
(let* ((dep-forms (parse-dependency-defs defsystem-depends-on))
(deps (loop :for spec :in dep-forms
:when (resolve-dependency-spec nil spec)
:collect :it)))
(load-systems* deps)
dep-forms))
(registered (system-registered-p name))
(registered! (if registered
(rplaca registered (get-file-stamp source-file))
(register-system
(make-instance 'system :name name :source-file source-file))))
(system (reset-system (cdr registered!)
:name name :source-file source-file))
(component-options
(append
(remove-plist-keys '(:defsystem-depends-on :class) options)
;; cache defsystem-depends-on in canonical form
(when checked-defsystem-depends-on
`(:defsystem-depends-on ,checked-defsystem-depends-on)))))
;; This works hand in hand with asdf/find-system:find-system-if-being-defined:
(set-asdf-cache-entry `(find-system ,name) (list system))
;; We change-class AFTER we loaded the defsystem-depends-on
;; since the class might be defined as part of those.
(let ((class (class-for-type nil class)))
(unless (subtypep class 'system)
(error 'non-system-system :name name :class-name (class-name class)))
(unless (eq (type-of system) class)
(change-class system class)))
(parse-component-form
nil (list*
:module name
:pathname (determine-system-directory pathname)
component-options)))))
(nest
(with-asdf-cache ())
(let* ((name (coerce-name name))
(source-file (if sfp source-file (resolve-symlinks* (load-pathname))))
(asd-name (and source-file
(equalp "asd" (pathname-type source-file))
(pathname-name source-file)))
(primary-name (primary-system-name name)))
(when (and asd-name (not (equal asd-name primary-name)))
(warn (make-condition 'bad-system-name :source-file source-file :name name))))
(let* (;; NB: handle defsystem-depends-on BEFORE to create the system object,
;; so that in case it fails, there is no incomplete object polluting the build.
(checked-defsystem-depends-on
(let* ((dep-forms (parse-dependency-defs defsystem-depends-on))
(deps (loop :for spec :in dep-forms
:when (resolve-dependency-spec nil spec)
:collect :it)))
(load-systems* deps)
dep-forms))
(registered (system-registered-p name))
(registered! (if registered
(rplaca registered (get-file-stamp source-file))
(register-system
(make-instance 'system :name name :source-file source-file))))
(system (reset-system (cdr registered!)
:name name :source-file source-file))
(component-options
(append
(remove-plist-keys '(:defsystem-depends-on :class) options)
;; cache defsystem-depends-on in canonical form
(when checked-defsystem-depends-on
`(:defsystem-depends-on ,checked-defsystem-depends-on))))
(directory (determine-system-directory pathname)))
;; This works hand in hand with asdf/find-system:find-system-if-being-defined:
(set-asdf-cache-entry `(find-system ,name) (list system)))
;; We change-class AFTER we loaded the defsystem-depends-on
;; since the class might be defined as part of those.
(let ((class (class-for-type nil class)))
(unless (subtypep class 'system)
(error 'non-system-system :name name :class-name (class-name class)))
(unless (eq (type-of system) class)
(change-class system class)))
(parse-component-form nil (list* :module name :pathname directory component-options))))
(defmacro defsystem (name &body options)
`(apply 'register-system-definition ',name ',options)))
;;-*- Lisp -*-
(load-system 'test-mutual-redefinition-1)
(defun current-system-source-file (x)
(system-source-file (asdf::registered-system x)))
(with-asdf-cache ()
(DBG "loading test-mutual-redefinition-1")
(let ((warned-p nil))
(handler-bind ((bad-system-name (lambda (c)
(assert-equal (component-name c) "test-mutual-redefinition-2")
(assert-equal (pathname-name (system-source-file c)) "test-mutual-redefinition-1")
(setf warned-p t))))
(load-system 'test-mutual-redefinition-1))
(assert warned-p))
(assert-pathname-equal
(test-source "test-mutual-redefinition-1.asd")
(current-system-source-file "test-mutual-redefinition-1"))
......
......@@ -30,7 +30,7 @@
(sleep 1)
(clear-system :test1)
(touch-file test1.asd)
(touch-file test1.asd :offset 600)
(find-system :test1)
(defparameter date6 (system-registered-time :test1))
(assert-compare (> date6 date4))
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