From: Harald Jörg <haj@posteo.de>
Date: Mon, 23 Aug 2021 14:26:45 +0000 (+0200)
Subject: ; cperl-mode: bugfix / rework fontification of here-docs
X-Git-Tag: emacs-28.0.90~1340
X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=975939df214179906c9101c14e1306502b49466f;p=emacs.git

; cperl-mode: bugfix / rework fontification of here-docs

* lisp/progmodes/cperl-mode.el (cperl-mode): Use
`cperl-font-lock-syntactic-face-function'.
(cperl-commentify): Add a docstring, eliminate unused formal
parameter `noface'.
(cperl-is-here-doc-p): New function to detect whether "<<" starts
a here-document, factored out from `cperl-find-pods-heres'.
(cperl-here-doc-functions): New variable: List of functions which
allow here-documents as parameters, for use in
`cperl-is-here-doc-p'.
(cperl-process-here-doc): New function, factored out from
`cperl-find-pods-heres'.  Fixed to keep correct fontification
after non-interactive (elisp) changes (Bug#14343, Bug#28962).
(cperl-find-pods-heres): Extend the doc-string to describe all
parameters.  Don't remove text properties in recursive calls on
the same line.  Call `cperl-process-here-doc' when appropriate.
(cperl-font-lock-syntactic-face-function): New function to
highlight c-style comments as here-documents (adapted from
perl-mode.el).

* test/lisp/progmodes/cperl-mode-tests.el
(cperl-test-identify-heredoc): New test for the new function
`cperl-is-here-doc-p'.
(cperl-test-identify-no-heredoc): New test for the new function
`cperl-is-here-doc-p', testing constructs which start with "<<"
but are no here-documents.
(cperl-test-here-doc-missing-end): New test to verify correct
detection of a missing here-document delimiter.
(cperl-test-bug-14343): New test to verify that inserting text
into a here-document with elisp does not break fontification.
---

diff --git a/lisp/progmodes/cperl-mode.el b/lisp/progmodes/cperl-mode.el
index 3370df64919..6bffea59367 100644
--- a/lisp/progmodes/cperl-mode.el
+++ b/lisp/progmodes/cperl-mode.el
@@ -1741,7 +1741,9 @@ or as help on variables `cperl-tips', `cperl-problems',
               '((cperl-load-font-lock-keywords
                  cperl-load-font-lock-keywords-1
                  cperl-load-font-lock-keywords-2)
