From 9a19e5991b33db7b8a71b653078f2a3c0a7afd08 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Harald=20J=C3=B6rg?= <haj@posteo.de>
Date: Tue, 5 Jan 2021 00:09:02 +0100
Subject: [PATCH] ; perl-mode: Display here-docs as strings instead of comments

* lisp/progmodes/perl-mode.el
(perl-syntax-propertize-function): Handle HERE doc starter
lines ending in a comment.
(perl-heredoc): New face for HERE docs, inheriting from
font-lock-string-face.
(perl-font-lock-syntactic-face-function): Apply the new face
to HERE docs (Bug#23461).

* test/lisp/progmodes/cperl-mode-tests.el
(cperl-test--run-bug-10483): Skip for Perl mode.  The test
explicitly calls a function of CPerl mode.

* test/lisp/progmodes/cperl-mode-resources/here-docs.pl: New
tests for HERE docs, common to Perl mode and CPerl mode.
---
 lisp/progmodes/perl-mode.el                   |  29 +++-
 .../cperl-mode-resources/here-docs.pl         | 143 ++++++++++++++++++
 test/lisp/progmodes/cperl-mode-tests.el       |  31 ++++
 3 files changed, 202 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 ec20b01a0f..2a2a4978c6 100644
--- a/lisp/progmodes/perl-mode.el
+++ b/lisp/progmodes/perl-mode.el
@@ -324,13 +324,33 @@ 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
+              ;; Beware of `foo <<'BAR' #baz` because
+              ;; the newline needs to start the here-doc
+              ;; and can't be used to close the comment.
+              (let ((eol-state (save-excursion (syntax-ppss eol))))
+                (when (nth 4 eol-state)
+                  (if (/= (1- eol) (nth 8 eol-state))
+                      ;; make the last char of the comment closing it
+                      (put-text-property (1- eol) eol
+                                         'syntax-table (string-to-syntax ">"))
+                    ;; In `foo <<'BAR' #` the # is the last character
+                    ;; before eol and can't both open and close the
+                    ;; comment.  Workaround: disguise the "#" as
+                    ;; whitespace and fontify it as a comment.
+                    (put-text-property (1- eol) eol
+                                       'syntax-table (string-to-syntax "-"))
+                    (put-text-property (1- eol) eol
+                                       'font-lock-face
+                                       'font-lock-comment-face))))
               (cons (car (string-to-syntax "< c"))
                     ;; Remember the names of heredocs found on this line.
                     (cons (cons (pcase (aref name 0)
@@ -483,8 +503,15 @@ perl-syntax-propertize-special-constructs
 	      ;; as twoarg).
 	      (perl-syntax-propertize-special-constructs limit)))))))))
 
+(defface perl-heredoc
+  '((t (:inherit font-lock-string-face)))
+  "The face for here-documents.  Inherits from font-lock-string-face.")
+
 (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
+    'perl-heredoc)
    ((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..8af4625fff
--- /dev/null
+++ b/test/lisp/progmodes/cperl-mode-resources/here-docs.pl
@@ -0,0 +1,143 @@
+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 correcty.
+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';
+my $noindent;
+
+=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
+
+$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
+
+$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
+
+=head2 Test case 5
+
+A HERE document with a comment sign, but no comment to follow.
+
+
+=cut
+
+## test case
+
+$text = <<HERE; #
+look-here
+HERE
+
+$noindent = "New statement in this line";
+
+=head2 Test case 6
+
+A HERE document with a comment sign, but no comment to follow, with a
+statement to be continued.  Also, the character before the comment
+sign has a relevant syntax property (end of string in our case) which
+must be preserved.
+
+=cut
+
+## test case
+
+$text = <<"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 46e687f14d..71fa4e5ea4 100644
--- a/test/lisp/progmodes/cperl-mode-tests.el
+++ b/test/lisp/progmodes/cperl-mode-tests.el
@@ -135,6 +135,36 @@ 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 with the appropriate face."
+  (let ((file (ert-resource-file "here-docs.pl"))
+        (cperl-continued-statement-offset perl-continued-statement-offset)
+        (target-font (if (equal cperl-test-mode 'perl-mode) 'perl-heredoc
+                       'font-lock-string-face))
+        (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)
+                     target-font))
+            (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 ()
@@ -164,6 +194,7 @@ cperl-test-bug-10483
   (interactive)
   (skip-unless (not (getenv "EMACS_HYDRA_CI"))) ; FIXME times out
   (skip-unless (not (< emacs-major-version 28))) ; times out in older Emacsen
+  (skip-unless (eq cperl-test-mode #'cperl-mode))
   (let* ((emacs (concat invocation-directory invocation-name))
          (test-function 'cperl-test--run-bug-10483)
          (test-function-name (symbol-name test-function))
-- 
2.20.1