bug#23461: perl-mode: Displaying HERE-docs as strings instead of comments [PATCH]

[haj@posteo.de (Harald Jörg)]

[-- Attachment #1: Type: text/plain, Size: 1048 bytes --]

Stefan Monnier writes:

>> Investigating how to fix this leads to the longer story.  There are two
>> possible approaches:
>>
>>   1) use a string-style syntax (generic string) instead of c-style
>>      comments to flag HERE-documents.  That way, font-lock picks up the
>>      correct face automagically.
>>
>>   2) Keep HERE_docs as c-style comments, but change the face mapping by
>>      injecting a function into font-lock-defaults which applies the
>>      string face to c-style comments.
>
> 3) Use `font-lock-syntactic-face-function`?

Ah - thanks for this pointer!  I wasn't aware of this function, though
this feature is already in use in perl-mode.el.

This looks like to be an improved variation of 2): HERE-docs remain
marked as c-style comments, and `font-lock-syntactic-face-function` is
used to display them as strings.

A patch for this variation is attached.  Tests and test resources are
the same as with the first patch, and this patch also contains the same
fix for HERE-doc starters with a trailing comment.
-- 
Cheers,
haj

[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: Display HERE-docs as strings --]
[-- Type: text/x-diff, Size: 7480 bytes --]

From f5025280db960b956e64bd9c1a7049c0fa294c79 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Harald=20J=C3=B6rg?= <haj@posteo.de>
Date: Wed, 23 Dec 2020 15:17:27 +0100
Subject: [PATCH] ; perl-mode: Display here-docs as strings instead of
 comments.

* lisp/progmodes/perl-mode.el
(perl-font-lock-syntactic-face-function): Declare HERE-docs to be
fontified as string.
(perl-syntax-propertize-function): Handle comments after a
HERE-doc starter line.

* test/lisp/progmodes/cperl-mode-tests.el (cperl-test-heredocs):
New test (30 should-forms) for various aspects of HERE-documents.
Works for CPerl mode, and with the patch also for Perl mode.

* test/lisp/progmodes/cperl-mode-resources/here-docs.pl: New file
with test cases.
---
 lisp/progmodes/perl-mode.el                   |  20 +++-
 .../cperl-mode-resources/here-docs.pl         | 111 ++++++++++++++++++
 test/lisp/progmodes/cperl-mode-tests.el       |  29 +++++
 3 files changed, 159 insertions(+), 1 deletion(-)
 create mode 100644 test/lisp/progmodes/cperl-mode-resources/here-docs.pl

diff --git a/lisp/progmodes/perl-mode.el b/lisp/progmodes/perl-mode.el
index fd8a51b5a5..cc3eb4948a 100644
--- a/lisp/progmodes/perl-mode.el
+++ b/lisp/progmodes/perl-mode.el
@@ -324,13 +324,28 @@ perl-syntax-propertize-function
         ;; disambiguate with the left-bitshift operator.
         "\\|" perl--syntax-exp-intro-regexp "<<\\(?2:\\sw+\\)\\)"
         ".*\\(\n\\)")
