;cperl-mode.el: Fix fontification edge cases

These were reported by happy-barney on GitHub
https://github.com/HaraldJoerg/cperl-mode/issues

* lisp/progmodes/cperl-mode.el (cperl-init-faces): Don't mistake
$method as a method declaration.
Move matcher for "use require" higher to prevent "require" being
fontified as keyword.

* test/lisp/progmodes/cperl-mode-resources/sub-names.pl: Add a
test case for $method

* test/lisp/progmodes/cperl-mode-tests.el
(cperl-test-fontify-declarations): Add a test case for a module
name looking like a keyword
(cperl-test-fontify-sub-names): Verify that $method does not
declare a method
This commit is contained in:
Harald Jörg 2026-05-25 11:23:34 +02:00
parent 6d15d68e1f
commit 217064e9dc
3 changed files with 45 additions and 24 deletions

View file

@ -6353,7 +6353,7 @@ functions (which they are not). Inherits from `default'.")
;; facespec is evaluated depending on whether the ;; facespec is evaluated depending on whether the
;; statement ends in a "{" (definition) or ";" ;; statement ends in a "{" (definition) or ";"
;; (declaration without body) ;; (declaration without body)
(list (concat "\\<" cperl-sub-regexp (list (concat "\\(?:\\`\\|[^$%@*&]\\)" cperl-sub-regexp
;; group 1: optional subroutine name ;; group 1: optional subroutine name
(rx (rx
(sequence (eval cperl--ws+-rx) (sequence (eval cperl--ws+-rx)
@ -6400,7 +6400,24 @@ functions (which they are not). Inherits from `default'.")
(error (match-end 2)))) (error (match-end 2))))
nil nil
(1 font-lock-variable-name-face))) (1 font-lock-variable-name-face)))
;; -------- flow control ;; -------- various stuff calling for a package name
;; (matcher (subexp facespec) (subexp facespec))
`(,(rx (sequence
(or (sequence (or line-start space "{" )
(group-n 1 (or "package" "require" "use"
"import" "no" "bootstrap" "class"))
(eval cperl--ws+-rx))
(sequence (group-n 2 (sequence ":"
(eval cperl--ws*-rx)
"isa"))
"("
(eval cperl--ws*-rx)))
(group-n 3 (eval cperl--normal-identifier-rx))
(any " \t\n;)"))) ; require A if B;
(1 font-lock-keyword-face t t)
(2 font-lock-constant-face t t)
(3 font-lock-function-name-face))
;; -------- flow control
;; (matcher . subexp) font-lock-keyword-face by default ;; (matcher . subexp) font-lock-keyword-face by default
;; This highlights declarations and definitions differently. ;; This highlights declarations and definitions differently.
;; We do not try to highlight in the case of attributes: ;; We do not try to highlight in the case of attributes:
@ -6507,22 +6524,6 @@ functions (which they are not). Inherits from `default'.")
;; (matcher subexp facespec) ;; (matcher subexp facespec)
'("-[rwxoRWXOezsfdlpSbctugkTBMAC]\\>\\([ \t]+_\\>\\)?" 0 '("-[rwxoRWXOezsfdlpSbctugkTBMAC]\\>\\([ \t]+_\\>\\)?" 0
font-lock-function-name-face keep) ; Not very good, triggers at "[a-z]" font-lock-function-name-face keep) ; Not very good, triggers at "[a-z]"
;; -------- various stuff calling for a package name
;; (matcher (subexp facespec) (subexp facespec))
`(,(rx (sequence
(or (sequence (or line-start space "{" )
(or "package" "require" "use" "import"
"no" "bootstrap" "class")
(eval cperl--ws+-rx))
(sequence (group-n 2 (sequence ":"
(eval cperl--ws*-rx)
"isa"))
"("
(eval cperl--ws*-rx)))
(group-n 1 (eval cperl--normal-identifier-rx))
(any " \t\n;)"))) ; require A if B;
(1 font-lock-function-name-face)
(2 font-lock-constant-face t t))
;; -------- formats ;; -------- formats
;; (matcher subexp facespec) ;; (matcher subexp facespec)
'("^[ \t]*format[ \t]+\\([a-zA-Z_][a-zA-Z_0-9:]*\\)[ \t]*=[ \t]*$" '("^[ \t]*format[ \t]+\\([a-zA-Z_][a-zA-Z_0-9:]*\\)[ \t]*=[ \t]*$"

View file

@ -17,6 +17,15 @@
# This comment has a method name in it, and we don't want "method" # This comment has a method name in it, and we don't want "method"
# to be fontified as a keyword, nor "name" fontified as a name. # to be fontified as a keyword, nor "name" fontified as a name.
# Next is a variable named "$method" followed by a keyword. This
# keyword is not a subroutine name and should not be fontified
# accordingly. Reported by Branislav Zahradnik,
# https://github.com/HaraldJoerg/cperl-mode/issues/24
push @abstract, $method
unless defined &$method
;
__END__ __END__
=head1 Test using the keywords POD =head1 Test using the keywords POD

View file

@ -143,7 +143,8 @@ point in the distant past, and is still broken in perl-mode. "
(with-temp-buffer (with-temp-buffer
(funcall cperl-test-mode) (funcall cperl-test-mode)
(insert "package Foo::Bar;\n") (insert "package Foo::Bar;\n")
(insert "use Fee::Fie::Foe::Foo\n;") (insert "use Fee::Fie::Foe::Foo\n;\n")
(insert "use require::relative;\n") ; module name has a keyword
(insert "my $xyzzy = 'PLUGH';\n") (insert "my $xyzzy = 'PLUGH';\n")
(goto-char (point-min)) (goto-char (point-min))
(font-lock-ensure) (font-lock-ensure)
@ -153,9 +154,15 @@ point in the distant past, and is still broken in perl-mode. "
(search-forward "use") ; This was buggy in perl-mode (search-forward "use") ; This was buggy in perl-mode
(should (equal (get-text-property (match-beginning 0) 'face) (should (equal (get-text-property (match-beginning 0) 'face)
'font-lock-keyword-face)) 'font-lock-keyword-face))
(search-forward "my") (re-search-forward (rx(sequence(group-n 1 "use")
(should (equal (get-text-property (match-beginning 0) 'face) (1+ blank)
'font-lock-keyword-face)))) (group-n 2 "require"))))
(should (equal (get-text-property (match-beginning 1) 'face)
'font-lock-keyword-face))
(should (equal (get-text-property (match-beginning 2) 'face)
(if (eq cperl-test-mode #'cperl-mode)
'font-lock-function-name-face
'font-lock-constant-face)))))
(ert-deftest cperl-test-fontify-attrs-and-signatures () (ert-deftest cperl-test-fontify-attrs-and-signatures ()
"Test fontification of the various combinations of subroutine "Test fontification of the various combinations of subroutine
@ -330,13 +337,17 @@ comments and POD they should be fontified as POD."
(should (equal (get-text-property (match-beginning 1) 'face) (should (equal (get-text-property (match-beginning 1) 'face)
(if (equal cperl-test-mode 'perl-mode) nil (if (equal cperl-test-mode 'perl-mode) nil
'cperl-method-call))) 'cperl-method-call)))
;; POD ;; comment
(search-forward-regexp "\\(method\\) \\(name\\)") (search-forward-regexp "\\(method\\) \\(name\\)")
(should (equal (get-text-property (match-beginning 1) 'face) (should (equal (get-text-property (match-beginning 1) 'face)
'font-lock-comment-face)) 'font-lock-comment-face))
(should (equal (get-text-property (match-beginning 2) 'face) (should (equal (get-text-property (match-beginning 2) 'face)
'font-lock-comment-face)) 'font-lock-comment-face))
;; comment ;; false positive: $method is not a method
(search-forward-regexp "\\($method\\)\\(?:\n\\|\\s-\\)+\\(unless\\)")
(should (equal (get-text-property (match-beginning 2) 'face)
'font-lock-keyword-face))
;; POD
(search-forward-regexp "\\(method\\) \\(name\\)") (search-forward-regexp "\\(method\\) \\(name\\)")
(should (equal (get-text-property (match-beginning 1) 'face) (should (equal (get-text-property (match-beginning 1) 'face)
'font-lock-comment-face)) 'font-lock-comment-face))