From: Rafael Garcia-Suarez Date: Fri, 2 Nov 2007 09:42:41 +0000 (+0000) Subject: Upgrade to cperl-mode 5.23 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=8f95267c958b61f3eebefee65cef169136d932b0;p=p5sagit%2Fp5-mst-13.2.git Upgrade to cperl-mode 5.23 p4raw-id: //depot/perl@32210 --- diff --git a/emacs/cperl-mode.el b/emacs/cperl-mode.el index b958122..e795286 100644 --- a/emacs/cperl-mode.el +++ b/emacs/cperl-mode.el @@ -1,10 +1,11 @@ ;;; cperl-mode.el --- Perl code editing commands for Emacs -;; Copyright (C) 1985, 86, 87, 91, 92, 93, 94, 95, 96, 97, 98, 99, 2000, 2003 +;; Copyright (C) 1985, 86, 87, 91, 92, 93, 94, 95, 96, 97, 98, 99, +;; 2000, 2003, 2005, 2006 ;; Free Software Foundation, Inc. ;; Author: Ilya Zakharevich and Bob Olson -;; Maintainer: Ilya Zakharevich +;; Maintainer: Ilya Zakharevich ;; Keywords: languages, Perl ;; This file is part of GNU Emacs. @@ -36,15 +37,15 @@ ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301, USA. +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. -;;; Corrections made by Ilya Zakharevich cperl@ilyaz.org +;;; Corrections made by Ilya Zakharevich ilyaz@cpan.org ;;; XEmacs changes by Peter Arius arius@informatik.uni-erlangen.de ;;; Commentary: -;; $Id: cperl-mode.el,v 5.0 2003/02/17 01:33:20 vera Exp vera $ +;; $Id: cperl-mode.el,v 5.23 2007/02/15 11:34:23 vera Exp vera $ ;;; If your Emacs does not default to `cperl-mode' on Perl files: ;;; To use this mode put the following into @@ -239,7 +240,7 @@ ;;; Fontification updated to 19.30 style. ;;; The change 19.29->30 did not add all the required functionality, ;;; but broke "font-lock-extra.el". Get "choose-color.el" from -;;; ftp://ftp.math.ohio-state.edu/pub/users/ilya/emacs +;;; http://ilyaz.org/software/emacs ;;;; After 1.16: ;;; else # comment @@ -1134,12 +1135,375 @@ ;;; Now works for else/continue/sub blocks ;;; (`cperl-short-docs'): Minor edits; make messages fit 80-column screen -;;;; After 4.37: -;;; `cperl-add-tags-recurse-noxs-fullpath' -;;; added (for -batch mode); +;;;; After 5.0: +;;; `cperl-add-tags-recurse-noxs-fullpath': new function (for -batch mode) + +;;;; After 5.1: +;;;;;; Major edit. Summary of most visible changes: + +;;;;;; a) Multiple < +;;; Copyright message updated. +;;; `cperl-init-faces': Work around a bug in `font-lock'. May slow +;;; facification down a bit. +;;; Misprint for my|our|local for old `font-lock' +;;; "our" was not fontified same as "my|local" +;;; Highlight variables after "my" etc even in +;;; a middle of an expression +;;; Do not facify multiple variables after my etc +;;; unless parentheses are present + +;;; After 5.5, 5.6 +;;; `cperl-fontify-syntaxically': after-change hook could reset +;;; `cperl-syntax-done-to' to a middle of line; unwind to BOL. + +;;; After 5.7: +;;; `cperl-init-faces': Allow highlighting of local ($/) +;;; `cperl-problems-old-emaxen': New variable (for the purpose of DOCSTRING). +;;; `cperl-problems': Remove fixed problems. +;;; `cperl-find-pods-heres': Recognize #-comments in m##x too +;;; Recognize charclasses (unless delimiter is \). +;;; `cperl-fontify-syntaxically': Unwinding to safe was done in wrong order +;;; `cperl-regexp-scan': Update docs +;;; `cperl-beautify-regexp-piece': use information got from regexp scan + +;;; After 5.8: +;;; Major user visible changes: +;;; Recognition and fontification of character classes in RExen. +;;; Variable indentation of RExen according to groups +;;; +;;; `cperl-find-pods-heres': Recognize POSIX classes in REx charclasses +;;; Fontify REx charclasses in variable-name face +;;; Fontify POSIX charclasses in "type" face +;;; Fontify unmatched "]" in function-name face +;;; Mark first-char of HERE-doc as `front-sticky' +;;; Reset `front-sticky' property when needed +;;; `cperl-calculate-indent': Indents //x -RExen accordning to parens level +;;; `cperl-to-comment-or-eol': Recognize ends of `syntax-type' constructs +;;; `cperl-backward-to-noncomment': Recognize stringy `syntax-type' constructs +;;; Support `narrow'ed buffers. +;;; `cperl-praise': Remove a reservation +;;; `cperl-make-indent': New function +;;; `cperl-indent-for-comment': Use `cperl-make-indent' +;;; `cperl-indent-line': Likewise +;;; `cperl-lineup': Likewise +;;; `cperl-beautify-regexp-piece': Likewise +;;; `cperl-contract-level': Likewise +;;; `cperl-toggle-set-debug-unwind': New function +;;; New menu entry for this +;;; `fill-paragraph-function': Use when `boundp' +;;; `cperl-calculate-indent': Take into account groups when indenting RExen +;;; `cperl-to-comment-or-eol': Recognize # which end a string +;;; `cperl-modify-syntax-type': Make only syntax-table property non-sticky +;;; `cperl-fill-paragraph': Return t: needed for `fill-paragraph-function' +;;; `cperl-fontify-syntaxically': More clear debugging message +;;; `cperl-pod2man-build-command': XEmacs portability: check `Man-filter-list' +;;; `cperl-init-faces': More complicated highlight even on XEmacs (new) +;;; Merge cosmetic changes from XEmacs + +;;; After 5.9: +;;; `cperl-1+': Moved to before the first use +;;; `cperl-1-': Likewise + +;;; After 5.10: + +;;; This code may lock Emacs hard!!! Use on your own risk! + +;;; `cperl-font-locking': New internal variable +;;; `cperl-beginning-of-property': New function +;;; `cperl-calculate-indent': Use `cperl-beginning-of-property' +;;; instead of `previous-single-property-change' +;;; `cperl-unwind-to-safe': Likewise +;;; `cperl-after-expr-p': Likewise +;;; `cperl-get-here-doc-region': Likewise +;;; `cperl-font-lock-fontify-region-function': Likewise +;;; `cperl-to-comment-or-eol': Do not call `cperl-update-syntaxification' +;;; recursively +;;; Bound `next-single-property-change' +;;; via `point-max' +;;; `cperl-unwind-to-safe': Bound likewise +;;; `cperl-font-lock-fontify-region-function': Likewise +;;; `cperl-find-pods-heres': Mark as recursive for `cperl-to-comment-or-eol' +;;; Initialization of +;;; `cperl-font-lock-multiline-start' could be missed if the "main" +;;; fontification did not run due to the keyword being already fontified. +;;; `cperl-pod-spell': Return t from do-one-chunk function +;;; `cperl-map-pods-heres': Stop when the worker returns nil +;;; Call `cperl-update-syntaxification' +;;; `cperl-get-here-doc-region': Call `cperl-update-syntaxification' +;;; `cperl-get-here-doc-delim': Remove unused function + +;;; After 5.11: + +;;; The possible lockup of Emacs (introduced in 5.10) fixed + +;;; `cperl-unwind-to-safe': `cperl-beginning-of-property' won't return nil +;;; `cperl-syntaxify-for-menu': New customization variable +;;; `cperl-select-this-pod-or-here-doc': New function +;;; `cperl-get-here-doc-region': Extra argument +;;; Do not adjust pos by 1 + +;;; New menu entries (Perl/Tools): selection of current POD or HERE-DOC section +;;; (Debugging CPerl:) backtrace on fontification + +;;; After 5.12: +;;; `cperl-cached-syntax-table': use `car-safe' +;;; `cperl-forward-re': Remove spurious argument SET-ST +;;; Add documentation +;;; `cperl-forward-group-in-re': New function +;;; `cperl-find-pods-heres': Find and highlight (?{}) blocks in RExen +;;; (XXXX Temporary (?) hack is to syntax-mark them as comment) + +;;; After 5.13: +;;; `cperl-string-syntax-table': Make { and } not-grouping +;;; (Sometimes they ARE grouping in RExen, but matching them would only +;;; confuse in many situations when they are not) +;;; `beginning-of-buffer': Replaced two occurences with goto-char... +;;; `cperl-calculate-indent': `char-after' could be nil... +;;; `cperl-find-pods-heres': REx can start after "[" too +;;; Hightlight (??{}) in RExen too +;;; `cperl-maybe-white-and-comment-rex': New constant +;;; `cperl-white-and-comment-rex': Likewise +;;; XXXX Not very efficient, but hard to make +;;; better while keeping 1 group + +;;; After 5.13: +;;; `cperl-find-pods-heres': $foo << identifier() is not a HERE-DOC +;;; Likewise for 1 << identifier + +;;; After 5.14: +;;; `cperl-find-pods-heres': Different logic for $foo .= < (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 @@ -2191,7 +2656,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 |)]) @@ -2230,16 +2704,17 @@ 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) (substitute-key-definition - 'fill-paragraph 'cperl-fill-paragraph - cperl-mode-map global-map) - (substitute-key-definition 'indent-region 'cperl-indent-region cperl-mode-map global-map) (substitute-key-definition @@ -2275,7 +2750,18 @@ the faces: please specify bold, italic, underline, shadow and box.) ["Contract a group" cperl-contract-level cperl-use-syntax-table-text-property] ["Contract groups" cperl-contract-levels - cperl-use-syntax-table-text-property]) + cperl-use-syntax-table-text-property] + "----" + ["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)] @@ -2292,12 +2778,50 @@ the faces: please specify bold, italic, underline, shadow and box.) "----" ("Tools" ["Imenu" imenu (fboundp 'imenu)] - ["Insert spaces if needed" cperl-find-bad-style t] + ["Imenu on Perl Info" cperl-imenu-on-info (featurep 'imenu)] + "----" + ["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))] + "----" + ["CPerl pretty print (exprmntl)" cperl-ps-print + (fboundp 'ps-extend-face-list)] + "----" + ["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] + "----" ["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" ;;; ["Create tags for current file" cperl-etags t] ;;; ["Add tags for current file" (cperl-etags t) t] @@ -2319,7 +2843,7 @@ the faces: please specify bold, italic, underline, shadow and box.) ["Add tags for Perl files in (sub)directories" (cperl-write-tags nil nil t t) t])) ("Perl docs" - ["Define word at point" imenu-go-find-at-position + ["Define word at point" imenu-go-find-at-position (fboundp 'imenu-go-find-at-position)] ["Help on function" cperl-info-on-command t] ["Help on function at point" cperl-info-on-current-command t] @@ -2327,7 +2851,7 @@ the faces: please specify bold, italic, underline, shadow and box.) ["Perldoc" cperl-perldoc t] ["Perldoc on word at point" cperl-perldoc-at-point t] ["View manpage of POD in this file" cperl-build-manpage t] - ["Auto-help on" cperl-lazy-install + ["Auto-help on" cperl-lazy-install (and (fboundp 'run-with-idle-timer) (not cperl-lazy-installed))] ["Auto-help off" cperl-lazy-unstall @@ -2339,16 +2863,16 @@ the faces: please specify bold, italic, underline, shadow and box.) ["Electric keywords" cperl-toggle-abbrev t] ["Fix whitespace on indent" cperl-toggle-construct-fix t] ["Auto-help on Perl constructs" cperl-toggle-autohelp t] - ["Auto fill" auto-fill-mode t]) + ["Auto fill" auto-fill-mode t]) ("Indent styles..." ["CPerl" (cperl-set-style "CPerl") t] ["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] @@ -2358,8 +2882,8 @@ the faces: please specify bold, italic, underline, shadow and box.) ["Praise" (describe-variable 'cperl-praise) t] ["Faces" (describe-variable 'cperl-tips-faces) t] ["CPerl mode" (describe-function 'cperl-mode) t] - ["CPerl version" - (message "The version of master-file for this CPerl is %s" + ["CPerl version" + (message "The version of master-file for this CPerl is %s" cperl-version) t])))) (error nil)) @@ -2368,12 +2892,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]*\\)?" + "^\\(" ; 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\\([12]\\)[ \t]+\\([^\n]+\\)$" + "=head\\([1-4]\\)[ \t]+" ; 16=level + "\\([^\n]+\\)$" ; 17=text "\\)")) (defvar cperl-outline-regexp @@ -2385,6 +2970,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)) @@ -2409,6 +3000,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 ) @@ -2432,6 +3025,10 @@ The expansion is entirely correct because it uses the C preprocessor." (funcall f 'cperl-font-lock-keywords-2 'perl-font-lock-keywords-2))) (defvar cperl-use-major-mode 'perl-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 () @@ -2577,16 +3174,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 @@ -2640,8 +3245,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) @@ -2653,6 +3262,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) + (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) @@ -2666,9 +3279,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]+\\([^ \t\n{(;]+\\)\\([ \t]*([^()]*)[ \t]*\\)?[ \t]*") +;;; "[ \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) @@ -2679,22 +3305,42 @@ or as help on variables `cperl-tips', `cperl-problems', (function cperl-imenu--create-perl-index)) (make-local-variable 'imenu-sort-function) (setq imenu-sort-function nil) + (make-local-variable 'vc-rcs-header) + (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 cperl-vc-header-alist) ; Avoid warning + (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))) + (let ((f 'compilation-build-compilation-error-regexp-alist)) + (funcall f))) + ((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") - '(perl-font-lock-keywords-2)) + '(perl-font-lock-keywords-2 nil nil ((?_ . "w")))) ((string< emacs-version "19.33") ; Which one to use? '((perl-font-lock-keywords perl-font-lock-keywords-1 - perl-font-lock-keywords-2))) + perl-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))))) + 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) @@ -2704,10 +3350,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 ;; Another bug: unless font-lock-syntactic-keywords, font-lock ;; ignores syntax-table text-property. (t) is a hack ;; to make font-lock think that font-lock-syntactic-keywords @@ -2717,6 +3365,16 @@ or as help on variables `cperl-tips', `cperl-problems', (if cperl-syntaxify-by-font-lock '(t (cperl-fontify-syntaxically)) '(t))))) + (if (boundp 'font-lock-multiline) ; Newer font-lock; use its facilities + (progn + (setq cperl-font-lock-multiline t) ; Not localized... + (set (make-local-variable 'font-lock-multiline) t)) + (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) @@ -2733,12 +3391,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 RMS Emacs. (run-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 @@ -2787,31 +3451,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. @@ -2837,7 +3507,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)))))) @@ -3068,7 +3738,7 @@ to nil." (not (eq (get-text-property (point) 'syntax-type) 'pod)))))) - (save-excursion (forward-sexp -1) + (save-excursion (forward-sexp -1) (not (memq (following-char) (append "$@%&*" nil)))) (progn (and (eq (preceding-char) ?y) @@ -3137,15 +3807,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))) @@ -3421,7 +4086,7 @@ key. Will untabivy if `cperl-electric-backspace-untabify' is non-nil." (backward-delete-char-untabify arg) (delete-backward-char arg))))) -(defun cperl-inside-parens-p () +(defun cperl-inside-parens-p () ;; NOT USED???? (condition-case () (save-excursion (save-restriction @@ -3485,7 +4150,8 @@ Return the amount the indentation changed by." (t (skip-chars-forward " \t") (if (listp indent) (setq indent (car indent))) - (cond ((looking-at "[A-Za-z_][A-Za-z_0-9]*:[^:]") + (cond ((and (looking-at "[A-Za-z_][A-Za-z_0-9]*:[^:]") + (not (looking-at "[smy]:\\|tr:"))) (and (> indent 0) (setq indent (max cperl-min-label-indent (+ indent cperl-label-offset))))) @@ -3501,8 +4167,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)) @@ -3549,63 +4216,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) @@ -3613,437 +4272,432 @@ 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 4 state) + [comment]) + ((nth 3 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)) + (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") + ;; s: foo : bar :x is NOT label + (and (looking-at "#\\|\\([a-zA-Z0-9_$]+\\):[^:]\\|=[a-zA-Z]") + (not (looking-at "[sym]:\\|tr:")))) + ;; 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. + 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'. +(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. -Not finished, not used." +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* ((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))) + (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: " 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)) ; sibling-beg + (if (> (elt i 2) (point)) ; colon-line-end; have label before point + (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: " i)))) + (t + (error (format "Got strange value of indent: " i))))))) (defun cperl-calculate-indent-within-comment () "Return the indentation amount for line, assuming that @@ -4063,14 +4717,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 @@ -4099,20 +4761,14 @@ Returns true if comment is found." (goto-char (1- cpoint))))) (setq stop-in t) ; Finish (forward-char -1)) - (setq stop-in t))) ; Finish + (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 @@ -4147,35 +4803,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 $$ @@ -4222,7 +4896,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) @@ -4247,6 +4921,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) @@ -4272,13 +4973,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 @@ -4295,32 +5007,119 @@ 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 (and + (< (point) e) + (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 @@ -4331,33 +5130,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-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! @@ -4373,36 +5201,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 "\\|" - ;; 1+6+2+1+1=11 extra () before this: - "\\[ \t]*\\([a-zA-Z_:'0-9]+[ \t]*\\)?\\(([^()]*)\\)" + ;; 1+6+2+1+1=11 extra () before this + "\\" ; 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...): "\\(\\ %s" min max) (and cperl-pod-here-fontify ;; We had evals here, do not know why... (setq face cperl-pod-face @@ -4410,16 +5246,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)) @@ -4427,11 +5269,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)))) @@ -4457,11 +5326,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) @@ -4504,7 +5377,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 <"))) + (error t))))))) + (error nil))) ; func(< overshoot (point))) + (goto-char overshoot) + (setq overshoot e1)) (if (> e1 max) (setq tmpend tb)))) ;; format @@ -4631,7 +5543,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\\)\\>" @@ -4640,10 +5552,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) @@ -4657,7 +5569,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))) @@ -4675,41 +5587,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 @@ -4719,13 +5630,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")) @@ -4757,11 +5664,13 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', ((and (eq (following-char) ?:) (eq b1 ?\{) ; Check for $ { s::bar } (looking-at "::[a-zA-Z0-9_:]*[ \t\n\f]*}") - (progn + (progn (goto-char (1- go)) (skip-chars-backward " \t\n\f") (memq (preceding-char) (append "$@%&*" nil)))) + (setq bb t)) + ((eobp) (setq bb t))))) (if bb (goto-char i) @@ -4774,15 +5683,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 [] @@ -4794,13 +5704,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 @@ -4817,9 +5732,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) ?\>)) @@ -4827,6 +5744,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) @@ -4842,7 +5760,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-face))) + e1 (point) 'face my-cperl-REx-modifiers-face))) ;; Check whether it is m// which means "previous match" ;; and highlight differently (setq is-REx @@ -4860,7 +5778,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 @@ -4869,135 +5787,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)(?" "\\)?" + "\\[[^][]*\\]" + "\\|" + "{[^{}]*}" + "\\)*" + ;; 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 + (if (and i2 e1 b1 (> e1 b1)) + (progn ; No errors finding the second part... (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): + ;;"\\\\(" ;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: ;; "\\(\\ 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) @@ -5008,7 +6208,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")))) @@ -5016,48 +6219,93 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', (not modified) (set-buffer-modified-p nil)) (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-unwind-to-safe nil) + (setq pr (get-text-property (point) 'syntax-type)))) + (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))))))) + (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)))) @@ -5079,12 +6327,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 @@ -5096,7 +6344,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)))) @@ -5112,6 +6360,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)) @@ -5155,18 +6441,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 @@ -5195,16 +6514,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)) - (insert (make-string cperl-indent-region-fix-constructs ?\ )) - (beginning-of-line))) + (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 ?\ )) + (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\\)\\>") @@ -5241,19 +6570,19 @@ Returns some position at the last line." (insert (make-string cperl-indent-region-fix-constructs ?\ )) (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") @@ -5263,13 +6592,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 @@ -5292,7 +6621,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 ?\ )))) + (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 @@ -5452,7 +6791,7 @@ indentation and initial hashes. Behaves usually outside of comment." (interactive "P") (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) @@ -5484,7 +6823,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. @@ -5508,8 +6847,13 @@ indentation and initial hashes. Behaves usually outside of comment." (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))))) + (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#]*$")) @@ -5525,7 +6869,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 @@ -5575,8 +6920,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)) (if noninteractive (message "Scanning Perl for index") @@ -5589,72 +6934,81 @@ indentation and initial hashes. Behaves usually outside of comment." nil t) (or noninteractive (imenu-progress-message prev-pos)) + ;; 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))))) @@ -5720,19 +7074,16 @@ 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.") @@ -5746,19 +7097,23 @@ indentation and initial hashes. Behaves usually outside of comment." (defun cperl-windowed-init () "Initialization under windowed version." - (if (or (featurep 'ps-print) cperl-faces-init) - ;; Need to init anyway: - (or cperl-faces-init (cperl-init-faces)) - (add-hook 'font-lock-mode-hook - (function - (lambda () - (if (memq major-mode '(perl-mode cperl-mode)) - (progn - (or cperl-faces-init (cperl-init-faces))))))) - (if (fboundp 'eval-after-load) - (eval-after-load - "ps-print" - '(or cperl-faces-init (cperl-init-faces)))))) + (cond ((featurep 'ps-print) + (or cperl-faces-init + (progn + (and (boundp 'font-lock-multiline) + (setq cperl-font-lock-multiline t)) + (cperl-init-faces)))) + ((not cperl-faces-init) + (add-hook 'font-lock-mode-hook + (function + (lambda () + (if (memq major-mode '(perl-mode cperl-mode)) + (progn + (or cperl-faces-init (cperl-init-faces))))))) + (if (fboundp 'eval-after-load) + (eval-after-load + "ps-print" + '(or cperl-faces-init (cperl-init-faces))))))) (defun cperl-load-font-lock-keywords () (or cperl-faces-init (cperl-init-faces)) @@ -5777,7 +7132,7 @@ indentation and initial hashes. Behaves usually outside of comment." (defvar perl-font-lock-keywords nil "Additional expressions to highlight in Perl mode. Default set.") (defvar perl-font-lock-keywords-2 nil - "Additional expressions to highlight in Perl mode. Maximal set") + "Additional expressions to highlight in Perl mode. Maximal set.") (defvar font-lock-background-mode) (defvar font-lock-display-type) @@ -5785,9 +7140,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 @@ -5810,7 +7168,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;():,\|&]" @@ -5894,7 +7252,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" @@ -5916,8 +7274,31 @@ indentation and initial hashes. Behaves usually outside of comment." ;; "\\|") '("-[rwxoRWXOezsfdlpSbctugkTBMAC]\\>\\([ \t]+_\\>\\)?" 0 font-lock-function-name-face keep) ; Not very good, triggers at "[a-z]" - '("\\ 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))) '("\\= 19.12 ;; ((fboundp 'valid-color-name-p) 'valid-color-name-p) @@ -6089,6 +7533,8 @@ indentation and initial hashes. Behaves usually outside of comment." "Face for data types") (cperl-force-face cperl-nonoverridable-face "Face for data types from another group") + (cperl-force-face font-lock-warning-face + "Face for things which should stand out") (cperl-force-face font-lock-comment-face "Face for comments") (cperl-force-face font-lock-function-name-face @@ -6317,81 +7763,213 @@ 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)))) + (let ((list (mapcar (function (lambda (elt) (list (car elt)))) cperl-style-alist))) (list (completing-read "Enter style: " list nil 'insist)))) (or cperl-old-style @@ -6487,7 +8065,7 @@ Customized by setting variables `cperl-shrink-wrap-info-frame', iniwin (selected-window) fr1 (window-frame iniwin)) (set-buffer buf) - (beginning-of-buffer) + (goto-char (point-min)) (or isvar (progn (re-search-forward "^-X[ \t\n]") (forward-line -1))) @@ -6560,6 +8138,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 @@ -6599,7 +8179,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) @@ -6637,22 +8217,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)) ?\ )) + (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!) + "/\\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*") @@ -6852,7 +8458,7 @@ Delay of auto-help controlled by `cperl-lazy-help-time'." (string-match "^sub[ \t]+\\([_a-zA-Z]+\\)[^:_a-zA-Z]" (elt elt 3))) ;; Need to insert the name without package as well - (setq lst (cons (cons (substring (elt elt 3) + (setq lst (cons (cons (substring (elt elt 3) (match-beginning 1) (match-end 1)) (cdr elt)) @@ -6872,16 +8478,17 @@ Delay of auto-help controlled by `cperl-lazy-help-time'." ret)))) (defun cperl-add-tags-recurse-noxs () - "Add to TAGS data for Perl (skipping XSUBs) in the current directory -and kids. Use as + "Add to TAGS data for \"pure\" Perl files in the current directory and kids. +Use as emacs -batch -q -no-site-file -l emacs/cperl-mode.el \ -f cperl-add-tags-recurse-noxs " (cperl-write-tags nil nil t t nil t)) (defun cperl-add-tags-recurse-noxs-fullpath () - "Add to TAGS data for Perl (skipping XSUBs) in the current directory -and kids, using fullpath, so TAGS is relocatable. Use as + "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 " @@ -6932,7 +8539,7 @@ Use as (setq cperl-unreadable-ok t tm nil) ; Return empty list (error "Aborting: unreadable directory %s" file))))))) - (mapcar (function + (mapcar (function (lambda (file) (cond ((string-match cperl-noscan-files-regexp file) @@ -7056,7 +8663,7 @@ One may build such TAGS files from CPerl mode menu." (cperl-tags-hier-fill)) (or tags-table-list (call-interactively 'visit-tags-table)) - (mapcar + (mapcar (function (lambda (tagsfile) (message "Updating list of classes... %s" tagsfile) @@ -7078,7 +8685,7 @@ One may build such TAGS files from CPerl mode menu." (error "No items found")) (setq update ;;; (imenu-choose-buffer-index "Packages: " (nth 2 cperl-hierarchy)) - (if (if (boundp 'display-popup-menus-p) + (if (if (fboundp 'display-popup-menus-p) (let ((f 'display-popup-menus-p)) (funcall f)) window-system) @@ -7106,12 +8713,12 @@ One may build such TAGS files from CPerl mode menu." l1 head tail cons1 cons2 ord writeto packs recurse root-packages root-functions ms many_ms same_name ps (move-deeper - (function + (function (lambda (elt) (cond ((and (string-match regexp (car elt)) (or (eq ord 1) (match-end 2))) (setq head (substring (car elt) 0 (match-end 1)) - tail (if (match-end 2) (substring (car elt) + tail (if (match-end 2) (substring (car elt) (match-end 2))) recurse t) (if (setq cons1 (assoc head writeto)) nil @@ -7138,7 +8745,7 @@ One may build such TAGS files from CPerl mode menu." (cdr to))) ;;Now clean up leaders with one child only (mapcar (function (lambda (elt) - (if (not (and (listp (cdr elt)) + (if (not (and (listp (cdr elt)) (eq (length elt) 2))) nil (setcar elt (car (nth 1 elt))) (setcdr elt (cdr (nth 1 elt)))))) @@ -7156,8 +8763,8 @@ One may build such TAGS files from CPerl mode menu." root-functions)) ;; Now add back packages removed from display (mapcar (function (lambda (elt) - (setcdr to (cons (cons (concat "package " (car elt)) - (cdr elt)) + (setcdr to (cons (cons (concat "package " (car elt)) + (cdr elt)) (cdr to))))) (if (default-value 'imenu-sort-function) (nreverse @@ -7210,17 +8817,17 @@ One may build such TAGS files from CPerl mode menu." (defvar cperl-bad-style-regexp (mapconcat 'identity '("[^-\n\t <>=+!.&|(*/'`\"#^][-=+<>!|&^]" ; char sign - "[-<>=+^&|]+[^- \t\n=+<>~]") ; sign+ char + "[-<>=+^&|]+[^- \t\n=+<>~]") ; sign+ char "\\|") "Finds places such that insertion of a whitespace may help a lot.") (defvar cperl-not-bad-style-regexp - (mapconcat + (mapconcat 'identity '("[^-\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+\\)?>" ; + "<\\$?\\sw+\\(\\.\\(\\sw\\|_\\)+\\)?>" ; "-[a-zA-Z][ \t]+[_$\"'`a-zA-Z]" ; -f file, -t STDIN "-[0-9]" ; -5 "\\+\\+" ; ++var @@ -7252,7 +8859,7 @@ Currently it is tuned to C and Perl syntax." (interactive) (let (found-bad (p (point))) (setq last-nonmenu-event 13) ; To disable popup - (beginning-of-buffer) + (goto-char (point-min)) (map-y-or-n-p "Insert space here? " (lambda (arg) (insert " ")) 'cperl-next-bad-style @@ -7585,8 +9192,8 @@ $~ The name of the current report format. \\ Creates reference to what follows, like \$var, or quotes non-\w in strings. \\0 Octal char, e.g. \\033. \\E Case modification terminator. See \\Q, \\L, and \\U. -\\L Lowercase until \\E . See also \l, lc. -\\U Upcase until \\E . See also \u, uc. +\\L Lowercase until \\E . See also \\l, lc. +\\U Upcase until \\E . See also \\u, uc. \\Q Quote metacharacters until \\E . See also quotemeta. \\a Alarm character (octal 007). \\b Backspace character (octal 010). @@ -7648,7 +9255,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) @@ -7784,7 +9391,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) @@ -7885,7 +9492,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) @@ -7914,7 +9521,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) @@ -7924,7 +9531,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 @@ -7950,6 +9557,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 "\\^?\\]") @@ -7963,12 +9580,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)) @@ -7976,7 +9589,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) @@ -8036,7 +9649,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) @@ -8059,10 +9672,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 @@ -8131,7 +9741,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) @@ -8140,10 +9750,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)))))) @@ -8182,96 +9789,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 "\\")) (error nil)) (error - "`%s' (EXPR) {BLOCK} with `else'/`elsif'" s0) - (goto-char (1- pos5)) - (cperl-backward-to-noncomment pos4) + "`%s' (EXPR) {BLOCK} with `else'/`elsif'" if-string) + (goto-char (1- post-B)) + (cperl-backward-to-noncomment pre-B) (if (eq (preceding-char) ?\;) (forward-char -1)) - (setq pos45 (point)) - (goto-char pos4) - (while (re-search-forward "\\<\\(for\\|foreach\\|if\\|unless\\|while\\|until\\)\\>\\|;" pos45 t) + (setq end-B-code (point)) + (goto-char pre-B) + (while (re-search-forward "\\<\\(for\\|foreach\\|if\\|unless\\|while\\|until\\)\\>\\|;" end-B-code t) (setq p (match-beginning 0) - s1 (buffer-substring p (match-end 0)) - state (parse-partial-sexp pos4 p)) + A (buffer-substring p (match-end 0)) + state (parse-partial-sexp pre-B p)) (or (nth 3 state) (nth 4 state) (nth 5 state) - (error "`%s' inside `%s' BLOCK" s1 s0)) + (error "`%s' inside `%s' BLOCK" A if-string)) (goto-char (match-end 0))) ;; Finally got it - (goto-char (1+ pos4)) + (goto-char (1+ pre-B)) (skip-chars-forward " \t\n") - (setq s2 (buffer-substring (point) pos45)) - (goto-char pos45) + (setq B (buffer-substring (point) end-B-code)) + (goto-char end-B-code) (or (looking-at ";?[ \t\n]*}") (progn (skip-chars-forward "; \t\n") - (setq s2 (concat s2 "\n" (buffer-substring (point) (1- pos5)))))) - (and (equal s2 "") - (setq s2 "1")) - (goto-char (1- pos3)) - (cperl-backward-to-noncomment pos2) + (setq B-comment + (buffer-substring (point) (1- post-B))))) + (and (equal B "") + (setq B "1")) + (goto-char (1- post-A)) + (cperl-backward-to-noncomment pre-A) (or (looking-at "[ \t\n]*)") - (goto-char (1- pos3))) + (goto-char (1- post-A))) (setq p (point)) - (goto-char (1+ pos2)) + (goto-char (1+ pre-A)) (skip-chars-forward " \t\n") - (setq s1 (buffer-substring (point) p)) - (delete-region pos4 pos5) - (delete-region pos2 pos3) - (goto-char pos1) - (insert s2 " ") + (setq A (buffer-substring (point) p)) + (delete-region pre-B post-B) + (delete-region pre-A post-A) + (goto-char pre-if) + (insert B " ") + (and B-comment (insert B-comment " ")) (just-one-space) (forward-word 1) - (setq pos1 (point)) - (insert " " s1 ";") + (setq pre-A (point)) + (insert " " A ";") (delete-horizontal-space) + (setq post-B (point)) + (if (looking-at "#") + (indent-for-comment)) + (goto-char post-B) (forward-char -1) (delete-horizontal-space) - (goto-char pos1) + (goto-char pre-A) (just-one-space) - (cperl-indent-line)) - (error "`%s' (EXPR) not with an {BLOCK}" s0))) - (error "`%s' not with an (EXPR)" s0))) - (error "Not at `if', `unless', `while', `until', `for' or `foreach'"))) + (goto-char pre-if) + (setq pre-A (set-marker (make-marker) pre-A)) + (while (<= (point) (marker-position pre-A)) + (cperl-indent-line) + (forward-line 1)) + (goto-char (marker-position pre-A)) + (if B-comment + (progn + (forward-line -1) + (indent-for-comment) + (goto-char (marker-position pre-A))))) + (error "`%s' (EXPR) not with an {BLOCK}" if-string))) + ;; (error "`%s' not with an (EXPR)" if-string) + (forward-sexp -1) + (cperl-invert-if-unless-modifiers))) + ;;(error "Not at `if', `unless', `while', `until', `for' or `foreach'") + (cperl-invert-if-unless-modifiers))) ;;; By Anthony Foiani ;;; Getting help on modules in C-h f ? ;;; 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 @@ -8303,6 +10011,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) @@ -8347,7 +10056,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)))) @@ -8361,6 +10070,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 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 @@ -8414,47 +10322,104 @@ Delay of auto-help controlled by `cperl-lazy-help-time'." before-change-functions after-change-functions deactivate-mark buffer-file-name buffer-file-truename) (remove-text-properties beg end '(face nil)) - (when (and (not modified) (buffer-modified-p)) + (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 @@ -8466,7 +10431,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.23 $")) (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.")