master a1887cc: ; cperl-mode.el: Fix border cases of inserting with elisp

[Harald Jörg]

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

    ; cperl-mode.el: Fix border cases of inserting with elisp
    
    * lisp/progmodes/cperl-mode.el (cperl-unwind-to-safe): Replace
    (and extend) inline comment by a docstring.  Handle edge cases when
    inserting text with elisp (related to Bug#28962).
    (cperl-process-here-doc): Add syntax-type `here-doc-start'.
    (cperl-find-pods-heres): Make sure that the results of this
    function are immediately visible.
    
    * test/lisp/progmodes/cperl-mode-tests.el (cperl-test-bug-14343):
    Add test cases for "empty" here-documents and inserting at the
    edges of a here-document.
---
 lisp/progmodes/cperl-mode.el            | 37 +++++++++++++++++++--
 test/lisp/progmodes/cperl-mode-tests.el | 58 +++++++++++++++++++++++++++++----
 2 files changed, 87 insertions(+), 8 deletions(-)

diff --git a/lisp/progmodes/cperl-mode.el b/lisp/progmodes/cperl-mode.el
index 727deab..f518501 100644
--- a/lisp/progmodes/cperl-mode.el
+++ b/lisp/progmodes/cperl-mode.el
@@ -3338,8 +3338,10 @@ Works before syntax recognition is done."
 ;;             Each non-literal part is marked `syntax-type' ==> `pod'
 ;;             Each literal part is marked `syntax-type' ==> `in-pod'
 ;;     b) HEREs:
+;;              The point before start is marked `here-doc-start'
 ;;             Start-to-end is marked `here-doc-group' ==> t
 ;;             The body is marked `syntax-type' ==> `here-doc'
+;;                and is also marked as style 2 comment
 ;;             The delimiter is marked `syntax-type' ==> `here-doc-delim'
 ;;     c) FORMATs:
 ;;             First line (to =) marked `first-format-line' ==> t
@@ -3356,8 +3358,36 @@ Works before syntax recognition is done."
 ;; (value: 0 in //o, 1 if "interpolated variable" is whole-REx, t otherwise).
 
 (defun cperl-unwind-to-safe (before &optional end)
-  ;; if BEFORE, go to the previous start-of-line on each step of unwinding
-  (let ((pos (point)))
+  "Move point back to a safe place, back up one extra line if BEFORE.
+A place is \"safe\" if it is not within POD, a here-document, a
+format, a quote-like expression, a subroutine attribute list or a
+multiline declaration.  These places all have special syntactical
+rules and need to be parsed as a whole.  If END, return the
+position of the end of the unsafe construct."
+  (let ((pos (point))
+        (state (syntax-ppss)))
+    ;; Check edge cases for here-documents first
+    (when before                        ; we need a safe start for parsing
+      (cond
+       ((or (equal (get-text-property (cperl-1- (point)) 'syntax-type)
+                   'here-doc-start)
+            (equal (syntax-after (cperl-1- (point)))
+                   (string-to-syntax "> c")))
+        ;; point is either immediately after the start of a here-doc
+        ;; (which may consist of nothing but one newline) or
+        ;; immediately after the now-outdated end marker of the
+        ;; here-doc. In both cases we need to back up to the line
+        ;; where the here-doc delimiters are defined.
+        (forward-char -1)
+        (cperl-backward-to-noncomment (point-min))
+        (beginning-of-line))
+       ((eq 2 (nth 7 state))
+        ;; point is somewhere in a here-document.  Back up to the line
+        ;; where the here-doc delimiters are defined.
+        (goto-char (nth 8 state))      ; beginning of this here-doc
+        (cperl-backward-to-noncomment  ; skip back over more
+         (point-min))                  ;     here-documents (if any)
+        (beginning-of-line))))         ; skip back over here-doc starters
     (while (and pos (progn
                      (beginning-of-line)
                      (get-text-property (setq pos (point)) 'syntax-type)))
@@ -3657,6 +3687,8 @@ This is part of `cperl-find-pods-heres' (below)."
     ;; 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)
