From 3d847fa9fd68592c50ea5e18c86b9f3eb5030654 Mon Sep 17 00:00:00 2001
From: Stefan Monnier <monnier@iro.umontreal.ca>
Date: Mon, 24 Jul 2017 18:10:02 -0400
Subject: [PATCH] * lisp/progmodes/perl-mode.el: Add support for indented here
 docs

* lisp/progmodes/perl-mode.el (perl-syntax-propertize-function):
Recognize the new <<~ syntax for indented here docs.
(perl-syntax-propertize-special-constructs): Adjust search of the
end of here docs accordingly.

* test/manual/indent/perl.perl: Add test for indented here docs.
---
 lisp/progmodes/perl-mode.el  | 43 ++++++++++++------------------------
 test/manual/indent/perl.perl |  8 +++++++
 2 files changed, 22 insertions(+), 29 deletions(-)

diff --git a/lisp/progmodes/perl-mode.el b/lisp/progmodes/perl-mode.el
index 3def37a2ea8..6197a53ee66 100644
--- a/lisp/progmodes/perl-mode.el
+++ b/lisp/progmodes/perl-mode.el
@@ -213,25 +213,6 @@
             (regexp-opt perl--syntax-exp-intro-keywords)
             "\\|[-?:.,;|&+*=!~({[]\\|\\(^\\)\\)[ \t\n]*")))
 
-;; FIXME: handle here-docs and regexps.
-;; <<EOF <<"EOF" <<'EOF' (no space)
-;; see `man perlop'
-;; ?...?
-;; /.../
-;; m [...]
-;; m /.../
-;; q /.../ = '...'
-;; qq /.../ = "..."
-;; qx /.../ = `...`
-;; qr /.../ = precompiled regexp =~=~ m/.../
-;; qw /.../
-;; s /.../.../
-;; s <...> /.../
-;; s '...'...'
-;; tr /.../.../
-;; y /.../.../
-;;
-;; <file*glob>
 (defun perl-syntax-propertize-function (start end)
   (let ((case-fold-search nil))
     (goto-char start)
@@ -324,23 +305,25 @@
       ((concat
         "\\(?:"
         ;; << "EOF", << 'EOF', or << \EOF
-        "<<[ \t]*\\('[^'\n]*'\\|\"[^\"\n]*\"\\|\\\\[[:alpha:]][[:alnum:]]*\\)"
+        "<<\\(~\\)?[ \t]*\\('[^'\n]*'\\|\"[^\"\n]*\"\\|\\\\[[:alpha:]][[:alnum:]]*\\)"
         ;; The <<EOF case which needs perl--syntax-exp-intro-regexp, to
         ;; disambiguate with the left-bitshift operator.
-        "\\|" perl--syntax-exp-intro-regexp "<<\\(?1:\\sw+\\)\\)"
+        "\\|" perl--syntax-exp-intro-regexp "<<\\(?2:\\sw+\\)\\)"
         ".*\\(\n\\)")
-       (3 (let* ((st (get-text-property (match-beginning 3) 'syntax-table))
-                 (name (match-string 1)))
-            (goto-char (match-end 1))
+       (4 (let* ((st (get-text-property (match-beginning 4) '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))))
                 ;; Leave the property of the newline unchanged.
                 st
               (cons (car (string-to-syntax "< c"))
                     ;; Remember the names of heredocs found on this line.
-                    (cons (pcase (aref name 0)
-                            (`?\\ (substring name 1))
-                            ((or `?\" `?\' `?\`) (substring name 1 -1))
-                            (_ name))
+                    (cons (cons (pcase (aref name 0)
+                                  (`?\\ (substring name 1))
+                                  ((or `?\" `?\' `?\`) (substring name 1 -1))
+                                  (_ name))
+                                indented)
                           (cdr st)))))))
       ;; We don't call perl-syntax-propertize-special-constructs directly
       ;; from the << rule, because there might be other elements (between
@@ -383,7 +366,9 @@
           (goto-char (nth 8 state)))
         (while (and names
                     (re-search-forward
-                     (concat "^" (regexp-quote (pop names)) "\n")
+                     (pcase-let ((`(,name . ,indented) (pop names)))
+                       (concat "^" (if indented "[ \t]*")
+                               (regexp-quote name) "\n"))
                      limit 'move))
           (unless names
             (put-text-property (1- (point)) (point) 'syntax-table
diff --git a/test/manual/indent/perl.perl b/test/manual/indent/perl.perl
index f86a09b2733..06f32e7f090 100755
--- a/test/manual/indent/perl.perl
+++ b/test/manual/indent/perl.perl
@@ -53,6 +53,14 @@ EOF1
 bar
 EOF2
 
+print <<~"EOF1" . <<\EOF2 . s/he"llo/th'ere/;
+foo
+EOF2
+   bar
+   EOF1
+bar
+EOF2
+
 print $'; # This should not start a string!
 
 print "hello" for /./;
-- 
2.39.5