Commit cc32dbf7 authored by Robert Goldman's avatar Robert Goldman
Browse files

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
Loading
Loading
Loading
Loading
+1 −1
Original line number Original line Diff line number Diff line
@@ -124,7 +124,7 @@
   #:missing-dependency
   #:missing-dependency
   #:missing-dependency-of-version
   #:missing-dependency-of-version
   #:circular-dependency        ; errors
   #: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
   #:package-inferred-system-missing-package-error
   #:operation-definition-warning #:operation-definition-error
   #:operation-definition-warning #:operation-definition-error


+55 −40
Original line number Original line Diff line number Diff line
@@ -12,7 +12,7 @@
   #:defsystem #:register-system-definition
   #:defsystem #:register-system-definition
   #:class-for-type #:*default-component-class*
   #:class-for-type #:*default-component-class*
   #:determine-system-directory #:parse-component-form
   #: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))
   #:sysdef-error-component #:check-component-input))
(in-package :asdf/parse-defsystem)
(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~@:>")
               (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)))))
                       (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)
  (defun sysdef-error-component (msg type name value)
    (sysdef-error (strcat msg (compatfmt "~&~@<The value specified for ~(~A~) ~A is ~S~@:>"))
    (sysdef-error (strcat msg (compatfmt "~&~@<The value specified for ~(~A~) ~A is ~S~@:>"))
                  type name value))
                  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
    ;; To avoid infinite recursion in cases where you defsystem a system
    ;; that is registered to a different location to find-system,
    ;; that is registered to a different location to find-system,
    ;; we also need to remember it in the asdf-cache.
    ;; we also need to remember it in the asdf-cache.
    (with-asdf-cache ()
    (nest
      (let* ((name (coerce-name name))
     (with-asdf-cache ())
             (source-file (if sfp source-file (resolve-symlinks* (load-pathname))))
     (let* ((name (coerce-name name))
             ;; NB: handle defsystem-depends-on BEFORE to create the system object,
            (source-file (if sfp source-file (resolve-symlinks* (load-pathname))))
             ;; so that in case it fails, there is no incomplete object polluting the build.
            (asd-name (and source-file
             (checked-defsystem-depends-on
                           (equalp "asd" (pathname-type source-file))
               (let* ((dep-forms (parse-dependency-defs defsystem-depends-on))
                           (pathname-name source-file)))
                      (deps (loop :for spec :in dep-forms
            (primary-name (primary-system-name name)))
                                  :when (resolve-dependency-spec nil spec)
       (when (and asd-name (not (equal asd-name primary-name)))
                                    :collect :it)))
         (warn (make-condition 'bad-system-name :source-file source-file :name name))))
                 (load-systems* deps)
     (let* (;; NB: handle defsystem-depends-on BEFORE to create the system object,
                 dep-forms))
            ;; so that in case it fails, there is no incomplete object polluting the build.
             (registered (system-registered-p name))
            (checked-defsystem-depends-on
             (registered! (if registered
             (let* ((dep-forms (parse-dependency-defs defsystem-depends-on))
                              (rplaca registered (get-file-stamp source-file))
                    (deps (loop :for spec :in dep-forms
                              (register-system
                            :when (resolve-dependency-spec nil spec)
                               (make-instance 'system :name name :source-file source-file))))
                            :collect :it)))
             (system (reset-system (cdr registered!)
               (load-systems* deps)
                                   :name name :source-file source-file))
               dep-forms))
             (component-options
            (registered (system-registered-p name))
              (append
            (registered! (if registered
               (remove-plist-keys '(:defsystem-depends-on :class) options)
                             (rplaca registered (get-file-stamp source-file))
               ;; cache defsystem-depends-on in canonical form
                             (register-system
               (when checked-defsystem-depends-on
                              (make-instance 'system :name name :source-file source-file))))
                 `(:defsystem-depends-on ,checked-defsystem-depends-on)))))
            (system (reset-system (cdr registered!)
        ;; This works hand in hand with asdf/find-system:find-system-if-being-defined:
                                  :name name :source-file source-file))
        (set-asdf-cache-entry `(find-system ,name) (list system))
            (component-options
        ;; We change-class AFTER we loaded the defsystem-depends-on
             (append
        ;; since the class might be defined as part of those.
              (remove-plist-keys '(:defsystem-depends-on :class) options)
        (let ((class (class-for-type nil class)))
              ;; cache defsystem-depends-on in canonical form
          (unless (subtypep class 'system)
              (when checked-defsystem-depends-on
            (error 'non-system-system :name name :class-name (class-name class)))
                `(:defsystem-depends-on ,checked-defsystem-depends-on))))
          (unless (eq (type-of system) class)
            (directory (determine-system-directory pathname)))
            (change-class system class)))
       ;; This works hand in hand with asdf/find-system:find-system-if-being-defined:
        (parse-component-form
       (set-asdf-cache-entry `(find-system ,name) (list system)))
         nil (list*
     ;; We change-class AFTER we loaded the defsystem-depends-on
              :module name
     ;; since the class might be defined as part of those.
              :pathname (determine-system-directory pathname)
     (let ((class (class-for-type nil class)))
              component-options)))))
       (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)
  (defmacro defsystem (name &body options)
    `(apply 'register-system-definition ',name ',options)))
    `(apply 'register-system-definition ',name ',options)))
+7 −1
Original line number Original line Diff line number Diff line
;;-*- Lisp -*-
;;-*- Lisp -*-


(load-system 'test-mutual-redefinition-1)
(defun current-system-source-file (x)
(defun current-system-source-file (x)
  (system-source-file (asdf::registered-system x)))
  (system-source-file (asdf::registered-system x)))


(with-asdf-cache ()
(with-asdf-cache ()
  (DBG "loading test-mutual-redefinition-1")
  (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
  (assert-pathname-equal
   (test-source "test-mutual-redefinition-1.asd")
   (test-source "test-mutual-redefinition-1.asd")
   (current-system-source-file "test-mutual-redefinition-1"))
   (current-system-source-file "test-mutual-redefinition-1"))
+1 −1
Original line number Original line Diff line number Diff line
@@ -30,7 +30,7 @@
(sleep 1)
(sleep 1)


(clear-system :test1)
(clear-system :test1)
(touch-file test1.asd)
(touch-file test1.asd :offset 600)
(find-system :test1)
(find-system :test1)
(defparameter date6 (system-registered-time :test1))
(defparameter date6 (system-registered-time :test1))
(assert-compare (> date6 date4))
(assert-compare (> date6 date4))