+(defvar perl-quote-like-pairs
+ '((?\( . ?\)) (?\[ . ?\]) (?\{ . ?\}) (?\< . ?\>)))
+
+;; 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>
+(defvar perl-font-lock-syntactic-keywords
+ ;; Turn POD into b-style comments
+ '(("^\\(=\\)\\sw" (1 "< b"))
+ ("^=cut[ \t]*\\(\n\\)" (1 "> b"))
+ ;; Catch ${ so that ${var} doesn't screw up indentation.
+ ;; This also catches $' to handle 'foo$', although it should really
+ ;; check that it occurs inside a '..' string.
+ ("\\(\\$\\)[{']" (1 ". p"))
+ ;; Handle funny names like $DB'stop.
+ ("\\$ ?{?^?[_a-zA-Z][_a-zA-Z0-9]*\\('\\)[_a-zA-Z]" (1 "_"))
+ ;; format statements
+ ("^[ \t]*format.*=[ \t]*\\(\n\\)" (1 '(7)))
+ ;; Funny things in sub arg specifications like `sub myfunc ($$)'
+ ("\\<sub\\s-+\\S-+\\s-*(\\([^)]+\\))" 1 '(1))
+ ;; regexp and funny quotes
+ ("[?:.,;=!~({[][ \t\n]*\\(/\\)" (1 '(7)))
+ ("[?:.,;=!~({[ \t\n]\\([msy]\\|q[qxrw]?\\|tr\\)\\>\\s-*\\([^])}> \n\t]\\)"
+ ;; Nasty cases:
+ ;; /foo/m $a->m $#m $m @m %m
+ ;; \s (appears often in regexps).
+ ;; -s file
+ (2 (if (assoc (char-after (match-beginning 2))
+ perl-quote-like-pairs)
+ '(15) '(7))))
+ ;; TODO: here-documents ("<<\\(\\sw\\|['\"]\\)")
+ ))
+
+(defvar perl-empty-syntax-table
+ (let ((st (copy-syntax-table)))
+ ;; Make all chars be of punctuation syntax.
+ (dotimes (i 256) (aset st i '(1)))
+ (modify-syntax-entry ?\\ "\\" st)
+ st)
+ "Syntax table used internally for processing quote-like operators.")
+
+(defun perl-quote-syntax-table (char)
+ (let ((close (cdr (assq char perl-quote-like-pairs)))
+ (st (copy-syntax-table perl-empty-syntax-table)))
+ (if (not close)
+ (modify-syntax-entry char "\"" st)
+ (modify-syntax-entry char "(" st)
+ (modify-syntax-entry close ")" st))
+ st))
+
+(defun perl-font-lock-syntactic-face-function (state)
+ (let ((char (nth 3 state)))
+ (cond
+ ((not char)
+ ;; Comment or docstring.
+ (if (nth 7 state) font-lock-doc-face font-lock-comment-face))
+ ((and (char-valid-p char) (eq (char-syntax (nth 3 state)) ?\"))
+ ;; Normal string.
+ font-lock-string-face)
+ ((eq (nth 3 state) ?\n)
+ ;; A `format' command.
+ (save-excursion
+ (when (and (re-search-forward "^\\s *\\.\\s *$" nil t)
+ (not (eobp)))
+ (put-text-property (point) (1+ (point)) 'syntax-table '(7)))
+ font-lock-string-face))
+ (t
+ ;; This is regexp like quote thingy.
+ (setq char (char-after (nth 8 state)))
+ (save-excursion
+ (let ((twoargs (save-excursion
+ (goto-char (nth 8 state))
+ (skip-syntax-backward " ")
+ (skip-syntax-backward "w")
+ (member (buffer-substring
+ (point) (progn (forward-word 1) (point)))
+ '("tr" "s" "y"))))
+ (close (cdr (assq char perl-quote-like-pairs)))
+ (pos (point))
+ (st (perl-quote-syntax-table char)))
+ (if (not close)
+ ;; The closing char is the same as the opening char.
+ (with-syntax-table st
+ (parse-partial-sexp (point) (point-max)
+ nil nil state 'syntax-table)
+ (when twoargs
+ (parse-partial-sexp (point) (point-max)
+ nil nil state 'syntax-table)))
+ ;; The open/close chars are matched like () [] {} and <>.
+ (let ((parse-sexp-lookup-properties nil))
+ (ignore-errors
+ (with-syntax-table st
+ (goto-char (nth 8 state)) (forward-sexp 1))
+ (when twoargs
+ (save-excursion
+ ;; Skip whitespace and make sure that font-lock will
+ ;; refontify the second part in the proper context.
+ (put-text-property
+ (point) (progn (forward-comment (point-max)) (point))
+ 'font-lock-multiline t)
+ ;;
+ (unless
+ (save-excursion
+ (let* ((char2 (char-after))
+ (st2 (perl-quote-syntax-table char2)))
+ (with-syntax-table st2 (forward-sexp 1))
+ (put-text-property pos (line-end-position)
+ 'jit-lock-defer-multiline t)
+ (looking-at "\\s-*\\sw*e")))
+ (put-text-property (point) (1+ (point))
+ 'syntax-table
+ (if (assoc (char-after)
+ perl-quote-like-pairs)
+ '(15) '(7)))))))))
+ ;; Erase any syntactic marks within the quoted text.
+ (put-text-property pos (1- (point)) 'syntax-table nil)
+ (when (eq (char-before (1- (point))) ?$)
+ (put-text-property (- (point) 2) (1- (point))
+ 'syntax-table '(1)))
+ (put-text-property (1- (point)) (point)
+ 'syntax-table (if close '(15) '(7)))
+ font-lock-string-face))))))
+ ;; (if (or twoargs (not (looking-at "\\s-*\\sw*e")))
+ ;; font-lock-string-face
+ ;; (font-lock-fontify-syntactically-region
+ ;; ;; FIXME: `end' is accessed via dyn-scoping.
+ ;; pos (min end (1- (point))) nil '(nil))
+ ;; nil)))))))
+