Commit 9826a251 authored by Robert Goldman's avatar Robert Goldman
Browse files

Merge branch 'cl-ppcre-passive-aggressive' into 'master' 

Quash some BAD-SYSTEM-NAME warnings.

See merge request asdf/asdf!116
parents 903419f4 c70dec3f

parse-defsystem.lisp

+14 −2
Changes for parse-defsystem.lisp: 14 added lines, 2 removed lines.
Original line number Diff line number Diff line
@@ -17,6 +17,7 @@ 
   #:class-for-type #:*default-component-class*

   #:determine-system-directory #:parse-component-form

   #:non-toplevel-system #:non-system-system #:bad-system-name

   #:*known-name-exception-systems*

   #:sysdef-error-component #:check-component-input

   #:explain))

(in-package :asdf/parse-defsystem)
@@ -344,6 +345,8 @@ system names contained using COERCE-NAME. Return the result." 
           (coerce-name (component-system component))))

        component)))



  (defparameter* *known-name-exception-systems* '("cl-ppcre"))



  (defun register-system-definition

      (name &rest options &key pathname (class 'system) (source-file () sfp)

                            defsystem-depends-on &allow-other-keys)
@@ -357,12 +360,21 @@ system names contained using COERCE-NAME. Return the result." 
     (with-asdf-session ())

     (let* ((name (coerce-name name))

            (source-file (if sfp source-file (resolve-symlinks* (load-pathname))))))

     (flet ((fix-case (x) (if (logical-pathname-p source-file) (string-downcase x) x))))

     (flet ((fix-case (x) (if (logical-pathname-p source-file) (string-downcase x) x))

            (known-exception (name)

              ;; is NAME a known exception that should be screened out

              ;; of checking for BAD-SYSTEM-NAME?

              (member-if #'(lambda (x) (uiop:string-prefix-p x name))

                                  *known-name-exception-systems*))))

     (let* ((asd-name (and source-file

                           (equal "asd" (fix-case (pathname-type source-file)))

                           (fix-case (pathname-name source-file))))

            ;; note that PRIMARY-NAME is a *syntactically* primary name --

            ;; so "cl-ppcre-test" (grrr.....) is a PRIMARY-NAME.

            (primary-name (primary-system-name name)))

       (when (and asd-name (not (equal asd-name primary-name)))

       (when (and asd-name

                  (not (equal asd-name primary-name))

                  (not (known-exception 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.

test/cl-ppcre.asd

0 → 100644
+4 −0
Changes for test/cl-ppcre.asd: 4 added lines, 0 removed lines.
Original line number Diff line number Diff line 
(defsystem "cl-ppcre"

    :description "Test special handling of CL-PPCRE")

(defsystem "cl-ppcre-test"

    :depends-on ("cl-ppcre"))

test/test-defsystem-errors.script

+10 −0
Changes for test/test-defsystem-errors.script: 10 added lines, 0 removed lines.
Original line number Diff line number Diff line 
;;; -*- Lisp -*-



(defun defsystem-error-handler (form &optional (error 'error))

  (declare (ignore error))

  (handler-case (eval form)

    (error () t)

    (:no-error (&rest values)
@@ -16,3 +17,12 @@ 
(defsystem-error (non-toplevel-system)

    :foo :components ((:system :bar)))



;;; test for my kluge for cl-ppcre

(assert

 (catch 'bad-name-warn

   (handler-bind

       ((bad-system-name #'(lambda (c)

                             (declare (ignorable c))

                             (format t "~&Catching bad name warning: ~A~%" c)

                             (throw 'bad-name-warn nil))))

     (find-system "cl-ppcre"))))