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

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

Quash some BAD-SYSTEM-NAME warnings.

See merge request !116
parents 903419f4 c70dec3f
......@@ -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.
......
(defsystem "cl-ppcre"
:description "Test special handling of CL-PPCRE")
(defsystem "cl-ppcre-test"
:depends-on ("cl-ppcre"))
;;; -*- 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"))))
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