+    (put-text-property (1- here-doc-start) here-doc-start
+                       'syntax-type 'here-doc-start)
     (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"))
@@ -3698,6 +3730,7 @@ recursive calls in starting lines of here-documents."
                cperl-syntax-state nil
                cperl-syntax-done-to min))
   (or max (setq max (point-max)))
+  (font-lock-flush min max)
   (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
diff --git a/test/lisp/progmodes/cperl-mode-tests.el 
b/test/lisp/progmodes/cperl-mode-tests.el
index c03eb52..5f3ba4d 100644
--- a/test/lisp/progmodes/cperl-mode-tests.el
+++ b/test/lisp/progmodes/cperl-mode-tests.el
@@ -245,6 +245,9 @@ issued by CPerl mode."
 (defconst cperl--tests-heredoc-face
   (if (equal cperl-test-mode 'perl-mode) 'perl-heredoc
     'font-lock-string-face))
+(defconst cperl--tests-heredoc-delim-face
+  (if (equal cperl-test-mode 'perl-mode) 'perl-heredoc
+    'font-lock-constant-face))
 
 (ert-deftest cperl-test-heredocs ()
   "Test that HERE-docs are fontified with the appropriate face."
@@ -430,10 +433,10 @@ under timeout control."
   "Verify that inserting text into a HERE-doc string with Elisp
 does not break fontification."
   (with-temp-buffer
-    (insert "my $string = <<HERE;\n")
-    (insert "One line of text.\n")
-    (insert "Last line of this string.\n")
-    (insert "HERE\n")
+    (insert "my $string = <<HERE;\n"
+            "One line of text.\n"
+            "Last line of this string.\n"
+            "HERE\n")
     (funcall cperl-test-mode)
     (font-lock-ensure)
     (goto-char (point-min))
@@ -446,8 +449,51 @@ does not break fontification."
     (forward-line -1)
     (should (equal (get-text-property (point) 'face)
                    cperl--tests-heredoc-face))
-    ))
-
+    (search-forward "HERE")
+    (beginning-of-line)
+    (should (equal (get-text-property (point) 'face)
+                   cperl--tests-heredoc-delim-face)))
+  ;; insert into an empty here-document
+  (with-temp-buffer
+    (insert "print <<HERE;\n"
+            "HERE\n")
+    (funcall cperl-test-mode)
+    (font-lock-ensure)
+    (goto-char (point-min))
+    (forward-line)
+    (should (equal (get-text-property (point) 'face)
+                   cperl--tests-heredoc-delim-face))
+    ;; Insert a newline into the empty here-document
+    (goto-char (point-min))
+    (forward-line)
+    (insert "\n")
+    (search-forward "HERE")
+    (beginning-of-line)
+    (should (equal (get-text-property (point) 'face)
+                   cperl--tests-heredoc-delim-face))
+    ;; Insert text at the beginning of the here-doc
+    (goto-char (point-min))
+    (forward-line)
+    (insert "text")
+    (font-lock-ensure)
+    (search-backward "text")
+    (should (equal (get-text-property (point) 'face)
+                   cperl--tests-heredoc-face))
+    (search-forward "HERE")
+    (beginning-of-line)
+    (should (equal (get-text-property (point) 'face)
+                   cperl--tests-heredoc-delim-face))
+    ;; Insert a new line immediately before the delimiter
+    ;; (That's where the point is anyway)
+    (insert "A new line\n")
+    (font-lock-ensure)
+    ;; The delimiter is still the delimiter
+    (should (equal (get-text-property (point) 'face)
+                   cperl--tests-heredoc-delim-face))
+    (forward-line -1)
+    ;; The new line has been "added" to the here-document
+    (should (equal (get-text-property (point) 'face)
+                   cperl--tests-heredoc-face))))
 
 (ert-deftest cperl-test-bug-16368 ()
   "Verify that `cperl-forward-group-in-re' doesn't hide errors."