diff options
Diffstat (limited to 'lisp/progmodes/cperl-mode.el')
| -rw-r--r-- | lisp/progmodes/cperl-mode.el | 4130 |
1 files changed, 2947 insertions, 1183 deletions
diff --git a/lisp/progmodes/cperl-mode.el b/lisp/progmodes/cperl-mode.el index ad44753f352..3264e0e72f6 100644 --- a/lisp/progmodes/cperl-mode.el +++ b/lisp/progmodes/cperl-mode.el @@ -5,7 +5,7 @@ ;; Free Software Foundation, Inc. ;; Author: Ilya Zakharevich and Bob Olson -;; Maintainer: Ilya Zakharevich <cperl@ilyaz.org> +;; Maintainer: Ilya Zakharevich <ilyaz@cpan.org> ;; Keywords: languages, Perl ;; This file is part of GNU Emacs. @@ -25,7 +25,7 @@ ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. -;;; Corrections made by Ilya Zakharevich cperl@ilyaz.org +;;; Corrections made by Ilya Zakharevich ilyaz@cpan.org ;;; Commentary: @@ -67,67 +67,89 @@ ;; likewise with m, tr, y, q, qX instead of s ;;; Code: - + (defvar vc-rcs-header) (defvar vc-sccs-header) -;; Some macros are needed for `defcustom' (eval-when-compile - (condition-case nil - (require 'man) - (error nil)) - (defconst cperl-xemacs-p (string-match "XEmacs\\|Lucid" emacs-version)) - (defvar cperl-can-font-lock - (or cperl-xemacs-p - (and (boundp 'emacs-major-version) - (or window-system - (> emacs-major-version 20))))) - (if cperl-can-font-lock - (require 'font-lock)) - (defvar msb-menu-cond) - (defvar gud-perldb-history) - (defvar font-lock-background-mode) ; not in Emacs - (defvar font-lock-display-type) ; ditto - (defmacro cperl-is-face (arg) ; Takes quoted arg - (cond ((fboundp 'find-face) - `(find-face ,arg)) - (;;(and (fboundp 'face-list) - ;; (face-list)) - (fboundp 'face-list) - `(member ,arg (and (fboundp 'face-list) - (face-list)))) - (t - `(boundp ,arg)))) - (defmacro cperl-make-face (arg descr) ; Takes unquoted arg - (cond ((fboundp 'make-face) - `(make-face (quote ,arg))) - (t - `(defvar ,arg (quote ,arg) ,descr)))) - (defmacro cperl-force-face (arg descr) ; Takes unquoted arg - `(progn - (or (cperl-is-face (quote ,arg)) - (cperl-make-face ,arg ,descr)) - (or (boundp (quote ,arg)) ; We use unquoted variants too - (defvar ,arg (quote ,arg) ,descr)))) - (if cperl-xemacs-p - (defmacro cperl-etags-snarf-tag (file line) - `(progn - (beginning-of-line 2) - (list ,file ,line))) - (defmacro cperl-etags-snarf-tag (file line) - `(etags-snarf-tag))) - (if cperl-xemacs-p - (defmacro cperl-etags-goto-tag-location (elt) - ;;(progn - ;; (switch-to-buffer (get-file-buffer (elt (, elt) 0))) - ;; (set-buffer (get-file-buffer (elt (, elt) 0))) - ;; Probably will not work due to some save-excursion??? - ;; Or save-file-position? - ;; (message "Did I get to line %s?" (elt (, elt) 1)) - `(goto-line (string-to-number (elt ,elt 1)))) - ;;) - (defmacro cperl-etags-goto-tag-location (elt) - `(etags-goto-tag-location ,elt)))) + (condition-case nil + (require 'custom) + (error nil)) + (condition-case nil + (require 'man) + (error nil)) + (defconst cperl-xemacs-p (string-match "XEmacs\\|Lucid" emacs-version)) + (defvar cperl-can-font-lock + (or cperl-xemacs-p + (and (boundp 'emacs-major-version) + (or window-system + (> emacs-major-version 20))))) + (if cperl-can-font-lock + (require 'font-lock)) + (defvar msb-menu-cond) + (defvar gud-perldb-history) + (defvar font-lock-background-mode) ; not in Emacs + (defvar font-lock-display-type) ; ditto + (defvar paren-backwards-message) ; Not in newer XEmacs? + (or (fboundp 'defgroup) + (defmacro defgroup (name val doc &rest arr) + nil)) + (or (fboundp 'custom-declare-variable) + (defmacro defcustom (name val doc &rest arr) + (` (defvar (, name) (, val) (, doc))))) + (or (and (fboundp 'custom-declare-variable) + (string< "19.31" emacs-version)) ; Checked with 19.30: defface does not work + (defmacro defface (&rest arr) + nil)) + ;; Avoid warning (tmp definitions) + (or (fboundp 'x-color-defined-p) + (defmacro x-color-defined-p (col) + (cond ((fboundp 'color-defined-p) (` (color-defined-p (, col)))) + ;; XEmacs >= 19.12 + ((fboundp 'valid-color-name-p) (` (valid-color-name-p (, col)))) + ;; XEmacs 19.11 + ((fboundp 'x-valid-color-name-p) (` (x-valid-color-name-p (, col)))) + (t '(error "Cannot implement color-defined-p"))))) + (defmacro cperl-is-face (arg) ; Takes quoted arg + (cond ((fboundp 'find-face) + (` (find-face (, arg)))) + (;;(and (fboundp 'face-list) + ;; (face-list)) + (fboundp 'face-list) + (` (member (, arg) (and (fboundp 'face-list) + (face-list))))) + (t + (` (boundp (, arg)))))) + (defmacro cperl-make-face (arg descr) ; Takes unquoted arg + (cond ((fboundp 'make-face) + (` (make-face (quote (, arg))))) + (t + (` (defvar (, arg) (quote (, arg)) (, descr)))))) + (defmacro cperl-force-face (arg descr) ; Takes unquoted arg + (` (progn + (or (cperl-is-face (quote (, arg))) + (cperl-make-face (, arg) (, descr))) + (or (boundp (quote (, arg))) ; We use unquoted variants too + (defvar (, arg) (quote (, arg)) (, descr)))))) + (if cperl-xemacs-p + (defmacro cperl-etags-snarf-tag (file line) + (` (progn + (beginning-of-line 2) + (list (, file) (, line))))) + (defmacro cperl-etags-snarf-tag (file line) + (` (etags-snarf-tag)))) + (if cperl-xemacs-p + (defmacro cperl-etags-goto-tag-location (elt) + (`;;(progn + ;; (switch-to-buffer (get-file-buffer (elt (, elt) 0))) + ;; (set-buffer (get-file-buffer (elt (, elt) 0))) + ;; Probably will not work due to some save-excursion??? + ;; Or save-file-position? + ;; (message "Did I get to line %s?" (elt (, elt) 1)) + (goto-line (string-to-int (elt (, elt) 1))))) + ;;) + (defmacro cperl-etags-goto-tag-location (elt) + (` (etags-goto-tag-location (, elt)))))) (defconst cperl-xemacs-p (string-match "XEmacs\\|Lucid" emacs-version)) @@ -251,6 +273,12 @@ This is in addition to cperl-continued-statement-offset." :type 'integer :group 'cperl-indentation-details) +(defcustom cperl-indent-wrt-brace t + "*Non-nil means indent statements in if/etc block relative brace, not if/etc. +Versions 5.2 ... 5.20 behaved as if this were `nil'." + :type 'boolean + :group 'cperl-indentation-details) + (defcustom cperl-auto-newline nil "*Non-nil means automatically newline before and after braces, and after colons and semicolons, inserted in CPerl code. The following @@ -347,20 +375,26 @@ Affects: `cperl-font-lock', `cperl-electric-lbrace-space', :type 'integer :group 'cperl-indentation-details) -(defvar cperl-vc-header-alist nil) -(make-obsolete-variable - 'cperl-vc-header-alist - "use cperl-vc-rcs-header or cperl-vc-sccs-header instead.") +(defcustom cperl-indent-comment-at-column-0 nil + "*Non-nil means that comment started at column 0 should be indentable." + :type 'boolean + :group 'cperl-indentation-details) (defcustom cperl-vc-sccs-header '("($sccs) = ('%W\%' =~ /(\\d+(\\.\\d+)+)/) ;") "*Special version of `vc-sccs-header' that is used in CPerl mode buffers." :type '(repeat string) :group 'cperl) -(defcustom cperl-vc-rcs-header '("($rcs) = (' $Id\$ ' =~ /(\\d+(\\.\\d+)+)/) ;") +(defcustom cperl-vc-rcs-header '("($rcs) = (' $Id\$ ' =~ /(\\d+(\\.\\d+)+)/);") "*Special version of `vc-rcs-header' that is used in CPerl mode buffers." :type '(repeat string) - :group 'cperl) + :group 'cperl) + +;; This became obsolete... +(defvar cperl-vc-header-alist nil) +(make-obsolete-variable + 'cperl-vc-header-alist + "use cperl-vc-rcs-header or cperl-vc-sccs-header instead.") (defcustom cperl-clobber-mode-lists (not @@ -408,8 +442,15 @@ Font for POD headers." :type 'face :group 'cperl-faces) -(defcustom cperl-invalid-face 'underline - "*Face for highlighting trailing whitespace." +;;; Some double-evaluation happened with font-locks... Needed with 21.2... +(defvar cperl-singly-quote-face cperl-xemacs-p) + +(defcustom cperl-invalid-face ; Does not customize with '' on XEmacs + (if cperl-singly-quote-face + 'underline ''underline) ; On older Emacsen was evaluated by `font-lock' + (if cperl-singly-quote-face + "*This face is used for highlighting trailing whitespace." + "*Face for highlighting trailing whitespace.") :type 'face :version "21.1" :group 'cperl-faces) @@ -441,7 +482,14 @@ You can always make lookup from menu or using \\[cperl-find-pods-heres]." (defcustom cperl-regexp-scan t "*Not-nil means make marking of regular expression more thorough. -Effective only with `cperl-pod-here-scan'. Not implemented yet." +Effective only with `cperl-pod-here-scan'." + :type 'boolean + :group 'cperl-speed) + +(defcustom cperl-hook-after-change t + "*Not-nil means install hook to know which regions of buffer are changed. +May significantly speed up delayed fontification. Changes take effect +after reload." :type 'boolean :group 'cperl-speed) @@ -564,17 +612,25 @@ when syntaxifying a chunk of buffer." :type 'boolean :group 'cperl-speed) +(defcustom cperl-syntaxify-for-menu + t + "*Non-nil means that CPerl syntaxifies up to the point before showing menu. +This way enabling/disabling of menu items is more correct." + :type 'boolean + :group 'cperl-speed) + (defcustom cperl-ps-print-face-properties '((font-lock-keyword-face nil nil bold shadow) (font-lock-variable-name-face nil nil bold) (font-lock-function-name-face nil nil bold italic box) (font-lock-constant-face nil "LightGray" bold) - (cperl-array nil "LightGray" bold underline) - (cperl-hash nil "LightGray" bold italic underline) + (cperl-array-face nil "LightGray" bold underline) + (cperl-hash-face nil "LightGray" bold italic underline) (font-lock-comment-face nil "LightGray" italic) (font-lock-string-face nil nil italic underline) - (cperl-nonoverridable nil nil italic underline) + (cperl-nonoverridable-face nil nil italic underline) (font-lock-type-face nil nil underline) + (font-lock-warning-face nil "LightGray" bold italic box) (underline nil "LightGray" strikeout)) "List given as an argument to `ps-extend-face-list' in `cperl-ps-print'." :type '(repeat (cons symbol @@ -588,7 +644,7 @@ when syntaxifying a chunk of buffer." (defvar cperl-dark-foreground (cperl-choose-color "orchid1" "orange")) -(defface cperl-nonoverridable +(defface cperl-nonoverridable-face `((((class grayscale) (background light)) (:background "Gray90" :slant italic :underline t)) (((class grayscale) (background dark)) @@ -600,10 +656,8 @@ when syntaxifying a chunk of buffer." (t (:weight bold :underline t))) "Font Lock mode face used non-overridable keywords and modifiers of regexps." :group 'cperl-faces) -;; backward-compatibility alias -(put 'cperl-nonoverridable-face 'face-alias 'cperl-nonoverridable) -(defface cperl-array +(defface cperl-array-face `((((class grayscale) (background light)) (:background "Gray90" :weight bold)) (((class grayscale) (background dark)) @@ -615,10 +669,8 @@ when syntaxifying a chunk of buffer." (t (:weight bold))) "Font Lock mode face used to highlight array names." :group 'cperl-faces) -;; backward-compatibility alias -(put 'cperl-array-face 'face-alias 'cperl-array) -(defface cperl-hash +(defface cperl-hash-face `((((class grayscale) (background light)) (:background "Gray90" :weight bold :slant italic)) (((class grayscale) (background dark)) @@ -630,8 +682,6 @@ when syntaxifying a chunk of buffer." (t (:weight bold :slant italic))) "Font Lock mode face used to highlight hash names." :group 'cperl-faces) -;; backward-compatibility alias -(put 'cperl-hash-face 'face-alias 'cperl-hash) @@ -639,9 +689,7 @@ when syntaxifying a chunk of buffer." (defvar cperl-tips 'please-ignore-this-line "Get maybe newer version of this package from - ftp://ftp.math.ohio-state.edu/pub/users/ilya/emacs -and/or - ftp://ftp.math.ohio-state.edu/pub/users/ilya/perl + http://ilyaz.org/software/emacs Subdirectory `cperl-mode' may contain yet newer development releases and/or patches to related files. @@ -666,9 +714,9 @@ want it to: put the following into your .emacs file: (defalias 'perl-mode 'cperl-mode) Get perl5-info from - $CPAN/doc/manual/info/perl-info.tar.gz -older version was on - http://www.metronet.com:70/9/perlinfo/perl5/manual/perl5-info.tar.gz + $CPAN/doc/manual/info/perl5-old/perl5-info.tar.gz +Also, one can generate a newer documentation running `pod2texi' converter + $CPAN/doc/manual/info/perl5/pod2texi-0.1.tar.gz If you use imenu-go, run imenu on perl5-info buffer (you can do it from Perl menu). If many files are related, generate TAGS files from @@ -700,11 +748,18 @@ micro-docs on what I know about CPerl problems.") "Description of problems in CPerl mode. Some faces will not be shown on some versions of Emacs unless you install choose-color.el, available from - ftp://ftp.math.ohio-state.edu/pub/users/ilya/emacs/ + http://ilyaz.org/software/emacs `fill-paragraph' on a comment may leave the point behind the -paragraph. Parsing of lines with several <<EOF is not implemented -yet. +paragraph. It also triggers a bug in some versions of Emacs (CPerl tries +to detect it and bulk out). + +See documentation of a variable `cperl-problems-old-emaxen' for the +problems which disappear if you upgrade Emacs to a reasonably new +version (20.3 for Emacs, and those of 2004 for XEmacs).") + +(defvar cperl-problems-old-emaxen 'please-ignore-this-line + "Description of problems in CPerl mode specific for older Emacs versions. Emacs had a _very_ restricted syntax parsing engine until version 20.1. Most problems below are corrected starting from this version of @@ -812,6 +867,13 @@ voice); o) Highlights trailing whitespace; p) Is able to manipulate Perl Regular Expressions to ease conversion to a more readable form. + q) Can ispell POD sections and HERE-DOCs. + r) Understands comments and character classes inside regular + expressions; can find matching () and [] in a regular expression. + s) Allows indentation of //x-style regular expressions; + t) Highlights different symbols in regular expressions according + to their function; much less problems with backslashitis; + u) Allows to find regular expressions which contain interpolated parts. 5) The indentation engine was very smart, but most of tricks may be not needed anymore with the support for `syntax-table' property. Has @@ -829,7 +891,10 @@ the settings present before the switch. line-breaks/spacing between elements of the construct. 10) Uses a linear-time algorith for indentation of regions (on Emaxen with -capable syntax engines).") +capable syntax engines). + +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 @@ -878,19 +943,19 @@ B) Speed of editing operations. (defvar cperl-tips-faces 'please-ignore-this-line "CPerl mode uses following faces for highlighting: - `cperl-array' Array names - `cperl-hash' Hash names + `cperl-array-face' Array names + `cperl-hash-face' Hash names `font-lock-comment-face' Comments, PODs and whatever is considered syntaxically to be not code `font-lock-constant-face' HERE-doc delimiters, labels, delimiters of 2-arg operators s/y/tr/ or of RExen, - `font-lock-function-name-face' Special-cased m// and s//foo/, _ as - a target of a file tests, file tests, + `font-lock-warning-face' Special-cased m// and s//foo/, + `font-lock-function-name-face' _ as a target of a file tests, file tests, subroutine names at the moment of definition (except those conflicting with Perl operators), package names (when recognized), format names `font-lock-keyword-face' Control flow switch constructs, declarators - `cperl-nonoverridable' Non-overridable keywords, modifiers of RExen + `cperl-nonoverridable-face' Non-overridable keywords, modifiers of RExen `font-lock-string-face' Strings, qw() constructs, RExen, POD sections, literal parts and the terminator of formats and whatever is syntaxically considered @@ -908,7 +973,25 @@ m// and s/// which do not do what one would expect them to do. Help with best setup of these faces for printout requested (for each of the faces: please specify bold, italic, underline, shadow and box.) -\(Not finished.)") +In regular expressions (except character classes): + `font-lock-string-face' \"Normal\" stuff and non-0-length constructs + `font-lock-constant-face': Delimiters + `font-lock-warning-face' Special-cased m// and s//foo/, + Mismatched closing delimiters, parens + we couldn't match, misplaced quantifiers, + unrecognized escape sequences + `cperl-nonoverridable-face' Modifiers, as gism in m/REx/gism + `font-lock-type-face' POSIX classes inside charclasses, + escape sequences with arguments (\x \23 \p \N) + and others match-a-char escape sequences + `font-lock-keyword-face' Capturing parens, and | + `font-lock-function-name-face' Special symbols: $ ^ . [ ] [^ ] (?{ }) (??{ }) + `font-lock-builtin-face' \"Remaining\" 0-length constructs, executable + parts of a REx, not-capturing parens + `font-lock-variable-name-face' Interpolated constructs, embedded code + `font-lock-comment-face' Embedded comments + +") @@ -985,6 +1068,25 @@ the faces: please specify bold, italic, underline, shadow and box.) (cperl-hairy (or hairy t)) (t (symbol-value symbol)))) + +(defun cperl-make-indent (column &optional minimum keep) + "Makes indent of the current line the requested amount. +Unless KEEP, removes the old indentation. Works around a bug in ancient +versions of Emacs." + (let ((prop (get-text-property (point) 'syntax-type))) + (or keep + (delete-horizontal-space)) + (indent-to column minimum) + ;; In old versions (e.g., 19.33) `indent-to' would not inherit properties + (and prop + (> (current-column) 0) + (save-excursion + (beginning-of-line) + (or (get-text-property (point) 'syntax-type) + (and (looking-at "\\=[ \t]") + (put-text-property (point) (match-end 0) + 'syntax-type prop))))))) + ;;; Probably it is too late to set these guys already, but it can help later: ;;;(and cperl-clobber-mode-lists @@ -1035,7 +1137,16 @@ the faces: please specify bold, italic, underline, shadow and box.) (cperl-define-key "\C-c\C-w" 'cperl-toggle-construct-fix) (cperl-define-key "\C-c\C-f" 'auto-fill-mode) (cperl-define-key "\C-c\C-e" 'cperl-toggle-electric) + (cperl-define-key "\C-c\C-b" 'cperl-find-bad-style) + (cperl-define-key "\C-c\C-p" 'cperl-pod-spell) + (cperl-define-key "\C-c\C-d" 'cperl-here-doc-spell) + (cperl-define-key "\C-c\C-n" 'cperl-narrow-to-here-doc) + (cperl-define-key "\C-c\C-v" 'cperl-next-interpolated-REx) + (cperl-define-key "\C-c\C-x" 'cperl-next-interpolated-REx-0) + (cperl-define-key "\C-c\C-y" 'cperl-next-interpolated-REx-1) (cperl-define-key "\C-c\C-ha" 'cperl-toggle-autohelp) + (cperl-define-key "\C-c\C-hp" 'cperl-perldoc) + (cperl-define-key "\C-c\C-hP" 'cperl-perldoc-at-point) (cperl-define-key "\e\C-q" 'cperl-indent-exp) ; Usually not bound (cperl-define-key [?\C-\M-\|] 'cperl-lineup [(control meta |)]) @@ -1074,9 +1185,13 @@ the faces: please specify bold, italic, underline, shadow and box.) (<= emacs-minor-version 11) (<= emacs-major-version 19)) (progn ;; substitute-key-definition is usefulness-deenhanced... - (cperl-define-key "\M-q" 'cperl-fill-paragraph) + ;;;;;(cperl-define-key "\M-q" 'cperl-fill-paragraph) (cperl-define-key "\e;" 'cperl-indent-for-comment) (cperl-define-key "\e\C-\\" 'cperl-indent-region)) + (or (boundp 'fill-paragraph-function) + (substitute-key-definition + 'fill-paragraph 'cperl-fill-paragraph + cperl-mode-map global-map)) (substitute-key-definition 'indent-sexp 'cperl-indent-exp cperl-mode-map global-map) @@ -1094,52 +1209,101 @@ the faces: please specify bold, italic, underline, shadow and box.) (progn (require 'easymenu) (easy-menu-define - cperl-menu cperl-mode-map "Menu for CPerl mode" - '("Perl" - ["Beginning of function" beginning-of-defun t] - ["End of function" end-of-defun t] - ["Mark function" mark-defun t] - ["Indent expression" cperl-indent-exp t] + cperl-menu cperl-mode-map "Menu for CPerl mode" + '("Perl" + ["Beginning of function" beginning-of-defun t] + ["End of function" end-of-defun t] + ["Mark function" mark-defun t] + ["Indent expression" cperl-indent-exp t] ["Fill paragraph/comment" fill-paragraph t] + "----" + ["Line up a construction" cperl-lineup (cperl-use-region-p)] + ["Invert if/unless/while etc" cperl-invert-if-unless t] + ("Regexp" + ["Beautify" cperl-beautify-regexp + cperl-use-syntax-table-text-property] + ["Beautify one level deep" (cperl-beautify-regexp 1) + cperl-use-syntax-table-text-property] + ["Beautify a group" cperl-beautify-level + cperl-use-syntax-table-text-property] + ["Beautify a group one level deep" (cperl-beautify-level 1) + cperl-use-syntax-table-text-property] + ["Contract a group" cperl-contract-level + cperl-use-syntax-table-text-property] + ["Contract groups" cperl-contract-levels + cperl-use-syntax-table-text-property] "----" - ["Line up a construction" cperl-lineup (cperl-use-region-p)] - ["Invert if/unless/while etc" cperl-invert-if-unless t] - ("Regexp" - ["Beautify" cperl-beautify-regexp - cperl-use-syntax-table-text-property] - ["Beautify one level deep" (cperl-beautify-regexp 1) - cperl-use-syntax-table-text-property] - ["Beautify a group" cperl-beautify-level - cperl-use-syntax-table-text-property] - ["Beautify a group one level deep" (cperl-beautify-level 1) - cperl-use-syntax-table-text-property] - ["Contract a group" cperl-contract-level - cperl-use-syntax-table-text-property] - ["Contract groups" cperl-contract-levels - cperl-use-syntax-table-text-property]) - ["Refresh \"hard\" constructions" cperl-find-pods-heres t] + ["Find next interpolated" cperl-next-interpolated-REx + (next-single-property-change (point-min) 'REx-interpolated)] + ["Find next interpolated (no //o)" + cperl-next-interpolated-REx-0 + (or (text-property-any (point-min) (point-max) 'REx-interpolated t) + (text-property-any (point-min) (point-max) 'REx-interpolated 1))] + ["Find next interpolated (neither //o nor whole-REx)" + cperl-next-interpolated-REx-1 + (text-property-any (point-min) (point-max) 'REx-interpolated t)]) + ["Insert spaces if needed to fix style" cperl-find-bad-style t] + ["Refresh \"hard\" constructions" cperl-find-pods-heres t] + "----" + ["Indent region" cperl-indent-region (cperl-use-region-p)] + ["Comment region" cperl-comment-region (cperl-use-region-p)] + ["Uncomment region" cperl-uncomment-region (cperl-use-region-p)] + "----" + ["Run" mode-compile (fboundp 'mode-compile)] + ["Kill" mode-compile-kill (and (fboundp 'mode-compile-kill) + (get-buffer "*compilation*"))] + ["Next error" next-error (get-buffer "*compilation*")] + ["Check syntax" cperl-check-syntax (fboundp 'mode-compile)] + "----" + ["Debugger" cperl-db t] + "----" + ("Tools" + ["Imenu" imenu (fboundp 'imenu)] + ["Imenu on Perl Info" cperl-imenu-on-info (featurep 'imenu)] "----" - ["Indent region" cperl-indent-region (cperl-use-region-p)] - ["Comment region" cperl-comment-region (cperl-use-region-p)] - ["Uncomment region" cperl-uncomment-region (cperl-use-region-p)] + ["Ispell PODs" cperl-pod-spell + ;; Better not to update syntaxification here: + ;; debugging syntaxificatio can be broken by this??? + (or + (get-text-property (point-min) 'in-pod) + (< (progn + (and cperl-syntaxify-for-menu + (cperl-update-syntaxification (point-max) (point-max))) + (next-single-property-change (point-min) 'in-pod nil (point-max))) + (point-max)))] + ["Ispell HERE-DOCs" cperl-here-doc-spell + (< (progn + (and cperl-syntaxify-for-menu + (cperl-update-syntaxification (point-max) (point-max))) + (next-single-property-change (point-min) 'here-doc-group nil (point-max))) + (point-max))] + ["Narrow to this HERE-DOC" cperl-narrow-to-here-doc + (eq 'here-doc (progn + (and cperl-syntaxify-for-menu + (cperl-update-syntaxification (point) (point))) + (get-text-property (point) 'syntax-type)))] + ["Select this HERE-DOC or POD section" + cperl-select-this-pod-or-here-doc + (memq (progn + (and cperl-syntaxify-for-menu + (cperl-update-syntaxification (point) (point))) + (get-text-property (point) 'syntax-type)) + '(here-doc pod))] "----" - ["Run" mode-compile (fboundp 'mode-compile)] - ["Kill" mode-compile-kill (and (fboundp 'mode-compile-kill) - (get-buffer "*compilation*"))] - ["Next error" next-error (get-buffer "*compilation*")] - ["Check syntax" cperl-check-syntax (fboundp 'mode-compile)] + ["CPerl pretty print (exprmntl)" cperl-ps-print + (fboundp 'ps-extend-face-list)] "----" - ["Debugger" cperl-db t] + ["Syntaxify region" cperl-find-pods-heres-region + (cperl-use-region-p)] + ["Profile syntaxification" cperl-time-fontification t] + ["Debug errors in delayed fontification" cperl-emulate-lazy-lock t] + ["Debug unwind for syntactic scan" cperl-toggle-set-debug-unwind t] + ["Debug backtrace on syntactic scan (BEWARE!!!)" + (cperl-toggle-set-debug-unwind nil t) t] "----" - ("Tools" - ["Imenu" imenu (fboundp 'imenu)] - ["Insert spaces if needed" cperl-find-bad-style t] - ["Class Hierarchy from TAGS" cperl-tags-hier-init t] - ;;["Update classes" (cperl-tags-hier-init t) tags-table-list] - ["CPerl pretty print (exprmntl)" cperl-ps-print - (fboundp 'ps-extend-face-list)] - ["Imenu on info" cperl-imenu-on-info (featurep 'imenu)] - ("Tags" + ["Class Hierarchy from TAGS" cperl-tags-hier-init t] + ;;["Update classes" (cperl-tags-hier-init t) tags-table-list] + ("Tags" ;;; ["Create tags for current file" cperl-etags t] ;;; ["Add tags for current file" (cperl-etags t) t] ;;; ["Create tags for Perl files in directory" (cperl-etags nil t) t] @@ -1186,10 +1350,10 @@ the faces: please specify bold, italic, underline, shadow and box.) ["PerlStyle" (cperl-set-style "PerlStyle") t] ["GNU" (cperl-set-style "GNU") t] ["C++" (cperl-set-style "C++") t] - ["FSF" (cperl-set-style "FSF") t] + ["K&R" (cperl-set-style "K&R") t] ["BSD" (cperl-set-style "BSD") t] ["Whitesmith" (cperl-set-style "Whitesmith") t] - ["Current" (cperl-set-style "Current") t] + ["Memorize Current" (cperl-set-style "Current") t] ["Memorized" (cperl-set-style-back) cperl-old-style]) ("Micro-docs" ["Tips" (describe-variable 'cperl-tips) t] @@ -1208,12 +1372,73 @@ the faces: please specify bold, italic, underline, shadow and box.) The expansion is entirely correct because it uses the C preprocessor." t) +;;; These two must be unwound, otherwise take exponential time +(defconst cperl-maybe-white-and-comment-rex "[ \t\n]*\\(#[^\n]*\n[ \t\n]*\\)*" +"Regular expression to match optional whitespace with interpspersed 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\\)+" +"Regular expression to match whitespace with interpspersed comments. +Should contain exactly one group.") + + +;;; Is incorporated in `cperl-imenu--function-name-regexp-perl' +;;; `cperl-outline-regexp', `defun-prompt-regexp'. +;;; Details of groups in this may be used in several functions; see comments +;;; near mentioned above variable(s)... +;;; sub($$):lvalue{} sub:lvalue{} Both allowed... +(defsubst cperl-after-sub-regexp (named attr) ; 9 groups without attr... + "Match the text after `sub' in a subroutine declaration. +If NAMED is nil, allows anonymous subroutines. Matches up to the first \":\" +of attributes (if present), or end of the name or prototype (whatever is +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 + "\\)" ; END n+1=name-group + (if named "" "?") + "\\(" ; n+4=proto-group + cperl-maybe-white-and-comment-rex ; n+5=pre-proto + "\\(([^()]*)\\)" ; n+6=prototype + "\\)?" ; END n+4=proto-group + "\\(" ; n+7=attr-group + cperl-maybe-white-and-comment-rex ; n+8=pre-attr + "\\(" ; n+9=start-attr + ":" + (if attr (concat + "\\(" + cperl-maybe-white-and-comment-rex ; whitespace-comments + "\\(\\sw\\|_\\)+" ; attr-name + ;; attr-arg (1 level of internal parens allowed!) + "\\((\\(\\\\.\\|[^\\\\()]\\|([^\\\\()]*)\\)*)\\)?" + "\\(" ; optional : (XXX allows trailing???) + cperl-maybe-white-and-comment-rex ; whitespace-comments + ":\\)?" + "\\)+") + "[^:]") + "\\)" + "\\)?" ; END n+6=proto-group + )) + +;;; 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 - "^\\(" - "[ \t]*\\(sub\\|package\\)[ \t\n]+\\([a-zA-Z_0-9:']+\\)[ \t]*\\(([^()]*)[ \t]*\\)?" - "\\|" - "=head\\([12]\\)[ \t]+\\([^\n]+\\)$" + "^\\(" ; 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]*sub" + (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 @@ -1225,6 +1450,12 @@ The expansion is entirely correct because it uses the C preprocessor." (defvar cperl-string-syntax-table nil "Syntax table in use in CPerl mode string-like chunks.") +(defsubst cperl-1- (p) + (max (point-min) (1- p))) + +(defsubst cperl-1+ (p) + (min (point-max) (1+ p))) + (if cperl-mode-syntax-table () (setq cperl-mode-syntax-table (make-syntax-table)) @@ -1249,6 +1480,8 @@ The expansion is entirely correct because it uses the C preprocessor." (modify-syntax-entry ?| "." cperl-mode-syntax-table) (setq cperl-string-syntax-table (copy-syntax-table cperl-mode-syntax-table)) (modify-syntax-entry ?$ "." cperl-string-syntax-table) + (modify-syntax-entry ?\{ "." cperl-string-syntax-table) + (modify-syntax-entry ?\} "." cperl-string-syntax-table) (modify-syntax-entry ?# "." cperl-string-syntax-table)) ; (?# comment ) @@ -1257,6 +1490,10 @@ The expansion is entirely correct because it uses the C preprocessor." ;; Fix for msb.el (defvar cperl-msb-fixed nil) (defvar cperl-use-major-mode 'cperl-mode) +(defvar cperl-font-lock-multiline-start nil) +(defvar cperl-font-lock-multiline nil) +(defvar cperl-compilation-error-regexp-alist nil) +(defvar cperl-font-locking nil) ;;;###autoload (defun cperl-mode () @@ -1402,16 +1639,24 @@ Variables controlling indentation style: `cperl-min-label-indent' Minimal indentation for line that is a label. -Settings for K&R and BSD indentation styles are - `cperl-indent-level' 5 8 - `cperl-continued-statement-offset' 5 8 - `cperl-brace-offset' -5 -8 - `cperl-label-offset' -5 -8 +Settings for classic indent-styles: K&R BSD=C++ GNU PerlStyle=Whitesmith + `cperl-indent-level' 5 4 2 4 + `cperl-brace-offset' 0 0 0 0 + `cperl-continued-brace-offset' -5 -4 0 0 + `cperl-label-offset' -5 -4 -2 -4 + `cperl-continued-statement-offset' 5 4 2 4 CPerl knows several indentation styles, and may bulk set the corresponding variables. Use \\[cperl-set-style] to do this. Use \\[cperl-set-style-back] to restore the memorized preexisting values -\(both available from menu). +\(both available from menu). See examples in `cperl-style-examples'. + +Part of the indentation style is how different parts of if/elsif/else +statements are broken into lines; in CPerl, this is reflected on how +templates for these constructs are created (controlled by +`cperl-extra-newline-before-brace'), and how reflow-logic should treat \"continuation\" blocks of else/elsif/continue, controlled by the same variable, +and by `cperl-extra-newline-before-brace-multiline', +`cperl-merge-trailing-else', `cperl-indent-region-fix-constructs'. If `cperl-indent-level' is 0, the statement after opening brace in column 0 is indented on @@ -1465,8 +1710,12 @@ or as help on variables `cperl-tips', `cperl-problems', ("head2" "head2" cperl-electric-pod 0))) (setq abbrevs-changed prev-a-c))) (setq local-abbrev-table cperl-mode-abbrev-table) - (abbrev-mode (if (cperl-val 'cperl-electric-keywords) 1 0)) + (if (cperl-val 'cperl-electric-keywords) + (abbrev-mode 1)) (set-syntax-table cperl-mode-syntax-table) + ;; Until Emacs is multi-threaded, we do not actually need it local: + (make-local-variable 'cperl-font-lock-multiline-start) + (make-local-variable 'cperl-font-locking) (make-local-variable 'outline-regexp) ;; (setq outline-regexp imenu-example--function-name-regexp-perl) (setq outline-regexp cperl-outline-regexp) @@ -1478,7 +1727,10 @@ or as help on variables `cperl-tips', `cperl-problems', (setq paragraph-separate paragraph-start) (make-local-variable 'paragraph-ignore-fill-prefix) (setq paragraph-ignore-fill-prefix t) - (set (make-local-variable 'fill-paragraph-function) 'cperl-fill-paragraph) + (if cperl-xemacs-p + (progn + (make-local-variable 'paren-backwards-message) + (set 'paren-backwards-message t))) (make-local-variable 'indent-line-function) (setq indent-line-function 'cperl-indent-line) (make-local-variable 'require-final-newline) @@ -1492,9 +1744,22 @@ or as help on variables `cperl-tips', `cperl-problems', (make-local-variable 'comment-start-skip) (setq comment-start-skip "#+ *") (make-local-variable 'defun-prompt-regexp) - (setq defun-prompt-regexp "^[ \t]*sub[ \t\n]+\\([^ \t\n{(;]+\\)\\([ \t\n]*([^()]*)[ \t\n]*\\)?[ \t\n]*") +;;; "[ \t]*sub" +;;; (cperl-after-sub-regexp 'named nil) ; 8=name 11=proto 14=attr-start +;;; cperl-maybe-white-and-comment-rex ; 15=pre-block + (setq defun-prompt-regexp + (concat "^[ \t]*\\(sub" + (cperl-after-sub-regexp 'named 'attr-groups) + "\\|" ; per toke.c + "\\(BEGIN\\|CHECK\\|INIT\\|END\\|AUTOLOAD\\|DESTROY\\)" + "\\)" + cperl-maybe-white-and-comment-rex)) (make-local-variable 'comment-indent-function) (setq comment-indent-function 'cperl-comment-indent) + (and (boundp 'fill-paragraph-function) + (progn + (make-local-variable 'fill-paragraph-function) + (set 'fill-paragraph-function 'cperl-fill-paragraph))) (make-local-variable 'parse-sexp-ignore-comments) (setq parse-sexp-ignore-comments t) (make-local-variable 'indent-region-function) @@ -1509,21 +1774,40 @@ or as help on variables `cperl-tips', `cperl-problems', (set 'vc-rcs-header cperl-vc-rcs-header) (make-local-variable 'vc-sccs-header) (set 'vc-sccs-header cperl-vc-sccs-header) + ;; This one is obsolete... + (make-local-variable 'vc-header-alist) + (set 'vc-header-alist (or cperl-vc-header-alist ; Avoid warning + (` ((SCCS (, (car cperl-vc-sccs-header))) + (RCS (, (car cperl-vc-rcs-header))))))) + (cond ((boundp 'compilation-error-regexp-alist-alist);; xemacs 20.x + (make-local-variable 'compilation-error-regexp-alist-alist) + (set 'compilation-error-regexp-alist-alist + (cons (cons 'cperl cperl-compilation-error-regexp-alist) + (symbol-value 'compilation-error-regexp-alist-alist))) + (if (fboundp 'compilation-build-compilation-error-regexp-alist) + (let ((f 'compilation-build-compilation-error-regexp-alist)) + (funcall f)) + (push 'cperl compilation-error-regexp-alist))) + ((boundp 'compilation-error-regexp-alist);; xmeacs 19.x + (make-local-variable 'compilation-error-regexp-alist) + (set 'compilation-error-regexp-alist + (cons cperl-compilation-error-regexp-alist + (symbol-value 'compilation-error-regexp-alist))))) (make-local-variable 'font-lock-defaults) (setq font-lock-defaults (cond ((string< emacs-version "19.30") - '(cperl-font-lock-keywords-2)) + '(cperl-font-lock-keywords-2 nil nil ((?_ . "w")))) ((string< emacs-version "19.33") ; Which one to use? '((cperl-font-lock-keywords cperl-font-lock-keywords-1 - cperl-font-lock-keywords-2))) + cperl-font-lock-keywords-2) nil nil ((?_ . "w")))) (t '((cperl-load-font-lock-keywords cperl-load-font-lock-keywords-1 - cperl-load-font-lock-keywords-2) - nil nil ((?_ . "w")))))) + cperl-load-font-lock-keywords-2) nil nil ((?_ . "w")))))) (make-local-variable 'cperl-syntax-state) + (setq cperl-syntax-state nil) ; reset syntaxification cache (if cperl-use-syntax-table-text-property (progn (make-local-variable 'parse-sexp-lookup-properties) @@ -1533,10 +1817,12 @@ or as help on variables `cperl-tips', `cperl-problems', (or (boundp 'font-lock-unfontify-region-function) (set 'font-lock-unfontify-region-function 'font-lock-default-unfontify-region)) - (make-local-variable 'font-lock-unfontify-region-function) - (set 'font-lock-unfontify-region-function ; not present with old Emacs - 'cperl-font-lock-unfontify-region-function) + (unless cperl-xemacs-p ; Our: just a plug for wrong font-lock + (make-local-variable 'font-lock-unfontify-region-function) + (set 'font-lock-unfontify-region-function ; not present with old Emacs + 'cperl-font-lock-unfontify-region-function)) (make-local-variable 'cperl-syntax-done-to) + (setq cperl-syntax-done-to nil) ; reset syntaxification cache (make-local-variable 'font-lock-syntactic-keywords) (setq font-lock-syntactic-keywords (if cperl-syntaxify-by-font-lock @@ -1546,10 +1832,20 @@ or as help on variables `cperl-tips', `cperl-problems', ;; to make font-lock think that font-lock-syntactic-keywords ;; are defined. '(t))))) + (if (boundp 'font-lock-multiline) ; Newer font-lock; use its facilities + (progn + (setq cperl-font-lock-multiline t) ; Not localized... + (set 'font-lock-multiline t)) ; not present with old Emacs; auto-local + (make-local-variable 'font-lock-fontify-region-function) + (set 'font-lock-fontify-region-function ; not present with old Emacs + 'cperl-font-lock-fontify-region-function)) + (make-local-variable 'font-lock-fontify-region-function) + (set 'font-lock-fontify-region-function ; not present with old Emacs + 'cperl-font-lock-fontify-region-function) (make-local-variable 'cperl-old-style) (if (boundp 'normal-auto-fill-function) ; 19.33 and later (set (make-local-variable 'normal-auto-fill-function) - 'cperl-do-auto-fill) ; RMS has it as #'cperl-do-auto-fill ??? + 'cperl-do-auto-fill) (or (fboundp 'cperl-old-auto-fill-mode) (progn (fset 'cperl-old-auto-fill-mode (symbol-function 'auto-fill-mode)) @@ -1562,12 +1858,18 @@ or as help on variables `cperl-tips', `cperl-problems', (if (cperl-val 'cperl-font-lock) (progn (or cperl-faces-init (cperl-init-faces)) (font-lock-mode 1)))) + (set (make-local-variable 'facemenu-add-face-function) + 'cperl-facemenu-add-face-function) ; XXXX What this guy is for??? (and (boundp 'msb-menu-cond) (not cperl-msb-fixed) (cperl-msb-fix)) (if (featurep 'easymenu) (easy-menu-add cperl-menu)) ; A NOP in Emacs. (run-mode-hooks 'cperl-mode-hook) + (if cperl-hook-after-change + (progn + (make-local-hook 'after-change-functions) + (add-hook 'after-change-functions 'cperl-after-change-function nil t))) ;; After hooks since fontification will break this (if cperl-pod-here-scan (or cperl-syntaxify-by-font-lock @@ -1616,31 +1918,37 @@ or as help on variables `cperl-tips', `cperl-problems', (defvar cperl-st-ket '(5 . ?\<)) -(defun cperl-comment-indent () +(defun cperl-comment-indent () ; called at point at supposed comment (let ((p (point)) (c (current-column)) was phony) - (if (looking-at "^#") 0 ; Existing comment at bol stays there. + (if (and (not cperl-indent-comment-at-column-0) + (looking-at "^#")) + 0 ; Existing comment at bol stays there. ;; Wrong comment found (save-excursion (setq was (cperl-to-comment-or-eol) phony (eq (get-text-property (point) 'syntax-table) cperl-st-cfence)) (if phony - (progn + (progn ; Too naive??? (re-search-forward "#\\|$") ; Hmm, what about embedded #? (if (eq (preceding-char) ?\#) (forward-char -1)) (setq was nil))) - (if (= (point) p) + (if (= (point) p) ; Our caller found a correct place (progn (skip-chars-backward " \t") - (max (1+ (current-column)) ; Else indent at comment column - comment-column)) + (setq was (current-column)) + (if (eq was 0) + comment-column + (max (1+ was) ; Else indent at comment column + comment-column))) + ;; No, the caller found a random place; we need to edit ourselves (if was nil (insert comment-start) (backward-char (length comment-start))) (setq cperl-wrong-comment t) - (indent-to comment-column 1) ; Indent minimum 1 - c))))) ; except leave at least one space. + (cperl-make-indent comment-column 1) ; Indent min 1 + c))))) ;;;(defun cperl-comment-indent-fallback () ;;; "Is called if the standard comment-search procedure fails. @@ -1666,7 +1974,7 @@ or as help on variables `cperl-tips', `cperl-problems', (interactive) (let (cperl-wrong-comment) (indent-for-comment) - (if cperl-wrong-comment + (if cperl-wrong-comment ; set by `cperl-comment-indent' (progn (cperl-to-comment-or-eol) (forward-char (length comment-start)))))) @@ -1966,15 +2274,10 @@ to nil." (or (get-text-property (point) 'in-pod) (cperl-after-expr-p nil "{;:") - (and (re-search-backward - ;; "\\(\\`\n?\\|\n\n\\)=\\sw+" - "\\(\\`\n?\\|^\n\\)=\\sw+" - (point-min) t) - (not (or - (looking-at "=cut") - (and cperl-use-syntax-table-text-property - (not (eq (get-text-property (point) 'syntax-type) - 'pod))))))))) + (and (re-search-backward "\\(\\`\n?\\|^\n\\)=\\sw+" (point-min) t) + (not (looking-at "\n*=cut")) + (or (not cperl-use-syntax-table-text-property) + (eq (get-text-property (point) 'syntax-type) 'pod)))))) (progn (save-excursion (setq notlast (re-search-forward "^\n=" nil t))) @@ -2252,7 +2555,7 @@ key. Will untabify if `cperl-electric-backspace-untabify' is non-nil." (put 'cperl-electric-backspace 'delete-selection 'supersede) -(defun cperl-inside-parens-p () +(defun cperl-inside-parens-p () ;; NOT USED???? (condition-case () (save-excursion (save-restriction @@ -2332,8 +2635,9 @@ Return the amount the indentation changed by." (zerop shift-amt)) (if (> (- (point-max) pos) (point)) (goto-char (- (point-max) pos))) - (delete-region beg (point)) - (indent-to indent) + ;;;(delete-region beg (point)) + ;;;(indent-to indent) + (cperl-make-indent indent) ;; If initial point was within line's indentation, ;; position after the indentation. Else stay at same point in text. (if (> (- (point-max) pos) (point)) @@ -2380,63 +2684,55 @@ Return the amount the indentation changed by." (or state (setq state (parse-partial-sexp start start-point -1 nil start-state))) (list start state depth prestart)))) -(defun cperl-block-p () ; Do not C-M-q ! One string contains ";" ! - ;; Positions is before ?\{. Checks whether it starts a block. - ;; No save-excursion! - (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)) - (and (memq (char-syntax (preceding-char)) '(?w ?_)) - (progn - (backward-sexp) - ;; Need take into account `bless', `return', `tr',... - (or (and (looking-at "[a-zA-Z0-9_:]+[ \t\n\f]*[{#]") ; Method call syntax - (not (looking-at "\\(bless\\|return\\|q[wqrx]?\\|tr\\|[smy]\\)\\>"))) - (progn - (skip-chars-backward " \t\n\f") - (and (memq (char-syntax (preceding-char)) '(?w ?_)) - (progn - (backward-sexp) - (looking-at - "sub[ \t]+[a-zA-Z0-9_:]+[ \t\n\f]*\\(([^()]*)[ \t\n\f]*\\)?[#{]"))))))))) - (defvar cperl-look-for-prop '((pod in-pod) (here-doc-delim here-doc-group))) -(defun cperl-calculate-indent (&optional parse-data) ; was parse-start - "Return appropriate indentation for current line as Perl code. -In usual case returns an integer: the column to indent to. -Returns nil if line starts inside a string, t if in a comment. - -Will not correct the indentation for labels, but will correct it for braces -and closing parentheses and brackets." +(defun cperl-beginning-of-property (p prop &optional lim) + "Given that P has a property PROP, find where the property starts. +Will not look before LIM." + ;;; XXXX What to do at point-max??? + (or (previous-single-property-change (cperl-1+ p) prop lim) + (point-min)) +;;; (cond ((eq p (point-min)) +;;; p) +;;; ((and lim (<= p lim)) +;;; p) +;;; ((not (get-text-property (1- p) prop)) +;;; p) +;;; (t (or (previous-single-property-change p look-prop lim) +;;; (point-min)))) + ) + +(defun cperl-sniff-for-indent (&optional parse-data) ; was parse-start + ;; Old workhorse for calculation of indentation; the major problem + ;; is that it mixes the sniffer logic to understand what the current line + ;; MEANS with the logic to actually calculate where to indent it. + ;; The latter part should be eventually moved to `cperl-calculate-indent'; + ;; actually, this is mostly done now... (cperl-update-syntaxification (point) (point)) - (save-excursion - (if (or - (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!")) - (and (not cperl-indent-left-aligned-comments) - (looking-at "^#"))) - nil - (beginning-of-line) - (let ((indent-point (point)) - (char-after (save-excursion - (skip-chars-forward " \t") - (following-char))) - (in-pod (get-text-property (point) 'in-pod)) - (pre-indent-point (point)) - p prop look-prop is-block delim) - (cond - (in-pod - ;; In the verbatim part, probably code example. What to do??? - ) - (t - (save-excursion - ;; Not in POD + (let ((res (get-text-property (point) 'syntax-type))) + (save-excursion + (cond + ((and (memq res '(pod here-doc here-doc-delim format)) + (not (get-text-property (point) 'indentable))) + (vector res)) + ;; before start of POD - whitespace found since do not have 'pod! + ((looking-at "[ \t]*\n=") + (error "Spaces before POD section!")) + ((and (not cperl-indent-left-aligned-comments) + (looking-at "^#")) + [comment-special:at-beginning-of-line]) + ((get-text-property (point) 'in-pod) + [in-pod]) + (t + (beginning-of-line) + (let* ((indent-point (point)) + (char-after-pos (save-excursion + (skip-chars-forward " \t") + (point))) + (char-after (char-after char-after-pos)) + (pre-indent-point (point)) + p prop look-prop is-block delim) + (save-excursion ; Know we are not in POD, find appropriate pos before (cperl-backward-to-noncomment nil) (setq p (max (point-min) (1- (point))) prop (get-text-property p 'syntax-type) @@ -2444,437 +2740,597 @@ and closing parentheses and brackets." 'syntax-type)) (if (memq prop '(pod here-doc format here-doc-delim)) (progn - (goto-char (or (previous-single-property-change p look-prop) - (point-min))) + (goto-char (cperl-beginning-of-property p look-prop)) (beginning-of-line) - (setq pre-indent-point (point))))))) - (goto-char pre-indent-point) - (let* ((case-fold-search nil) - (s-s (cperl-get-state (car parse-data) (nth 1 parse-data))) - (start (or (nth 2 parse-data) - (nth 0 s-s))) - (state (nth 1 s-s)) - (containing-sexp (car (cdr state))) - old-indent) - (if (and - ;;containing-sexp ;; We are buggy at toplevel :-( - parse-data) - (progn - (setcar parse-data pre-indent-point) - (setcar (cdr parse-data) state) - (or (nth 2 parse-data) - (setcar (cddr parse-data) start)) - ;; Before this point: end of statement - (setq old-indent (nth 3 parse-data)))) - (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. - ;; Indent like the previous top level line - ;; unless that ends in a closeparen without semicolon, - ;; in which case this line is the first argument decl. - (skip-chars-forward " \t") - (+ (save-excursion - (goto-char start) - (- (current-indentation) - (if (nth 2 s-s) cperl-indent-level 0))) - (if (= char-after ?{) cperl-continued-brace-offset 0) - (progn - (cperl-backward-to-noncomment (or old-indent (point-min))) - ;; Look at previous line that's at column 0 - ;; to determine whether we are in top-level decls - ;; or function's arg decls. Set basic-indent accordingly. - ;; Now add a little if this is a continuation line. - (if (or (bobp) - (eq (point) old-indent) ; old-indent was at comment - (eq (preceding-char) ?\;) - ;; Had ?\) too - (and (eq (preceding-char) ?\}) - (cperl-after-block-and-statement-beg - (point-min))) ; Was start - too close - (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]*:"))) - (get-text-property (point) 'first-format-line)) - (progn - (if (and parse-data - (not (eq char-after ?\C-j))) - (setcdr (cddr parse-data) - (list pre-indent-point))) - 0) - cperl-continued-statement-offset)))) - ((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 (if delim "}" ")]}") nil)) - (looking-at "[ \t]*\\(#\\|$\\)") - (skip-chars-forward " \t")) - (+ (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. - (goto-char pre-indent-point) - (cperl-backward-to-noncomment containing-sexp) - ;; 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 ?_)))) - ;;) - (if (eq (preceding-char) ?\,) - ;; Will go to beginning of line, essentially. - ;; Will ignore embedded sexpr XXXX. - (cperl-backward-to-start-of-continued-exp containing-sexp)) - (beginning-of-line) - (cperl-backward-to-noncomment containing-sexp)) - ;; Now we get the answer. - (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)) - (get-text-property (point) 'first-format-line))) - ;; This line is continuation of preceding line's statement; - ;; indent `cperl-continued-statement-offset' more than the - ;; previous line of the statement. - ;; - ;; There might be a label on this line, just - ;; consider it bad style and ignore it. - (progn - (cperl-backward-to-start-of-continued-exp containing-sexp) - (+ (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) - ;; Do not move `parse-data', this should - ;; be quick anyway (this comment comes - ;; from different location): - (cperl-calculate-indent)) - (current-column)) - (if (eq char-after ?\{) - cperl-continued-brace-offset 0))) - ;; This line starts a new statement. - ;; Position following last unclosed open. - (goto-char containing-sexp) - ;; Is line first statement after an open-brace? - (or - ;; If no, find that first statement and indent like - ;; it. If the first statement begins with label, do - ;; not believe when the indentation of the label is too - ;; small. - (save-excursion - (forward-char 1) - (setq old-indent (current-indentation)) - (let ((colon-line-end 0)) - (while - (progn (skip-chars-forward " \t\n") - (looking-at "#\\|[a-zA-Z0-9_$]*:[^:]\\|=[a-zA-Z]")) - ;; Skip over comments and labels following openbrace. - (cond ((= (following-char) ?\#) - (forward-line 1)) - ((= (following-char) ?\=) - (goto-char - (or (next-single-property-change (point) 'in-pod) - (point-max)))) ; do not loop if no syntaxification - ;; label: - (t - (save-excursion (end-of-line) - (setq colon-line-end (point))) - (search-forward ":")))) - ;; The first following code counts - ;; if it is before the line we want to indent. - (and (< (point) indent-point) - (if (> colon-line-end (point)) ; After label - (if (> (current-indentation) - cperl-min-label-indent) - (- (current-indentation) cperl-label-offset) - ;; Do not believe: `max' is involved - (+ old-indent cperl-indent-level)) - (current-column))))) - ;; If no previous statement, - ;; indent it relative to line brace is on. - ;; For open brace in column zero, don't let statement - ;; start there too. If cperl-indent-level is zero, - ;; use cperl-brace-offset + cperl-continued-statement-offset instead. - ;; For open-braces not the first thing in a line, - ;; add in cperl-brace-imaginary-offset. - - ;; If first thing on a line: ????? - (+ (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. - (progn (skip-chars-backward " \t") - (if (bolp) 0 cperl-brace-imaginary-offset)) - ;; If the openbrace is preceded by a parenthesized exp, - ;; move to the beginning of that; - ;; possibly a different line - (progn - (if (eq (preceding-char) ?\)) - (forward-sexp -1)) - ;; In the case it starts a subroutine, indent with - ;; respect to `sub', not with respect to the - ;; first thing on the line, say in the case of - ;; anonymous sub in a hash. - ;; - (skip-chars-backward " \t") - (if (and (eq (preceding-char) ?b) + (setq pre-indent-point (point))))) + (goto-char pre-indent-point) ; Orig line skipping preceeding pod/etc + (let* ((case-fold-search nil) + (s-s (cperl-get-state (car parse-data) (nth 1 parse-data))) + (start (or (nth 2 parse-data) ; last complete sexp terminated + (nth 0 s-s))) ; Good place to start parsing + (state (nth 1 s-s)) + (containing-sexp (car (cdr state))) + old-indent) + (if (and + ;;containing-sexp ;; We are buggy at toplevel :-( + parse-data) + (progn + (setcar parse-data pre-indent-point) + (setcar (cdr parse-data) state) + (or (nth 2 parse-data) + (setcar (cddr parse-data) start)) + ;; Before this point: end of statement + (setq old-indent (nth 3 parse-data)))) + (cond ((get-text-property (point) 'indentable) + ;; indent to "after" the surrounding open + ;; (same offset as `cperl-beautify-regexp-piece'), + ;; skip blanks if we do not close the expression. + (setq delim ; We do not close the expression + (get-text-property + (cperl-1+ char-after-pos) 'indentable) + p (1+ (cperl-beginning-of-property + (point) 'indentable)) + is-block ; misused for: preceeding line in REx + (save-excursion ; Find preceeding line + (cperl-backward-to-noncomment p) + (beginning-of-line) + (if (<= (point) p) + (progn ; get indent from the first line + (goto-char p) + (skip-chars-forward " \t") + (if (memq (char-after (point)) + (append "#\n" nil)) + nil ; Can't use intentation of this line... + (point))) + (skip-chars-forward " \t") + (point))) + prop (parse-partial-sexp p char-after-pos)) + (cond ((not delim) ; End the REx, ignore is-block + (vector 'indentable 'terminator p is-block)) + (is-block ; Indent w.r.t. preceeding line + (vector 'indentable 'cont-line char-after-pos + is-block char-after p)) + (t ; No preceeding line... + (vector 'indentable 'first-line p)))) + ((get-text-property char-after-pos 'REx-part2) + (vector 'REx-part2 (point))) + ((nth 3 state) + [comment]) + ((nth 4 state) + [string]) + ;; 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. + ;; Indent like the previous top level line + ;; unless that ends in a closeparen without semicolon, + ;; in which case this line is the first argument decl. + (skip-chars-forward " \t") + (cperl-backward-to-noncomment (or old-indent (point-min))) + (setq state + (or (bobp) + (eq (point) old-indent) ; old-indent was at comment + (eq (preceding-char) ?\;) + ;; Had ?\) too + (and (eq (preceding-char) ?\}) + (cperl-after-block-and-statement-beg + (point-min))) ; Was start - too close + (memq char-after (append ")]}" nil)) + (and (eq (preceding-char) ?\:) ; label (progn (forward-sexp -1) - (looking-at "sub\\>")) - (setq old-indent - (nth 1 - (parse-partial-sexp - (save-excursion (beginning-of-line) (point)) - (point))))) - (progn (goto-char (1+ old-indent)) - (skip-chars-forward " \t") - (current-column)) - ;; Get initial indentation of the line we are on. - ;; 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]*:[^:]")) - (if (> (current-indentation) cperl-min-label-indent) - (- (current-indentation) cperl-label-offset) - ;; Do not move `parse-data', this should - ;; be quick anyway: - (cperl-calculate-indent)) - (current-indentation)))))))))))))) - -;; (defvar cperl-indent-alist -;; '((string nil) -;; (comment nil) -;; (toplevel 0) -;; (toplevel-after-parenth 2) -;; (toplevel-continued 2) -;; (expression 1)) -;; "Alist of indentation rules for CPerl mode. -;; The values mean: -;; nil: do not indent; -;; number: add this amount of indentation. - -;; Not finished, not used.") - -;; (defun cperl-where-am-i (&optional parse-start start-state) -;; ;; Unfinished -;; "Return a list of lists ((TYPE POS)...) of good points before the point. -;; ;; POS may be nil if it is hard to find, say, when TYPE is `string' or `comment'. - -;; ;; Not finished, not used." -;; (save-excursion -;; (let* ((start-point (point)) -;; (s-s (cperl-get-state)) -;; (start (nth 0 s-s)) -;; (state (nth 1 s-s)) -;; (prestart (nth 3 s-s)) -;; (containing-sexp (car (cdr state))) -;; (case-fold-search nil) -;; (res (list (list 'parse-start start) (list 'parse-prestart prestart)))) -;; (cond ((nth 3 state) ; In string -;; (setq res (cons (list 'string nil (nth 3 state)) res))) ; What started string -;; ((nth 4 state) ; In comment -;; (setq res (cons '(comment) res))) -;; ((null containing-sexp) -;; ;; Line is at top level. -;; ;; Indent like the previous top level line -;; ;; unless that ends in a closeparen without semicolon, -;; ;; in which case this line is the first argument decl. -;; (cperl-backward-to-noncomment (or parse-start (point-min))) -;; ;;(skip-chars-backward " \t\f\n") -;; (cond -;; ((or (bobp) -;; (memq (preceding-char) (append ";}" nil))) -;; (setq res (cons (list 'toplevel start) res))) -;; ((eq (preceding-char) ?\) ) -;; (setq res (cons (list 'toplevel-after-parenth start) res))) -;; (t -;; (setq res (cons (list 'toplevel-continued start) res))))) -;; ((/= (char-after containing-sexp) ?{) -;; ;; line is expression, not statement: -;; ;; indent to just after the surrounding open. -;; ;; skip blanks if we do not close the expression. -;; (setq res (cons (list 'expression-blanks -;; (progn -;; (goto-char (1+ containing-sexp)) -;; (or (looking-at "[ \t]*\\(#\\|$\\)") -;; (skip-chars-forward " \t")) -;; (point))) -;; (cons (list 'expression containing-sexp) res)))) -;; ((progn -;; ;; Containing-expr starts with \{. Check whether it is a hash. -;; (goto-char containing-sexp) -;; (not (cperl-block-p))) -;; (setq res (cons (list 'expression-blanks -;; (progn -;; (goto-char (1+ containing-sexp)) -;; (or (looking-at "[ \t]*\\(#\\|$\\)") -;; (skip-chars-forward " \t")) -;; (point))) -;; (cons (list 'expression containing-sexp) res)))) -;; (t -;; ;; Statement level. -;; (setq res (cons (list 'in-block containing-sexp) res)) -;; ;; Is it a continuation or a new statement? -;; ;; Find previous non-comment character. -;; (cperl-backward-to-noncomment containing-sexp) -;; ;; Back up over label lines, since they don't -;; ;; affect whether our line is a continuation. -;; ;; Back up comma-delimited lines too ????? -;; (while (or (eq (preceding-char) ?\,) -;; (save-excursion (cperl-after-label))) -;; (if (eq (preceding-char) ?\,) -;; ;; Will go to beginning of line, essentially -;; ;; Will ignore embedded sexpr XXXX. -;; (cperl-backward-to-start-of-continued-exp containing-sexp)) -;; (beginning-of-line) -;; (cperl-backward-to-noncomment containing-sexp)) -;; ;; Now we get the answer. -;; (if (not (memq (preceding-char) (append ";}{" '(nil)))) ; Was ?\, -;; ;; This line is continuation of preceding line's statement. -;; (list (list 'statement-continued containing-sexp)) -;; ;; This line starts a new statement. -;; ;; Position following last unclosed open. -;; (goto-char containing-sexp) -;; ;; Is line first statement after an open-brace? -;; (or -;; ;; If no, find that first statement and indent like -;; ;; it. If the first statement begins with label, do -;; ;; not believe when the indentation of the label is too -;; ;; small. -;; (save-excursion -;; (forward-char 1) -;; (let ((colon-line-end 0)) -;; (while (progn (skip-chars-forward " \t\n" start-point) -;; (and (< (point) start-point) -;; (looking-at -;; "#\\|[a-zA-Z_][a-zA-Z0-9_]*:[^:]"))) -;; ;; Skip over comments and labels following openbrace. -;; (cond ((= (following-char) ?\#) -;; ;;(forward-line 1) -;; (end-of-line)) -;; ;; label: -;; (t -;; (save-excursion (end-of-line) -;; (setq colon-line-end (point))) -;; (search-forward ":")))) -;; ;; Now at the point, after label, or at start -;; ;; of first statement in the block. -;; (and (< (point) start-point) -;; (if (> colon-line-end (point)) -;; ;; Before statement after label -;; (if (> (current-indentation) -;; cperl-min-label-indent) -;; (list (list 'label-in-block (point))) -;; ;; Do not believe: `max' is involved -;; (list -;; (list 'label-in-block-min-indent (point)))) -;; ;; Before statement -;; (list 'statement-in-block (point)))))) -;; ;; If no previous statement, -;; ;; indent it relative to line brace is on. -;; ;; For open brace in column zero, don't let statement -;; ;; start there too. If cperl-indent-level is zero, -;; ;; use cperl-brace-offset + cperl-continued-statement-offset instead. -;; ;; For open-braces not the first thing in a line, -;; ;; add in cperl-brace-imaginary-offset. - -;; ;; If first thing on a line: ????? -;; (+ (if (and (bolp) (zerop cperl-indent-level)) -;; (+ cperl-brace-offset cperl-continued-statement-offset) -;; cperl-indent-level) -;; ;; Move back over whitespace before the openbrace. -;; ;; If openbrace is not first nonwhite thing on the line, -;; ;; add the cperl-brace-imaginary-offset. -;; (progn (skip-chars-backward " \t") -;; (if (bolp) 0 cperl-brace-imaginary-offset)) -;; ;; If the openbrace is preceded by a parenthesized exp, -;; ;; move to the beginning of that; -;; ;; possibly a different line -;; (progn -;; (if (eq (preceding-char) ?\)) -;; (forward-sexp -1)) -;; ;; Get initial indentation of the line we are on. -;; ;; 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]*:[^:]")) -;; (if (> (current-indentation) cperl-min-label-indent) -;; (- (current-indentation) cperl-label-offset) -;; (cperl-calculate-indent)) -;; (current-indentation)))))))) -;; res))) + (skip-chars-backward " \t") + (looking-at "[ \t]*[a-zA-Z_][a-zA-Z_0-9]*[ \t]*:"))) + (get-text-property (point) 'first-format-line))) + + ;; Look at previous line that's at column 0 + ;; to determine whether we are in top-level decls + ;; or function's arg decls. Set basic-indent accordingly. + ;; Now add a little if this is a continuation line. + (and state + parse-data + (not (eq char-after ?\C-j)) + (setcdr (cddr parse-data) + (list pre-indent-point))) + (vector 'toplevel start char-after state (nth 2 s-s))) + ((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 (if delim "}" ")]}") nil)) + (looking-at "[ \t]*\\(#\\|$\\)") + (skip-chars-forward " \t")) + (setq old-indent (point)) ; delim=is-brace + (vector 'in-parens char-after (point) delim containing-sexp)) + (t + ;; Statement level. Is it a continuation or a new statement? + ;; Find previous non-comment character. + (goto-char pre-indent-point) ; Skip one level of POD/etc + (cperl-backward-to-noncomment containing-sexp) + ;; 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 ?_)))) + ;;) + ;; This is always FALSE? + (if (eq (preceding-char) ?\,) + ;; Will go to beginning of line, essentially. + ;; Will ignore embedded sexpr XXXX. + (cperl-backward-to-start-of-continued-exp containing-sexp)) + (beginning-of-line) + (cperl-backward-to-noncomment containing-sexp)) + ;; Now we get non-label preceeding the indent point + (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)) + (get-text-property (point) 'first-format-line))) + ;; This line is continuation of preceding line's statement; + ;; indent `cperl-continued-statement-offset' more than the + ;; previous line of the statement. + ;; + ;; There might be a label on this line, just + ;; consider it bad style and ignore it. + (progn + (cperl-backward-to-start-of-continued-exp containing-sexp) + (vector 'continuation (point) char-after is-block delim)) + ;; This line starts a new statement. + ;; Position following last unclosed open brace + (goto-char containing-sexp) + ;; Is line first statement after an open-brace? + (or + ;; If no, find that first statement and indent like + ;; it. If the first statement begins with label, do + ;; not believe when the indentation of the label is too + ;; small. + (save-excursion + (forward-char 1) + (let ((colon-line-end 0)) + (while + (progn (skip-chars-forward " \t\n") + (looking-at "#\\|[a-zA-Z0-9_$]*:[^:]\\|=[a-zA-Z]")) + ;; Skip over comments and labels following openbrace. + (cond ((= (following-char) ?\#) + (forward-line 1)) + ((= (following-char) ?\=) + (goto-char + (or (next-single-property-change (point) 'in-pod) + (point-max)))) ; do not loop if no syntaxification + ;; label: + (t + (save-excursion (end-of-line) + (setq colon-line-end (point))) + (search-forward ":")))) + ;; We are at beginning of code (NOT label or comment) + ;; First, the following code counts + ;; if it is before the line we want to indent. + (and (< (point) indent-point) + (vector 'have-prev-sibling (point) colon-line-end + containing-sexp)))) + (progn + ;; If no previous statement, + ;; indent it relative to line brace is on. + + ;; For open-braces not the first thing in a line, + ;; add in cperl-brace-imaginary-offset. + + ;; If first thing on a line: ????? + ;; Move back over whitespace before the openbrace. + (setq ; brace first thing on a line + old-indent (progn (skip-chars-backward " \t") (bolp))) + ;; Should we indent w.r.t. earlier than start? + ;; Move to start of control group, possibly on a different line + (or cperl-indent-wrt-brace + (cperl-backward-to-noncomment (point-min))) + ;; If the openbrace is preceded by a parenthesized exp, + ;; move to the beginning of that; + (if (eq (preceding-char) ?\)) + (progn + (forward-sexp -1) + (cperl-backward-to-noncomment (point-min)))) + ;; In the case it starts a subroutine, indent with + ;; respect to `sub', not with respect to the + ;; first thing on the line, say in the case of + ;; anonymous sub in a hash. + (if (and;; Is it a sub in group starting on this line? + (cond ((get-text-property (point) 'attrib-group) + (goto-char (cperl-beginning-of-property + (point) 'attrib-group))) + ((eq (preceding-char) ?b) + (forward-sexp -1) + (looking-at "sub\\>"))) + (setq p (nth 1 ; start of innermost containing list + (parse-partial-sexp + (save-excursion (beginning-of-line) + (point)) + (point))))) + (progn + (goto-char (1+ p)) ; enclosing block on the same line + (skip-chars-forward " \t") + (vector 'code-start-in-block containing-sexp char-after + (and delim (not is-block)) ; is a HASH + old-indent ; brace first thing on a line + t (point) ; have something before... + ) + ;;(current-column) + ) + ;; Get initial indentation of the line we are on. + ;; If line starts with label, calculate label indentation + (vector 'code-start-in-block containing-sexp char-after + (and delim (not is-block)) ; is a HASH + old-indent ; brace first thing on a line + nil (point) ; nothing interesting before + )))))))))))))) + +(defvar cperl-indent-rules-alist + '((pod nil) ; via `syntax-type' property + (here-doc nil) ; via `syntax-type' property + (here-doc-delim nil) ; via `syntax-type' property + (format nil) ; via `syntax-type' property + (in-pod nil) ; via `in-pod' property + (comment-special:at-beginning-of-line nil) + (string t) + (comment nil)) + "Alist of indentation rules for CPerl mode. +The values mean: + nil: do not indent; + number: add this amount of indentation. + +Not finished.") + +(defun cperl-calculate-indent (&optional parse-data) ; was parse-start + "Return appropriate indentation for current line as Perl code. +In usual case returns an integer: the column to indent to. +Returns nil if line starts inside a string, t if in a comment. + +Will not correct the indentation for labels, but will correct it for braces +and closing parentheses and brackets." + ;; This code is still a broken architecture: in some cases we need to + ;; compensate for some modifications which `cperl-indent-line' will add later + (save-excursion + (let ((i (cperl-sniff-for-indent parse-data)) what p) + (cond + ;;((or (null i) (eq i t) (numberp i)) + ;; i) + ((vectorp i) + (setq what (assoc (elt i 0) cperl-indent-rules-alist)) + (cond + (what (cadr what)) ; Load from table + ;; + ;; Indenters for regular expressions with //x and qw() + ;; + ((eq 'REx-part2 (elt i 0)) ;; [self start] start of /REP in s//REP/x + (goto-char (elt i 1)) + (condition-case nil ; Use indentation of the 1st part + (forward-sexp -1)) + (current-column)) + ((eq 'indentable (elt i 0)) ; Indenter for REGEXP qw() etc + (cond ;;; [indentable terminator start-pos is-block] + ((eq 'terminator (elt i 1)) ; Lone terminator of "indentable string" + (goto-char (elt i 2)) ; After opening parens + (1- (current-column))) + ((eq 'first-line (elt i 1)); [indentable first-line start-pos] + (goto-char (elt i 2)) + (+ (or cperl-regexp-indent-step cperl-indent-level) + -1 + (current-column))) + ((eq 'cont-line (elt i 1)); [indentable cont-line pos prev-pos first-char start-pos] + ;; Indent as the level after closing parens + (goto-char (elt i 2)) ; indent line + (skip-chars-forward " \t)") ; Skip closing parens + (setq p (point)) + (goto-char (elt i 3)) ; previous line + (skip-chars-forward " \t)") ; Skip closing parens + ;; Number of parens in between: + (setq p (nth 0 (parse-partial-sexp (point) p)) + what (elt i 4)) ; First char on current line + (goto-char (elt i 3)) ; previous line + (+ (* p (or cperl-regexp-indent-step cperl-indent-level)) + (cond ((eq what ?\) ) + (- cperl-close-paren-offset)) ; compensate + ((eq what ?\| ) + (- (or cperl-regexp-indent-step cperl-indent-level))) + (t 0)) + (if (eq (following-char) ?\| ) + (or cperl-regexp-indent-step cperl-indent-level) + 0) + (current-column))) + (t + (error "Unrecognized value of indent: %s" i)))) + ;; + ;; Indenter for stuff at toplevel + ;; + ((eq 'toplevel (elt i 0)) ;; [toplevel start char-after state immed-after-block] + (+ (save-excursion ; To beg-of-defun, or end of last sexp + (goto-char (elt i 1)) ; start = Good place to start parsing + (- (current-indentation) ; + (if (elt i 4) cperl-indent-level 0))) ; immed-after-block + (if (eq (elt i 2) ?{) cperl-continued-brace-offset 0) ; char-after + ;; Look at previous line that's at column 0 + ;; to determine whether we are in top-level decls + ;; or function's arg decls. Set basic-indent accordingly. + ;; Now add a little if this is a continuation line. + (if (elt i 3) ; state (XXX What is the semantic???) + 0 + cperl-continued-statement-offset))) + ;; + ;; Indenter for stuff in "parentheses" (or brackets, braces-as-hash) + ;; + ((eq 'in-parens (elt i 0)) + ;; in-parens char-after old-indent-point is-brace containing-sexp + + ;; group is an expression, not a block: + ;; indent to just after the surrounding open parens, + ;; skip blanks if we do not close the expression. + (+ (progn + (goto-char (elt i 2)) ; old-indent-point + (current-column)) + (if (and (elt i 3) ; is-brace + (eq (elt i 1) ?\})) ; char-after + ;; Correct indentation of trailing ?\} + (+ cperl-indent-level cperl-close-paren-offset) + 0))) + ;; + ;; Indenter for continuation lines + ;; + ((eq 'continuation (elt i 0)) + ;; [continuation statement-start char-after is-block is-brace] + (goto-char (elt i 1)) ; statement-start + (+ (if (memq (elt i 2) (append "}])" nil)) ; char-after + 0 ; Closing parenth + cperl-continued-statement-offset) + (if (or (elt i 3) ; is-block + (not (elt i 4)) ; is-brace + (not (eq (elt i 2) ?\}))) ; char-after + 0 + ;; Now it is a hash reference + (+ cperl-indent-level cperl-close-paren-offset)) + ;; Labels do not take :: ... + (if (looking-at "\\(\\w\\|_\\)+[ \t]*:") + (if (> (current-indentation) cperl-min-label-indent) + (- (current-indentation) cperl-label-offset) + ;; Do not move `parse-data', this should + ;; be quick anyway (this comment comes + ;; from different location): + (cperl-calculate-indent)) + (current-column)) + (if (eq (elt i 2) ?\{) ; char-after + cperl-continued-brace-offset 0))) + ;; + ;; Indenter for lines in a block which are not leading lines + ;; + ((eq 'have-prev-sibling (elt i 0)) + ;; [have-prev-sibling sibling-beg colon-line-end block-start] + (goto-char (elt i 1)) + (if (> (elt i 2) (point)) ; colon-line-end; After-label, same line + (if (> (current-indentation) + cperl-min-label-indent) + (- (current-indentation) cperl-label-offset) + ;; Do not believe: `max' was involved in calculation of indent + (+ cperl-indent-level + (save-excursion + (goto-char (elt i 3)) ; block-start + (current-indentation)))) + (current-column))) + ;; + ;; Indenter for the first line in a block + ;; + ((eq 'code-start-in-block (elt i 0)) + ;;[code-start-in-block before-brace char-after + ;; is-a-HASH-ref brace-is-first-thing-on-a-line + ;; group-starts-before-start-of-sub start-of-control-group] + (goto-char (elt i 1)) + ;; For open brace in column zero, don't let statement + ;; start there too. If cperl-indent-level=0, + ;; use cperl-brace-offset + cperl-continued-statement-offset instead. + (+ (if (and (bolp) (zerop cperl-indent-level)) + (+ cperl-brace-offset cperl-continued-statement-offset) + cperl-indent-level) + (if (and (elt i 3) ; is-a-HASH-ref + (eq (elt i 2) ?\})) ; char-after: End of a hash reference + (+ cperl-indent-level cperl-close-paren-offset) + 0) + ;; Unless openbrace is the first nonwhite thing on the line, + ;; add the cperl-brace-imaginary-offset. + (if (elt i 4) 0 ; brace-is-first-thing-on-a-line + cperl-brace-imaginary-offset) + (progn + (goto-char (elt i 6)) ; start-of-control-group + (if (elt i 5) ; group-starts-before-start-of-sub + (current-column) + ;; Get initial indentation of the line we are on. + ;; 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]*:[^:]")) + (if (> (current-indentation) cperl-min-label-indent) + (- (current-indentation) cperl-label-offset) + ;; Do not move `parse-data', this should + ;; be quick anyway: + (cperl-calculate-indent)) + (current-indentation)))))) + (t + (error "Unrecognized value of indent: %s" i)))) + (t + (error "Got strange value of indent: %s" i)))))) + +(defvar cperl-indent-alist + '((string nil) + (comment nil) + (toplevel 0) + (toplevel-after-parenth 2) + (toplevel-continued 2) + (expression 1)) + "Alist of indentation rules for CPerl mode. +The values mean: + nil: do not indent; + number: add this amount of indentation. + +Not finished, not used.") + +(defun cperl-where-am-i (&optional parse-start start-state) + ;; Unfinished + "Return a list of lists ((TYPE POS)...) of good points before the point. +POS may be nil if it is hard to find, say, when TYPE is `string' or `comment'. + +Not finished, not used." + (save-excursion + (let* ((start-point (point)) unused + (s-s (cperl-get-state)) + (start (nth 0 s-s)) + (state (nth 1 s-s)) + (prestart (nth 3 s-s)) + (containing-sexp (car (cdr state))) + (case-fold-search nil) + (res (list (list 'parse-start start) (list 'parse-prestart prestart)))) + (cond ((nth 3 state) ; In string + (setq res (cons (list 'string nil (nth 3 state)) res))) ; What started string + ((nth 4 state) ; In comment + (setq res (cons '(comment) res))) + ((null containing-sexp) + ;; Line is at top level. + ;; Indent like the previous top level line + ;; unless that ends in a closeparen without semicolon, + ;; in which case this line is the first argument decl. + (cperl-backward-to-noncomment (or parse-start (point-min))) + ;;(skip-chars-backward " \t\f\n") + (cond + ((or (bobp) + (memq (preceding-char) (append ";}" nil))) + (setq res (cons (list 'toplevel start) res))) + ((eq (preceding-char) ?\) ) + (setq res (cons (list 'toplevel-after-parenth start) res))) + (t + (setq res (cons (list 'toplevel-continued start) res))))) + ((/= (char-after containing-sexp) ?{) + ;; line is expression, not statement: + ;; indent to just after the surrounding open. + ;; skip blanks if we do not close the expression. + (setq res (cons (list 'expression-blanks + (progn + (goto-char (1+ containing-sexp)) + (or (looking-at "[ \t]*\\(#\\|$\\)") + (skip-chars-forward " \t")) + (point))) + (cons (list 'expression containing-sexp) res)))) + ((progn + ;; Containing-expr starts with \{. Check whether it is a hash. + (goto-char containing-sexp) + (not (cperl-block-p))) + (setq res (cons (list 'expression-blanks + (progn + (goto-char (1+ containing-sexp)) + (or (looking-at "[ \t]*\\(#\\|$\\)") + (skip-chars-forward " \t")) + (point))) + (cons (list 'expression containing-sexp) res)))) + (t + ;; Statement level. + (setq res (cons (list 'in-block containing-sexp) res)) + ;; Is it a continuation or a new statement? + ;; Find previous non-comment character. + (cperl-backward-to-noncomment containing-sexp) + ;; Back up over label lines, since they don't + ;; affect whether our line is a continuation. + ;; Back up comma-delimited lines too ????? + (while (or (eq (preceding-char) ?\,) + (save-excursion (cperl-after-label))) + (if (eq (preceding-char) ?\,) + ;; Will go to beginning of line, essentially + ;; Will ignore embedded sexpr XXXX. + (cperl-backward-to-start-of-continued-exp containing-sexp)) + (beginning-of-line) + (cperl-backward-to-noncomment containing-sexp)) + ;; Now we get the answer. + (if (not (memq (preceding-char) (append ";}{" '(nil)))) ; Was ?\, + ;; This line is continuation of preceding line's statement. + (list (list 'statement-continued containing-sexp)) + ;; This line starts a new statement. + ;; Position following last unclosed open. + (goto-char containing-sexp) + ;; Is line first statement after an open-brace? + (or + ;; If no, find that first statement and indent like + ;; it. If the first statement begins with label, do + ;; not believe when the indentation of the label is too + ;; small. + (save-excursion + (forward-char 1) + (let ((colon-line-end 0)) + (while (progn (skip-chars-forward " \t\n" start-point) + (and (< (point) start-point) + (looking-at + "#\\|[a-zA-Z_][a-zA-Z0-9_]*:[^:]"))) + ;; Skip over comments and labels following openbrace. + (cond ((= (following-char) ?\#) + ;;(forward-line 1) + (end-of-line)) + ;; label: + (t + (save-excursion (end-of-line) + (setq colon-line-end (point))) + (search-forward ":")))) + ;; Now at the point, after label, or at start + ;; of first statement in the block. + (and (< (point) start-point) + (if (> colon-line-end (point)) + ;; Before statement after label + (if (> (current-indentation) + cperl-min-label-indent) + (list (list 'label-in-block (point))) + ;; Do not believe: `max' is involved + (list + (list 'label-in-block-min-indent (point)))) + ;; Before statement + (list 'statement-in-block (point)))))) + ;; If no previous statement, + ;; indent it relative to line brace is on. + ;; For open brace in column zero, don't let statement + ;; start there too. If cperl-indent-level is zero, + ;; use cperl-brace-offset + cperl-continued-statement-offset instead. + ;; For open-braces not the first thing in a line, + ;; add in cperl-brace-imaginary-offset. + + ;; If first thing on a line: ????? + (setq unused ; This is not finished... + (+ (if (and (bolp) (zerop cperl-indent-level)) + (+ cperl-brace-offset cperl-continued-statement-offset) + cperl-indent-level) + ;; Move back over whitespace before the openbrace. + ;; If openbrace is not first nonwhite thing on the line, + ;; add the cperl-brace-imaginary-offset. + (progn (skip-chars-backward " \t") + (if (bolp) 0 cperl-brace-imaginary-offset)) + ;; If the openbrace is preceded by a parenthesized exp, + ;; move to the beginning of that; + ;; possibly a different line + (progn + (if (eq (preceding-char) ?\)) + (forward-sexp -1)) + ;; Get initial indentation of the line we are on. + ;; 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]*:[^:]")) + (if (> (current-indentation) cperl-min-label-indent) + (- (current-indentation) cperl-label-offset) + (cperl-calculate-indent)) + (current-indentation))))))))) + res))) (defun cperl-calculate-indent-within-comment () "Return the indentation amount for line, assuming that @@ -2894,14 +3350,22 @@ the current line is to be regarded as part of a block comment." (defun cperl-to-comment-or-eol () "Go to position before comment on the current line, or to end of line. -Returns true if comment is found." - (let (state stop-in cpoint (lim (progn (end-of-line) (point)))) +Returns true if comment is found. In POD will not move the point." + ;; If the line is inside other syntax groups (qq-style strings, HERE-docs) + ;; then looks for literal # or end-of-line. + (let (state stop-in cpoint (lim (progn (end-of-line) (point))) pr e) + (or cperl-font-locking + (cperl-update-syntaxification lim lim)) (beginning-of-line) - (if (or - (eq (get-text-property (point) 'syntax-type) 'pod) - (re-search-forward "\\=[ \t]*\\(#\\|$\\)" lim t)) + (if (setq pr (get-text-property (point) 'syntax-type)) + (setq e (next-single-property-change (point) 'syntax-type nil (point-max)))) + (if (or (eq pr 'pod) + (if (or (not e) (> e lim)) ; deep inside a group + (re-search-forward "\\=[ \t]*\\(#\\|$\\)" lim t))) (if (eq (preceding-char) ?\#) (progn (backward-char 1) t)) - ;; Else + ;; Else - need to do it the hard way + (and (and e (<= e lim)) + (goto-char e)) (while (not stop-in) (setq state (parse-partial-sexp (point) lim nil nil nil t)) ; stop at comment @@ -2933,17 +3397,11 @@ Returns true if comment is found." (setq stop-in t))) ; Finish (nth 4 state)))) -(defsubst cperl-1- (p) - (max (point-min) (1- p))) - -(defsubst cperl-1+ (p) - (min (point-max) (1+ p))) - (defsubst cperl-modify-syntax-type (at how) (if (< at (point-max)) (progn (put-text-property at (1+ at) 'syntax-table how) - (put-text-property at (1+ at) 'rear-nonsticky t)))) + (put-text-property at (1+ at) 'rear-nonsticky '(syntax-table))))) (defun cperl-protect-defun-start (s e) ;; C code looks for "^\\s(" to skip comment backward in "hard" situations @@ -2978,35 +3436,53 @@ Returns true if comment is found." ( ?\{ . ?\} ) ( ?\< . ?\> ))) -(defun cperl-forward-re (lim end is-2arg set-st st-l err-l argument +(defun cperl-cached-syntax-table (st) + "Get a syntax table cached in ST, or create and cache into ST a syntax table. +All the entries of the syntax table are \".\", except for a backslash, which +is quoting." + (if (car-safe st) + (car st) + (setcar st (make-syntax-table)) + (setq st (car st)) + (let ((i 0)) + (while (< i 256) + (modify-syntax-entry i "." st) + (setq i (1+ i)))) + (modify-syntax-entry ?\\ "\\" st) + st)) + +(defun cperl-forward-re (lim end is-2arg st-l err-l argument &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 reset-st) +"Find the end of a regular expression or a stringish construct (q[] etc). +The point should be before the starting delimiter. + +Goes to LIM if none is found. If IS-2ARG is non-nil, assumes that it +is s/// or tr/// like expression. If END is nil, generates an error +message if needed. If SET-ST is non-nil, will use (or generate) a +cached syntax table in ST-L. If ERR-L is non-nil, will store the +error message in its CAR (unless it already contains some error +message). ARGUMENT should be the name of the construct (used in error +messages). OSTART, OEND may be set in recursive calls when processing +the second argument of 2ARG construct. + +Works *before* syntax recognition is done. In IS-2ARG situation may +modify syntax-type text property if the situation is too hard." + (let (b starter ender st i i2 go-forward reset-st set-st) (skip-chars-forward " \t") ;; ender means matching-char matcher. (setq b (point) starter (if (eobp) 0 (char-after b)) ender (cdr (assoc starter cperl-starters))) ;; What if starter == ?\\ ???? - (if set-st - (if (car st-l) - (setq st (car st-l)) - (setcar st-l (make-syntax-table)) - (setq i 0 st (car st-l)) - (while (< i 256) - (modify-syntax-entry i "." st) - (setq i (1+ i))) - (modify-syntax-entry ?\\ "\\" st))) + (setq st (cperl-cached-syntax-table st-l)) (setq set-st t) ;; Whether we have an intermediate point (setq i nil) ;; Prepare the syntax table: - (and set-st - (if (not ender) ; m/blah/, s/x//, s/x/y/ - (modify-syntax-entry starter "$" st) - (modify-syntax-entry starter (concat "(" (list ender)) st) - (modify-syntax-entry ender (concat ")" (list starter)) st))) + (if (not ender) ; m/blah/, s/x//, s/x/y/ + (modify-syntax-entry starter "$" st) + (modify-syntax-entry starter (concat "(" (list ender)) st) + (modify-syntax-entry ender (concat ")" (list starter)) st)) (condition-case bb (progn ;; We use `$' syntax class to find matching stuff, but $$ @@ -3053,7 +3529,7 @@ Returns true if comment is found." (modify-syntax-entry starter (if (eq starter ?\\) "\\" ".") st) (if ender (modify-syntax-entry ender "." st)) (setq set-st nil) - (setq ender (cperl-forward-re lim end nil t st-l err-l + (setq ender (cperl-forward-re lim end nil st-l err-l argument starter ender) ender (nth 2 ender))))) (error (goto-char lim) @@ -3078,6 +3554,33 @@ Returns true if comment is found." ;; go-forward: has 2 args, and the second part is empty (list i i2 ender starter go-forward))) +(defun cperl-forward-group-in-re (&optional st-l) + "Find the end of a group in a REx. +Return the error message (if any). Does not work if delimiter is `)'. +Works before syntax recognition is done." + ;; Works *before* syntax recognition is done + (or st-l (setq st-l (list nil))) ; Avoid overwriting '() + (let (st b reset-st) + (condition-case b + (progn + (setq st (cperl-cached-syntax-table st-l)) + (modify-syntax-entry ?\( "()" st) + (modify-syntax-entry ?\) ")(" st) + (setq reset-st (syntax-table)) + (set-syntax-table st) + (forward-sexp 1)) + (error (message + "cperl-forward-group-in-re: error %s" b))) + ;; now restore the initial state + (if st + (progn + (modify-syntax-entry ?\( "." st) + (modify-syntax-entry ?\) "." st))) + (if reset-st + (set-syntax-table reset-st)) + b)) + + (defvar font-lock-string-face) ;;(defvar font-lock-reference-face) (defvar font-lock-constant-face) @@ -3103,13 +3606,24 @@ Returns true if comment is found." ;; 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' +;; second part of s///e is marked `syntax-type' ==> `multiline' +;; e) Attributes of subroutines: `attrib-group' ==> t +;; (or 0 if declaration); up to `{' or ';': `syntax-type' => `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) - (setq opos pos) - (while (and pos (get-text-property pos 'syntax-type)) - (setq pos (previous-single-property-change pos 'syntax-type)) + (while (and pos (progn + (beginning-of-line) + (get-text-property (setq pos (point)) 'syntax-type))) + (setq opos pos + pos (cperl-beginning-of-property pos 'syntax-type)) + (if (eq pos (point-min)) + (setq pos nil)) (if pos (if before (progn @@ -3126,32 +3640,117 @@ Returns true if comment is found." (setq pos (point)) (if end ;; Do the same for end, going small steps - (progn + (save-excursion (while (and end (get-text-property end 'syntax-type)) (setq pos end - end (next-single-property-change end 'syntax-type))) + end (next-single-property-change end 'syntax-type nil (point-max))) + (if end (progn (goto-char end) + (or (bolp) (forward-line 1)) + (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-pods-heres (&optional min max non-inter end ignore-max) +(defun cperl-find-sub-attrs (&optional st-l b-fname e-fname pos) + "Syntaxically mark (and fontify) attributes of a subroutine. +Should be called with the point before leading colon of an attribute." + ;; Works *before* syntax recognition is done + (or st-l (setq st-l (list nil))) ; Avoid overwriting '() + (let (st b p reset-st after-first (start (point)) start1 end1) + (condition-case b + (while (looking-at + (concat + "\\(" ; 1=optional? colon + ":" cperl-maybe-white-and-comment-rex ; 2=whitespace/comment? + "\\)" + (if after-first "?" "") + ;; No space between name and paren allowed... + "\\(\\sw+\\)" ; 3=name + "\\((\\)?")) ; 4=optional paren + (and (match-beginning 1) + (cperl-postpone-fontification + (match-beginning 0) (cperl-1+ (match-beginning 0)) + 'face font-lock-constant-face)) + (setq start1 (match-beginning 3) end1 (match-end 3)) + (cperl-postpone-fontification start1 end1 + 'face font-lock-constant-face) + (goto-char end1) ; end or before `(' + (if (match-end 4) ; Have attribute arguments... + (progn + (if st nil + (setq st (cperl-cached-syntax-table st-l)) + (modify-syntax-entry ?\( "()" st) + (modify-syntax-entry ?\) ")(" st)) + (setq reset-st (syntax-table) p (point)) + (set-syntax-table st) + (forward-sexp 1) + (set-syntax-table reset-st) + (setq reset-st nil) + (cperl-commentify p (point) t))) ; mark as string + (forward-comment (buffer-size)) + (setq after-first t)) + (error (message + "L%d: attribute `%s': %s" + (count-lines (point-min) (point)) + (and start1 end1 (buffer-substring start1 end1)) b) + (setq start nil))) + (and start + (progn + (put-text-property start (point) + 'attrib-group (if (looking-at "{") t 0)) + (and pos + (< 1 (count-lines (+ 3 pos) (point))) ; end of `sub' + ;; Apparently, we do not need `multiline': faces added now + (put-text-property (+ 3 pos) (cperl-1+ (point)) + 'syntax-type 'sub-decl)) + (and b-fname ; Fontify here: the following condition + (cperl-postpone-fontification ; is too hard to determine by + b-fname e-fname 'face ; a REx, so do it here + (if (looking-at "{") + font-lock-function-name-face + font-lock-variable-name-face))))) + ;; now restore the initial state + (if st + (progn + (modify-syntax-entry ?\( "." st) + (modify-syntax-entry ?\) "." st))) + (if reset-st + (set-syntax-table reset-st)))) + +(defsubst cperl-look-at-leading-count (is-x-REx e) + (if (re-search-forward (concat "\\=" (if is-x-REx "[ \t\n]*" "") "[{?+*]") + (1- e) t) ; return nil on failure, no moving + (if (eq ?\{ (preceding-char)) nil + (cperl-postpone-fontification + (1- (point)) (point) + '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) "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'." (interactive) - (or min (setq min (point-min) + (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 - is-REx is-x-REx REx-comment-start REx-comment-end was-comment i2 + 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)) + (modified (buffer-modified-p)) overshoot is-o-REx (after-change-functions nil) + (cperl-font-locking t) (use-syntax-state (and cperl-syntax-state (>= min (car cperl-syntax-state)))) (state-point (if use-syntax-state @@ -3162,33 +3761,62 @@ 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)) + '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)) (search (concat - "\\(\\`\n?\\|^\n\\)=" + "\\(\\`\n?\\|^\n\\)=" ; POD "\\|" ;; One extra () before this: - "<<" + "<<" ; HERE-DOC "\\(" ; 1 + 1 ;; First variant "BLAH" or just ``. "[ \t]*" ; Yes, whitespace is allowed! @@ -3204,36 +3832,44 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', "\\)" "\\|" ;; 1+6 extra () before this: - "^[ \t]*\\(format\\)[ \t]*\\([a-zA-Z0-9_]+\\)?[ \t]*=[ \t]*$" + "^[ \t]*\\(format\\)[ \t]*\\([a-zA-Z0-9_]+\\)?[ \t]*=[ \t]*$" ;FRMAT (if cperl-use-syntax-table-text-property (concat "\\|" ;; 1+6+2=9 extra () before this: - "\\<\\(q[wxqr]?\\|[msy]\\|tr\\)\\>" + "\\<\\(q[wxqr]?\\|[msy]\\|tr\\)\\>" ; QUOTED CONSTRUCT "\\|" ;; 1+6+2+1=10 extra () before this: "\\([?/<]\\)" ; /blah/ or ?blah? or <file*glob> "\\|" - ;; 1+6+2+1+1=11 extra () before this: - "\\<sub\\>[ \t]*\\([a-zA-Z_:'0-9]+[ \t]*\\)?\\(([^()]*)\\)" + ;; 1+6+2+1+1=11 extra () before this + "\\<sub\\>" ; sub with proto/attr + "\\(" + cperl-white-and-comment-rex + "\\(::[a-zA-Z_:'0-9]*\\|[a-zA-Z_'][a-zA-Z_:'0-9]*\\)\\)?" ; name + "\\(" + cperl-maybe-white-and-comment-rex + "\\(([^()]*)\\|:[^:]\\)\\)" ; prototype or attribute start "\\|" - ;; 1+6+2+1+1+2=13 extra () before this: - "\\$\\(['{]\\)" + ;; 1+6+2+1+1+6=17 extra () before this: + "\\$\\(['{]\\)" ; $' or ${foo} "\\|" - ;; 1+6+2+1+1+2+1=14 extra () before this: + ;; 1+6+2+1+1+6+1=18 extra () before this (old pack'var syntax; + ;; we do not support intervening comments...): "\\(\\<sub[ \t\n\f]+\\|[&*$@%]\\)[a-zA-Z0-9_]*'" - ;; 1+6+2+1+1+2+1+1=15 extra () before this: + ;; 1+6+2+1+1+6+1+1=19 extra () before this: "\\|" - "__\\(END\\|DATA\\)__" - ;; 1+6+2+1+1+2+1+1+1=16 extra () before this: + "__\\(END\\|DATA\\)__" ; __END__ or __DATA__ + ;; 1+6+2+1+1+6+1+1+1=20 extra () before this: "\\|" - "\\\\\\(['`\"($]\\)") + "\\\\\\(['`\"($]\\)") ; BACKWACKED something-hairy "")))) (unwind-protect (progn (save-excursion (or non-inter (message "Scanning for \"hard\" Perl constructions...")) + ;;(message "find: %s --> %s" min max) (and cperl-pod-here-fontify ;; We had evals here, do not know why... (setq face cperl-pod-face @@ -3241,16 +3877,22 @@ the sections using `cperl-pod-head-face', `cperl-pod-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)) ;; Need to remove face as well... (goto-char min) (and (eq system-type 'emx) - (looking-at "extproc[ \t]") ; Analogue of #! + (eq (point) 1) + (let ((case-fold-search t)) + (looking-at "extproc[ \t]")) ; Analogue of #! (cperl-commentify min (save-excursion (end-of-line) (point)) nil)) @@ -3258,11 +3900,38 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', (< (point) max) (re-search-forward search max t)) (setq tmpend nil) ; Valid for most cases + (setq b (match-beginning 0) + state (save-excursion (parse-partial-sexp + state-point b nil nil state)) + state-point b) (cond + ;; 1+6+2+1+1+6=17 extra () before this: + ;; "\\$\\(['{]\\)" + ((match-beginning 18) ; $' or ${foo} + (if (eq (preceding-char) ?\') ; $' + (progn + (setq b (1- (point)) + state (parse-partial-sexp + state-point (1- b) nil nil state) + state-point (1- b)) + (if (nth 3 state) ; in string + (cperl-modify-syntax-type (1- b) cperl-st-punct)) + (goto-char (1+ b))) + ;; else: ${ + (setq bb (match-beginning 0)) + (cperl-modify-syntax-type bb cperl-st-punct))) + ;; No processing in strings/comments beyond this point: + ((or (nth 3 state) (nth 4 state)) + t) ; Do nothing in comment/string ((match-beginning 1) ; POD section ;; "\\(\\`\n?\\|^\n\\)=" - (if (looking-at "cut\\>") - (if ignore-max + (setq b (match-beginning 0) + state (parse-partial-sexp + state-point b nil nil state) + state-point b) + (if (or (nth 3 state) (nth 4 state) + (looking-at "cut\\>")) + (if (or (nth 3 state) (nth 4 state) ignore-max) nil ; Doing a chunk only (message "=cut is not preceded by a POD section") (or (car err-l) (setcar err-l (point)))) @@ -3288,11 +3957,15 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', (progn (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 rear-nonsticky t + front-sticky t first-format-line t + REx-part2 t indentable t)) (setq tmpend tb))) (put-text-property b e 'in-pod t) @@ -3335,7 +4008,8 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', (or (eq e (point-max)) (forward-char -1)))) ; Prepare for immediate POD start. ;; Here document - ;; We do only one here-per-line + ;; We can do many here-per-line; + ;; but multiline quote on the same line as <<HERE confuses us... ;; ;; One extra () before this: ;;"<<" ;; "\\(" ; 1 + 1 @@ -3352,21 +4026,42 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', ;; "\\(\\)" ; To preserve count of pars :-( 6 + 1 ;; "\\)" ((match-beginning 2) ; 1 + 1 - ;; Abort in comment: - (setq b (point)) - (setq state (parse-partial-sexp state-point b nil nil state) - state-point b + (setq b (point) tb (match-beginning 0) - i (or (nth 3 state) (nth 4 state))) - (if i - (setq c t) - (setq c (and - (match-beginning 5) - (not (match-beginning 6)) ; Empty - (looking-at - "[ \t]*[=0-9$@%&(]")))) + c (and ; not HERE-DOC + (match-beginning 5) + (save-match-data + (or (looking-at "[ \t]*(") ; << function_call() + (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?\\|system\\|exec\\|sort\\)\\>"))) + (error t))))))) + (error nil))) ; func(<<EOF) + (and (not (match-beginning 6)) ; Empty + (looking-at + "[ \t]*[=0-9$@%&(]")))))) (if c ; Not here-doc nil ; Skip it. + (setq c (match-end 2)) ; 1 + 1 (if (match-beginning 5) ;4 + 1 (setq b1 (match-beginning 5) ; 4 + 1 e1 (match-end 5)) ; 4 + 1 @@ -3376,15 +4071,20 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', qtag (regexp-quote tag)) (cond (cperl-pod-here-fontify ;; Highlight the starting delimiter - (cperl-postpone-fontification b1 e1 'face font-lock-constant-face) + (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 "^" qtag "$") stop-point 'toend) - (eq (following-char) ?\n)) + ;;;(eq (following-char) ?\n) ; XXXX WHY??? + ) (progn ; Pretend we matched at the end (goto-char (point-max)) (re-search-forward "\\'") @@ -3393,8 +4093,9 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', (if cperl-pod-here-fontify (progn ;; Highlight the ending delimiter - (cperl-postpone-fontification (match-beginning 0) (match-end 0) - 'face font-lock-constant-face) + (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) @@ -3404,10 +4105,21 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', '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) + (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)))) ;; format @@ -3462,7 +4174,7 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', (if (> (point) max) (setq tmpend tb)) (put-text-property b (point) 'syntax-type 'format)) - ;; Regexp: + ;; qq-like String or Regexp: ((or (match-beginning 10) (match-beginning 11)) ;; 1+6+2=9 extra () before this: ;; "\\<\\(q[wxqr]?\\|[msy]\\|tr\\)\\>" @@ -3471,10 +4183,10 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', (setq b1 (if (match-beginning 10) 10 11) argument (buffer-substring (match-beginning b1) (match-end b1)) - b (point) + b (point) ; end of qq etc i b c (char-after (match-beginning b1)) - bb (char-after (1- (match-beginning b1))) ; tmp holder + bb (char-after (1- (match-beginning b1))) ; tmp holder ;; bb == "Not a stringy" bb (if (eq b1 10) ; user variables/whatever (and (memq bb (append "$@%*#_:-&>" nil)) ; $#y) @@ -3488,7 +4200,7 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', (- (match-beginning b1) 2)) ?\-)) ((eq bb ?\&) - (not (eq (char-after ; &&m/blah/ + (not (eq (char-after ; &&m/blah/ (- (match-beginning b1) 2)) ?\&))) (t t))) @@ -3506,41 +4218,40 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', (setq argument "" b1 nil bb ; Not a regexp? - (progn - (not - ;; What is below: regexp-p? - (and - (or (memq (preceding-char) - (append (if (memq c '(?\? ?\<)) - ;; $a++ ? 1 : 2 - "~{(=|&*!,;:" - "~{(=|&+-*!,;:") nil)) - (and (eq (preceding-char) ?\}) - (cperl-after-block-p (point-min))) - (and (eq (char-syntax (preceding-char)) ?w) - (progn - (forward-sexp -1) + (not + ;; What is below: regexp-p? + (and + (or (memq (preceding-char) + (append (if (memq c '(?\? ?\<)) + ;; $a++ ? 1 : 2 + "~{(=|&*!,;:[" + "~{(=|&+-*!,;:[") nil)) + (and (eq (preceding-char) ?\}) + (cperl-after-block-p (point-min))) + (and (eq (char-syntax (preceding-char)) ?w) + (progn + (forward-sexp -1) ;; After these keywords `/' starts a RE. One should add all the ;; functions/builtins which expect an argument, but ... - (if (eq (preceding-char) ?-) - ;; -d ?foo? is a RE - (looking-at "[a-zA-Z]\\>") - (and - (not (memq (preceding-char) - '(?$ ?@ ?& ?%))) - (looking-at - "\\(while\\|if\\|unless\\|until\\|and\\|or\\|not\\|xor\\|split\\|grep\\|map\\|print\\)\\>"))))) - (and (eq (preceding-char) ?.) - (eq (char-after (- (point) 2)) ?.)) - (bobp)) - ;; m|blah| ? foo : bar; - (not - (and (eq c ?\?) - cperl-use-syntax-table-text-property - (not (bobp)) - (progn - (forward-char -1) - (looking-at "\\s|"))))))) + (if (eq (preceding-char) ?-) + ;; -d ?foo? is a RE + (looking-at "[a-zA-Z]\\>") + (and + (not (memq (preceding-char) + '(?$ ?@ ?& ?%))) + (looking-at + "\\(while\\|if\\|unless\\|until\\|and\\|or\\|not\\|xor\\|split\\|grep\\|map\\|print\\)\\>"))))) + (and (eq (preceding-char) ?.) + (eq (char-after (- (point) 2)) ?.)) + (bobp)) + ;; m|blah| ? foo : bar; + (not + (and (eq c ?\?) + cperl-use-syntax-table-text-property + (not (bobp)) + (progn + (forward-char -1) + (looking-at "\\s|")))))) b (1- b)) ;; s y tr m ;; Check for $a -> y @@ -3550,13 +4261,9 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', (eq (char-after (- go 2)) ?-)) ;; Not a regexp (setq bb t)))) - (or bb (setq state (parse-partial-sexp - state-point b nil nil state) - state-point b)) - (setq bb (or bb (nth 3 state) (nth 4 state))) - (goto-char b) (or bb (progn + (goto-char b) (if (looking-at "[ \t\n\f]+\\(#[^\n]*\n[ \t\n\f]*\\)+") (goto-char (match-end 0)) (skip-chars-forward " \t\n\f")) @@ -3593,6 +4300,8 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', (skip-chars-backward " \t\n\f") (memq (preceding-char) (append "$@%&*" nil)))) + (setq bb t)) + ((eobp) (setq bb t))))) (if bb (goto-char i) @@ -3605,15 +4314,16 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', ;; qtag means two-arg matcher, may be reset to ;; 2 or 3 later if some special quoting is needed. ;; e1 means matching-char matcher. - (setq b (point) + (setq b (point) ; before the first delimiter ;; has 2 args i2 (string-match "^\\([sy]\\|tr\\)$" argument) ;; We do not search to max, since we may be called from ;; some hook of fontification, and max is random i (cperl-forward-re stop-point end i2 - t st-l err-l argument) - ;; Note that if `go', then it is considered as 1-arg + st-l err-l argument) + ;; If `go', then it is considered as 1-arg, `b1' is nil + ;; as in s/foo//x; the point is before final "slash" b1 (nth 1 i) ; start of the second part tag (nth 2 i) ; ender-char, true if second part ; is with matching chars [] @@ -3625,13 +4335,18 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', (1- e1)) e (if i i e1) ; end of the first part qtag nil ; need to preserve backslashitis - is-x-REx nil) ; REx has //x modifier + is-x-REx nil is-o-REx nil); REx has //x //o modifiers + ;; If s{} (), then b/b1 are at "{", "(", e1/i after ")", "}" ;; 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)) + (and (if go (looking-at ".\\sw*x") + (looking-at "\\sw*x")) ; qr//x + (setq is-x-REx t)) + (and (if go (looking-at ".\\sw*o") + (looking-at "\\sw*o")) ; //o + (setq is-o-REx t)) (if (null i) ;; Considered as 1arg form (progn @@ -3648,9 +4363,11 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', (cperl-commentify b i t) (if (looking-at "\\sw*e") ; s///e (progn + ;; Cache the syntax info... + (setq cperl-syntax-state (cons state-point state)) (and ;; silent: - (cperl-find-pods-heres b1 (1- (point)) t end) + (car (cperl-find-pods-heres b1 (1- (point)) t end)) ;; Error (goto-char (1+ max))) (if (and tag (eq (preceding-char) ?\>)) @@ -3658,6 +4375,7 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', (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 i (point) 'syntax-type 'multiline) (if is-x-REx (put-text-property b i 'indentable t))) (cperl-commentify b1 (point) t) @@ -3673,7 +4391,7 @@ 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))) + e1 (point) 'face my-cperl-REx-modifiers-face))) ;; Check whether it is m// which means "previous match" ;; and highlight differently (setq is-REx @@ -3691,7 +4409,7 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', (not (looking-at "split\\>"))) (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 @@ -3700,135 +4418,417 @@ 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 better + ;; 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)(?<!bar)(x)(?:$ab|\$\/)$|\\\b\x888\776\[\:$/xxx; +;;;m?(\?\?{b,a})? + m/(??{aa})(?(?=xx)aa|bb)(?#aac)/; +;;;m$(^ab[c]\$)$ + m+(^ab[c]\$\+)+ + m](^ab[c\]$|.+)] + m)(^ab[c]$|.+\)); +;;;m^a[\^b]c^ + m.a[^b]\.c.; (save-excursion (goto-char (1+ b)) + ;; First + (cperl-look-at-leading-count is-x-REx e) + (setq hairy-RE + (concat + (if is-x-REx + (if (eq (char-after b) ?\#) + "\\((\\?\\\\#\\)\\|\\(\\\\#\\)" + "\\((\\?#\\)\\|\\(#\\)") + ;; keep the same count: add a fake group + (if (eq (char-after b) ?\#) + "\\((\\?\\\\#\\)\\(\\)" + "\\((\\?#\\)\\(\\)")) + "\\|" + "\\(\\[\\)" ; 3=[ + "\\|" + "\\(]\\)" ; 4=] + "\\|" + ;; XXXX Will not be able to use it in s))) + (if (eq (char-after b) ?\) ) + "\\())))\\)" ; Will never match + (if (eq (char-after b) ?? ) + ;;"\\((\\\\\\?\\(\\\\\\?\\)?{\\)" + "\\((\\\\\\?\\\\\\?{\\|()\\\\\\?{\\)" + "\\((\\?\\??{\\)")) ; 5= (??{ (?{ + "\\|" ; 6= 0-length, 7: name, 8,9:code, 10:group + "\\(" ;; XXXX 1-char variables, exc. |()\s + "[$@]" + "\\(" + "[_a-zA-Z:][_a-zA-Z0-9:]*" + "\\|" + "{[^{}]*}" ; only one-level allowed + "\\|" + "[^{(|) \t\r\n\f]" + "\\)" + "\\(" ;;8,9:code part of array/hash elt + "\\(" "->" "\\)?" + "\\[[^][]*\\]" + "\\|" + "{[^{}]*}" + "\\)*" + ;; XXXX: what if u is delim? + "\\|" + "[)^|$.*?+]" + "\\|" + "{[0-9]+}" + "\\|" + "{[0-9]+,[0-9]*}" + "\\|" + "\\\\[luLUEQbBAzZG]" + "\\|" + "(" ; Group opener + "\\(" ; 10 group opener follower + "\\?\\((\\?\\)" ; 11: in (?(?=C)A|B) + "\\|" + "\\?[:=!>?{]" ; "?" something + "\\|" + "\\?[-imsx]+[:)]" ; (?i) (?-s:.) + "\\|" + "\\?([0-9]+)" ; (?(1)foo|bar) + "\\|" + "\\?<[=!]" + ;;;"\\|" + ;;; "\\?" + "\\)?" + "\\)" + "\\|" + "\\\\\\(.\\)" ; 12=\SYMBOL + )) (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)) + (and (< (point) (1- e)) + (re-search-forward hairy-RE (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) + (setq REx-subgr-start (point) + 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 + (- (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 + (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 ] 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 + (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 - (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)))) + (goto-char (1- e)) + (message qtag)) + (cperl-postpone-fontification + (1- tag) (1- (point)) + 'face font-lock-variable-name-face) + (cperl-postpone-fontification + REx-subgr-start (1- tag) + 'face my-cperl-REx-spec-char-face) + (cperl-postpone-fontification + (1- (point)) (point) + 'face my-cperl-REx-spec-char-face) + (if cperl-use-syntax-table-text-property + (progn + (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))) - (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)))))) + (cond + (was-subgr + (setq REx-subgr-end (point)) + (cperl-commentify + REx-subgr-start REx-subgr-end nil) + (cperl-postpone-fontification + REx-subgr-start REx-subgr-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 - (1- e1) e1 'face font-lock-constant-face) + (1- e1) e1 'face my-cperl-delimiters-face) (if (assoc (char-after b) cperl-starters) - (cperl-postpone-fontification - b1 (1+ b1) 'face font-lock-constant-face)))) + (progn + (cperl-postpone-fontification + b1 (1+ b1) 'face my-cperl-delimiters-face) + (put-text-property b1 (1+ b1) + 'REx-part2 t))))) (if (> (point) max) (setq tmpend tb)))) - ((match-beginning 13) ; sub with prototypes - (setq b (match-beginning 0)) + ((match-beginning 17) ; sub with prototype or attribute + ;; 1+6+2+1+1=11 extra () before this (sub with proto/attr): + ;;"\\<sub\\>\\(" ;12 + ;; cperl-white-and-comment-rex ;13 + ;; "\\([a-zA-Z_:'0-9]+\\)\\)?" ; name ;14 + ;;"\\(" cperl-maybe-white-and-comment-rex ;15,16 + ;; "\\(([^()]*)\\|:[^:]\\)\\)" ; 17:proto or attribute start + (setq b1 (match-beginning 14) e1 (match-end 14)) (if (memq (char-after (1- b)) '(?\$ ?\@ ?\% ?\& ?\*)) nil - (setq state (parse-partial-sexp - state-point b nil nil state) - state-point b) - (if (or (nth 3 state) (nth 4 state)) - nil - ;; Mark as string - (cperl-commentify (match-beginning 13) (match-end 13) t)) - (goto-char (match-end 0)))) - ;; 1+6+2+1+1+2=13 extra () before this: - ;; "\\$\\(['{]\\)" - ((and (match-beginning 14) - (eq (preceding-char) ?\')) ; $' - (setq b (1- (point)) - state (parse-partial-sexp - state-point (1- b) nil nil state) - state-point (1- b)) - (if (nth 3 state) ; in string - (cperl-modify-syntax-type (1- b) cperl-st-punct)) - (goto-char (1+ b))) - ;; 1+6+2+1+1+2=13 extra () before this: - ;; "\\$\\(['{]\\)" - ((match-beginning 14) ; ${ - (setq bb (match-beginning 0)) - (cperl-modify-syntax-type bb cperl-st-punct)) - ;; 1+6+2+1+1+2+1=14 extra () before this: + (goto-char b) + (if (eq (char-after (match-beginning 17)) ?\( ) + (progn + (cperl-commentify ; Prototypes; mark as string + (match-beginning 17) (match-end 17) t) + (goto-char (match-end 0)) + ;; Now look for attributes after prototype: + (forward-comment (buffer-size)) + (and (looking-at ":[^:]") + (cperl-find-sub-attrs st-l b1 e1 b))) + ;; treat attributes without prototype + (goto-char (match-beginning 17)) + (cperl-find-sub-attrs st-l b1 e1 b)))) + ;; 1+6+2+1+1+6+1=18 extra () before this: ;; "\\(\\<sub[ \t\n\f]+\\|[&*$@%]\\)[a-zA-Z0-9_]*'") - ((match-beginning 15) ; old $abc'efg syntax - (setq bb (match-end 0) - b (match-beginning 0) - state (parse-partial-sexp - state-point b nil nil state) - state-point b) - (if (nth 3 state) ; in string - nil - (put-text-property (1- bb) bb 'syntax-table cperl-st-word)) + ((match-beginning 19) ; old $abc'efg syntax + (setq bb (match-end 0)) + ;;;(if (nth 3 state) nil ; in string + (put-text-property (1- bb) bb 'syntax-table cperl-st-word) (goto-char bb)) - ;; 1+6+2+1+1+2+1+1=15 extra () before this: + ;; 1+6+2+1+1+6+1+1=19 extra () before this: ;; "__\\(END\\|DATA\\)__" - ((match-beginning 16) ; __END__, __DATA__ - (setq bb (match-end 0) - b (match-beginning 0) - state (parse-partial-sexp - state-point b nil nil state) - state-point b) - (if (or (nth 3 state) (nth 4 state)) - nil - ;; (put-text-property b (1+ bb) 'syntax-type 'pod) ; Cheat - (cperl-commentify b bb nil) - (setq end t)) - (goto-char bb)) - ((match-beginning 17) ; "\\\\\\(['`\"($]\\)" - ;; Trailing backslash ==> non-quoting outside string/comment - (setq bb (match-end 0) - b (match-beginning 0)) + ((match-beginning 20) ; __END__, __DATA__ + (setq bb (match-end 0)) + ;; (put-text-property b (1+ bb) 'syntax-type 'pod) ; Cheat + (cperl-commentify b bb nil) + (setq end t)) + ;; "\\\\\\(['`\"($]\\)" + ((match-beginning 21) + ;; Trailing backslash; make non-quoting outside string/comment + (setq bb (match-end 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)) + (cperl-modify-syntax-type b cperl-st-punct) (goto-char bb)) (t (error "Error in regexp of the sniffer"))) (if (> (point) stop-point) @@ -3839,7 +4839,10 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', (or (car err-l) (setcar err-l b))) (goto-char stop-point)))) (setq cperl-syntax-state (cons state-point state) - cperl-syntax-done-to (or tmpend (max (point) max)))) + ;; Do not mark syntax as done past tmpend??? + cperl-syntax-done-to (or tmpend (max (point) max))) + ;;(message "state-at=%s, done-to=%s" state-point cperl-syntax-done-to) + ) (if (car err-l) (goto-char (car err-l)) (or non-inter (message "Scanning for \"hard\" Perl constructions... done")))) @@ -3851,48 +4854,91 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', ;; cperl-mode-syntax-table. ;; (set-syntax-table cperl-mode-syntax-table) ) - (car err-l))) + (list (car err-l) overshoot))) + +(defun cperl-find-pods-heres-region (min max) + (interactive "r") + (cperl-find-pods-heres min max)) (defun cperl-backward-to-noncomment (lim) ;; Stops at lim or after non-whitespace that is not in comment + ;; XXXX Wrongly understands end-of-multiline strings with # as comment (let (stop p pr) - (while (and (not stop) (> (point) (or lim 1))) + (while (and (not stop) (> (point) (or lim (point-min)))) (skip-chars-backward " \t\n\f" lim) (setq p (point)) (beginning-of-line) (if (memq (setq pr (get-text-property (point) 'syntax-type)) '(pod here-doc here-doc-delim)) (cperl-unwind-to-safe nil) - (or (looking-at "^[ \t]*\\(#\\|$\\)") - (progn (cperl-to-comment-or-eol) (bolp)) - (progn - (skip-chars-backward " \t") - (if (< p (point)) (goto-char p)) - (setq stop t))))))) + (or (and (looking-at "^[ \t]*\\(#\\|$\\)") + (not (memq pr '(string prestring)))) + (progn (cperl-to-comment-or-eol) (bolp)) + (progn + (skip-chars-backward " \t") + (if (< p (point)) (goto-char p)) + (setq stop t))))))) +;; Used only in `cperl-calculate-indent'... +(defun cperl-block-p () ; Do not C-M-q ! One string contains ";" ! + ;; Positions is before ?\{. Checks whether 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)) + (get-text-property (cperl-1- (point)) 'attrib-group) + (and (memq (char-syntax (preceding-char)) '(?w ?_)) + (progn + (backward-sexp) + ;; sub {BLK}, print {BLK} $data, but NOT `bless', `return', `tr' + (or (and (looking-at "[a-zA-Z0-9_:]+[ \t\n\f]*[{#]") ; Method call syntax + (not (looking-at "\\(bless\\|return\\|q[wqrx]?\\|tr\\|[smy]\\)\\>"))) + ;; sub bless::foo {} + (progn + (cperl-backward-to-noncomment (point-min)) + (and (eq (preceding-char) ?b) + (progn + (forward-sexp -1) + (looking-at "sub[ \t\n\f#]"))))))))) + +;;; What is the difference of (cperl-after-block-p lim t) and (cperl-block-p)? +;;; No save-excursion; condition-case ... In (cperl-block-p) the block +;;; may be a part of an in-statement construct, such as +;;; ${something()}, print {FH} $data. +;;; 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 preceeding } ends a block or a following { starts one. -Would not look before LIM. If PRE-BLOCK is nil checks preceeding }. -otherwise following {." - ;; We suppose that the preceding char is }. + "Return true if the preceeding } (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." (save-excursion (condition-case nil (progn (or pre-block (forward-sexp -1)) (cperl-backward-to-noncomment lim) (or (eq (point) lim) - (eq (preceding-char) ?\) ) ; if () {} sub f () {} - (if (eq (char-syntax (preceding-char)) ?w) ; else {} + ;; if () {} // sub f () {} // sub f :a(') {} + (eq (preceding-char) ?\) ) + ;; label: {} + (save-excursion (cperl-after-label)) + ;; sub :attr {} + (get-text-property (cperl-1- (point)) 'attrib-group) + (if (memq (char-syntax (preceding-char)) '(?w ?_)) ; else {} (save-excursion (forward-sexp -1) - (or (looking-at "\\(else\\|continue\\|grep\\|map\\|BEGIN\\|END\\|CHECK\\|INIT\\)\\>") + ;; else {} but not else::func {} + (or (and (looking-at "\\(else\\|continue\\|grep\\|map\\|BEGIN\\|END\\|CHECK\\|INIT\\)\\>") + (not (looking-at "\\(\\sw\\|_\\)+::"))) ;; sub f {} (progn (cperl-backward-to-noncomment lim) - (and (eq (char-syntax (preceding-char)) ?w) + (and (eq (preceding-char) ?b) (progn (forward-sexp -1) - (looking-at "sub\\>")))))) + (looking-at "sub[ \t\n\f#]")))))) + ;; What preceeds is not word... XXXX Last statement in sub??? (cperl-after-expr-p lim)))) (error nil)))) @@ -3914,12 +4960,12 @@ CHARS is a string that contains good characters to have before us (however, (if (get-text-property (point) 'here-doc-group) (progn (goto-char - (previous-single-property-change (point) 'here-doc-group)) + (cperl-beginning-of-property (point) 'here-doc-group)) (beginning-of-line 0))) (if (get-text-property (point) 'in-pod) (progn (goto-char - (previous-single-property-change (point) 'in-pod)) + (cperl-beginning-of-property (point) 'in-pod)) (beginning-of-line 0))) (if (looking-at "^[ \t]*\\(#\\|$\\)") nil ; Only comment, skip ;; Else: last iteration, or a label @@ -3931,7 +4977,7 @@ CHARS is a string that contains good characters to have before us (however, (progn (forward-char -1) (skip-chars-backward " \t\n\f" lim) - (eq (char-syntax (preceding-char)) ?w))) + (memq (char-syntax (preceding-char)) '(?w ?_)))) (forward-sexp -1) ; Possibly label. Skip it (goto-char p) (setq stop t)))) @@ -3947,6 +4993,44 @@ 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) + ;; May be after $, @, $# etc of a variable + (skip-chars-backward "$@%#"))) + (error nil))) + +(defun cperl-at-end-of-expr (&optional lim) + ;; Since the SEXP approach below is very fragile, do some overengineering + (or (looking-at (concat cperl-maybe-white-and-comment-rex "[;}]")) + (condition-case nil + (save-excursion + ;; If nothing interesting after, does as (forward-sexp -1); + ;; otherwise fails, or ends at a start of following sexp. + ;; XXXX PROBLEMS: if what follows (after ";") @FOO, or ${bar} + ;; may be stuck after @ or $; just put some stupid workaround now: + (let ((p (point))) + (forward-sexp 1) + (forward-sexp -1) + (while (memq (preceding-char) (append "%&@$*" nil)) + (forward-char -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)) @@ -3987,18 +5071,51 @@ conditional/loop constructs." (beginning-of-line) (while (null done) (setq top (point)) - (while (= (nth 0 (parse-partial-sexp (point) tmp-end - -1)) -1) + ;; Plan A: if line has an unfinished paren-group, go to end-of-group + (while (= -1 (nth 0 (parse-partial-sexp (point) tmp-end -1))) (setq top (point))) ; Get the outermost parenths in line (goto-char top) (while (< (point) tmp-end) (parse-partial-sexp (point) tmp-end nil t) ; To start-sexp or eol (or (eolp) (forward-sexp 1))) - (if (> (point) tmp-end) - (save-excursion - (end-of-line) - (setq tmp-end (point))) - (setq done t))) + (if (> (point) tmp-end) ; Yes, there an unfinished block + nil + (if (eq ?\) (preceding-char)) + (progn ;; Plan B: find by REGEXP block followup this line + (setq top (point)) + (condition-case nil + (progn + (forward-sexp -2) + (if (eq (following-char) ?$ ) ; for my $var (list) + (progn + (forward-sexp -1) + (if (looking-at "\\(my\\|local\\|our\\)\\>") + (forward-sexp -1)))) + (if (looking-at + (concat "\\(\\elsif\\|if\\|unless\\|while\\|until" + "\\|for\\(each\\)?\\>\\(\\(" + cperl-maybe-white-and-comment-rex + "\\(my\\|local\\|our\\)\\)?" + cperl-maybe-white-and-comment-rex + "\\$[_a-zA-Z0-9]+\\)?\\)\\>")) + (progn + (goto-char top) + (forward-sexp 1) + (setq top (point))))) + (error (setq done t))) + (goto-char top)) + (if (looking-at ; Try Plan C: continuation block + (concat cperl-maybe-white-and-comment-rex + "\\<\\(else\\|elsif\|continue\\)\\>")) + (progn + (goto-char (match-end 0)) + (save-excursion + (end-of-line) + (setq tmp-end (point)))) + (setq done t)))) + (save-excursion + (end-of-line) + (setq tmp-end (point)))) (goto-char tmp-end) (setq tmp-end (point-marker))) (if cperl-indent-region-fix-constructs @@ -4027,16 +5144,26 @@ Returns some position at the last line." ;; Looking at: ;; } ;; else - (if (and cperl-merge-trailing-else - (looking-at - "[ \t]*}[ \t]*\n[ \t\n]*\\(els\\(e\\|if\\)\\|continue\\)\\>")) - (progn - (search-forward "}") - (setq p (point)) - (skip-chars-forward " \t\n") - (delete-region p (point)) + (if cperl-merge-trailing-else + (if (looking-at + "[ \t]*}[ \t]*\n[ \t\n]*\\(els\\(e\\|if\\)\\|continue\\)\\>") + (progn + (search-forward "}") + (setq p (point)) + (skip-chars-forward " \t\n") + (delete-region p (point)) (insert (make-string cperl-indent-region-fix-constructs ?\s)) - (beginning-of-line))) + (beginning-of-line))) + (if (looking-at "[ \t]*}[ \t]*\\(els\\(e\\|if\\)\\|continue\\)\\>") + (save-excursion + (search-forward "}") + (delete-horizontal-space) + (insert "\n") + (setq ret (point)) + (if (cperl-indent-line parse-data) + (progn + (cperl-fix-line-spacing end parse-data) + (setq ret (point))))))) ;; Looking at: ;; } else (if (looking-at "[ \t]*}\\(\t*\\|[ \t][ \t]+\\)\\<\\(els\\(e\\|if\\)\\|continue\\)\\>") @@ -4073,19 +5200,19 @@ Returns some position at the last line." (insert (make-string cperl-indent-region-fix-constructs ?\s)) (beginning-of-line))) - ;; Looking at: - ;; } foreach my $var () { + ;; 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]+\\(my\\|local\\|our\\)\\)?[ \t]*\\$[_a-zA-Z0-9]+\\)?\\|until\\)\\>\\([ \t]*(\\|[ \t\n]*{\\)\\|[ \t]*{") (progn - (setq ml (match-beginning 8)) + (setq ml (match-beginning 8)) ; "(" or "{" after control word (re-search-forward "[({]") (forward-char -1) (setq p (point)) (if (eq (following-char) ?\( ) (progn (forward-sexp 1) - (setq pp (point))) + (setq pp (point))) ; past parenth-group ;; after `else' or nothing (if ml ; after `else' (skip-chars-backward " \t\n") @@ -4095,13 +5222,13 @@ Returns some position at the last line." ;; Multiline expr should be special (setq ml (and pp (save-excursion (goto-char p) (search-forward "\n" pp t)))) - (if (and (or (not pp) (< pp end)) + (if (and (or (not pp) (< pp end)) ; Do not go too far... (looking-at "[ \t\n]*{")) (progn (cond ((bolp) ; Were before `{', no if/else/etc nil) - ((looking-at "\\(\t*\\| [ \t]+\\){") + ((looking-at "\\(\t*\\| [ \t]+\\){") ; Not exactly 1 SPACE (delete-horizontal-space) (if (if ml cperl-extra-newline-before-brace-multiline @@ -4124,7 +5251,17 @@ Returns some position at the last line." (skip-chars-forward " \t\n") (delete-region pp (point)) (insert - (make-string cperl-indent-region-fix-constructs ?\s)))) + (make-string cperl-indent-region-fix-constructs ?\ ))) + ((and (looking-at "[\t ]*{") + (if ml cperl-extra-newline-before-brace-multiline + cperl-extra-newline-before-brace)) + (delete-horizontal-space) + (insert "\n") + (setq ret (point)) + (if (cperl-indent-line parse-data) + (progn + (cperl-fix-line-spacing end parse-data) + (setq ret (point)))))) ;; Now we are before `{' (if (looking-at "[ \t\n]*{[ \t]*[^ \t\n#]") (progn @@ -4276,7 +5413,7 @@ indentation and initial hashes. Behaves usually outside of comment." ;; (interactive "P") ; Only works when called from fill-paragraph. -stef (let (;; Non-nil if the current line contains a comment. has-comment - + fill-paragraph-function ; do not recurse ;; If has-comment, the appropriate fill-prefix for the comment. comment-fill-prefix ;; Line that contains code and comment (or nil) @@ -4308,7 +5445,7 @@ indentation and initial hashes. Behaves usually outside of comment." dc (- c (current-column)) len (- start (point)) start (point-marker)) (delete-char len) - (insert (make-string dc ?-))))) + (insert (make-string dc ?-))))) ; Placeholder (to avoid splitting???) (if (not has-comment) (fill-paragraph justify) ; Do the usual thing outside of comment ;; Narrow to include only the comment, and then fill the region. @@ -4330,11 +5467,16 @@ indentation and initial hashes. Behaves usually outside of comment." (point))) ;; Remove existing hashes (save-excursion - (goto-char (point-min)) - (while (progn (forward-line 1) (< (point) (point-max))) - (skip-chars-forward " \t") - (and (looking-at "#+") - (delete-char (- (match-end 0) (match-beginning 0)))))) + (goto-char (point-min)) + (while (progn (forward-line 1) (< (point) (point-max))) + (skip-chars-forward " \t") + (if (looking-at "#+") + (progn + (if (and (eq (point) (match-beginning 0)) + (not (eq (point) (match-end 0)))) nil + (error + "Bug in Emacs: `looking-at' in `narrow-to-region': match-data is garbage")) + (delete-char (- (match-end 0) (match-beginning 0))))))) ;; Lines with only hashes on them can be paragraph boundaries. (let ((paragraph-start (concat paragraph-start "\\|^[ \t#]*$")) @@ -4350,7 +5492,8 @@ indentation and initial hashes. Behaves usually outside of comment." (setq comment-column c) (indent-for-comment) ;; Repeat once more, flagging as iteration - (cperl-fill-paragraph justify t))))))) + (cperl-fill-paragraph justify t)))))) + t) (defun cperl-do-auto-fill () ;; Break out if the line is short enough @@ -4401,8 +5544,8 @@ 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 marker - (prev-pos 0) char fchar index index1 name (end-range 0) package) + packages ends-ranges p marker is-proto + (prev-pos 0) is-pack index index1 name (end-range 0) package) (goto-char (point-min)) (cperl-update-syntaxification (point-max) (point-max)) ;; Search for the function @@ -4410,72 +5553,81 @@ indentation and initial hashes. Behaves usually outside of comment." (while (re-search-forward (or regexp cperl-imenu--function-name-regexp-perl) nil t) + ;; 2=package-group, 5=package-name 8=sub-name (cond ((and ; Skip some noise if building tags - (match-beginning 2) ; package or sub - (eq (char-after (match-beginning 2)) ?p) ; package + (match-beginning 5) ; package name + ;;(eq (char-after (match-beginning 2)) ?p) ; package (not (save-match-data (looking-at "[ \t\n]*;")))) ; Plain text word 'package' nil) ((and - (match-beginning 2) ; package or sub + (or (match-beginning 2) + (match-beginning 8)) ; package or sub ;; 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))) - (save-excursion - (goto-char (match-beginning 2)) - (setq fchar (following-char))) + (setq is-pack (match-beginning 2)) ;; (if (looking-at "([^()]*)[ \t\n\f]*") ;; (goto-char (match-end 0))) ; Messes what follows - (setq char (following-char) ; ?\; for "sub foo () ;" - meth nil + (setq meth nil p (point)) (while (and ends-ranges (>= p (car ends-ranges))) ;; delete obsolete entries (setq ends-ranges (cdr ends-ranges) packages (cdr packages))) (setq package (or (car packages) "") end-range (or (car ends-ranges) 0)) - (if (eq fchar ?p) - (setq name (buffer-substring (match-beginning 3) (match-end 3)) - name (progn - (set-text-properties 0 (length name) nil name) - name) - package (concat name "::") - name (concat "package " name) - end-range - (save-excursion - (parse-partial-sexp (point) (point-max) -1) (point)) - ends-ranges (cons end-range ends-ranges) - packages (cons package packages))) - ;; ) + (if is-pack ; doing "package" + (progn + (if (match-beginning 5) ; named package + (setq name (buffer-substring (match-beginning 5) + (match-end 5)) + name (progn + (set-text-properties 0 (length name) nil name) + name) + package (concat name "::") + name (concat "package " name)) + ;; Support nameless packages + (setq name "package;" package "")) + (setq end-range + (save-excursion + (parse-partial-sexp (point) (point-max) -1) (point)) + ends-ranges (cons end-range ends-ranges) + packages (cons package packages))) + (setq is-proto + (or (eq (following-char) ?\;) + (eq 0 (get-text-property (point) 'attrib-group))))) ;; Skip this function name if it is a prototype declaration. - (if (and (eq fchar ?s) (eq char ?\;)) nil - (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)))) + (if (and is-proto (not is-pack)) nil + (or is-pack + (setq name + (buffer-substring (match-beginning 8) (match-end 8))) + (set-text-properties 0 (length name) nil name)) + (setq marker (make-marker)) + (set-marker marker (match-end (if is-pack 2 8))) + (cond (is-pack nil) + ((string-match "[:']" name) + (setq meth t)) + ((> p end-range) nil) + (t + (setq name (concat package name) meth t))) (setq index (cons name marker)) - (if (eq fchar ?p) + (if is-pack (push index index-pack-alist) (push index index-alist)) (if meth (push index index-meth-alist)) (push index index-unsorted-alist))) - ((match-beginning 5) ; POD section - ;; (beginning-of-line) - (setq index (imenu-example--name-and-position) - name (buffer-substring (match-beginning 6) (match-end 6))) + ((match-beginning 16) ; POD section + (setq name (buffer-substring (match-beginning 17) (match-end 17)) + marker (make-marker)) + (set-marker marker (match-beginning 17)) (set-text-properties 0 (length name) nil name) - (if (eq (char-after (match-beginning 5)) ?2) - (setq name (concat " " name))) - (setcar index name) + (setq name (concat (make-string + (* 3 (- (char-after (match-beginning 16)) ?1)) + ?\ ) + name) + index (cons name marker)) (setq index1 (cons (concat "=" name) (cdr index))) (push index index-pod-alist) (push index1 index-unsorted-alist))))) @@ -4539,29 +5691,20 @@ indentation and initial hashes. Behaves usually outside of comment." (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 +;;;; 2=package-group, 5=package-name 8=sub-name 16=head-level + ((match-beginning 2) 0) ; package + ((match-beginning 8) 1) ; sub + ((match-beginning 16) + (- (char-after (match-beginning 16)) ?0)) ; headN ==> N + (t 5))) ; should not happen (defvar cperl-compilation-error-regexp-alist - ;; This look like a paranoiac regexp: could anybody find a better one? (which WORK). + ;; This look like a paranoiac regexp: could anybody find a better one? (which WORKS). '(("^[^\n]* \\(file\\|at\\) \\([^ \t\n]+\\) [^\n]*line \\([0-9]+\\)[\\., \n]" 2 3)) "Alist that specifies how to match errors in perl output.") -(if (fboundp 'eval-after-load) - (eval-after-load - "mode-compile" - '(setq perl-compilation-error-regexp-alist - cperl-compilation-error-regexp-alist))) - (defun cperl-windowed-init () "Initialization under windowed version." @@ -4602,9 +5745,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 @@ -4627,7 +5773,7 @@ indentation and initial hashes. Behaves usually outside of comment." 'identity '("if" "until" "while" "elsif" "else" "unless" "for" "foreach" "continue" "exit" "die" "last" "goto" "next" - "redo" "return" "local" "exec" "sub" "do" "dump" "use" + "redo" "return" "local" "exec" "sub" "do" "dump" "use" "our" "require" "package" "eval" "my" "BEGIN" "END" "CHECK" "INIT") "\\|") ; Flow control "\\)\\>") 2) ; was "\\)[ \n\t;():,\|&]" @@ -4711,7 +5857,7 @@ indentation and initial hashes. Behaves usually outside of comment." ;; "chop" "defined" "delete" "do" "each" "else" "elsif" ;; "eval" "exists" "for" "foreach" "format" "goto" ;; "grep" "if" "keys" "last" "local" "map" "my" "next" - ;; "no" "package" "pop" "pos" "print" "printf" "push" + ;; "no" "our" "package" "pop" "pos" "print" "printf" "push" ;; "q" "qq" "qw" "qx" "redo" "return" "scalar" "shift" ;; "sort" "splice" "split" "study" "sub" "tie" "tr" ;; "undef" "unless" "unshift" "untie" "until" "use" @@ -4726,15 +5872,38 @@ indentation and initial hashes. Behaves usually outside of comment." "u\\(se\\|n\\(shift\\|ti\\(l\\|e\\)\\|def\\|less\\)\\)\\|" "while\\|y\\|__\\(END\\|DATA\\)__" ;__DATA__ added manually "\\|[sm]" ; Added manually - "\\)\\>") 2 'cperl-nonoverridable) + "\\)\\>") 2 'cperl-nonoverridable-face) ;; (mapconcat 'identity ;; '("#endif" "#else" "#ifdef" "#ifndef" "#if" ;; "#include" "#define" "#undef") ;; "\\|") '("-[rwxoRWXOezsfdlpSbctugkTBMAC]\\>\\([ \t]+_\\>\\)?" 0 font-lock-function-name-face keep) ; Not very good, triggers at "[a-z]" - '("\\<sub[ \t]+\\([^ \t{;()]+\\)[ \t]*\\(([^()]*)[ \t]*\\)?[#{\n]" 1 - font-lock-function-name-face) + ;; This highlights declarations and definitions differenty. + ;; We do not try to highlight in the case of attributes: + ;; it is already done by `cperl-find-pods-heres' + (list (concat "\\<sub" + cperl-white-and-comment-rex ; whitespace/comments + "\\([^ \n\t{;()]+\\)" ; 2=name (assume non-anonymous) + "\\(" + cperl-maybe-white-and-comment-rex ;whitespace/comments? + "([^()]*)\\)?" ; prototype + cperl-maybe-white-and-comment-rex ; whitespace/comments? + "[{;]") + 2 (if cperl-font-lock-multiline + '(if (eq (char-after (cperl-1- (match-end 0))) ?\{ ) + 'font-lock-function-name-face + 'font-lock-variable-name-face) + ;; need to manually set 'multiline' for older font-locks + '(progn + (if (< 1 (count-lines (match-beginning 0) + (match-end 0))) + (put-text-property + (+ 3 (match-beginning 0)) (match-end 0) + 'syntax-type 'multiline)) + (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) '("^[ \t]*format[ \t]+\\([a-zA-z_][a-zA-z_0-9:]*\\)[ \t]*=[ \t]*$" @@ -4770,12 +5939,56 @@ 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\\|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\\our\\)[ \t]*\\(([ \t]*\\)?\\([$@%*][a-zA-Z0-9_:]+\\)" + ;; 1=my_etc, 2=white? 3=(+white? 4=white? 5=var + (` ((, (concat "\\<\\(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{}]*\\(my\\|local\\|our\\)[ \t]*\\(([ \t]*\\)?\\([$@%*][a-zA-Z0-9_:]+\\)" 3 font-lock-variable-name-face))) '("\\<for\\(each\\)?\\([ \t]+\\(my\\|local\\|our\\)\\)?[ \t]*\\(\\$[a-zA-Z_][a-zA-Z_0-9]*\\)[ \t]*(" 4 font-lock-variable-name-face) @@ -4785,21 +5998,32 @@ indentation and initial hashes. Behaves usually outside of comment." (setq t-font-lock-keywords-1 (and (fboundp 'turn-on-font-lock) ; Check for newer font-lock - (not cperl-xemacs-p) ; not yet as of XEmacs 19.12 + ;; not yet as of XEmacs 19.12, works with 21.1.11 + (or + (not cperl-xemacs-p) + (string< "21.1.9" emacs-version) + (and (string< "21.1.10" emacs-version) + (string< emacs-version "21.1.2"))) '( ("\\(\\([@%]\\|\$#\\)[a-zA-Z_:][a-zA-Z0-9_:]*\\)" 1 (if (eq (char-after (match-beginning 2)) ?%) - 'cperl-hash - 'cperl-array) + 'cperl-hash-face + 'cperl-array-face) t) ; arrays and hashes ("\\(\\([$@]+\\)[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 - 'cperl-array) ; arrays and hashes + '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]\\)\\)" + (1 cperl-array-face) + (2 font-lock-variable-name-face)) + ("\\(%\\)\\(\\$+\\([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") ;;; Too much noise from \s* @s[ and friends ;;("\\(\\<\\([msy]\\|tr\\)[ \t]*\\([^ \t\na-zA-Z0-9_]\\)\\|\\(/\\)\\)" @@ -4811,7 +6035,7 @@ indentation and initial hashes. Behaves usually outside of comment." (if cperl-highlight-variables-indiscriminately (setq t-font-lock-keywords-1 (append t-font-lock-keywords-1 - (list '("[$*]{?\\(\\sw+\\)" 1 + (list '("\\([$*]{?\\sw+\\)" 1 font-lock-variable-name-face))))) (setq cperl-font-lock-keywords-1 (if cperl-syntaxify-by-font-lock @@ -4864,27 +6088,35 @@ 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 [nil nil t t t] nil [nil nil t t t]) - (list 'cperl-nonoverridable + (list 'cperl-nonoverridable-face ["chartreuse3" ("orchid1" "orange") nil "Gray80"] [nil nil "gray90"] [nil nil nil t t] [nil nil t t] [nil nil t t t]) - (list 'cperl-array + (list 'cperl-array-face ["blue" "yellow" nil "Gray80"] ["lightyellow2" ("navy" "os2blue" "darkgreen") "gray90"] t nil nil) - (list 'cperl-hash + (list 'cperl-hash-face ["red" "red" nil "Gray80"] ["lightyellow2" ("navy" "os2blue" "darkgreen") "gray90"] @@ -4907,15 +6139,17 @@ indentation and initial hashes. Behaves usually outside of comment." "Face for variable names") (cperl-force-face font-lock-type-face "Face for data types") - (cperl-force-face cperl-nonoverridable + (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 "Face for function names") - (cperl-force-face cperl-hash + (cperl-force-face cperl-hash-face "Face for hashes") - (cperl-force-face cperl-array + (cperl-force-face cperl-array-face "Face for arrays") ;;(defvar font-lock-constant-face 'font-lock-constant-face) ;;(defvar font-lock-variable-name-face 'font-lock-variable-name-face) @@ -4925,7 +6159,7 @@ indentation and initial hashes. Behaves usually outside of comment." ;; "Face to use for data types.")) ;;(or (boundp 'cperl-nonoverridable-face) ;; (defconst cperl-nonoverridable-face - ;; 'cperl-nonoverridable + ;; 'cperl-nonoverridable-face ;; "Face to use for data types from another group.")) ;;(if (not cperl-xemacs-p) nil ;; (or (boundp 'font-lock-comment-face) @@ -4941,24 +6175,24 @@ indentation and initial hashes. Behaves usually outside of comment." ;; 'font-lock-function-name-face ;; "Face to use for function names."))) (if (and - (not (cperl-is-face 'cperl-array)) + (not (cperl-is-face 'cperl-array-face)) (cperl-is-face 'font-lock-emphasized-face)) - (copy-face 'font-lock-emphasized-face 'cperl-array)) + (copy-face 'font-lock-emphasized-face 'cperl-array-face)) (if (and - (not (cperl-is-face 'cperl-hash)) + (not (cperl-is-face 'cperl-hash-face)) (cperl-is-face 'font-lock-other-emphasized-face)) - (copy-face 'font-lock-other-emphasized-face 'cperl-hash)) + (copy-face 'font-lock-other-emphasized-face 'cperl-hash-face)) (if (and - (not (cperl-is-face 'cperl-nonoverridable)) + (not (cperl-is-face 'cperl-nonoverridable-face)) (cperl-is-face 'font-lock-other-type-face)) - (copy-face 'font-lock-other-type-face 'cperl-nonoverridable)) + (copy-face 'font-lock-other-type-face 'cperl-nonoverridable-face)) ;;(or (boundp 'cperl-hash-face) ;; (defconst cperl-hash-face - ;; 'cperl-hash + ;; 'cperl-hash-face ;; "Face to use for hashes.")) ;;(or (boundp 'cperl-array-face) ;; (defconst cperl-array-face - ;; 'cperl-array + ;; 'cperl-array-face ;; "Face to use for arrays.")) ;; Here we try to guess background (let ((background @@ -4997,17 +6231,17 @@ indentation and initial hashes. Behaves usually outside of comment." "pink"))) (t (set-face-background 'font-lock-type-face "gray90")))) - (if (cperl-is-face 'cperl-nonoverridable) + (if (cperl-is-face 'cperl-nonoverridable-face) nil - (copy-face 'font-lock-type-face 'cperl-nonoverridable) + (copy-face 'font-lock-type-face 'cperl-nonoverridable-face) (cond ((eq background 'light) - (set-face-foreground 'cperl-nonoverridable + (set-face-foreground 'cperl-nonoverridable-face (if (x-color-defined-p "chartreuse3") "chartreuse3" "chartreuse"))) ((eq background 'dark) - (set-face-foreground 'cperl-nonoverridable + (set-face-foreground 'cperl-nonoverridable-face (if (x-color-defined-p "orchid1") "orchid1" "orange"))))) @@ -5059,15 +6293,15 @@ indentation and initial hashes. Behaves usually outside of comment." '(setq ps-bold-faces ;; font-lock-variable-name-face ;; font-lock-constant-face - (append '(cperl-array cperl-hash) + (append '(cperl-array-face cperl-hash-face) ps-bold-faces) ps-italic-faces ;; font-lock-constant-face - (append '(cperl-nonoverridable cperl-hash) + (append '(cperl-nonoverridable-face cperl-hash-face) ps-italic-faces) ps-underlined-faces ;; font-lock-type-face - (append '(cperl-array cperl-hash underline cperl-nonoverridable) + (append '(cperl-array-face cperl-hash-face underline cperl-nonoverridable-face) ps-underlined-faces)))) (defvar ps-print-face-extension-alist) @@ -5100,27 +6334,27 @@ Style of printout regulated by the variable `cperl-ps-print-face-properties'." ;;; (defvar ps-italic-faces nil) ;;; (setq ps-bold-faces ;;; (append '(font-lock-emphasized-face -;;; cperl-array +;;; cperl-array-face ;;; font-lock-keyword-face ;;; font-lock-variable-name-face ;;; font-lock-constant-face ;;; font-lock-reference-face ;;; font-lock-other-emphasized-face -;;; cperl-hash) +;;; cperl-hash-face) ;;; ps-bold-faces)) ;;; (setq ps-italic-faces -;;; (append '(cperl-nonoverridable +;;; (append '(cperl-nonoverridable-face ;;; font-lock-constant-face ;;; font-lock-reference-face ;;; font-lock-other-emphasized-face -;;; cperl-hash) +;;; cperl-hash-face) ;;; ps-italic-faces)) ;;; (setq ps-underlined-faces ;;; (append '(font-lock-emphasized-face -;;; cperl-array +;;; cperl-array-face ;;; font-lock-other-emphasized-face -;;; cperl-hash -;;; cperl-nonoverridable font-lock-type-face) +;;; cperl-hash-face +;;; cperl-nonoverridable-face font-lock-type-face) ;;; ps-underlined-faces)) ;;; (cons 'font-lock-type-face ps-underlined-faces)) @@ -5130,79 +6364,211 @@ Style of printout regulated by the variable `cperl-ps-print-face-properties'." (defconst cperl-styles-entries '(cperl-indent-level cperl-brace-offset cperl-continued-brace-offset cperl-label-offset cperl-extra-newline-before-brace + cperl-extra-newline-before-brace-multiline cperl-merge-trailing-else cperl-continued-statement-offset)) +(defconst cperl-style-examples +"##### Numbers etc are: cperl-indent-level cperl-brace-offset +##### cperl-continued-brace-offset cperl-label-offset +##### cperl-continued-statement-offset +##### cperl-merge-trailing-else cperl-extra-newline-before-brace + +########### (Do not forget cperl-extra-newline-before-brace-multiline) + +### CPerl (=GNU - extra-newline-before-brace + merge-trailing-else) 2/0/0/-2/2/t/nil +if (foo) { + bar + baz; + label: + { + boon; + } +} else { + stop; +} + +### PerlStyle (=CPerl with 4 as indent) 4/0/0/-4/4/t/nil +if (foo) { + bar + baz; + label: + { + boon; + } +} else { + stop; +} + +### GNU 2/0/0/-2/2/nil/t +if (foo) + { + bar + baz; + label: + { + boon; + } + } +else + { + stop; + } + +### C++ (=PerlStyle with braces aligned with control words) 4/0/-4/-4/4/nil/t +if (foo) +{ + bar + baz; + label: + { + boon; + } +} +else +{ + stop; +} + +### BSD (=C++, but will not change preexisting merge-trailing-else +### and extra-newline-before-brace ) 4/0/-4/-4/4 +if (foo) +{ + bar + baz; + label: + { + boon; + } +} +else +{ + stop; +} + +### K&R (=C++ with indent 5 - merge-trailing-else, but will not +### change preexisting extra-newline-before-brace) 5/0/-5/-5/5/nil +if (foo) +{ + bar + baz; + label: + { + boon; + } +} +else +{ + stop; +} + +### Whitesmith (=PerlStyle, but will not change preexisting +### extra-newline-before-brace and merge-trailing-else) 4/0/0/-4/4 +if (foo) + { + bar + baz; + label: + { + boon; + } + } +else + { + stop; + } +" +"Examples of if/else with different indent styles (with v4.23).") + (defconst cperl-style-alist - '(("CPerl" ; =GNU without extra-newline-before-brace + '(("CPerl" ;; =GNU - extra-newline-before-brace + cperl-merge-trailing-else (cperl-indent-level . 2) (cperl-brace-offset . 0) (cperl-continued-brace-offset . 0) (cperl-label-offset . -2) + (cperl-continued-statement-offset . 2) (cperl-extra-newline-before-brace . nil) - (cperl-merge-trailing-else . t) - (cperl-continued-statement-offset . 2)) + (cperl-extra-newline-before-brace-multiline . nil) + (cperl-merge-trailing-else . t)) + ("PerlStyle" ; CPerl with 4 as indent (cperl-indent-level . 4) (cperl-brace-offset . 0) (cperl-continued-brace-offset . 0) (cperl-label-offset . -4) + (cperl-continued-statement-offset . 4) (cperl-extra-newline-before-brace . nil) - (cperl-merge-trailing-else . t) - (cperl-continued-statement-offset . 4)) + (cperl-extra-newline-before-brace-multiline . nil) + (cperl-merge-trailing-else . t)) + ("GNU" (cperl-indent-level . 2) (cperl-brace-offset . 0) (cperl-continued-brace-offset . 0) (cperl-label-offset . -2) + (cperl-continued-statement-offset . 2) (cperl-extra-newline-before-brace . t) - (cperl-merge-trailing-else . nil) - (cperl-continued-statement-offset . 2)) + (cperl-extra-newline-before-brace-multiline . t) + (cperl-merge-trailing-else . nil)) + ("K&R" (cperl-indent-level . 5) (cperl-brace-offset . 0) (cperl-continued-brace-offset . -5) (cperl-label-offset . -5) + (cperl-continued-statement-offset . 5) ;;(cperl-extra-newline-before-brace . nil) ; ??? - (cperl-merge-trailing-else . nil) - (cperl-continued-statement-offset . 5)) + ;;(cperl-extra-newline-before-brace-multiline . nil) + (cperl-merge-trailing-else . nil)) + ("BSD" (cperl-indent-level . 4) (cperl-brace-offset . 0) (cperl-continued-brace-offset . -4) (cperl-label-offset . -4) + (cperl-continued-statement-offset . 4) ;;(cperl-extra-newline-before-brace . nil) ; ??? - (cperl-continued-statement-offset . 4)) + ;;(cperl-extra-newline-before-brace-multiline . nil) + ;;(cperl-merge-trailing-else . nil) ; ??? + ) + ("C++" (cperl-indent-level . 4) (cperl-brace-offset . 0) (cperl-continued-brace-offset . -4) (cperl-label-offset . -4) (cperl-continued-statement-offset . 4) - (cperl-merge-trailing-else . nil) - (cperl-extra-newline-before-brace . t)) - ("Current") + (cperl-extra-newline-before-brace . t) + (cperl-extra-newline-before-brace-multiline . t) + (cperl-merge-trailing-else . nil)) + ("Whitesmith" (cperl-indent-level . 4) (cperl-brace-offset . 0) (cperl-continued-brace-offset . 0) (cperl-label-offset . -4) + (cperl-continued-statement-offset . 4) ;;(cperl-extra-newline-before-brace . nil) ; ??? - (cperl-continued-statement-offset . 4))) - "(Experimental) list of variables to set to get a particular indentation style. -Should be used via `cperl-set-style' or via Perl menu.") + ;;(cperl-extra-newline-before-brace-multiline . nil) + ;;(cperl-merge-trailing-else . nil) ; ??? + ) + ("Current")) + "List of variables to set to get a particular indentation style. +Should be used via `cperl-set-style' or via Perl menu. + +See examples in `cperl-style-examples'.") (defun cperl-set-style (style) "Set CPerl mode variables to use one of several different indentation styles. The arguments are a string representing the desired style. The list of styles is in `cperl-style-alist', available styles -are GNU, K&R, BSD, C++ and Whitesmith. +are CPerl, PerlStyle, GNU, K&R, BSD, C++ and Whitesmith. The current value of style is memorized (unless there is a memorized data already), may be restored by `cperl-set-style-back'. Chosing \"Current\" style will not change style, so this may be used for -side-effect of memorizing only." +side-effect of memorizing only. Examples in `cperl-style-examples'." (interactive (let ((list (mapcar (function (lambda (elt) (list (car elt)))) cperl-style-alist))) @@ -5373,6 +6739,8 @@ Customized by setting variables `cperl-shrink-wrap-info-frame', (match-beginning 1) (match-end 1))) (defun cperl-imenu-on-info () + "Shows imenu for Perl Info Buffer. +Opens Perl Info buffer if needed." (interactive) (let* ((buffer (current-buffer)) imenu-create-index-function @@ -5412,7 +6780,7 @@ If STEP is nil, `cperl-lineup-step' will be used \(or `cperl-indent-level', if `cperl-lineup-step' is nil). Will not move the position at the start to the left." (interactive "r") - (let (search col tcol seen b e) + (let (search col tcol seen b) (save-excursion (goto-char end) (end-of-line) @@ -5450,22 +6818,25 @@ Will not move the position at the start to the left." (if (/= (% col step) 0) (setq step (* step (1+ (/ col step))))) (while (progn - (setq e (point)) - (skip-chars-backward " \t") - (delete-region (point) e) - (indent-to-column col) ;(make-string (- col (current-column)) ?\s)) + (cperl-make-indent col) (beginning-of-line 2) (and (< (point) end) (re-search-forward search end t) (goto-char (match-beginning 0)))))))) ; No body -(defun cperl-etags (&optional add all files) +(defun cperl-etags (&optional add all files) ;; NOT USED??? "Run etags with appropriate options for Perl files. If optional argument ALL is `recursive', will process Perl files in subdirectories too." (interactive) (let ((cmd "etags") - (args '("-l" "none" "-r" "/\\<\\(package\\|sub\\)[ \\t]+\\(\\([a-zA-Z0-9:_]*::\\)?\\([a-zA-Z0-9_]+\\)[ \\t]*\\(([^()]*)[ \t]*\\)?\\([{#]\\|$\\)\\)/\\4/")) + (args '("-l" "none" "-r" + ;; 1=fullname 2=package? 3=name 4=proto? 5=attrs? (VERY APPROX!) + "/\\<sub[ \\t]+\\(\\([a-zA-Z0-9:_]*::\\)?\\([a-zA-Z0-9_]+\\)\\)[ \\t]*\\(([^()]*)[ \t]*\\)?\\([ \t]*:[^#{;]*\\)?\\([{#]\\|$\\)/\\3/" + "-r" + "/\\<package[ \\t]+\\(\\([a-zA-Z0-9:_]*::\\)?\\([a-zA-Z0-9_]+\\)\\)[ \\t]*\\([#;]\\|$\\)/\\1/" + "-r" + "/\\<\\(package\\)[ \\t]*;/\\1;/")) res) (if add (setq args (cons "-a" args))) (or files (setq files (list buffer-file-name))) @@ -5537,6 +6908,29 @@ Delay of auto-help controlled by `cperl-lazy-help-time'." (message "indent-region/indent-sexp will %sbe automatically fix whitespace." (if cperl-indent-region-fix-constructs "" "not "))) +(defun cperl-toggle-set-debug-unwind (arg &optional backtrace) + "Toggle (or, with numeric argument, set) debugging state of syntaxification. +Nonpositive numeric argument disables debugging messages. The message +summarizes which regions it was decided to rescan for syntactic constructs. + +The message looks like this: + + Syxify req=123..138 actual=101..146 done-to: 112=>146 statepos: 73=>117 + +Numbers are character positions in the buffer. REQ provides the range to +rescan requested by `font-lock'. ACTUAL is the range actually resyntaxified; +for correct operation it should start and end outside any special syntactic +construct. DONE-TO and STATEPOS indicate changes to internal caches maintained +by CPerl." + (interactive "P") + (or arg + (setq arg (if (eq cperl-syntaxify-by-font-lock + (if backtrace 'backtrace 'message)) 0 1))) + (setq arg (if (> arg 0) (if backtrace 'backtrace 'message) t)) + (setq cperl-syntaxify-by-font-lock arg) + (message "Debugging messages of syntax unwind %sabled." + (if (eq arg t) "dis" "en"))) + ;;;; Tags file creation. (defvar cperl-tmp-buffer " *cperl-tmp*") @@ -5677,13 +7071,22 @@ Delay of auto-help controlled by `cperl-lazy-help-time'." ret)))) (defun cperl-add-tags-recurse-noxs () - "Add to TAGS data for Perl and XSUB files in the current directory and kids. + "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 + -f cperl-add-tags-recurse-noxs " (cperl-write-tags nil nil t t nil t)) +(defun cperl-add-tags-recurse-noxs-fullpath () + "Add to TAGS data for \"pure\" Perl in the current directory and kids. +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 +" + (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 @@ -5853,9 +7256,9 @@ One may build such TAGS files from CPerl mode menu." (cperl-tags-hier-fill)) (or tags-table-list (call-interactively 'visit-tags-table)) - (mapcar - (function - (lambda (tagsfile) + (mapcar + (function + (lambda (tagsfile) (message "Updating list of classes... %s" tagsfile) (set-buffer (get-file-buffer tagsfile)) (cperl-tags-hier-fill))) @@ -6017,7 +7420,7 @@ One may build such TAGS files from CPerl mode menu." '("[^-\t <>=+]\\(--\\|\\+\\+\\)" ; var-- var++ "[a-zA-Z0-9_][|&][a-zA-Z0-9_$]" ; abc|def abc&def are often used. "&[(a-zA-Z0-9_$]" ; &subroutine &(var->field) - "<\\$?\\sw+\\(\\.\\sw+\\)?>" ; <IN> <stdin.h> + "<\\$?\\sw+\\(\\.\\(\\sw\\|_\\)+\\)?>" ; <IN> <stdin.h> "-[a-zA-Z][ \t]+[_$\"'`a-zA-Z]" ; -f file, -t STDIN "-[0-9]" ; -5 "\\+\\+" ; ++var @@ -6049,8 +7452,7 @@ Currently it is tuned to C and Perl syntax." (interactive) (let (found-bad (p (point))) (setq last-nonmenu-event 13) ; To disable popup - (with-no-warnings ; It is useful to push the mark here. - (beginning-of-buffer)) + (goto-char (point-min)) (map-y-or-n-p "Insert space here? " (lambda (arg) (insert " ")) 'cperl-next-bad-style @@ -6446,7 +7848,7 @@ endservent eof[([FILEHANDLE])] ... eq ... String equality. eval(EXPR) or eval { BLOCK } -exec(LIST) +exec([TRUENAME] ARGV0, ARGVs) or exec(SHELL_COMMAND_LINE) exit(EXPR) exp(EXPR) fcntl(FILEHANDLE,FUNCTION,SCALAR) @@ -6582,7 +7984,7 @@ substr(EXPR,OFFSET[,LEN]) symlink(OLDFILE,NEWFILE) syscall(LIST) sysread(FILEHANDLE,SCALAR,LENGTH[,OFFSET]) -system(LIST) +system([TRUENAME] ARGV0 [,ARGV]) or system(SHELL_COMMAND_LINE) syswrite(FILEHANDLE,SCALAR,LENGTH[,OFFSET]) tell[(FILEHANDLE)] telldir(DIRHANDLE) @@ -6683,7 +8085,7 @@ prototype \\&SUB Returns prototype of the function given a reference. ;; b is before the starting delimiter, e before the ending ;; e should be a marker, may be changed, but remains "correct". ;; EMBED is nil iff we process the whole REx. - ;; The REx is guarantied to have //x + ;; The REx is guaranteed 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) @@ -6712,7 +8114,7 @@ prototype \\&SUB Returns prototype of the function given a reference. (goto-char e) (delete-horizontal-space) (insert "\n") - (indent-to-column c) + (cperl-make-indent c) (set-marker e (point)))) (goto-char b) (end-of-line 2) @@ -6722,7 +8124,7 @@ prototype \\&SUB Returns prototype of the function given a reference. inline t) (skip-chars-forward " \t") (delete-region s (point)) - (indent-to-column c1) + (cperl-make-indent c1) (while (and inline (looking-at @@ -6748,6 +8150,16 @@ prototype \\&SUB Returns prototype of the function given a reference. (eq (preceding-char) ?\{))) (forward-char -1) (forward-sexp 1)) + ((and ; [], already syntaxified + (match-beginning 6) + cperl-regexp-scan + cperl-use-syntax-table-text-property) + (forward-char -1) + (forward-sexp 1) + (or (eq (preceding-char) ?\]) + (error "[]-group not terminated")) + (re-search-forward + "\\=\\([*+?]\\|{[0-9]+\\(,[0-9]*\\)?}\\)\\??" e t)) ((match-beginning 6) ; [] (setq tmp (point)) (if (looking-at "\\^?\\]") @@ -6761,12 +8173,8 @@ prototype \\&SUB Returns prototype of the function given a reference. (setq pos t))) (or (eq (preceding-char) ?\]) (error "[]-group not terminated")) - (if (eq (following-char) ?\{) - (progn - (forward-sexp 1) - (and (eq (following-char) ??) - (forward-char 1))) - (re-search-forward "\\=\\([*+?]\\??\\)" e t))) + (re-search-forward + "\\=\\([*+?]\\|{[0-9]+\\(,[0-9]*\\)?}\\)\\??" e t)) ((match-beginning 7) ; () (goto-char (match-beginning 0)) (setq pos (current-column)) @@ -6774,7 +8182,7 @@ prototype \\&SUB Returns prototype of the function given a reference. (progn (delete-horizontal-space) (insert "\n") - (indent-to-column c1))) + (cperl-make-indent c1))) (setq tmp (point)) (forward-sexp 1) ;; (or (forward-sexp 1) @@ -6834,7 +8242,7 @@ prototype \\&SUB Returns prototype of the function given a reference. (insert "\n")) ;; first at line (delete-region (point) tmp)) - (indent-to-column c) + (cperl-make-indent c) (forward-char 1) (skip-chars-forward " \t") (setq spaces nil) @@ -6857,10 +8265,7 @@ prototype \\&SUB Returns prototype of the function given a reference. (/= (current-indentation) c)) (progn (beginning-of-line) - (setq s (point)) - (skip-chars-forward " \t") - (delete-region s (point)) - (indent-to-column c))))) + (cperl-make-indent c))))) (defun cperl-make-regexp-x () ;; Returns position of the start @@ -6929,7 +8334,7 @@ We suppose that the regexp is scanned already." (interactive) ;; (save-excursion ; Can't, breaks `cperl-contract-levels' (cperl-regext-to-level-start) - (let ((b (point)) (e (make-marker)) s c) + (let ((b (point)) (e (make-marker)) c) (forward-sexp 1) (set-marker e (1- (point))) (goto-char b) @@ -6938,10 +8343,7 @@ We suppose that the regexp is scanned already." ((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)) + (cperl-make-indent c)) (t (delete-char -1) (just-one-space)))))) @@ -6980,96 +8382,197 @@ 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) + ;; May be after $, @, $# etc of a variable + (skip-chars-backward "$@%#") + (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 "\\<els\\(e\\|if\\)\\>")) (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 <afoiani@uswest.com> ;;; Getting help on modules in C-h f ? ;;; This is a modified version of `man'. ;;; Need to teach it how to lookup functions +;;;###autoload (defun cperl-perldoc (word) "Run `perldoc' on WORD." (interactive @@ -7101,6 +8604,7 @@ We suppose that the regexp is scanned already." (t (Man-getpage-in-background word))))) +;;;###autoload (defun cperl-perldoc-at-point () "Run a `perldoc' on the word around point." (interactive) @@ -7145,7 +8649,7 @@ We suppose that the regexp is scanned already." (defun cperl-pod2man-build-command () "Builds the entire background manpage and cleaning command." (let ((command (concat pod2man-program " %s 2>/dev/null")) - (flist Man-filter-list)) + (flist (and (boundp 'Man-filter-list) Man-filter-list))) (while (and flist (car flist)) (let ((pcom (car (car flist))) (pargs (cdr (car flist)))) @@ -7159,6 +8663,205 @@ 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. +If a region is highlighted, restricts to the region." + (interactive "") + (cperl-pod-spell t beg end)) + +(defun cperl-pod-spell (&optional do-heres beg end) + "Spell-check POD documentation. +If invoked with prefix argument, will do HERE-DOCs instead. +If a region is highlighted, restricts to the region." + (interactive "P") + (save-excursion + (let (beg end) + (if (cperl-mark-active) + (setq beg (min (mark) (point)) + end (max (mark) (point))) + (setq beg (point-min) + end (point-max))) + (cperl-map-pods-heres (function + (lambda (s e p) + (if do-heres + (setq e (save-excursion + (goto-char e) + (forward-line -1) + (point)))) + (ispell-region s e) + t)) + (if do-heres 'here-doc-group 'in-pod) + beg end)))) + +(defun cperl-map-pods-heres (func &optional prop s end) + "Executes 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)) + (or prop (setq prop 'in-pod)) + (or s (setq s (point-min))) + (or end (setq end (point-max))) + (cperl-update-syntaxification end end) + (save-excursion + (goto-char (setq pos s)) + (while (and cont (< pos end)) + (setq has-prop (get-text-property pos prop)) + (setq posend (next-single-property-change pos prop nil end)) + (and has-prop + (setq cont (funcall func pos posend prop))) + (setq pos posend))))) + +;;; Based on code by Masatake YAMATO: +(defun cperl-get-here-doc-region (&optional pos pod) + "Return HERE document region around the point. +Return nil if the point is not in a HERE document region. If POD is non-nil, +will return a POD section if point is in a POD section." + (or pos (setq pos (point))) + (cperl-update-syntaxification pos pos) + (if (or (eq 'here-doc (get-text-property pos 'syntax-type)) + (and pod + (eq 'pod (get-text-property pos 'syntax-type)))) + (let ((b (cperl-beginning-of-property pos 'syntax-type)) + (e (next-single-property-change pos 'syntax-type))) + (cons b (or e (point-max)))))) + +(defun cperl-narrow-to-here-doc (&optional pos) + "Narrows editing region to the HERE-DOC at POS. +POS defaults to the point." + (interactive "d") + (or pos (setq pos (point))) + (let ((p (cperl-get-here-doc-region pos))) + (or p (error "Not inside a HERE document")) + (narrow-to-region (car p) (cdr p)) + (message + "When you are finished with narrow editing, type C-x n w"))) + +(defun cperl-select-this-pod-or-here-doc (&optional pos) + "Select the HERE-DOC (or POD section) at POS. +POS defaults to the point." + (interactive "d") + (let ((p (cperl-get-here-doc-region pos t))) + (if p + (progn + (goto-char (car p)) + (push-mark (cdr p) nil t)) ; Message, activate in transient-mode + (message "I do not think POS is in POD or a HERE-doc...")))) + +(defun cperl-facemenu-add-face-function (face end) + "A callback to process user-initiated font-change requests. +Translates `bold', `italic', and `bold-italic' requests to insertion of +corresponding POD directives, and `underline' to C<> POD directive. + +Such requests are usually bound to M-o LETTER." + (or (get-text-property (point) 'in-pod) + (error "Faces can only be set within POD")) + (setq facemenu-end-add-face (if (eq face 'bold-italic) ">>" ">")) + (cdr (or (assq face '((bold . "B<") + (italic . "I<") + (bold-italic . "B<I<") + (underline . "C<"))) + (error "Face %s not configured for cperl-mode" + face)))) + +(defun cperl-time-fontification (&optional l step lim) + "Times how long it takes to do incremental fontification in a region. +L is the line to start at, STEP is the number of lines to skip when +doing next incremental fontification, LIM is the maximal number of +incremental fontification to perform. Messages are accumulated in +*Messages* buffer. + +May be used for pinpointing which construct slows down buffer fontification: +start with default arguments, then refine the slowdown regions." + (interactive "nLine to start at: \nnStep to do incremental fontification: ") + (or l (setq l 1)) + (or step (setq step 500)) + (or lim (setq lim 40)) + (let* ((timems (function (lambda () + (let ((tt (current-time))) + (+ (* 1000 (nth 1 tt)) (/ (nth 2 tt) 1000)))))) + (tt (funcall timems)) (c 0) delta tot) + (goto-line l) + (cperl-mode) + (setq tot (- (- tt (setq tt (funcall timems))))) + (message "cperl-mode at %s: %s" l tot) + (while (and (< c lim) (not (eobp))) + (forward-line step) + (setq l (+ l step)) + (setq c (1+ c)) + (cperl-update-syntaxification (point) (point)) + (setq delta (- (- tt (setq tt (funcall timems)))) tot (+ tot delta)) + (message "to %s:%6s,%7s" l delta tot)) + tot)) + +(defun cperl-emulate-lazy-lock (&optional window-size) + "Emulate `lazy-lock' without `condition-case', so `debug-on-error' works. +Start fontifying the buffer from the start (or end) using the given +WINDOW-SIZE (units is lines). Negative WINDOW-SIZE starts at end, and +goes backwards; default is -50. This function is not CPerl-specific; it +may be used to debug problems with delayed incremental fontification." + (interactive + "nSize of window for incremental fontification, negative goes backwards: ") + (or window-size (setq window-size -50)) + (let ((pos (if (> window-size 0) + (point-min) + (point-max))) + p) + (goto-char pos) + (normal-mode) + ;; Why needed??? With older font-locks??? + (set (make-local-variable 'font-lock-cache-position) (make-marker)) + (while (if (> window-size 0) + (< pos (point-max)) + (> pos (point-min))) + (setq p (progn + (forward-line window-size) + (point))) + (font-lock-fontify-region (min p pos) (max p pos)) + (setq pos p)))) + + (defun cperl-lazy-install ()) ; Avoid a warning (defun cperl-lazy-unstall ()) ; Avoid a warning @@ -7174,7 +8877,7 @@ We suppose that the regexp is scanned already." "Switches on Auto-Help on Perl constructs (put in the message area). Delay of auto-help controlled by `cperl-lazy-help-time'." (interactive) - (make-variable-buffer-local 'cperl-help-shown) + (make-local-variable 'cperl-help-shown) (if (and (cperl-val 'cperl-lazy-help-time) (not cperl-lazy-installed)) (progn @@ -7207,48 +8910,109 @@ Delay of auto-help controlled by `cperl-lazy-help-time'." ;;; Plug for wrong font-lock: (defun cperl-font-lock-unfontify-region-function (beg end) - ;; Simplified now that font-lock-unfontify-region uses save-buffer-state. - (let (before-change-functions after-change-functions) - (remove-text-properties beg end '(face nil)))) + (let* ((modified (buffer-modified-p)) (buffer-undo-list t) + (inhibit-read-only t) (inhibit-point-motion-hooks t) + before-change-functions after-change-functions + deactivate-mark buffer-file-name buffer-file-truename) + (remove-text-properties beg end '(face nil)) + (if (and (not modified) (buffer-modified-p)) + (set-buffer-modified-p nil)))) + +(defun cperl-font-lock-fontify-region-function (beg end loudly) + "Extends the region to safe positions, then calls 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'." + (save-excursion + (goto-char beg) + (while (and beg + (progn + (beginning-of-line) + (eq (get-text-property (setq beg (point)) 'syntax-type) + 'multiline))) + (if (setq beg (cperl-beginning-of-property beg 'syntax-type)) + (goto-char beg))) + (setq beg (point)) + (goto-char end) + (while (and end + (progn + (or (bolp) (condition-case nil + (forward-line 1) + (error nil))) + (eq (get-text-property (setq end (point)) 'syntax-type) + 'multiline))) + (setq end (next-single-property-change end 'syntax-type nil (point-max))) + (goto-char end)) + (setq end (point))) + (font-lock-default-fontify-region beg end loudly)) (defvar cperl-d-l nil) (defun cperl-fontify-syntaxically (end) ;; Some vars for debugging only ;; (message "Syntaxifying...") - (let ((dbg (point)) (iend end) + (let ((dbg (point)) (iend end) (idone cperl-syntax-done-to) (istate (car cperl-syntax-state)) - start) - (and cperl-syntaxify-unwind - (setq end (cperl-unwind-to-safe t end))) - (setq start (point)) + start from-start edebug-backtrace-buffer) + (if (eq cperl-syntaxify-by-font-lock 'backtrace) + (progn + (require 'edebug) + (let ((f 'edebug-backtrace)) + (funcall f)))) ; Avoid compile-time warning (or cperl-syntax-done-to - (setq cperl-syntax-done-to (point-min))) - (if (or (not (boundp 'font-lock-hot-pass)) - (eval 'font-lock-hot-pass) - t) ; Not debugged otherwise - ;; Need to forget what is after `start' - (setq start (min cperl-syntax-done-to start)) - ;; Fontification without a change - (setq start (max cperl-syntax-done-to start))) + (setq cperl-syntax-done-to (point-min) + from-start t)) + (setq start (if (and cperl-hook-after-change + (not from-start)) + cperl-syntax-done-to ; Fontify without change; ignore start + ;; Need to forget what is after `start' + (min cperl-syntax-done-to (point)))) + (goto-char start) + (beginning-of-line) + (setq start (point)) + (and cperl-syntaxify-unwind + (setq end (cperl-unwind-to-safe t end) + start (point))) (and (> end start) (setq cperl-syntax-done-to start) ; In case what follows fails (cperl-find-pods-heres start end t nil t)) - (if (eq cperl-syntaxify-by-font-lock 'message) - (message "Syntaxified %s..%s from %s to %s(%s), state %s-->%s" - dbg iend - start end cperl-syntax-done-to + (if (memq cperl-syntaxify-by-font-lock '(backtrace message)) + (message "Syxify req=%s..%s actual=%s..%s done-to: %s=>%s statepos: %s=>%s" + dbg iend start end idone cperl-syntax-done-to istate (car cperl-syntax-state))) ; For debugging nil)) ; Do not iterate (defun cperl-fontify-update (end) - (let ((pos (point)) prop posend) + (let ((pos (point-min)) prop posend) + (setq end (point-max)) (while (< pos end) - (setq prop (get-text-property pos 'cperl-postpone)) - (setq posend (next-single-property-change pos 'cperl-postpone nil end)) + (setq prop (get-text-property pos 'cperl-postpone) + posend (next-single-property-change pos 'cperl-postpone nil end)) (and prop (put-text-property pos posend (car prop) (cdr prop))) (setq pos posend))) nil) ; Do not iterate +(defun cperl-fontify-update-bad (end) + ;; Since fontification happens with different region than syntaxification, + ;; do to the end of buffer, not to END;;; likewise, start earlier if needed + (let* ((pos (point)) (prop (get-text-property pos 'cperl-postpone)) posend) + (if prop + (setq pos (or (cperl-beginning-of-property + (cperl-1+ pos) 'cperl-postpone) + (point-min)))) + (while (< pos end) + (setq posend (next-single-property-change pos 'cperl-postpone)) + (and prop (put-text-property pos posend (car prop) (cdr prop))) + (setq pos posend) + (setq prop (get-text-property pos 'cperl-postpone)))) + nil) ; Do not iterate + +;; Called when any modification is made to buffer text. +(defun cperl-after-change-function (beg end old-len) + ;; We should have been informed about changes by `font-lock'. Since it + ;; does not inform as which calls are defered, do it ourselves + (if cperl-syntax-done-to + (setq cperl-syntax-done-to (min cperl-syntax-done-to beg)))) + (defun cperl-update-syntaxification (from to) (if (and cperl-use-syntax-table-text-property cperl-syntaxify-by-font-lock @@ -7260,7 +9024,7 @@ Delay of auto-help controlled by `cperl-lazy-help-time'." (cperl-fontify-syntaxically to))))) (defvar cperl-version - (let ((v "Revision: 5.0")) + (let ((v "Revision: 5.22")) (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.") |