-       (4 (let* ((st (get-text-property (match-beginning 4) 'syntax-table))
+       (4 (let* ((eol (match-beginning 4))
+                 (st (get-text-property eol 'syntax-table))
                  (name (match-string 2))
                  (indented (match-beginning 1)))
             (goto-char (match-end 2))
             (if (save-excursion (nth 8 (syntax-ppss (match-beginning 0))))
+                ;; '>>' occurred in a string, or in a comment.
                 ;; Leave the property of the newline unchanged.
                 st
+              ;; Before changing the syntax to c-style comment, let's
+              ;; check whether we are in an end-of-line comment, and
+              ;; if so, cheat by shifting the comment markers one char
+              ;; to the left.
+              (when (nth 4 (save-excursion (syntax-ppss eol)))
+                (when (equal (car (syntax-after (1- eol)))
+                             (car (string-to-syntax "<")))
+                  ;; yet another edge case: "#" is the last character
+                  ;; in that line, so there's actually no comment.
+                  (put-text-property (- eol 2) (1- eol)
+                                     'syntax-table (string-to-syntax "<")))
+                (put-text-property (1- eol) eol
+                                   'syntax-table (string-to-syntax ">")))
               (cons (car (string-to-syntax "< c"))
                     ;; Remember the names of heredocs found on this line.
                     (cons (cons (pcase (aref name 0)
@@ -485,6 +500,9 @@ perl-syntax-propertize-special-constructs
 
 (defun perl-font-lock-syntactic-face-function (state)
   (cond
+   ((and (eq 2 (nth 7 state)) ; c-style comment
+         (cdr-safe (get-text-property (nth 8 state) 'syntax-table))) ; HERE doc
+    'font-lock-string-face)
    ((and (nth 3 state)
          (eq ?e (cdr-safe (get-text-property (nth 8 state) 'syntax-table)))
          ;; This is a second-arg of s{..}{...} form; let's check if this second
diff --git a/test/lisp/progmodes/cperl-mode-resources/here-docs.pl b/test/lisp/progmodes/cperl-mode-resources/here-docs.pl
new file mode 100644
index 0000000000..39e4fe06ba
--- /dev/null
+++ b/test/lisp/progmodes/cperl-mode-resources/here-docs.pl
@@ -0,0 +1,111 @@
+use 5.020;
+
+=head1 NAME
+
+here-docs.pl - resource file for cperl-test-here-docs
+
+=head1 DESCRIPTION
+
+This file holds a couple of HERE documents, with a variety of normal
+and edge cases.  For a formatted view of this description, run:
+
+   (cperl-perldoc "here-docs.pl")
+
+For each of the HERE documents, the following checks will done:
+
+=over 4
+
+=item *
+
+All occurrences of the string "look-here" are fontified as
+'font-lock-string-face.  Note that we deliberately test the face, not
+the syntax property: Users won't care for the syntax property, but
+they see the face.  Different implementations with different syntax
+properties have been seen in the past.
+
+=item *
+
+Indentation of the line(s) containing "look-here" is 0, i.e. there are no
+leading spaces.
+
+=item *
+
+Indentation of the following perl statement containing "indent" should
+be 0 if the statement contains "noindent", and according to the mode's
+continued-statement-offset otherwise.
+
+=back
+
+=cut
+
+# Prologue to make the test file valid without warnings
+
+my $text;
+my $any;
+my $indentation;
+my $anywhere = 'back again';
+
+=head1 The Tests
+
+=head2 Test Case 1
+
+We have two HERE documents in one line with different quoting styles.
+
+=cut
+
+## test case
+
+$text = <<"HERE" . <<'THERE' . $any;
+#look-here and
+HERE
+$tlook-here and
+THERE
+
+my $noindent = "This should be left-justified";
+
+=head2 Test case 2
+
+A HERE document followed by a continuation line
+
+=cut
+
+## test case
+
+$text = <<HERE
+look-here
+HERE
+
+. 'indent-level'; # Continuation, should be indented
+
+=head2 Test case 3
+
+A here document with a line-end comment in the starter line,
+after a complete statement
+
+=cut
+
+## test case
+
+$text = <<HERE; # start here
+look-here
+HERE
+
+my $noindent = "New statement in this line";
+
+=head2 Test case 4
+
+A HERE document with a to-be-continued statement and a comment in the
+starter line.
+
+=cut
+
+## test case
+
+$text = <<HERE # start here
+look-here
+HERE
+
+. 'indent-level'; # Continuation, should be indented
+
+
+__END__
diff --git a/test/lisp/progmodes/cperl-mode-tests.el b/test/lisp/progmodes/cperl-mode-tests.el
index cb2d067a61..d9b090896d 100644
--- a/test/lisp/progmodes/cperl-mode-tests.el
+++ b/test/lisp/progmodes/cperl-mode-tests.el
@@ -135,6 +135,35 @@ cperl-test-fontify-punct-vars
         (should (equal (nth 3 (syntax-ppss)) nil))
         (should (equal (nth 4 (syntax-ppss)) t))))))
 
+(ert-deftest cperl-test-heredocs ()
+  "Test that HERE-docs are fontified as strings."
+  (let ((file (ert-resource-file "here-docs.pl"))
+        (cperl-continued-statement-offset perl-continued-statement-offset)
+        (case-fold-search nil))
+    (with-temp-buffer
+      (insert-file-contents file)
+      (goto-char (point-min))
+      (funcall cperl-test-mode)
+      (indent-region (point-min) (point-max))
+      (font-lock-ensure (point-min) (point-max))
+      (while (search-forward "## test case" nil t)
+        (save-excursion
+          (while (search-forward "look-here" nil t)
+            (should (equal
+                     (get-text-property (match-beginning 0) 'face)
+                     'font-lock-string-face))
+            (beginning-of-line)
+            (should (null (looking-at "[ \t]")))
+            (forward-line 1)))
+        (should (re-search-forward
+                 (concat "^\\([ \t]*\\)" ; the actual indentation amount
+                         "\\([^ \t\n].*?\\)\\(no\\)?indent")
+                 nil t))
+        (should (equal (- (match-end 1) (match-beginning 1))
+                       (if (match-beginning 3) 0
+                         perl-indent-level))))
+      )))
+
 ;;; Tests for issues reported in the Bug Tracker
 
 (defun cperl-test--run-bug-10483 ()
-- 
2.20.1