diff options
Diffstat (limited to 'lisp/progmodes/cperl-mode.el')
| -rw-r--r-- | lisp/progmodes/cperl-mode.el | 1265 |
1 files changed, 794 insertions, 471 deletions
diff --git a/lisp/progmodes/cperl-mode.el b/lisp/progmodes/cperl-mode.el index 3370df64919..fe9612a09a9 100644 --- a/lisp/progmodes/cperl-mode.el +++ b/lisp/progmodes/cperl-mode.el @@ -308,12 +308,11 @@ Can be overwritten by `cperl-hairy' if nil." Can be overwritten by `cperl-hairy' if nil. Uses `abbrev-mode' to do the expansion. If you want to use your -own abbrevs in cperl-mode, but do not want keywords to be +own abbrevs in `cperl-mode', but do not want keywords to be electric, you must redefine `cperl-mode-abbrev-table': do \\[edit-abbrevs], search for `cperl-mode-abbrev-table', and, in that paragraph, delete the words that appear at the ends of lines and -that begin with \"cperl-electric\". -" +that begin with \"cperl-electric\"." :type '(choice (const null) boolean) :group 'cperl-affected-by-hairy) @@ -362,14 +361,14 @@ Affects: `cperl-font-lock', `cperl-electric-lbrace-space', ;; :group 'cperl) (defcustom cperl-info-on-command-no-prompt nil - "Not-nil (and non-null) means not to prompt on C-h f. + "Not-nil (and non-null) means not to prompt on \\[cperl-info-on-command]. The opposite behavior is always available if prefixed with C-c. Can be overwritten by `cperl-hairy' if nil." :type '(choice (const null) boolean) :group 'cperl-affected-by-hairy) (defcustom cperl-clobber-lisp-bindings nil - "Not-nil (and non-null) means not overwrite C-h f. + "Not-nil (and non-null) means not overwrite \\[describe-function]. The function is available on \\[cperl-info-on-command], \\[cperl-get-help]. Can be overwritten by `cperl-hairy' if nil." :type '(choice (const null) boolean) @@ -508,9 +507,9 @@ Currently used with `cperl-check-syntax' only." :group 'cperl-help-system) (defcustom cperl-indent-region-fix-constructs 1 - "Amount of space to insert between `}' and `else' or `elsif' -in `cperl-indent-region'. Set to nil to leave as is. Values other -than 1 and nil will probably not work." + "Amount of space to insert between `}' and `else' or `elsif'. +Used by `cperl-indent-region'. Set to nil to leave as is. +Values other than 1 and nil will probably not work." :type '(choice (const nil) (const 1)) :group 'cperl-indentation-details) @@ -767,8 +766,7 @@ line-breaks/spacing between elements of the construct. 10) Uses a linear-time algorithm for indentation of regions. -11) Syntax-highlight, indentation, sexp-recognition inside regular expressions. -") +11) Syntax-highlight, indentation, sexp-recognition inside regular expressions.") (defvar cperl-speed 'please-ignore-this-line "This is an incomplete compendium of what is available in other parts @@ -865,9 +863,7 @@ In regular expressions (including character classes): backslashes of escape sequences `font-lock-variable-name-face' Interpolated constructs, embedded code, POSIX classes (inside charclasses) - `font-lock-comment-face' Embedded comments - -") + `font-lock-comment-face' Embedded comments") @@ -1023,15 +1019,9 @@ Unless KEEP, removes the old indentation." (define-key map [(control ?c) (control ?h) ?v] ;;(concat (char-to-string help-char) "v") ; does not work 'cperl-get-help)) - (substitute-key-definition - 'indent-sexp 'cperl-indent-exp - map global-map) - (substitute-key-definition - 'indent-region 'cperl-indent-region - map global-map) - (substitute-key-definition - 'indent-for-comment 'cperl-indent-for-comment - map global-map) + (define-key map [remap indent-sexp] #'cperl-indent-exp) + (define-key map [remap indent-region] #'cperl-indent-region) + (define-key map [remap indent-for-comment] #'cperl-indent-for-comment) map) "Keymap used in CPerl mode.") @@ -1203,153 +1193,198 @@ The expansion is entirely correct because it uses the C preprocessor." ;; minimalistic Perl grammar, to be used instead of individual (and ;; not always consistent) literal regular expressions. -(defconst cperl--basic-identifier-regexp - (rx (sequence (or alpha "_") (* (or word "_")))) - "A regular expression for the name of a \"basic\" Perl variable. +;; This is necessary to compile this file under Emacs 26.1 +;; (there's no rx-define which would help) +(eval-and-compile + + (defconst cperl--basic-identifier-rx + '(sequence (or alpha "_") (* (or word "_"))) + "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.") -(defconst cperl--label-regexp - (rx-to-string - `(sequence - symbol-start - (regexp ,cperl--basic-identifier-regexp) - (0+ space) - ":")) - "A regular expression for a Perl label. + (defconst cperl--label-rx + `(sequence symbol-start + ,cperl--basic-identifier-rx + (0+ space) + ":") + "A regular expression for a Perl label. By convention, labels are uppercase alphabetics, but this isn't enforced.") -(defconst cperl--normal-identifier-regexp - (rx-to-string - `(or - (sequence - (1+ (sequence - (opt (regexp ,cperl--basic-identifier-regexp)) - "::")) - (opt (regexp ,cperl--basic-identifier-regexp))) - (regexp ,cperl--basic-identifier-regexp))) - "A regular expression for a Perl variable name with optional namespace. + (defconst cperl--false-label-rx + '(sequence (or (in "sym") "tr") (0+ space) ":") + "A regular expression which is similar to a label, but might as +well be a quote-like operator with a colon as delimiter.") + + (defconst cperl--normal-identifier-rx + `(or (sequence (1+ (sequence + (opt ,cperl--basic-identifier-rx) + "::")) + (opt ,cperl--basic-identifier-rx)) + ,cperl--basic-identifier-rx) + "A regular expression for a Perl variable name with optional namespace. Examples are `foo`, `Some::Module::VERSION`, and `::` (yes, that is a legal variable name).") -(defconst cperl--special-identifier-regexp - (rx-to-string - `(or - (1+ digit) ; $0, $1, $2, ... - (sequence "^" (any "A-Z" "]^_?\\")) ; $^V - (sequence "{" (0+ space) ; ${^MATCH} - "^" (any "A-Z" "]^_?\\") - (0+ (any "A-Z" "_" digit)) - (0+ space) "}") - (in "!\"$%&'()+,-./:;<=>?@\\]^_`|~"))) ; $., $|, $", ... but not $^ or ${ - "The list of Perl \"punctuation\" variables, as listed in perlvar.") - -(defconst cperl--ws-regexp - (rx-to-string - '(or space "\n")) - "Regular expression for a single whitespace in Perl.") - -(defconst cperl--eol-comment-regexp - (rx-to-string - '(sequence "#" (0+ (not (in "\n"))) "\n")) - "Regular expression for a single end-of-line comment in Perl") - -(defconst cperl--ws-or-comment-regexp - (rx-to-string - `(1+ - (or - (regexp ,cperl--ws-regexp) - (regexp ,cperl--eol-comment-regexp)))) - "Regular expression for a sequence of whitespace and comments in Perl.") - -(defconst cperl--ows-regexp - (rx-to-string - `(opt (regexp ,cperl--ws-or-comment-regexp))) - "Regular expression for optional whitespaces or comments in Perl") - -(defconst cperl--version-regexp - (rx-to-string - `(or - (sequence (opt "v") - (>= 2 (sequence (1+ digit) ".")) - (1+ digit) - (opt (sequence "_" (1+ word)))) - (sequence (1+ digit) - (opt (sequence "." (1+ digit))) - (opt (sequence "_" (1+ word)))))) - "A sequence for recommended version number schemes in Perl.") - -(defconst cperl--package-regexp - (rx-to-string - `(sequence - "package" ; FIXME: the "class" and "role" keywords need to be - ; recognized soon...ish. - (regexp ,cperl--ws-or-comment-regexp) - (group (regexp ,cperl--normal-identifier-regexp)) - (opt - (sequence - (regexp ,cperl--ws-or-comment-regexp) - (group (regexp ,cperl--version-regexp)))))) - "A regular expression for package NAME VERSION in Perl. -Contains two groups for the package name and version.") - -(defconst cperl--package-for-imenu-regexp - (rx-to-string - `(sequence - (regexp ,cperl--package-regexp) - (regexp ,cperl--ows-regexp) - (group (or ";" "{")))) - "A regular expression to collect package names for `imenu`. + (defconst cperl--special-identifier-rx + '(or + (1+ digit) ; $0, $1, $2, ... + (sequence "^" (any "A-Z" "]^_?\\")) ; $^V + (sequence "{" (0+ space) ; ${^MATCH} + "^" (any "A-Z" "]^_?\\") + (0+ (any "A-Z" "_" digit)) + (0+ space) "}") + (in "!\"$%&'()+,-./:;<=>?@\\]^_`|~")) ; $., $|, $", ... but not $^ or ${ + "The list of Perl \"punctuation\" variables, as listed in perlvar.") + + (defconst cperl--ws-rx + '(sequence (or space "\n")) + "Regular expression for a single whitespace in Perl.") + + (defconst cperl--eol-comment-rx + '(sequence "#" (0+ (not (in "\n"))) "\n") + "Regular expression for a single end-of-line comment in Perl") + + (defconst cperl--ws-or-comment-rx + `(or ,cperl--ws-rx + ,cperl--eol-comment-rx) + "A regular expression for either whitespace or comment") + + (defconst cperl--ws*-rx + `(0+ ,cperl--ws-or-comment-rx) + "Regular expression for optional whitespaces or comments in Perl") + + (defconst cperl--ws+-rx + `(1+ ,cperl--ws-or-comment-rx) + "Regular expression for a sequence of whitespace and comments in Perl.") + + ;; 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 + (rx-to-string + `(or + (sequence (optional "v") + (>= 2 (sequence (1+ digit) ".")) + (1+ digit) + (optional (sequence "_" (1+ word)))) + (sequence (1+ digit) + (optional (sequence "." (1+ digit))) + (optional (sequence "_" (1+ word)))))) + "A sequence for recommended version number schemes in Perl.") + + (defconst cperl--package-rx + `(sequence (group "package") + ,cperl--ws+-rx + (group ,cperl--normal-identifier-rx) + (optional (sequence ,cperl--ws+-rx + (group (regexp ,cperl--version-regexp))))) + "A regular expression for package NAME VERSION in Perl. +Contains three groups for the keyword \"package\", for the +package name and for the version.") + + (defconst cperl--package-for-imenu-rx + `(sequence symbol-start + (group-n 1 "package") + ,cperl--ws*-rx + (group-n 2 ,cperl--normal-identifier-rx) + (optional (sequence ,cperl--ws+-rx + (regexp ,cperl--version-regexp))) + ,cperl--ws*-rx + (group-n 3 (or ";" "{"))) + "A regular expression to collect package names for `imenu'. Catches \"package NAME;\", \"package NAME VERSION;\", \"package NAME BLOCK\" and \"package NAME VERSION BLOCK.\" Contains three -groups: Two from `cperl--package-regexp` for the package name and -version, and a third to detect \"package BLOCK\" syntax.") - -(defconst cperl--sub-name-regexp - (rx-to-string - `(sequence - (optional (sequence (group (or "my" "state" "our")) - (regexp ,cperl--ws-or-comment-regexp))) - "sub" ; FIXME: the "method" and maybe "fun" keywords need to be - ; recognized soon...ish. - (regexp ,cperl--ws-or-comment-regexp) - (group (regexp ,cperl--normal-identifier-regexp)))) - "A regular expression to detect a subroutine start. -Contains two groups: One for to distinguish lexical from -\"normal\" subroutines and one for the subroutine name.") - -(defconst cperl--pod-heading-regexp - (rx-to-string - `(sequence - line-start "=head" - (group (in "1-4")) - (1+ (in " \t")) - (group (1+ (not (in "\n")))) - line-end)) ; that line-end seems to be redundant? +groups: One for the keyword \"package\", one for the package +name, and one for the discovery of a following BLOCK.") + + (defconst cperl--sub-name-for-imenu-rx + `(sequence symbol-start + (optional (sequence (group-n 3 (or "my" "state" "our")) + ,cperl--ws+-rx)) + (group-n 1 "sub") + ,cperl--ws+-rx + (group-n 2 ,cperl--normal-identifier-rx)) + "A regular expression to detect a subroutine start. +Contains three groups: One one to distinguish lexical from +\"normal\" subroutines, for the keyword \"sub\", and one for the +subroutine name.") + +(defconst cperl--block-declaration-rx + `(sequence + (or "package" "sub") ; "class" and "method" coming soon + (1+ ,cperl--ws-or-comment-rx) + ,cperl--normal-identifier-rx) + "A regular expression to find a declaration for a named block. +Used for indentation. These declarations introduce a block which +does not need a semicolon to terminate the statement.") + +(defconst cperl--pod-heading-rx + `(sequence line-start + (group-n 1 "=head") + (group-n 3 (in "1-4")) + (1+ (in " \t")) + (group-n 2 (1+ (not (in "\n"))))) "A regular expression to detect a POD heading. Contains two groups: One for the heading level, and one for the heading text.") -(defconst cperl--imenu-entries-regexp - (rx-to-string - `(or - (regexp ,cperl--package-for-imenu-regexp) ; 1..3 - (regexp ,cperl--sub-name-regexp) ; 4..5 - (regexp ,cperl--pod-heading-regexp))) ; 6..7 - "A regular expression to collect stuff that goes into the `imenu` index. +(defconst cperl--imenu-entries-rx + `(or ,cperl--package-for-imenu-rx + ,cperl--sub-name-for-imenu-rx + ,cperl--pod-heading-rx) + "A regular expression to collect stuff that goes into the `imenu' index. Covers packages, subroutines, and POD headings.") +;; end of eval-and-compiled stuff +) + + +(defun cperl-block-declaration-p () + "Test whether the following ?\\{ opens a declaration block. +Returns the column where the declarating keyword is found, or nil +if this isn't a declaration block. Declaration blocks are named +subroutines, packages and the like. They start with a keyword +and a name, to be followed by various descriptive items which are +just skipped over for our purpose. Declaration blocks end a +statement, so there's no semicolon." + ;; A scan error means that none of the declarators has been found + (condition-case nil + (let ((is-block-declaration nil) + (continue-searching t)) + (while (and continue-searching (not (bobp))) + (forward-sexp -1) + (cond + ((looking-at (rx (eval cperl--block-declaration-rx))) + (setq is-block-declaration (current-column) + continue-searching nil)) + ;; Another brace means this is no block declaration + ((looking-at "{") + (setq continue-searching nil)) + (t + (cperl-backward-to-noncomment (point-min)) + ;; A semicolon or an opening brace prevent this block from + ;; being a block declaration + (when (or (eq (preceding-char) ?\;) + (eq (preceding-char) ?{)) + (setq continue-searching nil))))) + is-block-declaration) + (error nil))) + ;; These two must be unwound, otherwise take exponential time -(defconst cperl-maybe-white-and-comment-rex "[ \t\n]*\\(#[^\n]*\n[ \t\n]*\\)*" +(defconst cperl-maybe-white-and-comment-rex + (rx (group (eval cperl--ws*-rx))) + ;; was: "[ \t\n]*\\(#[^\n]*\n[ \t\n]*\\)*" "Regular expression to match optional whitespace with interspersed comments. Should contain exactly one group.") ;; This one is tricky to unwind; still very inefficient... -(defconst cperl-white-and-comment-rex "\\([ \t\n]\\|#[^\n]*\n\\)+" +(defconst cperl-white-and-comment-rex + (rx (group (eval cperl--ws+-rx))) + ;; was: "\\([ \t\n]\\|#[^\n]*\n\\)+" "Regular expression to match whitespace with interspersed comments. Should contain exactly one group.") @@ -1366,7 +1401,7 @@ the last)." (concat ; Assume n groups before this... "\\(" ; n+1=name-group cperl-white-and-comment-rex ; n+2=pre-name - "\\(::[a-zA-Z_0-9:']+\\|[a-zA-Z_'][a-zA-Z_0-9:']*\\)" ; n+3=name + (rx-to-string `(group ,cperl--normal-identifier-rx)) "\\)" ; END n+1=name-group (if named "" "?") "\\(" ; n+4=proto-group @@ -1405,28 +1440,9 @@ the last)." when (eq char (aref keyword (1- (length keyword)))) return t)) -;; Details of groups in this are used in `cperl-imenu--create-perl-index' -;; and `cperl-outline-level'. -;; Was: 2=sub|package; now 2=package-group, 5=package-name 8=sub-name (+3) -(defvar cperl-imenu--function-name-regexp-perl - (concat - "^\\(" ; 1 = all - "\\([ \t]*package" ; 2 = package-group - "\\(" ; 3 = package-name-group - cperl-white-and-comment-rex ; 4 = pre-package-name - "\\([a-zA-Z_0-9:']+\\)\\)?\\)" ; 5 = package-name - "\\|" - "[ \t]*" - cperl-sub-regexp - (cperl-after-sub-regexp 'named nil) ; 8=name 11=proto 14=attr-start - cperl-maybe-white-and-comment-rex ; 15=pre-block - "\\|" - "=head\\([1-4]\\)[ \t]+" ; 16=level - "\\([^\n]+\\)$" ; 17=text - "\\)")) - (defvar cperl-outline-regexp - (concat cperl-imenu--function-name-regexp-perl "\\|" "\\`")) + (rx (sequence line-start (0+ blank) (eval cperl--imenu-entries-rx))) + "The regular expression used for `outline-minor-mode'.") (defvar cperl-mode-syntax-table nil "Syntax table in use in CPerl mode buffers.") @@ -1562,7 +1578,7 @@ into \\{cperl-mode-map} -Setting the variable `cperl-font-lock' to t switches on font-lock-mode +Setting the variable `cperl-font-lock' to t switches on `font-lock-mode' \(even with older Emacsen), `cperl-electric-lbrace-space' to t switches on electric space between $ and {, `cperl-electric-parens-string' is the string that contains parentheses that should be electric in CPerl @@ -1741,7 +1757,9 @@ or as help on variables `cperl-tips', `cperl-problems', '((cperl-load-font-lock-keywords cperl-load-font-lock-keywords-1 cperl-load-font-lock-keywords-2) - nil nil ((?_ . "w")))) + nil nil ((?_ . "w")) nil + (font-lock-syntactic-face-function + . cperl-font-lock-syntactic-face-function))) ;; Reset syntaxification cache. (setq-local cperl-syntax-state nil) (when cperl-use-syntax-table-text-property @@ -2451,7 +2469,8 @@ Will untabify if `cperl-electric-backspace-untabify' is non-nil." (put 'cperl-electric-backspace 'delete-selection 'supersede) -(defun cperl-inside-parens-p () ;; NOT USED???? +(defun cperl-inside-parens-p () + (declare (obsolete nil "28.1")) ; not used (condition-case () (save-excursion (save-restriction @@ -2514,8 +2533,9 @@ Return the amount the indentation changed by." (t (skip-chars-forward " \t") (if (listp indent) (setq indent (car indent))) - (cond ((and (looking-at "[A-Za-z_][A-Za-z_0-9]*:[^:]") - (not (looking-at "[smy]:\\|tr:"))) + (cond ((and (looking-at (rx (sequence (eval cperl--label-rx) + (not (in ":"))))) + (not (looking-at (rx (eval cperl--false-label-rx))))) (and (> indent 0) (setq indent (max cperl-min-label-indent (+ indent cperl-label-offset))))) @@ -2547,12 +2567,13 @@ Return the amount the indentation changed by." '(?w ?_)) (progn (backward-sexp) - (looking-at "[a-zA-Z_][a-zA-Z0-9_]*:[^:]")))) + (looking-at (rx (sequence (eval cperl--label-rx) + (not (in ":")))))))) (defun cperl-get-state (&optional parse-start start-state) - "Return list (START STATE DEPTH PRESTART), + "Return list (START STATE DEPTH PRESTART). START is a good place to start parsing, or equal to -PARSE-START if preset, +PARSE-START if preset. STATE is what is returned by `parse-partial-sexp'. DEPTH is true is we are immediately after end of block which contains START. @@ -2707,12 +2728,16 @@ Will not look before LIM." (and (eq (preceding-char) ?\}) (cperl-after-block-and-statement-beg (point-min))) ; Was start - too close + (and char-after (char-equal char-after ?{) + (save-excursion (cperl-block-declaration-p))) (memq char-after (append ")]}" nil)) (and (eq (preceding-char) ?\:) ; label (progn (forward-sexp -1) (skip-chars-backward " \t") - (looking-at "[ \t]*[a-zA-Z_][a-zA-Z_0-9]*[ \t]*:"))) + (looking-at + (rx (sequence (0+ blank) + (eval cperl--label-rx)))))) (get-text-property (point) 'first-format-line))) ;; Look at previous line that's at column 0 @@ -2750,12 +2775,10 @@ Will not look before LIM." ;; Back up over label lines, since they don't ;; affect whether our line is a continuation. ;; (Had \, too) - (while;;(or (eq (preceding-char) ?\,) - (and (eq (preceding-char) ?:) - (or;;(eq (char-after (- (point) 2)) ?\') ; ???? - (memq (char-syntax (char-after (- (point) 2))) - '(?w ?_)))) - ;;) + (while (and (eq (preceding-char) ?:) + (re-search-backward + (rx (sequence (eval cperl--label-rx) point)) + nil t)) ;; This is always FALSE? (if (eq (preceding-char) ?\,) ;; Will go to beginning of line, essentially. @@ -2767,6 +2790,7 @@ 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)) (memq (preceding-char) (append (if is-block " ;{" " ,;{") '(nil))) (and (eq (preceding-char) ?\}) @@ -2795,10 +2819,17 @@ Will not look before LIM." (forward-char 1) (let ((colon-line-end 0)) (while - (progn (skip-chars-forward " \t\n") - ;; s: foo : bar :x is NOT label - (and (looking-at "#\\|\\([a-zA-Z0-9_$]+\\):[^:]\\|=[a-zA-Z]") - (not (looking-at "[sym]:\\|tr:")))) + (progn + (skip-chars-forward " \t\n") + ;; s: foo : bar :x is NOT label + (and (looking-at + (rx + (or "#" + (sequence (eval cperl--label-rx) + (not (in ":"))) + (sequence "=" (in "a-zA-Z"))))) + (not (looking-at + (rx (eval cperl--false-label-rx)))))) ;; Skip over comments and labels following openbrace. (cond ((= (following-char) ?\#) (forward-line 1)) @@ -3057,7 +3088,10 @@ and closing parentheses and brackets." ;; If line starts with label, calculate label indentation (if (save-excursion (beginning-of-line) - (looking-at "[ \t]*[a-zA-Z_][a-zA-Z_0-9]*:[^:]")) + (looking-at (rx + (sequence (0+ space) + (eval cperl--label-rx) + (not (in ":")))))) (if (> (current-indentation) cperl-min-label-indent) (- (current-indentation) cperl-label-offset) ;; Do not move `parse-data', this should @@ -3070,8 +3104,9 @@ and closing parentheses and brackets." (error "Got strange value of indent: %s" i)))))) (defun cperl-calculate-indent-within-comment () - "Return the indentation amount for line, assuming that -the current line is to be regarded as part of a block comment." + "Return the indentation amount for line. +Assume that the current line is to be regarded as part of a block +comment." (let (end) (save-excursion (beginning-of-line) @@ -3147,26 +3182,29 @@ Returns true if comment is found. In POD will not move the point." (while (re-search-forward "^\\s(" e 'to-end) (put-text-property (1- (point)) (point) 'syntax-table cperl-st-punct)))) -(defun cperl-commentify (bb e string &optional noface) - (if cperl-use-syntax-table-text-property - (if (eq noface 'n) ; Only immediate - nil - ;; We suppose that e is _after_ the end of construction, as after eol. - (setq string (if string cperl-st-sfence cperl-st-cfence)) - (if (> bb (- e 2)) +(defun cperl-commentify (begin end string) + "Mark text from BEGIN to END as generic string or comment. +Mark as generic string if STRING, as generic comment otherwise. +A single character is marked as punctuation and directly +fontified. Do nothing if BEGIN and END are equal. If +`cperl-use-syntax-text-property' is nil, just fontify." + (if (and cperl-use-syntax-table-text-property + (> end begin)) + (progn + (setq string (if string cperl-st-sfence cperl-st-cfence)) + (if (> begin (- end 2)) ;; one-char string/comment?! - (cperl-modify-syntax-type bb cperl-st-punct) - (cperl-modify-syntax-type bb string) - (cperl-modify-syntax-type (1- e) string)) - (if (and (eq string cperl-st-sfence) (> (- e 2) bb)) - (put-text-property (1+ bb) (1- e) + (cperl-modify-syntax-type begin cperl-st-punct) + (cperl-modify-syntax-type begin string) + (cperl-modify-syntax-type (1- end) string)) + (if (and (eq string cperl-st-sfence) (> (- end 2) begin)) + (put-text-property (1+ begin) (1- end) 'syntax-table cperl-string-syntax-table)) - (cperl-protect-defun-start bb e)) + (cperl-protect-defun-start begin end)) ;; Fontify - (or noface - (not cperl-pod-here-fontify) - (put-text-property bb e 'face (if string 'font-lock-string-face - 'font-lock-comment-face))))) + (when cperl-pod-here-fontify + (put-text-property begin end 'face (if string 'font-lock-string-face + 'font-lock-comment-face))))) (defvar cperl-starters '(( ?\( . ?\) ) ( ?\[ . ?\] ) @@ -3333,8 +3371,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 @@ -3351,8 +3391,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))) @@ -3510,19 +3578,194 @@ Should be called with the point before leading colon of an attribute." (goto-char endbracket) ; just in case something misbehaves??? t)) +(defvar cperl-here-doc-functions + (regexp-opt '("print" "printf" "say" ; print $handle <<EOF + "system" "exec" ; system $progname <<EOF + "sort") ; sort $subname <<EOF + 'symbols) ; avoid false positives + "List of keywords after which `$var <<bareword' is a here-document. +After any other token `$var <<bareword' is treated as the variable `$var' +left-shifted by the return value of the function `bareword'.") + +(defun cperl-is-here-doc-p (start) + "Find out whether a \"<<\" construct starting at START is a here-document. +The point is expected to be after the end of the delimiter. +Quoted delimiters after \"<<\" are unambiguously starting +here-documents and are not handled here. This function does not +move point but does change match data." + ;; not a here-doc | here-doc + ;; $foo << b; | $f .= <<B; + ;; ($f+1) << b; | a($f) . <<B; + ;; foo 1, <<B; | $x{a} <<b; + ;; Limitations: + ;; foo <<bar is statically undecidable. It could be either + ;; foo() << bar # left shifting the return value or + ;; foo(<<bar) # passing a here-doc to foo(). + ;; We treat it as here-document and kindly ask programmers to + ;; disambiguate by adding parens. + (null + (or (looking-at "[ \t]*(") ; << function_call() + (looking-at ">>") ; <<>> operator + (save-excursion ; 1 << func_name, or $foo << 10 + (condition-case nil + (progn + (goto-char start) + (forward-sexp -1) ;; examine the part before "<<" + (save-match-data + (cond + ((looking-at "[0-9$({]") + (forward-sexp 1) + (and + (looking-at "[ \t]*<<") + (condition-case nil + ;; print $foo <<EOF + (progn + (forward-sexp -2) + (not + (looking-at cperl-here-doc-functions))) + (error t))))))) + (error nil)))))) ; func(<<EOF) + +(defun cperl-process-here-doc (min max end overshoot stop-point + end-of-here-doc err-l + indented-here-doc-p + matched-pos todo-pos + delim-begin delim-end) + "Process a here-document's delimiters and body. +The parameters MIN, MAX, END, OVERSHOOT, STOP-POINT, ERR-L are +used for recursive calls to `cperl-find-pods-here' to handle the +rest of the line which contains the delimiter. MATCHED-POS and +TODO-POS are initial values for this function's result. +END-OF-HERE-DOC is the end of a previous here-doc in the same +line, or nil if this is the first. DELIM-BEGIN and DELIM-END are +the positions where the here-document's delimiter has been found. +This is part of `cperl-find-pods-heres' (below)." + (let* ((my-cperl-delimiters-face font-lock-constant-face) + (delimiter (buffer-substring-no-properties delim-begin delim-end)) + (qtag (regexp-quote delimiter)) + (use-syntax-state (and cperl-syntax-state + (>= min (car cperl-syntax-state)))) + (state-point (if use-syntax-state + (car cperl-syntax-state) + (point-min))) + (state (if use-syntax-state + (cdr cperl-syntax-state))) + here-doc-start here-doc-end defs-eol + warning-message) + (when cperl-pod-here-fontify + ;; Highlight the starting delimiter + (cperl-postpone-fontification delim-begin delim-end + 'face my-cperl-delimiters-face) + (cperl-put-do-not-fontify delim-begin delim-end t)) + (forward-line) + (setq here-doc-start (point) ; first char of (first) here-doc + defs-eol (1- here-doc-start)) ; end of definitions line + (if end-of-here-doc + ;; skip to the end of the previous here-doc + (goto-char end-of-here-doc) + ;; otherwise treat the first (or only) here-doc: Check for + ;; special cases if the line containing the delimiter(s) + ;; ends in a regular comment or a solitary ?# + (let* ((eol-state (save-excursion (syntax-ppss defs-eol)))) + (when (nth 4 eol-state) ; EOL is in a comment + (if (= (1- defs-eol) (nth 8 eol-state)) + ;; line ends with a naked comment starter. + ;; We let it start the here-doc. + (progn + (put-text-property (1- defs-eol) defs-eol + 'font-lock-face + 'font-lock-comment-face) + (put-text-property (1- defs-eol) defs-eol + 'syntax-type 'here-doc) + (put-text-property (1- defs-eol) defs-eol + 'syntax-type 'here-doc) + (put-text-property (1- defs-eol) defs-eol + 'syntax-table + (string-to-syntax "< c")) + ) + ;; line ends with a "regular" comment: make + ;; the last character of the comment closing + ;; it so that we can use the line feed to + ;; start the here-doc + (put-text-property (1- defs-eol) defs-eol + 'syntax-table + (string-to-syntax ">")))))) + (setq here-doc-start (point)) ; now points to current here-doc + ;; Find the terminating delimiter. + ;; We do not search to max, since we may be called from + ;; some hook of fontification, and max is random + (or (re-search-forward + (concat "^" (when indented-here-doc-p "[ \t]*") + qtag "$") + stop-point 'toend) + (progn ; Pretend we matched at the end + (goto-char (point-max)) + (re-search-forward "\\'") + (setq warning-message + (format "End of here-document `%s' not found." delimiter)) + (or (car err-l) (setcar err-l here-doc-start)))) + (when cperl-pod-here-fontify + ;; Highlight the ending delimiter + (cperl-postpone-fontification + (match-beginning 0) (match-end 0) + 'face my-cperl-delimiters-face) + (cperl-put-do-not-fontify here-doc-start (match-end 0) t)) + (setq here-doc-end (cperl-1+ (match-end 0))) ; eol after delim + (put-text-property here-doc-start (match-beginning 0) + 'syntax-type 'here-doc) + (put-text-property (match-beginning 0) here-doc-end + 'syntax-type 'here-doc-delim) + (put-text-property here-doc-start here-doc-end 'here-doc-group t) + ;; This makes insertion at the start of HERE-DOC update + ;; 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")) + (cperl-modify-syntax-type (1- (match-beginning 0)) + (string-to-syntax "> c"))) + (cperl-put-do-not-fontify here-doc-start (match-end 0) t) + ;; Cache the syntax info... + (setq cperl-syntax-state (cons state-point state)) + ;; ... and process the rest of the line... + (setq overshoot + (elt ; non-inter ignore-max + (cperl-find-pods-heres todo-pos defs-eol + t end t here-doc-end) + 1)) + (if (and overshoot (> overshoot (point))) + (goto-char overshoot) + (setq overshoot here-doc-end)) + (list (if (> here-doc-end max) matched-pos nil) + overshoot + warning-message))) + ;; Debugging this may require (setq max-specpdl-size 2000)... (defun cperl-find-pods-heres (&optional min max non-inter end ignore-max end-of-here-doc) - "Scans the buffer for hard-to-parse Perl constructions. -If `cperl-pod-here-fontify' is not-nil after evaluation, will fontify -the sections using `cperl-pod-head-face', `cperl-pod-face', -`cperl-here-face'." + "Scan the buffer for hard-to-parse Perl constructions. +If `cperl-pod-here-fontify' is non-nil after evaluation, +fontify the sections using `cperl-pod-head-face', +`cperl-pod-face', `cperl-here-face'. The optional parameters are +for internal use: scan from MIN to MAX, or the whole buffer if +these are nil. If NON-INTER, don't write progress messages. If +IGNORE-MAX, scan to end of buffer. If END, we are after a +\"__END__\" or \"__DATA__\" token, so ignore unbalanced +constructs. END-OF-HERE-DOC points to the end of a here-document +which has already been processed. +Value is a two-element list of the position where an error +occurred (if any) and the \"overshoot\", which is used for +recursive calls in starting lines of here-documents." (interactive) (or min (setq min (point-min) cperl-syntax-state nil cperl-syntax-done-to min)) (or max (setq max (point-max))) - (let* ((cperl-pod-here-fontify (eval cperl-pod-here-fontify)) go tmpend - face head-face here-face b e bb tag qtag b1 e1 argument i c tail tb + (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 (case-fold-search nil) (inhibit-read-only t) (buffer-undo-list t) (modified (buffer-modified-p)) overshoot is-o-REx name @@ -3591,7 +3834,8 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', "\\<" cperl-sub-regexp "\\>" ; sub with proto/attr "\\(" cperl-white-and-comment-rex - "\\(::[a-zA-Z_:'0-9]*\\|[a-zA-Z_'][a-zA-Z_:'0-9]*\\)\\)?" ; name + (rx (group (eval cperl--normal-identifier-rx))) + "\\)" "\\(" cperl-maybe-white-and-comment-rex "\\(([^()]*)\\|:[^:]\\)\\)" ; prototype or attribute start @@ -3619,20 +3863,20 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', (and cperl-pod-here-fontify ;; We had evals here, do not know why... (setq face cperl-pod-face - head-face cperl-pod-head-face - here-face cperl-here-face)) - (remove-text-properties min max - '(syntax-type t in-pod t syntax-table t - attrib-group t - REx-interpolated t - cperl-postpone t - syntax-subtype t - rear-nonsticky t - front-sticky t - here-doc-group t - first-format-line t - REx-part2 t - indentable t)) + head-face cperl-pod-head-face)) + (unless end-of-here-doc + (remove-text-properties min max + '(syntax-type t in-pod t syntax-table t + attrib-group t + REx-interpolated t + cperl-postpone t + syntax-subtype t + rear-nonsticky t + front-sticky t + here-doc-group t + first-format-line t + REx-part2 t + indentable t))) ;; Need to remove face as well... (goto-char min) (while (and @@ -3751,120 +3995,36 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', ;; but multiline quote on the same line as <<HERE confuses us... ;; ;; One extra () before this: ;;"<<" - ;; "\\(" ; 1 + 1 + ;; "<<\\(~?\\)" ; HERE-DOC, indented-p = capture 2 ;; ;; First variant "BLAH" or just ``. ;; "[ \t]*" ; Yes, whitespace is allowed! - ;; "\\([\"'`]\\)" ; 2 + 1 - ;; "\\([^\"'`\n]*\\)" ; 3 + 1 - ;; "\\3" + ;; "\\([\"'`]\\)" ; 3 + 1 + ;; "\\([^\"'`\n]*\\)" ; 4 + 1 + ;; "\\4" ;; "\\|" ;; ;; Second variant: Identifier or \ID or empty - ;; "\\\\?\\(\\([a-zA-Z_][a-zA-Z_0-9]*\\)?\\)" ; 4 + 1, 5 + 1 + ;; "\\\\?\\(\\([a-zA-Z_][a-zA-Z_0-9]*\\)?\\)" ; 5 + 1, 6 + 1 ;; ;; Do not have <<= or << 30 or <<30 or << $blah. ;; ;; "\\([^= \t0-9$@%&]\\|[ \t]+[^ \t\n0-9$@%&]\\)" ; 6 + 1 - ;; "\\(\\)" ; To preserve count of pars :-( 6 + 1 ;; "\\)" - ((match-beginning 3) ; 2 + 1: found "<<", detect its type - (setq b (point) - tb (match-beginning 0) - c (and ; not HERE-DOC - (match-beginning 6) - (save-match-data - (or (looking-at "[ \t]*(") ; << function_call() - (looking-at ">>") ; <<>> operator - (save-excursion ; 1 << func_name, or $foo << 10 - (condition-case nil - (progn - (goto-char tb) - ;;; XXX What to do: foo <<bar ??? - ;;; XXX Need to support print {a} <<B ??? - (forward-sexp -1) - (save-match-data - ; $foo << b; $f .= <<B; - ; ($f+1) << b; a($f) . <<B; - ; foo 1, <<B; $x{a} <<b; - (cond - ((looking-at "[0-9$({]") - (forward-sexp 1) - (and - (looking-at "[ \t]*<<") - (condition-case nil - ;; print $foo <<EOF - (progn - (forward-sexp -2) - (not - (looking-at "\\(printf?\\|say\\|system\\|exec\\|sort\\)\\>"))) - (error t))))))) - (error nil))) ; func(<<EOF) - (and (not (match-beginning 7)) ; Empty - (looking-at - "[ \t]*[=0-9$@%&(]")))))) - (if c ; Not here-doc - nil ; Skip it. - (setq c (match-end 3)) ; 2 + 1 - (if (match-beginning 6) ;6 + 1 - (setq b1 (match-beginning 6) ; 5 + 1 - e1 (match-end 6)) ; 5 + 1 - (setq b1 (match-beginning 5) ; 4 + 1 - e1 (match-end 5))) ; 4 + 1 - (setq tag (buffer-substring b1 e1) - qtag (regexp-quote tag)) - (cond (cperl-pod-here-fontify - ;; Highlight the starting delimiter - (cperl-postpone-fontification - b1 e1 'face my-cperl-delimiters-face) - (cperl-put-do-not-fontify b1 e1 t))) - (forward-line) - (setq i (point)) - (if end-of-here-doc - (goto-char end-of-here-doc)) - (setq b (point)) - ;; We do not search to max, since we may be called from - ;; some hook of fontification, and max is random - (or (and (re-search-forward - (concat "^" (when (equal (match-string 2) "~") "[ \t]*") - qtag "$") - stop-point 'toend) - ;;;(eq (following-char) ?\n) ; XXXX WHY??? - ) - (progn ; Pretend we matched at the end - (goto-char (point-max)) - (re-search-forward "\\'") - (setq warning-message - (format "End of here-document `%s' not found." tag)) - (or (car err-l) (setcar err-l b)))) - (if cperl-pod-here-fontify - (progn - ;; Highlight the ending delimiter - (cperl-postpone-fontification - (match-beginning 0) (match-end 0) - 'face my-cperl-delimiters-face) - (cperl-put-do-not-fontify b (match-end 0) t) - ;; Highlight the HERE-DOC - (cperl-postpone-fontification b (match-beginning 0) - 'face here-face))) - (setq e1 (cperl-1+ (match-end 0))) - (put-text-property b (match-beginning 0) - 'syntax-type 'here-doc) - (put-text-property (match-beginning 0) e1 - 'syntax-type 'here-doc-delim) - (put-text-property b e1 'here-doc-group t) - ;; This makes insertion at the start of HERE-DOC update - ;; the whole construct: - (put-text-property b (cperl-1+ b) 'front-sticky '(syntax-type)) - (cperl-commentify b e1 nil) - (cperl-put-do-not-fontify b (match-end 0) t) - ;; Cache the syntax info... - (setq cperl-syntax-state (cons state-point state)) - ;; ... and process the rest of the line... - (setq overshoot - (elt ; non-inter ignore-max - (cperl-find-pods-heres c i t end t e1) 1)) - (if (and overshoot (> overshoot (point))) - (goto-char overshoot) - (setq overshoot e1)) - (if (> e1 max) - (setq tmpend tb)))) + ((match-beginning 3) ; 2 + 1: found "<<", detect its type + (let* ((matched-pos (match-beginning 0)) + (quoted-delim-p (if (match-beginning 6) nil t)) + (delim-capture (if quoted-delim-p 5 6))) + (when (cperl-is-here-doc-p matched-pos) + (let ((here-doc-results + (cperl-process-here-doc + min max end overshoot stop-point ; for recursion + end-of-here-doc err-l ; for recursion + (equal (match-string 2) "~") ; indented here-doc? + matched-pos ; for recovery (?) + (match-end 3) ; todo from here + (match-beginning delim-capture) ; starting delimiter + (match-end delim-capture)))) ; boundaries + (setq tmpend (nth 0 here-doc-results) + overshoot (nth 1 here-doc-results)) + (and (nth 2 here-doc-results) + (setq warning-message (nth 2 here-doc-results))))))) ;; format ((match-beginning 8) ;; 1+6=7 extra () before this: @@ -3950,10 +4110,12 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', (t t)))) ;; <file> or <$file> (and (eq c ?\<) - ;; Do not stringify <FH>, <$fh> : + ;; Stringify what looks like a glob, but + ;; do not stringify file handles <FH>, <$fh> : (save-match-data (looking-at - "\\$?\\([_a-zA-Z:][_a-zA-Z0-9:]*\\)?>")))) + (rx (sequence (opt "$") + (eval cperl--normal-identifier-rx))))))) tb (match-beginning 0)) (goto-char (match-beginning b1)) (cperl-backward-to-noncomment (point-min)) @@ -4023,7 +4185,16 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', (error nil))) (if (or bb (looking-at ; $foo -> {s} - "[$@]\\$*\\([a-zA-Z0-9_:]+\\|[^{]\\)\\([ \t\n]*->\\)?[ \t\n]*{") + (rx + (sequence + (in "$@") (0+ "$") + (or + (eval cperl--normal-identifier-rx) + (not (in "{"))) + (opt (sequence (eval cperl--ws*-rx)) + "->") + (eval cperl--ws*-rx) + "{"))) (and ; $foo[12] -> {s} (memq (following-char) '(?\{ ?\[)) (progn @@ -4038,7 +4209,12 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', (setq bb t)) ((and (eq (following-char) ?:) (eq b1 ?\{) ; Check for $ { s::bar } - (looking-at "::[a-zA-Z0-9_:]*[ \t\n\f]*}") + ;; (looking-at "::[a-zA-Z0-9_:]*[ \t\n\f]*}") + (looking-at + (rx (sequence "::" + (eval cperl--normal-identifier-rx) + (eval cperl--ws*-rx) + "}"))) (progn (goto-char (1- go)) (skip-chars-backward " \t\n\f") @@ -4203,7 +4379,7 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', "\\(" ;; XXXX 1-char variables, exc. |()\s "[$@]" "\\(" - "[_a-zA-Z:][_a-zA-Z0-9:]*" + (rx (eval cperl--normal-identifier-rx)) "\\|" "{[^{}]*}" ; only one-level allowed "\\|" @@ -4642,19 +4818,24 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', (if (< p (point)) (goto-char p)) (setq stop t)))))) -;; Used only in `cperl-calculate-indent'... +;; Used only in `cperl-sniff-for-indent'... (defun cperl-block-p () - "Point is before ?\\{. Checks whether it starts a block." + "Point is before ?\\{. Return true if it starts a block." ;; No save-excursion! This is more a distinguisher of a block/hash ref... (cperl-backward-to-noncomment (point-min)) (or (memq (preceding-char) (append ";){}$@&%\C-@" nil)) ; Or label! \C-@ at bobp ; Label may be mixed up with `$blah :' (save-excursion (cperl-after-label)) + ;; text with the 'attrib-group property is also covered by the + ;; next clause. We keep it because it is faster (for + ;; subroutines with attributes). (get-text-property (cperl-1- (point)) 'attrib-group) + (save-excursion (cperl-block-declaration-p)) (and (memq (char-syntax (preceding-char)) '(?w ?_)) (progn (backward-sexp) ;; sub {BLK}, print {BLK} $data, but NOT `bless', `return', `tr', `constant' + ;; a-zA-Z is fine here, these are Perl keywords (or (and (looking-at "[a-zA-Z0-9_:]+[ \t\n\f]*[{#]") ; Method call syntax (not (looking-at "\\(bless\\|return\\|q[wqrx]?\\|tr\\|[smy]\\|constant\\)\\>"))) ;; sub bless::foo {} @@ -4672,7 +4853,7 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', ;; Moreover, one takes positive approach (looks for else,grep etc) ;; another negative (looks for bless,tr etc) (defun cperl-after-block-p (lim &optional pre-block) - "Return true if the preceding } (if PRE-BLOCK, following {) delimits a block. + "Return non-nil if the preceding } (if PRE-BLOCK, following {) delimits a block. Would not look before LIM. Assumes that LIM is a good place to begin a statement. The kind of block we treat here is one after which a new statement would start; thus the block in ${func()} does not count." @@ -4688,6 +4869,7 @@ statement would start; thus the block in ${func()} does not count." (save-excursion (cperl-after-label)) ;; sub :attr {} (get-text-property (cperl-1- (point)) 'attrib-group) + (save-excursion (cperl-block-declaration-p)) (if (memq (char-syntax (preceding-char)) '(?w ?_)) ; else {} (save-excursion (forward-sexp -1) @@ -4707,7 +4889,7 @@ statement would start; thus the block in ${func()} does not count." (error nil)))) (defun cperl-after-expr-p (&optional lim chars test) - "Return true if the position is good for start of expression. + "Return non-nil if the position is good for start of expression. TEST is the expression to evaluate at the found position. If absent, CHARS is a string that contains good characters to have before us (however, `}' is treated \"smartly\" if it is not in the list)." @@ -4803,7 +4985,8 @@ CHARS is a string that contains good characters to have before us (however, (skip-chars-forward " \t")) (defun cperl-after-block-and-statement-beg (lim) - ;; We assume that we are after ?\} + "Return non-nil if the preceding ?} ends the statement." + ;; We assume that we are after ?\} (and (cperl-after-block-p lim) (save-excursion @@ -4861,7 +5044,11 @@ conditional/loop constructs." cperl-maybe-white-and-comment-rex "\\(state\\|my\\|local\\|our\\)\\)?" cperl-maybe-white-and-comment-rex - "\\$[_a-zA-Z0-9]+\\)?\\)\\>")) + (rx + (sequence + "$" + (eval cperl--basic-identifier-rx))) + "\\)?\\)\\>")) (progn (goto-char top) (forward-sexp 1) @@ -4955,7 +5142,14 @@ Returns some position at the last line." ;; Looking at: ;; foreach my $var ( (if (looking-at - "[ \t]*\\<for\\(each\\)?[ \t]+\\(state\\|my\\|local\\|our\\)[ \t]*\\$[_a-zA-Z0-9]+\\(\t*\\|[ \t][ \t]+\\)[^ \t\n#]") + (rx (sequence (0+ blank) symbol-start + "for" (opt "each") + (1+ blank) + (or "state" "my" "local" "our") + (0+ blank) + "$" (eval cperl--basic-identifier-rx) + (1+ blank) + (not (in " \t\n#"))))) (progn (forward-sexp 3) (delete-horizontal-space) @@ -4965,9 +5159,25 @@ Returns some position at the last line." ;; Looking at (with or without "}" at start, ending after "({"): ;; } foreach my $var () OR { (if (looking-at - "[ \t]*\\(}[ \t]*\\)?\\<\\(els\\(e\\|if\\)\\|continue\\|if\\|unless\\|while\\|for\\(each\\)?\\(\\([ \t]+\\(state\\|my\\|local\\|our\\)\\)?[ \t]*\\$[_a-zA-Z0-9]+\\)?\\|until\\)\\>\\([ \t]*(\\|[ \t\n]*{\\)\\|[ \t]*{") + (rx (sequence + (0+ blank) + (opt (sequence "}" (0+ blank) )) + symbol-start + (or "else" "elsif" "continue" "if" "unless" "while" "until" + (sequence (or "for" "foreach") + (opt + (opt (sequence (1+ blank) + (or "state" "my" "local" "our"))) + (0+ blank) + "$" (eval cperl--basic-identifier-rx)))) + symbol-end + (group-n 1 + (or + (or (sequence (0+ blank) "(") + (sequence (eval cperl--ws*-rx) "{")) + (sequence (0+ blank) "{")))))) (progn - (setq ml (match-beginning 8)) ; "(" or "{" after control word + (setq ml (match-beginning 1)) ; "(" or "{" after control word (re-search-forward "[({]") (forward-char -1) (setq p (point)) @@ -5279,8 +5489,12 @@ indentation and initial hashes. Behaves usually outside of comment." ;; Previous space could have gone: (or (memq (preceding-char) '(?\s ?\t)) (insert " ")))))) +(defvar cperl-imenu-package-keywords '("package" "class" "role")) +(defvar cperl-imenu-sub-keywords '("sub" "method" "function" "fun")) +(defvar cperl-imenu-pod-keywords '("=head")) + (defun cperl-imenu--create-perl-index () - "Implement `imenu-create-index-function` for CPerl mode. + "Implement `imenu-create-index-function' for CPerl mode. This function relies on syntaxification to exclude lines which look like declarations but actually are part of a string, a comment, or POD." @@ -5297,20 +5511,21 @@ comment, or POD." (current-package "(main)") (current-package-end (point-max))) ; end of package scope ;; collect index entries - (while (re-search-forward cperl--imenu-entries-regexp nil t) + (while (re-search-forward (rx (eval cperl--imenu-entries-rx)) nil t) ;; First, check whether we have left the scope of previously ;; recorded packages, and if so, eliminate them from the stack. (while (< current-package-end (point)) (setq current-package (pop package-stack)) (setq current-package-end (pop package-stack))) (let ((state (syntax-ppss)) + (entry-type (match-string 1)) name marker) ; for the "current" entry (cond ((nth 3 state) nil) ; matched in a string, so skip - ((match-string 1) ; found a package name! + ((member entry-type cperl-imenu-package-keywords) ; package or class (unless (nth 4 state) ; skip if in a comment - (setq name (match-string-no-properties 1) - marker (copy-marker (match-end 1))) + (setq name (match-string-no-properties 2) + marker (copy-marker (match-end 2))) (if (string= (match-string 3) ";") (setq current-package name) ; package NAME; ;; No semicolon, therefore we have: package NAME BLOCK. @@ -5323,32 +5538,33 @@ comment, or POD." (setq current-package-end (save-excursion (goto-char (match-beginning 3)) (forward-sexp) - (point))) + (point)))) (push (cons name marker) index-package-alist) - (push (cons (concat "package " name) marker) index-unsorted-alist)))) - ((match-string 5) ; found a sub name! + (push (cons (concat entry-type " " name) marker) index-unsorted-alist))) + ((or (member entry-type cperl-imenu-sub-keywords) ; sub or method + (string-equal entry-type "")) ; named blocks (unless (nth 4 state) ; skip if in a comment - (setq name (match-string-no-properties 5) - marker (copy-marker (match-end 5))) + (setq name (match-string-no-properties 2) + marker (copy-marker (match-end 2))) ;; Qualify the sub name with the package if it doesn't ;; already have one, and if it isn't lexically scoped. ;; "my" and "state" subs are lexically scoped, but "our" ;; are just lexical aliases to package subs. (if (and (null (string-match "::" name)) - (or (null (match-string 4)) - (string-equal (match-string 4) "our"))) + (or (null (match-string 3)) + (string-equal (match-string 3) "our"))) (setq name (concat current-package "::" name))) (let ((index (cons name marker))) (push index index-alist) (push index index-sub-alist) (push index index-unsorted-alist)))) - ((match-string 6) ; found a POD heading! - (when (get-text-property (match-beginning 6) 'in-pod) + ((member entry-type cperl-imenu-pod-keywords) ; POD heading + (when (get-text-property (match-beginning 2) 'in-pod) (setq name (concat (make-string - (* 3 (- (char-after (match-beginning 6)) ?1)) + (* 3 (- (char-after (match-beginning 3)) ?1)) ?\ ) - (match-string-no-properties 7)) - marker (copy-marker (match-beginning 7))) + (match-string-no-properties 2)) + marker (copy-marker (match-beginning 2))) (push (cons name marker) index-pod-alist) (push (cons (concat "=" name) marker) index-unsorted-alist))) (t (error "Unidentified match: %s" (match-string 0)))))) @@ -5371,7 +5587,11 @@ comment, or POD." (setq lst index-sub-alist) (while lst (setq elt (car lst) lst (cdr lst)) - (cond ((string-match "\\(::\\|'\\)[_a-zA-Z0-9]+$" (car elt)) + (cond ((string-match + (rx (sequence (or "::" "'") + (eval cperl--basic-identifier-rx) + string-end)) + (car elt)) (setq pack (substring (car elt) 0 (match-beginning 0))) (if (setq group (assoc pack hier-list)) (if (listp (cdr group)) @@ -5444,7 +5664,7 @@ comment, or POD." (defvar cperl-font-lock-keywords nil "Additional expressions to highlight in Perl mode. Default set.") (defvar cperl-font-lock-keywords-2 nil - "Additional expressions to highlight in Perl mode. Maximal set") + "Additional expressions to highlight in Perl mode. Maximal set.") (defun cperl-load-font-lock-keywords () (or cperl-faces-init (cperl-init-faces)) @@ -5458,11 +5678,22 @@ comment, or POD." (or cperl-faces-init (cperl-init-faces)) cperl-font-lock-keywords-2) +(defun cperl-font-lock-syntactic-face-function (state) + "Apply faces according to their syntax type. +In CPerl mode, this is used for here-documents which have been +marked as c-style comments. For everything else, delegate to the +default function." + (cond + ;; A c-style comment is a HERE-document. Fontify if requested. + ((and (eq 2 (nth 7 state)) + cperl-pod-here-fontify) + cperl-here-face) + (t (funcall (default-value 'font-lock-syntactic-face-function) state)))) + (defun cperl-init-faces () (condition-case errs (progn - (let (t-font-lock-keywords t-font-lock-keywords-1 font-lock-anchored) - (setq font-lock-anchored t) + (let (t-font-lock-keywords t-font-lock-keywords-1) (setq t-font-lock-keywords (list @@ -5575,105 +5806,188 @@ comment, or POD." (if (eq (char-after (cperl-1- (match-end 0))) ?\{ ) 'font-lock-function-name-face 'font-lock-variable-name-face)))) - '("\\<\\(package\\|require\\|use\\|import\\|no\\|bootstrap\\)[ \t]+\\([a-zA-Z_][a-zA-Z_0-9:]*\\)[ \t;]" ; require A if B; - 2 font-lock-function-name-face) + `(,(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; + 1 font-lock-function-name-face) '("^[ \t]*format[ \t]+\\([a-zA-Z_][a-zA-Z_0-9:]*\\)[ \t]*=[ \t]*$" 1 font-lock-function-name-face) - (cond (font-lock-anchored - '("\\([]}\\%@>*&]\\|\\$[a-zA-Z0-9_:]*\\)[ \t]*{[ \t]*\\(-?[a-zA-Z0-9_:]+\\)[ \t]*}" - (2 font-lock-string-face t) - ("\\=[ \t]*{[ \t]*\\(-?[a-zA-Z0-9_:]+\\)[ \t]*}" - nil nil - (1 font-lock-string-face t)))) - (t '("\\([]}\\%@>*&]\\|\\$[a-zA-Z0-9_:]*\\)[ \t]*{[ \t]*\\(-?[a-zA-Z0-9_:]+\\)[ \t]*}" - 2 font-lock-string-face t))) - '("[[ \t{,(]\\(-?[a-zA-Z0-9_:]+\\)[ \t]*=>" 1 - font-lock-string-face t) - '("^[ \t]*\\([a-zA-Z0-9_]+[ \t]*:\\)[ \t]*\\($\\|{\\|\\<\\(until\\|while\\|for\\(each\\)?\\|do\\)\\>\\)" 1 - font-lock-constant-face) ; labels - '("\\<\\(continue\\|next\\|last\\|redo\\|break\\|goto\\)\\>[ \t]+\\([a-zA-Z0-9_:]+\\)" ; labels as targets - 2 font-lock-constant-face) + ;; bareword hash key: $foo{bar} + `(,(rx (or (in "]}\\%@>*&") ; What Perl is this? + (sequence "$" (eval cperl--normal-identifier-rx))) + (0+ blank) "{" (0+ blank) + (group-n 1 (sequence (opt "-") + (eval cperl--basic-identifier-rx))) + (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} + (,(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]*}" + 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 + `(,(rx + (sequence + (0+ space) + (group (eval cperl--label-rx)) + (0+ space) + (or line-end "#" "{" + (sequence word-start + (or "until" "while" "for" "foreach" "do") + word-end)))) + 1 font-lock-constant-face) + ;; labels as targets (no trailing colon!) + `(,(rx + (sequence + symbol-start + (or "continue" "next" "last" "redo" "break" "goto") + (1+ space) + (group (eval cperl--basic-identifier-rx)))) + 1 font-lock-constant-face) ;; Uncomment to get perl-mode-like vars ;;; '("[$*]{?\\(\\sw+\\)" 1 font-lock-variable-name-face) ;;; '("\\([@%]\\|\\$#\\)\\(\\sw+\\)" ;;; (2 (cons font-lock-variable-name-face '(underline)))) - (cond (font-lock-anchored ;; 1=my_etc, 2=white? 3=(+white? 4=white? 5=var - `(,(concat "\\<\\(state\\|my\\|local\\|our\\)" - cperl-maybe-white-and-comment-rex - "\\((" - cperl-maybe-white-and-comment-rex - "\\)?\\([$@%*]\\([a-zA-Z0-9_:]+\\|[^a-zA-Z0-9_]\\)\\)") - (5 ,(if cperl-font-lock-multiline - 'font-lock-variable-name-face - '(progn (setq cperl-font-lock-multiline-start - (match-beginning 0)) - 'font-lock-variable-name-face))) - (,(concat "\\=" - cperl-maybe-white-and-comment-rex - "," - cperl-maybe-white-and-comment-rex - "\\([$@%*]\\([a-zA-Z0-9_:]+\\|[^a-zA-Z0-9_]\\)\\)") - ;; 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 cperl-font-lock-multiline - '(if (match-beginning 3) - (save-excursion - (goto-char (match-beginning 3)) - (condition-case nil - (forward-sexp 1) - (error - (condition-case nil - (forward-char 200) - (error nil)))) ; typeahead - (1- (point))) ; report limit - (forward-char -2)) ; disable continued expr - '(if (match-beginning 3) - (point-max) ; No limit for continuation - (forward-char -2))) ; disable continued expr - ,(if cperl-font-lock-multiline - nil - '(progn ; Do at end - ;; "my" may be already fontified (POD), - ;; so cperl-font-lock-multiline-start is nil - (if (or (not cperl-font-lock-multiline-start) - (> 2 (count-lines - cperl-font-lock-multiline-start - (point)))) - nil - (put-text-property - (1+ cperl-font-lock-multiline-start) (point) - 'syntax-type 'multiline)) - (setq cperl-font-lock-multiline-start nil))) - (3 font-lock-variable-name-face)))) - (t '("^[ \t{}]*\\(state\\|my\\|local\\|our\\)[ \t]*\\(([ \t]*\\)?\\([$@%*][a-zA-Z0-9_:]+\\)" - 3 font-lock-variable-name-face))) - '("\\<for\\(each\\)?\\([ \t]+\\(state\\|my\\|local\\|our\\)\\)?[ \t]*\\(\\$[a-zA-Z_][a-zA-Z_0-9]*\\)[ \t]*(" - 4 font-lock-variable-name-face) + `(,(rx (sequence (or "state" "my" "local" "our")) + (eval cperl--ws*-rx) + (opt (sequence "(" (eval cperl--ws*-rx))) + (group + (in "$@%*") + (or + (eval cperl--normal-identifier-rx) + (eval cperl--special-identifier-rx)) + ) + ) + ;; (concat "\\<\\(state\\|my\\|local\\|our\\)" + ;; cperl-maybe-white-and-comment-rex + ;; "\\((" + ;; cperl-maybe-white-and-comment-rex + ;; "\\)?\\([$@%*]\\([a-zA-Z0-9_:]+\\|[^a-zA-Z0-9_]\\)\\)") + ;; (5 ,(if cperl-font-lock-multiline + (1 ,(if cperl-font-lock-multiline + 'font-lock-variable-name-face + '(progn (setq cperl-font-lock-multiline-start + (match-beginning 0)) + 'font-lock-variable-name-face))) + (,(rx (sequence point + (eval cperl--ws*-rx) + "," + (eval cperl--ws*-rx) + (group + (in "$@%*") + (or + (eval cperl--normal-identifier-rx) + (eval cperl--special-identifier-rx)) + ) + ) + ) + ;; ,(concat "\\=" + ;; cperl-maybe-white-and-comment-rex + ;; "," + ;; cperl-maybe-white-and-comment-rex + ;; "\\([$@%*]\\([a-zA-Z0-9_:]+\\|[^a-zA-Z0-9_]\\)\\)") + ;; 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 cperl-font-lock-multiline + '(if (match-beginning 1) + (save-excursion + (goto-char (match-beginning 1)) + (condition-case nil + (forward-sexp 1) + (error + (condition-case nil + (forward-char 200) + (error nil)))) ; typeahead + (1- (point))) ; report limit + (forward-char -2)) ; disable continued expr + '(if (match-beginning 1) + (point-max) ; No limit for continuation + (forward-char -2))) ; disable continued expr + ,(if cperl-font-lock-multiline + nil + '(progn ; Do at end + ;; "my" may be already fontified (POD), + ;; so cperl-font-lock-multiline-start is nil + (if (or (not cperl-font-lock-multiline-start) + (> 2 (count-lines + cperl-font-lock-multiline-start + (point)))) + nil + (put-text-property + (1+ cperl-font-lock-multiline-start) (point) + 'syntax-type 'multiline)) + (setq cperl-font-lock-multiline-start nil))) + (1 font-lock-variable-name-face))) + ;; foreach my $foo ( + `(,(rx symbol-start "for" (opt "each") + (opt (sequence (1+ blank) + (or "state" "my" "local" "our"))) + (0+ blank) + (group-n 1 (sequence "$" + (eval cperl--basic-identifier-rx))) + (0+ blank) "(") +;; '("\\<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 '("\\(?:^\\|[^smywqrx$]\\)\\(!\\)" 1 font-lock-negation-char-face) '("\\[\\(\\^\\)" 1 font-lock-negation-char-face prepend))) (setq t-font-lock-keywords-1 - '( - ("\\(\\([@%]\\|\\$#\\)[a-zA-Z_:][a-zA-Z0-9_:]*\\)" 1 + `( + ;; arrays and hashes. Access to elements is fixed below + (,(rx (group-n 1 (group-n 2 (or (in "@%") "$#")) + (eval cperl--normal-identifier-rx))) + 1 +;; ("\\(\\([@%]\\|\\$#\\)[a-zA-Z_:][a-zA-Z0-9_:]*\\)" 1 (if (eq (char-after (match-beginning 2)) ?%) 'cperl-hash-face 'cperl-array-face) nil) ; arrays and hashes - ("\\(\\([$@%]+\\)[a-zA-Z_:][a-zA-Z0-9_:]*\\)[ \t]*\\([[{]\\)" + ;; access to array/hash elements + (,(rx (group-n 1 (group-n 2 (in "$@%")) + (eval cperl--normal-identifier-rx)) + (0+ blank) + (group-n 3 (in "[{"))) +;; ("\\(\\([$@%]+\\)[a-zA-Z_:][a-zA-Z0-9_:]*\\)[ \t]*\\([[{]\\)" 1 (if (= (- (match-end 2) (match-beginning 2)) 1) (if (eq (char-after (match-beginning 3)) ?{) 'cperl-hash-face 'cperl-array-face) ; arrays and hashes font-lock-variable-name-face) ; Just to put something - t) - ("\\(@\\|\\$#\\)\\(\\$+\\([a-zA-Z_:][a-zA-Z0-9_:]*\\|[^ \t\n]\\)\\)" + t) ; override previous + ;; @$ array dereferences, $#$ last array index + (,(rx (group-n 1 (or "@" "$#")) + (group-n 2 (sequence "$" + (or (eval cperl--normal-identifier-rx) + (not (in " \t\n")))))) + ;; ("\\(@\\|\\$#\\)\\(\\$+\\([a-zA-Z_:][a-zA-Z0-9_:]*\\|[^ \t\n]\\)\\)" (1 'cperl-array-face) (2 font-lock-variable-name-face)) - ("\\(%\\)\\(\\$+\\([a-zA-Z_:][a-zA-Z0-9_:]*\\|[^ \t\n]\\)\\)" + ;; %$ hash dereferences + (,(rx (group-n 1 "%") + (group-n 2 (sequence "$" + (or (eval cperl--normal-identifier-rx) + (not (in " \t\n")))))) + ;; ("\\(%\\)\\(\\$+\\([a-zA-Z_:][a-zA-Z0-9_:]*\\|[^ \t\n]\\)\\)" (1 'cperl-hash-face) (2 font-lock-variable-name-face)) ;;("\\([smy]\\|tr\\)\\([^a-z_A-Z0-9]\\)\\(\\([^\n\\]*||\\)\\)\\2") @@ -6048,7 +6362,7 @@ side-effect of memorizing only. Examples in `cperl-style-examples'." (filename nodename &optional no-going-back strict-case)) (defun cperl-info-buffer (type) - ;; Returns buffer with documentation. Creates if missing. + ;; Return buffer with documentation. Creates if missing. ;; If TYPE, this vars buffer. ;; Special care is taken to not stomp over an existing info buffer (let* ((bname (if type "*info-perl-var*" "*info-perl*")) @@ -6182,7 +6496,7 @@ Customized by setting variables `cperl-shrink-wrap-info-frame', (declare-function imenu-choose-buffer-index "imenu" (&optional prompt alist)) (defun cperl-imenu-on-info () - "Shows imenu for Perl Info Buffer. + "Show imenu for Perl Info Buffer. Opens Perl Info buffer if needed." (interactive) (require 'imenu) @@ -6235,6 +6549,8 @@ Will not move the position at the start to the left." (indent-region beg end nil) (goto-char beg) (setq col (current-column)) + ;; Assuming that lineup is done on Perl syntax, this regexp + ;; doesn't need to be unicode aware -- haj, 2021-09-10 (if (looking-at "[a-zA-Z0-9_]") (if (looking-at "\\<[a-zA-Z0-9_]+\\>") (setq search @@ -6272,6 +6588,9 @@ Will not move the position at the start to the left." "Run etags with appropriate options for Perl files. If optional argument ALL is `recursive', will process Perl files in subdirectories too." + ;; Apparently etags doesn't support UTF-8 encoded sources, and usage + ;; of etags has been commented out in the menu since ... well, + ;; forever. So, let's just stick to ASCII here. -- haj, 2021-09-14 (interactive) (let ((cmd "etags") (args `("-l" "none" "-r" @@ -6411,6 +6730,9 @@ Does not move point." ;; Search for the function (progn ;;save-match-data (while (re-search-forward + ;; FIXME: Should XS code be unicode aware? Recent C + ;; compilers (Gcc 10+) are, but I guess this isn't used + ;; much. -- haj, 2021-09-14 "^\\([ \t]*MODULE\\>[^\n]*\\<PACKAGE[ \t]*=[ \t]*\\([a-zA-Z_][a-zA-Z_0-9:]*\\)\\>\\|\\([a-zA-Z_][a-zA-Z_0-9]*\\)(\\|[ \t]*BOOT:\\)" nil t) (cond @@ -6473,7 +6795,7 @@ Does not move point." (setq lst (mapcar (lambda (elt) - (cond ((string-match "^[_a-zA-Z]" (car elt)) + (cond ((string-match (rx line-start (or alpha "_")) (car elt)) (goto-char (cdr elt)) (beginning-of-line) ; pos should be of the start of the line (list (car elt) @@ -6503,9 +6825,14 @@ Does not move point." "," (number-to-string (1- (elt elt 1))) ; Char pos 0-based "\n") - (if (and (string-match "^[_a-zA-Z]+::" (car elt)) - (string-match (concat "^" cperl-sub-regexp "[ \t]+\\([_a-zA-Z]+\\)[^:_a-zA-Z]") - (elt elt 3))) + (if (and (string-match (rx line-start + (eval cperl--basic-identifier-rx) "++") + (car elt)) + (string-match (rx-to-string `(sequence line-start + (regexp ,cperl-sub-regexp) + (1+ (in " \t")) + ,cperl--normal-identifier-rx)) + (elt elt 3))) ;; Need to insert the name without package as well (setq lst (cons (cons (substring (elt elt 3) (match-beginning 1) @@ -6530,8 +6857,7 @@ Does not move point." "Add to TAGS data for \"pure\" Perl files in the current directory and kids. Use as emacs -batch -q -no-site-file -l emacs/cperl-mode.el \\ - -f cperl-add-tags-recurse-noxs -" + -f cperl-add-tags-recurse-noxs" (cperl-write-tags nil nil t t nil t)) (defun cperl-add-tags-recurse-noxs-fullpath () @@ -6539,16 +6865,14 @@ Use as Writes down fullpath, so TAGS is relocatable (but if the build directory is relocated, the file TAGS inside it breaks). Use as emacs -batch -q -no-site-file -l emacs/cperl-mode.el \\ - -f cperl-add-tags-recurse-noxs-fullpath -" + -f cperl-add-tags-recurse-noxs-fullpath" (cperl-write-tags nil nil t t nil t "")) (defun cperl-add-tags-recurse () "Add to TAGS file data for Perl files in the current directory and kids. Use as emacs -batch -q -no-site-file -l emacs/cperl-mode.el \\ - -f cperl-add-tags-recurse -" + -f cperl-add-tags-recurse" (cperl-write-tags nil nil t t)) (defvar cperl-tags-file-name "TAGS" @@ -6958,14 +7282,14 @@ Currently it is tuned to C and Perl syntax." ;;(concat "\\(" (mapconcat #'identity - '("[$@%*&][0-9a-zA-Z_:]+\\([ \t]*[[{]\\)?" ; Usual variable + '("[$@%*&][[:alnum:]_:]+\\([ \t]*[[{]\\)?" ; Usual variable "[$@]\\^[a-zA-Z]" ; Special variable "[$@][^ \n\t]" ; Special variable "-[a-zA-Z]" ; File test "\\\\[a-zA-Z0]" ; Special chars "^=[a-z][a-zA-Z0-9_]*" ; POD sections "[-!&*+,./<=>?\\^|~]+" ; Operator - "[a-zA-Z_0-9:]+" ; symbol or number + "[[:alnum:]_:]+" ; symbol or number "x=" "#!") ;;"\\)\\|\\(" @@ -6981,7 +7305,7 @@ Currently it is tuned to C and Perl syntax." ;; Does not save-excursion ;; Get to the something meaningful (or (eobp) (eolp) (forward-char 1)) - (re-search-backward "[-a-zA-Z0-9_:!&*+,./<=>?\\^|~$%@]" + (re-search-backward "[-[:alnum:]_:!&*+,./<=>?\\^|~$%@]" (point-at-bol) 'to-beg) ;; (cond @@ -6990,8 +7314,8 @@ Currently it is tuned to C and Perl syntax." ;; (or (bobp) (backward-char 1)))) ;; Try to backtrace (cond - ((looking-at "[a-zA-Z0-9_:]") ; symbol - (skip-chars-backward "a-zA-Z0-9_:") + ((looking-at "[[:alnum:]_:]") ; symbol + (skip-chars-backward "[:alnum:]_:") (cond ((and (eq (preceding-char) ?^) ; $^I (eq (char-after (- (point) 2)) ?\$)) @@ -7002,7 +7326,7 @@ Currently it is tuned to C and Perl syntax." (eq (current-column) 1)) (forward-char -1))) ; =head1 (if (and (eq (preceding-char) ?\<) - (looking-at "\\$?[a-zA-Z0-9_:]+>")) ; <FH> + (looking-at "\\$?[[:alnum:]_:]+>")) ; <FH> (forward-char -1))) ((and (looking-at "=") (eq (preceding-char) ?x)) ; x= (forward-char -1)) @@ -7015,15 +7339,15 @@ Currently it is tuned to C and Perl syntax." (not (eq (char-after (- (point) 2)) ?\$))) ; $- (forward-char -1)) ((and (eq (following-char) ?\>) - (string-match "[a-zA-Z0-9_]" (char-to-string (preceding-char))) + (string-match "[[:alnum:]_]" (char-to-string (preceding-char))) (save-excursion (forward-sexp -1) (and (eq (preceding-char) ?\<) - (looking-at "\\$?[a-zA-Z0-9_:]+>")))) ; <FH> + (looking-at "\\$?[[:alnum:]_:]+>")))) ; <FH> (search-backward "<")))) ((and (eq (following-char) ?\$) (eq (preceding-char) ?\<) - (looking-at "\\$?[a-zA-Z0-9_:]+>")) ; <$fh> + (looking-at "\\$?[[:alnum:]_:]+>")) ; <$fh> (forward-char -1))) (if (looking-at cperl-have-help-regexp) (buffer-substring (match-beginning 0) (match-end 0)))) @@ -7532,11 +7856,10 @@ prototype \\&SUB Returns prototype of the function given a reference. =begin formatname Start directly formatted region. =end formatname End directly formatted region. =for formatname text Paragraph in special format. -=encoding encodingname Encoding of the document. -") +=encoding encodingname Encoding of the document.") (defun cperl-switch-to-doc-buffer (&optional interactive) - "Go to the perl documentation buffer and insert the documentation." + "Go to the Perl documentation buffer and insert the documentation." (interactive "p") (let ((buf (get-buffer-create cperl-doc-buffer))) (if interactive @@ -8195,7 +8518,7 @@ If a region is highlighted, restricts to the region." beg end)))) (defun cperl-map-pods-heres (func &optional prop s end) - "Executes a function over regions of pods or here-documents. + "Execute a function over regions of pods or here-documents. PROP is the text-property to search for; default to `in-pod'. Stop when function returns nil." (let (pos posend has-prop (cont t)) @@ -8370,7 +8693,7 @@ Delay of auto-help controlled by `cperl-lazy-help-time'." (remove-text-properties beg end '(face nil)))) (defun cperl-font-lock-fontify-region-function (beg end loudly) - "Extends the region to safe positions, then calls the default function. + "Extend the region to safe positions, then call the default function. Newer `font-lock's can do it themselves. We unwind only as far as needed for fontification. Syntaxification may do extra unwind via `cperl-unwind-to-safe'." |