From f3af2006d5ae84f6a016c7b2d3ef3aba73f948bb Mon Sep 17 00:00:00 2001 From: "Robert P. Goldman" Date: Fri, 14 Dec 2018 10:30:29 -1000 Subject: [PATCH 1/2] Quash some BAD-SYSTEM-NAME warnings. I'm sick of Stas's social engineering attempt to stoke anger about this warning, so I'm specifically quashing warnings from "cl-ppcre." --- parse-defsystem.lisp | 16 ++++++++++++++-- 1 file changed, 14 insertions(+), 2 deletions(-) diff --git a/parse-defsystem.lisp b/parse-defsystem.lisp index d4d10a0f..51d2bb0d 100644 --- a/parse-defsystem.lisp +++ b/parse-defsystem.lisp @@ -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. -- GitLab From c70dec3ff443c47ce5c29ee177c298e87f077c9a Mon Sep 17 00:00:00 2001 From: "Robert P. Goldman" Date: Fri, 14 Dec 2018 13:39:29 -1000 Subject: [PATCH 2/2] Test for quashing BAD-NAME-WARN. --- test/cl-ppcre.asd | 4 ++++ test/test-defsystem-errors.script | 10 ++++++++++ 2 files changed, 14 insertions(+) create mode 100644 test/cl-ppcre.asd diff --git a/test/cl-ppcre.asd b/test/cl-ppcre.asd new file mode 100644 index 00000000..fc730d80 --- /dev/null +++ b/test/cl-ppcre.asd @@ -0,0 +1,4 @@ +(defsystem "cl-ppcre" + :description "Test special handling of CL-PPCRE") +(defsystem "cl-ppcre-test" + :depends-on ("cl-ppcre")) diff --git a/test/test-defsystem-errors.script b/test/test-defsystem-errors.script index dd3ed36e..a2ee7114 100644 --- a/test/test-defsystem-errors.script +++ b/test/test-defsystem-errors.script @@ -1,6 +1,7 @@ ;;; -*- 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")))) -- GitLab