[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Emacs-diffs] Changes to emacs/lisp/progmodes/cperl-mode.el,v
|
From: |
Stefan Monnier |
|
Subject: |
[Emacs-diffs] Changes to emacs/lisp/progmodes/cperl-mode.el,v |
|
Date: |
Wed, 11 Oct 2006 06:47:36 +0000 |
CVSROOT: /sources/emacs
Module name: emacs
Changes by: Stefan Monnier <monnier> 06/10/11 06:47:35
Index: progmodes/cperl-mode.el
===================================================================
RCS file: /sources/emacs/emacs/lisp/progmodes/cperl-mode.el,v
retrieving revision 1.79
retrieving revision 1.80
diff -u -b -r1.79 -r1.80
--- progmodes/cperl-mode.el 29 Sep 2006 20:52:30 -0000 1.79
+++ progmodes/cperl-mode.el 11 Oct 2006 06:47:35 -0000 1.80
@@ -5,7 +5,7 @@
;; Free Software Foundation, Inc.
;; Author: Ilya Zakharevich and Bob Olson
-;; Maintainer: Ilya Zakharevich <address@hidden>
+;; Maintainer: Ilya Zakharevich <address@hidden>
;; Keywords: languages, Perl
;; This file is part of GNU Emacs.
@@ -25,7 +25,7 @@
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
-;;; Corrections made by Ilya Zakharevich address@hidden
+;;; Corrections made by Ilya Zakharevich address@hidden
;;; Commentary:
@@ -71,9 +71,11 @@
(defvar vc-rcs-header)
(defvar vc-sccs-header)
-;; Some macros are needed for `defcustom'
(eval-when-compile
(condition-case nil
+ (require 'custom)
+ (error nil))
+ (condition-case nil
(require 'man)
(error nil))
(defconst cperl-xemacs-p (string-match "XEmacs\\|Lucid" emacs-version))
@@ -88,46 +90,66 @@
(defvar gud-perldb-history)
(defvar font-lock-background-mode) ; not in Emacs
(defvar font-lock-display-type) ; ditto
+ (defvar paren-backwards-message) ; Not in newer XEmacs?
+ (or (fboundp 'defgroup)
+ (defmacro defgroup (name val doc &rest arr)
+ nil))
+ (or (fboundp 'custom-declare-variable)
+ (defmacro defcustom (name val doc &rest arr)
+ (` (defvar (, name) (, val) (, doc)))))
+ (or (and (fboundp 'custom-declare-variable)
+ (string< "19.31" emacs-version)) ; Checked with 19.30: defface
does not work
+ (defmacro defface (&rest arr)
+ nil))
+ ;; Avoid warning (tmp definitions)
+ (or (fboundp 'x-color-defined-p)
+ (defmacro x-color-defined-p (col)
+ (cond ((fboundp 'color-defined-p) (` (color-defined-p (, col))))
+ ;; XEmacs >= 19.12
+ ((fboundp 'valid-color-name-p) (` (valid-color-name-p (,
col))))
+ ;; XEmacs 19.11
+ ((fboundp 'x-valid-color-name-p) (` (x-valid-color-name-p (,
col))))
+ (t '(error "Cannot implement color-defined-p")))))
(defmacro cperl-is-face (arg) ; Takes quoted arg
(cond ((fboundp 'find-face)
- `(find-face ,arg))
+ (` (find-face (, arg))))
(;;(and (fboundp 'face-list)
;; (face-list))
(fboundp 'face-list)
- `(member ,arg (and (fboundp 'face-list)
- (face-list))))
+ (` (member (, arg) (and (fboundp 'face-list)
+ (face-list)))))
(t
- `(boundp ,arg))))
+ (` (boundp (, arg))))))
(defmacro cperl-make-face (arg descr) ; Takes unquoted arg
(cond ((fboundp 'make-face)
- `(make-face (quote ,arg)))
+ (` (make-face (quote (, arg)))))
(t
- `(defvar ,arg (quote ,arg) ,descr))))
+ (` (defvar (, arg) (quote (, arg)) (, descr))))))
(defmacro cperl-force-face (arg descr) ; Takes unquoted arg
- `(progn
- (or (cperl-is-face (quote ,arg))
- (cperl-make-face ,arg ,descr))
- (or (boundp (quote ,arg)) ; We use unquoted variants too
- (defvar ,arg (quote ,arg) ,descr))))
+ (` (progn
+ (or (cperl-is-face (quote (, arg)))
+ (cperl-make-face (, arg) (, descr)))
+ (or (boundp (quote (, arg))) ; We use unquoted variants too
+ (defvar (, arg) (quote (, arg)) (, descr))))))
(if cperl-xemacs-p
(defmacro cperl-etags-snarf-tag (file line)
- `(progn
+ (` (progn
(beginning-of-line 2)
- (list ,file ,line)))
+ (list (, file) (, line)))))
(defmacro cperl-etags-snarf-tag (file line)
- `(etags-snarf-tag)))
+ (` (etags-snarf-tag))))
(if cperl-xemacs-p
(defmacro cperl-etags-goto-tag-location (elt)
- ;;(progn
+ (`;;(progn
;; (switch-to-buffer (get-file-buffer (elt (, elt) 0)))
;; (set-buffer (get-file-buffer (elt (, elt) 0)))
;; Probably will not work due to some save-excursion???
;; Or save-file-position?
;; (message "Did I get to line %s?" (elt (, elt) 1))
- `(goto-line (string-to-number (elt ,elt 1))))
+ (goto-line (string-to-int (elt (, elt) 1)))))
;;)
(defmacro cperl-etags-goto-tag-location (elt)
- `(etags-goto-tag-location ,elt))))
+ (` (etags-goto-tag-location (, elt))))))
(defconst cperl-xemacs-p (string-match "XEmacs\\|Lucid" emacs-version))
@@ -251,6 +273,12 @@
:type 'integer
:group 'cperl-indentation-details)
+(defcustom cperl-indent-wrt-brace t
+ "*Non-nil means indent statements in if/etc block relative brace, not if/etc.
+Versions 5.2 ... 5.20 behaved as if this were `nil'."
+ :type 'boolean
+ :group 'cperl-indentation-details)
+
(defcustom cperl-auto-newline nil
"*Non-nil means automatically newline before and after braces,
and after colons and semicolons, inserted in CPerl code. The following
@@ -347,21 +375,27 @@
:type 'integer
:group 'cperl-indentation-details)
-(defvar cperl-vc-header-alist nil)
-(make-obsolete-variable
- 'cperl-vc-header-alist
- "use cperl-vc-rcs-header or cperl-vc-sccs-header instead.")
+(defcustom cperl-indent-comment-at-column-0 nil
+ "*Non-nil means that comment started at column 0 should be indentable."
+ :type 'boolean
+ :group 'cperl-indentation-details)
(defcustom cperl-vc-sccs-header '("($sccs) = ('%W\%' =~ /(\\d+(\\.\\d+)+)/) ;")
"*Special version of `vc-sccs-header' that is used in CPerl mode buffers."
:type '(repeat string)
:group 'cperl)
-(defcustom cperl-vc-rcs-header '("($rcs) = (' $Id\$ ' =~ /(\\d+(\\.\\d+)+)/)
;")
+(defcustom cperl-vc-rcs-header '("($rcs) = (' $Id\$ ' =~ /(\\d+(\\.\\d+)+)/);")
"*Special version of `vc-rcs-header' that is used in CPerl mode buffers."
:type '(repeat string)
:group 'cperl)
+;; This became obsolete...
+(defvar cperl-vc-header-alist nil)
+(make-obsolete-variable
+ 'cperl-vc-header-alist
+ "use cperl-vc-rcs-header or cperl-vc-sccs-header instead.")
+
(defcustom cperl-clobber-mode-lists
(not
(and
@@ -408,8 +442,15 @@
:type 'face
:group 'cperl-faces)
-(defcustom cperl-invalid-face 'underline
- "*Face for highlighting trailing whitespace."
+;;; Some double-evaluation happened with font-locks... Needed with 21.2...
+(defvar cperl-singly-quote-face cperl-xemacs-p)
+
+(defcustom cperl-invalid-face ; Does not customize with '' on XEmacs
+ (if cperl-singly-quote-face
+ 'underline ''underline) ; On older Emacsen was evaluated by `font-lock'
+ (if cperl-singly-quote-face
+ "*This face is used for highlighting trailing whitespace."
+ "*Face for highlighting trailing whitespace.")
:type 'face
:version "21.1"
:group 'cperl-faces)
@@ -441,7 +482,14 @@
(defcustom cperl-regexp-scan t
"*Not-nil means make marking of regular expression more thorough.
-Effective only with `cperl-pod-here-scan'. Not implemented yet."
+Effective only with `cperl-pod-here-scan'."
+ :type 'boolean
+ :group 'cperl-speed)
+
+(defcustom cperl-hook-after-change t
+ "*Not-nil means install hook to know which regions of buffer are changed.
+May significantly speed up delayed fontification. Changes take effect
+after reload."
:type 'boolean
:group 'cperl-speed)
@@ -564,17 +612,25 @@
:type 'boolean
:group 'cperl-speed)
+(defcustom cperl-syntaxify-for-menu
+ t
+ "*Non-nil means that CPerl syntaxifies up to the point before showing menu.
+This way enabling/disabling of menu items is more correct."
+ :type 'boolean
+ :group 'cperl-speed)
+
(defcustom cperl-ps-print-face-properties
'((font-lock-keyword-face nil nil bold shadow)
(font-lock-variable-name-face nil nil bold)
(font-lock-function-name-face nil nil bold italic box)
(font-lock-constant-face nil "LightGray" bold)
- (cperl-array nil "LightGray" bold underline)
- (cperl-hash nil "LightGray" bold italic
underline)
+ (cperl-array-face nil "LightGray" bold underline)
+ (cperl-hash-face nil "LightGray" bold italic
underline)
(font-lock-comment-face nil "LightGray" italic)
(font-lock-string-face nil nil italic underline)
- (cperl-nonoverridable nil nil italic underline)
+ (cperl-nonoverridable-face nil nil italic underline)
(font-lock-type-face nil nil underline)
+ (font-lock-warning-face nil "LightGray" bold italic box)
(underline nil "LightGray" strikeout))
"List given as an argument to `ps-extend-face-list' in `cperl-ps-print'."
:type '(repeat (cons symbol
@@ -588,7 +644,7 @@
(defvar cperl-dark-foreground
(cperl-choose-color "orchid1" "orange"))
-(defface cperl-nonoverridable
+(defface cperl-nonoverridable-face
`((((class grayscale) (background light))
(:background "Gray90" :slant italic :underline t))
(((class grayscale) (background dark))
@@ -600,10 +656,8 @@
(t (:weight bold :underline t)))
"Font Lock mode face used non-overridable keywords and modifiers of regexps."
:group 'cperl-faces)
-;; backward-compatibility alias
-(put 'cperl-nonoverridable-face 'face-alias 'cperl-nonoverridable)
-(defface cperl-array
+(defface cperl-array-face
`((((class grayscale) (background light))
(:background "Gray90" :weight bold))
(((class grayscale) (background dark))
@@ -615,10 +669,8 @@
(t (:weight bold)))
"Font Lock mode face used to highlight array names."
:group 'cperl-faces)
-;; backward-compatibility alias
-(put 'cperl-array-face 'face-alias 'cperl-array)
-(defface cperl-hash
+(defface cperl-hash-face
`((((class grayscale) (background light))
(:background "Gray90" :weight bold :slant italic))
(((class grayscale) (background dark))
@@ -630,8 +682,6 @@
(t (:weight bold :slant italic)))
"Font Lock mode face used to highlight hash names."
:group 'cperl-faces)
-;; backward-compatibility alias
-(put 'cperl-hash-face 'face-alias 'cperl-hash)
@@ -639,9 +689,7 @@
(defvar cperl-tips 'please-ignore-this-line
"Get maybe newer version of this package from
- ftp://ftp.math.ohio-state.edu/pub/users/ilya/emacs
-and/or
- ftp://ftp.math.ohio-state.edu/pub/users/ilya/perl
+ http://ilyaz.org/software/emacs
Subdirectory `cperl-mode' may contain yet newer development releases and/or
patches to related files.
@@ -666,9 +714,9 @@
(defalias 'perl-mode 'cperl-mode)
Get perl5-info from
- $CPAN/doc/manual/info/perl-info.tar.gz
-older version was on
- http://www.metronet.com:70/9/perlinfo/perl5/manual/perl5-info.tar.gz
+ $CPAN/doc/manual/info/perl5-old/perl5-info.tar.gz
+Also, one can generate a newer documentation running `pod2texi' converter
+ $CPAN/doc/manual/info/perl5/pod2texi-0.1.tar.gz
If you use imenu-go, run imenu on perl5-info buffer (you can do it
from Perl menu). If many files are related, generate TAGS files from
@@ -700,11 +748,18 @@
"Description of problems in CPerl mode.
Some faces will not be shown on some versions of Emacs unless you
install choose-color.el, available from
- ftp://ftp.math.ohio-state.edu/pub/users/ilya/emacs/
+ http://ilyaz.org/software/emacs
`fill-paragraph' on a comment may leave the point behind the
-paragraph. Parsing of lines with several <<EOF is not implemented
-yet.
+paragraph. It also triggers a bug in some versions of Emacs (CPerl tries
+to detect it and bulk out).
+
+See documentation of a variable `cperl-problems-old-emaxen' for the
+problems which disappear if you upgrade Emacs to a reasonably new
+version (20.3 for Emacs, and those of 2004 for XEmacs).")
+
+(defvar cperl-problems-old-emaxen 'please-ignore-this-line
+ "Description of problems in CPerl mode specific for older Emacs versions.
Emacs had a _very_ restricted syntax parsing engine until version
20.1. Most problems below are corrected starting from this version of
@@ -812,6 +867,13 @@
o) Highlights trailing whitespace;
p) Is able to manipulate Perl Regular Expressions to ease
conversion to a more readable form.
+ q) Can ispell POD sections and HERE-DOCs.
+ r) Understands comments and character classes inside regular
+ expressions; can find matching () and [] in a regular expression.
+ s) Allows indentation of //x-style regular expressions;
+ t) Highlights different symbols in regular expressions according
+ to their function; much less problems with backslashitis;
+ u) Allows to find regular expressions which contain interpolated parts.
5) The indentation engine was very smart, but most of tricks may be
not needed anymore with the support for `syntax-table' property. Has
@@ -829,7 +891,10 @@
line-breaks/spacing between elements of the construct.
10) Uses a linear-time algorith for indentation of regions (on Emaxen with
-capable syntax engines).")
+capable syntax engines).
+
+11) Syntax-highlight, indentation, sexp-recognition inside regular expressions.
+")
(defvar cperl-speed 'please-ignore-this-line
"This is an incomplete compendium of what is available in other parts
@@ -878,19 +943,19 @@
(defvar cperl-tips-faces 'please-ignore-this-line
"CPerl mode uses following faces for highlighting:
- `cperl-array' Array names
- `cperl-hash' Hash names
+ `cperl-array-face' Array names
+ `cperl-hash-face' Hash names
`font-lock-comment-face' Comments, PODs and whatever is considered
syntaxically to be not code
`font-lock-constant-face' HERE-doc delimiters, labels, delimiters of
2-arg operators s/y/tr/ or of RExen,
- `font-lock-function-name-face' Special-cased m// and s//foo/, _ as
- a target of a file tests, file tests,
+ `font-lock-warning-face' Special-cased m// and s//foo/,
+ `font-lock-function-name-face' _ as a target of a file tests, file tests,
subroutine names at the moment of definition
(except those conflicting with Perl operators),
package names (when recognized), format names
`font-lock-keyword-face' Control flow switch constructs, declarators
- `cperl-nonoverridable' Non-overridable keywords, modifiers of RExen
+ `cperl-nonoverridable-face' Non-overridable keywords, modifiers of RExen
`font-lock-string-face' Strings, qw() constructs, RExen, POD sections,
literal parts and the terminator of formats
and whatever is syntaxically considered
@@ -908,7 +973,25 @@
Help with best setup of these faces for printout requested (for each of
the faces: please specify bold, italic, underline, shadow and box.)
-\(Not finished.)")
+In regular expressions (except character classes):
+ `font-lock-string-face' \"Normal\" stuff and non-0-length constructs
+ `font-lock-constant-face': Delimiters
+ `font-lock-warning-face' Special-cased m// and s//foo/,
+ Mismatched closing delimiters, parens
+ we couldn't match, misplaced quantifiers,
+ unrecognized escape sequences
+ `cperl-nonoverridable-face' Modifiers, as gism in m/REx/gism
+ `font-lock-type-face' POSIX classes inside charclasses,
+ escape sequences with arguments (\x \23 \p \N)
+ and others match-a-char escape sequences
+ `font-lock-keyword-face' Capturing parens, and |
+ `font-lock-function-name-face' Special symbols: $ ^ . [ ] [^ ] (?{ }) (??{ })
+ `font-lock-builtin-face' \"Remaining\" 0-length constructs, executable
+ parts of a REx, not-capturing parens
+ `font-lock-variable-name-face' Interpolated constructs, embedded code
+ `font-lock-comment-face' Embedded comments
+
+")
@@ -985,6 +1068,25 @@
(cperl-hairy (or hairy t))
(t (symbol-value symbol))))
+
+(defun cperl-make-indent (column &optional minimum keep)
+ "Makes indent of the current line the requested amount.
+Unless KEEP, removes the old indentation. Works around a bug in ancient
+versions of Emacs."
+ (let ((prop (get-text-property (point) 'syntax-type)))
+ (or keep
+ (delete-horizontal-space))
+ (indent-to column minimum)
+ ;; In old versions (e.g., 19.33) `indent-to' would not inherit properties
+ (and prop
+ (> (current-column) 0)
+ (save-excursion
+ (beginning-of-line)
+ (or (get-text-property (point) 'syntax-type)
+ (and (looking-at "\\=[ \t]")
+ (put-text-property (point) (match-end 0)
+ 'syntax-type prop)))))))
+
;;; Probably it is too late to set these guys already, but it can help later:
;;;(and cperl-clobber-mode-lists
@@ -1035,7 +1137,16 @@
(cperl-define-key "\C-c\C-w" 'cperl-toggle-construct-fix)
(cperl-define-key "\C-c\C-f" 'auto-fill-mode)
(cperl-define-key "\C-c\C-e" 'cperl-toggle-electric)
+ (cperl-define-key "\C-c\C-b" 'cperl-find-bad-style)
+ (cperl-define-key "\C-c\C-p" 'cperl-pod-spell)
+ (cperl-define-key "\C-c\C-d" 'cperl-here-doc-spell)
+ (cperl-define-key "\C-c\C-n" 'cperl-narrow-to-here-doc)
+ (cperl-define-key "\C-c\C-v" 'cperl-next-interpolated-REx)
+ (cperl-define-key "\C-c\C-x" 'cperl-next-interpolated-REx-0)
+ (cperl-define-key "\C-c\C-y" 'cperl-next-interpolated-REx-1)
(cperl-define-key "\C-c\C-ha" 'cperl-toggle-autohelp)
+ (cperl-define-key "\C-c\C-hp" 'cperl-perldoc)
+ (cperl-define-key "\C-c\C-hP" 'cperl-perldoc-at-point)
(cperl-define-key "\e\C-q" 'cperl-indent-exp) ; Usually not bound
(cperl-define-key [?\C-\M-\|] 'cperl-lineup
[(control meta |)])
@@ -1074,9 +1185,13 @@
(<= 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)
@@ -1116,7 +1231,18 @@
["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)]
@@ -1133,12 +1259,50 @@
"----"
("Tools"
["Imenu" imenu (fboundp 'imenu)]
- ["Insert spaces if needed" cperl-find-bad-style t]
- ["Class Hierarchy from TAGS" cperl-tags-hier-init t]
- ;;["Update classes" (cperl-tags-hier-init t) tags-table-list]
+ ["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)]
- ["Imenu on info" cperl-imenu-on-info (featurep 'imenu)]
+ "----"
+ ["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]
("Tags"
;;; ["Create tags for current file" cperl-etags t]
;;; ["Add tags for current file" (cperl-etags t) t]
@@ -1186,10 +1350,10 @@
["PerlStyle" (cperl-set-style "PerlStyle") t]
["GNU" (cperl-set-style "GNU") t]
["C++" (cperl-set-style "C++") t]
- ["FSF" (cperl-set-style "FSF") t]
+ ["K&R" (cperl-set-style "K&R") t]
["BSD" (cperl-set-style "BSD") t]
["Whitesmith" (cperl-set-style "Whitesmith") t]
- ["Current" (cperl-set-style "Current") t]
+ ["Memorize Current" (cperl-set-style "Current") t]
["Memorized" (cperl-set-style-back) cperl-old-style])
("Micro-docs"
["Tips" (describe-variable 'cperl-tips) t]
@@ -1208,12 +1372,73 @@
The 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
"\\|"
- "=head\\([12]\\)[ \t]+\\([^\n]+\\)$"
+ "[ \t]*sub"
+ (cperl-after-sub-regexp 'named nil) ; 8=name 11=proto 14=attr-start
+ cperl-maybe-white-and-comment-rex ; 15=pre-block
+ "\\|"
+ "=head\\([1-4]\\)[ \t]+" ; 16=level
+ "\\([^\n]+\\)$" ; 17=text
"\\)"))
(defvar cperl-outline-regexp
@@ -1225,6 +1450,12 @@
(defvar cperl-string-syntax-table nil
"Syntax table in use in CPerl mode string-like chunks.")
+(defsubst cperl-1- (p)
+ (max (point-min) (1- p)))
+
+(defsubst cperl-1+ (p)
+ (min (point-max) (1+ p)))
+
(if cperl-mode-syntax-table
()
(setq cperl-mode-syntax-table (make-syntax-table))
@@ -1249,6 +1480,8 @@
(modify-syntax-entry ?| "." cperl-mode-syntax-table)
(setq cperl-string-syntax-table (copy-syntax-table cperl-mode-syntax-table))
(modify-syntax-entry ?$ "." cperl-string-syntax-table)
+ (modify-syntax-entry ?\{ "." cperl-string-syntax-table)
+ (modify-syntax-entry ?\} "." cperl-string-syntax-table)
(modify-syntax-entry ?# "." cperl-string-syntax-table)) ; (?# comment )
@@ -1257,6 +1490,10 @@
;; Fix for msb.el
(defvar cperl-msb-fixed nil)
(defvar cperl-use-major-mode 'cperl-mode)
+(defvar cperl-font-lock-multiline-start nil)
+(defvar cperl-font-lock-multiline nil)
+(defvar cperl-compilation-error-regexp-alist nil)
+(defvar cperl-font-locking nil)
;;;###autoload
(defun cperl-mode ()
@@ -1402,16 +1639,24 @@
`cperl-min-label-indent'
Minimal indentation for line that is a label.
-Settings for K&R and BSD indentation styles are
- `cperl-indent-level' 5 8
- `cperl-continued-statement-offset' 5 8
- `cperl-brace-offset' -5 -8
- `cperl-label-offset' -5 -8
+Settings for classic indent-styles: K&R BSD=C++ GNU PerlStyle=Whitesmith
+ `cperl-indent-level' 5 4 2 4
+ `cperl-brace-offset' 0 0 0 0
+ `cperl-continued-brace-offset' -5 -4 0 0
+ `cperl-label-offset' -5 -4 -2 -4
+ `cperl-continued-statement-offset' 5 4 2 4
CPerl knows several indentation styles, and may bulk set the
corresponding variables. Use \\[cperl-set-style] to do this. Use
\\[cperl-set-style-back] to restore the memorized preexisting values
-\(both available from menu).
+\(both available from menu). See examples in `cperl-style-examples'.
+
+Part of the indentation style is how different parts of if/elsif/else
+statements are broken into lines; in CPerl, this is reflected on how
+templates for these constructs are created (controlled by
+`cperl-extra-newline-before-brace'), and how reflow-logic should treat
\"continuation\" blocks of else/elsif/continue, controlled by the same variable,
+and by `cperl-extra-newline-before-brace-multiline',
+`cperl-merge-trailing-else', `cperl-indent-region-fix-constructs'.
If `cperl-indent-level' is 0, the statement after opening brace in
column 0 is indented on
@@ -1465,8 +1710,12 @@
("head2" "head2" cperl-electric-pod 0)))
(setq abbrevs-changed prev-a-c)))
(setq local-abbrev-table cperl-mode-abbrev-table)
- (abbrev-mode (if (cperl-val 'cperl-electric-keywords) 1 0))
+ (if (cperl-val 'cperl-electric-keywords)
+ (abbrev-mode 1))
(set-syntax-table cperl-mode-syntax-table)
+ ;; Until Emacs is multi-threaded, we do not actually need it local:
+ (make-local-variable 'cperl-font-lock-multiline-start)
+ (make-local-variable 'cperl-font-locking)
(make-local-variable 'outline-regexp)
;; (setq outline-regexp imenu-example--function-name-regexp-perl)
(setq outline-regexp cperl-outline-regexp)
@@ -1478,7 +1727,10 @@
(setq paragraph-separate paragraph-start)
(make-local-variable 'paragraph-ignore-fill-prefix)
(setq paragraph-ignore-fill-prefix t)
- (set (make-local-variable 'fill-paragraph-function) 'cperl-fill-paragraph)
+ (if cperl-xemacs-p
+ (progn
+ (make-local-variable 'paren-backwards-message)
+ (set 'paren-backwards-message t)))
(make-local-variable 'indent-line-function)
(setq indent-line-function 'cperl-indent-line)
(make-local-variable 'require-final-newline)
@@ -1492,9 +1744,22 @@
(make-local-variable 'comment-start-skip)
(setq comment-start-skip "#+ *")
(make-local-variable 'defun-prompt-regexp)
- (setq defun-prompt-regexp "^[ \t]*sub[ \t\n]+\\([^ \t\n{(;]+\\)\\([
\t\n]*([^()]*)[ \t\n]*\\)?[ \t\n]*")
+;;; "[ \t]*sub"
+;;; (cperl-after-sub-regexp 'named nil) ; 8=name 11=proto 14=attr-start
+;;; cperl-maybe-white-and-comment-rex ; 15=pre-block
+ (setq defun-prompt-regexp
+ (concat "^[ \t]*\\(sub"
+ (cperl-after-sub-regexp 'named 'attr-groups)
+ "\\|" ; per toke.c
+ "\\(BEGIN\\|CHECK\\|INIT\\|END\\|AUTOLOAD\\|DESTROY\\)"
+ "\\)"
+ cperl-maybe-white-and-comment-rex))
(make-local-variable 'comment-indent-function)
(setq comment-indent-function 'cperl-comment-indent)
+ (and (boundp 'fill-paragraph-function)
+ (progn
+ (make-local-variable 'fill-paragraph-function)
+ (set 'fill-paragraph-function 'cperl-fill-paragraph)))
(make-local-variable 'parse-sexp-ignore-comments)
(setq parse-sexp-ignore-comments t)
(make-local-variable 'indent-region-function)
@@ -1509,21 +1774,40 @@
(set 'vc-rcs-header cperl-vc-rcs-header)
(make-local-variable 'vc-sccs-header)
(set 'vc-sccs-header cperl-vc-sccs-header)
+ ;; This one is obsolete...
+ (make-local-variable 'vc-header-alist)
+ (set 'vc-header-alist (or cperl-vc-header-alist ; Avoid warning
+ (` ((SCCS (, (car cperl-vc-sccs-header)))
+ (RCS (, (car cperl-vc-rcs-header)))))))
+ (cond ((boundp 'compilation-error-regexp-alist-alist);; xemacs 20.x
+ (make-local-variable 'compilation-error-regexp-alist-alist)
+ (set 'compilation-error-regexp-alist-alist
+ (cons (cons 'cperl cperl-compilation-error-regexp-alist)
+ (symbol-value 'compilation-error-regexp-alist-alist)))
+ (if (fboundp 'compilation-build-compilation-error-regexp-alist)
+ (let ((f 'compilation-build-compilation-error-regexp-alist))
+ (funcall f))
+ (push 'cperl compilation-error-regexp-alist)))
+ ((boundp 'compilation-error-regexp-alist);; xmeacs 19.x
+ (make-local-variable 'compilation-error-regexp-alist)
+ (set 'compilation-error-regexp-alist
+ (cons cperl-compilation-error-regexp-alist
+ (symbol-value 'compilation-error-regexp-alist)))))
(make-local-variable 'font-lock-defaults)
(setq font-lock-defaults
(cond
((string< emacs-version "19.30")
- '(cperl-font-lock-keywords-2))
+ '(cperl-font-lock-keywords-2 nil nil ((?_ . "w"))))
((string< emacs-version "19.33") ; Which one to use?
'((cperl-font-lock-keywords
cperl-font-lock-keywords-1
- cperl-font-lock-keywords-2)))
+ cperl-font-lock-keywords-2) nil nil ((?_ . "w"))))
(t
'((cperl-load-font-lock-keywords
cperl-load-font-lock-keywords-1
- cperl-load-font-lock-keywords-2)
- nil nil ((?_ . "w"))))))
+ cperl-load-font-lock-keywords-2) nil nil ((?_ . "w"))))))
(make-local-variable 'cperl-syntax-state)
+ (setq cperl-syntax-state nil) ; reset syntaxification cache
(if cperl-use-syntax-table-text-property
(progn
(make-local-variable 'parse-sexp-lookup-properties)
@@ -1533,10 +1817,12 @@
(or (boundp 'font-lock-unfontify-region-function)
(set 'font-lock-unfontify-region-function
'font-lock-default-unfontify-region))
+ (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)
+ 'cperl-font-lock-unfontify-region-function))
(make-local-variable 'cperl-syntax-done-to)
+ (setq cperl-syntax-done-to nil) ; reset syntaxification cache
(make-local-variable 'font-lock-syntactic-keywords)
(setq font-lock-syntactic-keywords
(if cperl-syntaxify-by-font-lock
@@ -1546,10 +1832,20 @@
;; to make font-lock think that font-lock-syntactic-keywords
;; are defined.
'(t)))))
+ (if (boundp 'font-lock-multiline) ; Newer font-lock; use its facilities
+ (progn
+ (setq cperl-font-lock-multiline t) ; Not localized...
+ (set 'font-lock-multiline t)) ; not present with old Emacs; auto-local
+ (make-local-variable 'font-lock-fontify-region-function)
+ (set 'font-lock-fontify-region-function ; not present with old Emacs
+ 'cperl-font-lock-fontify-region-function))
+ (make-local-variable 'font-lock-fontify-region-function)
+ (set 'font-lock-fontify-region-function ; not present with old Emacs
+ 'cperl-font-lock-fontify-region-function)
(make-local-variable 'cperl-old-style)
(if (boundp 'normal-auto-fill-function) ; 19.33 and later
(set (make-local-variable 'normal-auto-fill-function)
- 'cperl-do-auto-fill) ; RMS has it as #'cperl-do-auto-fill ???
+ 'cperl-do-auto-fill)
(or (fboundp 'cperl-old-auto-fill-mode)
(progn
(fset 'cperl-old-auto-fill-mode (symbol-function 'auto-fill-mode))
@@ -1562,12 +1858,18 @@
(if (cperl-val 'cperl-font-lock)
(progn (or cperl-faces-init (cperl-init-faces))
(font-lock-mode 1))))
+ (set (make-local-variable 'facemenu-add-face-function)
+ 'cperl-facemenu-add-face-function) ; XXXX What this guy is for???
(and (boundp 'msb-menu-cond)
(not cperl-msb-fixed)
(cperl-msb-fix))
(if (featurep 'easymenu)
(easy-menu-add cperl-menu)) ; A NOP in Emacs.
(run-mode-hooks 'cperl-mode-hook)
+ (if cperl-hook-after-change
+ (progn
+ (make-local-hook 'after-change-functions)
+ (add-hook 'after-change-functions 'cperl-after-change-function nil t)))
;; After hooks since fontification will break this
(if cperl-pod-here-scan
(or cperl-syntaxify-by-font-lock
@@ -1616,31 +1918,37 @@
(defvar cperl-st-ket '(5 . ?\<))
-(defun cperl-comment-indent ()
+(defun cperl-comment-indent () ; called at point at supposed comment
(let ((p (point)) (c (current-column)) was phony)
- (if (looking-at "^#") 0 ; Existing comment at bol stays there.
+ (if (and (not cperl-indent-comment-at-column-0)
+ (looking-at "^#"))
+ 0 ; Existing comment at bol stays there.
;; Wrong comment found
(save-excursion
(setq was (cperl-to-comment-or-eol)
phony (eq (get-text-property (point) 'syntax-table)
cperl-st-cfence))
(if phony
- (progn
+ (progn ; Too naive???
(re-search-forward "#\\|$") ; Hmm, what about embedded #?
(if (eq (preceding-char) ?\#)
(forward-char -1))
(setq was nil)))
- (if (= (point) p)
+ (if (= (point) p) ; Our caller found a correct place
(progn
(skip-chars-backward " \t")
- (max (1+ (current-column)) ; Else indent at comment column
- comment-column))
+ (setq was (current-column))
+ (if (eq was 0)
+ comment-column
+ (max (1+ was) ; Else indent at comment column
+ comment-column)))
+ ;; No, the caller found a random place; we need to edit ourselves
(if was nil
(insert comment-start)
(backward-char (length comment-start)))
(setq cperl-wrong-comment t)
- (indent-to comment-column 1) ; Indent minimum 1
- c))))) ; except leave at least one space.
+ (cperl-make-indent comment-column 1) ; Indent min 1
+ c)))))
;;;(defun cperl-comment-indent-fallback ()
;;; "Is called if the standard comment-search procedure fails.
@@ -1666,7 +1974,7 @@
(interactive)
(let (cperl-wrong-comment)
(indent-for-comment)
- (if cperl-wrong-comment
+ (if cperl-wrong-comment ; set by `cperl-comment-indent'
(progn (cperl-to-comment-or-eol)
(forward-char (length comment-start))))))
@@ -1966,15 +2274,10 @@
(or
(get-text-property (point) 'in-pod)
(cperl-after-expr-p nil "{;:")
- (and (re-search-backward
- ;; "\\(\\`\n?\\|\n\n\\)=\\sw+"
- "\\(\\`\n?\\|^\n\\)=\\sw+"
- (point-min) t)
- (not (or
- (looking-at "=cut")
- (and cperl-use-syntax-table-text-property
- (not (eq (get-text-property (point) 'syntax-type)
- 'pod)))))))))
+ (and (re-search-backward "\\(\\`\n?\\|^\n\\)=\\sw+" (point-min) t)
+ (not (looking-at "\n*=cut"))
+ (or (not cperl-use-syntax-table-text-property)
+ (eq (get-text-property (point) 'syntax-type) 'pod))))))
(progn
(save-excursion
(setq notlast (re-search-forward "^\n=" nil t)))
@@ -2252,7 +2555,7 @@
(put 'cperl-electric-backspace 'delete-selection 'supersede)
-(defun cperl-inside-parens-p ()
+(defun cperl-inside-parens-p () ;; NOT USED????
(condition-case ()
(save-excursion
(save-restriction
@@ -2332,8 +2635,9 @@
(zerop shift-amt))
(if (> (- (point-max) pos) (point))
(goto-char (- (point-max) pos)))
- (delete-region beg (point))
- (indent-to indent)
+ ;;;(delete-region beg (point))
+ ;;;(indent-to indent)
+ (cperl-make-indent indent)
;; If initial point was within line's indentation,
;; position after the indentation. Else stay at same point in text.
(if (> (- (point-max) pos) (point))
@@ -2380,63 +2684,55 @@
(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.
+(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))))
+ )
-Will not correct the indentation for labels, but will correct it for braces
-and closing parentheses and brackets."
+(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))
+ (let ((res (get-text-property (point) 'syntax-type)))
(save-excursion
- (if (or
- (and (memq (get-text-property (point) 'syntax-type)
- '(pod here-doc here-doc-delim format))
+ (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!
- (and (looking-at "[ \t]*\n=")
+ ((looking-at "[ \t]*\n=")
(error "Spaces before POD section!"))
- (and (not cperl-indent-left-aligned-comments)
- (looking-at "^#")))
- nil
+ ((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 (save-excursion
+ (let* ((indent-point (point))
+ (char-after-pos (save-excursion
(skip-chars-forward " \t")
- (following-char)))
- (in-pod (get-text-property (point) 'in-pod))
+ (point)))
+ (char-after (char-after char-after-pos))
(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
+ (save-excursion ; Know we are not in POD, find
appropriate pos before
(cperl-backward-to-noncomment nil)
(setq p (max (point-min) (1- (point)))
prop (get-text-property p 'syntax-type)
@@ -2444,15 +2740,14 @@
'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)
+ (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)
- (nth 0 s-s)))
+ (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)
@@ -2467,16 +2762,42 @@
;; 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,
+ ;; indent to "after" the surrounding open
+ ;; (same offset as `cperl-beautify-regexp-piece'),
;; 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))
+ (setq delim ; We do not close the expression
+ (get-text-property
+ (cperl-1+ char-after-pos) 'indentable)
+ p (1+ (cperl-beginning-of-property
+ (point) 'indentable))
+ is-block ; misused for: preceeding line in REx
+ (save-excursion ; Find preceeding line
+ (cperl-backward-to-noncomment p)
+ (beginning-of-line)
+ (if (<= (point) p)
+ (progn ; get indent from the first line
+ (goto-char p)
+ (skip-chars-forward " \t")
+ (if (memq (char-after (point))
+ (append "#\n" nil))
+ nil ; Can't use intentation of this line...
+ (point)))
+ (skip-chars-forward " \t")
+ (point)))
+ prop (parse-partial-sexp p char-after-pos))
+ (cond ((not delim) ; End the REx, ignore is-block
+ (vector 'indentable 'terminator p is-block))
+ (is-block ; Indent w.r.t. preceeding line
+ (vector 'indentable 'cont-line char-after-pos
+ is-block char-after p))
+ (t ; No preceeding line...
+ (vector 'indentable 'first-line p))))
+ ((get-text-property char-after-pos 'REx-part2)
+ (vector 'REx-part2 (point)))
+ ((nth 3 state)
+ [comment])
+ ((nth 4 state)
+ [string])
;; XXXX Do we need to special-case this?
((null containing-sexp)
;; Line is at top level. May be data or function definition,
@@ -2485,18 +2806,9 @@
;; 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)
+ (setq state
+ (or (bobp)
(eq (point) old-indent) ; old-indent was at
comment
(eq (preceding-char) ?\;)
;; Had ?\) too
@@ -2509,14 +2821,18 @@
(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)))
+ (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)))
- 0)
- cperl-continued-statement-offset))))
+ (vector 'toplevel start char-after state (nth 2 s-s)))
((not
(or (setq is-block
(and (setq delim (= (char-after containing-sexp)
?{))
@@ -2532,56 +2848,30 @@
(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)))
+ (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)
+ (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) ?\,)
+ (while;;(or (eq (preceding-char) ?\,)
(and (eq (preceding-char) ?:)
- (or ;;(eq (char-after (- (point) 2)) ?\') ; ????
+ (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 the answer.
+ ;; 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)))
@@ -2597,27 +2887,9 @@
;; 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)))
+ (vector 'continuation (point) char-after is-block
delim))
;; This line starts a new statement.
- ;; Position following last unclosed open.
+ ;; Position following last unclosed open brace
(goto-char containing-sexp)
;; Is line first statement after an open-brace?
(or
@@ -2627,7 +2899,6 @@
;; small.
(save-excursion
(forward-char 1)
- (setq old-indent (current-indentation))
(let ((colon-line-end 0))
(while
(progn (skip-chars-forward " \t\n")
@@ -2644,63 +2915,243 @@
(save-excursion (end-of-line)
(setq colon-line-end (point)))
(search-forward ":"))))
- ;; The first following code counts
+ ;; 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)
- (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)))))
+ (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 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))
+ (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;
- ;; possibly a different line
- (progn
(if (eq (preceding-char) ?\))
- (forward-sexp -1))
+ (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.
- ;;
- (skip-chars-backward " \t")
- (if (and (eq (preceding-char) ?b)
- (progn
+ (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 old-indent
- (nth 1
+ (looking-at "sub\\>")))
+ (setq p (nth 1 ; start of innermost containing list
(parse-partial-sexp
- (save-excursion
(beginning-of-line) (point))
+ (save-excursion (beginning-of-line)
+ (point))
(point)))))
- (progn (goto-char (1+ old-indent))
+ (progn
+ (goto-char (1+ p)) ; enclosing block on the same
line
(skip-chars-forward " \t")
+ (vector 'code-start-in-block containing-sexp
char-after
+ (and delim (not is-block)) ; is a HASH
+ old-indent ; brace first thing on a line
+ t (point) ; have something before...
+ )
+ ;;(current-column)
+ )
+ ;; Get initial indentation of the line we are on.
+ ;; If line starts with label, calculate label
indentation
+ (vector 'code-start-in-block containing-sexp
char-after
+ (and delim (not is-block)) ; is a HASH
+ old-indent ; brace first thing on a line
+ nil (point) ; nothing interesting before
+ ))))))))))))))
+
+(defvar cperl-indent-rules-alist
+ '((pod nil) ; via `syntax-type' property
+ (here-doc nil) ; via `syntax-type' property
+ (here-doc-delim nil) ; via `syntax-type' property
+ (format nil) ; via `syntax-type' property
+ (in-pod nil) ; via `in-pod' property
+ (comment-special:at-beginning-of-line nil)
+ (string t)
+ (comment nil))
+ "Alist of indentation rules for CPerl mode.
+The values mean:
+ nil: do not indent;
+ number: add this amount of indentation.
+
+Not finished.")
+
+(defun cperl-calculate-indent (&optional parse-data) ; was parse-start
+ "Return appropriate indentation for current line as Perl code.
+In usual case returns an integer: the column to indent to.
+Returns nil if line starts inside a string, t if in a comment.
+
+Will not correct the indentation for labels, but will correct it for braces
+and closing parentheses and brackets."
+ ;; This code is still a broken architecture: in some cases we need to
+ ;; compensate for some modifications which `cperl-indent-line' will add later
+ (save-excursion
+ (let ((i (cperl-sniff-for-indent parse-data)) what p)
+ (cond
+ ;;((or (null i) (eq i t) (numberp i))
+ ;; i)
+ ((vectorp i)
+ (setq what (assoc (elt i 0) cperl-indent-rules-alist))
+ (cond
+ (what (cadr what)) ; Load from table
+ ;;
+ ;; Indenters for regular expressions with //x and qw()
+ ;;
+ ((eq 'REx-part2 (elt i 0)) ;; [self start] start of /REP in s//REP/x
+ (goto-char (elt i 1))
+ (condition-case nil ; Use indentation of the 1st part
+ (forward-sexp -1))
+ (current-column))
+ ((eq 'indentable (elt i 0)) ; Indenter for REGEXP qw() etc
+ (cond ;;; [indentable terminator start-pos is-block]
+ ((eq 'terminator (elt i 1)) ; Lone terminator of "indentable string"
+ (goto-char (elt i 2)) ; After opening parens
+ (1- (current-column)))
+ ((eq 'first-line (elt i 1)); [indentable first-line start-pos]
+ (goto-char (elt i 2))
+ (+ (or cperl-regexp-indent-step cperl-indent-level)
+ -1
+ (current-column)))
+ ((eq 'cont-line (elt i 1)); [indentable cont-line pos prev-pos
first-char start-pos]
+ ;; Indent as the level after closing parens
+ (goto-char (elt i 2)) ; indent line
+ (skip-chars-forward " \t)") ; Skip closing parens
+ (setq p (point))
+ (goto-char (elt i 3)) ; previous line
+ (skip-chars-forward " \t)") ; Skip closing parens
+ ;; Number of parens in between:
+ (setq p (nth 0 (parse-partial-sexp (point) p))
+ what (elt i 4)) ; First char on current line
+ (goto-char (elt i 3)) ; previous line
+ (+ (* p (or cperl-regexp-indent-step cperl-indent-level))
+ (cond ((eq what ?\) )
+ (- cperl-close-paren-offset)) ; compensate
+ ((eq what ?\| )
+ (- (or cperl-regexp-indent-step cperl-indent-level)))
+ (t 0))
+ (if (eq (following-char) ?\| )
+ (or cperl-regexp-indent-step cperl-indent-level)
+ 0)
+ (current-column)))
+ (t
+ (error "Unrecognized value of indent: %s" i))))
+ ;;
+ ;; Indenter for stuff at toplevel
+ ;;
+ ((eq 'toplevel (elt i 0)) ;; [toplevel start char-after state
immed-after-block]
+ (+ (save-excursion ; To beg-of-defun, or end of last sexp
+ (goto-char (elt i 1)) ; start = Good place to start parsing
+ (- (current-indentation) ;
+ (if (elt i 4) cperl-indent-level 0))) ; immed-after-block
+ (if (eq (elt i 2) ?{) cperl-continued-brace-offset 0) ; char-after
+ ;; Look at previous line that's at column 0
+ ;; to determine whether we are in top-level decls
+ ;; or function's arg decls. Set basic-indent accordingly.
+ ;; Now add a little if this is a continuation line.
+ (if (elt i 3) ; state (XXX What is the semantic???)
+ 0
+ cperl-continued-statement-offset)))
+ ;;
+ ;; Indenter for stuff in "parentheses" (or brackets, braces-as-hash)
+ ;;
+ ((eq 'in-parens (elt i 0))
+ ;; in-parens char-after old-indent-point is-brace containing-sexp
+
+ ;; group is an expression, not a block:
+ ;; indent to just after the surrounding open parens,
+ ;; skip blanks if we do not close the expression.
+ (+ (progn
+ (goto-char (elt i 2)) ; old-indent-point
+ (current-column))
+ (if (and (elt i 3) ; is-brace
+ (eq (elt i 1) ?\})) ; char-after
+ ;; Correct indentation of trailing ?\}
+ (+ cperl-indent-level cperl-close-paren-offset)
+ 0)))
+ ;;
+ ;; Indenter for continuation lines
+ ;;
+ ((eq 'continuation (elt i 0))
+ ;; [continuation statement-start char-after is-block is-brace]
+ (goto-char (elt i 1)) ; statement-start
+ (+ (if (memq (elt i 2) (append "}])" nil)) ; char-after
+ 0 ; Closing parenth
+ cperl-continued-statement-offset)
+ (if (or (elt i 3) ; is-block
+ (not (elt i 4)) ; is-brace
+ (not (eq (elt i 2) ?\}))) ; char-after
+ 0
+ ;; Now it is a hash reference
+ (+ cperl-indent-level cperl-close-paren-offset))
+ ;; Labels do not take :: ...
+ (if (looking-at "\\(\\w\\|_\\)+[ \t]*:")
+ (if (> (current-indentation) cperl-min-label-indent)
+ (- (current-indentation) cperl-label-offset)
+ ;; Do not move `parse-data', this should
+ ;; be quick anyway (this comment comes
+ ;; from different location):
+ (cperl-calculate-indent))
(current-column))
+ (if (eq (elt i 2) ?\{) ; char-after
+ cperl-continued-brace-offset 0)))
+ ;;
+ ;; Indenter for lines in a block which are not leading lines
+ ;;
+ ((eq 'have-prev-sibling (elt i 0))
+ ;; [have-prev-sibling sibling-beg colon-line-end block-start]
+ (goto-char (elt i 1))
+ (if (> (elt i 2) (point)) ; colon-line-end; After-label, same line
+ (if (> (current-indentation)
+ cperl-min-label-indent)
+ (- (current-indentation) cperl-label-offset)
+ ;; Do not believe: `max' was involved in calculation of indent
+ (+ cperl-indent-level
+ (save-excursion
+ (goto-char (elt i 3)) ; block-start
+ (current-indentation))))
+ (current-column)))
+ ;;
+ ;; Indenter for the first line in a block
+ ;;
+ ((eq 'code-start-in-block (elt i 0))
+ ;;[code-start-in-block before-brace char-after
+ ;; is-a-HASH-ref brace-is-first-thing-on-a-line
+ ;; group-starts-before-start-of-sub start-of-control-group]
+ (goto-char (elt i 1))
+ ;; For open brace in column zero, don't let statement
+ ;; start there too. If cperl-indent-level=0,
+ ;; use cperl-brace-offset + cperl-continued-statement-offset instead.
+ (+ (if (and (bolp) (zerop cperl-indent-level))
+ (+ cperl-brace-offset cperl-continued-statement-offset)
+ cperl-indent-level)
+ (if (and (elt i 3) ; is-a-HASH-ref
+ (eq (elt i 2) ?\})) ; char-after: End of a hash reference
+ (+ cperl-indent-level cperl-close-paren-offset)
+ 0)
+ ;; Unless openbrace is the first nonwhite thing on the line,
+ ;; add the cperl-brace-imaginary-offset.
+ (if (elt i 4) 0 ; brace-is-first-thing-on-a-line
+ cperl-brace-imaginary-offset)
+ (progn
+ (goto-char (elt i 6)) ; start-of-control-group
+ (if (elt i 5) ; group-starts-before-start-of-sub
+ (current-column)
;; Get initial indentation of the line we are on.
;; If line starts with label, calculate label
indentation
(if (save-excursion
@@ -2711,170 +3162,175 @@
;; Do not move `parse-data', this should
;; be quick anyway:
(cperl-calculate-indent))
- (current-indentation))))))))))))))
-
-;; (defvar cperl-indent-alist
-;; '((string nil)
-;; (comment nil)
-;; (toplevel 0)
-;; (toplevel-after-parenth 2)
-;; (toplevel-continued 2)
-;; (expression 1))
-;; "Alist of indentation rules for CPerl mode.
-;; The values mean:
-;; nil: do not indent;
-;; number: add this amount of indentation.
-
-;; Not finished, not used.")
-
-;; (defun cperl-where-am-i (&optional parse-start start-state)
-;; ;; Unfinished
-;; "Return a list of lists ((TYPE POS)...) of good points before the point.
-;; ;; POS may be nil if it is hard to find, say, when TYPE is `string' or
`comment'.
-
-;; ;; Not finished, not used."
-;; (save-excursion
-;; (let* ((start-point (point))
-;; (s-s (cperl-get-state))
-;; (start (nth 0 s-s))
-;; (state (nth 1 s-s))
-;; (prestart (nth 3 s-s))
-;; (containing-sexp (car (cdr state)))
-;; (case-fold-search nil)
-;; (res (list (list 'parse-start start) (list 'parse-prestart
prestart))))
-;; (cond ((nth 3 state) ; In string
-;; (setq res (cons (list 'string nil (nth 3 state)) res))) ; What
started string
-;; ((nth 4 state) ; In comment
-;; (setq res (cons '(comment) res)))
-;; ((null containing-sexp)
-;; ;; Line is at top level.
-;; ;; Indent like the previous top level line
-;; ;; unless that ends in a closeparen without semicolon,
-;; ;; in which case this line is the first argument decl.
-;; (cperl-backward-to-noncomment (or parse-start (point-min)))
-;; ;;(skip-chars-backward " \t\f\n")
-;; (cond
-;; ((or (bobp)
-;; (memq (preceding-char) (append ";}" nil)))
-;; (setq res (cons (list 'toplevel start) res)))
-;; ((eq (preceding-char) ?\) )
-;; (setq res (cons (list 'toplevel-after-parenth start) res)))
-;; (t
-;; (setq res (cons (list 'toplevel-continued start) res)))))
-;; ((/= (char-after containing-sexp) ?{)
-;; ;; line is expression, not statement:
-;; ;; indent to just after the surrounding open.
-;; ;; skip blanks if we do not close the expression.
-;; (setq res (cons (list 'expression-blanks
-;; (progn
-;; (goto-char (1+ containing-sexp))
-;; (or (looking-at "[ \t]*\\(#\\|$\\)")
-;; (skip-chars-forward " \t"))
-;; (point)))
-;; (cons (list 'expression containing-sexp) res))))
-;; ((progn
-;; ;; Containing-expr starts with \{. Check whether it is a hash.
-;; (goto-char containing-sexp)
-;; (not (cperl-block-p)))
-;; (setq res (cons (list 'expression-blanks
-;; (progn
-;; (goto-char (1+ containing-sexp))
-;; (or (looking-at "[ \t]*\\(#\\|$\\)")
-;; (skip-chars-forward " \t"))
-;; (point)))
-;; (cons (list 'expression containing-sexp) res))))
-;; (t
-;; ;; Statement level.
-;; (setq res (cons (list 'in-block containing-sexp) res))
-;; ;; Is it a continuation or a new statement?
-;; ;; Find previous non-comment character.
-;; (cperl-backward-to-noncomment containing-sexp)
-;; ;; Back up over label lines, since they don't
-;; ;; affect whether our line is a continuation.
-;; ;; Back up comma-delimited lines too ?????
-;; (while (or (eq (preceding-char) ?\,)
-;; (save-excursion (cperl-after-label)))
-;; (if (eq (preceding-char) ?\,)
-;; ;; Will go to beginning of line, essentially
-;; ;; Will ignore embedded sexpr XXXX.
-;; (cperl-backward-to-start-of-continued-exp containing-sexp))
-;; (beginning-of-line)
-;; (cperl-backward-to-noncomment containing-sexp))
-;; ;; Now we get the answer.
-;; (if (not (memq (preceding-char) (append ";}{" '(nil)))) ; Was ?\,
-;; ;; This line is continuation of preceding line's statement.
-;; (list (list 'statement-continued containing-sexp))
-;; ;; This line starts a new statement.
-;; ;; Position following last unclosed open.
-;; (goto-char containing-sexp)
-;; ;; Is line first statement after an open-brace?
-;; (or
-;; ;; If no, find that first statement and indent like
-;; ;; it. If the first statement begins with label, do
-;; ;; not believe when the indentation of the label is too
-;; ;; small.
-;; (save-excursion
-;; (forward-char 1)
-;; (let ((colon-line-end 0))
-;; (while (progn (skip-chars-forward " \t\n" start-point)
-;; (and (< (point) start-point)
-;; (looking-at
-;; "#\\|[a-zA-Z_][a-zA-Z0-9_]*:[^:]")))
-;; ;; Skip over comments and labels following openbrace.
-;; (cond ((= (following-char) ?\#)
-;; ;;(forward-line 1)
-;; (end-of-line))
-;; ;; label:
-;; (t
-;; (save-excursion (end-of-line)
-;; (setq colon-line-end (point)))
-;; (search-forward ":"))))
-;; ;; Now at the point, after label, or at start
-;; ;; of first statement in the block.
-;; (and (< (point) start-point)
-;; (if (> colon-line-end (point))
-;; ;; Before statement after label
-;; (if (> (current-indentation)
-;; cperl-min-label-indent)
-;; (list (list 'label-in-block (point)))
-;; ;; Do not believe: `max' is involved
-;; (list
-;; (list 'label-in-block-min-indent (point))))
-;; ;; Before statement
-;; (list 'statement-in-block (point))))))
-;; ;; If no previous statement,
-;; ;; indent it relative to line brace is on.
-;; ;; For open brace in column zero, don't let statement
-;; ;; start there too. If cperl-indent-level is zero,
-;; ;; use cperl-brace-offset + cperl-continued-statement-offset
instead.
-;; ;; For open-braces not the first thing in a line,
-;; ;; add in cperl-brace-imaginary-offset.
-
-;; ;; If first thing on a line: ?????
-;; (+ (if (and (bolp) (zerop cperl-indent-level))
-;; (+ cperl-brace-offset cperl-continued-statement-offset)
-;; cperl-indent-level)
-;; ;; Move back over whitespace before the openbrace.
-;; ;; If openbrace is not first nonwhite thing on the line,
-;; ;; add the cperl-brace-imaginary-offset.
-;; (progn (skip-chars-backward " \t")
-;; (if (bolp) 0 cperl-brace-imaginary-offset))
-;; ;; If the openbrace is preceded by a parenthesized exp,
-;; ;; move to the beginning of that;
-;; ;; possibly a different line
-;; (progn
-;; (if (eq (preceding-char) ?\))
-;; (forward-sexp -1))
-;; ;; Get initial indentation of the line we are on.
-;; ;; If line starts with label, calculate label indentation
-;; (if (save-excursion
-;; (beginning-of-line)
-;; (looking-at "[ \t]*[a-zA-Z_][a-zA-Z_0-9]*:[^:]"))
-;; (if (> (current-indentation) cperl-min-label-indent)
-;; (- (current-indentation) cperl-label-offset)
-;; (cperl-calculate-indent))
-;; (current-indentation))))))))
-;; res)))
+ (current-indentation))))))
+ (t
+ (error "Unrecognized value of indent: %s" i))))
+ (t
+ (error "Got strange value of indent: %s" i))))))
+
+(defvar cperl-indent-alist
+ '((string nil)
+ (comment nil)
+ (toplevel 0)
+ (toplevel-after-parenth 2)
+ (toplevel-continued 2)
+ (expression 1))
+ "Alist of indentation rules for CPerl mode.
+The values mean:
+ nil: do not indent;
+ number: add this amount of indentation.
+
+Not finished, not used.")
+
+(defun cperl-where-am-i (&optional parse-start start-state)
+ ;; Unfinished
+ "Return a list of lists ((TYPE POS)...) of good points before the point.
+POS may be nil if it is hard to find, say, when TYPE is `string' or `comment'.
+
+Not finished, not used."
+ (save-excursion
+ (let* ((start-point (point)) unused
+ (s-s (cperl-get-state))
+ (start (nth 0 s-s))
+ (state (nth 1 s-s))
+ (prestart (nth 3 s-s))
+ (containing-sexp (car (cdr state)))
+ (case-fold-search nil)
+ (res (list (list 'parse-start start) (list 'parse-prestart
prestart))))
+ (cond ((nth 3 state) ; In string
+ (setq res (cons (list 'string nil (nth 3 state)) res))) ; What
started string
+ ((nth 4 state) ; In comment
+ (setq res (cons '(comment) res)))
+ ((null containing-sexp)
+ ;; Line is at top level.
+ ;; Indent like the previous top level line
+ ;; unless that ends in a closeparen without semicolon,
+ ;; in which case this line is the first argument decl.
+ (cperl-backward-to-noncomment (or parse-start (point-min)))
+ ;;(skip-chars-backward " \t\f\n")
+ (cond
+ ((or (bobp)
+ (memq (preceding-char) (append ";}" nil)))
+ (setq res (cons (list 'toplevel start) res)))
+ ((eq (preceding-char) ?\) )
+ (setq res (cons (list 'toplevel-after-parenth start) res)))
+ (t
+ (setq res (cons (list 'toplevel-continued start) res)))))
+ ((/= (char-after containing-sexp) ?{)
+ ;; line is expression, not statement:
+ ;; indent to just after the surrounding open.
+ ;; skip blanks if we do not close the expression.
+ (setq res (cons (list 'expression-blanks
+ (progn
+ (goto-char (1+ containing-sexp))
+ (or (looking-at "[ \t]*\\(#\\|$\\)")
+ (skip-chars-forward " \t"))
+ (point)))
+ (cons (list 'expression containing-sexp) res))))
+ ((progn
+ ;; Containing-expr starts with \{. Check whether it is a hash.
+ (goto-char containing-sexp)
+ (not (cperl-block-p)))
+ (setq res (cons (list 'expression-blanks
+ (progn
+ (goto-char (1+ containing-sexp))
+ (or (looking-at "[ \t]*\\(#\\|$\\)")
+ (skip-chars-forward " \t"))
+ (point)))
+ (cons (list 'expression containing-sexp) res))))
+ (t
+ ;; Statement level.
+ (setq res (cons (list 'in-block containing-sexp) res))
+ ;; Is it a continuation or a new statement?
+ ;; Find previous non-comment character.
+ (cperl-backward-to-noncomment containing-sexp)
+ ;; Back up over label lines, since they don't
+ ;; affect whether our line is a continuation.
+ ;; Back up comma-delimited lines too ?????
+ (while (or (eq (preceding-char) ?\,)
+ (save-excursion (cperl-after-label)))
+ (if (eq (preceding-char) ?\,)
+ ;; Will go to beginning of line, essentially
+ ;; Will ignore embedded sexpr XXXX.
+ (cperl-backward-to-start-of-continued-exp containing-sexp))
+ (beginning-of-line)
+ (cperl-backward-to-noncomment containing-sexp))
+ ;; Now we get the answer.
+ (if (not (memq (preceding-char) (append ";}{" '(nil)))) ; Was ?\,
+ ;; This line is continuation of preceding line's statement.
+ (list (list 'statement-continued containing-sexp))
+ ;; This line starts a new statement.
+ ;; Position following last unclosed open.
+ (goto-char containing-sexp)
+ ;; Is line first statement after an open-brace?
+ (or
+ ;; If no, find that first statement and indent like
+ ;; it. If the first statement begins with label, do
+ ;; not believe when the indentation of the label is too
+ ;; small.
+ (save-excursion
+ (forward-char 1)
+ (let ((colon-line-end 0))
+ (while (progn (skip-chars-forward " \t\n" start-point)
+ (and (< (point) start-point)
+ (looking-at
+ "#\\|[a-zA-Z_][a-zA-Z0-9_]*:[^:]")))
+ ;; Skip over comments and labels following openbrace.
+ (cond ((= (following-char) ?\#)
+ ;;(forward-line 1)
+ (end-of-line))
+ ;; label:
+ (t
+ (save-excursion (end-of-line)
+ (setq colon-line-end (point)))
+ (search-forward ":"))))
+ ;; Now at the point, after label, or at start
+ ;; of first statement in the block.
+ (and (< (point) start-point)
+ (if (> colon-line-end (point))
+ ;; Before statement after label
+ (if (> (current-indentation)
+ cperl-min-label-indent)
+ (list (list 'label-in-block (point)))
+ ;; Do not believe: `max' is involved
+ (list
+ (list 'label-in-block-min-indent (point))))
+ ;; Before statement
+ (list 'statement-in-block (point))))))
+ ;; If no previous statement,
+ ;; indent it relative to line brace is on.
+ ;; For open brace in column zero, don't let statement
+ ;; start there too. If cperl-indent-level is zero,
+ ;; use cperl-brace-offset + cperl-continued-statement-offset
instead.
+ ;; For open-braces not the first thing in a line,
+ ;; add in cperl-brace-imaginary-offset.
+
+ ;; If first thing on a line: ?????
+ (setq unused ; This is not finished...
+ (+ (if (and (bolp) (zerop cperl-indent-level))
+ (+ cperl-brace-offset cperl-continued-statement-offset)
+ cperl-indent-level)
+ ;; Move back over whitespace before the openbrace.
+ ;; If openbrace is not first nonwhite thing on the line,
+ ;; add the cperl-brace-imaginary-offset.
+ (progn (skip-chars-backward " \t")
+ (if (bolp) 0 cperl-brace-imaginary-offset))
+ ;; If the openbrace is preceded by a parenthesized exp,
+ ;; move to the beginning of that;
+ ;; possibly a different line
+ (progn
+ (if (eq (preceding-char) ?\))
+ (forward-sexp -1))
+ ;; Get initial indentation of the line we are on.
+ ;; If line starts with label, calculate label indentation
+ (if (save-excursion
+ (beginning-of-line)
+ (looking-at "[ \t]*[a-zA-Z_][a-zA-Z_0-9]*:[^:]"))
+ (if (> (current-indentation) cperl-min-label-indent)
+ (- (current-indentation) cperl-label-offset)
+ (cperl-calculate-indent))
+ (current-indentation)))))))))
+ res)))
(defun cperl-calculate-indent-within-comment ()
"Return the indentation amount for line, assuming that
@@ -2894,14 +3350,22 @@
(defun cperl-to-comment-or-eol ()
"Go to position before comment on the current line, or to end of line.
-Returns true if comment is found."
- (let (state stop-in cpoint (lim (progn (end-of-line) (point))))
+Returns true if comment is found. In POD will not move the point."
+ ;; If the line is inside other syntax groups (qq-style strings, HERE-docs)
+ ;; then looks for literal # or end-of-line.
+ (let (state stop-in cpoint (lim (progn (end-of-line) (point))) pr e)
+ (or cperl-font-locking
+ (cperl-update-syntaxification lim lim))
(beginning-of-line)
- (if (or
- (eq (get-text-property (point) 'syntax-type) 'pod)
- (re-search-forward "\\=[ \t]*\\(#\\|$\\)" lim t))
+ (if (setq pr (get-text-property (point) 'syntax-type))
+ (setq e (next-single-property-change (point) 'syntax-type nil
(point-max))))
+ (if (or (eq pr 'pod)
+ (if (or (not e) (> e lim)) ; deep inside a group
+ (re-search-forward "\\=[ \t]*\\(#\\|$\\)" lim t)))
(if (eq (preceding-char) ?\#) (progn (backward-char 1) t))
- ;; Else
+ ;; Else - need to do it the hard way
+ (and (and e (<= e lim))
+ (goto-char e))
(while (not stop-in)
(setq state (parse-partial-sexp (point) lim nil nil nil t))
; stop at comment
@@ -2933,17 +3397,11 @@
(setq stop-in t))) ; Finish
(nth 4 state))))
-(defsubst cperl-1- (p)
- (max (point-min) (1- p)))
-
-(defsubst cperl-1+ (p)
- (min (point-max) (1+ p)))
-
(defsubst cperl-modify-syntax-type (at how)
(if (< at (point-max))
(progn
(put-text-property at (1+ at) 'syntax-table how)
- (put-text-property at (1+ at) 'rear-nonsticky t))))
+ (put-text-property at (1+ at) 'rear-nonsticky '(syntax-table)))))
(defun cperl-protect-defun-start (s e)
;; C code looks for "^\\s(" to skip comment backward in "hard" situations
@@ -2978,35 +3436,53 @@
( ?\{ . ?\} )
( ?\< . ?\> )))
-(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)))
+ (modify-syntax-entry ender (concat ")" (list starter)) st))
(condition-case bb
(progn
;; We use `$' syntax class to find matching stuff, but $$
@@ -3053,7 +3529,7 @@
(modify-syntax-entry starter (if (eq starter ?\\) "\\" ".") st)
(if ender (modify-syntax-entry ender "." st))
(setq set-st nil)
- (setq ender (cperl-forward-re lim end nil t st-l err-l
+ (setq ender (cperl-forward-re lim end nil st-l err-l
argument starter ender)
ender (nth 2 ender)))))
(error (goto-char lim)
@@ -3078,6 +3554,33 @@
;; go-forward: has 2 args, and the second part is empty
(list i i2 ender starter go-forward)))
+(defun cperl-forward-group-in-re (&optional st-l)
+ "Find the end of a group in a REx.
+Return the error message (if any). Does not work if delimiter is `)'.
+Works before syntax recognition is done."
+ ;; Works *before* syntax recognition is done
+ (or st-l (setq st-l (list nil))) ; Avoid overwriting '()
+ (let (st b reset-st)
+ (condition-case b
+ (progn
+ (setq st (cperl-cached-syntax-table st-l))
+ (modify-syntax-entry ?\( "()" st)
+ (modify-syntax-entry ?\) ")(" st)
+ (setq reset-st (syntax-table))
+ (set-syntax-table st)
+ (forward-sexp 1))
+ (error (message
+ "cperl-forward-group-in-re: error %s" b)))
+ ;; now restore the initial state
+ (if st
+ (progn
+ (modify-syntax-entry ?\( "." st)
+ (modify-syntax-entry ?\) "." st)))
+ (if reset-st
+ (set-syntax-table reset-st))
+ b))
+
+
(defvar font-lock-string-face)
;;(defvar font-lock-reference-face)
(defvar font-lock-constant-face)
@@ -3103,13 +3606,24 @@
;; d) 'Q'uoted string:
;; part between markers inclusive is marked `syntax-type' ==>
`string'
;; part between `q' and the first marker is marked `syntax-type'
==> `prestring'
+;; second part of s///e is marked `syntax-type' ==> `multiline'
+;; e) Attributes of subroutines: `attrib-group' ==> t
+;; (or 0 if declaration); up to `{' or ';': `syntax-type' =>
`sub-decl'.
+;; f) Multiline my/our declaration lists etc: `syntax-type' => `multiline'
+
+;;; In addition, some parts of RExes may be marked as `REx-interpolated'
+;;; (value: 0 in //o, 1 if "interpolated variable" is whole-REx, t otherwise).
(defun cperl-unwind-to-safe (before &optional end)
;; if BEFORE, go to the previous start-of-line on each step of unwinding
(let ((pos (point)) opos)
- (setq opos pos)
- (while (and pos (get-text-property pos 'syntax-type))
- (setq pos (previous-single-property-change pos 'syntax-type))
+ (while (and pos (progn
+ (beginning-of-line)
+ (get-text-property (setq pos (point)) 'syntax-type)))
+ (setq opos pos
+ pos (cperl-beginning-of-property pos 'syntax-type))
+ (if (eq pos (point-min))
+ (setq pos nil))
(if pos
(if before
(progn
@@ -3126,17 +3640,101 @@
(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-sub-attrs (&optional st-l b-fname e-fname pos)
+ "Syntaxically mark (and fontify) attributes of a subroutine.
+Should be called with the point before leading colon of an attribute."
+ ;; Works *before* syntax recognition is done
+ (or st-l (setq st-l (list nil))) ; Avoid overwriting '()
+ (let (st b p reset-st after-first (start (point)) start1 end1)
+ (condition-case b
+ (while (looking-at
+ (concat
+ "\\(" ; 1=optional? colon
+ ":" cperl-maybe-white-and-comment-rex ; 2=whitespace/comment?
+ "\\)"
+ (if after-first "?" "")
+ ;; No space between name and paren allowed...
+ "\\(\\sw+\\)" ; 3=name
+ "\\((\\)?")) ; 4=optional paren
+ (and (match-beginning 1)
+ (cperl-postpone-fontification
+ (match-beginning 0) (cperl-1+ (match-beginning 0))
+ 'face font-lock-constant-face))
+ (setq start1 (match-beginning 3) end1 (match-end 3))
+ (cperl-postpone-fontification start1 end1
+ 'face font-lock-constant-face)
+ (goto-char end1) ; end or before `('
+ (if (match-end 4) ; Have attribute arguments...
+ (progn
+ (if st nil
+ (setq st (cperl-cached-syntax-table st-l))
+ (modify-syntax-entry ?\( "()" st)
+ (modify-syntax-entry ?\) ")(" st))
+ (setq reset-st (syntax-table) p (point))
+ (set-syntax-table st)
+ (forward-sexp 1)
+ (set-syntax-table reset-st)
+ (setq reset-st nil)
+ (cperl-commentify p (point) t))) ; mark as string
+ (forward-comment (buffer-size))
+ (setq after-first t))
+ (error (message
+ "L%d: attribute `%s': %s"
+ (count-lines (point-min) (point))
+ (and start1 end1 (buffer-substring start1 end1)) b)
+ (setq start nil)))
+ (and start
+ (progn
+ (put-text-property start (point)
+ 'attrib-group (if (looking-at "{") t 0))
+ (and pos
+ (< 1 (count-lines (+ 3 pos) (point))) ; end of `sub'
+ ;; Apparently, we do not need `multiline': faces added now
+ (put-text-property (+ 3 pos) (cperl-1+ (point))
+ 'syntax-type 'sub-decl))
+ (and b-fname ; Fontify here: the following condition
+ (cperl-postpone-fontification ; is too hard to determine by
+ b-fname e-fname 'face ; a REx, so do it here
+ (if (looking-at "{")
+ font-lock-function-name-face
+ font-lock-variable-name-face)))))
+ ;; now restore the initial state
+ (if st
+ (progn
+ (modify-syntax-entry ?\( "." st)
+ (modify-syntax-entry ?\) "." st)))
+ (if reset-st
+ (set-syntax-table reset-st))))
+
+(defsubst cperl-look-at-leading-count (is-x-REx e)
+ (if (re-search-forward (concat "\\=" (if is-x-REx "[ \t\n]*" "") "[{?+*]")
+ (1- e) t) ; return nil on failure, no moving
+ (if (eq ?\{ (preceding-char)) nil
+ (cperl-postpone-fontification
+ (1- (point)) (point)
+ 'face font-lock-warning-face))))
-(defun cperl-find-pods-heres (&optional min max non-inter end ignore-max)
+;;; 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',
@@ -3148,10 +3746,11 @@
(or max (setq max (point-max)))
(let* ((cperl-pod-here-fontify (eval cperl-pod-here-fontify)) go tmpend
face head-face here-face b e bb tag qtag b1 e1 argument i c tail tb
- is-REx is-x-REx REx-comment-start REx-comment-end was-comment i2
+ is-REx is-x-REx REx-subgr-start REx-subgr-end was-subgr i2 hairy-RE
(case-fold-search nil) (inhibit-read-only t) (buffer-undo-list t)
- (modified (buffer-modified-p))
+ (modified (buffer-modified-p)) overshoot is-o-REx
(after-change-functions nil)
+ (cperl-font-locking t)
(use-syntax-state (and cperl-syntax-state
(>= min (car cperl-syntax-state))))
(state-point (if use-syntax-state
@@ -3162,33 +3761,62 @@
;; (st-l '(nil)) (err-l '(nil)) ; Would overwrite - propagates from a
function call to a function call!
(st-l (list nil)) (err-l (list nil))
;; Somehow font-lock may be not loaded yet...
+ ;; (e.g., when building TAGS via command-line call)
(font-lock-string-face (if (boundp 'font-lock-string-face)
font-lock-string-face
'font-lock-string-face))
- (font-lock-constant-face (if (boundp 'font-lock-constant-face)
+ (my-cperl-delimiters-face (if (boundp 'font-lock-constant-face)
font-lock-constant-face
'font-lock-constant-face))
- (font-lock-function-name-face
+ (my-cperl-REx-spec-char-face ; [] ^.$ and wrapper-of ({})
(if (boundp 'font-lock-function-name-face)
font-lock-function-name-face
'font-lock-function-name-face))
+ (font-lock-variable-name-face ; interpolated vars and ({})-code
+ (if (boundp 'font-lock-variable-name-face)
+ font-lock-variable-name-face
+ 'font-lock-variable-name-face))
+ (font-lock-function-name-face ; used in `cperl-find-sub-attrs'
+ (if (boundp 'font-lock-function-name-face)
+ font-lock-function-name-face
+ 'font-lock-function-name-face))
+ (font-lock-constant-face ; used in `cperl-find-sub-attrs'
+ (if (boundp 'font-lock-constant-face)
+ font-lock-constant-face
+ 'font-lock-constant-face))
+ (my-cperl-REx-0length-face ; 0-length, (?:)etc, non-literal \
+ (if (boundp 'font-lock-builtin-face)
+ font-lock-builtin-face
+ 'font-lock-builtin-face))
(font-lock-comment-face
(if (boundp 'font-lock-comment-face)
font-lock-comment-face
'font-lock-comment-face))
- (cperl-nonoverridable-face
+ (font-lock-warning-face
+ (if (boundp 'font-lock-warning-face)
+ font-lock-warning-face
+ 'font-lock-warning-face))
+ (my-cperl-REx-ctl-face ; (|)
+ (if (boundp 'font-lock-keyword-face)
+ font-lock-keyword-face
+ 'font-lock-keyword-face))
+ (my-cperl-REx-modifiers-face ; //gims
(if (boundp 'cperl-nonoverridable-face)
cperl-nonoverridable-face
- 'cperl-nonoverridable))
+ 'cperl-nonoverridable-face))
+ (my-cperl-REx-length1-face ; length=1 escaped chars, POSIX classes
+ (if (boundp 'font-lock-type-face)
+ font-lock-type-face
+ 'font-lock-type-face))
(stop-point (if ignore-max
(point-max)
max))
(search
(concat
- "\\(\\`\n?\\|^\n\\)="
+ "\\(\\`\n?\\|^\n\\)=" ; POD
"\\|"
;; One extra () before this:
- "<<"
+ "<<" ; HERE-DOC
"\\(" ; 1 + 1
;; First variant "BLAH" or just ``.
"[ \t]*" ; Yes, whitespace is allowed!
@@ -3204,36 +3832,44 @@
"\\)"
"\\|"
;; 1+6 extra () before this:
- "^[ \t]*\\(format\\)[ \t]*\\([a-zA-Z0-9_]+\\)?[ \t]*=[ \t]*$"
+ "^[ \t]*\\(format\\)[ \t]*\\([a-zA-Z0-9_]+\\)?[ \t]*=[ \t]*$" ;FRMAT
(if cperl-use-syntax-table-text-property
(concat
"\\|"
;; 1+6+2=9 extra () before this:
- "\\<\\(q[wxqr]?\\|[msy]\\|tr\\)\\>"
+ "\\<\\(q[wxqr]?\\|[msy]\\|tr\\)\\>" ; QUOTED CONSTRUCT
"\\|"
;; 1+6+2+1=10 extra () before this:
"\\([?/<]\\)" ; /blah/ or ?blah? or <file*glob>
"\\|"
- ;; 1+6+2+1+1=11 extra () before this:
- "\\<sub\\>[ \t]*\\([a-zA-Z_:'0-9]+[ \t]*\\)?\\(([^()]*)\\)"
+ ;; 1+6+2+1+1=11 extra () before this
+ "\\<sub\\>" ; sub with proto/attr
+ "\\("
+ cperl-white-and-comment-rex
+ "\\(::[a-zA-Z_:'0-9]*\\|[a-zA-Z_'][a-zA-Z_:'0-9]*\\)\\)?" ;
name
+ "\\("
+ cperl-maybe-white-and-comment-rex
+ "\\(([^()]*)\\|:[^:]\\)\\)" ; prototype or attribute start
"\\|"
- ;; 1+6+2+1+1+2=13 extra () before this:
- "\\$\\(['{]\\)"
+ ;; 1+6+2+1+1+6=17 extra () before this:
+ "\\$\\(['{]\\)" ; $' or ${foo}
"\\|"
- ;; 1+6+2+1+1+2+1=14 extra () before this:
+ ;; 1+6+2+1+1+6+1=18 extra () before this (old pack'var syntax;
+ ;; we do not support intervening comments...):
"\\(\\<sub[ \t\n\f]+\\|[&address@hidden)[a-zA-Z0-9_]*'"
- ;; 1+6+2+1+1+2+1+1=15 extra () before this:
+ ;; 1+6+2+1+1+6+1+1=19 extra () before this:
"\\|"
- "__\\(END\\|DATA\\)__"
- ;; 1+6+2+1+1+2+1+1+1=16 extra () before this:
+ "__\\(END\\|DATA\\)__" ; __END__ or __DATA__
+ ;; 1+6+2+1+1+6+1+1+1=20 extra () before this:
"\\|"
- "\\\\\\(['`\"($]\\)")
+ "\\\\\\(['`\"($]\\)") ; BACKWACKED something-hairy
""))))
(unwind-protect
(progn
(save-excursion
(or non-inter
(message "Scanning for \"hard\" Perl constructions..."))
+ ;;(message "find: %s --> %s" min max)
(and cperl-pod-here-fontify
;; We had evals here, do not know why...
(setq face cperl-pod-face
@@ -3241,16 +3877,22 @@
here-face cperl-here-face))
(remove-text-properties min max
'(syntax-type t in-pod t syntax-table t
+ attrib-group t
+ REx-interpolated t
cperl-postpone t
syntax-subtype t
rear-nonsticky t
+ front-sticky t
here-doc-group t
first-format-line t
+ REx-part2 t
indentable t))
;; Need to remove face as well...
(goto-char min)
(and (eq system-type 'emx)
- (looking-at "extproc[ \t]") ; Analogue of #!
+ (eq (point) 1)
+ (let ((case-fold-search t))
+ (looking-at "extproc[ \t]")) ; Analogue of #!
(cperl-commentify min
(save-excursion (end-of-line) (point))
nil))
@@ -3258,11 +3900,38 @@
(< (point) max)
(re-search-forward search max t))
(setq tmpend nil) ; Valid for most cases
+ (setq b (match-beginning 0)
+ state (save-excursion (parse-partial-sexp
+ state-point b nil nil state))
+ state-point b)
(cond
+ ;; 1+6+2+1+1+6=17 extra () before this:
+ ;; "\\$\\(['{]\\)"
+ ((match-beginning 18) ; $' or ${foo}
+ (if (eq (preceding-char) ?\') ; $'
+ (progn
+ (setq b (1- (point))
+ state (parse-partial-sexp
+ state-point (1- b) nil nil state)
+ state-point (1- b))
+ (if (nth 3 state) ; in string
+ (cperl-modify-syntax-type (1- b) cperl-st-punct))
+ (goto-char (1+ b)))
+ ;; else: ${
+ (setq bb (match-beginning 0))
+ (cperl-modify-syntax-type bb cperl-st-punct)))
+ ;; No processing in strings/comments beyond this point:
+ ((or (nth 3 state) (nth 4 state))
+ t) ; Do nothing in comment/string
((match-beginning 1) ; POD section
;; "\\(\\`\n?\\|^\n\\)="
- (if (looking-at "cut\\>")
- (if ignore-max
+ (setq b (match-beginning 0)
+ state (parse-partial-sexp
+ state-point b nil nil state)
+ state-point b)
+ (if (or (nth 3 state) (nth 4 state)
+ (looking-at "cut\\>"))
+ (if (or (nth 3 state) (nth 4 state) ignore-max)
nil ; Doing a chunk only
(message "=cut is not preceded by a POD section")
(or (car err-l) (setcar err-l (point))))
@@ -3288,11 +3957,15 @@
(progn
(remove-text-properties
max e '(syntax-type t in-pod t syntax-table t
+ attrib-group t
+ REx-interpolated t
cperl-postpone t
syntax-subtype t
here-doc-group t
rear-nonsticky t
+ front-sticky t
first-format-line t
+ REx-part2 t
indentable t))
(setq tmpend tb)))
(put-text-property b e 'in-pod t)
@@ -3335,7 +4008,8 @@
(or (eq e (point-max))
(forward-char -1)))) ; Prepare for immediate POD start.
;; Here document
- ;; We do only one here-per-line
+ ;; We can do many here-per-line;
+ ;; but multiline quote on the same line as <<HERE confuses us...
;; ;; One extra () before this:
;;"<<"
;; "\\(" ; 1 + 1
@@ -3352,21 +4026,42 @@
;; "\\(\\)" ; To preserve count of pars :-( 6 + 1
;; "\\)"
((match-beginning 2) ; 1 + 1
- ;; Abort in comment:
- (setq b (point))
- (setq state (parse-partial-sexp state-point b nil nil state)
- state-point b
+ (setq b (point)
tb (match-beginning 0)
- i (or (nth 3 state) (nth 4 state)))
- (if i
- (setq c t)
- (setq c (and
+ c (and ; not HERE-DOC
(match-beginning 5)
- (not (match-beginning 6)) ; Empty
+ (save-match-data
+ (or (looking-at "[ \t]*(") ; << function_call()
+ (save-excursion ; 1 << func_name, or $foo << 10
+ (condition-case nil
+ (progn
+ (goto-char tb)
+ ;;; XXX What to do: foo <<bar ???
+ ;;; XXX Need to support print {a} <<B ???
+ (forward-sexp -1)
+ (save-match-data
+ ; $foo << b; $f .= <<B;
+ ; ($f+1) << b; a($f) . <<B;
+ ; foo 1, <<B; $x{a} <<b;
+ (cond
+ ((looking-at "[0-9$({]")
+ (forward-sexp 1)
+ (and
+ (looking-at "[ \t]*<<")
+ (condition-case nil
+ ;; print $foo <<EOF
+ (progn
+ (forward-sexp -2)
+ (not
+ (looking-at
"\\(printf?\\|system\\|exec\\|sort\\)\\>")))
+ (error t)))))))
+ (error nil))) ; func(<<EOF)
+ (and (not (match-beginning 6)) ; Empty
(looking-at
- "[ address@hidden&(]"))))
+ "[ address@hidden&(]"))))))
(if c ; Not here-doc
nil ; Skip it.
+ (setq c (match-end 2)) ; 1 + 1
(if (match-beginning 5) ;4 + 1
(setq b1 (match-beginning 5) ; 4 + 1
e1 (match-end 5)) ; 4 + 1
@@ -3376,15 +4071,20 @@
qtag (regexp-quote tag))
(cond (cperl-pod-here-fontify
;; Highlight the starting delimiter
- (cperl-postpone-fontification b1 e1 'face
font-lock-constant-face)
+ (cperl-postpone-fontification
+ b1 e1 'face my-cperl-delimiters-face)
(cperl-put-do-not-fontify b1 e1 t)))
(forward-line)
+ (setq i (point))
+ (if end-of-here-doc
+ (goto-char end-of-here-doc))
(setq b (point))
;; We do not search to max, since we may be called from
;; some hook of fontification, and max is random
(or (and (re-search-forward (concat "^" qtag "$")
stop-point 'toend)
- (eq (following-char) ?\n))
+ ;;;(eq (following-char) ?\n) ; XXXX WHY???
+ )
(progn ; Pretend we matched at the end
(goto-char (point-max))
(re-search-forward "\\'")
@@ -3393,8 +4093,9 @@
(if cperl-pod-here-fontify
(progn
;; Highlight the ending delimiter
- (cperl-postpone-fontification (match-beginning 0)
(match-end 0)
- 'face
font-lock-constant-face)
+ (cperl-postpone-fontification
+ (match-beginning 0) (match-end 0)
+ 'face my-cperl-delimiters-face)
(cperl-put-do-not-fontify b (match-end 0) t)
;; Highlight the HERE-DOC
(cperl-postpone-fontification b (match-beginning 0)
@@ -3404,10 +4105,21 @@
'syntax-type 'here-doc)
(put-text-property (match-beginning 0) e1
'syntax-type 'here-doc-delim)
- (put-text-property b e1
- 'here-doc-group t)
+ (put-text-property b e1 'here-doc-group t)
+ ;; This makes insertion at the start of HERE-DOC update
+ ;; the whole construct:
+ (put-text-property b (cperl-1+ b) 'front-sticky
'(syntax-type))
(cperl-commentify b e1 nil)
(cperl-put-do-not-fontify b (match-end 0) t)
+ ;; Cache the syntax info...
+ (setq cperl-syntax-state (cons state-point state))
+ ;; ... and process the rest of the line...
+ (setq overshoot
+ (elt ; non-inter ignore-max
+ (cperl-find-pods-heres c i t end t e1) 1))
+ (if (and overshoot (> overshoot (point)))
+ (goto-char overshoot)
+ (setq overshoot e1))
(if (> e1 max)
(setq tmpend tb))))
;; format
@@ -3462,7 +4174,7 @@
(if (> (point) max)
(setq tmpend tb))
(put-text-property b (point) 'syntax-type 'format))
- ;; Regexp:
+ ;; qq-like String or Regexp:
((or (match-beginning 10) (match-beginning 11))
;; 1+6+2=9 extra () before this:
;; "\\<\\(q[wxqr]?\\|[msy]\\|tr\\)\\>"
@@ -3471,7 +4183,7 @@
(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
@@ -3506,15 +4218,14 @@
(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))
+ "~{(=|&*!,;:["
+ "~{(=|&+-*!,;:[") nil))
(and (eq (preceding-char) ?\})
(cperl-after-block-p (point-min)))
(and (eq (char-syntax (preceding-char))
?w)
@@ -3540,7 +4251,7 @@
(not (bobp))
(progn
(forward-char -1)
- (looking-at "\\s|")))))))
+ (looking-at "\\s|"))))))
b (1- b))
;; s y tr m
;; Check for $a -> y
@@ -3550,13 +4261,9 @@
(eq (char-after (- go 2)) ?-))
;; Not a regexp
(setq bb t))))
- (or bb (setq state (parse-partial-sexp
- state-point b nil nil state)
- state-point b))
- (setq bb (or bb (nth 3 state) (nth 4 state)))
- (goto-char b)
(or bb
(progn
+ (goto-char b)
(if (looking-at "[ \t\n\f]+\\(#[^\n]*\n[ \t\n\f]*\\)+")
(goto-char (match-end 0))
(skip-chars-forward " \t\n\f"))
@@ -3593,6 +4300,8 @@
(skip-chars-backward " \t\n\f")
(memq (preceding-char)
(append "address@hidden&*" nil))))
+ (setq bb t))
+ ((eobp)
(setq bb t)))))
(if bb
(goto-char i)
@@ -3605,15 +4314,16 @@
;; qtag means two-arg matcher, may be reset to
;; 2 or 3 later if some special quoting is needed.
;; e1 means matching-char matcher.
- (setq b (point)
+ (setq b (point) ; before the first delimiter
;; has 2 args
i2 (string-match "^\\([sy]\\|tr\\)$" argument)
;; We do not search to max, since we may be called from
;; some hook of fontification, and max is random
i (cperl-forward-re stop-point end
i2
- t st-l err-l argument)
- ;; Note that if `go', then it is considered as 1-arg
+ st-l err-l argument)
+ ;; If `go', then it is considered as 1-arg, `b1' is nil
+ ;; as in s/foo//x; the point is before final "slash"
b1 (nth 1 i) ; start of the second part
tag (nth 2 i) ; ender-char, true if second part
; is with matching chars []
@@ -3625,13 +4335,18 @@
(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
+ (and (if go (looking-at ".\\sw*x")
+ (looking-at "\\sw*x")) ; qr//x
(setq is-x-REx t))
+ (and (if go (looking-at ".\\sw*o")
+ (looking-at "\\sw*o")) ; //o
+ (setq is-o-REx t))
(if (null i)
;; Considered as 1arg form
(progn
@@ -3648,9 +4363,11 @@
(cperl-commentify b i t)
(if (looking-at "\\sw*e") ; s///e
(progn
+ ;; Cache the syntax info...
+ (setq cperl-syntax-state (cons state-point state))
(and
;; silent:
- (cperl-find-pods-heres b1 (1- (point)) t end)
+ (car (cperl-find-pods-heres b1 (1- (point)) t end))
;; Error
(goto-char (1+ max)))
(if (and tag (eq (preceding-char) ?\>))
@@ -3658,6 +4375,7 @@
(cperl-modify-syntax-type (1- (point))
cperl-st-ket)
(cperl-modify-syntax-type i cperl-st-bra)))
(put-text-property b i 'syntax-type 'string)
+ (put-text-property i (point) 'syntax-type 'multiline)
(if is-x-REx
(put-text-property b i 'indentable t)))
(cperl-commentify b1 (point) t)
@@ -3673,7 +4391,7 @@
(forward-word 1) ; skip modifiers s///s
(if tail (cperl-commentify tail (point) t))
(cperl-postpone-fontification
- e1 (point) 'face 'cperl-nonoverridable)))
+ e1 (point) 'face my-cperl-REx-modifiers-face)))
;; Check whether it is m// which means "previous match"
;; and highlight differently
(setq is-REx
@@ -3691,7 +4409,7 @@
(not (looking-at "split\\>")))
(error t))))
(cperl-postpone-fontification
- b e 'face font-lock-function-name-face)
+ b e 'face font-lock-warning-face)
(if (or i2 ; Has 2 args
(and cperl-fontify-m-as-s
(or
@@ -3700,54 +4418,355 @@
(not (eq ?\< (char-after b)))))))
(progn
(cperl-postpone-fontification
- b (cperl-1+ b) 'face font-lock-constant-face)
+ b (cperl-1+ b) 'face my-cperl-delimiters-face)
(cperl-postpone-fontification
- (1- e) e 'face font-lock-constant-face)))
+ (1- e) e 'face my-cperl-delimiters-face)))
(if (and is-REx cperl-regexp-scan)
- ;; Process RExen better
+ ;; Process RExen: embedded comments, charclasses and ]
+;;;/\3333\xFg\x{FFF}a\ppp\PPP\qqq\C\99f(?{ foo })(??{ foo })/;
+;;;/a\.b[^a[:ff:]b]x$ab->$[|$,$ab->[cd]->[ef]|$ab[xy].|^${a,b}{c,d}/;
+;;;/(?<=foo)(?<!bar)(x)(?:$ab|\$\/)$|\\\b\x888\776\[\:$/xxx;
+;;;m?(\?\?{b,a})? + m/(??{aa})(?(?=xx)aa|bb)(?#aac)/;
+;;;m$(^ab[c]\$)$ + m+(^ab[c]\$\+)+ + m](^ab[c\]$|.+)] + m)(^ab[c]$|.+\));
+;;;m^a[\^b]c^ + m.a[^b]\.c.;
(save-excursion
(goto-char (1+ b))
- (while
- (and (< (point) e)
- (re-search-forward
+ ;; First
+ (cperl-look-at-leading-count is-x-REx e)
+ (setq hairy-RE
+ (concat
(if is-x-REx
(if (eq (char-after b) ?\#)
"\\((\\?\\\\#\\)\\|\\(\\\\#\\)"
"\\((\\?#\\)\\|\\(#\\)")
+ ;; keep the same count: add a fake group
(if (eq (char-after b) ?\#)
- "\\((\\?\\\\#\\)"
- "\\((\\?#\\)"))
- (1- e) 'to-end))
+ "\\((\\?\\\\#\\)\\(\\)"
+ "\\((\\?#\\)\\(\\)"))
+ "\\|"
+ "\\(\\[\\)" ; 3=[
+ "\\|"
+ "\\(]\\)" ; 4=]
+ "\\|"
+ ;; XXXX Will not be able to use it in s)))
+ (if (eq (char-after b) ?\) )
+ "\\())))\\)" ; Will never match
+ (if (eq (char-after b) ?? )
+ ;;"\\((\\\\\\?\\(\\\\\\?\\)?{\\)"
+ "\\((\\\\\\?\\\\\\?{\\|()\\\\\\?{\\)"
+ "\\((\\?\\??{\\)")) ; 5= (??{ (?{
+ "\\|" ; 6= 0-length, 7: name, 8,9:code,
10:group
+ "\\(" ;; XXXX 1-char variables, exc. |()\s
+ "address@hidden"
+ "\\("
+ "[_a-zA-Z:][_a-zA-Z0-9:]*"
+ "\\|"
+ "{[^{}]*}" ; only one-level allowed
+ "\\|"
+ "[^{(|) \t\r\n\f]"
+ "\\)"
+ "\\(" ;;8,9:code part of array/hash elt
+ "\\(" "->" "\\)?"
+ "\\[[^][]*\\]"
+ "\\|"
+ "{[^{}]*}"
+ "\\)*"
+ ;; XXXX: what if u is delim?
+ "\\|"
+ "[)^|$.*?+]"
+ "\\|"
+ "{[0-9]+}"
+ "\\|"
+ "{[0-9]+,[0-9]*}"
+ "\\|"
+ "\\\\[luLUEQbBAzZG]"
+ "\\|"
+ "(" ; Group opener
+ "\\(" ; 10 group opener follower
+ "\\?\\((\\?\\)" ; 11: in (?(?=C)A|B)
+ "\\|"
+ "\\?[:=!>?{]" ; "?" something
+ "\\|"
+ "\\?[-imsx]+[:)]" ; (?i) (?-s:.)
+ "\\|"
+ "\\?([0-9]+)" ; (?(1)foo|bar)
+ "\\|"
+ "\\?<[=!]"
+ ;;;"\\|"
+ ;;; "\\?"
+ "\\)?"
+ "\\)"
+ "\\|"
+ "\\\\\\(.\\)" ; 12=\SYMBOL
+ ))
+ (while
+ (and (< (point) (1- e))
+ (re-search-forward hairy-RE (1- e) 'to-end))
(goto-char (match-beginning 0))
- (setq REx-comment-start (point)
- was-comment t)
+ (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
- ;; XXX not working if outside delimiter is #
- (eq (preceding-char) ?\\)
- (= (% (skip-chars-backward "$\\\\") 2) -1)))
- ;; Not a comment, avoid loop:
- (progn (setq was-comment nil)
- (forward-char 1))
- (if (match-beginning 2)
- (progn
+ (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
+ (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 (search-forward ")" (1- e) 'toend)
+ (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-comment-start))))
+ REx-subgr-start))))
(if (>= (point) e)
(goto-char (1- e)))
- (if was-comment
- (progn
- (setq REx-comment-end (point))
+ (cond
+ (was-subgr
+ (setq REx-subgr-end (point))
(cperl-commentify
- REx-comment-start REx-comment-end nil)
+ REx-subgr-start REx-subgr-end nil)
(cperl-postpone-fontification
- REx-comment-start REx-comment-end
+ 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)
@@ -3755,80 +4774,61 @@
(if i2
(progn
(cperl-postpone-fontification
- (1- e1) e1 'face font-lock-constant-face)
+ (1- e1) e1 'face my-cperl-delimiters-face)
(if (assoc (char-after b) cperl-starters)
+ (progn
(cperl-postpone-fontification
- b1 (1+ b1) 'face font-lock-constant-face))))
+ b1 (1+ b1) 'face my-cperl-delimiters-face)
+ (put-text-property b1 (1+ b1)
+ 'REx-part2 t)))))
(if (> (point) max)
(setq tmpend tb))))
- ((match-beginning 13) ; sub with prototypes
- (setq b (match-beginning 0))
- (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:
- ;; "\\(\\<sub[ \t\n\f]+\\|[&address@hidden)[a-zA-Z0-9_]*'")
- ((match-beginning 15) ; old $abc'efg syntax
- (setq bb (match-end 0)
- b (match-beginning 0)
- state (parse-partial-sexp
- state-point b nil nil state)
- state-point b)
- (if (nth 3 state) ; in string
+ ((match-beginning 17) ; sub with prototype or attribute
+ ;; 1+6+2+1+1=11 extra () before this (sub with proto/attr):
+ ;;"\\<sub\\>\\(" ;12
+ ;; cperl-white-and-comment-rex ;13
+ ;; "\\([a-zA-Z_:'0-9]+\\)\\)?" ; name ;14
+ ;;"\\(" cperl-maybe-white-and-comment-rex ;15,16
+ ;; "\\(([^()]*)\\|:[^:]\\)\\)" ; 17:proto or attribute start
+ (setq b1 (match-beginning 14) e1 (match-end 14))
+ (if (memq (char-after (1- b))
+ '(?\$ ?\@ ?\% ?\& ?\*))
nil
- (put-text-property (1- bb) bb 'syntax-table cperl-st-word))
+ (goto-char b)
+ (if (eq (char-after (match-beginning 17)) ?\( )
+ (progn
+ (cperl-commentify ; Prototypes; mark as string
+ (match-beginning 17) (match-end 17) t)
+ (goto-char (match-end 0))
+ ;; Now look for attributes after prototype:
+ (forward-comment (buffer-size))
+ (and (looking-at ":[^:]")
+ (cperl-find-sub-attrs st-l b1 e1 b)))
+ ;; treat attributes without prototype
+ (goto-char (match-beginning 17))
+ (cperl-find-sub-attrs st-l b1 e1 b))))
+ ;; 1+6+2+1+1+6+1=18 extra () before this:
+ ;; "\\(\\<sub[ \t\n\f]+\\|[&address@hidden)[a-zA-Z0-9_]*'")
+ ((match-beginning 19) ; old $abc'efg syntax
+ (setq bb (match-end 0))
+ ;;;(if (nth 3 state) nil ; in string
+ (put-text-property (1- bb) bb 'syntax-table cperl-st-word)
(goto-char bb))
- ;; 1+6+2+1+1+2+1+1=15 extra () before this:
+ ;; 1+6+2+1+1+6+1+1=19 extra () before this:
;; "__\\(END\\|DATA\\)__"
- ((match-beginning 16) ; __END__, __DATA__
- (setq bb (match-end 0)
- b (match-beginning 0)
- state (parse-partial-sexp
- state-point b nil nil state)
- state-point b)
- (if (or (nth 3 state) (nth 4 state))
- nil
+ ((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))
- (goto-char bb))
- ((match-beginning 17) ; "\\\\\\(['`\"($]\\)"
- ;; Trailing backslash ==> non-quoting outside string/comment
- (setq bb (match-end 0)
- b (match-beginning 0))
+ ;; "\\\\\\(['`\"($]\\)"
+ ((match-beginning 21)
+ ;; Trailing backslash; make non-quoting outside string/comment
+ (setq bb (match-end 0))
(goto-char b)
(skip-chars-backward "\\\\")
;;;(setq i2 (= (% (skip-chars-backward "\\\\") 2) -1))
- (setq state (parse-partial-sexp
- state-point b nil nil state)
- state-point b)
- (if (or (nth 3 state) (nth 4 state) )
- nil
- (cperl-modify-syntax-type b cperl-st-punct))
+ (cperl-modify-syntax-type b cperl-st-punct)
(goto-char bb))
(t (error "Error in regexp of the sniffer")))
(if (> (point) stop-point)
@@ -3839,7 +4839,10 @@
(or (car err-l) (setcar err-l b)))
(goto-char stop-point))))
(setq cperl-syntax-state (cons state-point state)
- cperl-syntax-done-to (or tmpend (max (point) max))))
+ ;; Do not mark syntax as done past tmpend???
+ cperl-syntax-done-to (or tmpend (max (point) max)))
+ ;;(message "state-at=%s, done-to=%s" state-point
cperl-syntax-done-to)
+ )
(if (car err-l) (goto-char (car err-l))
(or non-inter
(message "Scanning for \"hard\" Perl constructions... done"))))
@@ -3851,48 +4854,91 @@
;; cperl-mode-syntax-table.
;; (set-syntax-table cperl-mode-syntax-table)
)
- (car err-l)))
+ (list (car err-l) overshoot)))
+
+(defun cperl-find-pods-heres-region (min max)
+ (interactive "r")
+ (cperl-find-pods-heres min max))
(defun cperl-backward-to-noncomment (lim)
;; Stops at lim or after non-whitespace that is not in comment
+ ;; XXXX Wrongly understands end-of-multiline strings with # as comment
(let (stop p pr)
- (while (and (not stop) (> (point) (or lim 1)))
+ (while (and (not stop) (> (point) (or lim (point-min))))
(skip-chars-backward " \t\n\f" lim)
(setq p (point))
(beginning-of-line)
(if (memq (setq pr (get-text-property (point) 'syntax-type))
'(pod here-doc here-doc-delim))
(cperl-unwind-to-safe nil)
- (or (looking-at "^[ \t]*\\(#\\|$\\)")
+ (or (and (looking-at "^[ \t]*\\(#\\|$\\)")
+ (not (memq pr '(string prestring))))
(progn (cperl-to-comment-or-eol) (bolp))
(progn
(skip-chars-backward " \t")
(if (< p (point)) (goto-char p))
(setq stop t)))))))
+;; Used only in `cperl-calculate-indent'...
+(defun cperl-block-p () ; Do not C-M-q ! One string
contains ";" !
+ ;; Positions is before ?\{. Checks whether it starts a block.
+ ;; No save-excursion! This is more a distinguisher of a block/hash ref...
+ (cperl-backward-to-noncomment (point-min))
+ (or (memq (preceding-char) (append ";){}$@&%\C-@" nil)) ; Or label! \C-@ at
bobp
+ ; Label may be mixed up with `$blah :'
+ (save-excursion (cperl-after-label))
+ (get-text-property (cperl-1- (point)) 'attrib-group)
+ (and (memq (char-syntax (preceding-char)) '(?w ?_))
+ (progn
+ (backward-sexp)
+ ;; sub {BLK}, print {BLK} $data, but NOT `bless', `return', `tr'
+ (or (and (looking-at "[a-zA-Z0-9_:]+[ \t\n\f]*[{#]") ; Method call
syntax
+ (not (looking-at
"\\(bless\\|return\\|q[wqrx]?\\|tr\\|[smy]\\)\\>")))
+ ;; sub bless::foo {}
+ (progn
+ (cperl-backward-to-noncomment (point-min))
+ (and (eq (preceding-char) ?b)
+ (progn
+ (forward-sexp -1)
+ (looking-at "sub[ \t\n\f#]")))))))))
+
+;;; What is the difference of (cperl-after-block-p lim t) and (cperl-block-p)?
+;;; No save-excursion; condition-case ... In (cperl-block-p) the block
+;;; may be a part of an in-statement construct, such as
+;;; ${something()}, print {FH} $data.
+;;; Moreover, one takes positive approach (looks for else,grep etc)
+;;; another negative (looks for bless,tr etc)
(defun cperl-after-block-p (lim &optional pre-block)
- "Return true if the preceeding } ends a block or a following { starts one.
-Would not look before LIM. If PRE-BLOCK is nil checks preceeding }.
-otherwise following {."
- ;; We suppose that the preceding char is }.
+ "Return true if the preceeding } (if PRE-BLOCK, following {) delimits a
block.
+Would not look before LIM. Assumes that LIM is a good place to begin a
+statement. The kind of block we treat here is one after which a new
+statement would start; thus the block in ${func()} does not count."
(save-excursion
(condition-case nil
(progn
(or pre-block (forward-sexp -1))
(cperl-backward-to-noncomment lim)
(or (eq (point) lim)
- (eq (preceding-char) ?\) ) ; if () {} sub f () {}
- (if (eq (char-syntax (preceding-char)) ?w) ; else {}
+ ;; if () {} // sub f () {} // sub f :a(') {}
+ (eq (preceding-char) ?\) )
+ ;; label: {}
+ (save-excursion (cperl-after-label))
+ ;; sub :attr {}
+ (get-text-property (cperl-1- (point)) 'attrib-group)
+ (if (memq (char-syntax (preceding-char)) '(?w ?_)) ; else {}
(save-excursion
(forward-sexp -1)
- (or (looking-at
"\\(else\\|continue\\|grep\\|map\\|BEGIN\\|END\\|CHECK\\|INIT\\)\\>")
+ ;; else {} but not else::func {}
+ (or (and (looking-at
"\\(else\\|continue\\|grep\\|map\\|BEGIN\\|END\\|CHECK\\|INIT\\)\\>")
+ (not (looking-at "\\(\\sw\\|_\\)+::")))
;; sub f {}
(progn
(cperl-backward-to-noncomment lim)
- (and (eq (char-syntax (preceding-char)) ?w)
+ (and (eq (preceding-char) ?b)
(progn
(forward-sexp -1)
- (looking-at "sub\\>"))))))
+ (looking-at "sub[ \t\n\f#]"))))))
+ ;; What preceeds is not word... XXXX Last statement in sub???
(cperl-after-expr-p lim))))
(error nil))))
@@ -3914,14 +4960,12 @@
(if (get-text-property (point) 'here-doc-group)
(progn
(goto-char
- (or (previous-single-property-change (point) 'here-doc-group)
- (point)))
+ (cperl-beginning-of-property (point) 'here-doc-group))
(beginning-of-line 0)))
(if (get-text-property (point) 'in-pod)
(progn
(goto-char
- (or (previous-single-property-change (point) 'in-pod)
- (point)))
+ (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
@@ -3933,7 +4977,7 @@
(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))))
@@ -3949,6 +4993,44 @@
(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 "address@hidden")))
+ (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))
@@ -3989,18 +5071,51 @@
(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)
+ (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)))
- (setq done t)))
+ (setq tmp-end (point))))
(goto-char tmp-end)
(setq tmp-end (point-marker)))
(if cperl-indent-region-fix-constructs
@@ -4029,9 +5144,9 @@
;; Looking at:
;; }
;; else
- (if (and cperl-merge-trailing-else
- (looking-at
- "[ \t]*}[ \t]*\n[ \t\n]*\\(els\\(e\\|if\\)\\|continue\\)\\>"))
+ (if cperl-merge-trailing-else
+ (if (looking-at
+ "[ \t]*}[ \t]*\n[ \t\n]*\\(els\\(e\\|if\\)\\|continue\\)\\>")
(progn
(search-forward "}")
(setq p (point))
@@ -4039,6 +5154,16 @@
(delete-region p (point))
(insert (make-string cperl-indent-region-fix-constructs ?\s))
(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\\)\\>")
@@ -4075,19 +5200,19 @@
(insert
(make-string cperl-indent-region-fix-constructs ?\s))
(beginning-of-line)))
- ;; Looking at:
- ;; } foreach my $var () {
+ ;; Looking at (with or without "}" at start, ending after "({"):
+ ;; } foreach my $var () OR {
(if (looking-at
"[ \t]*\\(}[
\t]*\\)?\\<\\(\\els\\(e\\|if\\)\\|continue\\|if\\|unless\\|while\\|for\\(each\\)?\\(\\([
\t]+\\(my\\|local\\|our\\)\\)?[ \t]*\\$[_a-zA-Z0-9]+\\)?\\|until\\)\\>\\([
\t]*(\\|[ \t\n]*{\\)\\|[ \t]*{")
(progn
- (setq ml (match-beginning 8))
+ (setq ml (match-beginning 8)) ; "(" or "{" after control word
(re-search-forward "[({]")
(forward-char -1)
(setq p (point))
(if (eq (following-char) ?\( )
(progn
(forward-sexp 1)
- (setq pp (point)))
+ (setq pp (point))) ; past parenth-group
;; after `else' or nothing
(if ml ; after `else'
(skip-chars-backward " \t\n")
@@ -4097,13 +5222,13 @@
;; 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
@@ -4126,7 +5251,17 @@
(skip-chars-forward " \t\n")
(delete-region pp (point))
(insert
- (make-string cperl-indent-region-fix-constructs ?\s))))
+ (make-string cperl-indent-region-fix-constructs ?\ )))
+ ((and (looking-at "[\t ]*{")
+ (if ml cperl-extra-newline-before-brace-multiline
+ cperl-extra-newline-before-brace))
+ (delete-horizontal-space)
+ (insert "\n")
+ (setq ret (point))
+ (if (cperl-indent-line parse-data)
+ (progn
+ (cperl-fix-line-spacing end parse-data)
+ (setq ret (point))))))
;; Now we are before `{'
(if (looking-at "[ \t\n]*{[ \t]*[^ \t\n#]")
(progn
@@ -4278,7 +5413,7 @@
;; (interactive "P") ; Only works when called from fill-paragraph. -stef
(let (;; Non-nil if the current line contains a comment.
has-comment
-
+ fill-paragraph-function ; do not recurse
;; If has-comment, the appropriate fill-prefix for the comment.
comment-fill-prefix
;; Line that contains code and comment (or nil)
@@ -4310,7 +5445,7 @@
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.
@@ -4335,8 +5470,13 @@
(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#]*$"))
@@ -4352,7 +5492,8 @@
(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
@@ -4403,8 +5544,8 @@
(let ((index-alist '()) (index-pack-alist '()) (index-pod-alist '())
(index-unsorted-alist '()) (i-s-f (default-value 'imenu-sort-function))
(index-meth-alist '()) meth
- packages ends-ranges p marker
- (prev-pos 0) char fchar index index1 name (end-range 0) package)
+ packages ends-ranges p marker is-proto
+ (prev-pos 0) is-pack index index1 name (end-range 0) package)
(goto-char (point-min))
(cperl-update-syntaxification (point-max) (point-max))
;; Search for the function
@@ -4412,72 +5553,81 @@
(while (re-search-forward
(or regexp cperl-imenu--function-name-regexp-perl)
nil t)
+ ;; 2=package-group, 5=package-name 8=sub-name
(cond
((and ; Skip some noise if building tags
- (match-beginning 2) ; package or sub
- (eq (char-after (match-beginning 2)) ?p) ; package
+ (match-beginning 5) ; package name
+ ;;(eq (char-after (match-beginning 2)) ?p) ; package
(not (save-match-data
(looking-at "[ \t\n]*;")))) ; Plain text word 'package'
nil)
((and
- (match-beginning 2) ; package or sub
+ (or (match-beginning 2)
+ (match-beginning 8)) ; package or sub
;; Skip if quoted (will not skip multi-line ''-strings :-():
(null (get-text-property (match-beginning 1) 'syntax-table))
(null (get-text-property (match-beginning 1) 'syntax-type))
(null (get-text-property (match-beginning 1) 'in-pod)))
- (save-excursion
- (goto-char (match-beginning 2))
- (setq fchar (following-char)))
+ (setq is-pack (match-beginning 2))
;; (if (looking-at "([^()]*)[ \t\n\f]*")
;; (goto-char (match-end 0))) ; Messes what follows
- (setq char (following-char) ; ?\; for "sub foo () ;"
- meth nil
+ (setq meth nil
p (point))
(while (and ends-ranges (>= p (car ends-ranges)))
;; delete obsolete entries
(setq ends-ranges (cdr ends-ranges) packages (cdr packages)))
(setq package (or (car packages) "")
end-range (or (car ends-ranges) 0))
- (if (eq fchar ?p)
- (setq name (buffer-substring (match-beginning 3) (match-end 3))
+ (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)
- end-range
+ 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)
+ (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 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)))))
@@ -4541,29 +5691,20 @@
(defun cperl-outline-level ()
(looking-at outline-regexp)
(cond ((not (match-beginning 1)) 0) ; beginning-of-file
- ((match-beginning 2)
- (if (eq (char-after (match-beginning 2)) ?p)
- 0 ; package
- 1)) ; sub
- ((match-beginning 5)
- (if (eq (char-after (match-beginning 5)) ?1)
- 1 ; head1
- 2)) ; head2
- (t 3))) ; should not happen
+;;;; 2=package-group, 5=package-name 8=sub-name 16=head-level
+ ((match-beginning 2) 0) ; package
+ ((match-beginning 8) 1) ; sub
+ ((match-beginning 16)
+ (- (char-after (match-beginning 16)) ?0)) ; headN ==> N
+ (t 5))) ; should not happen
(defvar cperl-compilation-error-regexp-alist
- ;; This look like a paranoiac regexp: could anybody find a better one?
(which WORK).
+ ;; This look like a paranoiac regexp: could anybody find a better one?
(which WORKS).
'(("^[^\n]* \\(file\\|at\\) \\([^ \t\n]+\\) [^\n]*line \\([0-9]+\\)[\\., \n]"
2 3))
"Alist that specifies how to match errors in perl output.")
-(if (fboundp 'eval-after-load)
- (eval-after-load
- "mode-compile"
- '(setq perl-compilation-error-regexp-alist
- cperl-compilation-error-regexp-alist)))
-
(defun cperl-windowed-init ()
"Initialization under windowed version."
@@ -4604,9 +5745,12 @@
;; 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")
+ "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
@@ -4629,7 +5773,7 @@
'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;():,\|&]"
@@ -4713,7 +5857,7 @@
;; "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"
@@ -4728,15 +5872,38 @@
"u\\(se\\|n\\(shift\\|ti\\(l\\|e\\)\\|def\\|less\\)\\)\\|"
"while\\|y\\|__\\(END\\|DATA\\)__" ;__DATA__ added manually
"\\|[sm]" ; Added manually
- "\\)\\>") 2 'cperl-nonoverridable)
+ "\\)\\>") 2 'cperl-nonoverridable-face)
;; (mapconcat 'identity
;; '("#endif" "#else" "#ifdef" "#ifndef" "#if"
;; "#include" "#define" "#undef")
;; "\\|")
'("-[rwxoRWXOezsfdlpSbctugkTBMAC]\\>\\([ \t]+_\\>\\)?" 0
font-lock-function-name-face keep) ; Not very good, triggers at
"[a-z]"
- '("\\<sub[ \t]+\\([^ \t{;()]+\\)[ \t]*\\(([^()]*)[ \t]*\\)?[#{\n]" 1
- font-lock-function-name-face)
+ ;; This highlights declarations and definitions differenty.
+ ;; We do not try to highlight in the case of attributes:
+ ;; it is already done by `cperl-find-pods-heres'
+ (list (concat "\\<sub"
+ cperl-white-and-comment-rex ; whitespace/comments
+ "\\([^ \n\t{;()]+\\)" ; 2=name (assume non-anonymous)
+ "\\("
+ cperl-maybe-white-and-comment-rex
;whitespace/comments?
+ "([^()]*)\\)?" ; prototype
+ cperl-maybe-white-and-comment-rex ;
whitespace/comments?
+ "[{;]")
+ 2 (if cperl-font-lock-multiline
+ '(if (eq (char-after (cperl-1- (match-end 0))) ?\{ )
+ 'font-lock-function-name-face
+ 'font-lock-variable-name-face)
+ ;; need to manually set 'multiline' for older font-locks
+ '(progn
+ (if (< 1 (count-lines (match-beginning 0)
+ (match-end 0)))
+ (put-text-property
+ (+ 3 (match-beginning 0)) (match-end 0)
+ 'syntax-type 'multiline))
+ (if (eq (char-after (cperl-1- (match-end 0))) ?\{ )
+ 'font-lock-function-name-face
+ 'font-lock-variable-name-face))))
'("\\<\\(package\\|require\\|use\\|import\\|no\\|bootstrap\\)[
\t]+\\([a-zA-z_][a-zA-z_0-9:]*\\)[ \t;]" ; require A if B;
2 font-lock-function-name-face)
'("^[ \t]*format[ \t]+\\([a-zA-z_][a-zA-z_0-9:]*\\)[ \t]*=[ \t]*$"
@@ -4772,12 +5939,56 @@
(2 '(restart 2 nil) nil t)))
nil t))) ; local variables, multiple
(font-lock-anchored
- '("^[ \t{}]*\\(my\\|local\\|our\\)[ \t]*\\(([
\t]*\\)?\\(address@hidden:]+\\)"
- (3 font-lock-variable-name-face)
- ("\\=[ \t]*,[ \t]*\\(address@hidden:]+\\)"
- nil nil
- (1 font-lock-variable-name-face))))
- (t '("^[ \t{}]*\\(my\\|local\\our\\)[ \t]*\\(([
\t]*\\)?\\(address@hidden:]+\\)"
+ ;; 1=my_etc, 2=white? 3=(+white? 4=white? 5=var
+ (` ((, (concat "\\<\\(my\\|local\\|our\\)"
+ cperl-maybe-white-and-comment-rex
+ "\\(("
+ cperl-maybe-white-and-comment-rex
+
"\\)?\\(address@hidden([a-zA-Z0-9_:]+\\|[^a-zA-Z0-9_]\\)\\)"))
+ (5 (, (if cperl-font-lock-multiline
+ 'font-lock-variable-name-face
+ '(progn (setq cperl-font-lock-multiline-start
+ (match-beginning 0))
+ 'font-lock-variable-name-face))))
+ ((, (concat "\\="
+ cperl-maybe-white-and-comment-rex
+ ","
+ cperl-maybe-white-and-comment-rex
+
"\\(address@hidden([a-zA-Z0-9_:]+\\|[^a-zA-Z0-9_]\\)\\)"))
+ ;; Bug in font-lock: limit is used not only to limit
+ ;; searches, but to set the "extend window for
+ ;; facification" property. Thus we need to minimize.
+ (, (if cperl-font-lock-multiline
+ '(if (match-beginning 3)
+ (save-excursion
+ (goto-char (match-beginning 3))
+ (condition-case nil
+ (forward-sexp 1)
+ (error
+ (condition-case nil
+ (forward-char 200)
+ (error nil)))) ; typeahead
+ (1- (point))) ; report limit
+ (forward-char -2)) ; disable continued expr
+ '(if (match-beginning 3)
+ (point-max) ; No limit for continuation
+ (forward-char -2)))) ; disable continued expr
+ (, (if cperl-font-lock-multiline
+ nil
+ '(progn ; Do at end
+ ;; "my" may be already fontified (POD),
+ ;; so cperl-font-lock-multiline-start is nil
+ (if (or (not cperl-font-lock-multiline-start)
+ (> 2 (count-lines
+ cperl-font-lock-multiline-start
+ (point))))
+ nil
+ (put-text-property
+ (1+ cperl-font-lock-multiline-start) (point)
+ 'syntax-type 'multiline))
+ (setq cperl-font-lock-multiline-start nil))))
+ (3 font-lock-variable-name-face)))))
+ (t '("^[ \t{}]*\\(my\\|local\\|our\\)[ \t]*\\(([
\t]*\\)?\\(address@hidden:]+\\)"
3 font-lock-variable-name-face)))
'("\\<for\\(each\\)?\\([ \t]+\\(my\\|local\\|our\\)\\)?[
\t]*\\(\\$[a-zA-Z_][a-zA-Z_0-9]*\\)[ \t]*("
4 font-lock-variable-name-face)
@@ -4787,21 +5998,32 @@
(setq
t-font-lock-keywords-1
(and (fboundp 'turn-on-font-lock) ; Check for newer font-lock
- (not cperl-xemacs-p) ; not yet as of XEmacs 19.12
+ ;; not yet as of XEmacs 19.12, works with 21.1.11
+ (or
+ (not cperl-xemacs-p)
+ (string< "21.1.9" emacs-version)
+ (and (string< "21.1.10" emacs-version)
+ (string< emacs-version "21.1.2")))
'(
("\\(\\(address@hidden|\$#\\)[a-zA-Z_:][a-zA-Z0-9_:]*\\)" 1
(if (eq (char-after (match-beginning 2)) ?%)
- 'cperl-hash
- 'cperl-array)
+ 'cperl-hash-face
+ 'cperl-array-face)
t) ; arrays and hashes
("\\(\\(address@hidden)[a-zA-Z_:][a-zA-Z0-9_:]*\\)[
\t]*\\([[{]\\)"
1
(if (= (- (match-end 2) (match-beginning 2)) 1)
(if (eq (char-after (match-beginning 3)) ?{)
- 'cperl-hash
- 'cperl-array) ; arrays and hashes
+ 'cperl-hash-face
+ 'cperl-array-face) ; arrays and hashes
font-lock-variable-name-face) ; Just to put something
t)
+ ("\\(@\\|\\$#\\)\\(\\$+\\([a-zA-Z_:][a-zA-Z0-9_:]*\\|[^
\t\n]\\)\\)"
+ (1 cperl-array-face)
+ (2 font-lock-variable-name-face))
+ ("\\(%\\)\\(\\$+\\([a-zA-Z_:][a-zA-Z0-9_:]*\\|[^ \t\n]\\)\\)"
+ (1 cperl-hash-face)
+ (2 font-lock-variable-name-face))
;;("\\([smy]\\|tr\\)\\([^a-z_A-Z0-9]\\)\\(\\([^\n\\]*||\\)\\)\\2")
;;; Too much noise from \s* @s[ and friends
;;("\\(\\<\\([msy]\\|tr\\)[ \t]*\\([^
\t\na-zA-Z0-9_]\\)\\|\\(/\\)\\)"
@@ -4813,7 +6035,7 @@
(if cperl-highlight-variables-indiscriminately
(setq t-font-lock-keywords-1
(append t-font-lock-keywords-1
- (list '("[$*]{?\\(\\sw+\\)" 1
+ (list '("\\([$*]{?\\sw+\\)" 1
font-lock-variable-name-face)))))
(setq cperl-font-lock-keywords-1
(if cperl-syntaxify-by-font-lock
@@ -4866,27 +6088,35 @@
[nil nil t t
t]
nil
[nil nil t t
t])
+ (list 'font-lock-warning-face
+ ["Pink" "Red" "Gray50"
"LightGray"]
+ ["gray20" "gray90"
+ "gray80"
"gray20"]
+ [nil nil t t
t]
+ nil
+ [nil nil t t
t]
+ )
(list 'font-lock-constant-face
["CadetBlue" "Aquamarine" "Gray50"
"LightGray"]
nil
[nil nil t t
t]
nil
[nil nil t t
t])
- (list 'cperl-nonoverridable
+ (list 'cperl-nonoverridable-face
["chartreuse3" ("orchid1" "orange")
nil "Gray80"]
[nil nil "gray90"]
[nil nil nil t
t]
[nil nil t t]
[nil nil t t
t])
- (list 'cperl-array
+ (list 'cperl-array-face
["blue" "yellow" nil
"Gray80"]
["lightyellow2" ("navy" "os2blue" "darkgreen")
"gray90"]
t
nil
nil)
- (list 'cperl-hash
+ (list 'cperl-hash-face
["red" "red" nil
"Gray80"]
["lightyellow2" ("navy" "os2blue" "darkgreen")
"gray90"]
@@ -4909,15 +6139,17 @@
"Face for variable names")
(cperl-force-face font-lock-type-face
"Face for data types")
- (cperl-force-face cperl-nonoverridable
+ (cperl-force-face cperl-nonoverridable-face
"Face for data types from another group")
+ (cperl-force-face font-lock-warning-face
+ "Face for things which should stand out")
(cperl-force-face font-lock-comment-face
"Face for comments")
(cperl-force-face font-lock-function-name-face
"Face for function names")
- (cperl-force-face cperl-hash
+ (cperl-force-face cperl-hash-face
"Face for hashes")
- (cperl-force-face cperl-array
+ (cperl-force-face cperl-array-face
"Face for arrays")
;;(defvar font-lock-constant-face 'font-lock-constant-face)
;;(defvar font-lock-variable-name-face 'font-lock-variable-name-face)
@@ -4927,7 +6159,7 @@
;; "Face to use for data types."))
;;(or (boundp 'cperl-nonoverridable-face)
;; (defconst cperl-nonoverridable-face
- ;; 'cperl-nonoverridable
+ ;; 'cperl-nonoverridable-face
;; "Face to use for data types from another group."))
;;(if (not cperl-xemacs-p) nil
;; (or (boundp 'font-lock-comment-face)
@@ -4943,24 +6175,24 @@
;; 'font-lock-function-name-face
;; "Face to use for function names.")))
(if (and
- (not (cperl-is-face 'cperl-array))
+ (not (cperl-is-face 'cperl-array-face))
(cperl-is-face 'font-lock-emphasized-face))
- (copy-face 'font-lock-emphasized-face 'cperl-array))
+ (copy-face 'font-lock-emphasized-face 'cperl-array-face))
(if (and
- (not (cperl-is-face 'cperl-hash))
+ (not (cperl-is-face 'cperl-hash-face))
(cperl-is-face 'font-lock-other-emphasized-face))
- (copy-face 'font-lock-other-emphasized-face 'cperl-hash))
+ (copy-face 'font-lock-other-emphasized-face 'cperl-hash-face))
(if (and
- (not (cperl-is-face 'cperl-nonoverridable))
+ (not (cperl-is-face 'cperl-nonoverridable-face))
(cperl-is-face 'font-lock-other-type-face))
- (copy-face 'font-lock-other-type-face 'cperl-nonoverridable))
+ (copy-face 'font-lock-other-type-face 'cperl-nonoverridable-face))
;;(or (boundp 'cperl-hash-face)
;; (defconst cperl-hash-face
- ;; 'cperl-hash
+ ;; 'cperl-hash-face
;; "Face to use for hashes."))
;;(or (boundp 'cperl-array-face)
;; (defconst cperl-array-face
- ;; 'cperl-array
+ ;; 'cperl-array-face
;; "Face to use for arrays."))
;; Here we try to guess background
(let ((background
@@ -4999,17 +6231,17 @@
"pink")))
(t
(set-face-background 'font-lock-type-face "gray90"))))
- (if (cperl-is-face 'cperl-nonoverridable)
+ (if (cperl-is-face 'cperl-nonoverridable-face)
nil
- (copy-face 'font-lock-type-face 'cperl-nonoverridable)
+ (copy-face 'font-lock-type-face 'cperl-nonoverridable-face)
(cond
((eq background 'light)
- (set-face-foreground 'cperl-nonoverridable
+ (set-face-foreground 'cperl-nonoverridable-face
(if (x-color-defined-p "chartreuse3")
"chartreuse3"
"chartreuse")))
((eq background 'dark)
- (set-face-foreground 'cperl-nonoverridable
+ (set-face-foreground 'cperl-nonoverridable-face
(if (x-color-defined-p "orchid1")
"orchid1"
"orange")))))
@@ -5061,15 +6293,15 @@
'(setq ps-bold-faces
;; font-lock-variable-name-face
;; font-lock-constant-face
- (append '(cperl-array cperl-hash)
+ (append '(cperl-array-face cperl-hash-face)
ps-bold-faces)
ps-italic-faces
;; font-lock-constant-face
- (append '(cperl-nonoverridable cperl-hash)
+ (append '(cperl-nonoverridable-face cperl-hash-face)
ps-italic-faces)
ps-underlined-faces
;; font-lock-type-face
- (append '(cperl-array cperl-hash underline cperl-nonoverridable)
+ (append '(cperl-array-face cperl-hash-face underline
cperl-nonoverridable-face)
ps-underlined-faces))))
(defvar ps-print-face-extension-alist)
@@ -5102,27 +6334,27 @@
;;; (defvar ps-italic-faces nil)
;;; (setq ps-bold-faces
;;; (append '(font-lock-emphasized-face
-;;; cperl-array
+;;; cperl-array-face
;;; font-lock-keyword-face
;;; font-lock-variable-name-face
;;; font-lock-constant-face
;;; font-lock-reference-face
;;; font-lock-other-emphasized-face
-;;; cperl-hash)
+;;; cperl-hash-face)
;;; ps-bold-faces))
;;; (setq ps-italic-faces
-;;; (append '(cperl-nonoverridable
+;;; (append '(cperl-nonoverridable-face
;;; font-lock-constant-face
;;; font-lock-reference-face
;;; font-lock-other-emphasized-face
-;;; cperl-hash)
+;;; cperl-hash-face)
;;; ps-italic-faces))
;;; (setq ps-underlined-faces
;;; (append '(font-lock-emphasized-face
-;;; cperl-array
+;;; cperl-array-face
;;; font-lock-other-emphasized-face
-;;; cperl-hash
-;;; cperl-nonoverridable font-lock-type-face)
+;;; cperl-hash-face
+;;; cperl-nonoverridable-face font-lock-type-face)
;;; ps-underlined-faces))
;;; (cons 'font-lock-type-face ps-underlined-faces))
@@ -5132,79 +6364,211 @@
(defconst cperl-styles-entries
'(cperl-indent-level cperl-brace-offset cperl-continued-brace-offset
cperl-label-offset cperl-extra-newline-before-brace
+ cperl-extra-newline-before-brace-multiline
cperl-merge-trailing-else
cperl-continued-statement-offset))
+(defconst cperl-style-examples
+"##### Numbers etc are: cperl-indent-level cperl-brace-offset
+##### cperl-continued-brace-offset cperl-label-offset
+##### cperl-continued-statement-offset
+##### cperl-merge-trailing-else cperl-extra-newline-before-brace
+
+########### (Do not forget cperl-extra-newline-before-brace-multiline)
+
+### CPerl (=GNU - extra-newline-before-brace + merge-trailing-else)
2/0/0/-2/2/t/nil
+if (foo) {
+ bar
+ baz;
+ label:
+ {
+ boon;
+ }
+} else {
+ stop;
+}
+
+### PerlStyle (=CPerl with 4 as indent) 4/0/0/-4/4/t/nil
+if (foo) {
+ bar
+ baz;
+ label:
+ {
+ boon;
+ }
+} else {
+ stop;
+}
+
+### GNU 2/0/0/-2/2/nil/t
+if (foo)
+ {
+ bar
+ baz;
+ label:
+ {
+ boon;
+ }
+ }
+else
+ {
+ stop;
+ }
+
+### C++ (=PerlStyle with braces aligned with control words)
4/0/-4/-4/4/nil/t
+if (foo)
+{
+ bar
+ baz;
+ label:
+ {
+ boon;
+ }
+}
+else
+{
+ stop;
+}
+
+### BSD (=C++, but will not change preexisting
merge-trailing-else
+### and extra-newline-before-brace ) 4/0/-4/-4/4
+if (foo)
+{
+ bar
+ baz;
+ label:
+ {
+ boon;
+ }
+}
+else
+{
+ stop;
+}
+
+### K&R (=C++ with indent 5 - merge-trailing-else, but will not
+### change preexisting extra-newline-before-brace) 5/0/-5/-5/5/nil
+if (foo)
+{
+ bar
+ baz;
+ label:
+ {
+ boon;
+ }
+}
+else
+{
+ stop;
+}
+
+### Whitesmith (=PerlStyle, but will not change preexisting
+### extra-newline-before-brace and merge-trailing-else) 4/0/0/-4/4
+if (foo)
+ {
+ bar
+ baz;
+ label:
+ {
+ boon;
+ }
+ }
+else
+ {
+ stop;
+ }
+"
+"Examples of if/else with different indent styles (with v4.23).")
+
(defconst cperl-style-alist
- '(("CPerl" ; =GNU without extra-newline-before-brace
+ '(("CPerl" ;; =GNU - extra-newline-before-brace + cperl-merge-trailing-else
(cperl-indent-level . 2)
(cperl-brace-offset . 0)
(cperl-continued-brace-offset . 0)
(cperl-label-offset . -2)
+ (cperl-continued-statement-offset . 2)
(cperl-extra-newline-before-brace . nil)
- (cperl-merge-trailing-else . t)
- (cperl-continued-statement-offset . 2))
+ (cperl-extra-newline-before-brace-multiline . nil)
+ (cperl-merge-trailing-else . t))
+
("PerlStyle" ; CPerl with 4 as indent
(cperl-indent-level . 4)
(cperl-brace-offset . 0)
(cperl-continued-brace-offset . 0)
(cperl-label-offset . -4)
+ (cperl-continued-statement-offset . 4)
(cperl-extra-newline-before-brace . nil)
- (cperl-merge-trailing-else . t)
- (cperl-continued-statement-offset . 4))
+ (cperl-extra-newline-before-brace-multiline . nil)
+ (cperl-merge-trailing-else . t))
+
("GNU"
(cperl-indent-level . 2)
(cperl-brace-offset . 0)
(cperl-continued-brace-offset . 0)
(cperl-label-offset . -2)
+ (cperl-continued-statement-offset . 2)
(cperl-extra-newline-before-brace . t)
- (cperl-merge-trailing-else . nil)
- (cperl-continued-statement-offset . 2))
+ (cperl-extra-newline-before-brace-multiline . t)
+ (cperl-merge-trailing-else . nil))
+
("K&R"
(cperl-indent-level . 5)
(cperl-brace-offset . 0)
(cperl-continued-brace-offset . -5)
(cperl-label-offset . -5)
+ (cperl-continued-statement-offset . 5)
;;(cperl-extra-newline-before-brace . nil) ; ???
- (cperl-merge-trailing-else . nil)
- (cperl-continued-statement-offset . 5))
+ ;;(cperl-extra-newline-before-brace-multiline . nil)
+ (cperl-merge-trailing-else . nil))
+
("BSD"
(cperl-indent-level . 4)
(cperl-brace-offset . 0)
(cperl-continued-brace-offset . -4)
(cperl-label-offset . -4)
+ (cperl-continued-statement-offset . 4)
;;(cperl-extra-newline-before-brace . nil) ; ???
- (cperl-continued-statement-offset . 4))
+ ;;(cperl-extra-newline-before-brace-multiline . nil)
+ ;;(cperl-merge-trailing-else . nil) ; ???
+ )
+
("C++"
(cperl-indent-level . 4)
(cperl-brace-offset . 0)
(cperl-continued-brace-offset . -4)
(cperl-label-offset . -4)
(cperl-continued-statement-offset . 4)
- (cperl-merge-trailing-else . nil)
- (cperl-extra-newline-before-brace . t))
- ("Current")
+ (cperl-extra-newline-before-brace . t)
+ (cperl-extra-newline-before-brace-multiline . t)
+ (cperl-merge-trailing-else . nil))
+
("Whitesmith"
(cperl-indent-level . 4)
(cperl-brace-offset . 0)
(cperl-continued-brace-offset . 0)
(cperl-label-offset . -4)
+ (cperl-continued-statement-offset . 4)
;;(cperl-extra-newline-before-brace . nil) ; ???
- (cperl-continued-statement-offset . 4)))
- "(Experimental) list of variables to set to get a particular indentation
style.
-Should be used via `cperl-set-style' or via Perl menu.")
+ ;;(cperl-extra-newline-before-brace-multiline . nil)
+ ;;(cperl-merge-trailing-else . nil) ; ???
+ )
+ ("Current"))
+ "List of variables to set to get a particular indentation style.
+Should be used via `cperl-set-style' or via Perl menu.
+
+See examples in `cperl-style-examples'.")
(defun cperl-set-style (style)
"Set CPerl mode variables to use one of several different indentation styles.
The arguments are a string representing the desired style.
The list of styles is in `cperl-style-alist', available styles
-are GNU, K&R, BSD, C++ and Whitesmith.
+are CPerl, PerlStyle, GNU, K&R, BSD, C++ and Whitesmith.
The current value of style is memorized (unless there is a memorized
data already), may be restored by `cperl-set-style-back'.
Chosing \"Current\" style will not change style, so this may be used for
-side-effect of memorizing only."
+side-effect of memorizing only. Examples in `cperl-style-examples'."
(interactive
(let ((list (mapcar (function (lambda (elt) (list (car elt))))
cperl-style-alist)))
@@ -5375,6 +6739,8 @@
(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
@@ -5414,7 +6780,7 @@
\(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)
@@ -5452,22 +6818,25 @@
(if (/= (% col step) 0) (setq step (* step (1+ (/ col step)))))
(while
(progn
- (setq e (point))
- (skip-chars-backward " \t")
- (delete-region (point) e)
- (indent-to-column col) ;(make-string (- col (current-column)) ?\s))
+ (cperl-make-indent col)
(beginning-of-line 2)
(and (< (point) end)
(re-search-forward search end t)
(goto-char (match-beginning 0)))))))) ; No body
-(defun cperl-etags (&optional add all files)
+(defun cperl-etags (&optional add all files) ;; NOT USED???
"Run etags with appropriate options for Perl files.
If optional argument ALL is `recursive', will process Perl files
in subdirectories too."
(interactive)
(let ((cmd "etags")
- (args '("-l" "none" "-r" "/\\<\\(package\\|sub\\)[
\\t]+\\(\\([a-zA-Z0-9:_]*::\\)?\\([a-zA-Z0-9_]+\\)[ \\t]*\\(([^()]*)[
\t]*\\)?\\([{#]\\|$\\)\\)/\\4/"))
+ (args '("-l" "none" "-r"
+ ;; 1=fullname 2=package? 3=name
4=proto? 5=attrs? (VERY APPROX!)
+ "/\\<sub[
\\t]+\\(\\([a-zA-Z0-9:_]*::\\)?\\([a-zA-Z0-9_]+\\)\\)[ \\t]*\\(([^()]*)[
\t]*\\)?\\([ \t]*:[^#{;]*\\)?\\([{#]\\|$\\)/\\3/"
+ "-r"
+ "/\\<package[
\\t]+\\(\\([a-zA-Z0-9:_]*::\\)?\\([a-zA-Z0-9_]+\\)\\)[ \\t]*\\([#;]\\|$\\)/\\1/"
+ "-r"
+ "/\\<\\(package\\)[ \\t]*;/\\1;/"))
res)
(if add (setq args (cons "-a" args)))
(or files (setq files (list buffer-file-name)))
@@ -5539,6 +6908,29 @@
(message "indent-region/indent-sexp will %sbe automatically fix whitespace."
(if cperl-indent-region-fix-constructs "" "not ")))
+(defun cperl-toggle-set-debug-unwind (arg &optional backtrace)
+ "Toggle (or, with numeric argument, set) debugging state of syntaxification.
+Nonpositive numeric argument disables debugging messages. The message
+summarizes which regions it was decided to rescan for syntactic constructs.
+
+The message looks like this:
+
+ Syxify req=123..138 actual=101..146 done-to: 112=>146 statepos: 73=>117
+
+Numbers are character positions in the buffer. REQ provides the range to
+rescan requested by `font-lock'. ACTUAL is the range actually resyntaxified;
+for correct operation it should start and end outside any special syntactic
+construct. DONE-TO and STATEPOS indicate changes to internal caches maintained
+by CPerl."
+ (interactive "P")
+ (or arg
+ (setq arg (if (eq cperl-syntaxify-by-font-lock
+ (if backtrace 'backtrace 'message)) 0 1)))
+ (setq arg (if (> arg 0) (if backtrace 'backtrace 'message) t))
+ (setq cperl-syntaxify-by-font-lock arg)
+ (message "Debugging messages of syntax unwind %sabled."
+ (if (eq arg t) "dis" "en")))
+
;;;; Tags file creation.
(defvar cperl-tmp-buffer " *cperl-tmp*")
@@ -5679,13 +7071,22 @@
ret))))
(defun cperl-add-tags-recurse-noxs ()
- "Add to TAGS data for Perl and XSUB files in the current directory and kids.
+ "Add to TAGS data for \"pure\" Perl files in the current directory and kids.
Use as
emacs -batch -q -no-site-file -l emacs/cperl-mode.el \
- -f cperl-add-tags-recurse
+ -f cperl-add-tags-recurse-noxs
"
(cperl-write-tags nil nil t t nil t))
+(defun cperl-add-tags-recurse-noxs-fullpath ()
+ "Add to TAGS data for \"pure\" Perl in the current directory and kids.
+Writes down fullpath, so TAGS is relocatable (but if the build directory
+is relocated, the file TAGS inside it breaks). Use as
+ emacs -batch -q -no-site-file -l emacs/cperl-mode.el \
+ -f cperl-add-tags-recurse-noxs-fullpath
+"
+ (cperl-write-tags nil nil t t nil t ""))
+
(defun cperl-add-tags-recurse ()
"Add to TAGS file data for Perl files in the current directory and kids.
Use as
@@ -6019,7 +7420,7 @@
'("[^-\t <>=+]\\(--\\|\\+\\+\\)" ; var-- var++
"[a-zA-Z0-9_][|&][a-zA-Z0-9_$]" ; abc|def abc&def are often used.
"&[(a-zA-Z0-9_$]" ; &subroutine &(var->field)
- "<\\$?\\sw+\\(\\.\\sw+\\)?>" ; <IN> <stdin.h>
+ "<\\$?\\sw+\\(\\.\\(\\sw\\|_\\)+\\)?>" ; <IN> <stdin.h>
"-[a-zA-Z][ \t]+[_$\"'`a-zA-Z]" ; -f file, -t STDIN
"-[0-9]" ; -5
"\\+\\+" ; ++var
@@ -6051,8 +7452,7 @@
(interactive)
(let (found-bad (p (point)))
(setq last-nonmenu-event 13) ; To disable popup
- (with-no-warnings ; It is useful to push the mark here.
- (beginning-of-buffer))
+ (goto-char (point-min))
(map-y-or-n-p "Insert space here? "
(lambda (arg) (insert " "))
'cperl-next-bad-style
@@ -6448,7 +7848,7 @@
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)
@@ -6584,7 +7984,7 @@
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)
@@ -6685,7 +8085,7 @@
;; 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)
@@ -6714,7 +8114,7 @@
(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)
@@ -6724,7 +8124,7 @@
inline t)
(skip-chars-forward " \t")
(delete-region s (point))
- (indent-to-column c1)
+ (cperl-make-indent c1)
(while (and
inline
(looking-at
@@ -6750,6 +8150,16 @@
(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 "\\^?\\]")
@@ -6763,12 +8173,8 @@
(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))
@@ -6776,7 +8182,7 @@
(progn
(delete-horizontal-space)
(insert "\n")
- (indent-to-column c1)))
+ (cperl-make-indent c1)))
(setq tmp (point))
(forward-sexp 1)
;; (or (forward-sexp 1)
@@ -6836,7 +8242,7 @@
(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)
@@ -6859,10 +8265,7 @@
(/= (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
@@ -6931,7 +8334,7 @@
(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)
@@ -6940,10 +8343,7 @@
((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))))))
@@ -6982,96 +8382,197 @@
(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 "address@hidden")
+ (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 "\\<")
+ (and (= (char-syntax (preceding-char)) ?w)
(forward-sexp -1))
(if (looking-at "\\<\\(if\\|unless\\|while\\|until\\|for\\|foreach\\)\\>")
- (let ((pos1 (point))
- pos2 pos3 pos4 pos5 s1 s2 state p pos45
- (s0 (buffer-substring (match-beginning 0) (match-end 0))))
+ (let ((pre-if (point))
+ pre-A post-A pre-B post-B A B state p end-B-code is-block B-comment
+ (if-string (buffer-substring (match-beginning 0) (match-end 0))))
(forward-sexp 2)
- (setq pos3 (point))
+ (setq post-A (point))
(forward-sexp -1)
- (setq pos2 (point))
- (if (eq (following-char) ?\( )
+ (setq pre-A (point))
+ (setq is-block (and (eq (following-char) ?\( )
+ (save-excursion
+ (condition-case nil
+ (progn
+ (forward-sexp 2)
+ (forward-sexp -1)
+ (eq (following-char) ?\{ ))
+ (error nil)))))
+ (if is-block
(progn
- (goto-char pos3)
+ (goto-char post-A)
(forward-sexp 1)
- (setq pos5 (point))
+ (setq post-B (point))
(forward-sexp -1)
- (setq pos4 (point))
- ;; XXXX In fact may be `A if (B); {C}' ...
+ (setq pre-B (point))
(if (and (eq (following-char) ?\{ )
(progn
- (cperl-backward-to-noncomment pos3)
+ (cperl-backward-to-noncomment post-A)
(eq (preceding-char) ?\) )))
(if (condition-case nil
(progn
- (goto-char pos5)
+ (goto-char post-B)
(forward-sexp 1)
(forward-sexp -1)
(looking-at "\\<els\\(e\\|if\\)\\>"))
(error nil))
(error
- "`%s' (EXPR) {BLOCK} with `else'/`elsif'" s0)
- (goto-char (1- pos5))
- (cperl-backward-to-noncomment pos4)
+ "`%s' (EXPR) {BLOCK} with `else'/`elsif'" if-string)
+ (goto-char (1- post-B))
+ (cperl-backward-to-noncomment pre-B)
(if (eq (preceding-char) ?\;)
(forward-char -1))
- (setq pos45 (point))
- (goto-char pos4)
- (while (re-search-forward
"\\<\\(for\\|foreach\\|if\\|unless\\|while\\|until\\)\\>\\|;" pos45 t)
+ (setq end-B-code (point))
+ (goto-char pre-B)
+ (while (re-search-forward
"\\<\\(for\\|foreach\\|if\\|unless\\|while\\|until\\)\\>\\|;" end-B-code t)
(setq p (match-beginning 0)
- s1 (buffer-substring p (match-end 0))
- state (parse-partial-sexp pos4 p))
+ A (buffer-substring p (match-end 0))
+ state (parse-partial-sexp pre-B p))
(or (nth 3 state)
(nth 4 state)
(nth 5 state)
- (error "`%s' inside `%s' BLOCK" s1 s0))
+ (error "`%s' inside `%s' BLOCK" A if-string))
(goto-char (match-end 0)))
;; Finally got it
- (goto-char (1+ pos4))
+ (goto-char (1+ pre-B))
(skip-chars-forward " \t\n")
- (setq s2 (buffer-substring (point) pos45))
- (goto-char pos45)
+ (setq B (buffer-substring (point) end-B-code))
+ (goto-char end-B-code)
(or (looking-at ";?[ \t\n]*}")
(progn
(skip-chars-forward "; \t\n")
- (setq s2 (concat s2 "\n" (buffer-substring (point)
(1- pos5))))))
- (and (equal s2 "")
- (setq s2 "1"))
- (goto-char (1- pos3))
- (cperl-backward-to-noncomment pos2)
+ (setq B-comment
+ (buffer-substring (point) (1- post-B)))))
+ (and (equal B "")
+ (setq B "1"))
+ (goto-char (1- post-A))
+ (cperl-backward-to-noncomment pre-A)
(or (looking-at "[ \t\n]*)")
- (goto-char (1- pos3)))
+ (goto-char (1- post-A)))
(setq p (point))
- (goto-char (1+ pos2))
+ (goto-char (1+ pre-A))
(skip-chars-forward " \t\n")
- (setq s1 (buffer-substring (point) p))
- (delete-region pos4 pos5)
- (delete-region pos2 pos3)
- (goto-char pos1)
- (insert s2 " ")
+ (setq A (buffer-substring (point) p))
+ (delete-region pre-B post-B)
+ (delete-region pre-A post-A)
+ (goto-char pre-if)
+ (insert B " ")
+ (and B-comment (insert B-comment " "))
(just-one-space)
(forward-word 1)
- (setq pos1 (point))
- (insert " " s1 ";")
+ (setq pre-A (point))
+ (insert " " A ";")
(delete-horizontal-space)
+ (setq post-B (point))
+ (if (looking-at "#")
+ (indent-for-comment))
+ (goto-char post-B)
(forward-char -1)
(delete-horizontal-space)
- (goto-char pos1)
+ (goto-char pre-A)
(just-one-space)
- (cperl-indent-line))
- (error "`%s' (EXPR) not with an {BLOCK}" s0)))
- (error "`%s' not with an (EXPR)" s0)))
- (error "Not at `if', `unless', `while', `until', `for' or `foreach'")))
+ (goto-char pre-if)
+ (setq pre-A (set-marker (make-marker) pre-A))
+ (while (<= (point) (marker-position pre-A))
+ (cperl-indent-line)
+ (forward-line 1))
+ (goto-char (marker-position pre-A))
+ (if B-comment
+ (progn
+ (forward-line -1)
+ (indent-for-comment)
+ (goto-char (marker-position pre-A)))))
+ (error "`%s' (EXPR) not with an {BLOCK}" if-string)))
+ ;; (error "`%s' not with an (EXPR)" if-string)
+ (forward-sexp -1)
+ (cperl-invert-if-unless-modifiers)))
+ ;;(error "Not at `if', `unless', `while', `until', `for' or `foreach'")
+ (cperl-invert-if-unless-modifiers)))
;;; By Anthony Foiani <address@hidden>
;;; 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
@@ -7103,6 +8604,7 @@
(t
(Man-getpage-in-background word)))))
+;;;###autoload
(defun cperl-perldoc-at-point ()
"Run a `perldoc' on the word around point."
(interactive)
@@ -7147,7 +8649,7 @@
(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))))
@@ -7161,6 +8663,205 @@
(setq flist (cdr flist))))
command))
+
+(defun cperl-next-interpolated-REx-1 ()
+ "Move point to next REx which has interpolated parts without //o.
+Skips RExes consisting of one interpolated variable.
+
+Note that skipped RExen are not performance hits."
+ (interactive "")
+ (cperl-next-interpolated-REx 1))
+
+(defun cperl-next-interpolated-REx-0 ()
+ "Move point to next REx which has interpolated parts without //o."
+ (interactive "")
+ (cperl-next-interpolated-REx 0))
+
+(defun cperl-next-interpolated-REx (&optional skip beg limit)
+ "Move point to next REx which has interpolated parts.
+SKIP is a list of possible types to skip, BEG and LIMIT are the starting
+point and the limit of search (default to point and end of buffer).
+
+SKIP may be a number, then it behaves as list of numbers up to SKIP; this
+semantic may be used as a numeric argument.
+
+Types are 0 for / $rex /o (interpolated once), 1 for /$rex/ (if $rex is
+a result of qr//, this is not a performance hit), t for the rest."
+ (interactive "P")
+ (if (numberp skip) (setq skip (list 0 skip)))
+ (or beg (setq beg (point)))
+ (or limit (setq limit (point-max))) ; needed for n-s-p-c
+ (let (pp)
+ (and (eq (get-text-property beg 'syntax-type) 'string)
+ (setq beg (next-single-property-change beg 'syntax-type nil limit)))
+ (cperl-map-pods-heres
+ (function (lambda (s e p)
+ (if (memq (get-text-property s 'REx-interpolated) skip)
+ t
+ (setq pp s)
+ nil))) ; nil stops
+ 'REx-interpolated beg limit)
+ (if pp (goto-char pp)
+ (message "No more interpolated REx"))))
+
+;;; Initial version contributed by Trey Belew
+(defun cperl-here-doc-spell (&optional beg end)
+ "Spell-check HERE-documents in the Perl buffer.
+If a region is highlighted, restricts to the region."
+ (interactive "")
+ (cperl-pod-spell t beg end))
+
+(defun cperl-pod-spell (&optional do-heres beg end)
+ "Spell-check POD documentation.
+If invoked with prefix argument, will do HERE-DOCs instead.
+If a region is highlighted, restricts to the region."
+ (interactive "P")
+ (save-excursion
+ (let (beg end)
+ (if (cperl-mark-active)
+ (setq beg (min (mark) (point))
+ end (max (mark) (point)))
+ (setq beg (point-min)
+ end (point-max)))
+ (cperl-map-pods-heres (function
+ (lambda (s e p)
+ (if do-heres
+ (setq e (save-excursion
+ (goto-char e)
+ (forward-line -1)
+ (point))))
+ (ispell-region s e)
+ t))
+ (if do-heres 'here-doc-group 'in-pod)
+ beg end))))
+
+(defun cperl-map-pods-heres (func &optional prop s end)
+ "Executes a function over regions of pods or here-documents.
+PROP is the text-property to search for; default to `in-pod'. Stop when
+function returns nil."
+ (let (pos posend has-prop (cont t))
+ (or prop (setq prop 'in-pod))
+ (or s (setq s (point-min)))
+ (or end (setq end (point-max)))
+ (cperl-update-syntaxification end end)
+ (save-excursion
+ (goto-char (setq pos s))
+ (while (and cont (< pos end))
+ (setq has-prop (get-text-property pos prop))
+ (setq posend (next-single-property-change pos prop nil end))
+ (and has-prop
+ (setq cont (funcall func pos posend prop)))
+ (setq pos posend)))))
+
+;;; Based on code by Masatake YAMATO:
+(defun cperl-get-here-doc-region (&optional pos pod)
+ "Return HERE document region around the point.
+Return nil if the point is not in a HERE document region. If POD is non-nil,
+will return a POD section if point is in a POD section."
+ (or pos (setq pos (point)))
+ (cperl-update-syntaxification pos pos)
+ (if (or (eq 'here-doc (get-text-property pos 'syntax-type))
+ (and pod
+ (eq 'pod (get-text-property pos 'syntax-type))))
+ (let ((b (cperl-beginning-of-property pos 'syntax-type))
+ (e (next-single-property-change pos 'syntax-type)))
+ (cons b (or e (point-max))))))
+
+(defun cperl-narrow-to-here-doc (&optional pos)
+ "Narrows editing region to the HERE-DOC at POS.
+POS defaults to the point."
+ (interactive "d")
+ (or pos (setq pos (point)))
+ (let ((p (cperl-get-here-doc-region pos)))
+ (or p (error "Not inside a HERE document"))
+ (narrow-to-region (car p) (cdr p))
+ (message
+ "When you are finished with narrow editing, type C-x n w")))
+
+(defun cperl-select-this-pod-or-here-doc (&optional pos)
+ "Select the HERE-DOC (or POD section) at POS.
+POS defaults to the point."
+ (interactive "d")
+ (let ((p (cperl-get-here-doc-region pos t)))
+ (if p
+ (progn
+ (goto-char (car p))
+ (push-mark (cdr p) nil t)) ; Message, activate in transient-mode
+ (message "I do not think POS is in POD or a HERE-doc..."))))
+
+(defun cperl-facemenu-add-face-function (face end)
+ "A callback to process user-initiated font-change requests.
+Translates `bold', `italic', and `bold-italic' requests to insertion of
+corresponding POD directives, and `underline' to C<> POD directive.
+
+Such requests are usually bound to M-o LETTER."
+ (or (get-text-property (point) 'in-pod)
+ (error "Faces can only be set within POD"))
+ (setq facemenu-end-add-face (if (eq face 'bold-italic) ">>" ">"))
+ (cdr (or (assq face '((bold . "B<")
+ (italic . "I<")
+ (bold-italic . "B<I<")
+ (underline . "C<")))
+ (error "Face %s not configured for cperl-mode"
+ face))))
+
+(defun cperl-time-fontification (&optional l step lim)
+ "Times how long it takes to do incremental fontification in a region.
+L is the line to start at, STEP is the number of lines to skip when
+doing next incremental fontification, LIM is the maximal number of
+incremental fontification to perform. Messages are accumulated in
+*Messages* buffer.
+
+May be used for pinpointing which construct slows down buffer fontification:
+start with default arguments, then refine the slowdown regions."
+ (interactive "nLine to start at: \nnStep to do incremental fontification: ")
+ (or l (setq l 1))
+ (or step (setq step 500))
+ (or lim (setq lim 40))
+ (let* ((timems (function (lambda ()
+ (let ((tt (current-time)))
+ (+ (* 1000 (nth 1 tt)) (/ (nth 2 tt) 1000))))))
+ (tt (funcall timems)) (c 0) delta tot)
+ (goto-line l)
+ (cperl-mode)
+ (setq tot (- (- tt (setq tt (funcall timems)))))
+ (message "cperl-mode at %s: %s" l tot)
+ (while (and (< c lim) (not (eobp)))
+ (forward-line step)
+ (setq l (+ l step))
+ (setq c (1+ c))
+ (cperl-update-syntaxification (point) (point))
+ (setq delta (- (- tt (setq tt (funcall timems)))) tot (+ tot delta))
+ (message "to %s:%6s,%7s" l delta tot))
+ tot))
+
+(defun cperl-emulate-lazy-lock (&optional window-size)
+ "Emulate `lazy-lock' without `condition-case', so `debug-on-error' works.
+Start fontifying the buffer from the start (or end) using the given
+WINDOW-SIZE (units is lines). Negative WINDOW-SIZE starts at end, and
+goes backwards; default is -50. This function is not CPerl-specific; it
+may be used to debug problems with delayed incremental fontification."
+ (interactive
+ "nSize of window for incremental fontification, negative goes backwards: ")
+ (or window-size (setq window-size -50))
+ (let ((pos (if (> window-size 0)
+ (point-min)
+ (point-max)))
+ p)
+ (goto-char pos)
+ (normal-mode)
+ ;; Why needed??? With older font-locks???
+ (set (make-local-variable 'font-lock-cache-position) (make-marker))
+ (while (if (> window-size 0)
+ (< pos (point-max))
+ (> pos (point-min)))
+ (setq p (progn
+ (forward-line window-size)
+ (point)))
+ (font-lock-fontify-region (min p pos) (max p pos))
+ (setq pos p))))
+
+
(defun cperl-lazy-install ()) ; Avoid a warning
(defun cperl-lazy-unstall ()) ; Avoid a warning
@@ -7176,7 +8877,7 @@
"Switches on Auto-Help on Perl constructs (put in the message area).
Delay of auto-help controlled by `cperl-lazy-help-time'."
(interactive)
- (make-variable-buffer-local 'cperl-help-shown)
+ (make-local-variable 'cperl-help-shown)
(if (and (cperl-val 'cperl-lazy-help-time)
(not cperl-lazy-installed))
(progn
@@ -7209,48 +8910,109 @@
;;; Plug for wrong font-lock:
(defun cperl-font-lock-unfontify-region-function (beg end)
- ;; Simplified now that font-lock-unfontify-region uses save-buffer-state.
- (let (before-change-functions after-change-functions)
- (remove-text-properties beg end '(face nil))))
+ (let* ((modified (buffer-modified-p)) (buffer-undo-list t)
+ (inhibit-read-only t) (inhibit-point-motion-hooks t)
+ before-change-functions after-change-functions
+ deactivate-mark buffer-file-name buffer-file-truename)
+ (remove-text-properties beg end '(face nil))
+ (if (and (not modified) (buffer-modified-p))
+ (set-buffer-modified-p nil))))
+
+(defun cperl-font-lock-fontify-region-function (beg end loudly)
+ "Extends the region to safe positions, then calls the default function.
+Newer `font-lock's can do it themselves.
+We unwind only as far as needed for fontification. Syntaxification may
+do extra unwind via `cperl-unwind-to-safe'."
+ (save-excursion
+ (goto-char beg)
+ (while (and beg
+ (progn
+ (beginning-of-line)
+ (eq (get-text-property (setq beg (point)) 'syntax-type)
+ 'multiline)))
+ (if (setq beg (cperl-beginning-of-property beg 'syntax-type))
+ (goto-char beg)))
+ (setq beg (point))
+ (goto-char end)
+ (while (and end
+ (progn
+ (or (bolp) (condition-case nil
+ (forward-line 1)
+ (error nil)))
+ (eq (get-text-property (setq end (point)) 'syntax-type)
+ 'multiline)))
+ (setq end (next-single-property-change end 'syntax-type nil (point-max)))
+ (goto-char end))
+ (setq end (point)))
+ (font-lock-default-fontify-region beg end loudly))
(defvar cperl-d-l nil)
(defun cperl-fontify-syntaxically (end)
;; Some vars for debugging only
;; (message "Syntaxifying...")
- (let ((dbg (point)) (iend end)
+ (let ((dbg (point)) (iend end) (idone cperl-syntax-done-to)
(istate (car cperl-syntax-state))
- start)
- (and cperl-syntaxify-unwind
- (setq end (cperl-unwind-to-safe t end)))
- (setq start (point))
+ start from-start edebug-backtrace-buffer)
+ (if (eq cperl-syntaxify-by-font-lock 'backtrace)
+ (progn
+ (require 'edebug)
+ (let ((f 'edebug-backtrace))
+ (funcall f)))) ; Avoid compile-time warning
(or cperl-syntax-done-to
- (setq cperl-syntax-done-to (point-min)))
- (if (or (not (boundp 'font-lock-hot-pass))
- (eval 'font-lock-hot-pass)
- t) ; Not debugged otherwise
+ (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'
- (setq start (min cperl-syntax-done-to start))
- ;; Fontification without a change
- (setq start (max cperl-syntax-done-to 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
@@ -7262,7 +9024,7 @@
(cperl-fontify-syntaxically to)))))
(defvar cperl-version
- (let ((v "Revision: 5.0"))
+ (let ((v "Revision: 5.22"))
(string-match ":\\s *\\([0-9.]+\\)" v)
(substring v (match-beginning 1) (match-end 1)))
"Version of IZ-supported CPerl package this file is based on.")
- [Emacs-diffs] Changes to emacs/lisp/progmodes/cperl-mode.el,v,
Stefan Monnier <=