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.
This commit is contained in:
Harald Jörg
parent
361bf8a113
commit
a7ff8a76a5
4 changed files with 489 additions and 92 deletions
|
|
@ -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 <file*glob>
|
||||
"\\|"
|
||||
;; -------- 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):
|
||||
;;"\\<sub\\>\\(" ;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."
|
|||
;; '("\\<for\\(each\\)?\\([ \t]+\\(state\\|my\\|local\\|our\\)\\)?[ \t]*\\(\\$[a-zA-Z_][a-zA-Z_0-9]*\\)[ \t]*("
|
||||
1 font-lock-variable-name-face)
|
||||
;; Avoid $!, and s!!, qq!! etc. when not fontifying syntactically
|
||||
;; -------- ! as a negation char like $false = !$true
|
||||
;; (matcher subexp facespec)
|
||||
'("\\(?:^\\|[^smywqrx$]\\)\\(!\\)" 1 font-lock-negation-char-face)
|
||||
;; -------- ^ as a negation char in character classes m/[^abc]/
|
||||
;; (matcher subexp facespec)
|
||||
'("\\[\\(\\^\\)" 1 font-lock-negation-char-face prepend)))
|
||||
(setq
|
||||
t-font-lock-keywords-1
|
||||
`(
|
||||
;; arrays and hashes. Access to elements is fixed below
|
||||
;; -------- arrays and hashes. Access to elements is fixed below
|
||||
;; (matcher subexp facespec)
|
||||
;; facespec is an expression to distinguish between arrays and hashes
|
||||
(,(rx (group-n 1 (group-n 2 (or (in "@%") "$#"))
|
||||
(eval cperl--normal-identifier-rx)))
|
||||
1
|
||||
|
|
@ -5898,8 +6104,10 @@ default function."
|
|||
(if (eq (char-after (match-beginning 2)) ?%)
|
||||
'cperl-hash-face
|
||||
'cperl-array-face)
|
||||
nil) ; arrays and hashes
|
||||
;; access to array/hash elements
|
||||
nil)
|
||||
;; -------- access to array/hash elements
|
||||
;; (matcher subexp facespec)
|
||||
;; facespec is an expression to distinguish between arrays and hashes
|
||||
(,(rx (group-n 1 (group-n 2 (in "$@%"))
|
||||
(eval cperl--normal-identifier-rx))
|
||||
(0+ blank)
|
||||
|
|
@ -5912,7 +6120,8 @@ default function."
|
|||
'cperl-array-face) ; arrays and hashes
|
||||
font-lock-variable-name-face) ; Just to put something
|
||||
t) ; override previous
|
||||
;; @$ array dereferences, $#$ last array index
|
||||
;; -------- @$ array dereferences, $#$ last array index
|
||||
;; (matcher (subexp facespec) (subexp facespec))
|
||||
(,(rx (group-n 1 (or "@" "$#"))
|
||||
(group-n 2 (sequence "$"
|
||||
(or (eval cperl--normal-identifier-rx)
|
||||
|
|
@ -5920,7 +6129,8 @@ default function."
|
|||
;; ("\\(@\\|\\$#\\)\\(\\$+\\([a-zA-Z_:][a-zA-Z0-9_:]*\\|[^ \t\n]\\)\\)"
|
||||
(1 'cperl-array-face)
|
||||
(2 font-lock-variable-name-face))
|
||||
;; %$ hash dereferences
|
||||
;; -------- %$ hash dereferences
|
||||
;; (matcher (subexp facespec) (subexp facespec))
|
||||
(,(rx (group-n 1 "%")
|
||||
(group-n 2 (sequence "$"
|
||||
(or (eval cperl--normal-identifier-rx)
|
||||
|
|
|
|||
24
test/lisp/progmodes/cperl-mode-resources/cperl-bug-64190.pl
Normal file
24
test/lisp/progmodes/cperl-mode-resources/cperl-bug-64190.pl
Normal file
|
|
@ -0,0 +1,24 @@
|
|||
# Example 1
|
||||
|
||||
my ($var1,
|
||||
$var2,
|
||||
$var3);
|
||||
|
||||
# Example 2
|
||||
|
||||
package Foo
|
||||
0.1;
|
||||
|
||||
# Example 3 (intentionally incomplete, body is inserted by test)
|
||||
|
||||
sub do_stuff
|
||||
|
||||
# Example 4
|
||||
|
||||
sub do_more_stuff ($param1,
|
||||
$param2)
|
||||
{
|
||||
...;
|
||||
}
|
||||
|
||||
sub oops { ...; }
|
||||
26
test/lisp/progmodes/cperl-mode-resources/cperl-bug-64364.pl
Normal file
26
test/lisp/progmodes/cperl-mode-resources/cperl-bug-64364.pl
Normal file
|
|
@ -0,0 +1,26 @@
|
|||
# This resource file can be run with cperl--run-testcases from
|
||||
# cperl-tests.el and works with both perl-mode and cperl-mode.
|
||||
|
||||
# -------- Bug#64364: input -------
|
||||
package P {
|
||||
sub way { ...; }
|
||||
#
|
||||
sub bus
|
||||
:lvalue
|
||||
($sig,$na,@ture)
|
||||
{
|
||||
...;
|
||||
}
|
||||
}
|
||||
# -------- Bug#64364: expected output -------
|
||||
package P {
|
||||
sub way { ...; }
|
||||
#
|
||||
sub bus
|
||||
:lvalue
|
||||
($sig,$na,@ture)
|
||||
{
|
||||
...;
|
||||
}
|
||||
}
|
||||
# -------- Bug#64364: end -------
|
||||
|
|
@ -177,14 +177,18 @@ attributes, prototypes and signatures."
|
|||
(should (equal (get-text-property (1+ (match-beginning 0)) 'face)
|
||||
'font-lock-string-face)))
|
||||
(goto-char start-of-sub)
|
||||
;; Attributes with their optional parameters
|
||||
(when (search-forward-regexp "\\(:[a-z]+\\)\\((.*?)\\)?" end-of-sub t)
|
||||
(should (equal (get-text-property (match-beginning 1) 'face)
|
||||
'font-lock-constant-face))
|
||||
(when (match-beginning 2)
|
||||
(should (equal (get-text-property (match-beginning 2) 'face)
|
||||
'font-lock-string-face))))
|
||||
(goto-char end-of-sub)))
|
||||
|
||||
(goto-char end-of-sub)
|
||||
;; Subroutine signatures
|
||||
(when (search-forward "$bar" end-of-sub t)
|
||||
(should (equal (get-text-property (match-beginning) 'face)
|
||||
'font-lock-variable-name-face)))))
|
||||
;; Anonymous subroutines
|
||||
(while (search-forward-regexp "= sub" nil t)
|
||||
(let ((start-of-sub (match-beginning 0))
|
||||
|
|
@ -201,7 +205,11 @@ attributes, prototypes and signatures."
|
|||
(when (match-beginning 2)
|
||||
(should (equal (get-text-property (match-beginning 2) 'face)
|
||||
'font-lock-string-face))))
|
||||
(goto-char end-of-sub))))))
|
||||
(goto-char end-of-sub)
|
||||
;; Subroutine signatures
|
||||
(when (search-forward "$bar" end-of-sub t)
|
||||
(should (equal (get-text-property (match-beginning) 'face)
|
||||
'font-lock-variable-name-face))))))))
|
||||
|
||||
(ert-deftest cperl-test-fontify-special-variables ()
|
||||
"Test fontification of variables like $^T or ${^ENCODING}.
|
||||
|
|
@ -428,6 +436,62 @@ Also includes valid cases with whitespace in strange places."
|
|||
(cperl-test--validate-regexp (rx (eval cperl--basic-identifier-rx))
|
||||
valid invalid)))
|
||||
|
||||
(ert-deftest cperl-test-attribute-rx ()
|
||||
"Test attributes and attribute lists"
|
||||
(skip-unless (eq cperl-test-mode #'cperl-mode))
|
||||
(let ((valid
|
||||
'("foo" "bar()" "baz(quux)"))
|
||||
(invalid
|
||||
'("+foo" ; not an identifier
|
||||
"foo::bar" ; no package qualifiers allowed
|
||||
"(no-identifier)" ; no attribute name
|
||||
"baz (quux)"))) ; no space allowed before "("
|
||||
(cperl-test--validate-regexp (rx (eval cperl--single-attribute-rx))
|
||||
valid invalid)))
|
||||
|
||||
(ert-deftest cperl-test-attribute-list-rx ()
|
||||
"Test attributes and attribute lists"
|
||||
(skip-unless (eq cperl-test-mode #'cperl-mode))
|
||||
(let ((valid
|
||||
'(":" ":foo" ": bar()" ":baz(quux):"
|
||||
":isa(Foo)does(Bar)" ":isa(Foo):does(Bar)" ":isa(Foo):does(Bar):"
|
||||
": isa(Foo::Bar) : does(Bar)"))
|
||||
(invalid
|
||||
'(":foo + bar" ; not an identifier
|
||||
": foo(bar : : baz" ; too many colons
|
||||
": baz (quux)"))) ; no space allowed before "("
|
||||
(cperl-test--validate-regexp (rx (eval cperl--attribute-list-rx))
|
||||
valid invalid)))
|
||||
|
||||
(ert-deftest cperl-test-prototype-rx ()
|
||||
"Test subroutine prototypes"
|
||||
(skip-unless (eq cperl-test-mode #'cperl-mode))
|
||||
(let ((valid
|
||||
;; Examples from perldoc perlsub
|
||||
'("($$)" "($$$)" "($$;$)" "($$$;$)" "(@)" "($@)" "(\\@)" "(\\@$$@)"
|
||||
"(\\[%@])" "(*;$)" "(**)" "(&@)" "(;$)" "()"))
|
||||
(invalid
|
||||
'("$" ; missing paren
|
||||
"($self)" ; a variable, -> 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")))
|
||||
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue