master 3c44d7a1b70: cperl-mode.el: Subroutine names are fontified correctly in all places

[Harald Jörg]

branch: master
commit 3c44d7a1b70a2f7c813c9034bb3e28932a1a66c9
Author: Harald Jörg <haj@posteo.de>
Commit: Harald Jörg <haj@posteo.de>

    cperl-mode.el: Subroutine names are fontified correctly in all places
    
    Subroutine names are fontified as subroutine names even if the name is also
    the name of a builtin (fixing an ancient unreported bug).  Subroutine name
    are just comments in comment and pod (fixing a bug introduced recently)
    
    * lisp/progmodes/cperl-mode.el (cperl-init-faces): Move
    fontification of sub declarations before that of builtins.  Don't
    override existing faces when fontifying subroutine declarations.
    Don't fontify method calls even if the sub names match those of
    builtins.
    
    * test/lisp/progmodes/cperl-mode-tests.el (cperl-test-fontify-sub-names):
    New tests with a subroutine name in several surroundings.
    
    * test/lisp/progmodes/cperl-mode-resources/sub-names.pl: New resource
    for the new test.
---
 lisp/progmodes/cperl-mode.el                       | 114 ++++++++++++---------
 .../progmodes/cperl-mode-resources/sub-names.pl    |  25 +++++
 test/lisp/progmodes/cperl-mode-tests.el            |  33 ++++++
 3 files changed, 121 insertions(+), 51 deletions(-)

