From: Harald Jörg Date: Fri, 30 Jun 2023 21:41:06 +0000 (+0200) Subject: cperl-mode.el: Support subroutine signatures X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=a7ff8a76a52d316b27f05cd1267fe94cea9f35d1;p=emacs.git cperl-mode.el: Support subroutine signatures Since Perl 5.20, subroutine signatures were available as an experimental feature. With Perl 5.38, they will be always enabled in the new object system. * test/lisp/progmodes/cperl-mode-resources/cperl-bug-64190.pl: * test/lisp/progmodes/cperl-mode-resources/cperl-bug-64364.pl: New test resources. * test/lisp/progmodes/cperl-mode-tests.el (cperl-test-fontify-attrs-and-signatures): Add tests for signatures. (cperl-test-attribute-rx, cperl-test-attribute-list-rx) (cperl-test-prototype-rx, cperl-test-signature-rx): Tests for the new rx sequences. (cperl-test-bug-64190): New test for multiline declarations. (cperl-test-bug-64364): New test for indentation of declarations. * lisp/progmodes/cperl-mode.el: (toplevel): New rx sequences to match Perl variables and attributes. (cperl-declaration-header-p): New function to identify declarations. (cperl-block-declaration-p): Use the new function. (cperl-mode): Use the rx sequences. (cperl-get-state): Use the new function. (cperl-sniff-for-indent): Use the new function. (cperl-find-sub-attrs): Improve fontification of subroutine prototypes and attributes while typing when jit-lock-mode is active. Detect signatures, and distinguish them from prototypes. (cperl-find-pods-heres): Use the rx sequences to detect subroutines. (cperl-init-faces): Use the rx sequences for fontification. --- diff --git a/lisp/progmodes/cperl-mode.el b/lisp/progmodes/cperl-mode.el index 66f01109e3f..fb636d0fb78 100644 --- a/lisp/progmodes/cperl-mode.el +++ b/lisp/progmodes/cperl-mode.el @@ -1187,8 +1187,7 @@ The expansion is entirely correct because it uses the C preprocessor." "A regular expression for the name of a \"basic\" Perl variable. Neither namespace separators nor sigils are included. As is, this regular expression applies to labels,subroutine calls where -the ampersand sigil is not required, and names of subroutine -attributes.") +the ampersand sigil is not required, and names of attributes.") (defconst cperl--label-rx `(sequence symbol-start @@ -1225,6 +1224,30 @@ is a legal variable name).") (in "!\"$%&'()+,-./:;<=>?@\\]^_`|~")) ; $., $|, $", ... but not $^ or ${ "The list of Perl \"punctuation\" variables, as listed in perlvar.") + (defconst cperl--basic-scalar-rx + `(sequence "$" ,cperl--basic-identifier-rx) + "Regular expression for a scalar (without package). +This regexp intentionally does not support spaces (nor newlines +and comments) between the sigil and the identifier, for +educational reasons. So \"$foo\" will be matched, but \"$ foo\" +or \"${ foo }\" will not.") + + (defconst cperl--basic-array-rx + `(sequence "@" ,cperl--basic-identifier-rx) + "Regular expression for an array variable (without package). +This regexp intentionally does not support spaces (nor newlines +and comments) between the sigil and the identifier, for +educational reasons. So \"@foo\" will be matched, but \"@ foo\" +or \"@{ foo }\" will not.") + + (defconst cperl--basic-hash-rx + `(sequence "%" ,cperl--basic-identifier-rx) + "Regular expression for a hash variable (without package). +This regexp intentionally does not support spaces (nor newlines +and comments) between the sigil and the identifier, for +educational reasons. So \"%foo\" will be matched, but \"% foo\" +or \"%{ foo }\" will not.") + (defconst cperl--ws-rx '(sequence (or space "\n")) "Regular expression for a single whitespace in Perl.") @@ -1246,6 +1269,27 @@ is a legal variable name).") `(1+ ,cperl--ws-or-comment-rx) "Regular expression for a sequence of whitespace and comments in Perl.") + (defconst cperl--basic-variable-rx + `(sequence (in "$@%") ,cperl--basic-identifier-rx) + "Regular expression for a Perl variable (scalar, array or hash). +This regexp intentionally does not support spaces (nor newlines +and comments) between the sigil and the identifier, for +educational reasons. So \"$foo\" will be matched, but \"$ foo\" +or \"${ foo }\" will not.") + + (defconst cperl--variable-list-rx + `(sequence "(" + (optional (sequence + ,cperl--ws*-rx + ,cperl--basic-variable-rx + (0+ (sequence + ,cperl--ws*-rx + "," + ,cperl--ws*-rx + ,cperl--basic-variable-rx)) + ,cperl--ws*-rx))) + "Regular expression for a list of Perl variables for declarations.") + ;; This is left as a string regexp. There are many version schemes in ;; the wild, so people might want to fiddle with this variable. (defconst cperl--version-regexp @@ -1260,6 +1304,54 @@ is a legal variable name).") (optional (sequence "_" (1+ word)))))) "A sequence for recommended version number schemes in Perl.") + (defconst cperl--single-attribute-rx + `(sequence ,cperl--basic-identifier-rx + (optional (sequence "(" + (0+ (not (in ")"))) + ")"))) + "A regular expression for a single attribute, without leading colon. +It may have parameters in parens, but parens within the +parameter's value are not supported.. This regexp does not have +capture groups.") + + (defconst cperl--attribute-list-rx + `(sequence ":" + (0+ (sequence + ,cperl--ws*-rx + ,cperl--single-attribute-rx + ,cperl--ws*-rx + (optional ":")))) + "A regular expression for an attribute list. +Attribute lists may only occur in certain declarations. A colon +is required before the first attribute but optional between +subsequent attributes. This regexp does not have capture groups.") + + (defconst cperl--prototype-rx + `(sequence "(" + (0+ (any "$@%&*;\\[]")) + ")") + "A regular expression for a subroutine prototype. Not as strict as the actual prototype syntax, but good enough to distinguish prototypes from signatures.") + + (defconst cperl--signature-rx + `(sequence "(" + (optional + (sequence + (0+ (sequence ,cperl--ws*-rx + ,cperl--basic-scalar-rx + ,cperl--ws*-rx + ",")) + ,cperl--ws*-rx + (or ,cperl--basic-scalar-rx + ,cperl--basic-array-rx + ,cperl--basic-hash-rx))) + (optional (sequence ,cperl--ws*-rx) "," ) + ,cperl--ws*-rx + ")") + "A regular expression for a subroutine signature. +These are a bit more restricted than \"my\" declaration lists +because they allow only one slurpy variable, and only in the last +place.") + (defconst cperl--package-rx `(sequence (group "package") ,cperl--ws+-rx @@ -1327,6 +1419,15 @@ Covers packages, subroutines, and POD headings.") ) +(defun cperl-declaration-header-p (pos) + "Return t if POS is in the header of a declaration. +Perl syntax can have various constructs between a +keyword (e.g. \"sub\") and its associated block of code, and +these can span several lines. These blocks are identified and +marked with a text-property in `cperl-find-pods-heres'. This +function tests that property." + (equal (get-text-property pos 'syntax-type) 'sub-decl)) + (defun cperl-block-declaration-p () "Test whether the following ?\\{ opens a declaration block. Returns the column where the declarating keyword is found, or nil @@ -1345,6 +1446,9 @@ statement, so there's no semicolon." ((looking-at (rx (eval cperl--block-declaration-rx))) (setq is-block-declaration (current-column) continue-searching nil)) + ((cperl-declaration-header-p (point)) + (setq is-block-declaration (current-column) + continue-searching nil)) ;; Another brace means this is no block declaration ((looking-at "{") (setq continue-searching nil)) @@ -1710,6 +1814,8 @@ or as help on variables `cperl-tips', `cperl-problems', (concat "^[ \t]*\\(" cperl-sub-regexp (cperl-after-sub-regexp 'named 'attr-groups) + (rx (eval cperl--ws*-rx)) + (rx (optional (eval cperl--signature-rx))) "\\|" ; per toke.c "\\(BEGIN\\|UNITCHECK\\|CHECK\\|INIT\\|END\\|AUTOLOAD\\|DESTROY\\)" "\\)" @@ -2553,6 +2659,9 @@ PRESTART is the position basing on which START was found." (<= parse-start start-point)) (goto-char parse-start) (beginning-of-defun) + (when (cperl-declaration-header-p (point)) + (goto-char (cperl-beginning-of-property (point) 'syntax-type)) + (beginning-of-line)) (setq start-state nil)) (setq prestart (point)) (if start-state nil @@ -2759,12 +2868,15 @@ Will not look before LIM." (if (not (or (eq (1- (point)) containing-sexp) (and cperl-indent-parens-as-block (not is-block)) - (save-excursion (cperl-block-declaration-p)) + (and (looking-at "{") + (save-excursion (cperl-block-declaration-p))) (memq (preceding-char) (append (if is-block " ;{" " ,;{") '(nil))) (and (eq (preceding-char) ?\}) (cperl-after-block-and-statement-beg containing-sexp)) + (and (cperl-declaration-header-p indent-point) + (not (cperl-declaration-header-p char-after-pos))) (get-text-property (point) 'first-format-line))) ;; This line is continuation of preceding line's statement; ;; indent `cperl-continued-statement-offset' more than the @@ -2843,12 +2955,11 @@ Will not look before LIM." ;; anonymous sub in a hash. (if (and;; Is it a sub in group starting on this line? cperl-indent-subs-specially - (cond ((get-text-property (point) 'attrib-group) - (goto-char (cperl-beginning-of-property - (point) 'attrib-group))) - ((eq (preceding-char) ?b) - (forward-sexp -1) - (looking-at (concat cperl-sub-regexp "\\>")))) + (cond + ((cperl-declaration-header-p (point)) + (goto-char + (cperl-beginning-of-property (point) + 'syntax-type)))) (setq p (nth 1 ; start of innermost containing list (parse-partial-sexp (line-beginning-position) @@ -2992,6 +3103,9 @@ and closing parentheses and brackets." (goto-char (elt i 1)) ; statement-start (+ (if (or (memq (elt i 2) (append "}])" nil)) ; char-after (eq 'continuation ; do not stagger continuations + ;; FIXME: This clobbers the syntax state in parse-data + ;; for the *following* lines and makes the state + ;; useless for indent-region -- haj 2023-06-30 (elt (cperl-sniff-for-indent parse-data) 0))) 0 ; Closing parenthesis or continuation of a continuation cperl-continued-statement-offset) @@ -3467,22 +3581,37 @@ Should be called with the point before leading colon of an attribute." "L%d: attribute `%s': %s" (count-lines (point-min) (point)) (and start1 end1 (buffer-substring start1 end1)) b) - (setq start nil))) - (and start - (progn - (put-text-property start (point) - 'attrib-group (if (looking-at "{") t 0)) - (and pos - (< 1 (count-lines (+ 3 pos) (point))) ; end of `sub' - ;; Apparently, we do not need `multiline': faces added now - (put-text-property (+ 3 pos) (cperl-1+ (point)) - 'syntax-type 'sub-decl)) - (and b-fname ; Fontify here: the following condition - (cperl-postpone-fontification ; is too hard to determine by - b-fname e-fname 'face ; a REx, so do it here - (if (looking-at "{") - font-lock-function-name-face - font-lock-variable-name-face))))) + ; (setq start nil) I'd like to keep trying -- haj 2023-06-26 + )) + (cond + ;; Allow for a complete signature and trailing spaces here + ((search-forward-regexp (rx (sequence point + (eval cperl--ws*-rx) + (eval cperl--signature-rx) + (eval cperl--ws*-rx))) + nil + t)) ; NOERROR + ((looking-at (rx "(")) + ;; We might be in the process of typing a prototype or + ;; signature. These start with a left paren, so we want this to + ;; be included into the area marked as sub-decl. + nil) + ;; Else, we are in no mans land. Just keep trying. + (t + )) + (when (looking-at (rx (in ";{"))) + ;; A semicolon ends the declaration, an opening brace begins the + ;; BLOCK. Neither is part of the declaration. + (backward-char)) + (when start + (put-text-property start (point) + 'attrib-group (if (looking-at "{") t 0)) + (and pos + (progn + (< 1 (count-lines (+ 3 pos) (point))) ; end of `sub' + ;; Apparently, we do not need `multiline': faces added now + (put-text-property (+ 3 pos) (cperl-1+ (point)) + 'syntax-type 'sub-decl)))) ;; now restore the initial state (if st (progn @@ -3773,8 +3902,10 @@ recursive calls in starting lines of here-documents." max)) (search (concat - "\\(\\`\n?\\|^\n\\)=" ; POD + ;; -------- POD using capture group 1 + "\\(\\`\n?\\|^\n\\)=" "\\|" + ;; -------- HERE-document capture groups 2-7 ;; One extra () before this: "<<\\(~?\\)" ; HERE-DOC, indented-p = capture 2 "\\(" ; 2 + 1 @@ -3790,38 +3921,49 @@ recursive calls in starting lines of here-documents." ;; "\\([^= \t0-9$@%&]\\|[ \t]+[^ \t\n0-9$@%&]\\)" ; 6 + 1 "\\)" "\\|" + ;; -------- format capture groups 8-9 ;; 1+6 extra () before this: - "^[ \t]*\\(format\\)[ \t]*\\([a-zA-Z0-9_]+\\)?[ \t]*=[ \t]*$" ;FRMAT + "^[ \t]*\\(format\\)[ \t]*\\([a-zA-Z0-9_]+\\)?[ \t]*=[ \t]*$" (if cperl-use-syntax-table-text-property (concat "\\|" + ;; -------- quoted constructs and regexps, group 10 ;; 1+6+2=9 extra () before this: - "\\<\\(q[wxqr]?\\|[msy]\\|tr\\)\\>" ; QUOTED CONSTRUCT + "\\<\\(q[wxqr]?\\|[msy]\\|tr\\)\\>" "\\|" + ;; -------- "bare" regex or glob, group 11 ;; 1+6+2+1=10 extra () before this: "\\([/<]\\)" ; /blah/ or "\\|" + ;; -------- subroutine declarations, groups 12-17 ;; 1+6+2+1+1=11 extra () before this - "\\<" cperl-sub-regexp "\\>" ; sub with proto/attr - "\\(" - cperl-white-and-comment-rex - (rx (opt (group (eval cperl--normal-identifier-rx)))) - "\\)" - "\\(" - cperl-maybe-white-and-comment-rex - "\\(([^()]*)\\|:[^:]\\)\\)" ; prototype or attribute start + (rx (sequence + word-start + (group (regexp cperl-sub-regexp)) ; #12 + (eval cperl--ws+-rx) + (opt (group (eval cperl--normal-identifier-rx))) ; #13 + (eval cperl--ws*-rx) + (group (or (group (eval cperl--prototype-rx)) ; #14,#15 + ;; (group (eval cperl--signature-rx)) ; #16 + (group unmatchable) ; #16 + (group (or anything buffer-end)))))) ; #17 "\\|" - ;; 1+6+2+1+1+6=17 extra () before this: + ;; -------- weird variables, capture group 18 + ;; FIXME: We don't need that group -- haj 2023-06-21 + ;; 1+6+2+1+1+6=17 extra () before this "\\$\\(['{]\\)" ; $' or ${foo} "\\|" + ;; -------- old-style ' as package separator, group 19 ;; 1+6+2+1+1+6+1=18 extra () before this (old pack'var syntax; ;; we do not support intervening comments...): "\\(\\<" cperl-sub-regexp "[ \t\n\f]+\\|[&*$@%]\\)[a-zA-Z0-9_]*'" - ;; 1+6+2+1+1+6+1+1=19 extra () before this: "\\|" + ;; -------- __END__ and __DATA__ tokens, group 20 + ;; 1+6+2+1+1+6+1+1=19 extra () before this: "__\\(END\\|DATA\\)__" ; __END__ or __DATA__ ;; 1+6+2+1+1+6+1+1+1=20 extra () before this: "\\|" + ;; -------- backslash-escaped stuff, don't interpret it "\\\\\\(['`\"($]\\)") ; BACKWACKED something-hairy ""))) warning-message) @@ -4691,28 +4833,28 @@ recursive calls in starting lines of here-documents." 'REx-part2 t))))) (if (> (point) max) (setq tmpend tb)))) - ((match-beginning 17) ; sub with prototype or attribute + ((match-beginning 14) ; sub with prototype or attribute ;; 1+6+2+1+1=11 extra () before this (sub with proto/attr): - ;;"\\\\(" ;12 - ;; cperl-white-and-comment-rex ;13 - ;; "\\([a-zA-Z_:'0-9]+\\)\\)?" ; name ;14 - ;;"\\(" cperl-maybe-white-and-comment-rex ;15,16 - ;; "\\(([^()]*)\\|:[^:]\\)\\)" ; 17:proto or attribute start - (setq b1 (match-beginning 14) e1 (match-end 14)) + ;; match-string 12: Keyword "sub" + ;; match-string 13: Name of the subroutine (optional) + ;; match-string 14: Indicator for proto/attr/signature + ;; match-string 15: Prototype + ;; match-string 16: unused + ;; match-string 17: Distinguish declaration/definition + (setq b1 (match-beginning 13) e1 (match-end 13)) (if (memq (char-after (1- b)) '(?\$ ?\@ ?\% ?\& ?\*)) - nil + nil ;; we found $sub or @sub etc (goto-char b) - (if (eq (char-after (match-beginning 17)) ?\( ) + (if (match-beginning 15) ; a complete prototype (progn (cperl-commentify ; Prototypes; mark as string - (match-beginning 17) (match-end 17) t) + (match-beginning 15) (match-end 15) t) (goto-char (match-end 0)) ;; Now look for attributes after prototype: (forward-comment (buffer-size)) - (and (looking-at ":[^:]") - (cperl-find-sub-attrs st-l b1 e1 b))) - ;; treat attributes without prototype + (cperl-find-sub-attrs st-l b1 e1 b)) + ;; treat attributes without prototype and incomplete stuff (goto-char (match-beginning 17)) (cperl-find-sub-attrs st-l b1 e1 b)))) ;; 1+6+2+1+1+6+1=18 extra () before this: @@ -5313,6 +5455,10 @@ conditional/loop constructs." (let ((comment-column new-comm-indent)) (indent-for-comment))) (progn + ;; FIXME: It would be nice to keep indent-info, but this + ;; doesn not work if the region contains continuation + ;; lines (see `cperl-calculate-indent') -- haj 2023-06-30 + (setq indent-info (list nil nil nil)) (setq i (cperl-indent-line indent-info)) (or comm (not i) @@ -5668,7 +5814,11 @@ default function." (setq t-font-lock-keywords (list + ;; -------- trailing spaces -> use invalid-face as a warning + ;; (matcher subexp facespec) `("[ \t]+$" 0 ',cperl-invalid-face t) + ;; -------- flow control + ;; (matcher . subexp) font-lock-keyword-face by default (cons (concat "\\(^\\|[^$@%&\\]\\)\\<\\(" @@ -5688,6 +5838,8 @@ default function." "\\)\\>") 2) ; was "\\)[ \n\t;():,|&]" ; In what follows we use `type' style ; for overwritable builtins + ;; -------- builtin functions + ;; (matcher subexp facespec) (list (concat "\\(^\\|[^$@%&\\]\\)\\<\\(" @@ -5730,6 +5882,10 @@ default function." 2 'font-lock-type-face) ;; In what follows we use `other' style ;; for nonoverwritable builtins + ;; This is a bit shaky because the status + ;; "nonoverwritable" can change between Perl versions. + ;; -------- "non overridable" functions + ;; (matcher subexp facespec) (list (concat "\\(^\\|[^$@%&\\]\\)\\<\\(" @@ -5750,33 +5906,69 @@ default function." ;; '("#endif" "#else" "#ifdef" "#ifndef" "#if" ;; "#include" "#define" "#undef") ;; "\\|") + ;; -------- -X file tests + ;; (matcher subexp facespec) '("-[rwxoRWXOezsfdlpSbctugkTBMAC]\\>\\([ \t]+_\\>\\)?" 0 font-lock-function-name-face keep) ; Not very good, triggers at "[a-z]" ;; This highlights declarations and definitions differently. ;; We do not try to highlight in the case of attributes: ;; it is already done by `cperl-find-pods-heres' + ;; -------- function definition _and_ declaration + ;; (matcher (subexp facespec)) + ;; facespec is evaluated depending on whether the + ;; statement ends in a "{" (definition) or ";" + ;; (declaration without body) (list (concat "\\<" cperl-sub-regexp - cperl-white-and-comment-rex ; whitespace/comments - "\\([^ \n\t{;()]+\\)" ; 2=name (assume non-anonymous) - "\\(" - cperl-maybe-white-and-comment-rex ;whitespace/comments? - "([^()]*)\\)?" ; prototype - cperl-maybe-white-and-comment-rex ; whitespace/comments? + (rx + (sequence (eval cperl--ws+-rx) + (group (optional (eval cperl--normal-identifier-rx))))) +;; "\\([^ \n\t{;()]+\\)" ; 2=name (assume non-anonymous) + (rx + (optional + (group (sequence (group (eval cperl--ws*-rx)) + (eval cperl--prototype-rx))))) +;; "\\(" +;; cperl-maybe-white-and-comment-rex ;whitespace/comments? + ;; "([^()]*)\\)?" ; prototype + (rx (optional (sequence (eval cperl--ws*-rx) + (eval cperl--attribute-list-rx)))) +; cperl-maybe-white-and-comment-rex ; whitespace/comments? + (rx (group-n 3 + (optional (sequence(eval cperl--ws*-rx) + (eval cperl--signature-rx))))) + (rx (eval cperl--ws*-rx)) "[{;]") - 2 '(if (eq (char-after (cperl-1- (match-end 0))) ?\{ ) - 'font-lock-function-name-face - 'font-lock-variable-name-face)) + '(1 (if (eq (char-after (cperl-1- (match-end 0))) ?\{ ) + 'font-lock-function-name-face + 'font-lock-variable-name-face) + t ;; override + t) ;; laxmatch in case of anonymous subroutines + ;; -------- anchored: Signature + `(,(rx (or (eval cperl--basic-scalar-rx) + (eval cperl--basic-array-rx) + (eval cperl--basic-hash-rx))) + (progn + (goto-char (match-beginning 3)) ; pre-match: Back to sig + (match-end 3)) + + nil + (0 font-lock-variable-name-face))) + ;; -------- various stuff calling for a package name + ;; (matcher subexp facespec) `(,(rx (sequence symbol-start (or "package" "require" "use" "import" "no" "bootstrap") (eval cperl--ws+-rx) (group-n 1 (eval cperl--normal-identifier-rx)) - (any " \t;"))) ; require A if B; + (any " \t\n;"))) ; require A if B; 1 font-lock-function-name-face) + ;; -------- formats + ;; (matcher subexp facespec) '("^[ \t]*format[ \t]+\\([a-zA-Z_][a-zA-Z_0-9:]*\\)[ \t]*=[ \t]*$" 1 font-lock-function-name-face) - ;; bareword hash key: $foo{bar} - `(,(rx (or (in "]}\\%@>*&") ; What Perl is this? + ;; -------- bareword hash key: $foo{bar}, $foo[1]{bar} + ;; (matcher (subexp facespec) ... + `(,(rx (or (in "]}\\%@>*&") (sequence "$" (eval cperl--normal-identifier-rx))) (0+ blank) "{" (0+ blank) (group-n 1 (sequence (opt "-") @@ -5784,24 +5976,27 @@ default function." (0+ blank) "}") ;; '("\\([]}\\%@>*&]\\|\\$[a-zA-Z0-9_:]*\\)[ \t]*{[ \t]*\\(-?[a-zA-Z0-9_:]+\\)[ \t]*}" (1 font-lock-string-face t) - ;; anchored bareword hash key: $foo{bar}{baz} + ;; -------- anchored bareword hash key: $foo{bar}{baz} + ;; ... (anchored-matcher pre-form post-form subex-highlighters) (,(rx point - (0+ blank) "{" (0+ blank) - (group-n 1 (sequence (opt "-") - (eval cperl--basic-identifier-rx))) - (0+ blank) "}") - ;; ("\\=[ \t]*{[ \t]*\\(-?[a-zA-Z0-9_:]+\\)[ \t]*}" + (0+ blank) "{" (0+ blank) + (group-n 1 (sequence (opt "-") + (eval cperl--basic-identifier-rx))) + (0+ blank) "}") + ;; ("\\=[ \t]*{[ \t]*\\(-?[a-zA-Z0-9_:]+\\)[ \t]*}" nil nil (1 font-lock-string-face t))) - ;; hash element assignments with bareword key => value - `(,(rx (in "[ \t{,()") - (group-n 1 (sequence (opt "-") - (eval cperl--basic-identifier-rx))) - (0+ blank) "=>") - 1 font-lock-string-face t) -;; '("[[ \t{,(]\\(-?[a-zA-Z0-9_:]+\\)[ \t]*=>" 1 -;; font-lock-string-face t) - ;; labels + ;; -------- hash element assignments with bareword key => value + ;; (matcher subexp facespec) + `(,(rx (in "[ \t{,()") + (group-n 1 (sequence (opt "-") + (eval cperl--basic-identifier-rx))) + (0+ blank) "=>") + 1 font-lock-string-face t) + ;; '("[[ \t{,(]\\(-?[a-zA-Z0-9_:]+\\)[ \t]*=>" 1 + ;; font-lock-string-face t) + ;; -------- labels + ;; (matcher subexp facespec) `(,(rx (sequence (0+ space) @@ -5812,7 +6007,8 @@ default function." (or "until" "while" "for" "foreach" "do") word-end)))) 1 font-lock-constant-face) - ;; labels as targets (no trailing colon!) + ;; -------- labels as targets (no trailing colon!) + ;; (matcher subexp facespec) `(,(rx (sequence symbol-start @@ -5824,10 +6020,12 @@ default function." ;;; '("[$*]{?\\(\\sw+\\)" 1 font-lock-variable-name-face) ;;; '("\\([@%]\\|\\$#\\)\\(\\sw+\\)" ;;; (2 (cons font-lock-variable-name-face '(underline)))) - ;; 1=my_etc, 2=white? 3=(+white? 4=white? 5=var + ;; 1=my_etc, 2=white? 3=(+white? 4=white? 5=var + ;; -------- variable declarations + ;; (matcher (subexp facespec) ... `(,(rx (sequence (or "state" "my" "local" "our")) (eval cperl--ws*-rx) - (opt (sequence "(" (eval cperl--ws*-rx))) + (opt (group (sequence "(" (eval cperl--ws*-rx)))) (group (in "$@%*") (or @@ -5840,7 +6038,8 @@ default function." ;; "\\((" ;; cperl-maybe-white-and-comment-rex ;; "\\)?\\([$@%*]\\([a-zA-Z0-9_:]+\\|[^a-zA-Z0-9_]\\)\\)") - (1 font-lock-variable-name-face) + (2 font-lock-variable-name-face) + ;; ... (anchored-matcher pre-form post-form subex-highlighters) (,(rx (sequence point (eval cperl--ws*-rx) "," @@ -5861,7 +6060,7 @@ default function." ;; Bug in font-lock: limit is used not only to limit ;; searches, but to set the "extend window for ;; facification" property. Thus we need to minimize. - '(if (match-beginning 1) + (if (match-beginning 1) ; list declaration (save-excursion (goto-char (match-beginning 1)) (condition-case nil @@ -5874,7 +6073,8 @@ default function." (forward-char -2)) ; disable continued expr nil (1 font-lock-variable-name-face))) - ;; foreach my $foo ( + ;; ----- foreach my $foo ( + ;; (matcher subexp facespec) `(,(rx symbol-start "for" (opt "each") (opt (sequence (1+ blank) (or "state" "my" "local" "our"))) @@ -5885,12 +6085,18 @@ default function." ;; '("\\ subroutine signature + "(!$)" ; not all punctuation is permitted + "{$$}"))) ; wrong type of paren + (cperl-test--validate-regexp (rx (eval cperl--prototype-rx)) + valid invalid))) + +(ert-deftest cperl-test-signature-rx () + "Test subroutine signatures." + (skip-unless (eq cperl-test-mode #'cperl-mode)) + (let ((valid + '("()" "( )" "($self, %params)" "(@params)")) + (invalid + '("$self" ; missing paren + "($)" ; a subroutine signature + "($!)" ; globals not permitted in a signature + "(@par,%options)" ; two slurpy parameters + "{$self}"))) ; wrong type of paren + (cperl-test--validate-regexp (rx (eval cperl--signature-rx)) + valid invalid))) + ;;; Test unicode identifier in various places (defun cperl--test-unicode-setup (code string) @@ -1145,6 +1209,79 @@ as a regex." (funcall cperl-test-mode) (should-not (nth 3 (syntax-ppss 3))))) +(ert-deftest cperl-test-bug-64190 () + "Verify correct fontification of multiline declarations" + (skip-unless (eq cperl-test-mode #'cperl-mode)) + (let ((file (ert-resource-file "cperl-bug-64190.pl"))) + (with-temp-buffer + (insert-file-contents file) + (goto-char (point-min)) + (cperl-mode) + (font-lock-ensure) + ;; Example 1 + (while (search-forward "var" nil t) + (should (equal (get-text-property (point) 'face) + 'font-lock-variable-name-face))) + ;; Example 2 + (search-forward "package F") + (should (equal (get-text-property (point) 'face) + 'font-lock-function-name-face)) + + ;; Example 3 and 4 can't be directly tested because jit-lock and + ;; batch tests don't play together well. But we can approximate + ;; the behavior by calling the the fontification for the same + ;; region which would be used by jit-lock. + ;; Example 3 + (search-forward "sub do_stuff") + (let ((start-change (point))) + (insert "\n{") + (cperl-font-lock-fontify-region-function start-change + (point-max) + nil) ; silent + (font-lock-ensure start-change (point-max)) + (goto-char (1- start-change)) ; between the "ff" in "stuff" + (should (equal (get-text-property (point) 'face) + 'font-lock-function-name-face)) + (search-forward "{") + (insert "}")) ; make it legal again + + ;; Example 4 + (search-forward "$param2") + (beginning-of-line) + (let ((start-change (point))) + (insert " ") + (cperl-font-lock-fontify-region-function start-change + (point-max) + nil) ; silent + (font-lock-ensure start-change (point-max)) + (goto-char (1+ start-change)) + (should (equal (get-text-property (point) 'face) + 'font-lock-variable-name-face)) + (re-search-forward (rx (group "sub") " " (group "oops"))) + (should (equal (get-text-property (match-beginning 1) 'face) + 'font-lock-keyword-face)) + (should (equal (get-text-property (match-beginning 2) 'face) + 'font-lock-function-name-face)))))) + +(ert-deftest cperl-test-bug-64364 () + "Check that multi-line subroutine declarations indent correctly." + (cperl-set-style "PBP") ; make cperl-mode use the same settings as perl-mode + (cperl--run-test-cases + (ert-resource-file "cperl-bug-64364.pl") + (indent-region (point-min) (point-max))) + (cperl--run-test-cases + (ert-resource-file "cperl-bug-64364.pl") + (let ((tab-function + (if (equal cperl-test-mode 'perl-mode) + #'indent-for-tab-command + #'cperl-indent-command))) + (goto-char (point-min)) + (while (null (eobp)) + (funcall tab-function) + (forward-line 1)))) + (cperl-set-style-back)) + + (ert-deftest test-indentation () (ert-test-erts-file (ert-resource-file "cperl-indents.erts")))