-                nil nil ((?_ . "w"))))
+                nil nil ((?_ . "w")) nil
+                (font-lock-syntactic-face-function
+                 . cperl-font-lock-syntactic-face-function)))
   ;; Reset syntaxification cache.
   (setq-local cperl-syntax-state nil)
   (when cperl-use-syntax-table-text-property
@@ -3147,26 +3149,29 @@ Returns true if comment is found.  In POD will not move the point."
     (while (re-search-forward "^\\s(" e 'to-end)
       (put-text-property (1- (point)) (point) 'syntax-table cperl-st-punct))))
 
-(defun cperl-commentify (bb e string &optional noface)
-  (if cperl-use-syntax-table-text-property
-      (if (eq noface 'n)		; Only immediate
-	  nil
-	;; We suppose that e is _after_ the end of construction, as after eol.
-	(setq string (if string cperl-st-sfence cperl-st-cfence))
-	(if (> bb (- e 2))
+(defun cperl-commentify (begin end string)
+  "Marks text from BEGIN to END as generic string or comment.
+Marks as generic string if STRING, as generic comment otherwise.
+A single character is marked as punctuation and directly
+fontified.  Does nothing if BEGIN and END are equal.  If
+`cperl-use-syntax-text-property' is nil, just fontifies."
+  (if (and cperl-use-syntax-table-text-property
+           (> end begin))
+      (progn
+        (setq string (if string cperl-st-sfence cperl-st-cfence))
+        (if (> begin (- end 2))
 	    ;; one-char string/comment?!
-	    (cperl-modify-syntax-type bb cperl-st-punct)
-	  (cperl-modify-syntax-type bb string)
-	  (cperl-modify-syntax-type (1- e) string))
-	(if (and (eq string cperl-st-sfence) (> (- e 2) bb))
-	    (put-text-property (1+ bb) (1- e)
+	    (cperl-modify-syntax-type begin cperl-st-punct)
+          (cperl-modify-syntax-type begin string)
+          (cperl-modify-syntax-type (1- end) string))
+        (if (and (eq string cperl-st-sfence) (> (- end 2) begin))
+	    (put-text-property (1+ begin) (1- end)
 			       'syntax-table cperl-string-syntax-table))
-	(cperl-protect-defun-start bb e))
+        (cperl-protect-defun-start begin end))
     ;; Fontify
-    (or noface
-	(not cperl-pod-here-fontify)
-	(put-text-property bb e 'face (if string 'font-lock-string-face
-					'font-lock-comment-face)))))
+    (when cperl-pod-here-fontify
+      (put-text-property begin end 'face (if string 'font-lock-string-face
+				           'font-lock-comment-face)))))
 
 (defvar cperl-starters '(( ?\( . ?\) )
 			 ( ?\[ . ?\] )
@@ -3510,19 +3515,191 @@ Should be called with the point before leading colon of an attribute."
     (goto-char endbracket)		; just in case something misbehaves???
     t))
 
+(defvar cperl-here-doc-functions
+  (regexp-opt '("print" "printf" "say"  ; print $handle <<EOF
+                "system" "exec"         ; system $progname <<EOF
+                "sort")                 ; sort $subname <<EOF
+              'symbols)                 ; avoid false positives
+  "After these keywords `$var <<bareword' is a here-document.
+After any other tokens it is treated as the variable `$var',
+left-shifted by the return value of the function `bareword'.")
+
+(defun cperl-is-here-doc-p (start)
+  "Find out whether a \"<<\" construct starting at START is a here-document.
+The point is expected to be after the end of the delimiter.
+Quoted delimiters after \"<<\" are unambiguously starting
+here-documents and are not handled here.  This function does not
+move point but changes match data."
+  ;; not a here-doc | here-doc
+  ;; $foo << b;     | $f .= <<B;
+  ;; ($f+1) << b;   | a($f) . <<B;
+  ;; foo 1, <<B;    | $x{a} <<b;
+  ;; Limitations:
+  ;; foo <<bar is statically undecidable. It could be either
+  ;; foo() << bar # left shifting the return value or
+  ;; foo(<<bar)   # passing a here-doc to foo().
+  ;; We treat it as here-document and kindly ask programmers to
+  ;; disambiguate by adding parens.
+  (null
+   (or (looking-at "[ \t]*(") ; << function_call()
+       (looking-at ">>")      ; <<>> operator
+       (save-excursion ; 1 << func_name, or $foo << 10
+	 (condition-case nil
+	     (progn
+	       (goto-char start)
+	       (forward-sexp -1) ;; examine the part before "<<"
+	       (save-match-data
+		 (cond
+		  ((looking-at "[0-9$({]")
+		   (forward-sexp 1)
+		   (and
+		    (looking-at "[ \t]*<<")
+		    (condition-case nil
+			;; print $foo <<EOF
+			(progn
+			  (forward-sexp -2)
+			  (not
+			   (looking-at cperl-here-doc-functions)))
+		      (error t)))))))
+	   (error nil)))))) ; func(<<EOF)
+
+(defun cperl-process-here-doc (min max end overshoot stop-point
+                                   end-of-here-doc err-l
+                                   indented-here-doc-p
+                                   matched-pos todo-pos
+                                   delim-begin delim-end)
+  "Process a here-document's delimiters and body.
+The parameters MIN, MAX, END, OVERSHOOT, STOP-POINT, ERR-L are
+used for recursive calls to `cperl-find-pods-here' to handle the
+rest of the line which contains the delimiter.  MATCHED-POS and
+TODO-POS are initial values for this function's result.
+END-OF-HERE-DOC is the end of a previous here-doc in the same
+line, or nil if this is the first.  DELIM-BEGIN and DELIM-END are
+the positions where the here-document's delimiter has been found.
+This is part of `cperl-find-pods-heres' (below)."
+  (let* ((my-cperl-delimiters-face font-lock-constant-face)
+         (delimiter (buffer-substring-no-properties delim-begin delim-end))
+         (qtag (regexp-quote delimiter))
+         (use-syntax-state (and cperl-syntax-state
+			        (>= min (car cperl-syntax-state))))
+         (state-point (if use-syntax-state
+			  (car cperl-syntax-state)
+		        (point-min)))
+         (state (if use-syntax-state
+		    (cdr cperl-syntax-state)))
+         here-doc-start here-doc-end defs-eol
+         warning-message)
+    (when cperl-pod-here-fontify
+      ;; Highlight the starting delimiter
+      (cperl-postpone-fontification delim-begin delim-end
+                                    'face my-cperl-delimiters-face)
+      (cperl-put-do-not-fontify delim-begin delim-end t))
+    (forward-line)
+    (setq here-doc-start (point) ; first char of (first) here-doc
+          defs-eol (1- here-doc-start)) ; end of definitions line
+    (if end-of-here-doc
+        ;; skip to the end of the previous here-doc
+	(goto-char end-of-here-doc)
+      ;; otherwise treat the first (or only) here-doc: Check for
+      ;; special cases if the line containing the delimiter(s)
+      ;; ends in a regular comment or a solitary ?#
+      (let* ((eol-state (save-excursion (syntax-ppss defs-eol))))
+        (when (nth 4 eol-state) ; EOL is in a comment
+          (if (= (1- defs-eol) (nth 8 eol-state))
+              ;; line ends with a naked comment starter.
+              ;; We let it start the here-doc.
+              (progn
+                (put-text-property (1- defs-eol) defs-eol
+                                   'font-lock-face
+                                   'font-lock-comment-face)
+                (put-text-property (1- defs-eol) defs-eol
+                                   'syntax-type 'here-doc)
+                (put-text-property (1- defs-eol) defs-eol
+                                   'syntax-type 'here-doc)
+                (put-text-property (1- defs-eol) defs-eol
+                                   'syntax-table
+                                   (string-to-syntax "< c"))
+                )
+            ;; line ends with a "regular" comment: make
+            ;; the last character of the comment closing
+            ;; it so that we can use the line feed to
+            ;; start the here-doc
+            (put-text-property (1- defs-eol) defs-eol
+                               'syntax-table
+                               (string-to-syntax ">"))))))
+    (setq here-doc-start (point)) ; now points to current here-doc
+    ;; Find the terminating delimiter.
+    ;; We do not search to max, since we may be called from
+    ;; some hook of fontification, and max is random
+    (or (re-search-forward
+	 (concat "^" (when indented-here-doc-p "[ \t]*")
+		 qtag "$")
+	 stop-point 'toend)
+	(progn		; Pretend we matched at the end
+	  (goto-char (point-max))
+	  (re-search-forward "\\'")
+	  (setq warning-message
+                (format "End of here-document `%s' not found." delimiter))
+	  (or (car err-l) (setcar err-l here-doc-start))))
+    (when cperl-pod-here-fontify
+      ;; Highlight the ending delimiter
+      (cperl-postpone-fontification
+       (match-beginning 0) (match-end 0)
+       'face my-cperl-delimiters-face)
+      (cperl-put-do-not-fontify here-doc-start (match-end 0) t))
+    (setq here-doc-end (cperl-1+ (match-end 0))) ; eol after delim
+    (put-text-property here-doc-start (match-beginning 0)
+		       'syntax-type 'here-doc)
+    (put-text-property (match-beginning 0) here-doc-end
+		       'syntax-type 'here-doc-delim)
+    (put-text-property here-doc-start here-doc-end 'here-doc-group t)
+    ;; This makes insertion at the start of HERE-DOC update
+    ;; the whole construct:
+    (put-text-property here-doc-start (cperl-1+ here-doc-start) 'front-sticky '(syntax-type))
+    (cperl-commentify (match-beginning 0) (1- here-doc-end) nil)
+    (when (> (match-beginning 0) here-doc-start)
+      ;; here-document has non-zero length
+      (cperl-modify-syntax-type (1- here-doc-start) (string-to-syntax "< c"))
+      (cperl-modify-syntax-type (1- (match-beginning 0))
+                                (string-to-syntax "> c")))
+    (cperl-put-do-not-fontify here-doc-start (match-end 0) t)
+    ;; Cache the syntax info...
+    (setq cperl-syntax-state (cons state-point state))
+    ;; ... and process the rest of the line...
+    (setq overshoot
+	  (elt		; non-inter ignore-max
+	   (cperl-find-pods-heres todo-pos defs-eol
+                                  t end t here-doc-end)
+           1))
+    (if (and overshoot (> overshoot (point)))
+	(goto-char overshoot)
+      (setq overshoot here-doc-end))
+    (list (if (> here-doc-end max) matched-pos nil)
+          overshoot
+          warning-message)))
+
 ;; Debugging this may require (setq max-specpdl-size 2000)...
 (defun cperl-find-pods-heres (&optional min max non-inter end ignore-max end-of-here-doc)
   "Scans the buffer for hard-to-parse Perl constructions.
-If `cperl-pod-here-fontify' is not-nil after evaluation, will fontify
-the sections using `cperl-pod-head-face', `cperl-pod-face',
-`cperl-here-face'."
+If `cperl-pod-here-fontify' is not-nil after evaluation, will
+fontify the sections using `cperl-pod-head-face',
+`cperl-pod-face', `cperl-here-face'.  The optional parameters are
+for internal use: Scans from MIN to MAX, or the whole buffer if
+these are nil.  If NON-INTER, does't write progress messages.  If
+IGNORE-MAX, scans to end of buffer.  If END, we are after a
+\"__END__\" or \"__DATA__\" token and ignore unbalanced
+constructs.  END-OF-HERE-DOC points to the end of a here-document
+which has already been processed.  Returns a two-element list of
+the position where an error occurred (if any) and the
+\"overshoot\", which is used for recursive calls in starting
+lines of here-documents."
   (interactive)
   (or min (setq min (point-min)
 		cperl-syntax-state nil
 		cperl-syntax-done-to min))
   (or max (setq max (point-max)))
-  (let* ((cperl-pod-here-fontify (eval cperl-pod-here-fontify)) go tmpend
-	 face head-face here-face b e bb tag qtag b1 e1 argument i c tail tb
+  (let* (go tmpend
+	 face head-face b e bb tag qtag b1 e1 argument i c tail tb
 	 is-REx is-x-REx REx-subgr-start REx-subgr-end was-subgr i2 hairy-RE
 	 (case-fold-search nil) (inhibit-read-only t) (buffer-undo-list t)
 	 (modified (buffer-modified-p)) overshoot is-o-REx name
@@ -3619,20 +3796,20 @@ the sections using `cperl-pod-head-face', `cperl-pod-face',
 	    (and cperl-pod-here-fontify
 		 ;; We had evals here, do not know why...
 		 (setq face cperl-pod-face
-		       head-face cperl-pod-head-face
-		       here-face cperl-here-face))
-	    (remove-text-properties min max
-				    '(syntax-type t in-pod t syntax-table t
-						  attrib-group t
-						  REx-interpolated t
-						  cperl-postpone t
-						  syntax-subtype t
-						  rear-nonsticky t
-						  front-sticky t
-						  here-doc-group t
-						  first-format-line t
-						  REx-part2 t
-						  indentable t))
+		       head-face cperl-pod-head-face))
+            (unless end-of-here-doc
+	      (remove-text-properties min max
+				      '(syntax-type t in-pod t syntax-table t
+						    attrib-group t
+						    REx-interpolated t
+						    cperl-postpone t
+						    syntax-subtype t
+						    rear-nonsticky t
+						    front-sticky t
+						    here-doc-group t
+						    first-format-line t
+						    REx-part2 t
+						    indentable t)))
 	    ;; Need to remove face as well...
 	    (goto-char min)
 	    (while (and
@@ -3751,120 +3928,36 @@ the sections using `cperl-pod-head-face', `cperl-pod-face',
 	       ;; but multiline quote on the same line as <<HERE confuses us...
                ;; ;; One extra () before this:
 	       ;;"<<"
-	       ;;  "\\("			; 1 + 1
+	       ;;  "<<\\(~?\\)"		 ; HERE-DOC, indented-p = capture 2
 	       ;;  ;; First variant "BLAH" or just ``.
 	       ;;     "[ \t]*"			; Yes, whitespace is allowed!
-	       ;;     "\\([\"'`]\\)"	; 2 + 1
-	       ;;     "\\([^\"'`\n]*\\)"	; 3 + 1
-	       ;;     "\\3"
+	       ;;     "\\([\"'`]\\)"	; 3 + 1
+	       ;;     "\\([^\"'`\n]*\\)"	; 4 + 1
+	       ;;     "\\4"
 	       ;;  "\\|"
 	       ;;  ;; Second variant: Identifier or \ID or empty
-	       ;;    "\\\\?\\(\\([a-zA-Z_][a-zA-Z_0-9]*\\)?\\)" ; 4 + 1, 5 + 1
+	       ;;    "\\\\?\\(\\([a-zA-Z_][a-zA-Z_0-9]*\\)?\\)" ; 5 + 1, 6 + 1
 	       ;;    ;; Do not have <<= or << 30 or <<30 or << $blah.
 	       ;;    ;; "\\([^= \t0-9$@%&]\\|[ \t]+[^ \t\n0-9$@%&]\\)" ; 6 + 1
-	       ;;    "\\(\\)"		; To preserve count of pars :-( 6 + 1
 	       ;;  "\\)"
-	       ((match-beginning 3)	; 2 + 1: found "<<", detect its type
-		(setq b (point)
-		      tb (match-beginning 0)
-		      c (and		; not HERE-DOC
-			 (match-beginning 6)
-			 (save-match-data
-			   (or (looking-at "[ \t]*(") ; << function_call()
-			       (looking-at ">>")      ; <<>> operator
-			       (save-excursion ; 1 << func_name, or $foo << 10
-				 (condition-case nil
-				     (progn
-				       (goto-char tb)
-	       ;;; XXX What to do: foo <<bar ???
-	       ;;; XXX Need to support print {a} <<B ???
-				       (forward-sexp -1)
-				       (save-match-data
-					; $foo << b; $f .= <<B;
-					; ($f+1) << b; a($f) . <<B;
-					; foo 1, <<B; $x{a} <<b;
-					 (cond
-					  ((looking-at "[0-9$({]")
-					   (forward-sexp 1)
-					   (and
-					    (looking-at "[ \t]*<<")
-					    (condition-case nil
-						;; print $foo <<EOF
-						(progn
-						  (forward-sexp -2)
-						  (not
-						   (looking-at "\\(printf?\\|say\\|system\\|exec\\|sort\\)\\>")))
-						(error t)))))))
-				   (error nil))) ; func(<<EOF)
-			       (and (not (match-beginning 7)) ; Empty
-				    (looking-at
-				     "[ \t]*[=0-9$@%&(]"))))))
-		(if c			; Not here-doc
-		    nil			; Skip it.
-		  (setq c (match-end 3)) ; 2 + 1
-		  (if (match-beginning 6) ;6 + 1
-		      (setq b1 (match-beginning 6) ; 5 + 1
-			    e1 (match-end 6)) ; 5 + 1
-		    (setq b1 (match-beginning 5) ; 4 + 1
-			  e1 (match-end 5))) ; 4 + 1
-		  (setq tag (buffer-substring b1 e1)
-			qtag (regexp-quote tag))
-		  (cond (cperl-pod-here-fontify
-			 ;; Highlight the starting delimiter
-			 (cperl-postpone-fontification
-			  b1 e1 'face my-cperl-delimiters-face)
-			 (cperl-put-do-not-fontify b1 e1 t)))
-		  (forward-line)
-		  (setq i (point))
-		  (if end-of-here-doc
-		      (goto-char end-of-here-doc))
-		  (setq b (point))
-		  ;; We do not search to max, since we may be called from
-		  ;; some hook of fontification, and max is random
-		  (or (and (re-search-forward
-			    (concat "^" (when (equal (match-string 2) "~") "[ \t]*")
-				    qtag "$")
-			    stop-point 'toend)
-			   ;;;(eq (following-char) ?\n) ; XXXX WHY???
-			   )
-		    (progn		; Pretend we matched at the end
-		      (goto-char (point-max))
-		      (re-search-forward "\\'")
-		      (setq warning-message
-                            (format "End of here-document `%s' not found." tag))
-		      (or (car err-l) (setcar err-l b))))
-		  (if cperl-pod-here-fontify
-		      (progn
-			;; Highlight the ending delimiter
-			(cperl-postpone-fontification
-			 (match-beginning 0) (match-end 0)
-			 'face my-cperl-delimiters-face)
-			(cperl-put-do-not-fontify b (match-end 0) t)
-			;; Highlight the HERE-DOC
-			(cperl-postpone-fontification b (match-beginning 0)
-						      'face here-face)))
-		  (setq e1 (cperl-1+ (match-end 0)))
-		  (put-text-property b (match-beginning 0)
-				     'syntax-type 'here-doc)
-		  (put-text-property (match-beginning 0) e1
-				     'syntax-type 'here-doc-delim)
-		  (put-text-property b e1 'here-doc-group t)
-		  ;; This makes insertion at the start of HERE-DOC update
-		  ;; the whole construct:
-		  (put-text-property b (cperl-1+ b) 'front-sticky '(syntax-type))
-		  (cperl-commentify b e1 nil)
-		  (cperl-put-do-not-fontify b (match-end 0) t)
-		  ;; Cache the syntax info...
-		  (setq cperl-syntax-state (cons state-point state))
-		  ;; ... and process the rest of the line...
-		  (setq overshoot
-			(elt		; non-inter ignore-max
-			 (cperl-find-pods-heres c i t end t e1) 1))
-		  (if (and overshoot (> overshoot (point)))
-		      (goto-char overshoot)
-		    (setq overshoot e1))
-		  (if (> e1 max)
-		      (setq tmpend tb))))
+               ((match-beginning 3)     ; 2 + 1: found "<<", detect its type
+                (let* ((matched-pos (match-beginning 0))
+                       (quoted-delim-p (if (match-beginning 6) nil t))
+                       (delim-capture (if quoted-delim-p 5 6)))
+                  (when (cperl-is-here-doc-p matched-pos)
+                    (let ((here-doc-results
+                           (cperl-process-here-doc
+                            min max end overshoot stop-point ; for recursion
+                            end-of-here-doc err-l            ; for recursion
+                            (equal (match-string 2) "~")     ; indented here-doc?
+                            matched-pos                      ; for recovery (?)
+                            (match-end 3)                    ; todo from here
+                            (match-beginning delim-capture)  ; starting delimiter
+                            (match-end delim-capture))))     ;   boundaries
+                      (setq tmpend (nth 0 here-doc-results)
+                            overshoot (nth 1 here-doc-results))
+                      (and (nth 2 here-doc-results)
+                           (setq warning-message (nth 2 here-doc-results)))))))
 	       ;; format
 	       ((match-beginning 8)
 		;; 1+6=7 extra () before this:
@@ -5458,6 +5551,18 @@ comment, or POD."
   (or cperl-faces-init (cperl-init-faces))
   cperl-font-lock-keywords-2)
 
+(defun cperl-font-lock-syntactic-face-function (state)
+  "Apply faces according to their syntax type.  In CPerl mode, this
+is used for here-documents which have been marked as c-style
+comments.  For everything else, delegate to the default
+function."
+  (cond
+   ;; A c-style comment is a HERE-document.  Fontify if requested.
+   ((and (eq 2 (nth 7 state))
+         cperl-pod-here-fontify)
+    cperl-here-face)
+   (t (funcall (default-value 'font-lock-syntactic-face-function) state))))
+
 (defun cperl-init-faces ()
   (condition-case errs
       (progn
diff --git a/test/lisp/progmodes/cperl-mode-tests.el b/test/lisp/progmodes/cperl-mode-tests.el
index 4d2bac6ee47..bcef885a77c 100644
--- a/test/lisp/progmodes/cperl-mode-tests.el
+++ b/test/lisp/progmodes/cperl-mode-tests.el
@@ -154,6 +154,97 @@ point in the distant past, and is still broken in perl-mode. "
     (should (equal (get-text-property (match-beginning 0) 'face)
                    'font-lock-keyword-face))))
 
+(ert-deftest cperl-test-identify-heredoc ()
+  "Test whether a construct containing \"<<\" followed by a
+  bareword is properly identified for a here-document if
+  appropriate."
+  (skip-unless (eq cperl-test-mode #'cperl-mode))
+  (let ((here-docs
+         '("$text .= <<DELIM;"          ; mutator concatenating a here-doc
+           "func($arg) . <<DELIM;"      ; concatenating a return value
+           "func 1, <<DELIM;"           ; a function taking two arguments
+           "print {a} <<DELIM;"         ; printing to a file handle
+           "system $prog <<DELIM;"      ; lie about the program's name
+           )
+         )
+        (undecidable
+         '("foo <<bar")                 ; could be either "foo() <<bar"
+                                        ; or "foo(<<bar)"
+         )
+        )
+    (dolist (code here-docs)
+      (with-temp-buffer
+        (insert code)
+        (funcall cperl-test-mode)
+        (goto-char (point-min))
+        (search-forward "<<DELIM")
+        ;; point is now after delimiter, as in `cperl-find-pods-heres'
+        (should (cperl-is-here-doc-p (match-beginning 0)))
+        )
+      )
+    )
+  )
+
+(ert-deftest cperl-test-identify-no-heredoc ()
+  "Test whether a construct containing \"<<\" which is not a
+  here-document is properly rejected."
+  (skip-unless (eq cperl-test-mode #'cperl-mode))
+  (let (
+        (not-here-docs
+         '("while (<<>>) { ...; }"      ; double angle bracket operator
+           "expr <<func();"             ; left shift by a return value
+           "$var <<func;"               ; left shift by a return value
+           "($var+1) <<func;"           ; same for an expression
+           "$hash{key} <<func;"         ; same for a hash element
+           "or $var <<func;"            ; same for an expression
+           "sorted $by <<func"          ; _not_ a call to sort
+           )
+         )
+        (undecidable
+         '("foo <<bar"                  ; could be either "foo() <<bar"
+                                        ; or "foo(<<bar)"
+           "$foo = <<;")                ; empty delim forbidden since 5.28
+         )
+        )
+    (dolist (code not-here-docs)
+      (with-temp-buffer
+        (insert code)
+        (funcall cperl-test-mode)
+        (goto-char (point-min))
+        (re-search-forward "<<\\(func\\)?")
+        ;; point is now after delimiter, as in `cperl-find-pods-heres'
+        (should-not (cperl-is-here-doc-p (match-beginning 0)))
+        )
+      )
+    )
+  )
+
+(ert-deftest cperl-test-here-doc-missing-end ()
+  "Verify that a missing here-document terminator gives a message.
+This message prints the terminator which wasn't found and is only
+issued by CPerl mode."
+  (skip-unless (eq cperl-test-mode #'cperl-mode))
+  (ert-with-message-capture collected-messages
+    (with-temp-buffer
+      (insert "my $foo = <<HERE\n")
+      (insert "some text here\n")
+      (goto-char (point-min))
+      (funcall cperl-test-mode)
+      (cperl-find-pods-heres)
+      (should (string-match "End of here-document [‘']HERE[’']"
+                            collected-messages))))
+  (ert-with-message-capture collected-messages
+    (with-temp-buffer
+      (insert "my $foo = <<HERE . <<'THERE'\n")
+      (insert "some text here\n")
+      (insert "HERE\n")
+      (insert "more text here\n")
+      (goto-char (point-min))
+      (funcall cperl-test-mode)
+      (cperl-find-pods-heres)
+      (should (string-match "End of here-document [‘']THERE[’']"
+                            collected-messages)))))
+
 (defvar perl-continued-statement-offset)
 (defvar perl-indent-level)
 
@@ -339,6 +430,30 @@ under timeout control."
       (should (string-match
                "poop ('foo', \n      'bar')" (buffer-string))))))
 
+(ert-deftest cperl-test-bug-14343 ()
+  "Verify that inserting text into a HERE-doc string with Elisp
+does not break fontification."
+  (skip-unless (eq cperl-test-mode #'cperl-mode))
+  (with-temp-buffer
+    (insert "my $string = <<HERE;\n")
+    (insert "One line of text.\n")
+    (insert "Last line of this string.\n")
+    (insert "HERE\n")
+    (funcall cperl-test-mode)
+    (font-lock-ensure)
+    (goto-char (point-min))
+    (search-forward "One line")
+    (should (equal (get-text-property (point) 'face)
+                   'font-lock-string-face))
+    (beginning-of-line)
+    (insert "Another line if text.\n")
+    (font-lock-ensure)
+    (forward-line -1)
+    (should (equal (get-text-property (point) 'face)
+                   'font-lock-string-face))
+    ))
+
+
 (ert-deftest cperl-test-bug-16368 ()
   "Verify that `cperl-forward-group-in-re' doesn't hide errors."
   (skip-unless (eq cperl-test-mode #'cperl-mode))