From 9b613d233f79a6b81f8ae27cffb4d4ed8a9ca2b6 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Tue, 6 Mar 2001 22:06:44 +0000 Subject: *** empty log message *** --- lisp/progmodes/cperl-mode.el | 958 ++++++++++++++++++++++++++++++------------- 1 file changed, 674 insertions(+), 284 deletions(-) diff --git a/lisp/progmodes/cperl-mode.el b/lisp/progmodes/cperl-mode.el index 4fe657d35bc..c6fa46c4964 100644 --- a/lisp/progmodes/cperl-mode.el +++ b/lisp/progmodes/cperl-mode.el @@ -2,7 +2,7 @@ ;;;; The following message is relative to GNU version of the module: -;; Copyright (C) 1985, 86, 87, 91, 92, 93, 94, 95, 96, 1997 +;; Copyright (C) 1985, 86, 87, 1991--2000 ;; Free Software Foundation, Inc. ;; Author: Ilya Zakharevich and Bob Olson @@ -46,9 +46,10 @@ ;;; Commentary: -;; $Id: cperl-mode.el,v 4.23 1999/08/01 19:53:35 vera Exp vera $ +;; $Id: cperl-mode.el,v 4.32 2000/05/31 05:13:15 ilya Exp ilya $ -;;; Before RMS Emacs 20.3: To use this mode put the following into +;;; If your Emacs does not default to `cperl-mode' on Perl files: +;;; To use this mode put the following into ;;; your .emacs file: ;; (autoload 'perl-mode "cperl-mode" "alternate mode for editing Perl programs" t) @@ -923,6 +924,126 @@ ;;; (`cperl-after-expr-p'): Make true after __END__. ;;; (`cperl-electric-pod'): "SYNOPSIS" was misspelled. +;;;; After 4.23: +;;; (`cperl-beautify-regexp-piece'): Was not allowing for *? after a class. +;;; Allow for POSIX char-classes. +;;; Remove trailing whitespace when +;;; adding new linebreak. +;;; Add a level counter to stop shallow. +;;; Indents unprocessed groups rigidly. +;;; (`cperl-beautify-regexp'): Add an optional count argument to go that +;;; many levels deep. +;;; (`cperl-beautify-level'): Likewise +;;; Menu: Add new entries to Regexp menu to do one level +;;; (`cperl-contract-level'): Was entering an infinite loop +;;; (`cperl-find-pods-heres'): Typo (double quoting). +;;; Was detecting < $file > as FH instead of glob. +;;; Support for comments in RExen (except +;;; for m#\#comment#x), governed by +;;; `cperl-regexp-scan'. +;;; (`cperl-regexp-scan'): New customization variable. +;;; (`cperl-forward-re'): Improve logic of resetting syntax table. + +;;;; After 4.23 and: After 4.24: +;;; (`cperl-contract-levels'): Restore position. +;;; (`cperl-beautify-level'): Likewise. +;;; (`cperl-beautify-regexp'): Likewise. +;;; (`cperl-commentify'): Rudimental support for length=1 runs +;;; (`cperl-find-pods-heres'): Process 1-char long REx comments too /a#/x +;;; Processes REx-comments in #-delimited RExen. +;;; MAJOR BUG CORRECTED: after a misparse +;;; a body of a subroutine could be corrupted!!! +;;; One might need to reeval the function body +;;; to fix things. (A similar bug was +;;; present in `cperl-indent-region' eons ago.) +;;; To reproduce: +;; (defun foo () (let ((a '(t))) (insert (format "%s" a)) (setcar a 'BUG) t)) +;; (foo) +;; (foo) +;;; C-x C-e the above three lines (at end-of-line). First evaluation +;;; of `foo' inserts (t), second one inserts (BUG) ?! +;;; +;;; In CPerl it was triggered by inserting then deleting `/' at start of +;;; / a (?# asdf {[(}asdf )ef,/; + +;;;; After 4.25: +;;; (`cperl-commentify'): Was recognizing length=2 "strings" as length=1. +;;; (`imenu-example--create-perl-index'): +;;; Was not enforcing syntaxification-to-the-end. +;;; (`cperl-invert-if-unless'): Allow `for', `foreach'. +;;; (`cperl-find-pods-heres'): Quote `cperl-nonoverridable-face'. +;;; Mark qw(), m()x as indentable. +;;; (`cperl-init-faces'): Highlight `sysopen' too. +;;; Highlight $var in `for my $var' too. +;;; (`cperl-invert-if-unless'): Was leaving whitespace at end. +;;; (`cperl-linefeed'): Was splitting $var{$foo} if point after `{'. +;;; (`cperl-calculate-indent'): Remove old commented out code. +;;; Support (primitive) indentation of qw(), m()x. + + +;;;; After 4.26: +;;; (`cperl-problems'): Mention `fill-paragraph' on comment. \"" and +;;; q [] with intervening newlines. +;;; (`cperl-autoindent-on-semi'): New customization variable. +;;; (`cperl-electric-semi'): Use `cperl-autoindent-on-semi'. +;;; (`cperl-tips'): Mention how to make CPerl the default mode. +;;; (`cperl-mode'): Support `outline-minor-mode' +;;; (Thanks to Mark A. Hershberger). +;;; (`cperl-outline-level'): New function. +;;; (`cperl-highlight-variables-indiscriminately'): New customization var. +;;; (`cperl-init-faces'): Use `cperl-highlight-variables-indiscriminately'. +;;; (Thanks to Sean Kamath ). +;;; (`cperl-after-block-p'): Support CHECK and INIT. +;;; (`cperl-init-faces'): Likewise and "our". +;;; (Thanks to Doug MacEachern ). +;;; (`cperl-short-docs'): Likewise and "our". + + +;;;; After 4.27: +;;; (`cperl-find-pods-heres'): Recognize \"" as a string. +;;; Mark whitespace and comments between q and [] +;;; as `syntax-type' => `prestring'. +;;; Allow whitespace between << and "FOO". +;;; (`cperl-problems'): Remove \"" and q [] with intervening newlines. +;;; Mention multiple <")) - (setq over (looking-at "over\\>")) + (setq head1 (looking-at "head1\\>[ \t]*$")) + (setq over (and (looking-at "over\\>[ \t]*$") + (not (looking-at "over[ \t]*\n\n\n*=item\\>")))) (forward-char -1) (bolp)) (or (get-text-property (point) 'in-pod) (cperl-after-expr-p nil "{;:") (and (re-search-backward - "\\(\\`\n?\\|\n\n\\)=\\sw+" (point-min) t) + ;; "\\(\\`\n?\\|\n\n\\)=\\sw+" + "\\(\\`\n?\\|^\n\\)=\\sw+" + (point-min) t) (not (or (looking-at "=cut") (and cperl-use-syntax-table-text-property @@ -2830,12 +3008,12 @@ to nil." 'pod))))))))) (progn (save-excursion - (setq notlast (search-forward "\n\n=" nil t))) + (setq notlast (re-search-forward "^\n=" nil t))) (or notlast (progn (insert "\n\n=cut") (cperl-ensure-newlines 2) - (forward-sexp -2) + (forward-word -2) (if (and head1 (not (save-excursion @@ -2843,7 +3021,7 @@ to nil." (re-search-backward "\\(\\`\n?\\|\n\n\\)=head1\\>" nil t)))) ; Only one (progn - (forward-sexp 1) + (forward-word 1) (setq name (file-name-sans-extension (file-name-nondirectory (buffer-file-name))) p (point)) @@ -2852,10 +3030,10 @@ to nil." "=head1 DESCRIPTION") (cperl-ensure-newlines 4) (goto-char p) - (forward-sexp 2) + (forward-word 2) (end-of-line) (setq really-delete t)) - (forward-sexp 1)))) + (forward-word 1)))) (if over (progn (setq p (point)) @@ -2863,7 +3041,7 @@ to nil." "=back") (cperl-ensure-newlines 2) (goto-char p) - (forward-sexp 1) + (forward-word 1) (end-of-line) (setq really-delete t))) (if (and delete really-delete) @@ -2932,6 +3110,7 @@ If in POD, insert appropriate lines." ; Leave the level of parens (looking-at "[,; \t]*\\($\\|#\\)") ; Comma to allow anon subr ; Are at end + (cperl-after-block-p (point-min)) (progn (backward-sexp 1) (setq start (point-marker)) @@ -3019,7 +3198,9 @@ If in POD, insert appropriate lines." (interactive "P") (if cperl-auto-newline (cperl-electric-terminator arg) - (self-insert-command (prefix-numeric-value arg)))) + (self-insert-command (prefix-numeric-value arg)) + (if cperl-autoindent-on-semi + (cperl-indent-line)))) (defun cperl-electric-terminator (arg) "Insert character and correct line's indentation." @@ -3258,8 +3439,9 @@ Will not correct the indentation for labels, but will correct it for braces and closing parentheses and brackets.." (save-excursion (if (or - (memq (get-text-property (point) 'syntax-type) - '(pod here-doc here-doc-delim format)) + (and (memq (get-text-property (point) 'syntax-type) + '(pod here-doc here-doc-delim format)) + (not (get-text-property (point) 'indentable))) ;; before start of POD - whitespace found since do not have 'pod! (and (looking-at "[ \t]*\n=") (error "Spaces before pod section!")) @@ -3273,7 +3455,7 @@ and closing parentheses and brackets.." (following-char))) (in-pod (get-text-property (point) 'in-pod)) (pre-indent-point (point)) - p prop look-prop) + p prop look-prop is-block delim) (cond (in-pod ;; In the verbatim part, probably code example. What to do??? @@ -3310,48 +3492,18 @@ and closing parentheses and brackets.." (setcar (cddr parse-data) start)) ;; Before this point: end of statement (setq old-indent (nth 3 parse-data)))) - ;; (or parse-start (null symbol) - ;; (setq parse-start (symbol-value symbol) - ;; start-indent (nth 2 parse-start) - ;; parse-start (car parse-start))) - ;; (if parse-start - ;; (goto-char parse-start) - ;; (beginning-of-defun)) - ;; ;; Try to go out - ;; (while (< (point) indent-point) - ;; (setq start (point) parse-start start moved nil - ;; state (parse-partial-sexp start indent-point -1)) - ;; (if (> (car state) -1) nil - ;; ;; The current line could start like }}}, so the indentation - ;; ;; corresponds to a different level than what we reached - ;; (setq moved t) - ;; (beginning-of-line 2))) ; Go to the next line. - ;; (if start ; Not at the start of file - ;; (progn - ;; (goto-char start) - ;; (setq start-indent (current-indentation)) - ;; (if moved ; Should correct... - ;; (setq start-indent (- start-indent cperl-indent-level)))) - ;; (setq start-indent 0)) - ;; (if (< (point) indent-point) (setq parse-start (point))) - ;; (or state (setq state (parse-partial-sexp - ;; (point) indent-point -1 nil start-state))) - ;; (setq containing-sexp - ;; (or (car (cdr state)) - ;; (and (>= (nth 6 state) 0) old-containing-sexp)) - ;; old-containing-sexp nil start-state nil) -;;;; (while (< (point) indent-point) -;;;; (setq parse-start (point)) -;;;; (setq state (parse-partial-sexp (point) indent-point -1 nil start-state)) -;;;; (setq containing-sexp -;;;; (or (car (cdr state)) -;;;; (and (>= (nth 6 state) 0) old-containing-sexp)) -;;;; old-containing-sexp nil start-state nil)) - ;; (if symbol (set symbol (list indent-point state start-indent))) - ;; (goto-char indent-point) - (cond ((or (nth 3 state) (nth 4 state)) + (cond ((get-text-property (point) 'indentable) + ;; indent to just after the surrounding open, + ;; skip blanks if we do not close the expression. + (goto-char (1+ (previous-single-property-change (point) 'indentable))) + (or (memq char-after (append ")]}" nil)) + (looking-at "[ \t]*\\(#\\|$\\)") + (skip-chars-forward " \t")) + (current-column)) + ((or (nth 3 state) (nth 4 state)) ;; return nil or t if should not change this line (nth 4 state)) + ;; XXXX Do we need to special-case this? ((null containing-sexp) ;; Line is at top level. May be data or function definition, ;; or may be function argument declaration. @@ -3390,27 +3542,50 @@ and closing parentheses and brackets.." (list pre-indent-point))) 0) cperl-continued-statement-offset)))) - ((/= (char-after containing-sexp) ?{) - ;; line is expression, not statement: - ;; indent to just after the surrounding open, + ((not + (or (setq is-block + (and (setq delim (= (char-after containing-sexp) ?{)) + (save-excursion ; Is it a hash? + (goto-char containing-sexp) + (cperl-block-p)))) + cperl-indent-parens-as-block)) + ;; group is an expression, not a block: + ;; indent to just after the surrounding open parens, ;; skip blanks if we do not close the expression. (goto-char (1+ containing-sexp)) - (or (memq char-after (append ")]}" nil)) + (or (memq char-after + (append (if delim "}" ")]}") nil)) (looking-at "[ \t]*\\(#\\|$\\)") (skip-chars-forward " \t")) - (current-column)) - ((progn - ;; Containing-expr starts with \{. Check whether it is a hash. - (goto-char containing-sexp) - (not (cperl-block-p))) - (goto-char (1+ containing-sexp)) - (or (eq char-after ?\}) - (looking-at "[ \t]*\\(#\\|$\\)") - (skip-chars-forward " \t")) - (+ (current-column) ; Correct indentation of trailing ?\} - (if (eq char-after ?\}) (+ cperl-indent-level - cperl-close-paren-offset) + (+ (current-column) + (if (and delim + (eq char-after ?\})) + ;; Correct indentation of trailing ?\} + (+ cperl-indent-level cperl-close-paren-offset) 0))) +;;; ((and (/= (char-after containing-sexp) ?{) +;;; (not cperl-indent-parens-as-block)) +;;; ;; line is expression, not statement: +;;; ;; indent to just after the surrounding open, +;;; ;; skip blanks if we do not close the expression. +;;; (goto-char (1+ containing-sexp)) +;;; (or (memq char-after (append ")]}" nil)) +;;; (looking-at "[ \t]*\\(#\\|$\\)") +;;; (skip-chars-forward " \t")) +;;; (current-column)) +;;; ((progn +;;; ;; Containing-expr starts with \{. Check whether it is a hash. +;;; (goto-char containing-sexp) +;;; (and (not (cperl-block-p)) +;;; (not cperl-indent-parens-as-block))) +;;; (goto-char (1+ containing-sexp)) +;;; (or (eq char-after ?\}) +;;; (looking-at "[ \t]*\\(#\\|$\\)") +;;; (skip-chars-forward " \t")) +;;; (+ (current-column) ; Correct indentation of trailing ?\} +;;; (if (eq char-after ?\}) (+ cperl-indent-level +;;; cperl-close-paren-offset) +;;; 0))) (t ;; Statement level. Is it a continuation or a new statement? ;; Find previous non-comment character. @@ -3432,11 +3607,12 @@ and closing parentheses and brackets.." (beginning-of-line) (cperl-backward-to-noncomment containing-sexp)) ;; Now we get the answer. - ;; Had \?, too: - (if (not (or (memq (preceding-char) (append " ;{" '(nil))) + (if (not (or (eq (1- (point)) containing-sexp) + (memq (preceding-char) + (append (if is-block " ;{" " ,;{") '(nil))) (and (eq (preceding-char) ?\}) (cperl-after-block-and-statement-beg - containing-sexp)))) ; Was ?\, + containing-sexp)))) ;; This line is continuation of preceding line's statement; ;; indent `cperl-continued-statement-offset' more than the ;; previous line of the statement. @@ -3448,6 +3624,12 @@ and closing parentheses and brackets.." (+ (if (memq char-after (append "}])" nil)) 0 ; Closing parenth cperl-continued-statement-offset) + (if (or is-block + (not delim) + (not (eq char-after ?\}))) + 0 + ;; Now it is a hash reference + (+ cperl-indent-level cperl-close-paren-offset)) (if (looking-at "\\w+[ \t]*:") (if (> (current-indentation) cperl-min-label-indent) (- (current-indentation) cperl-label-offset) @@ -3503,6 +3685,12 @@ and closing parentheses and brackets.." (+ (if (and (bolp) (zerop cperl-indent-level)) (+ cperl-brace-offset cperl-continued-statement-offset) cperl-indent-level) + (if (or is-block + (not delim) + (not (eq char-after ?\}))) + 0 + ;; Now it is a hash reference + (+ cperl-indent-level cperl-close-paren-offset)) ;; Move back over whitespace before the openbrace. ;; If openbrace is not first nonwhite thing on the line, ;; add the cperl-brace-imaginary-offset. @@ -3790,8 +3978,11 @@ Returns true if comment is found." nil ;; We suppose that e is _after_ the end of construction, as after eol. (setq string (if string cperl-st-sfence cperl-st-cfence)) - (cperl-modify-syntax-type bb string) - (cperl-modify-syntax-type (1- e) string) + (if (> bb (- e 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) 'syntax-table cperl-string-syntax-table)) @@ -3801,6 +3992,7 @@ Returns true if comment is found." (not cperl-pod-here-fontify) (put-text-property bb e 'face (if string 'font-lock-string-face 'font-lock-comment-face))))) + (defvar cperl-starters '(( ?\( . ?\) ) ( ?\[ . ?\] ) ( ?\{ . ?\} ) @@ -3810,7 +4002,7 @@ Returns true if comment is found." &optional ostart oend) ;; Works *before* syntax recognition is done ;; May modify syntax-type text property if the situation is too hard - (let (b starter ender st i i2 go-forward) + (let (b starter ender st i i2 go-forward reset-st) (skip-chars-forward " \t") ;; ender means matching-char matcher. (setq b (point) @@ -3843,9 +4035,13 @@ Returns true if comment is found." (not ender)) ;; $ has TeXish matching rules, so $$ equiv $... (forward-char 2) + (setq reset-st (syntax-table)) (set-syntax-table st) (forward-sexp 1) - (set-syntax-table cperl-mode-syntax-table) + (if (<= (point) (1+ b)) + (error "Unfinished regular expression")) + (set-syntax-table reset-st) + (setq reset-st nil) ;; Now the problem is with m;blah;; (and (not ender) (eq (preceding-char) @@ -3882,6 +4078,8 @@ Returns true if comment is found." ender (nth 2 ender))))) (error (goto-char lim) (setq set-st nil) + (if reset-st + (set-syntax-table reset-st)) (or end (message "End of `%s%s%c ... %c' string/RE not found: %s" @@ -3897,7 +4095,7 @@ Returns true if comment is found." ;; i2: start of the second arg, if any (before delim iff `ender'). ;; ender: the last arg bounded by parens-like chars, the second one of them ;; starter: the starting delimiter of the first arg - ;; go-forward: has 2 args, and the second part is empth + ;; go-forward: has 2 args, and the second part is empty (list i i2 ender starter go-forward))) (defvar font-lock-string-face) @@ -3923,6 +4121,7 @@ Returns true if comment is found." ;; After-initial-line--to-end is marked `syntax-type' ==> `format' ;; d) 'Q'uoted string: ;; part between markers inclusive is marked `syntax-type' ==> `string' +;; part between `q' and the first marker is marked `syntax-type' ==> `prestring' (defun cperl-unwind-to-safe (before &optional end) ;; if BEFORE, go to the previous start-of-line on each step of unwinding @@ -3939,6 +4138,11 @@ Returns true if comment is found." (goto-char (setq pos (cperl-1- pos)))) ;; Up to the start (goto-char (point-min)))) + ;; Skip empty lines + (and (looking-at "\n*=") + (/= 0 (skip-chars-backward "\n")) + (forward-char)) + (setq pos (point)) (if end ;; Do the same for end, going small steps (progn @@ -3947,6 +4151,10 @@ Returns true if comment is found." end (next-single-property-change end 'syntax-type))) (or end pos))))) +(defvar cperl-nonoverridable-face) +(defvar font-lock-function-name-face) +(defvar font-lock-comment-face) + (defun cperl-find-pods-heres (&optional min max non-inter end ignore-max) "Scans the buffer for hard-to-parse Perl constructions. If `cperl-pod-here-fontify' is not-nil after evaluation, will fontify @@ -3958,6 +4166,7 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', cperl-syntax-done-to min)) (or max (setq max (point-max))) (let* (face head-face here-face b e bb tag qtag b1 e1 argument i c tail tb + is-REx is-x-REx REx-comment-start REx-comment-end was-comment i2 (cperl-pod-here-fontify (eval cperl-pod-here-fontify)) go tmpend (case-fold-search nil) (inhibit-read-only t) (buffer-undo-list t) (modified (buffer-modified-p)) @@ -3969,7 +4178,8 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', (point-min))) (state (if use-syntax-state (cdr cperl-syntax-state))) - (st-l '(nil)) (err-l '(nil)) i2 + ;; (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... (font-lock-string-face (if (boundp 'font-lock-string-face) font-lock-string-face @@ -3981,6 +4191,10 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', (if (boundp 'font-lock-function-name-face) font-lock-function-name-face 'font-lock-function-name-face)) + (font-lock-comment-face + (if (boundp 'font-lock-comment-face) + font-lock-comment-face + 'font-lock-comment-face)) (cperl-nonoverridable-face (if (boundp 'cperl-nonoverridable-face) cperl-nonoverridable-face @@ -3990,13 +4204,14 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', max)) (search (concat - "\\(\\`\n?\\|\n\n\\)=" + "\\(\\`\n?\\|^\n\\)=" "\\|" ;; One extra () before this: "<<" "\\(" ; 1 + 1 ;; First variant "BLAH" or just ``. - "\\([\"'`]\\)" ; 2 + 1 + "[ \t]*" ; Yes, whitespace is allowed! + "\\([\"'`]\\)" ; 2 + 1 = 3 "\\([^\"'`\n]*\\)" ; 3 + 1 "\\3" "\\|" @@ -4028,7 +4243,10 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', "\\(\\") + ;; "\\(\\`\n?\\|^\n\\)=" + (if (looking-at "cut\\>") (if ignore-max nil ; Doing a chunk only (message "=cut is not preceded by a POD section") @@ -4071,61 +4292,64 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', b1 nil) ; error condition ;; We do not search to max, since we may be called from ;; some hook of fontification, and max is random - (or (re-search-forward "\n\n=cut\\>" stop-point 'toend) + (or (re-search-forward "^\n=cut\\>" stop-point 'toend) (progn - (message "End of a POD section not marked by =cut") - (setq b1 t) - (or (car err-l) (setcar err-l b)))) + (goto-char b) + (if (re-search-forward "\n=cut\\>" stop-point 'toend) + (progn + (message "=cut is not preceded by an empty line") + (setq b1 t) + (or (car err-l) (setcar err-l b)))))) (beginning-of-line 2) ; An empty line after =cut is not POD! (setq e (point)) - (if (and b1 (eobp)) - ;; Unrecoverable error - nil - (and (> e max) - (progn - (remove-text-properties - max e '(syntax-type t in-pod t syntax-table t - 'cperl-postpone t)) - (setq tmpend tb))) - (put-text-property b e 'in-pod t) - (put-text-property b e 'syntax-type 'in-pod) - (goto-char b) - (while (re-search-forward "\n\n[ \t]" e t) - ;; We start 'pod 1 char earlier to include the preceding line - (beginning-of-line) - (put-text-property (cperl-1- b) (point) 'syntax-type 'pod) - (cperl-put-do-not-fontify b (point) t) - ;; mark the non-literal parts as PODs - (if cperl-pod-here-fontify - (cperl-postpone-fontification b (point) 'face face t)) - (re-search-forward "\n\n[^ \t\f\n]" e 'toend) - (beginning-of-line) - (setq b (point))) - (put-text-property (cperl-1- (point)) e 'syntax-type 'pod) - (cperl-put-do-not-fontify (point) e t) + (and (> e max) + (progn + (remove-text-properties + max e '(syntax-type t in-pod t syntax-table t + cperl-postpone t + syntax-subtype t + rear-nonsticky t + indentable t)) + (setq tmpend tb))) + (put-text-property b e 'in-pod t) + (put-text-property b e 'syntax-type 'in-pod) + (goto-char b) + (while (re-search-forward "\n\n[ \t]" e t) + ;; We start 'pod 1 char earlier to include the preceding line + (beginning-of-line) + (put-text-property (cperl-1- b) (point) 'syntax-type 'pod) + (cperl-put-do-not-fontify b (point) t) + ;; mark the non-literal parts as PODs (if cperl-pod-here-fontify - (progn - ;; mark the non-literal parts as PODs - (cperl-postpone-fontification (point) e 'face face t) - (goto-char bb) - (if (looking-at - "=[a-zA-Z0-9_]+\\>[ \t]*\\(\\(\n?[^\n]\\)+\\)$") - ;; mark the headers - (cperl-postpone-fontification - (match-beginning 1) (match-end 1) - 'face head-face)) - (while (re-search-forward - ;; One paragraph - "\n\n=[a-zA-Z0-9_]+\\>[ \t]*\\(\\(\n?[^\n]\\)+\\)$" - e 'toend) + (cperl-postpone-fontification b (point) 'face face t)) + (re-search-forward "\n\n[^ \t\f\n]" e 'toend) + (beginning-of-line) + (setq b (point))) + (put-text-property (cperl-1- (point)) e 'syntax-type 'pod) + (cperl-put-do-not-fontify (point) e t) + (if cperl-pod-here-fontify + (progn + ;; mark the non-literal parts as PODs + (cperl-postpone-fontification (point) e 'face face t) + (goto-char bb) + (if (looking-at + "=[a-zA-Z0-9_]+\\>[ \t]*\\(\\(\n?[^\n]\\)+\\)$") ;; mark the headers (cperl-postpone-fontification (match-beginning 1) (match-end 1) - 'face head-face)))) - (cperl-commentify bb e nil) - (goto-char e) - (or (eq e (point-max)) - (forward-char -1))))) ; Prepare for immediate pod start. + 'face head-face)) + (while (re-search-forward + ;; One paragraph + "^\n=[a-zA-Z0-9_]+\\>[ \t]*\\(\\(\n?[^\n]\\)+\\)$" + e 'toend) + ;; mark the headers + (cperl-postpone-fontification + (match-beginning 1) (match-end 1) + 'face head-face)))) + (cperl-commentify bb e nil) + (goto-char e) + (or (eq e (point-max)) + (forward-char -1)))) ; Prepare for immediate pod start. ;; Here document ;; We do only one here-per-line ;; ;; One extra () before this: @@ -4263,16 +4487,16 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', (or (memq bb '(?\$ ?\@ ?\% ?\* ?\#)) ; $#y (and (eq bb ?-) (eq c ?s)) ; -s file test - (and (eq bb ?\&) ; &&m/blah/ - (not (eq (char-after + (and (eq bb ?\&) + (not (eq (char-after ; &&m/blah/ (- (match-beginning b1) 2)) ?\&)))) ;; or <$file> (and (eq c ?\<) - ;; Do not stringify : + ;; Do not stringify , <$fh> : (save-match-data (looking-at - "\\s *\\$?\\([_a-zA-Z:][_a-zA-Z0-9:]*\\s *\\)?>")))) + "\\$?\\([_a-zA-Z:][_a-zA-Z0-9:]*\\)?>")))) tb (match-beginning 0)) (goto-char (match-beginning b1)) (cperl-backward-to-noncomment (point-min)) @@ -4328,9 +4552,12 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', (goto-char b) (if (or bb (nth 3 state) (nth 4 state)) (goto-char i) + ;; Skip whitespace and comments... (if (looking-at "[ \t\n\f]+\\(#[^\n]*\n[ \t\n\f]*\\)+") (goto-char (match-end 0)) (skip-chars-forward " \t\n\f")) + (if (> (point) b) + (put-text-property b (point) 'syntax-type 'prestring)) ;; qtag means two-arg matcher, may be reset to ;; 2 or 3 later if some special quoting is needed. ;; e1 means matching-char matcher. @@ -4353,16 +4580,23 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', tail (if (and i (not tag)) (1- e1)) e (if i i e1) ; end of the first part - qtag nil) ; need to preserve backslashitis + qtag nil ; need to preserve backslashitis + is-x-REx nil) ; REx has //x modifier ;; Commenting \\ is dangerous, what about ( ? (and i tail (eq (char-after i) ?\\) (setq qtag t)) + (if (looking-at "\\sw*x") ; qr//x + (setq is-x-REx t)) (if (null i) ;; Considered as 1arg form (progn (cperl-commentify b (point) t) (put-text-property b (point) 'syntax-type 'string) + (if (or is-x-REx + ;; ignore other text properties: + (string-match "^qw$" argument)) + (put-text-property b (point) 'indentable t)) (and go (setq e1 (cperl-1+ e1)) (or (eobp) @@ -4379,9 +4613,13 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', (progn (cperl-modify-syntax-type (1- (point)) cperl-st-ket) (cperl-modify-syntax-type i cperl-st-bra))) - (put-text-property b i 'syntax-type 'string)) + (put-text-property b i 'syntax-type 'string) + (if is-x-REx + (put-text-property b i 'indentable t))) (cperl-commentify b1 (point) t) (put-text-property b (point) 'syntax-type 'string) + (if is-x-REx + (put-text-property b i 'indentable t)) (if qtag (cperl-modify-syntax-type (1+ i) cperl-st-punct)) (setq tail nil))) @@ -4391,12 +4629,15 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', (forward-word 1) ; skip modifiers s///s (if tail (cperl-commentify tail (point) t)) (cperl-postpone-fontification - e1 (point) 'face cperl-nonoverridable-face))) + e1 (point) 'face 'cperl-nonoverridable-face))) ;; Check whether it is m// which means "previous match" ;; and highlight differently - (if (and (eq e (+ 2 b)) - (string-match "^\\([sm]?\\|qr\\)$" argument) - ;; <> is already filtered out + (setq is-REx + (and (string-match "^\\([sm]?\\|qr\\)$" argument) + (or (not (= (length argument) 0)) + (not (eq c ?\<))))) + (if (and is-REx + (eq e (+ 2 b)) ;; split // *is* using zero-pattern (save-excursion (condition-case nil @@ -4417,7 +4658,56 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', (cperl-postpone-fontification b (cperl-1+ b) 'face font-lock-constant-face) (cperl-postpone-fontification - (1- e) e 'face font-lock-constant-face)))) + (1- e) e 'face font-lock-constant-face))) + (if (and is-REx cperl-regexp-scan) + ;; Process RExen better + (save-excursion + (goto-char (1+ b)) + (while + (and (< (point) e) + (re-search-forward + (if is-x-REx + (if (eq (char-after b) ?\#) + "\\((\\?\\\\#\\)\\|\\(\\\\#\\)" + "\\((\\?#\\)\\|\\(#\\)") + (if (eq (char-after b) ?\#) + "\\((\\?\\\\#\\)" + "\\((\\?#\\)")) + (1- e) 'to-end)) + (goto-char (match-beginning 0)) + (setq REx-comment-start (point) + was-comment t) + (if (save-excursion + (and + ;; XXX not working if outside delimiter is # + (eq (preceding-char) ?\\) + (= (% (skip-chars-backward "$\\\\") 2) -1))) + ;; Not a comment, avoid loop: + (progn (setq was-comment nil) + (forward-char 1)) + (if (match-beginning 2) + (progn + (beginning-of-line 2) + (if (> (point) e) + (goto-char (1- e)))) + ;; Works also if the outside delimiters are (). + (or (search-forward ")" (1- e) 'toend) + (message + "Couldn't find end of (?#...)-comment in a REx, pos=%s" + REx-comment-start)))) + (if (>= (point) e) + (goto-char (1- e))) + (if was-comment + (progn + (setq REx-comment-end (point)) + (cperl-commentify + REx-comment-start REx-comment-end nil) + (cperl-postpone-fontification + REx-comment-start REx-comment-end + 'face font-lock-comment-face)))))) + (if (and is-REx is-x-REx) + (put-text-property (1+ b) (1- e) + 'syntax-subtype 'x-REx))) (if i2 (progn (cperl-postpone-fontification @@ -4470,7 +4760,7 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', (goto-char bb)) ;; 1+6+2+1+1+2+1+1=15 extra () before this: ;; "__\\(END\\|DATA\\)__" - (t ; __END__, __DATA__ + ((match-beginning 16) ; __END__, __DATA__ (setq bb (match-end 0) b (match-beginning 0) state (parse-partial-sexp @@ -4481,7 +4771,21 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', ;; (put-text-property b (1+ bb) 'syntax-type 'pod) ; Cheat (cperl-commentify b bb nil) (setq end t)) - (goto-char bb))) + (goto-char bb)) + ((match-beginning 17) ; "\\\\\\(['`\"]\\)" + (setq bb (match-end 0) + b (match-beginning 0)) + (goto-char b) + (skip-chars-backward "\\\\") + ;;;(setq i2 (= (% (skip-chars-backward "\\\\") 2) -1)) + (setq state (parse-partial-sexp + state-point b nil nil state) + state-point b) + (if (or (nth 3 state) (nth 4 state) ) + nil + (cperl-modify-syntax-type b cperl-st-punct)) + (goto-char bb)) + (t (error "Error in regexp of the sniffer"))) (if (> (point) stop-point) (progn (if end @@ -4530,7 +4834,7 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', (if (eq (char-syntax (preceding-char)) ?w) ; else {} (save-excursion (forward-sexp -1) - (or (looking-at "\\(else\\|grep\\|map\\|BEGIN\\|END\\)\\>") + (or (looking-at "\\(else\\|grep\\|map\\|BEGIN\\|END\\|CHECK\\|INIT\\)\\>") ;; sub f {} (progn (cperl-backward-to-noncomment lim) @@ -4689,7 +4993,7 @@ Returns some position at the last line." ;; Looking at: ;; foreach my $var (if (looking-at - "[ \t]*\\\\([ \t]*(\\|[ \t\n]*{\\)\\|[ \t]*{") + "[ \t]*\\(}[ \t]*\\)?\\<\\(\\els\\(e\\|if\\)\\|continue\\|if\\|unless\\|while\\|for\\(each\\)?\\(\\([ t]+\\(my\\|local\\|our\\)\\)?[ \t]*\\$[_a-zA-Z0-9]+\\)?\\|until\\)\\>\\([ \t]*(\\|[ \t\n]*{\\)\\|[ \t]*{") (progn (setq ml (match-beginning 8)) (re-search-forward "[({]") @@ -5050,12 +5354,13 @@ indentation and initial hashes. Behaves usually outside of comment." (let ((index-alist '()) (index-pack-alist '()) (index-pod-alist '()) (index-unsorted-alist '()) (i-s-f (default-value 'imenu-sort-function)) (index-meth-alist '()) meth - packages ends-ranges p + packages ends-ranges p marker (prev-pos 0) char fchar index index1 name (end-range 0) package) (goto-char (point-min)) (if noninteractive (message "Scanning Perl for index") (imenu-progress-message prev-pos 0)) + (cperl-update-syntaxification (point-max) (point-max)) ;; Search for the function (progn ;;save-match-data (while (re-search-forward @@ -5072,7 +5377,7 @@ indentation and initial hashes. Behaves usually outside of comment." nil) ((and (match-beginning 2) ; package or sub - ;; Skip if quoted (will not skip multi-line ''-comments :-(): + ;; Skip if quoted (will not skip multi-line ''-strings :-(): (null (get-text-property (match-beginning 1) 'syntax-table)) (null (get-text-property (match-beginning 1) 'syntax-type)) (null (get-text-property (match-beginning 1) 'in-pod))) @@ -5082,7 +5387,7 @@ indentation and initial hashes. Behaves usually outside of comment." ) ;; (if (looking-at "([^()]*)[ \t\n\f]*") ;; (goto-char (match-end 0))) ; Messes what follows - (setq char (following-char) + (setq char (following-char) ; ?\; for "sub foo () ;" meth nil p (point)) (while (and ends-ranges (>= p (car ends-ranges))) @@ -5105,16 +5410,18 @@ indentation and initial hashes. Behaves usually outside of comment." ;; ) ;; Skip this function name if it is a prototype declaration. (if (and (eq fchar ?s) (eq char ?\;)) nil - (setq index (imenu-example--name-and-position)) - (if (eq fchar ?p) nil - (setq name (buffer-substring (match-beginning 3) (match-end 3))) - (set-text-properties 0 (length name) nil name) + (setq name (buffer-substring (match-beginning 3) (match-end 3)) + marker (make-marker)) + (set-text-properties 0 (length name) nil name) + (set-marker marker (match-end 3)) + (if (eq fchar ?p) + (setq name (concat "package " name)) (cond ((string-match "[:']" name) (setq meth t)) ((> p end-range) nil) (t (setq name (concat package name) meth t)))) - (setcar index name) + (setq index (cons name marker)) (if (eq fchar ?p) (push index index-pack-alist) (push index index-alist)) @@ -5188,6 +5495,25 @@ indentation and initial hashes. Behaves usually outside of comment." index-alist)) (cperl-imenu-addback index-alist))) + +(defvar cperl-outline-regexp + (concat imenu-example--function-name-regexp-perl "\\|" "\\`")) + +;; Suggested by Mark A. Hershberger +(defun cperl-outline-level () + (looking-at outline-regexp) + (cond ((not (match-beginning 1)) 0) ; beginning-of-file + ((match-beginning 2) + (if (eq (char-after (match-beginning 2)) ?p) + 0 ; package + 1)) ; sub + ((match-beginning 5) + (if (eq (char-after (match-beginning 5)) ?1) + 1 ; head1 + 2)) ; head2 + (t 3))) ; should not happen + + (defvar cperl-compilation-error-regexp-alist ;; This look like a paranoiac regexp: could anybody find a better one? (which WORK). '(("^[^\n]* \\(file\\|at\\) \\([^ \t\n]+\\) [^\n]*line \\([0-9]+\\)[\\., \n]" @@ -5270,7 +5596,7 @@ indentation and initial hashes. Behaves usually outside of comment." '("if" "until" "while" "elsif" "else" "unless" "for" "foreach" "continue" "exit" "die" "last" "goto" "next" "redo" "return" "local" "exec" "sub" "do" "dump" "use" - "require" "package" "eval" "my" "BEGIN" "END") + "require" "package" "eval" "my" "BEGIN" "END" "CHECK" "INIT") "\\|") ; Flow control "\\)\\>") 2) ; was "\\)[ \n\t;():,\|&]" ; In what follows we use `type' style @@ -5307,7 +5633,7 @@ indentation and initial hashes. Behaves usually outside of comment." ;; "setsockopt" "shmctl" "shmget" "shmread" "shmwrite" ;; "shutdown" "sin" "sleep" "socket" "socketpair" ;; "sprintf" "sqrt" "srand" "stat" "substr" "symlink" - ;; "syscall" "sysread" "system" "syswrite" "tell" + ;; "syscall" "sysopen" "sysread" "system" "syswrite" "tell" ;; "telldir" "time" "times" "truncate" "uc" "ucfirst" ;; "umask" "unlink" "unpack" "utime" "values" "vec" ;; "wait" "waitpid" "wantarray" "warn" "write" "x" "xor" @@ -5336,7 +5662,7 @@ indentation and initial hashes. Behaves usually outside of comment." "\\(iority\\|otoent\\)\\|went\\|grp\\)\\|hostent\\|s\\(ervent\\|" "ockopt\\)\\|netent\\|grent\\)\\|ek\\(\\|dir\\)\\|lect\\|" "m\\(ctl\\|op\\|get\\)\\|nd\\)\\|h\\(utdown\\|m\\(read\\|ctl\\|" - "write\\|get\\)\\)\\|y\\(s\\(read\\|call\\|tem\\|write\\)\\|" + "write\\|get\\)\\)\\|y\\(s\\(read\\|call\\|open\\|tem\\|write\\)\\|" "mlink\\)\\|in\\|leep\\|ocket\\(pair\\|\\)\\)\\|t\\(runcate\\|" "ell\\(\\|dir\\)\\|ime\\(\\|s\\)\\)\\|u\\(c\\(\\|first\\)\\|" "time\\|mask\\|n\\(pack\\|link\\)\\)\\|v\\(alues\\|ec\\)\\|" @@ -5349,7 +5675,7 @@ indentation and initial hashes. Behaves usually outside of comment." (list (concat "\\(^\\|[^$@%&\\]\\)\\<\\(" - ;; "AUTOLOAD" "BEGIN" "DESTROY" "END" "__END__" "chomp" + ;; "AUTOLOAD" "BEGIN" "CHECK" "DESTROY" "END" "INIT" "__END__" "chomp" ;; "chop" "defined" "delete" "do" "each" "else" "elsif" ;; "eval" "exists" "for" "foreach" "format" "goto" ;; "grep" "if" "keys" "last" "local" "map" "my" "next" @@ -5358,10 +5684,10 @@ indentation and initial hashes. Behaves usually outside of comment." ;; "sort" "splice" "split" "study" "sub" "tie" "tr" ;; "undef" "unless" "unshift" "untie" "until" "use" ;; "while" "y" - "AUTOLOAD\\|BEGIN\\|cho\\(p\\|mp\\)\\|d\\(e\\(fined\\|lete\\)\\|" + "AUTOLOAD\\|BEGIN\\|CHECK\\|cho\\(p\\|mp\\)\\|d\\(e\\(fined\\|lete\\)\\|" "o\\)\\|DESTROY\\|e\\(ach\\|val\\|xists\\|ls\\(e\\|if\\)\\)\\|" - "END\\|for\\(\\|each\\|mat\\)\\|g\\(rep\\|oto\\)\\|if\\|keys\\|" - "l\\(ast\\|ocal\\)\\|m\\(ap\\|y\\)\\|n\\(ext\\|o\\)\\|" + "END\\|for\\(\\|each\\|mat\\)\\|g\\(rep\\|oto\\)\\|INIT\\|if\\|keys\\|" + "l\\(ast\\|ocal\\)\\|m\\(ap\\|y\\)\\|n\\(ext\\|o\\)\\|our\\|" "p\\(ackage\\|rint\\(\\|f\\)\\|ush\\|o\\(p\\|s\\)\\)\\|" "q\\(\\|q\\|w\\|x\\|r\\)\\|re\\(turn\\|do\\)\\|s\\(pli\\(ce\\|t\\)\\|" "calar\\|tudy\\|ub\\|hift\\|ort\\)\\|t\\(r\\|ie\\)\\|" @@ -5399,8 +5725,12 @@ indentation and initial hashes. Behaves usually outside of comment." font-lock-constant-face) ; labels '("\\<\\(continue\\|next\\|last\\|redo\\|goto\\)\\>[ \t]+\\([a-zA-Z0-9_:]+\\)" ; labels as targets 2 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 ((featurep 'font-lock-extra) - '("^[ \t]*\\(my\\|local\\)[ \t]*\\(([ \t]*\\)?\\([$@%*][a-zA-Z0-9_:]+\\)\\([ \t]*,\\)?" + '("^[ \t]*\\(my\\|local\\|our\\)[ \t]*\\(([ \t]*\\)?\\([$@%*][a-zA-Z0-9_:]+\\)\\([ \t]*,\\)?" (3 font-lock-variable-name-face) (4 '(another 4 nil ("\\=[ \t]*,[ \t]*\\([$@%*][a-zA-Z0-9_:]+\\)\\([ \t]*,\\)?" @@ -5408,15 +5738,15 @@ indentation and initial hashes. Behaves usually outside of comment." (2 '(restart 2 nil) nil t))) nil t))) ; local variables, multiple (font-lock-anchored - '("^[ \t{}]*\\(my\\|local\\)[ \t]*\\(([ \t]*\\)?\\([$@%*][a-zA-Z0-9_:]+\\)" + '("^[ \t{}]*\\(my\\|local\\|our\\)[ \t]*\\(([ \t]*\\)?\\([$@%*][a-zA-Z0-9_:]+\\)" (3 font-lock-variable-name-face) ("\\=[ \t]*,[ \t]*\\([$@%*][a-zA-Z0-9_:]+\\)" nil nil (1 font-lock-variable-name-face)))) - (t '("^[ \t{}]*\\(my\\|local\\)[ \t]*\\(([ \t]*\\)?\\([$@%*][a-zA-Z0-9_:]+\\)" + (t '("^[ \t{}]*\\(my\\|local\\our\\)[ \t]*\\(([ \t]*\\)?\\([$@%*][a-zA-Z0-9_:]+\\)" 3 font-lock-variable-name-face))) - '("\\ is a synonym for <>. ARGVOUT Output filehandle with -i flag. BEGIN { ... } Immediately executed (during compilation) piece of code. END { ... } Pseudo-subroutine executed after the script finishes. +CHECK { ... } Pseudo-subroutine executed after the script is compiled. +INIT { ... } Pseudo-subroutine executed before the script starts running. DATA Input filehandle for what follows after __END__ or __DATA__. accept(NEWSOCKET,GENERICSOCKET) alarm(SECONDS) @@ -7140,6 +7495,7 @@ msgget(KEY,FLAGS) msgrcv(ID,VAR,SIZE,TYPE.FLAGS) msgsnd(ID,MSG,FLAGS) my VAR or my (VAR1,...) Introduces a lexical variable ($VAR, @ARR, or %HASH). +our VAR or our (VAR1,...) Lexically enable a global variable ($V, @A, or %H). ... ne ... String inequality. next [LABEL] oct(EXPR) @@ -7308,14 +7664,18 @@ prototype \&SUB Returns prototype of the function given a reference. 'variable-documentation)) (setq buffer-read-only t))))) -(defun cperl-beautify-regexp-piece (b e embed) +(defun cperl-beautify-regexp-piece (b e embed level) ;; b is before the starting delimiter, e before the ending ;; e should be a marker, may be changed, but remains "correct". - (let (s c tmp (m (make-marker)) (m1 (make-marker)) c1 spaces inline code) + ;; EMBED is nil iff we process the whole REx. + ;; The REx is guarantied to have //x + ;; LEVEL shows how many levels deep to go + ;; position at enter and at leave is not defined + (let (s c tmp (m (make-marker)) (m1 (make-marker)) c1 spaces inline code pos) (if (not embed) (goto-char (1+ b)) (goto-char b) - (cond ((looking-at "(\\?\\\\#") ; badly commented (?#) + (cond ((looking-at "(\\?\\\\#") ; (?#) wrongly commented when //x-ing (forward-char 2) (delete-char 1) (forward-char 1)) @@ -7333,8 +7693,9 @@ prototype \&SUB Returns prototype of the function given a reference. (goto-char e) (beginning-of-line) (if (re-search-forward "[^ \t]" e t) - (progn + (progn ; Something before the ending delimiter (goto-char e) + (delete-horizontal-space) (insert "\n") (indent-to-column c) (set-marker e (point)))) @@ -7377,17 +7738,27 @@ prototype \&SUB Returns prototype of the function given a reference. (setq tmp (point)) (if (looking-at "\\^?\\]") (goto-char (match-end 0))) - (or (re-search-forward "\\]\\([*+{?]\\)?" e t) + ;; XXXX POSIX classes?! + (while (and (not pos) + (re-search-forward "\\[:\\|\\]" e t)) + (if (eq (preceding-char) ?:) + (or (re-search-forward ":\\]" e t) + (error "[:POSIX:]-group in []-group not terminated")) + (setq pos t))) + (or (eq (preceding-char) ?\]) + (error "[]-group not terminated")) + (if (eq (following-char) ?\{) (progn - (goto-char (1- tmp)) - (error "[]-group not terminated"))) - (if (not (eq (preceding-char) ?\{)) nil - (forward-char -1) - (forward-sexp 1))) + (forward-sexp 1) + (and (eq (following-char) ??) + (forward-char 1))) + (re-search-forward "\\=\\([*+?]\\??\\)" e t))) ((match-beginning 7) ; () (goto-char (match-beginning 0)) - (or (eq (current-column) c1) + (setq pos (current-column)) + (or (eq pos c1) (progn + (delete-horizontal-space) (insert "\n") (indent-to-column c1))) (setq tmp (point)) @@ -7398,20 +7769,29 @@ prototype \&SUB Returns prototype of the function given a reference. ;; (error "()-group not terminated"))) (set-marker m (1- (point))) (set-marker m1 (point)) - (cond - ((not (match-beginning 8)) - (cperl-beautify-regexp-piece tmp m t)) - ((eq (char-after (+ 2 tmp)) ?\{) ; Code - t) - ((eq (char-after (+ 2 tmp)) ?\() ; Conditional - (goto-char (+ 2 tmp)) - (forward-sexp 1) - (cperl-beautify-regexp-piece (point) m t)) - ((eq (char-after (+ 2 tmp)) ?<) ; Lookbehind - (goto-char (+ 3 tmp)) - (cperl-beautify-regexp-piece (point) m t)) - (t - (cperl-beautify-regexp-piece tmp m t))) + (if (= level 1) + (if (progn ; indent rigidly if multiline + ;; In fact does not make a lot of sense, since + ;; the starting position can be already lost due + ;; to insertion of "\n" and " " + (goto-char tmp) + (search-forward "\n" m1 t)) + (indent-rigidly (point) m1 (- c1 pos))) + (setq level (1- level)) + (cond + ((not (match-beginning 8)) + (cperl-beautify-regexp-piece tmp m t level)) + ((eq (char-after (+ 2 tmp)) ?\{) ; Code + t) + ((eq (char-after (+ 2 tmp)) ?\() ; Conditional + (goto-char (+ 2 tmp)) + (forward-sexp 1) + (cperl-beautify-regexp-piece (point) m t level)) + ((eq (char-after (+ 2 tmp)) ?<) ; Lookbehind + (goto-char (+ 3 tmp)) + (cperl-beautify-regexp-piece (point) m t level)) + (t + (cperl-beautify-regexp-piece tmp m t level)))) (goto-char m1) (cond ((looking-at "[*+?]\\??") (goto-char (match-end 0))) @@ -7425,6 +7805,7 @@ prototype \&SUB Returns prototype of the function given a reference. (progn (or (eolp) (indent-for-comment)) (beginning-of-line 2)) + (delete-horizontal-space) (insert "\n")) (end-of-line) (setq inline nil)) @@ -7435,6 +7816,7 @@ prototype \&SUB Returns prototype of the function given a reference. (if (re-search-forward "[^ \t]" tmp t) (progn (goto-char tmp) + (delete-horizontal-space) (insert "\n")) ;; first at line (delete-region (point) tmp)) @@ -7444,6 +7826,7 @@ prototype \&SUB Returns prototype of the function given a reference. (setq spaces nil) (if (looking-at "[#\n]") (beginning-of-line 2) + (delete-horizontal-space) (insert "\n")) (end-of-line) (setq inline nil))) @@ -7452,8 +7835,8 @@ prototype \&SUB Returns prototype of the function given a reference. (insert " ")) (skip-chars-forward " \t")) (or (looking-at "[#\n]") - (error "unknown code \"%s\" in a regexp" (buffer-substring (point) - (1+ (point))))) + (error "unknown code \"%s\" in a regexp" + (buffer-substring (point) (1+ (point))))) (and inline (end-of-line 2))) ;; Special-case the last line of group (if (and (>= (point) (marker-position e)) @@ -7468,6 +7851,7 @@ prototype \&SUB Returns prototype of the function given a reference. (defun cperl-make-regexp-x () ;; Returns position of the start + ;; XXX this is called too often! Need to cache the result! (save-excursion (or cperl-use-syntax-table-text-property (error "I need to have a regexp marked!")) @@ -7498,15 +7882,19 @@ prototype \&SUB Returns prototype of the function given a reference. (forward-char 1))) b))) -(defun cperl-beautify-regexp () +(defun cperl-beautify-regexp (&optional deep) "do it. (Experimental, may change semantics, recheck the result.) We suppose that the regexp is scanned already." - (interactive) - (goto-char (cperl-make-regexp-x)) - (let ((b (point)) (e (make-marker))) - (forward-sexp 1) - (set-marker e (1- (point))) - (cperl-beautify-regexp-piece b e nil))) + (interactive "P") + (if deep + (prefix-numeric-value deep) + (setq deep -1)) + (save-excursion + (goto-char (cperl-make-regexp-x)) + (let ((b (point)) (e (make-marker))) + (forward-sexp 1) + (set-marker e (1- (point))) + (cperl-beautify-regexp-piece b e nil deep)))) (defun cperl-regext-to-level-start () "Goto start of an enclosing group in regexp. @@ -7528,61 +7916,67 @@ We suppose that the regexp is scanned already." \(Experimental, may change semantics, recheck the result.) We suppose that the regexp is scanned already." (interactive) - (cperl-regext-to-level-start) - (let ((b (point)) (e (make-marker)) s c) - (forward-sexp 1) - (set-marker e (1- (point))) - (goto-char b) - (while (re-search-forward "\\(#\\)\\|\n" e t) - (cond - ((match-beginning 1) ; #-comment - (or c (setq c (current-indentation))) - (beginning-of-line 2) ; Skip - (setq s (point)) - (skip-chars-forward " \t") - (delete-region s (point)) - (indent-to-column c)) - (t - (delete-char -1) - (just-one-space)))))) + ;; (save-excursion ; Can't, breaks `cperl-contract-levels' + (cperl-regext-to-level-start) + (let ((b (point)) (e (make-marker)) s c) + (forward-sexp 1) + (set-marker e (1- (point))) + (goto-char b) + (while (re-search-forward "\\(#\\)\\|\n" e 'to-end) + (cond + ((match-beginning 1) ; #-comment + (or c (setq c (current-indentation))) + (beginning-of-line 2) ; Skip + (setq s (point)) + (skip-chars-forward " \t") + (delete-region s (point)) + (indent-to-column c)) + (t + (delete-char -1) + (just-one-space)))))) (defun cperl-contract-levels () "Find an enclosing group in regexp and contract all the kids. \(Experimental, may change semantics, recheck the result.) We suppose that the regexp is scanned already." (interactive) - (condition-case nil - (cperl-regext-to-level-start) - (error ; We are outside outermost group - (goto-char (cperl-make-regexp-x)))) - (let ((b (point)) (e (make-marker)) s c) - (forward-sexp 1) - (set-marker e (1- (point))) - (goto-char (1+ b)) - (while (re-search-forward "\\(\\\\\\\\\\)\\|(" e t) - (cond - ((match-beginning 1) ; Skip - nil) - (t ; Group - (cperl-contract-level)))))) - -(defun cperl-beautify-level () + (save-excursion + (condition-case nil + (cperl-regext-to-level-start) + (error ; We are outside outermost group + (goto-char (cperl-make-regexp-x)))) + (let ((b (point)) (e (make-marker)) s c) + (forward-sexp 1) + (set-marker e (1- (point))) + (goto-char (1+ b)) + (while (re-search-forward "\\(\\\\\\\\\\)\\|(" e t) + (cond + ((match-beginning 1) ; Skip + nil) + (t ; Group + (cperl-contract-level))))))) + +(defun cperl-beautify-level (&optional deep) "Find an enclosing group in regexp and beautify it. \(Experimental, may change semantics, recheck the result.) We suppose that the regexp is scanned already." - (interactive) - (cperl-regext-to-level-start) - (let ((b (point)) (e (make-marker))) - (forward-sexp 1) - (set-marker e (1- (point))) - (cperl-beautify-regexp-piece b e nil))) + (interactive "P") + (if deep + (prefix-numeric-value deep) + (setq deep -1)) + (save-excursion + (cperl-regext-to-level-start) + (let ((b (point)) (e (make-marker))) + (forward-sexp 1) + (set-marker e (1- (point))) + (cperl-beautify-regexp-piece b e nil deep)))) (defun cperl-invert-if-unless () - "Change `if (A) {B}' into `B if A;' if possible." + "Change `if (A) {B}' into `B if A;' etc if possible." (interactive) (or (looking-at "\\<") (forward-sexp -1)) - (if (looking-at "\\<\\(if\\|unless\\|while\\|until\\)\\>") + (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)))) @@ -7653,6 +8047,7 @@ We suppose that the regexp is scanned already." (forward-word 1) (setq pos1 (point)) (insert " " s1 ";") + (delete-horizontal-space) (forward-char -1) (delete-horizontal-space) (goto-char pos1) @@ -7660,7 +8055,7 @@ We suppose that the regexp is scanned already." (cperl-indent-line)) (error "`%s' (EXPR) not with an {BLOCK}" s0))) (error "`%s' not with an (EXPR)" s0))) - (error "Not at `if', `unless', `while', or `unless'"))) + (error "Not at `if', `unless', `while', `unless', `for' or `foreach'"))) ;;; By Anthony Foiani ;;; Getting help on modules in C-h f ? @@ -7789,6 +8184,7 @@ We suppose that the regexp is scanned already." (defvar cperl-d-l nil) (defun cperl-fontify-syntaxically (end) ;; Some vars for debugging only + ;; (message "Syntaxifying...") (let (start (dbg (point)) (iend end) (istate (car cperl-syntax-state))) (and cperl-syntaxify-unwind @@ -7806,12 +8202,6 @@ We suppose that the regexp is scanned already." (and (> end start) (setq cperl-syntax-done-to start) ; In case what follows fails (cperl-find-pods-heres start end t nil t)) - ;;(setq cperl-d-l (cons (format "Syntaxifying %s..%s from %s to %s\n" - ;; dbg end start cperl-syntax-done-to) - ;; cperl-d-l)) - ;;(let ((standard-output (get-buffer "*Messages*"))) - ;;(princ (format "Syntaxifying %s..%s from %s to %s\n" - ;; dbg end start cperl-syntax-done-to))) (if (eq cperl-syntaxify-by-font-lock 'message) (message "Syntaxified %s..%s from %s to %s(%s), state %s-->%s" dbg iend @@ -7839,7 +8229,7 @@ We suppose that the regexp is scanned already." (cperl-fontify-syntaxically to))))) (defvar cperl-version - (let ((v "$Revision: 4.23 $")) + (let ((v "$Revision: 4.32 $")) (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.") -- cgit v1.2.1