From 5dc2b5a210287cb063573ae1cfa13dbab44c2fc6 Mon Sep 17 00:00:00 2001 From: Don Armstrong Date: Mon, 24 Jul 2006 05:41:07 +0000 Subject: [PATCH] * update cperl mode --- emacs_el/cperl-mode.el | 968 +++++++++++++++++++++++++++++------------ 1 file changed, 691 insertions(+), 277 deletions(-) diff --git a/emacs_el/cperl-mode.el b/emacs_el/cperl-mode.el index 1cc2f17..e9ef085 100644 --- a/emacs_el/cperl-mode.el +++ b/emacs_el/cperl-mode.el @@ -45,7 +45,7 @@ ;;; Commentary: -;; $Id: cperl-mode.el,v 5.16 2006/02/21 11:18:21 vera Exp vera $ +;; $Id: cperl-mode.el,v 5.19 2006/06/01 11:11:57 vera Exp vera $ ;;; If your Emacs does not default to `cperl-mode' on Perl files: ;;; To use this mode put the following into @@ -1401,6 +1401,54 @@ ;;; Highlight many others 0-length builtins ;;; `cperl-praise': Mention indenting and highlight in RExen. +;;; After 5.15: +;;; `cperl-find-pods-heres': Highlight capturing parens in REx + +;;; After 5.16: +;;; `cperl-find-pods-heres': Highlight '|' for alternation +;;; Initialize `font-lock-warning-face' if not present +;;; `cperl-find-pods-heres': Use `font-lock-warning-face' instead of +;;; `font-lock-function-name-face' +;;; `cperl-look-at-leading-count': Likewise +;;; `cperl-find-pods-heres': localize `font-lock-variable-name-face' +;;; `font-lock-keyword-face' (needed for +;;; batch processing) etc +;;; Use `font-lock-builtin-face' for builtin in REx +;;; Now `font-lock-variable-name-face' +;;; is used for interpolated variables. +;;; Use "talking aliases" for faces inside REx +;;; Highlight parts of REx (except in charclasses) +;;; according to the syntax and/or semantic +;;; Syntax-mark a {}-part of (?{}) as "comment" +;;; (it was the ()-part) +;;; Better logic to distinguish what is what in REx +;;; `cperl-tips-faces': Document REx highlighting +;;; `cperl-praise': Mention REx syntax highlight etc. + +;;; After 5.17: +;;; `cperl-find-sub-attrs': Would not always manage to print error message +;;; `cperl-find-pods-heres': localize `font-lock-constant-face' + +;;; After 5.18: +;;; `cperl-find-pods-heres': Misprint in REx for parsing REx +;;; Very minor optimization +;;; `my-cperl-REx-modifiers-face' got quoted +;;; Recognize "print $foo < `sub-decl'. ;; f) Multiline my/our declaration lists etc: `syntax-type' => `multiline' +;;; In addition, some parts of RExes may be marked as `REx-interpolated' +;;; (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)) opos) @@ -4897,9 +4996,15 @@ Works before syntax recognition is done." (setq end (point))))) (or end pos))))) +;;; These are needed for byte-compile (at least with v19) (defvar cperl-nonoverridable-face) +(defvar font-lock-variable-name-face) (defvar font-lock-function-name-face) +(defvar font-lock-keyword-face) +(defvar font-lock-builtin-face) +(defvar font-lock-type-face) (defvar font-lock-comment-face) +(defvar font-lock-warning-face) (defun cperl-find-sub-attrs (&optional st-l b-fname e-fname pos) "Syntaxically mark (and fontify) attributes of a subroutine. @@ -4941,7 +5046,8 @@ Should be called with the point before leading colon of an attribute." (setq after-first t)) (error (message "L%d: attribute `%s': %s" - (count-lines (point-min) (point)) (buffer-substring start1 end1) b) + (count-lines (point-min) (point)) + (and start1 end1 (buffer-substring start1 end1)) b) (setq start nil))) (and start (progn @@ -4972,7 +5078,7 @@ Should be called with the point before leading colon of an attribute." (if (eq ?\{ (preceding-char)) nil (cperl-postpone-fontification (1- (point)) (point) - 'face font-lock-function-name-face)))) + 'face font-lock-warning-face)))) ;;; 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) @@ -4989,7 +5095,7 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', face head-face here-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 + (modified (buffer-modified-p)) overshoot is-o-REx (after-change-functions nil) (cperl-font-locking t) (use-syntax-state (and cperl-syntax-state @@ -5002,24 +5108,53 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', ;; (st-l '(nil)) (err-l '(nil)) ; Would overwrite - propagates from a function call to a function call! (st-l (list nil)) (err-l (list nil)) ;; Somehow font-lock may be not loaded yet... + ;; (e.g., when building TAGS via command-line call) (font-lock-string-face (if (boundp 'font-lock-string-face) font-lock-string-face 'font-lock-string-face)) - (font-lock-constant-face (if (boundp 'font-lock-constant-face) + (my-cperl-delimiters-face (if (boundp 'font-lock-constant-face) font-lock-constant-face 'font-lock-constant-face)) - (font-lock-function-name-face + (my-cperl-REx-spec-char-face ; [] ^.$ and wrapper-of ({}) + (if (boundp 'font-lock-function-name-face) + font-lock-function-name-face + 'font-lock-function-name-face)) + (font-lock-variable-name-face ; interpolated vars and ({})-code + (if (boundp 'font-lock-variable-name-face) + font-lock-variable-name-face + 'font-lock-variable-name-face)) + (font-lock-function-name-face ; used in `cperl-find-sub-attrs' (if (boundp 'font-lock-function-name-face) font-lock-function-name-face 'font-lock-function-name-face)) + (font-lock-constant-face ; used in `cperl-find-sub-attrs' + (if (boundp 'font-lock-constant-face) + font-lock-constant-face + 'font-lock-constant-face)) + (my-cperl-REx-0length-face ; 0-length, (?:)etc, non-literal \ + (if (boundp 'font-lock-builtin-face) + font-lock-builtin-face + 'font-lock-builtin-face)) (font-lock-comment-face (if (boundp 'font-lock-comment-face) font-lock-comment-face 'font-lock-comment-face)) - (cperl-nonoverridable-face + (font-lock-warning-face + (if (boundp 'font-lock-warning-face) + font-lock-warning-face + 'font-lock-warning-face)) + (my-cperl-REx-ctl-face ; (|) + (if (boundp 'font-lock-keyword-face) + font-lock-keyword-face + 'font-lock-keyword-face)) + (my-cperl-REx-modifiers-face ; //gims (if (boundp 'cperl-nonoverridable-face) cperl-nonoverridable-face 'cperl-nonoverridable-face)) + (my-cperl-REx-length1-face ; length=1 escaped chars, POSIX classes + (if (boundp 'font-lock-type-face) + font-lock-type-face + 'font-lock-type-face)) (stop-point (if ignore-max (point-max) max)) @@ -5090,6 +5225,7 @@ the sections using `cperl-pod-head-face', `cperl-pod-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 @@ -5169,6 +5305,7 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', (remove-text-properties max e '(syntax-type t in-pod t syntax-table t attrib-group t + REx-interpolated t cperl-postpone t syntax-subtype t here-doc-group t @@ -5256,7 +5393,15 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', (cond ((looking-at "[0-9$({]") (forward-sexp 1) - (looking-at "[ \t]*<<"))))) + (and + (looking-at "[ \t]*<<") + (condition-case nil + ;; print $foo <"))) + (error t))))))) (error nil))) ; func(<"))) (error t)))) (cperl-postpone-fontification - b e 'face font-lock-function-name-face) + b e 'face font-lock-warning-face) (if (or i2 ; Has 2 args (and cperl-fontify-m-as-s (or @@ -5613,11 +5763,17 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', (not (eq ?\< (char-after b))))))) (progn (cperl-postpone-fontification - b (cperl-1+ b) 'face font-lock-constant-face) + b (cperl-1+ b) 'face my-cperl-delimiters-face) (cperl-postpone-fontification - (1- e) e 'face font-lock-constant-face))) + (1- e) e 'face my-cperl-delimiters-face))) (if (and is-REx cperl-regexp-scan) ;; Process RExen: embedded comments, charclasses and ] +;;;/\3333\xFg\x{FFF}a\ppp\PPP\qqq\C\99f(?{ foo })(??{ foo })/; +;;;/a\.b[^a[:ff:]b]x$ab->$[|$,$ab->[cd]->[ef]|$ab[xy].|^${a,b}{c,d}/; +;;;/(?<=foo)(?" "\\)?" + "\\[[^][]*\\]" + "\\|" + "{[^{}]*}" + "\\)*" ;; XXXX: what if u is delim? - "\\(" - "[)^$|]" "\\|" - "[*?+]" ; Do not need \?? ! + "[)^|$.*?+]" "\\|" "{[0-9]+}" "\\|" @@ -5649,232 +5826,287 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', "\\|" "\\\\[luLUEQbBAzZG]" "\\|" - "(" - "\\(" - "\\?[:=!>]" + "(" ; Group opener + "\\(" ; 10 group opener follower + "\\?\\((\\?\\)" ; 11: in (?(?=C)A|B) + "\\|" + "\\?[:=!>?{]" ; "?" something "\\|" "\\?[-imsx]+[:)]" ; (?i) (?-s:.) "\\|" "\\?([0-9]+)" ; (?(1)foo|bar) "\\|" "\\?<[=!]" - "\\|" - "\\?" ; (?(?=foo)bar|baz) + ;;;"\\|" + ;;; "\\?" "\\)?" "\\)" - ;; XXXX Need {5,6}? "\\|" - "\\\\\\(.\\)" ; 7=\SYMBOL - ;; XXXX Will not be able to use it in s))) - (if (eq (char-after b) ?\) ) "" - (concat - "\\|" - (if (eq (char-after b) ?? ) ; 8 = (?{ - "\\((\\\\\\?\\(\\\\\\?\\)?{\\)" - "\\((\\?\\(\\?\\)?{\\)"))))) ; 8 = opt ? + "\\\\\\(.\\)" ; 12=\SYMBOL + )) (while (and (< (point) (1- e)) (re-search-forward hairy-RE (1- e) 'to-end)) (goto-char (match-beginning 0)) (setq REx-subgr-start (point) - was-subgr t) - (if (save-excursion - (and - nil ; Not needed now, when we skip \SYMBOL - (/= (1+ b) (point)) ; \ may be delim - (eq (preceding-char) ?\\) - (= (% (skip-chars-backward "\\\\") 2) - (if (and (eq (char-after b) ?\#) - (eq (following-char) ?\#)) - 0 - -1)))) - ;; Not a subgr, avoid loop: - (progn (setq was-subgr nil) - (forward-char 1)) - (cond - ((match-beginning 5) ; 0-length builtins - (setq was-subgr nil) ; We do stuff here - (goto-char (match-end 5)) - (if (>= (point) e) - (goto-char (1- e))) + was-subgr (following-char)) + (cond + ((match-beginning 6) ; 0-length builtins, groups + (goto-char (match-end 0)) + (if (match-beginning 11) + (goto-char (match-beginning 11))) + (if (>= (point) e) + (goto-char (1- e))) + (cperl-postpone-fontification + (match-beginning 0) (point) + 'face + (cond + ((eq was-subgr ?\) ) + (condition-case nil + (save-excursion + (forward-sexp -1) + (if (> (point) b) + (if (if (eq (char-after b) ?? ) + (looking-at "(\\\\\\?") + (eq (char-after (1+ (point))) ?\?)) + my-cperl-REx-0length-face + my-cperl-REx-ctl-face) + font-lock-warning-face)) + (error font-lock-warning-face))) + ((eq was-subgr ?\| ) + my-cperl-REx-ctl-face) + ((eq was-subgr ?\$ ) + (if (> (point) (1+ REx-subgr-start)) + (progn + (put-text-property + (match-beginning 0) (point) + 'REx-interpolated + (if is-o-REx 0 + (if (and (eq (match-beginning 0) + (1+ b)) + (eq (point) + (1- e))) 1 t))) + font-lock-variable-name-face) + my-cperl-REx-spec-char-face)) + ((memq was-subgr (append "^." nil) ) + my-cperl-REx-spec-char-face) + ((eq was-subgr ?\( ) + (if (not (match-beginning 10)) + my-cperl-REx-ctl-face + my-cperl-REx-0length-face)) + (t my-cperl-REx-0length-face))) + (if (and (memq was-subgr (append "(|" nil)) + (not (string-match "(\\?[-imsx]+)" + (match-string 0)))) + (cperl-look-at-leading-count is-x-REx e)) + (setq was-subgr nil)) ; We do stuff here + ((match-beginning 12) ; \SYMBOL + (forward-char 2) + (if (>= (point) e) + (goto-char (1- e)) + ;; How many chars to not highlight: + ;; 0-len special-alnums in other branch => + ;; Generic: \non-alnum (1), \alnum (1+face) + ;; Is-delim: \non-alnum (1/spec-2) alnum-1 (=what hai) + (setq REx-subgr-start (point) + qtag (preceding-char)) (cperl-postpone-fontification - (match-beginning 5) (point) - 'face font-lock-variable-name-face) - (if (and (memq (string-to-char (match-string 5)) - (append "(|" nil)) - (not (string-match "(\?[-imsx]+)" - (match-string 5)))) - (cperl-look-at-leading-count is-x-REx e))) - ((match-beginning 7) ; \SYMBOL - (forward-char 2) - (if (>= (point) e) - (goto-char (1- e)) - ;; 0-len special-alnums in other branch => - ;; Generic: \non-alnum (1), \alnum NO - ;; Is-delim: \non-alnum (1/spec-2) alnum-1 (=what hai) - ;; How many chars to not highlight - (setq was-subgr (if (eq (char-after b) - (string-to-char - (match-string 7))) - (if (string-match - "[][)^$|*?+]" - (match-string 7)) - 0 - 1) - (if (string-match - "[a-zA-Z0-9]" - (match-string 7)) - nil - 1))) - (if was-subgr + (- (point) 2) (- (point) 1) 'face + (if (memq qtag + (append "ghijkmoqvFHIJKMORTVY" nil)) + font-lock-warning-face + my-cperl-REx-0length-face)) + (if (and (eq (char-after b) qtag) + (memq qtag (append ".])^$|*?+" nil))) + (progn + (if (and cperl-use-syntax-table-text-property + (eq qtag ?\) )) + (put-text-property + REx-subgr-start (1- (point)) + 'syntax-table cperl-st-punct)) (cperl-postpone-fontification - (- (point) 2) (- (point) was-subgr) - 'face font-lock-variable-name-face))) - (setq was-subgr nil)) ; We do stuff here - ((match-beginning 3) ; [charclass] - ;; Mismatch for /$patterns->[1]/ - (forward-char 1) - (setq qtag 0) ; leaders - (if (eq (char-after b) ?^ ) - (and (eq (following-char) ?\\ ) - (eq (char-after (cperl-1+ (point))) - ?^ ) - (forward-char 2)) - (and (eq (following-char) ?^ ) - (forward-char 1))) - (setq argument b ; continue? - tag nil ; list of POSIX classes - qtag (point)) - (if (eq (char-after b) ?\] ) - (and (eq (following-char) ?\\ ) - (eq (char-after (cperl-1+ (point))) - ?\] ) - (setq qtag (1+ qtag)) - (forward-char 2)) - (and (eq (following-char) ?\] ) - (forward-char 1))) - ;; Apparently, I can't put \] into a charclass - ;; in m]]: m][\\\]\]] produces [\\]] + (1- (point)) (point) 'face + ; \] can't appear below + (if (memq qtag (append ".]^$" nil)) + 'my-cperl-REx-spec-char-face + (if (memq qtag (append "*?+" nil)) + 'my-cperl-REx-0length-face + 'my-cperl-REx-ctl-face))))) ; )| + ;; Test for arguments: + (cond + ;; This is not pretty: the 5.8.7 logic: + ;; \0numx -> octal (up to total 3 dig) + ;; \DIGIT -> backref unless \0 + ;; \DIGITs -> backref if legal + ;; otherwise up to 3 -> octal + ;; Do not try to distinguish, we guess + ((or (and (memq qtag (append "01234567" nil)) + (re-search-forward + "\\=[01234567]?[01234567]?" + (1- e) 'to-end)) + (and (memq qtag (append "89" nil)) + (re-search-forward + "\\=[0123456789]*" (1- e) 'to-end)) + (and (eq qtag ?x) + (re-search-forward + "\\=[0-9a-fA-F][0-9a-fA-F]?\\|\\={[0-9a-fA-F]+}" + (1- e) 'to-end)) + (and (memq qtag (append "pPN" nil)) + (re-search-forward "\\={[^{}]+}\\|." + (1- e) 'to-end)) + (eq (char-syntax qtag) ?w)) + (cperl-postpone-fontification + (1- REx-subgr-start) (point) + 'face my-cperl-REx-length1-face)))) + (setq was-subgr nil)) ; We do stuff here + ((match-beginning 3) ; [charclass] + (forward-char 1) + (if (eq (char-after b) ?^ ) + (and (eq (following-char) ?\\ ) + (eq (char-after (cperl-1+ (point))) + ?^ ) + (forward-char 2)) + (and (eq (following-char) ?^ ) + (forward-char 1))) + (setq argument b ; continue? + tag nil ; list of POSIX classes + qtag (point)) + (if (eq (char-after b) ?\] ) + (and (eq (following-char) ?\\ ) + (eq (char-after (cperl-1+ (point))) + ?\] ) + (setq qtag (1+ qtag)) + (forward-char 2)) + (and (eq (following-char) ?\] ) + (forward-char 1))) + ;; Apparently, I can't put \] into a charclass + ;; in m]]: m][\\\]\]] produces [\\]] ;;; POSIX? [:word:] [:^word:] only inside [] ;;; "\\=\\(\\\\.\\|[^][\\\\]\\|\\[:\\^?\sw+:]\\|\\[[^:]\\)*]") - (while - (and argument - (re-search-forward - (if (eq (char-after b) ?\] ) - "\\=\\(\\\\[^]]\\|[^]\\\\]\\)*\\\\]" - "\\=\\(\\\\.\\|[^]\\\\]\\)*]") - (1- e) 'toend)) - ;; Is this ] the end of POSIX class? - (if (save-excursion - (and - (search-backward "[" argument t) - (< REx-subgr-start (point)) - (not - (and ; Should work with delim = \ - (eq (preceding-char) ?\\ ) - (= (% (skip-chars-backward - "\\\\") 2) 0))) - (looking-at - (cond - ((eq (char-after b) ?\] ) - "\\\\*\\[:\\^?\\sw+:\\\\\\]") - ((eq (char-after b) ?\: ) - "\\\\*\\[\\\\:\\^?\\sw+\\\\:]") - ((eq (char-after b) ?^ ) - "\\\\*\\[:\\(\\\\\\^\\)?\\sw+:\]") - ((eq (char-syntax (char-after b)) - ?w) - (concat - "\\\\*\\[:\\(\\\\\\^\\)?\\(\\\\" - (char-to-string (char-after b)) - "\\|\\sw\\)+:\]")) - (t "\\\\*\\[:\\^?\\sw*:]"))) - (setq argument (point)))) - (setq tag (cons (cons argument (point)) - tag) - argument (point)) ; continue - (setq argument nil))) - (and argument - (message "Couldn't find end of charclass in a REx, pos=%s" - REx-subgr-start)) - (if (and cperl-use-syntax-table-text-property - (> (- (point) 2) REx-subgr-start)) - (put-text-property - (1+ REx-subgr-start) (1- (point)) - 'syntax-table cperl-st-punct)) + (while + (and argument + (re-search-forward + (if (eq (char-after b) ?\] ) + "\\=\\(\\\\[^]]\\|[^]\\\\]\\)*\\\\]" + "\\=\\(\\\\.\\|[^]\\\\]\\)*]") + (1- e) 'toend)) + ;; Is this ] an end of POSIX class? + (if (save-excursion + (and + (search-backward "[" argument t) + (< REx-subgr-start (point)) + (not + (and ; Should work with delim = \ + (eq (preceding-char) ?\\ ) + (= (% (skip-chars-backward + "\\\\") 2) 0))) + (looking-at + (cond + ((eq (char-after b) ?\] ) + "\\\\*\\[:\\^?\\sw+:\\\\\\]") + ((eq (char-after b) ?\: ) + "\\\\*\\[\\\\:\\^?\\sw+\\\\:]") + ((eq (char-after b) ?^ ) + "\\\\*\\[:\\(\\\\\\^\\)?\\sw+:\]") + ((eq (char-syntax (char-after b)) + ?w) + (concat + "\\\\*\\[:\\(\\\\\\^\\)?\\(\\\\" + (char-to-string (char-after b)) + "\\|\\sw\\)+:\]")) + (t "\\\\*\\[:\\^?\\sw*:]"))) + (setq argument (point)))) + (setq tag (cons (cons argument (point)) + tag) + argument (point)) ; continue + (setq argument nil))) + (and argument + (message "Couldn't find end of charclass in a REx, pos=%s" + REx-subgr-start)) + (if (and cperl-use-syntax-table-text-property + (> (- (point) 2) REx-subgr-start)) + (put-text-property + (1+ REx-subgr-start) (1- (point)) + 'syntax-table cperl-st-punct)) + (cperl-postpone-fontification + REx-subgr-start qtag + 'face my-cperl-REx-spec-char-face) + (cperl-postpone-fontification + (1- (point)) (point) 'face + my-cperl-REx-spec-char-face) + (if (eq (char-after b) ?\] ) + (cperl-postpone-fontification + (- (point) 2) (1- (point)) + 'face my-cperl-REx-0length-face)) + (while tag (cperl-postpone-fontification - REx-subgr-start qtag + (car (car tag)) (cdr (car tag)) + 'face my-cperl-REx-length1-face) + (setq tag (cdr tag))) + (setq was-subgr nil)) ; did facing already + ;; Now rare stuff: + ((and (match-beginning 2) ; #-comment + (/= (match-beginning 2) (match-end 2))) + (beginning-of-line 2) + (if (> (point) e) + (goto-char (1- e)))) + ((match-beginning 4) ; character "]" + (setq was-subgr nil) ; We do stuff here + (goto-char (match-end 0)) + (if cperl-use-syntax-table-text-property + (put-text-property + (1- (point)) (point) + 'syntax-table cperl-st-punct)) + (cperl-postpone-fontification + (1- (point)) (point) + 'face font-lock-warning-face)) + ((match-beginning 5) ; before (?{}) (??{}) + (setq tag (match-end 0)) + (if (or (setq qtag + (cperl-forward-group-in-re st-l)) + (and (>= (point) e) + (setq qtag "no matching `)' found")) + (and (not (eq (char-after (- (point) 2)) + ?\} )) + (setq qtag "Can't find })"))) + (progn + (goto-char (1- e)) + (message qtag)) + (cperl-postpone-fontification + (1- tag) (1- (point)) 'face font-lock-variable-name-face) (cperl-postpone-fontification - (if (eq (char-after b) ?\] ) - (- (point) 2) - (1- (point))) - (point) 'face font-lock-variable-name-face) - (while tag - (cperl-postpone-fontification - (car (car tag)) (cdr (car tag)) - 'face font-lock-type-face) - (setq tag (cdr tag))) - (setq was-subgr nil)) ; did facing already - ;; Now rare stuff: - ((and (match-beginning 2) ; #-comment - (/= (match-beginning 2) (match-end 2))) - (beginning-of-line 2) - (if (> (point) e) - (goto-char (1- e)))) - ((match-beginning 4) ; character "]" - (setq was-subgr nil) ; We do stuff here - (goto-char (match-end 0)) - (if cperl-use-syntax-table-text-property - (put-text-property - (1- (point)) (point) - 'syntax-table cperl-st-punct)) + REx-subgr-start (1- tag) + 'face my-cperl-REx-spec-char-face) (cperl-postpone-fontification (1- (point)) (point) - 'face font-lock-function-name-face)) - ((match-beginning 8) ; (?{}) - (setq was-subgr (point) - tag (match-end 0)) - (if (or - (setq qtag - (cperl-forward-group-in-re st-l)) - (and (>= (point) e) - (setq qtag "no matching `)' found")) - (and - (not (eq (char-after (- (point) 2)) - ?\} )) - (setq qtag "Can't find })"))) + 'face my-cperl-REx-spec-char-face) + (if cperl-use-syntax-table-text-property (progn - (goto-char (1- e)) - (message qtag)) - (cperl-postpone-fontification - (1- tag) (1- (point)) - 'face font-lock-variable-name-face) - (if cperl-use-syntax-table-text-property - (progn - (put-text-property - (1- (point)) (point) - 'syntax-table cperl-st-cfence) - (put-text-property - was-subgr (1+ was-subgr) - 'syntax-table cperl-st-cfence)))) - (setq was-subgr nil)) - (t ; (?#)-comment - ;; Inside "(" and "\" arn't special in any way - ;; Works also if the outside delimiters are (). - (or ;;(if (eq (char-after b) ?\) ) - ;;(re-search-forward - ;; "[^\\\\]\\(\\\\\\\\\\)*\\\\)" - ;; (1- e) 'toend) - (search-forward ")" (1- e) 'toend) - ;;) - (message - "Couldn't find end of (?#...)-comment in a REx, pos=%s" - REx-subgr-start))))) + (put-text-property + (- (point) 2) (1- (point)) + 'syntax-table cperl-st-cfence) + (put-text-property + (+ REx-subgr-start 2) + (+ REx-subgr-start 3) + 'syntax-table cperl-st-cfence)))) + (setq was-subgr nil)) + (t ; (?#)-comment + ;; Inside "(" and "\" arn't special in any way + ;; Works also if the outside delimiters are (). + (or;;(if (eq (char-after b) ?\) ) + ;;(re-search-forward + ;; "[^\\\\]\\(\\\\\\\\\\)*\\\\)" + ;; (1- e) 'toend) + (search-forward ")" (1- e) 'toend) + ;;) + (message + "Couldn't find end of (?#...)-comment in a REx, pos=%s" + REx-subgr-start)))) (if (>= (point) e) (goto-char (1- e))) (cond - ((eq was-subgr t) + (was-subgr (setq REx-subgr-end (point)) (cperl-commentify REx-subgr-start REx-subgr-end nil) @@ -5887,11 +6119,11 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', (if i2 (progn (cperl-postpone-fontification - (1- e1) e1 'face font-lock-constant-face) + (1- e1) e1 'face my-cperl-delimiters-face) (if (assoc (char-after b) cperl-starters) (progn (cperl-postpone-fontification - b1 (1+ b1) 'face font-lock-constant-face) + b1 (1+ b1) 'face my-cperl-delimiters-face) (put-text-property b1 (1+ b1) 'REx-part2 t))))) (if (> (point) max) @@ -6102,6 +6334,36 @@ CHARS is a string that contains good characters to have before us (however, (eq (get-text-property (point) 'syntax-type) 'format))))))))) +(defun cperl-backward-to-start-of-expr (&optional lim) + (condition-case nil + (progn + (while (and (or (not lim) + (> (point) lim)) + (not (cperl-after-expr-p lim))) + (forward-sexp -1))) + (error nil))) + +(defun cperl-at-end-of-expr (&optional lim) + (condition-case nil + (save-excursion + ;; If nothing interesting after, same as (forward-sexp -1); otherwise + ;; fails, or at a start of following sexp: + (let ((p (point))) + (forward-sexp 1) + (forward-sexp -1) + (or (< (point) p) + (cperl-after-expr-p lim)))) + (error t))) + +(defun cperl-forward-to-end-of-expr (&optional lim) + (let ((p (point)))) + (condition-case nil + (progn + (while (and (< (point) (or lim (point-max))) + (not (cperl-at-end-of-expr))) + (forward-sexp 1))) + (error nil))) + (defun cperl-backward-to-start-of-continued-exp (lim) (if (memq (preceding-char) (append ")]}\"'`" nil)) (forward-sexp -1)) @@ -6787,9 +7049,12 @@ indentation and initial hashes. Behaves usually outside of comment." ;; Allow `cperl-find-pods-heres' to run. (or (boundp 'font-lock-constant-face) (cperl-force-face font-lock-constant-face - "Face for constant and label names") - ;;(setq font-lock-constant-face 'font-lock-constant-face) - )) + "Face for constant and label names")) + (or (boundp 'font-lock-warning-face) + (cperl-force-face font-lock-warning-face + "Face for things which should stand out")) + ;;(setq font-lock-constant-face 'font-lock-constant-face) + ) (defun cperl-init-faces () (condition-case errs @@ -7118,6 +7383,14 @@ indentation and initial hashes. Behaves usually outside of comment." [nil nil t t t] nil [nil nil t t t]) + (list 'font-lock-warning-face + ["Pink" "Red" "Gray50" "LightGray"] + ["gray20" "gray90" + "gray80" "gray20"] + [nil nil t t t] + nil + [nil nil t t t] + ) (list 'font-lock-constant-face ["CadetBlue" "Aquamarine" "Gray50" "LightGray"] nil @@ -7163,6 +7436,8 @@ indentation and initial hashes. Behaves usually outside of comment." "Face for data types") (cperl-force-face cperl-nonoverridable-face "Face for data types from another group") + (cperl-force-face font-lock-warning-face + "Face for things which should stand out") (cperl-force-face font-lock-comment-face "Face for comments") (cperl-force-face font-lock-function-name-face @@ -9285,91 +9560,189 @@ We suppose that the regexp is scanned already." (set-marker e (1- (point))) (cperl-beautify-regexp-piece b e nil deep)))) +(defun cperl-invert-if-unless-modifiers () + "Change `B if A;' into `if (A) {B}' etc if possible. +\(Unfinished.)" + (interactive) ; + (let (A B pre-B post-B pre-if post-if pre-A post-A if-string + (w-rex "\\<\\(if\\|unless\\|while\\|until\\|for\\|foreach\\)\\>")) + (and (= (char-syntax (preceding-char)) ?w) + (forward-sexp -1)) + (setq pre-if (point)) + (cperl-backward-to-start-of-expr) + (setq pre-B (point)) + (forward-sexp 1) ; otherwise forward-to-end-of-expr is NOP + (cperl-forward-to-end-of-expr) + (setq post-A (point)) + (goto-char pre-if) + (or (looking-at w-rex) + ;; Find the position + (progn (goto-char post-A) + (while (and + (not (looking-at w-rex)) + (> (point) pre-B)) + (forward-sexp -1)) + (setq pre-if (point)))) + (or (looking-at w-rex) + (error "Can't find `if', `unless', `while', `until', `for' or `foreach'")) + ;; 1 B 2 ... 3 B-com ... 4 if 5 ... if-com 6 ... 7 A 8 + (setq if-string (buffer-substring (match-beginning 0) (match-end 0))) + ;; First, simple part: find code boundaries + (forward-sexp 1) + (setq post-if (point)) + (forward-sexp -2) + (forward-sexp 1) + (setq post-B (point)) + (cperl-backward-to-start-of-expr) + (setq pre-B (point)) + (setq B (buffer-substring pre-B post-B)) + (goto-char pre-if) + (forward-sexp 2) + (forward-sexp -1) + (setq pre-A (point)) + (cperl-forward-to-end-of-expr) + (setq post-A (point)) + (setq A (buffer-substring pre-A post-A)) + ;; Now modify (from end, to not break the stuff) + (skip-chars-forward " \t;") + (delete-region pre-A (point)) ; we move to pre-A + (insert "\n" B ";\n}") + (and (looking-at "[ \t]*#") (cperl-indent-for-comment)) + (delete-region pre-if post-if) + (delete-region pre-B post-B) + (goto-char pre-B) + (insert if-string " (" A ") {") + (setq post-B (point)) + (if (looking-at "[ \t]+$") + (delete-horizontal-space) + (if (looking-at "[ \t]*#") + (cperl-indent-for-comment) + (just-one-space))) + (forward-line 1) + (if (looking-at "[ \t]*$") + (progn ; delete line + (delete-horizontal-space) + (delete-region (point) (1+ (point))))) + (cperl-indent-line) + (goto-char (1- post-B)) + (forward-sexp 1) + (cperl-indent-line) + (goto-char pre-B))) + (defun cperl-invert-if-unless () - "Change `if (A) {B}' into `B if A;' etc if possible." + "Change `if (A) {B}' into `B if A;' etc (or visa versa) if possible. +If the cursor is not on the leading keyword of the BLOCK flavor of +construct, will assume it is the STATEMENT flavor, so will try to find +the appropriate statement modifier." (interactive) - (or (looking-at "\\<") - (forward-sexp -1)) + (and (= (char-syntax (preceding-char)) ?w) + (forward-sexp -1)) (if (looking-at "\\<\\(if\\|unless\\|while\\|until\\|for\\|foreach\\)\\>") - (let ((pos1 (point)) - pos2 pos3 pos4 pos5 s1 s2 state p pos45 - (s0 (buffer-substring (match-beginning 0) (match-end 0)))) + (let ((pre-if (point)) + pre-A post-A pre-B post-B A B state p end-B-code is-block B-comment + (if-string (buffer-substring (match-beginning 0) (match-end 0)))) (forward-sexp 2) - (setq pos3 (point)) + (setq post-A (point)) (forward-sexp -1) - (setq pos2 (point)) - (if (eq (following-char) ?\( ) + (setq pre-A (point)) + (setq is-block (and (eq (following-char) ?\( ) + (save-excursion + (condition-case nil + (progn + (forward-sexp 2) + (forward-sexp -1) + (eq (following-char) ?\{ )) + (error nil))))) + (if is-block (progn - (goto-char pos3) + (goto-char post-A) (forward-sexp 1) - (setq pos5 (point)) + (setq post-B (point)) (forward-sexp -1) - (setq pos4 (point)) - ;; XXXX In fact may be `A if (B); {C}' ... + (setq pre-B (point)) (if (and (eq (following-char) ?\{ ) (progn - (cperl-backward-to-noncomment pos3) + (cperl-backward-to-noncomment post-A) (eq (preceding-char) ?\) ))) (if (condition-case nil (progn - (goto-char pos5) + (goto-char post-B) (forward-sexp 1) (forward-sexp -1) (looking-at "\\")) (error nil)) (error - "`%s' (EXPR) {BLOCK} with `else'/`elsif'" s0) - (goto-char (1- pos5)) - (cperl-backward-to-noncomment pos4) + "`%s' (EXPR) {BLOCK} with `else'/`elsif'" if-string) + (goto-char (1- post-B)) + (cperl-backward-to-noncomment pre-B) (if (eq (preceding-char) ?\;) (forward-char -1)) - (setq pos45 (point)) - (goto-char pos4) - (while (re-search-forward "\\<\\(for\\|foreach\\|if\\|unless\\|while\\|until\\)\\>\\|;" pos45 t) + (setq end-B-code (point)) + (goto-char pre-B) + (while (re-search-forward "\\<\\(for\\|foreach\\|if\\|unless\\|while\\|until\\)\\>\\|;" end-B-code t) (setq p (match-beginning 0) - s1 (buffer-substring p (match-end 0)) - state (parse-partial-sexp pos4 p)) + A (buffer-substring p (match-end 0)) + state (parse-partial-sexp pre-B p)) (or (nth 3 state) (nth 4 state) (nth 5 state) - (error "`%s' inside `%s' BLOCK" s1 s0)) + (error "`%s' inside `%s' BLOCK" A if-string)) (goto-char (match-end 0))) ;; Finally got it - (goto-char (1+ pos4)) + (goto-char (1+ pre-B)) (skip-chars-forward " \t\n") - (setq s2 (buffer-substring (point) pos45)) - (goto-char pos45) + (setq B (buffer-substring (point) end-B-code)) + (goto-char end-B-code) (or (looking-at ";?[ \t\n]*}") (progn (skip-chars-forward "; \t\n") - (setq s2 (concat s2 "\n" (buffer-substring (point) (1- pos5)))))) - (and (equal s2 "") - (setq s2 "1")) - (goto-char (1- pos3)) - (cperl-backward-to-noncomment pos2) + (setq B-comment + (buffer-substring (point) (1- post-B))))) + (and (equal B "") + (setq B "1")) + (goto-char (1- post-A)) + (cperl-backward-to-noncomment pre-A) (or (looking-at "[ \t\n]*)") - (goto-char (1- pos3))) + (goto-char (1- post-A))) (setq p (point)) - (goto-char (1+ pos2)) + (goto-char (1+ pre-A)) (skip-chars-forward " \t\n") - (setq s1 (buffer-substring (point) p)) - (delete-region pos4 pos5) - (delete-region pos2 pos3) - (goto-char pos1) - (insert s2 " ") + (setq A (buffer-substring (point) p)) + (delete-region pre-B post-B) + (delete-region pre-A post-A) + (goto-char pre-if) + (insert B " ") + (and B-comment (insert B-comment " ")) (just-one-space) (forward-word 1) - (setq pos1 (point)) - (insert " " s1 ";") + (setq pre-A (point)) + (insert " " A ";") (delete-horizontal-space) + (setq post-B (point)) + (if (looking-at "#") + (indent-for-comment)) + (goto-char post-B) (forward-char -1) (delete-horizontal-space) - (goto-char pos1) + (goto-char pre-A) (just-one-space) - (cperl-indent-line)) - (error "`%s' (EXPR) not with an {BLOCK}" s0))) - (error "`%s' not with an (EXPR)" s0))) - (error "Not at `if', `unless', `while', `until', `for' or `foreach'"))) + (goto-char pre-if) + (setq pre-A (set-marker (make-marker) pre-A)) + (while (<= (point) (marker-position pre-A)) + (cperl-indent-line) + (forward-line 1)) + (goto-char (marker-position pre-A)) + (if B-comment + (progn + (forward-line -1) + (indent-for-comment) + (goto-char (marker-position pre-A))))) + (error "`%s' (EXPR) not with an {BLOCK}" if-string))) + ;; (error "`%s' not with an (EXPR)" if-string) + (forward-sexp -1) + (cperl-invert-if-unless-modifiers))) + ;;(error "Not at `if', `unless', `while', `until', `for' or `foreach'") + (cperl-invert-if-unless-modifiers))) ;;; By Anthony Foiani ;;; Getting help on modules in C-h f ? @@ -9466,6 +9839,47 @@ We suppose that the regexp is scanned already." (setq flist (cdr flist)))) command)) + +(defun cperl-next-interpolated-REx-1 () + "Move point to next REx which has interpolated parts without //o. +Skips RExes consisting of one interpolated variable. + +Note that skipped RExen are not performance hits." + (interactive "") + (cperl-next-interpolated-REx 1)) + +(defun cperl-next-interpolated-REx-0 () + "Move point to next REx which has interpolated parts without //o." + (interactive "") + (cperl-next-interpolated-REx 0)) + +(defun cperl-next-interpolated-REx (&optional skip beg limit) + "Move point to next REx which has interpolated parts. +SKIP is a list of possible types to skip, BEG and LIMIT are the starting +point and the limit of search (default to point and end of buffer). + +SKIP may be a number, then it behaves as list of numbers up to SKIP; this +semantic may be used as a numeric argument. + +Types are 0 for / $rex /o (interpolated once), 1 for /$rex/ (if $rex is +a result of qr//, this is not a performance hit), t for the rest." + (interactive "P") + (if (numberp skip) (setq skip (list 0 skip))) + (or beg (setq beg (point))) + (or limit (setq limit (point-max))) ; needed for n-s-p-c + (let (pp) + (and (eq (get-text-property beg 'syntax-type) 'string) + (setq beg (next-single-property-change beg 'syntax-type nil limit))) + (cperl-map-pods-heres + (function (lambda (s e p) + (if (memq (get-text-property s 'REx-interpolated) skip) + t + (setq pp s) + nil))) ; nil stops + 'REx-interpolated beg limit) + (if pp (goto-char pp) + (message "No more interpolated REx")))) + ;;; Initial version contributed by Trey Belew (defun cperl-here-doc-spell (&optional beg end) "Spell-check HERE-documents in the Perl buffer. @@ -9786,7 +10200,7 @@ do extra unwind via `cperl-unwind-to-safe'." (cperl-fontify-syntaxically to))))) (defvar cperl-version - (let ((v "$Revision: 5.16 $")) + (let ((v "$Revision: 5.19 $")) (string-match ":\\s *\\([0-9.]+\\)" v) (substring v (match-beginning 1) (match-end 1))) "Version of IZ-supported CPerl package this file is based on.") -- 2.39.2