diff --git a/lisp/progmodes/cperl-mode.el b/lisp/progmodes/cperl-mode.el
index 5dc49e4ebb4..51bed91c8c2 100644
--- a/lisp/progmodes/cperl-mode.el
+++ b/lisp/progmodes/cperl-mode.el
@@ -5875,6 +5875,13 @@ default function."
     cperl-here-face)
    (t (funcall (default-value 'font-lock-syntactic-face-function) state))))
 
+(defface cperl-method-call
+  '((t (:inherit 'default )))
+  "The face for method calls.  Usually, they are not fontified.
+We use this face to prevent calls to methods which look like
+builtin functions to be fontified like, well, builtin
+functions (which they are not).  Inherits from `default'.")
+
 (defun cperl-init-faces ()
   (condition-case errs
       (progn
@@ -5885,8 +5892,59 @@ default function."
             ;; -------- trailing spaces -> use invalid-face as a warning
             ;; (matcher subexp facespec)
            `("[ \t]+$" 0 ',cperl-invalid-face t)
+            ;; -------- function definition _and_ declaration
+            ;; (matcher (subexp facespec))
+            ;; facespec is evaluated depending on whether the
+            ;; statement ends in a "{" (definition) or ";"
+            ;; (declaration without body)
+           (list (concat "\\<" cperl-sub-regexp
+                          ;; group 1: optional subroutine name
+                          (rx
+                           (sequence (eval cperl--ws+-rx)
+                                     (group (optional
+                                             (eval 
cperl--normal-identifier-rx)))))
+                          ;; "fontified" elsewhere: Prototype
+                          (rx (optional
+                               (sequence (eval cperl--ws*-rx)
+                                         (eval cperl--prototype-rx))))
+                          ;; fontified elsewhere: Attributes
+                          (rx (optional (sequence (eval cperl--ws*-rx)
+                                                  (eval 
cperl--attribute-list-rx))))
+                          (rx (eval cperl--ws*-rx))
+                          ;; group 2: Identifies the start of the anchor
+                          (rx (group
+                               (or (group-n 3 ";") ; Either a declaration...
+                                   "{"             ; ... or a code block
+                                   ;; ... or a complete signature
+                                   (sequence (eval cperl--signature-rx)
+                                             (eval cperl--ws*-rx))
+                                   ;; ... or the start of a "sloppy" signature
+                                   (sequence (eval cperl--sloppy-signature-rx)
+                                             ;; arbtrarily continue "a few 
lines"
+                                             (repeat 0 200 (not (in "{"))))
+                                   ;; make sure we have a reasonably
+                                   ;; short match for an incomplete sub
+                                   (not (in ";{("))
+                                   buffer-end))))
+                 '(1 (if (match-beginning 3)
+                         'font-lock-variable-name-face
+                       'font-lock-function-name-face)
+                      nil ; override
+                      t)  ; laxmatch in case of anonymous subroutines
+                  ;; -------- anchored: Signature
+                  `(,(rx (sequence (in "(,")
+                                   (eval cperl--ws*-rx)
+                                   (group (eval cperl--basic-variable-rx))))
+                    (progn
+                      (goto-char (match-beginning 2)) ; pre-match: Back to sig
+                      (match-end 2))
+                    nil
+                    (1 font-lock-variable-name-face)))
             ;; -------- flow control
             ;; (matcher . subexp) font-lock-keyword-face by default
+           ;; This highlights declarations and definitions differently.
+           ;; We do not try to highlight in the case of attributes:
+           ;; it is already done by `cperl-find-pods-heres'
            (cons
             (concat
              "\\(^\\|[^$@%&\\]\\)\\<\\("
@@ -5910,6 +5968,11 @@ default function."
              "\\)\\>") 2)              ; was "\\)[ \n\t;():,|&]"
                                        ; In what follows we use `type' style
                                        ; for overwritable builtins
+            ;; -------- avoid method calls being fontified as keywords
+            ;; (matcher (subexp facespec))
+            (list
+             (rx "->" (* space) (group-n 1(eval cperl--basic-identifier-rx)))
+             1 ''cperl-method-call)
             ;; -------- builtin functions
             ;; (matcher subexp facespec)
            (list
@@ -5982,57 +6045,6 @@ default function."
             ;; (matcher subexp facespec)
            '("-[rwxoRWXOezsfdlpSbctugkTBMAC]\\>\\([ \t]+_\\>\\)?" 0
              font-lock-function-name-face keep) ; Not very good, triggers at 
"[a-z]"
-           ;; This highlights declarations and definitions differently.
-           ;; We do not try to highlight in the case of attributes:
-           ;; it is already done by `cperl-find-pods-heres'
-            ;; -------- function definition _and_ declaration
-            ;; (matcher (subexp facespec))
-            ;; facespec is evaluated depending on whether the
-            ;; statement ends in a "{" (definition) or ";"
-            ;; (declaration without body)
-           (list (concat "\\<" cperl-sub-regexp
-                          ;; group 1: optional subroutine name
-                          (rx
-                           (sequence (eval cperl--ws+-rx)
-                                     (group (optional
-                                             (eval 
cperl--normal-identifier-rx)))))
-                          ;; "fontified" elsewhere: Prototype
-                          (rx (optional
-                               (sequence (eval cperl--ws*-rx)
-                                         (eval cperl--prototype-rx))))
-                          ;; fontified elsewhere: Attributes
-                          (rx (optional (sequence (eval cperl--ws*-rx)
-                                                  (eval 
cperl--attribute-list-rx))))
-                          (rx (eval cperl--ws*-rx))
-                          ;; group 2: Identifies the start of the anchor
-                          (rx (group
-                               (or (group-n 3 ";") ; Either a declaration...
-                                   "{"             ; ... or a code block
-                                   ;; ... or a complete signature
-                                   (sequence (eval cperl--signature-rx)
-                                             (eval cperl--ws*-rx))
-                                   ;; ... or the start of a "sloppy" signature
-                                   (sequence (eval cperl--sloppy-signature-rx)
-                                             ;; arbtrarily continue "a few 
lines"
-                                             (repeat 0 200 (not (in "{"))))
-                                   ;; make sure we have a reasonably
-                                   ;; short match for an incomplete sub
-                                   (not (in ";{("))
-                                   buffer-end))))
-                 '(1 (if (match-beginning 3)
-                         'font-lock-variable-name-face
-                       'font-lock-function-name-face)
-                      t  ;; override
-                      t) ;; laxmatch in case of anonymous subroutines
-                  ;; -------- anchored: Signature
-                  `(,(rx (sequence (in "(,")
-                                   (eval cperl--ws*-rx)
-                                   (group (eval cperl--basic-variable-rx))))
-                    (progn
-                      (goto-char (match-beginning 2)) ; pre-match: Back to sig
-                      (match-end 2))
-                    nil
-                    (1 font-lock-variable-name-face)))
             ;; -------- various stuff calling for a package name
             ;; (matcher (subexp facespec) (subexp facespec))
             `(,(rx (sequence
diff --git a/test/lisp/progmodes/cperl-mode-resources/sub-names.pl 
b/test/lisp/progmodes/cperl-mode-resources/sub-names.pl
new file mode 100644
index 00000000000..46d05b4dbd2
--- /dev/null
+++ b/test/lisp/progmodes/cperl-mode-resources/sub-names.pl
@@ -0,0 +1,25 @@
+use 5.038;
+use feature 'class';
+use warnings;
+no warnings 'experimental';
+
+class C {
+    # "method" is not yet understood by perl-mode, but it isn't
+    # relevant here: We can use "sub" because what matters is the
+    # name, which collides with a builtin.
+    sub m {
+       "m called"
+    }
+}
+
+say C->new->m;
+
+# 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.
+
+__END__
+
+=head1 Test using the keywords POD
+
+This piece of POD has a method name in it, and we don't want "method"
+to be fontified as a keyword, nor "name" fontified as a name.
diff --git a/test/lisp/progmodes/cperl-mode-tests.el 
b/test/lisp/progmodes/cperl-mode-tests.el
index eaf228cb2e2..8f334245c64 100644
--- a/test/lisp/progmodes/cperl-mode-tests.el
+++ b/test/lisp/progmodes/cperl-mode-tests.el
@@ -256,6 +256,39 @@ These can occur as \"local\" aliases."
     (should (equal (get-text-property (point) 'face)
                    'font-lock-variable-name-face))))
 
+(ert-deftest cperl-test-fontify-sub-names ()
+    "Test fontification of subroutines named like builtins.
+On declaration, they should look like other used defined
+functions.  When called, they should not be fontified.  In
+comments and POD they should be fontified as POD."
+  (let ((file (ert-resource-file "sub-names.pl")))
+    (with-temp-buffer
+      (insert-file-contents file)
+      (goto-char (point-min))
+      (funcall cperl-test-mode)
+      (font-lock-ensure)
+      ;; The declaration
+      (search-forward-regexp "sub \\(m\\)")
+      (should (equal (get-text-property (match-beginning 1) 'face)
+                     'font-lock-function-name-face))
+      ;; calling as a method
+      (search-forward-regexp "C->new->\\(m\\)")
+      (should (equal (get-text-property (match-beginning 1) 'face)
+                     (if (equal cperl-test-mode 'perl-mode) nil
+                       'cperl-method-call)))
+      ;; POD
+      (search-forward-regexp "\\(method\\) \\(name\\)")
+      (should (equal (get-text-property (match-beginning 1) 'face)
+                     'font-lock-comment-face))
+      (should (equal (get-text-property (match-beginning 2) 'face)
+                     'font-lock-comment-face))
+      ;; comment
+      (search-forward-regexp "\\(method\\) \\(name\\)")
+      (should (equal (get-text-property (match-beginning 1) 'face)
+                     'font-lock-comment-face))
+      (should (equal (get-text-property (match-beginning 2) 'face)
+                     'font-lock-comment-face)))))
+
 (ert-deftest cperl-test-identify-heredoc ()
   "Test whether a construct containing \"<<\" followed by a
   bareword is properly identified for a here-document if