master fc1f6688a2d: ; cperl-mode.el: Don't override fontificaton in comments.

[Harald Jörg]

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

    ; cperl-mode.el: Don't override fontificaton in comments.
    
    * lisp/progmodes/cperl-mode.el (cperl-init-faces): Reorder the
    matchers for fontification of array and hash elements and keys so
    that they don't override comment and string fontification (Bug#66145).
    
    * test/lisp/progmodes/cperl-mode-tests.el (cperl-test-bug-66145):
    New test for all combinations of sigils and brackets/braces to
    verify that strings and comments are left untouched.  This test
    also works for perl-mode which has always done it correctly.
    
    * test/lisp/progmodes/cperl-mode-resources/cperl-bug-66145.pl: New
    resource file for the above test.
---
 lisp/progmodes/cperl-mode.el                       | 108 ++++++++++-----------
 .../cperl-mode-resources/cperl-bug-66145.pl        |  62 ++++++++++++
 test/lisp/progmodes/cperl-mode-tests.el            |  23 +++++
 3 files changed, 138 insertions(+), 55 deletions(-)

diff --git a/lisp/progmodes/cperl-mode.el b/lisp/progmodes/cperl-mode.el
index 1736b45c72d..c2d9c0d6020 100644
--- a/lisp/progmodes/cperl-mode.el
+++ b/lisp/progmodes/cperl-mode.el
@@ -6049,35 +6049,6 @@ functions (which they are not).  Inherits from 
`default'.")
             ;; (matcher subexp facespec)
            '("^[ \t]*format[ \t]+\\([a-zA-Z_][a-zA-Z_0-9:]*\\)[ \t]*=[ \t]*$"
              1 font-lock-function-name-face)
-            ;; -------- bareword hash key: $foo{bar}, $foo[1]{bar}
-            ;; (matcher (subexp facespec) ...
-            `(,(rx (or (in "]}\\%@>*&")
-                       (sequence "$" (eval cperl--normal-identifier-rx)))
-                   (0+ blank) "{" (0+ blank)
-                   (group-n 1 (sequence (opt "-")
-                                        (eval cperl--basic-identifier-rx)))
-                   (0+ blank) "}")
-;;         '("\\([]}\\%@>*&]\\|\\$[a-zA-Z0-9_:]*\\)[ \t]*{[ 
\t]*\\(-?[a-zA-Z0-9_:]+\\)[ \t]*}"
-             (1 font-lock-string-face t)
-              ;; -------- anchored bareword hash key: $foo{bar}{baz}
-              ;; ... (anchored-matcher pre-form post-form subex-highlighters)
-              (,(rx point
-                    (0+ blank) "{" (0+ blank)
-                    (group-n 1 (sequence (opt "-")
-                                         (eval cperl--basic-identifier-rx)))
-                    (0+ blank) "}")
-              ;; ("\\=[ \t]*{[ \t]*\\(-?[a-zA-Z0-9_:]+\\)[ \t]*}"
-              nil nil
-              (1 font-lock-string-face t)))
-            ;; -------- hash element assignments with bareword key => value
-            ;; (matcher subexp facespec)
-            `(,(rx (in "[ \t{,()")
-                   (group-n 1 (sequence (opt "-")
-                                        (eval cperl--basic-identifier-rx)))
-                   (0+ blank) "=>")
-              1 font-lock-string-face t)
-            ;;     '("[[ \t{,(]\\(-?[a-zA-Z0-9_:]+\\)[ \t]*=>" 1
-            ;;       font-lock-string-face t)
             ;; -------- labels
             ;; (matcher subexp facespec)
             `(,(rx
@@ -6177,32 +6148,33 @@ functions (which they are not).  Inherits from 
`default'.")
          (setq
           t-font-lock-keywords-1
           `(
-             ;; -------- arrays and hashes.  Access to elements is fixed below
-             ;; (matcher subexp facespec)
-             ;; facespec is an expression to distinguish between arrays and 
hashes
-             (,(rx (group-n 1 (group-n 2 (or (in "@%") "$#"))
-                            (eval cperl--normal-identifier-rx)))
-              1
-;;          ("\\(\\([@%]\\|\\$#\\)[a-zA-Z_:][a-zA-Z0-9_:]*\\)" 1
-             (if (eq (char-after (match-beginning 2)) ?%)
-                 'cperl-hash-face
-               'cperl-array-face)
-             nil)
-             ;; -------- access to array/hash elements
-             ;; (matcher subexp facespec)
-             ;; facespec is an expression to distinguish between arrays and 
hashes
-             (,(rx (group-n 1 (group-n 2 (in "$@%"))
-                            (eval cperl--normal-identifier-rx))
-                   (0+ blank)
-                   (group-n 3 (in "[{")))
-;;          ("\\(\\([$@%]+\\)[a-zA-Z_:][a-zA-Z0-9_:]*\\)[ \t]*\\([[{]\\)"
-             1
-             (if (= (- (match-end 2) (match-beginning 2)) 1)
-                 (if (eq (char-after (match-beginning 3)) ?{)
-                     'cperl-hash-face
-                   'cperl-array-face)             ; arrays and hashes
-               font-lock-variable-name-face)      ; Just to put something
-             t)                                   ; override previous
+            ;; -------- bareword hash key: $foo{bar}, $foo[1]{bar}
+            ;; (matcher (subexp facespec) ...
+            (,(rx (or (in "]}\\%@>*&")
+                       (sequence "$" (eval cperl--normal-identifier-rx)))
+                   (0+ blank) "{" (0+ blank)
+                   (group-n 1 (sequence (opt "-")
+                                        (eval cperl--basic-identifier-rx)))
+                   (0+ blank) "}")
+;;         '("\\([]}\\%@>*&]\\|\\$[a-zA-Z0-9_:]*\\)[ \t]*{[ 
\t]*\\(-?[a-zA-Z0-9_:]+\\)[ \t]*}"
+             (1 font-lock-string-face)
+              ;; -------- anchored bareword hash key: $foo{bar}{baz}
+              ;; ... (anchored-matcher pre-form post-form subex-highlighters)
+              (,(rx point
+                    (0+ blank) "{" (0+ blank)
+                    (group-n 1 (sequence (opt "-")
+                                         (eval cperl--basic-identifier-rx)))
+                    (0+ blank) "}")
+              ;; ("\\=[ \t]*{[ \t]*\\(-?[a-zA-Z0-9_:]+\\)[ \t]*}"
+              nil nil
+              (1 font-lock-string-face)))
+            ;; -------- hash element assignments with bareword key => value
+            ;; (matcher subexp facespec)
+            (,(rx (in "[ \t{,()")
+                   (group-n 1 (sequence (opt "-")
+                                        (eval cperl--basic-identifier-rx)))
+                   (0+ blank) "=>")
+              1 font-lock-string-face)
              ;; -------- @$ array dereferences, $#$ last array index
              ;; (matcher (subexp facespec) (subexp facespec))
              (,(rx (group-n 1 (or "@" "$#"))
@@ -6221,6 +6193,32 @@ functions (which they are not).  Inherits from 
`default'.")
             ;; ("\\(%\\)\\(\\$+\\([a-zA-Z_:][a-zA-Z0-9_:]*\\|[^ \t\n]\\)\\)"
              (1 'cperl-hash-face)
              (2 font-lock-variable-name-face))
+             ;; -------- access to array/hash elements
+             ;; (matcher subexp facespec)
+             ;; facespec is an expression to distinguish between arrays and 
hashes
+             (,(rx (group-n 1 (group-n 2 (in "$@%"))
+                            (eval cperl--normal-identifier-rx))
+                   (0+ blank)
+                   (group-n 3 (in "[{")))
+;;          ("\\(\\([$@%]+\\)[a-zA-Z_:][a-zA-Z0-9_:]*\\)[ \t]*\\([[{]\\)"
+             1
+             (if (= (- (match-end 2) (match-beginning 2)) 1)
+                 (if (eq (char-after (match-beginning 3)) ?{)
+                     'cperl-hash-face
+                   'cperl-array-face)             ; arrays and hashes
+               font-lock-variable-name-face)      ; Just to put something
+             nil)                                 ; do not override previous
+             ;; -------- "Pure" arrays and hashes.
+             ;; (matcher subexp facespec)
+             ;; facespec is an expression to distinguish between arrays and 
hashes
+             (,(rx (group-n 1 (group-n 2 (or (in "@%") "$#"))
+                            (eval cperl--normal-identifier-rx)))
+              1
+;;          ("\\(\\([@%]\\|\\$#\\)[a-zA-Z_:][a-zA-Z0-9_:]*\\)" 1
+             (if (eq (char-after (match-beginning 2)) ?%)
+                 'cperl-hash-face
+               'cperl-array-face)
+             nil)
 ;;("\\([smy]\\|tr\\)\\([^a-z_A-Z0-9]\\)\\(\\([^\n\\]*||\\)\\)\\2")
 ;;; Too much noise from \s* @s[ and friends
             ;;("\\(\\<\\([msy]\\|tr\\)[ \t]*\\([^ 
\t\na-zA-Z0-9_]\\)\\|\\(/\\)\\)"
diff --git a/test/lisp/progmodes/cperl-mode-resources/cperl-bug-66145.pl 
b/test/lisp/progmodes/cperl-mode-resources/cperl-bug-66145.pl
new file mode 100644
index 00000000000..70f12346ded
--- /dev/null
+++ b/test/lisp/progmodes/cperl-mode-resources/cperl-bug-66145.pl
@@ -0,0 +1,62 @@
+# The original code, from the bug report, with variables renamed
+
+sub foo {
+  # Here we do something like
+  # this: $array_comment [ num_things ]->{key_comment}
+}
+
+# --------------------------------------------------
+# Comments containing hash and array sigils
+
+# This is an @array, and this is a %hash
+# $array_comment[$index] = $hash_comment{key_comment}
+# The last element has the index $#array_comment
+# my @a_slice = @array_comment[1,2,3];
+# my @h_slice = @hash_comment{qw(a b c)};
+# my %a_set   = %array_comment[1,2,3];
+# my %h_set   = %hash_comment{qw(a b c)};
+
+# --------------------------------------------------
+# in POD
+
+=head1 NAME
+
+cperl-bug-66145 - don't fontify arrays and hashes in POD
+
+=head1 SYNOPSIS
+
+   $array_comment[$index] = $hash_comment{key_comment};
+   @array_comment = qw(in pod);
+   %hash_comment  = key_comment => q(pod);
+   @array_comment = @array_comment[1,2,3];
+   @array_comment = @hash_comment{qw(a b c)};
+   %hash_comment  = %array_comment[1,2,3];
+   %hash_comment  = %hash_comment{qw(a b c)};
+
+=cut
+
+# --------------------------------------------------
+# in strings
+
+my @strings = (
+    q/$array_string[$index] = $hash_string{key_string};/,
+    q/my @array_string = qw(in unquoted string);/,
+    q/my %hash_string  = (key_string => q(pod);)/,
+    q/@array_string    = @array_string[1,2,3];/,
+    q/@array_string    = @hash_string{qw(a b c)};/,
+    q/%hash_string     = %array_string[1,2,3];/,
+    q/%hash_string     = %hash_string{qw(a b c)};/,
+);
+
+# --------------------------------------------------
+# in a HERE-document (perl-mode has an extra face for that)
+
+my $here = <<DONE;
+   $array_here[$index_here] = $hash_here{key_here};
+   @array_here = qw(in a hrere-document);
+   %hash_here  = key_here => q(pod);
+   @array_here = @array_here[1,2,3];
+   @array_here = @hash_here{qw(a b c)};
+   %hash_here  = %array_here[1,2,3];
+   %hash_here  = %hash_here{qw(a b c)};
+DONE
diff --git a/test/lisp/progmodes/cperl-mode-tests.el 
b/test/lisp/progmodes/cperl-mode-tests.el
index a29ee54b6b9..87d4f11280c 100644
--- a/test/lisp/progmodes/cperl-mode-tests.el
+++ b/test/lisp/progmodes/cperl-mode-tests.el
@@ -1379,6 +1379,29 @@ as a regex."
        (forward-line 1))))
   (cperl-set-style-back))
 
+(ert-deftest cperl-test-bug-66145 ()
+  "Verify that hashes and arrays are only fontified in code.
+In strings, comments and POD the syntaxified faces should
+prevail.  The tests exercise all combinations of sigils $@% and
+parenthesess [{ for comments, POD, strings and HERE-documents.
+Fontification in code for `cperl-mode' is done in the tests
+beginning with `cperl-test-unicode`."
+  (let ((types '("array" "hash" "key"))
+        (faces `(("string"  . font-lock-string-face)
+                 ("comment" . font-lock-comment-face)
+                 ("here"    . ,(if (equal cperl-test-mode 'perl-mode)
+                                   'perl-heredoc
+                                 font-lock-string-face)))))
+    (with-temp-buffer
+      (insert-file-contents (ert-resource-file "cperl-bug-66145.pl"))
+      (funcall cperl-test-mode)
+      (font-lock-ensure)
+      (dolist (type types)
+        (goto-char (point-min))
+        (while (re-search-forward (concat type "_\\([a-z]+\\)") nil t)
+          (should (equal (get-text-property (match-beginning 1) 'face)
+                         (cdr (assoc (match-string-no-properties 1)
+                                     faces)))))))))
 
 (ert-deftest test-indentation ()
   (ert-test-erts-file (ert-resource-file "cperl-indents.erts")))