Mercurial > emacs
changeset 23977:abc9bc6aef59
Can use linear algorithm for indentation if Emacs supports it.
(cperl-after-expr-p): It is BLOCK if we reach lim when backup sexp.
(cperl-after-block-p): Likewise.
(cperl-after-block-and-statement-beg): Likewise.
(cperl-after-block-p): After END/BEGIN we are a block.
(cperl-after-expr-p): Skip labels when checking
(cperl-indent-region): Make a marker for END - text added/removed.
Disable hooks during the call (how to call them later?).
Now indents 820-line-long function in 6.5 sec (including
syntaxification) the first time (when buffer has few
properties), 7.1 sec the second time.
(cperl-indent-region): Do not indent whitespace lines
(cperl-style-alist)
Include `cperl-merge-trailing-else' where the value is clear.
(cperl-styles-entries): Likewise.
(cperl-problems): Improvements to docs.
(cperl-tips): Likewise.
(cperl-non-problems): Likewise.
(cperl-mode): Make lazy syntaxification possible.
Loads pseudo-faces for the sake of `cperl-find-pods-heres' (for 19.30).
`font-lock-unfontify-region-function' was set to a wrong function.
(cperl-find-pods-heres): Safe a position in buffer where it is safe to
restart syntaxification. Changed so that -d ?foo? is a RE. Do
not warn on `=cut' if doing a chunk only. 1 << 6 was OK,
but 1<<6 was considered as HERE-doc.
<file/glob> made into a string.
Postpone addition of faces after syntactic step.
Recognition of <FH> was wrong.
Highlight `gem' in s///gem as a keyword. `qr' recognized.
Knows that split// is null-RE.
Highlights separators in 3-parts expressions as labels.
<> was considered as a glob.
Would err if the last line is `=head1'.
$a-1 ? foo : bar; was a considered a regexp.
`<< (' was considered a start of HERE-doc.
mark qq[]-etc sections as syntax-type=string
Was not processing sub protos after a comment ine.
Was treating $a++ <= 5 as a glob.
Tolerate unfinished REx at end-of-buffer.
`unwind-protect' was left commented.
/ and ? after : start a REx.
(cperl-syntaxify-by-font-lock): Set to t, should be safe now.
Better default, customizes to `message' too, off in text-mode.
(cperl-array-face): Renamed from `font-lock-emphasized-face',
`defface'd.
(cperl-hash-face): Renamed from `font-lock-other-emphasized-face'.
`defface'd.
(cperl-emacs-can-parse): New state variable.
(cperl-indent-line): Corrected to use global state.
(cperl-calculate-indent): Likewise.
(cperl-fix-line-spacing): Likewise (not used yet).
(cperl-calculate-indent): Did not consider `,' as
continuation mark for statements.
(cperl-calculate-indent): Avoid parse-data optimization at toplevel.
Remove another parse-data optimization at toplevel: would
indent correctly.
Correct for labels when calculating indentation of continuations.
Docstring updated.
(cperl-choose-color): Converted to a function (to be
compilable in text-mode).
(cperl-dark-background): Disable without window-system.
Do `defface' only if window-system.
(cperl-fix-line-spacing): sped up to bail out early.
(x-color-defined-p): was not compiling on XEmacs
Was defmacro'ed with a tick. Remove another def.
(cperl-clobber-lisp-bindings): if set, C-c variants are the old ones
(cperl-unwind-to-safe): New function.
(cperl-fontify-syntaxically): Use `cperl-unwind-to-safe' to start at reasonable position.
(cperl-fontify-syntaxically): Unwinds start and end to go out of
long strings (not very successful).
(cperl-forward-re): Highlight the trailing / in s/foo// as string.
Highlight the starting // in s//foo/ as function-name.
Emit a meaningful error instead of a cryptic one for an
uncomplete REx near end-of-buffer.
(cperl-electric-keyword): `qr' recognized.
(cperl-electric-else): Likewise
(cperl-to-comment-or-eol): Likewise
(cperl-make-regexp-x): Likewise
(cperl-init-faces): Likewise, and `lock' (as overridable?).
Corrected to use new macros;
`if' for copying `reference-face' to `constant-face' was backward.
remove init `font-lock-other-emphasized-face',
`font-lock-emphasized-face', `font-lock-keyword-face'.
Interpolate `cperl-invalid-face'.
(cperl-make-regexp-x): Misprint in a message.
(cperl-syntaxify-unwind): New configuration variable
(cperl-fontify-m-as-s): New configuration variable
(cperl-electric-pod): check for after-expr was performed
inside of POD too.
(cperl-backward-to-noncomment): better treatment of PODs and HEREs.
(cperl-clobber-mode-lists): New configuration variable.
(cperl-not-bad-style-regexp): Updated.
Init: `cperl-is-face' was busted.
(cperl-make-face): New macros.
(cperl-force-face): New macros.
(font-lock-other-type-face): Done via `defface' too.
(cperl-nonoverridable-face): New face. Renamed from
`font-lock-other-type-face'.
(cperl-init-faces-weak): use `cperl-force-face'.
(cperl-comment-indent): Commenting __END__ was not working.
(cperl-indent-for-comment): Likewise.
(cperl-write-tags): Correct for XEmacs's `visit-tags-table-buffer'.
When removing old TAGS info was not relativizing filename.
(cperl-tags-hier-init): Gross hack to pretend we work (are we?).
Another try to work around XEmacs problems. Better progress messages.
(toplevel): require custom unprotected => failure on 19.28.
(cperl-xemacs-p): defined when compile too
(cperl-find-tags): Was writing line/pos in a wrong order,
pos off by 1 and not at beg-of-line.
(cperl-etags-snarf-tag): New macro
(cperl-etags-goto-tag-location): New macro
(cperl-version): New variable. New menu entry
random docstrings: References to "future" 20.3 removed.
Menu was described as `CPerl' instead of `Perl'
(perl-font-lock-keywords): Would not highlight `sub foo($$);'.
(cperl-toggle-construct-fix): Was toggling to t instead of 1.
(cperl-ps-print-init): Associate `cperl-array-face', `cperl-hash-face'
Remove `font-lock-emphasized-face', `font-lock-other-emphasized-face',
`font-lock-reference-face', `font-lock-keyword-face'.
Use `eval-after-load'.
Remove not-CPerl-related faces.
(cperl-tips-faces): New variable and an entry into Mini-docs.
(cperl-indent-exp): Was not processing else-blocks.
(cperl-get-state): NOP line removed.
(cperl-ps-print): New function and menu entry.
(cperl-ps-print-face-properties): New configuration variable.
(cperl-invalid-face): New configuration variable.
(perl-font-lock-keywords): Highlight trailing whitespace
(cperl-contract-levels): Documentation corrected.
(cperl-contract-level): Likewise.
(cperl-ps-extend-face-list): New macro.
(cperl-invalid-face): Change to ''underline.
| author | Richard M. Stallman <rms@gnu.org> |
|---|---|
| date | Sat, 02 Jan 1999 00:16:05 +0000 |
| parents | 12c74d5eff80 |
| children | 5975ffe0b250 |
| files | lisp/progmodes/cperl-mode.el |
| diffstat | 1 files changed, 1030 insertions(+), 370 deletions(-) [+] |
line wrap: on
line diff
--- a/lisp/progmodes/cperl-mode.el Sat Jan 02 00:14:41 1999 +0000 +++ b/lisp/progmodes/cperl-mode.el Sat Jan 02 00:16:05 1999 +0000 @@ -62,6 +62,61 @@ ;;; Code: +;; Some macros are needed for `defcustom' +(if (fboundp 'eval-when-compile) + (eval-when-compile + (defconst cperl-xemacs-p (string-match "XEmacs\\|Lucid" emacs-version)) + (defmacro cperl-is-face (arg) ; Takes quoted arg + (cond ((fboundp 'find-face) + (` (find-face (, arg)))) + (;;(and (fboundp 'face-list) + ;; (face-list)) + (fboundp 'face-list) + (` (member (, arg) (and (fboundp 'face-list) + (face-list))))) + (t + (` (boundp (, arg)))))) + (defmacro cperl-make-face (arg descr) ; Takes unquoted arg + (cond ((fboundp 'make-face) + (` (make-face (quote (, arg))))) + (t + (` (defconst (, 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 + (defconst (, arg) (quote (, arg)) (, descr)))))) + (if cperl-xemacs-p + (defmacro cperl-etags-snarf-tag (file line) + (` (progn + (beginning-of-line 2) + (list (, file) (, line))))) + (defmacro cperl-etags-snarf-tag (file line) + (` (etags-snarf-tag)))) + (if cperl-xemacs-p + (defmacro cperl-etags-goto-tag-location (elt) + (` ;;(progn + ;; (switch-to-buffer (get-file-buffer (elt (, elt) 0))) + ;; (set-buffer (get-file-buffer (elt (, elt) 0))) + ;; Probably will not work due to some save-excursion??? + ;; Or save-file-position? + ;; (message "Did I get to line %s?" (elt (, elt) 1)) + (goto-line (string-to-int (elt (, elt) 1))))) + ;;) + (defmacro cperl-etags-goto-tag-location (elt) + (` (etags-goto-tag-location (, elt))))))) + +(defun cperl-choose-color (&rest list) + (let (answer) + (while list + (or answer + (if (or (x-color-defined-p (car list)) + (null (cdr list))) + (setq answer (car list)))) + (setq list (cdr list))) + answer)) + (defgroup cperl nil "Major mode for editing Perl code." :prefix "cperl-" @@ -257,6 +312,16 @@ :type '(repeat (list symbol string)) :group 'cperl) +(defcustom cperl-clobber-mode-lists + (not + (and + (boundp 'interpreter-mode-alist) + (assoc "miniperl" interpreter-mode-alist) + (assoc "\\.\\([pP][Llm]\\|al\\)$" auto-mode-alist))) + "*Whether to install us into `interpreter-' and `extension' mode lists." + :type 'boolean + :group 'cperl) + (defcustom cperl-info-on-command-no-prompt nil "*Not-nil (and non-null) means not to prompt on C-h f. The opposite behaviour is always available if prefixed with C-c. @@ -293,11 +358,21 @@ :type 'face :group 'cperl-faces) +(defcustom cperl-invalid-face ''underline ; later evaluated by `font-lock' + "*The result of evaluation of this expression highlights trailing whitespace." + :type 'face + :group 'cperl-faces) + (defcustom cperl-pod-here-fontify '(featurep 'font-lock) "*Not-nil after evaluation means to highlight pod and here-docs sections." :type 'boolean :group 'cperl-faces) +(defcustom cperl-fontify-m-as-s t + "*Not-nil means highlight 1arg regular expressions operators same as 2arg." + :type 'boolean + :group 'cperl-faces) + (defcustom cperl-pod-here-scan t "*Not-nil means look for pod and here-docs sections during startup. You can always make lookup from menu or using \\[cperl-find-pods-heres]." @@ -401,12 +476,86 @@ :type 'boolean :group 'cperl-indentation-details) -(defcustom cperl-syntaxify-by-font-lock nil +(defcustom cperl-syntaxify-by-font-lock + (and window-system + (boundp 'parse-sexp-lookup-properties)) "*Non-nil means that CPerl uses `font-lock's routines for syntaxification. -Not debugged yet." +Having it TRUE may be not completely debugged yet." + :type '(choice (const message) boolean) + :group 'cperl-speed) + +(defcustom cperl-syntaxify-unwind + t + "*Non-nil means that CPerl unwinds to a start of along construction +when syntaxifying a chunk of buffer." :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-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-face nil nil italic underline) + (font-lock-type-face nil nil underline) + (underline nil "LightGray" strikeout)) + "List given as an argument to `ps-extend-face-list' in `cperl-ps-print'." + :type '(repeat (cons symbol + (cons (choice (const nil) string) + (cons (choice (const nil) string) + (repeat symbol))))) + :group 'cperl-faces) + +(if window-system + (progn + (defvar cperl-dark-background + (cperl-choose-color "navy" "os2blue" "darkgreen")) + (defvar cperl-dark-foreground + (cperl-choose-color "orchid1" "orange")) + + (defface cperl-nonoverridable-face + (` ((((class grayscale) (background light)) + (:background "Gray90" :italic t :underline t)) + (((class grayscale) (background dark)) + (:foreground "Gray80" :italic t :underline t :bold t)) + (((class color) (background light)) + (:foreground "chartreuse3")) + (((class color) (background dark)) + (:foreground (, cperl-dark-foreground))) + (t (:bold t :underline t)))) + "Font Lock mode face used to highlight array names." + :group 'cperl-faces) + + (defface cperl-array-face + (` ((((class grayscale) (background light)) + (:background "Gray90" :bold t)) + (((class grayscale) (background dark)) + (:foreground "Gray80" :bold t)) + (((class color) (background light)) + (:foreground "Blue" :background "lightyellow2" :bold t)) + (((class color) (background dark)) + (:foreground "yellow" :background (, cperl-dark-background) :bold t)) + (t (:bold t)))) + "Font Lock mode face used to highlight array names." + :group 'cperl-faces) + + (defface cperl-hash-face + (` ((((class grayscale) (background light)) + (:background "Gray90" :bold t :italic t)) + (((class grayscale) (background dark)) + (:foreground "Gray80" :bold t :italic t)) + (((class color) (background light)) + (:foreground "Red" :background "lightyellow2" :bold t :italic t)) + (((class color) (background dark)) + (:foreground "Red" :background (, cperl-dark-background) :bold t :italic t)) + (t (:bold t :italic t)))) + "Font Lock mode face used to highlight hash names." + :group 'cperl-faces))) + ;;; Short extra-docs. @@ -419,6 +568,13 @@ Subdirectory `cperl-mode' may contain yet newer development releases and/or patches to related files. +For best results apply to an older Emacs the patches from + ftp://ftp.math.ohio-state.edu/pub/users/ilya/cperl-mode/patches +\(this upgrades syntax-parsing abilities of RMS Emaxen v19.34 and +v20.2 up to the level of RMS Emacs v20.3 - a must for a good Perl +mode.) You will not get much from XEmacs, it's syntax abilities are +too primitive. + Get support packages choose-color.el (or font-lock-extra.el before 19.30), imenu-go.el from the same place. \(Look for other files there too... ;-). Get a patch for imenu.el in 19.29. Note that for 19.30 and @@ -434,27 +590,41 @@ http://www.metronet.com:70/9/perlinfo/perl5/manual/perl5-info.tar.gz If you use imenu-go, run imenu on perl5-info buffer (you can do it -from CPerl menu). If many files are related, generate TAGS files from -Tools/Tags submenu in CPerl menu. +from Perl menu). If many files are related, generate TAGS files from +Tools/Tags submenu in Perl menu. If some class structure is too complicated, use Tools/Hierarchy-view -from CPerl menu, or hierarchic view of imenu. The second one uses the +from Perl menu, or hierarchic view of imenu. The second one uses the current buffer only, the first one requires generation of TAGS from -CPerl/Tools/Tags menu beforehand. - -Run CPerl/Tools/Insert-spaces-if-needed to fix your lazy typing. - -Switch auto-help on/off with CPerl/Tools/Auto-help. - -Before reporting (non-)problems look in the problem section on what I -know about them.") +Perl/Tools/Tags menu beforehand. + +Run Perl/Tools/Insert-spaces-if-needed to fix your lazy typing. + +Switch auto-help on/off with Perl/Tools/Auto-help. + +Though with contemporary Emaxen CPerl mode should maintain the correct +parsing of Perl even when editing, sometimes it may be lost. Fix this by + + M-x norm RET + +In cases of more severe confusion sometimes it is helpful to do + + M-x load-l RET cperl-mode RET + M-x norm RET + +Before reporting (non-)problems look in the problem section of online +micro-docs on what I know about CPerl problems.") (defvar cperl-problems 'please-ignore-this-line "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/ -Even with newer Emacsen interaction of `font-lock' and +Emacs had a _very_ restricted syntax parsing engine until RMS's Emacs +20.1. Most problems below are corrected starting from this version of +Emacs, and all of them should go with (future) RMS's version 20.3. + +Note that even with newer Emacsen interaction of `font-lock' and syntaxification is not cleaned up. You may get slightly different colors basing on the order of fontification and syntaxification. This might be corrected by setting `cperl-syntaxify-by-font-lock' to t, but @@ -480,9 +650,10 @@ Similar problems arise in regexps, when /(\\s|$)/ should be rewritten as /($|\\s)/. Note that such a transposition is not always possible. -The solution is to upgrade your Emacs. Note that Emacs 20.2 has some -bugs related to `syntax-table' text properties. Patches are available -on the main CPerl download site, and on CPAN. +The solution is to upgrade your Emacs or patch an older one. Note +that RMS's 20.2 has some bugs related to `syntax-table' text +properties. Patches are available on the main CPerl download site, +and on CPAN. If these bugs cannot be fixed on your machine (say, you have an inferior environment and cannot recompile), you may still disable all the fancy stuff @@ -490,7 +661,9 @@ (defvar cperl-non-problems 'please-ignore-this-line "As you know from `problems' section, Perl syntax is too hard for CPerl on -older Emacsen. +older Emacsen. Here is what you can do if you cannot upgrade, or if +you want to switch off these capabilities on RMS Emacs 20.2 (+patches) or 20.3 +or better. Please skip this docs if you run a capable Emacs already. Most of the time, if you write your own code, you may find an equivalent \(and almost as readable) expression (what is discussed below is usually @@ -538,6 +711,7 @@ Imenu in 19.31 is broken. Set `imenu-use-keymap-menu' to t, and remove `car' before `imenu-choose-buffer-index' in `imenu'. `imenu-add-to-menubar' in 20.2 is broken. + A lot of things on XEmacs may be broken too, judging by bug reports I recieve. Note that some releases of XEmacs are better than the others as far as bugs reports I see are concerned.") @@ -549,8 +723,11 @@ 1) It does 99% of Perl syntax correct (as opposed to 80-90% in Perl mode - but the latter number may have improved too in last years) even -without `syntax-table' property; When using this property, it should -handle 99.995% of lines correct - or somesuch. +with old Emaxen which do not support `syntax-table' property. + +When using `syntax-table' property for syntax assist hints, it should +handle 99.995% of lines correct - or somesuch. It automatically +updates syntax assist hints when you edit your script. 2) It is generally believed to be \"the most user-friendly Emacs package\" whatever it may mean (I doubt that the people who say similar @@ -599,6 +776,10 @@ to B if A; + n) Highlights (by user-choice) either 3-delimiters constructs + (such as tr/a/b/), or regular expressions and `y/tr'. + o) Highlights trailing whitespace. + 5) The indentation engine was very smart, but most of tricks may be not needed anymore with the support for `syntax-table' property. Has progress indicator for indentation (with `imenu' loaded). @@ -655,8 +836,46 @@ syntax-engine-helping scan, thus will make many more Perl constructs be wrongly recognized by CPerl, thus may lead to wrongly matched parentheses, wrong indentation, etc. + + One can unset `cperl-syntaxify-unwind'. This might speed up editing + of, say, long POD sections. ") +(defvar cperl-tips-faces 'please-ignore-this-line + "CPerl mode uses following faces for highlighting: + + 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, + 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-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 + as string literals + font-lock-type-face Overridable keywords + font-lock-variable-name-face Variable declarations, indirect array and + hash names, POD headers/item names + cperl-invalid-face Trailing whitespace + +Note that in several situations the highlighting tries to inform about +possible confusion, such as different colors for function names in +declarations depending on what they (do not) override, or special cases +m// and s/// which do not do what one would expect them to do. + +Help with best setup of these faces for printout requested (for each of +the faces: please specify bold, italic, underline, shadow and box.) + +\(Not finished.)") + ;;; Portability stuff: @@ -713,9 +932,12 @@ 'lazy-lock) "Text property which inhibits refontification.") -(defsubst cperl-put-do-not-fontify (from to) +(defsubst cperl-put-do-not-fontify (from to &optional post) + ;; If POST, do not do it with postponed fontification + (if (and post cperl-syntaxify-by-font-lock) + nil (put-text-property (max (point-min) (1- from)) - to cperl-do-not-fontify t)) + to cperl-do-not-fontify t))) (defcustom cperl-mode-hook nil "Hook run by `cperl-mode'." @@ -724,6 +946,8 @@ (defvar cperl-syntax-state nil) (defvar cperl-syntax-done-to nil) +(defvar cperl-emacs-can-parse (> (length (save-excursion + (parse-partial-sexp 1 1))) 9)) ;; Make customization possible "in reverse" (defsubst cperl-val (symbol &optional default hairy) @@ -734,11 +958,12 @@ ;;; Probably it is too late to set these guys already, but it can help later: +;;;(and cperl-clobber-mode-lists ;;;(setq auto-mode-alist ;;; (append '(("\\.\\([pP][Llm]\\|al\\)$" . perl-mode)) auto-mode-alist )) ;;;(and (boundp 'interpreter-mode-alist) ;;; (setq interpreter-mode-alist (append interpreter-mode-alist -;;; '(("miniperl" . perl-mode))))) +;;; '(("miniperl" . perl-mode)))))) (if (fboundp 'eval-when-compile) (eval-when-compile (condition-case nil @@ -759,31 +984,18 @@ (condition-case nil (require 'info) (error nil)) + (if (fboundp 'ps-extend-face-list) + (defmacro cperl-ps-extend-face-list (arg) + (` (ps-extend-face-list (, arg)))) + (defmacro cperl-ps-extend-face-list (arg) + (` (error "This version of Emacs has no `ps-extend-face-list'.")))) ;; Calling `cperl-enable-font-lock' below doesn't compile on XEmacs, ;; macros instead of defsubsts don't work on Emacs, so we do the ;; expansion manually. Any other suggestions? (if (or (string-match "XEmacs\\|Lucid" emacs-version) window-system) (require 'font-lock)) - (require 'cl) - ;; Avoid warning (tmp definitions) - (or (fboundp 'x-color-defined-p) - (defalias 'x-color-defined-p - (cond ((fboundp 'color-defined-p) 'color-defined-p) - ;; XEmacs >= 19.12 - ((fboundp 'valid-color-name-p) 'valid-color-name-p) - ;; XEmacs 19.11 - (t 'x-valid-color-name-p)))) - (fset 'cperl-is-face - (cond ((fboundp 'find-face) - (symbol-function 'find-face)) - ((and (fboundp 'face-list) - (face-list)) - (function (lambda (face) - (member face (and (fboundp 'face-list) - (face-list)))))) - (t - (function (lambda (face) (boundp face)))))))) + (require 'cl))) (defvar cperl-mode-abbrev-table nil "Abbrev table in use in Cperl-mode buffers.") @@ -820,14 +1032,8 @@ (cperl-define-key "\177" 'cperl-electric-backspace) (cperl-define-key "\t" 'cperl-indent-command) ;; don't clobber the backspace binding: - (cperl-define-key "\C-c\C-hf" 'cperl-info-on-current-command - [(control c) (control h) f]) (cperl-define-key "\C-c\C-hF" 'cperl-info-on-command [(control c) (control h) F]) - (cperl-define-key "\C-c\C-hv" - ;;(concat (char-to-string help-char) "v") ; does not work - 'cperl-get-help - [(control c) (control h) v]) (if (cperl-val 'cperl-clobber-lisp-bindings) (progn (cperl-define-key "\C-hf" @@ -837,7 +1043,21 @@ (cperl-define-key "\C-hv" ;;(concat (char-to-string help-char) "v") ; does not work 'cperl-get-help - [(control h) v]))) + [(control h) v]) + (cperl-define-key "\C-c\C-hf" + ;;(concat (char-to-string help-char) "f") ; does not work + (key-binding "\C-hf") + [(control c) (control h) f]) + (cperl-define-key "\C-c\C-hv" + ;;(concat (char-to-string help-char) "v") ; does not work + (key-binding "\C-hv") + [(control c) (control h) v])) + (cperl-define-key "\C-c\C-hf" 'cperl-info-on-current-command + [(control c) (control h) f]) + (cperl-define-key "\C-c\C-hv" + ;;(concat (char-to-string help-char) "v") ; does not work + 'cperl-get-help + [(control c) (control h) v])) (if (and cperl-xemacs-p (<= emacs-minor-version 11) (<= emacs-major-version 19)) (progn @@ -902,6 +1122,8 @@ ["Insert spaces if needed" cperl-find-bad-style t] ["Class Hierarchy from TAGS" cperl-tags-hier-init t] ;;["Update classes" (cperl-tags-hier-init t) tags-table-list] + ["CPerl pretty print (exprmntl)" cperl-ps-print + (fboundp 'ps-extend-face-list)] ["Imenu on info" cperl-imenu-on-info (featurep 'imenu)] ("Tags" ;;; ["Create tags for current file" cperl-etags t] @@ -960,7 +1182,11 @@ ["Non-problems" (describe-variable 'cperl-non-problems) t] ["Speed" (describe-variable 'cperl-speed) t] ["Praise" (describe-variable 'cperl-praise) t] - ["CPerl mode" (describe-function 'cperl-mode) t])))) + ["Faces" (describe-variable 'cperl-tips-faces) t] + ["CPerl mode" (describe-function 'cperl-mode) t] + ["CPerl version" + (message "The version of master-file for this CPerl is %s" + cperl-version) t])))) (error nil)) (autoload 'c-macro-expand "cmacexp" @@ -1271,7 +1497,7 @@ ;; Fix broken font-lock: (or (boundp 'font-lock-unfontify-region-function) (set 'font-lock-unfontify-region-function - 'font-lock-default-unfontify-buffer)) + 'font-lock-default-unfontify-region)) (make-variable-buffer-local 'font-lock-unfontify-region-function) (set 'font-lock-unfontify-region-function 'cperl-font-lock-unfontify-region-function) @@ -1306,11 +1532,12 @@ (run-hooks 'cperl-mode-hook) ;; After hooks since fontification will break this (if cperl-pod-here-scan - (or (and (boundp 'font-lock-mode) - (eval 'font-lock-mode) ; Avoid warning - (boundp 'font-lock-hot-pass) ; Newer font-lock - cperl-syntaxify-by-font-lock) - (cperl-find-pods-heres)))) + (or ;;(and (boundp 'font-lock-mode) + ;; (eval 'font-lock-mode) ; Avoid warning + ;; (boundp 'font-lock-hot-pass) ; Newer font-lock + cperl-syntaxify-by-font-lock ;;) + (progn (or cperl-faces-init (cperl-init-faces-weak)) + (cperl-find-pods-heres))))) ;; Fix for perldb - make default reasonable (defvar gud-perldb-history) @@ -1348,13 +1575,28 @@ ;; based on its context. Do fallback if comment is found wrong. (defvar cperl-wrong-comment) +(defvar cperl-st-cfence '(14)) ; Comment-fence +(defvar cperl-st-sfence '(15)) ; String-fence +(defvar cperl-st-punct '(1)) +(defvar cperl-st-word '(2)) +(defvar cperl-st-bra '(4 . ?\>)) +(defvar cperl-st-ket '(5 . ?\<)) + (defun cperl-comment-indent () - (let ((p (point)) (c (current-column)) was) + (let ((p (point)) (c (current-column)) was phony) (if (looking-at "^#") 0 ; Existing comment at bol stays there. ;; Wrong comment found (save-excursion - (setq was (cperl-to-comment-or-eol)) + (setq was (cperl-to-comment-or-eol) + phony (eq (get-text-property (point) 'syntax-table) + cperl-st-cfence)) + (if phony + (progn + (re-search-forward "#\\|$") ; Hmm, what about embedded #? + (if (eq (preceding-char) ?\#) + (forward-char -1)) + (setq was nil))) (if (= (point) p) (progn (skip-chars-backward " \t") @@ -1609,7 +1851,7 @@ (save-excursion (not (re-search-backward - "[#\"'`]\\|\\<q\\(\\|[wqx]\\)\\>" + "[#\"'`]\\|\\<q\\(\\|[wqxr]\\)\\>" beg t))) (save-excursion (or (not (re-search-backward "^=" nil t)) (or @@ -1681,6 +1923,7 @@ (forward-char -1) (bolp)) (or + (get-text-property (point) 'in-pod) (cperl-after-expr-p nil "{;:") (and (re-search-backward "\\(\\`\n?\\|\n\n\\)=\\sw+" (point-min) t) @@ -1741,7 +1984,7 @@ (save-excursion (not (re-search-backward - "[#\"'`]\\|\\<q\\(\\|[wqx]\\)\\>" + "[#\"'`]\\|\\<q\\(\\|[wqxr]\\)\\>" beg t))) (save-excursion (or (not (re-search-backward "^=" nil t)) (looking-at "=cut") @@ -1980,6 +2223,7 @@ so that this line becomes properly indented. The relative indentation among the lines of the expression are preserved." (interactive "P") + (cperl-update-syntaxification (point) (point)) (if whole-exp ;; If arg, always indent this line as Perl ;; and shift remaining lines of expression the same amount. @@ -2003,13 +2247,13 @@ (insert-tab) (cperl-indent-line)))) -(defun cperl-indent-line (&optional symbol) +(defun cperl-indent-line (&optional parse-data) "Indent current line as Perl code. Return the amount the indentation changed by." (let (indent i beg shift-amt (case-fold-search nil) (pos (- (point-max) (point)))) - (setq indent (cperl-calculate-indent nil symbol) + (setq indent (cperl-calculate-indent parse-data) i indent) (beginning-of-line) (setq beg (point)) @@ -2056,16 +2300,20 @@ (looking-at "[a-zA-Z_][a-zA-Z0-9_]*:[^:]")))) (defun cperl-get-state (&optional parse-start start-state) - ;; returns list (START STATE DEPTH PRESTART), START is a good place - ;; to start parsing, STATE is what is returned by - ;; `parse-partial-sexp'. DEPTH is true is we are immediately after - ;; end of block which contains START. PRESTART is the position - ;; basing on which START was found. + ;; returns list (START STATE DEPTH PRESTART), + ;; START is a good place to start parsing, or equal to + ;; PARSE-START if preset, + ;; STATE is what is returned by `parse-partial-sexp'. + ;; DEPTH is true is we are immediately after end of block + ;; which contains START. + ;; PRESTART is the position basing on which START was found. (save-excursion (let ((start-point (point)) depth state start prestart) - (if parse-start + (if (and parse-start + (<= parse-start start-point)) (goto-char parse-start) - (beginning-of-defun)) + (beginning-of-defun) + (setq start-state nil)) (setq prestart (point)) (if start-state nil ;; Try to go out, if sub is not on the outermost level @@ -2079,7 +2327,6 @@ (beginning-of-line 2))) ; Go to the next line. (if start (goto-char start))) ; Not at the start of file (setq start (point)) - (if (< start start-point) (setq parse-start start)) (or state (setq state (parse-partial-sexp start start-point -1 nil start-state))) (list start state depth prestart)))) @@ -2095,7 +2342,7 @@ (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\\|qw\\|tr\\|[smy]\\)\\>"))) + (not (looking-at "\\(bless\\|return\\|q[wqrx]?\\|tr\\|[smy]\\)\\>"))) (progn (skip-chars-backward " \t\n\f") (and (memq (char-syntax (preceding-char)) '(?w ?_)) @@ -2106,10 +2353,13 @@ (defvar cperl-look-for-prop '((pod in-pod) (here-doc-delim here-doc-group))) -(defun cperl-calculate-indent (&optional parse-start symbol) +(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." +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.." (save-excursion (if (or (memq (get-text-property (point) 'syntax-type) @@ -2148,15 +2398,22 @@ (setq pre-indent-point (point))))))) (goto-char pre-indent-point) (let* ((case-fold-search nil) - (s-s (cperl-get-state)) - (start (nth 0 s-s)) + (s-s (cperl-get-state (car parse-data) (nth 1 parse-data))) + (start (or (nth 2 parse-data) + (nth 0 s-s))) (state (nth 1 s-s)) (containing-sexp (car (cdr state))) - (start-indent (save-excursion - (goto-char start) - (- (current-indentation) - (if (nth 2 s-s) cperl-indent-level 0)))) old-indent) + (if (and + ;;containing-sexp ;; We are buggy at toplevel :-( + parse-data) + (progn + (setcar parse-data pre-indent-point) + (setcar (cdr parse-data) state) + (or (nth 2 parse-data) + (setcar (cddr parse-data) start)) + ;; Before this point: end of statement + (setq old-indent (nth 3 parse-data)))) ;; (or parse-start (null symbol) ;; (setq parse-start (symbol-value symbol) ;; start-indent (nth 2 parse-start) @@ -2206,26 +2463,36 @@ ;; unless that ends in a closeparen without semicolon, ;; in which case this line is the first argument decl. (skip-chars-forward " \t") - (+ start-indent - (if (= (following-char) ?{) cperl-continued-brace-offset 0) + (+ (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 parse-start (point-min))) + (cperl-backward-to-noncomment (or old-indent (point-min))) ;; Look at previous line that's at column 0 ;; to determine whether we are in top-level decls ;; or function's arg decls. Set basic-indent accordingly. ;; Now add a little if this is a continuation line. (if (or (bobp) + (eq (point) old-indent) ; old-indent was at comment (eq (preceding-char) ?\;) ;; Had ?\) too (and (eq (preceding-char) ?\}) - (cperl-after-block-and-statement-beg start)) + (cperl-after-block-and-statement-beg + (point-min))) ; Was start - too close (memq char-after (append ")]}" nil)) (and (eq (preceding-char) ?\:) ; label (progn (forward-sexp -1) (skip-chars-backward " \t") (looking-at "[ \t]*[a-zA-Z_][a-zA-Z_0-9]*[ \t]*:")))) - 0 + (progn + (if (and parse-data + (not (eq char-after ?\C-j))) + (setcdr (cddr parse-data) + (list pre-indent-point))) + 0) cperl-continued-statement-offset)))) ((/= (char-after containing-sexp) ?{) ;; line is expression, not statement: @@ -2255,11 +2522,13 @@ (cperl-backward-to-noncomment containing-sexp) ;; Back up over label lines, since they don't ;; affect whether our line is a continuation. - (while (or (eq (preceding-char) ?\,) + ;; (Had \, too) + (while ;;(or (eq (preceding-char) ?\,) (and (eq (preceding-char) ?:) (or;;(eq (char-after (- (point) 2)) ?\') ; ???? (memq (char-syntax (char-after (- (point) 2))) - '(?w ?_))))) + '(?w ?_)))) + ;;) (if (eq (preceding-char) ?\,) ;; Will go to beginning of line, essentially. ;; Will ignore embedded sexpr XXXX. @@ -2275,12 +2544,22 @@ ;; This line is continuation of preceding line's statement; ;; indent `cperl-continued-statement-offset' more than the ;; previous line of the statement. + ;; + ;; There might be a label on this line, just + ;; consider it bad style and ignore it. (progn (cperl-backward-to-start-of-continued-exp containing-sexp) (+ (if (memq char-after (append "}])" nil)) 0 ; Closing parenth cperl-continued-statement-offset) - (current-column) + (if (looking-at "\\w+[ \t]*:") + (if (> (current-indentation) cperl-min-label-indent) + (- (current-indentation) cperl-label-offset) + ;; Do not move `parse-data', this should + ;; be quick anyway (this comment comes + ;;from different location): + (cperl-calculate-indent)) + (current-column)) (if (eq char-after ?\{) cperl-continued-brace-offset 0))) ;; This line starts a new statement. @@ -2364,9 +2643,9 @@ (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 - (if (and parse-start (<= parse-start (point))) - parse-start))) + ;; Do not move `parse-data', this should + ;; be quick anyway: + (cperl-calculate-indent)) (current-indentation)))))))))))))) (defvar cperl-indent-alist @@ -2528,9 +2807,7 @@ (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 - (if (and parse-start (<= parse-start (point))) - parse-start))) + (cperl-calculate-indent)) (current-indentation)))))))) res))) @@ -2578,7 +2855,7 @@ "\\=\\w+[ \t]*#\\([^\n\\\\#]\\|\\\\[\\\\#]\\)*#\\([^\n\\\\#]\\|\\\\[\\\\#]\\)*" lim 'move) (setq stop-in t))) - ((looking-at "\\(m\\|q\\([qxw]\\)?\\)\\>") + ((looking-at "\\(m\\|q\\([qxwr]\\)?\\)\\>") (or (re-search-forward "\\=\\w+[ \t]*#\\([^\n\\\\#]\\|\\\\[\\\\#]\\)*#" lim 'move) @@ -2598,13 +2875,6 @@ (defsubst cperl-1+ (p) (min (point-max) (1+ p))) -(defvar cperl-st-cfence '(14)) ; Comment-fence -(defvar cperl-st-sfence '(15)) ; String-fence -(defvar cperl-st-punct '(1)) -(defvar cperl-st-word '(2)) -(defvar cperl-st-bra '(4 . ?\>)) -(defvar cperl-st-ket '(5 . ?\<)) - (defsubst cperl-modify-syntax-type (at how) (if (< at (point-max)) (progn @@ -2618,9 +2888,10 @@ (while (re-search-forward "^\\s(" e 'to-end) (put-text-property (1- (point)) (point) 'syntax-table cperl-st-punct)))) -(defun cperl-commentify (bb e string) +(defun cperl-commentify (bb e string &optional noface) (if cperl-use-syntax-table-text-property - (progn + (if (eq noface 'n) ; Only immediate + nil ;; We suppose that e is _after_ the end of construction, as after eol. (setq string (if string cperl-st-sfence cperl-st-cfence)) (cperl-modify-syntax-type bb string) @@ -2628,7 +2899,16 @@ (if (and (eq string cperl-st-sfence) (> (- e 2) bb)) (put-text-property (1+ bb) (1- e) 'syntax-table cperl-string-syntax-table)) - (cperl-protect-defun-start bb e)))) + (cperl-protect-defun-start bb e)) + ;; Fontify + (or noface + (not cperl-pod-here-fontify) + (put-text-property bb e 'face (if string 'font-lock-string-face + 'font-lock-comment-face))))) +(defvar cperl-starters '(( ?\( . ?\) ) + ( ?\[ . ?\] ) + ( ?\{ . ?\} ) + ( ?\< . ?\> ))) (defun cperl-forward-re (lim end is-2arg set-st st-l err-l argument &optional ostart oend) @@ -2638,13 +2918,8 @@ (skip-chars-forward " \t") ;; ender means matching-char matcher. (setq b (point) - starter (char-after b) - ;; ender: - ender (cdr (assoc starter '(( ?\( . ?\) ) - ( ?\[ . ?\] ) - ( ?\{ . ?\} ) - ( ?\< . ?\> ) - )))) + starter (if (eobp) 0 (char-after b)) + ender (cdr (assoc starter cperl-starters))) ;; What if starter == ?\\ ???? (if set-st (if (car st-l) @@ -2666,6 +2941,8 @@ (modify-syntax-entry ender (concat ")" (list starter)) st))) (condition-case bb (progn + ;; We use `$' syntax class to find matching stuff, but $$ + ;; is recognized the same as $, so we need to check this manually. (if (and (eq starter (char-after (cperl-1+ b))) (not ender)) ;; $ has TeXish matching rules, so $$ equiv $... @@ -2681,6 +2958,7 @@ (forward-char -2) (= 0 (% (skip-chars-backward "\\\\") 2))) (forward-char -1))) + ;; Now we are after the first part. (and is-2arg ; Have trailing part (not ender) (eq (following-char) starter) ; Empty trailing part @@ -2703,15 +2981,14 @@ (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 argument starter ender) + (setq ender (cperl-forward-re lim end nil t st-l err-l + argument starter ender) ender (nth 2 ender))))) (error (goto-char lim) (setq set-st nil) (or end (message - "End of `%s%s%c ... %c' string not found: %s" + "End of `%s%s%c ... %c' string/RE not found: %s" argument (if ostart (format "%c ... %c" ostart (or oend ostart)) "") starter (or ender starter) bb) @@ -2720,11 +2997,60 @@ (progn (modify-syntax-entry starter (if (eq starter ?\\) "\\" ".") st) (if ender (modify-syntax-entry ender "." st)))) + ;; i: have 2 args, after end of the first arg + ;; i2: start of the second arg, if any (before delim iff `ender'). + ;; ender: the last arg bounded by parens-like chars, the second one of them + ;; starter: the starting delimiter of the first arg + ;; go-forward: has 2 args, and the second part is empth (list i i2 ender starter go-forward))) (defvar font-lock-string-face) -(defvar font-lock-reference-face) +;;(defvar font-lock-reference-face) (defvar font-lock-constant-face) +(defsubst cperl-postpone-fontification (b e type val &optional now) + ;; Do after syntactic fontification? + (if cperl-syntaxify-by-font-lock + (or now (put-text-property b e 'cperl-postpone (cons type val))) + (put-text-property b e type val))) + +;;; Here is how the global structures (those which cannot be +;;; recognized locally) are marked: +;; a) PODs: +;; Start-to-end is marked `in-pod' ==> t +;; Each non-literal part is marked `syntax-type' ==> `pod' +;; Each literal part is marked `syntax-type' ==> `in-pod' +;; b) HEREs: +;; Start-to-end is marked `here-doc-group' ==> t +;; The body is marked `syntax-type' ==> `here-doc' +;; The delimiter is marked `syntax-type' ==> `here-doc-delim' +;; c) FORMATs: +;; After-initial-line--to-end is marked `syntax-type' ==> `format' +;; d) 'Q'uoted string: +;; part between markers inclusive is marked `syntax-type' ==> `string' + +(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)) + (if pos + (if before + (progn + (goto-char (cperl-1- pos)) + (beginning-of-line) + (setq pos (point))) + (goto-char (setq pos (cperl-1- pos)))) + ;; Up to the start + (goto-char (point-min)))) + (if end + ;; Do the same for end, going small steps + (progn + (while (and end (get-text-property end 'syntax-type)) + (setq pos end + end (next-single-property-change end 'syntax-type))) + (or end pos))))) + (defun cperl-find-pods-heres (&optional min max non-inter end ignore-max) "Scans the buffer for hard-to-parse Perl constructions. If `cperl-pod-here-fontify' is not-nil after evaluation, will fontify @@ -2735,8 +3061,8 @@ cperl-syntax-state nil cperl-syntax-done-to min)) (or max (setq max (point-max))) - (let* (face head-face here-face b e bb tag qtag b1 e1 argument i c tail - (cperl-pod-here-fontify (eval cperl-pod-here-fontify)) go + (let* (face head-face here-face b e bb tag qtag b1 e1 argument i c tail tb + (cperl-pod-here-fontify (eval cperl-pod-here-fontify)) go tmpend (case-fold-search nil) (inhibit-read-only t) (buffer-undo-list t) (modified (buffer-modified-p)) (after-change-functions nil) @@ -2752,6 +3078,17 @@ (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) + font-lock-constant-face + 'font-lock-constant-face)) + (font-lock-function-name-face + (if (boundp 'font-lock-function-name-face) + font-lock-function-name-face + 'font-lock-function-name-face)) + (cperl-nonoverridable-face + (if (boundp 'cperl-nonoverridable-face) + cperl-nonoverridable-face + 'cperl-nonoverridable-face)) (stop-point (if ignore-max (point-max) max)) @@ -2761,16 +3098,17 @@ "\\|" ;; One extra () before this: "<<" - "\\(" + "\\(" ; 1 + 1 ;; First variant "BLAH" or just ``. - "\\([\"'`]\\)" - "\\([^\"'`\n]*\\)" + "\\([\"'`]\\)" ; 2 + 1 + "\\([^\"'`\n]*\\)" ; 3 + 1 "\\3" "\\|" - ;; Second variant: Identifier or empty - "\\(\\([a-zA-Z_][a-zA-Z_0-9]*\\)?\\)" - ;; Check that we do not have <<= or << 30 or << $blah. - "\\([^= \t$@%&]\\|[ \t]+[^ \t\n0-9$@%&]\\)" + ;; Second variant: Identifier or \ID or empty + "\\\\?\\(\\([a-zA-Z_][a-zA-Z_0-9]*\\)?\\)" ; 4 + 1, 5 + 1 + ;; Do not have <<= or << 30 or <<30 or << $blah. + ;; "\\([^= \t0-9$@%&]\\|[ \t]+[^ \t\n0-9$@%&]\\)" ; 6 + 1 + "\\(\\)" ; To preserve count of pars :-( 6 + 1 "\\)" "\\|" ;; 1+6 extra () before this: @@ -2779,10 +3117,10 @@ (concat "\\|" ;; 1+6+2=9 extra () before this: - "\\<\\(q[wxq]?\\|[msy]\\|tr\\)\\>" + "\\<\\(q[wxqr]?\\|[msy]\\|tr\\)\\>" "\\|" ;; 1+6+2+1=10 extra () before this: - "\\([?/]\\)" ; /blah/ or ?blah? + "\\([?/<]\\)" ; /blah/ or ?blah? or <file*glob> "\\|" ;; 1+6+2+1+1=11 extra () before this: "\\<sub\\>[ \t]*\\([a-zA-Z_:'0-9]+[ \t]*\\)?\\(([^()]*)\\)" @@ -2808,7 +3146,8 @@ head-face cperl-pod-head-face here-face cperl-here-face)) (remove-text-properties min max - '(syntax-type t in-pod t syntax-table t)) + '(syntax-type t in-pod t syntax-table t + cperl-postpone t)) ;; Need to remove face as well... (goto-char min) (and (eq system-type 'emx) @@ -2819,70 +3158,110 @@ (while (and (< (point) max) (re-search-forward search max t)) + (setq tmpend nil) ; Valid for most cases (cond ((match-beginning 1) ; POD section ;; "\\(\\`\n?\\|\n\n\\)=" (if (looking-at "\n*cut\\>") - (progn + (if ignore-max + nil ; Doing a chunk only (message "=cut is not preceded by a POD section") (or (car err-l) (setcar err-l (point)))) (beginning-of-line) - (setq b (point) bb b) + (setq b (point) + bb b + tb (match-beginning 0) + b1 nil) ; error condition ;; We do not search to max, since we may be called from ;; some hook of fontification, and max is random (or (re-search-forward "\n\n=cut\\>" stop-point 'toend) (progn (message "End of a POD section not marked by =cut") + (setq b1 t) (or (car err-l) (setcar err-l b)))) (beginning-of-line 2) ; An empty line after =cut is not POD! (setq e (point)) + (if (and b1 (eobp)) + ;; Unrecoverable error + nil (and (> e max) - (remove-text-properties max e - '(syntax-type t in-pod t syntax-table t))) + (progn + (remove-text-properties + max e '(syntax-type t in-pod t syntax-table t + 'cperl-postpone t)) + (setq tmpend tb))) (put-text-property b e 'in-pod t) + (put-text-property b e 'syntax-type 'in-pod) (goto-char b) (while (re-search-forward "\n\n[ \t]" e t) ;; We start 'pod 1 char earlier to include the preceding line (beginning-of-line) (put-text-property (cperl-1- b) (point) 'syntax-type 'pod) - (cperl-put-do-not-fontify b (point)) - (if cperl-pod-here-fontify (put-text-property b (point) 'face face)) + (cperl-put-do-not-fontify b (point) t) + ;; mark the non-literal parts as PODs + (if cperl-pod-here-fontify + (cperl-postpone-fontification b (point) 'face face t)) (re-search-forward "\n\n[^ \t\f\n]" e 'toend) (beginning-of-line) (setq b (point))) (put-text-property (cperl-1- (point)) e 'syntax-type 'pod) - (cperl-put-do-not-fontify (point) e) + (cperl-put-do-not-fontify (point) e t) (if cperl-pod-here-fontify - (progn (put-text-property (point) e 'face face) + (progn + ;; mark the non-literal parts as PODs + (cperl-postpone-fontification (point) e 'face face t) (goto-char bb) (if (looking-at "=[a-zA-Z0-9_]+\\>[ \t]*\\(\\(\n?[^\n]\\)+\\)$") - (put-text-property + ;; mark the headers + (cperl-postpone-fontification (match-beginning 1) (match-end 1) 'face head-face)) (while (re-search-forward ;; One paragraph "\n\n=[a-zA-Z0-9_]+\\>[ \t]*\\(\\(\n?[^\n]\\)+\\)$" e 'toend) - (put-text-property + ;; mark the headers + (cperl-postpone-fontification (match-beginning 1) (match-end 1) 'face head-face)))) (cperl-commentify bb e nil) (goto-char e) (or (eq e (point-max)) - (forward-char -1)))) ; Prepare for immediate pod start. + (forward-char -1))))) ; Prepare for immediate pod start. ;; Here document ;; We do only one here-per-line - ;; 1 () ahead - ;; "<<\\(\\([\"'`]\\)\\([^\"'`\n]*\\)\\3\\|\\(\\([a-zA-Z_][a-zA-Z_0-9]*\\)?\\)\\)" + ;; ;; One extra () before this: + ;;"<<" + ;; "\\(" ; 1 + 1 + ;; ;; First variant "BLAH" or just ``. + ;; "\\([\"'`]\\)" ; 2 + 1 + ;; "\\([^\"'`\n]*\\)" ; 3 + 1 + ;; "\\3" + ;; "\\|" + ;; ;; Second variant: Identifier or \ID or empty + ;; "\\\\?\\(\\([a-zA-Z_][a-zA-Z_0-9]*\\)?\\)" ; 4 + 1, 5 + 1 + ;; ;; Do not have <<= or << 30 or <<30 or << $blah. + ;; ;; "\\([^= \t0-9$@%&]\\|[ \t]+[^ \t\n0-9$@%&]\\)" ; 6 + 1 + ;; "\\(\\)" ; 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) - (if (or (nth 3 state) (nth 4 state)) - (goto-char (match-end 2)) + state-point b + tb (match-beginning 0) + i (or (nth 3 state) (nth 4 state))) + (if i + (setq c t) + (setq c (and + (match-beginning 5) + (not (match-beginning 6)) ; Empty + (looking-at + "[ \t]*[=0-9$@%&(]")))) + (if c ; Not here-doc + nil ; Skip it. (if (match-beginning 5) ;4 + 1 (setq b1 (match-beginning 5) ; 4 + 1 e1 (match-end 5)) ; 4 + 1 @@ -2891,8 +3270,9 @@ (setq tag (buffer-substring b1 e1) qtag (regexp-quote tag)) (cond (cperl-pod-here-fontify - (put-text-property b1 e1 'face font-lock-constant-face) - (cperl-put-do-not-fontify b1 e1))) + ;; Highlight the starting delimiter + (cperl-postpone-fontification b1 e1 'face font-lock-constant-face) + (cperl-put-do-not-fontify b1 e1 t))) (forward-line) (setq b (point)) ;; We do not search to max, since we may be called from @@ -2901,10 +3281,12 @@ stop-point 'toend) (if cperl-pod-here-fontify (progn - (put-text-property (match-beginning 0) (match-end 0) + ;; Highlight the ending delimiter + (cperl-postpone-fontification (match-beginning 0) (match-end 0) 'face font-lock-constant-face) - (cperl-put-do-not-fontify b (match-end 0)) - (put-text-property b (match-beginning 0) + (cperl-put-do-not-fontify b (match-end 0) t) + ;; Highlight the HERE-DOC + (cperl-postpone-fontification b (match-beginning 0) 'face here-face))) (setq e1 (cperl-1+ (match-end 0))) (put-text-property b (match-beginning 0) @@ -2914,7 +3296,9 @@ (put-text-property b e1 'here-doc-group t) (cperl-commentify b e1 nil) - (cperl-put-do-not-fontify b (match-end 0))) + (cperl-put-do-not-fontify b (match-end 0) t) + (if (> e1 max) + (setq tmpend tb))) (t (message "End of here-document `%s' not found." tag) (or (car err-l) (setcar err-l b)))))) ;; format @@ -2925,7 +3309,8 @@ name (if (match-beginning 8) ; 7 + 1 (buffer-substring (match-beginning 8) ; 7 + 1 (match-end 8)) ; 7 + 1 - "")) + "") + tb (match-beginning 0)) (setq argument nil) (if cperl-pod-here-fontify (while (and (eq (forward-line) 0) @@ -2942,30 +3327,34 @@ (setq b1 (point)) (setq argument (looking-at "^[^\n]*[@^]")) (end-of-line) - (put-text-property b1 (point) + ;; Highlight the format line + (cperl-postpone-fontification b1 (point) 'face font-lock-string-face) (cperl-commentify b1 (point) nil) - (cperl-put-do-not-fontify b1 (point))))) + (cperl-put-do-not-fontify b1 (point) t)))) ;; We do not search to max, since we may be called from ;; some hook of fontification, and max is random (re-search-forward "^[.;]$" stop-point 'toend)) (beginning-of-line) - (if (looking-at "^[.;]$") + (if (looking-at "^\\.$") ; ";" is not supported yet (progn - (put-text-property (point) (+ (point) 2) + ;; Highlight the ending delimiter + (cperl-postpone-fontification (point) (+ (point) 2) 'face font-lock-string-face) (cperl-commentify (point) (+ (point) 2) nil) - (cperl-put-do-not-fontify (point) (+ (point) 2))) + (cperl-put-do-not-fontify (point) (+ (point) 2) t)) (message "End of format `%s' not found." name) (or (car err-l) (setcar err-l b))) (forward-line) + (if (> (point) max) + (setq tmpend tb)) (put-text-property b (point) 'syntax-type 'format)) ;; Regexp: ((or (match-beginning 10) (match-beginning 11)) ;; 1+6+2=9 extra () before this: - ;; "\\<\\(q[wxq]?\\|[msy]\\|tr\\)\\>" + ;; "\\<\\(q[wxqr]?\\|[msy]\\|tr\\)\\>" ;; "\\|" - ;; "\\([?/]\\)" ; /blah/ or ?blah? + ;; "\\([?/<]\\)" ; /blah/ or ?blah? or <file*glob> (setq b1 (if (match-beginning 10) 10 11) argument (buffer-substring (match-beginning b1) (match-end b1)) @@ -2973,19 +3362,26 @@ i b c (char-after (match-beginning b1)) bb (char-after (1- (match-beginning b1))) ; tmp holder - bb (and ; user variables/whatever - (match-beginning 10) + ;; bb == "Not a stringy" + bb (if (eq b1 10) ; user variables/whatever (or (memq bb '(?\$ ?\@ ?\% ?\* ?\#)) ; $#y (and (eq bb ?-) (eq c ?s)) ; -s file test (and (eq bb ?\&) ; &&m/blah/ (not (eq (char-after (- (match-beginning b1) 2)) - ?\&)))))) + ?\&)))) + ;; <file> or <$file> + (and (eq c ?\<) + ;; Do not stringify <FH> : + (save-match-data + (looking-at + "\\s *\\$?\\([_a-zA-Z:][_a-zA-Z0-9:]*\\s *\\)?>")))) + tb (match-beginning 0)) (goto-char (match-beginning b1)) (cperl-backward-to-noncomment (point-min)) (or bb - (if (eq b1 11) ; bare /blah/ or ?blah? + (if (eq b1 11) ; bare /blah/ or ?blah? or <foo> (setq argument "" bb ; Not a regexp? (progn @@ -2993,10 +3389,10 @@ ;; What is below: regexp-p? (and (or (memq (preceding-char) - (append (if (eq c ?\?) + (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) @@ -3004,8 +3400,11 @@ (forward-sexp -1) ;;; After these keywords `/' starts a RE. One should add all the ;;; functions/builtins which expect an argument, but ... + (if (eq (preceding-char) ?-) + ;; -d ?foo? is a RE + (looking-at "[a-zA-Z]\\>") (looking-at - "\\(while\\|if\\|unless\\|until\\|and\\|or\\|not\\|xor\\|split\\|grep\\|map\\|print\\)\\>"))) + "\\(while\\|if\\|unless\\|until\\|and\\|or\\|not\\|xor\\|split\\|grep\\|map\\|print\\)\\>")))) (and (eq (preceding-char) ?.) (eq (char-after (- (point) 2)) ?.)) (bobp)) @@ -3037,53 +3436,106 @@ ;; 2 or 3 later if some special quoting is needed. ;; e1 means matching-char matcher. (setq b (point) + ;; 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 - (string-match "^\\([sy]\\|tr\\)$" argument) + i2 t st-l err-l argument) - i2 (nth 1 i) ; start of the second part - e1 (nth 2 i) ; ender, true if matching second part + ;; Note that if `go', then it is considered as 1-arg + b1 (nth 1 i) ; start of the second part + tag (nth 2 i) ; ender-char, true if second part + ; is with matching chars [] go (nth 4 i) ; There is a 1-char part after the end i (car i) ; intermediate point - tail (if (and i (not e1)) (1- (point))) - e nil) ; need to preserve backslashitis + e1 (point) ; end + ;; Before end of the second part if non-matching: /// + tail (if (and i (not tag)) + (1- e1)) + e (if i i e1) ; end of the first part + qtag nil) ; need to preserve backslashitis ;; Commenting \\ is dangerous, what about ( ? (and i tail (eq (char-after i) ?\\) - (setq e t)) + (setq qtag t)) (if (null i) + ;; Considered as 1arg form (progn (cperl-commentify b (point) t) - (if go (forward-char 1))) + (put-text-property b (point) 'syntax-type 'string) + (and go + (setq e1 (cperl-1+ e1)) + (or (eobp) + (forward-char 1)))) (cperl-commentify b i t) (if (looking-at "\\sw*e") ; s///e (progn (and ;; silent: - (cperl-find-pods-heres i2 (1- (point)) t end) + (cperl-find-pods-heres b1 (1- (point)) t end) ;; Error (goto-char (1+ max))) - (if (and e1 (eq (preceding-char) ?\>)) + (if (and tag (eq (preceding-char) ?\>)) (progn (cperl-modify-syntax-type (1- (point)) cperl-st-ket) - (cperl-modify-syntax-type i cperl-st-bra)))) - (cperl-commentify i2 (point) t) - (if e + (cperl-modify-syntax-type i cperl-st-bra))) + (put-text-property b i 'syntax-type 'string)) + (cperl-commentify b1 (point) t) + (put-text-property b (point) 'syntax-type 'string) + (if qtag (cperl-modify-syntax-type (1+ i) cperl-st-punct)) (setq tail nil))) + ;; Now: tail: if the second part is non-matching without ///e (if (eq (char-syntax (following-char)) ?w) (progn (forward-word 1) ; skip modifiers s///s - (if tail (cperl-commentify tail (point) t)))))) + (if tail (cperl-commentify tail (point) t)) + (cperl-postpone-fontification + e1 (point) 'face cperl-nonoverridable-face))) + ;; Check whether it is m// which means "previous match" + ;; and highlight differently + (if (and (eq e (+ 2 b)) + (string-match "^\\([sm]?\\|qr\\)$" argument) + ;; <> is already filtered out + ;; split // *is* using zero-pattern + (save-excursion + (condition-case nil + (progn + (goto-char tb) + (forward-sexp -1) + (not (looking-at "split\\>"))) + (error t)))) + (cperl-postpone-fontification + b e 'face font-lock-function-name-face) + (if (or i2 ; Has 2 args + (and cperl-fontify-m-as-s + (or + (string-match "^\\(m\\|qr\\)$" argument) + (and (eq 0 (length argument)) + (not (eq ?\< (char-after b))))))) + (progn + (cperl-postpone-fontification + b (cperl-1+ b) 'face font-lock-constant-face) + (cperl-postpone-fontification + (1- e) e 'face font-lock-constant-face)))) + (if i2 + (progn + (cperl-postpone-fontification + (1- e1) e1 'face font-lock-constant-face) + (if (assoc (char-after b) cperl-starters) + (cperl-postpone-fontification + b1 (1+ b1) 'face font-lock-constant-face)))) + (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 (1- b) nil nil state) - state-point (1- b)) + state-point b nil nil state) + state-point b) (if (or (nth 3 state) (nth 4 state)) nil ;; Mark as string @@ -3139,7 +3591,7 @@ (or (car err-l) (setcar err-l b))) (goto-char stop-point)))) (setq cperl-syntax-state (cons state-point state) - cperl-syntax-done-to (max (point) max))) + cperl-syntax-done-to (or tmpend (max (point) max)))) (if (car err-l) (goto-char (car err-l)) (or non-inter (message "Scanning for \"hard\" Perl constructions... done")))) @@ -3151,18 +3603,21 @@ (defun cperl-backward-to-noncomment (lim) ;; Stops at lim or after non-whitespace that is not in comment - (let (stop p) + (let (stop p pr) (while (and (not stop) (> (point) (or lim 1))) (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) (if (or (looking-at "^[ \t]*\\(#\\|$\\)") (progn (cperl-to-comment-or-eol) (bolp))) nil ; Only comment, skip ;; Else (skip-chars-backward " \t") (if (< p (point)) (goto-char p)) - (setq stop t))))) + (setq stop t)))))) (defun cperl-after-block-p (lim) ;; We suppose that the preceding char is }. @@ -3176,7 +3631,7 @@ (if (eq (char-syntax (preceding-char)) ?w) ; else {} (save-excursion (forward-sexp -1) - (or (looking-at "\\(else\\|grep\\|map\\)\\>") + (or (looking-at "\\(else\\|grep\\|map\\|BEGIN\\|END\\)\\>") ;; sub f {} (progn (cperl-backward-to-noncomment lim) @@ -3200,11 +3655,19 @@ (setq p (point)) (beginning-of-line) (if (looking-at "^[ \t]*\\(#\\|$\\)") nil ; Only comment, skip - ;; Else: last iteration (What to do with labels?) + ;; Else: last iteration, or a label (cperl-to-comment-or-eol) (skip-chars-backward " \t") (if (< p (point)) (goto-char p)) - (setq stop t))) + (setq p (point)) + (if (and (eq (preceding-char) ?:) + (progn + (forward-char -1) + (skip-chars-backward " \t\n\f" lim) + (eq (char-syntax (preceding-char)) ?w))) + (forward-sexp -1) ; Possibly label. Skip it + (goto-char p) + (setq stop t)))) (or (bobp) ; ???? Needed (eq (point) lim) (progn @@ -3243,8 +3706,9 @@ (defun cperl-indent-exp () "Simple variant of indentation of continued-sexp. -Should be slow. Will not indent comment if it starts at `comment-indent' -or looks like continuation of the comment on the previous line. + +Will not indent comment if it starts at `comment-indent' or looks like +continuation of the comment on the previous line. If `cperl-indent-region-fix-constructs', will improve spacing on conditional/loop constructs." @@ -3262,7 +3726,10 @@ (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) (progn (end-of-line) (setq tmp-end (point))) + (if (> (point) tmp-end) + (save-excursion + (end-of-line) + (setq tmp-end (point))) (setq done t))) (goto-char tmp-end) (setq tmp-end (point-marker))) @@ -3270,16 +3737,25 @@ (cperl-fix-line-spacing tmp-end)) (cperl-indent-region (point) tmp-end)))) -(defun cperl-fix-line-spacing (&optional end) - "Improve whitespace in a conditional/loop construct." +(defun cperl-fix-line-spacing (&optional end parse-data) + "Improve whitespace in a conditional/loop construct. +Returns some position at the last line." (interactive) (or end (setq end (point-max))) - (let (p pp ml + (let (p pp ml have-brace ret + (ee (save-excursion (end-of-line) (point))) (cperl-indent-region-fix-constructs (or cperl-indent-region-fix-constructs 1))) (save-excursion (beginning-of-line) + (setq ret (point)) + ;; }? continue + ;; blah; } + (if (not + (or (looking-at "[ \t]*\\(els\\(e\\|if\\)\\|continue\\|if\\|while\\|for\\(each\\)?\\|until\\)") + (setq have-brace (save-excursion (search-forward "}" ee t))))) + nil ; Do not need to do anything ;; Looking at: ;; } ;; else @@ -3304,7 +3780,7 @@ ;; Looking at: ;; else { (if (looking-at - "[ \t]*}?[ \t]*\\<\\(\\els\\(e\\|if\\)\\|continue\\|if\\|while\\|for\\(each\\)?\\|until\\)\\>\\(\t*\\|[ \t][ \t]+\\)[^ \t\n#]") + "[ \t]*}?[ \t]*\\<\\(\\els\\(e\\|if\\)\\|continue\\|unless\\|if\\|while\\|for\\(each\\)?\\|until\\)\\>\\(\t*\\|[ \t][ \t]+\\)[^ \t\n#]") (progn (forward-word 1) (delete-horizontal-space) @@ -3332,7 +3808,7 @@ ;; Looking at: ;; } foreach my $var () { (if (looking-at - "[ \t]*\\(}[ \t]*\\)?\\<\\(\\els\\(e\\|if\\)\\|continue\\|if\\|while\\|for\\(each\\)?\\(\\([ t]+\\(my\\|local\\)\\)?[ \t]*\\$[_a-zA-Z0-9]+\\)?\\|until\\)\\>\\([ \t]*(\\|[ \t\n]*{\\)\\|[ \t]*{") + "[ \t]*\\(}[ \t]*\\)?\\<\\(\\els\\(e\\|if\\)\\|continue\\|if\\|unless\\|while\\|for\\(each\\)?\\(\\([ t]+\\(my\\|local\\)\\)?[ \t]*\\$[_a-zA-Z0-9]+\\)?\\|until\\)\\>\\([ \t]*(\\|[ \t\n]*{\\)\\|[ \t]*{") (progn (setq ml (match-beginning 8)) (re-search-forward "[({]") @@ -3365,8 +3841,11 @@ (progn (delete-horizontal-space) (insert "\n") - (if (cperl-indent-line) - (cperl-fix-line-spacing end))) + (setq ret (point)) + (if (cperl-indent-line parse-data) + (progn + (cperl-fix-line-spacing end parse-data) + (setq ret (point))))) (insert (make-string cperl-indent-region-fix-constructs ?\ )))) ((and (looking-at "[ \t]*\n") @@ -3393,15 +3872,17 @@ (goto-char (1+ pp)) (delete-horizontal-space) (insert "\n") - (if (cperl-indent-line) - (cperl-fix-line-spacing end)))))))))) + (setq ret (point)) + (if (cperl-indent-line parse-data) + (setq ret (cperl-fix-line-spacing end parse-data))))))))))) (beginning-of-line) - (setq p (point) pp (save-excursion (end-of-line) (point))) + (setq p (point) pp (save-excursion (end-of-line) (point))) ; May be different from ee. ;; Now check whether there is a hanging `}' ;; Looking at: ;; } blah (if (and cperl-fix-hanging-brace-when-indent + have-brace (not (looking-at "[ \t]*}[ \t]*\\(\\<\\(els\\(if\\|e\\)\\|continue\\|while\\|until\\)\\>\\|$\\|#\\)")) (condition-case nil (progn @@ -3419,7 +3900,7 @@ (if (bolp) ;; `}' was the first thing on the line, insert NL *after* it. (progn - (cperl-indent-line) + (cperl-indent-line parse-data) (search-forward "}") (delete-horizontal-space) (insert "\n")) @@ -3429,10 +3910,18 @@ (and (eq (preceding-char) ?\} ) (cperl-after-block-p (point-min))) (insert ";")) - (insert "\n")) - (if (cperl-indent-line) - (cperl-fix-line-spacing end)) - (beginning-of-line)))))) + (insert "\n") + (setq ret (point))) + (if (cperl-indent-line parse-data) + (setq ret (cperl-fix-line-spacing end parse-data))) + (beginning-of-line))))) + ret)) + +(defvar cperl-update-start) ; Do not need to make them local +(defvar cperl-update-end) +(defun cperl-delay-update-hook (beg end old-len) + (setq cperl-update-start (min beg (or cperl-update-start (point-max)))) + (setq cperl-update-end (max end (or cperl-update-end (point-min))))) (defun cperl-indent-region (start end) "Simple variant of indentation of region in CPerl mode. @@ -3444,9 +3933,16 @@ If `cperl-indent-region-fix-constructs', will improve spacing on conditional/loop constructs." (interactive "r") + (cperl-update-syntaxification end end) (save-excursion - (let (st comm indent-info old-comm-indent new-comm-indent p pp i + (let (cperl-update-start cperl-update-end (h-a-c after-change-functions)) + (let (st comm old-comm-indent new-comm-indent p pp i empty + (indent-info (if cperl-emacs-can-parse + (list nil nil nil) ; Cannot use '(), since will modify + nil)) + after-change-functions ; Speed it up! (pm 0) (imenu-scanning-message "Indenting... (%3d%%)")) + (if h-a-c (add-hook 'after-change-functions 'cperl-delay-update-hook)) (goto-char start) (setq old-comm-indent (and (cperl-to-comment-or-eol) (current-column)) @@ -3460,30 +3956,36 @@ (and (fboundp 'imenu-progress-message) (imenu-progress-message pm (/ (* 100 (- (point) start)) (- end start -1)))) - (setq st (point) - indent-info nil - ) ; Believe indentation of the current - (if (and (setq comm (looking-at "[ \t]*#")) + (setq st (point)) + (if (or + (setq empty (looking-at "[ \t]*\n")) + (and (setq comm (looking-at "[ \t]*#")) (or (eq (current-indentation) (or old-comm-indent comment-column)) - (setq old-comm-indent nil))) + (setq old-comm-indent nil)))) (if (and old-comm-indent + (not empty) (= (current-indentation) old-comm-indent) - (not (eq (get-text-property (point) 'syntax-type) 'pod))) + (not (eq (get-text-property (point) 'syntax-type) 'pod)) + (not (eq (get-text-property (point) 'syntax-table) + cperl-st-cfence))) (let ((comment-column new-comm-indent)) (indent-for-comment))) (progn - (setq i (cperl-indent-line 'indent-info)) + (setq i (cperl-indent-line indent-info)) (or comm (not i) (progn (if cperl-indent-region-fix-constructs - (cperl-fix-line-spacing end)) + (goto-char (cperl-fix-line-spacing end indent-info))) (if (setq old-comm-indent (and (cperl-to-comment-or-eol) (not (memq (get-text-property (point) 'syntax-type) '(pod here-doc))) + (not (eq (get-text-property (point) + 'syntax-table) + cperl-st-cfence)) (current-column))) (progn (indent-for-comment) (skip-chars-backward " \t") @@ -3492,7 +3994,18 @@ (beginning-of-line 2)) (if (fboundp 'imenu-progress-message) (imenu-progress-message pm 100) - (message nil))))) + (message nil))) + ;; Now run the update hooks + (if after-change-functions + (save-excursion + (if cperl-update-end + (progn + (goto-char cperl-update-end) + (insert " ") + (delete-char -1) + (goto-char cperl-update-start) + (insert " ") + (delete-char -1)))))))) ;; Stolen from lisp-mode with a lot of improvements @@ -3827,8 +4340,16 @@ (defvar font-lock-background-mode) (defvar font-lock-display-type) +(defun cperl-init-faces-weak () + ;; Allow `cperl-find-pods-heres' to run. + (or (boundp 'font-lock-constant-face) + (cperl-force-face font-lock-constant-face + "Face for constant and label names") + ;;(setq font-lock-constant-face 'font-lock-constant-face) + )) + (defun cperl-init-faces () - (condition-case nil + (condition-case errs (progn (require 'font-lock) (and (fboundp 'font-lock-fontify-anchored-keywords) @@ -3840,6 +4361,7 @@ (setq t-font-lock-keywords (list + (list "[ \t]+$" 0 cperl-invalid-face t) (cons (concat "\\(^\\|[^$@%&\\]\\)\\<\\(" @@ -3873,7 +4395,7 @@ ;; "getservbyport" "getservent" "getsockname" ;; "getsockopt" "glob" "gmtime" "gt" "hex" "index" "int" ;; "ioctl" "join" "kill" "lc" "lcfirst" "le" "length" - ;; "link" "listen" "localtime" "log" "lstat" "lt" + ;; "link" "listen" "localtime" "lock" "log" "lstat" "lt" ;; "mkdir" "msgctl" "msgget" "msgrcv" "msgsnd" "ne" ;; "not" "oct" "open" "opendir" "or" "ord" "pack" "pipe" ;; "quotemeta" "rand" "read" "readdir" "readline" @@ -3905,7 +4427,7 @@ "ent\\)\\|gr\\(ent\\|nam\\|gid\\)\\)\\)\\)\\|" "hex\\|i\\(n\\(t\\|dex\\)\\|octl\\)\\|join\\|kill\\|" "l\\(i\\(sten\\|nk\\)\\|stat\\|c\\(\\|first\\)\\|t\\|e" - "\\(\\|ngth\\)\\|o\\(caltime\\|g\\)\\)\\|m\\(sg\\(rcv\\|snd\\|" + "\\(\\|ngth\\)\\|o\\(c\\(altime\\|k\\)\\|g\\)\\)\\|m\\(sg\\(rcv\\|snd\\|" "ctl\\|get\\)\\|kdir\\)\\|n\\(e\\|ot\\)\\|o\\(pen\\(\\|dir\\)\\|" "r\\(\\|d\\)\\|ct\\)\\|p\\(ipe\\|ack\\)\\|quotemeta\\|" "r\\(index\\|and\\|mdir\\|e\\(quire\\|ad\\(pipe\\|\\|lin" @@ -3941,19 +4463,19 @@ "END\\|for\\(\\|each\\|mat\\)\\|g\\(rep\\|oto\\)\\|if\\|keys\\|" "l\\(ast\\|ocal\\)\\|m\\(ap\\|y\\)\\|n\\(ext\\|o\\)\\|" "p\\(ackage\\|rint\\(\\|f\\)\\|ush\\|o\\(p\\|s\\)\\)\\|" - "q\\(\\|q\\|w\\|x\\)\\|re\\(turn\\|do\\)\\|s\\(pli\\(ce\\|t\\)\\|" + "q\\(\\|q\\|w\\|x\\|r\\)\\|re\\(turn\\|do\\)\\|s\\(pli\\(ce\\|t\\)\\|" "calar\\|tudy\\|ub\\|hift\\|ort\\)\\|t\\(r\\|ie\\)\\|" "u\\(se\\|n\\(shift\\|ti\\(l\\|e\\)\\|def\\|less\\)\\)\\|" "while\\|y\\|__\\(END\\|DATA\\)__" ;__DATA__ added manually "\\|[sm]" ; Added manually - "\\)\\>") 2 'font-lock-other-type-face) + "\\)\\>") 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 + '("\\<sub[ \t]+\\([^ \t{;()]+\\)[ \t]*\\(([^()]*)[ \t]*\\)?[#{\n]" 1 font-lock-function-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) @@ -4002,15 +4524,15 @@ '( ("\\(\\([@%]\\|\$#\\)[a-zA-Z_:][a-zA-Z0-9_:]*\\)" 1 (if (eq (char-after (match-beginning 2)) ?%) - font-lock-other-emphasized-face - font-lock-emphasized-face) + cperl-hash-face + cperl-array-face) t) ; arrays and hashes ("\\(\\([$@]+\\)[a-zA-Z_:][a-zA-Z0-9_:]*\\)[ \t]*\\([[{]\\)" 1 (if (= (- (match-end 2) (match-beginning 2)) 1) (if (eq (char-after (match-beginning 3)) ?{) - font-lock-other-emphasized-face - font-lock-emphasized-face) ; arrays and hashes + cperl-hash-face + cperl-array-face) ; arrays and hashes font-lock-variable-name-face) ; Just to put something t) ;;("\\([smy]\\|tr\\)\\([^a-z_A-Z0-9]\\)\\(\\([^\n\\]*||\\)\\)\\2") @@ -4021,10 +4543,14 @@ ;; (if (cperl-slash-is-regexp) ;; font-lock-function-name-face 'default) nil t)) ))) - (setq perl-font-lock-keywords-1 t-font-lock-keywords + (setq perl-font-lock-keywords-1 + (if cperl-syntaxify-by-font-lock + (cons 'cperl-fontify-update + t-font-lock-keywords) + t-font-lock-keywords) perl-font-lock-keywords perl-font-lock-keywords-1 perl-font-lock-keywords-2 (append - t-font-lock-keywords + perl-font-lock-keywords-1 t-font-lock-keywords-1))) (if (fboundp 'ps-print-buffer) (cperl-ps-print-init)) (if (or (featurep 'choose-color) (featurep 'font-lock-extra)) @@ -4044,12 +4570,6 @@ nil [nil nil t t t] nil) - (list 'font-lock-keyword-face - ["Purple" "LightSteelBlue" "DimGray" "Gray90"] - nil - [nil nil t t t] - nil - nil) (list 'font-lock-function-name-face (vector "Blue" "LightSkyBlue" "Gray50" "LightGray" @@ -4082,7 +4602,7 @@ nil [nil nil t t t] ) - (list 'font-lock-other-type-face + (list 'cperl-nonoverridable-face ["chartreuse3" ("orchid1" "orange") nil "Gray80"] [nil nil "gray90"] @@ -4090,74 +4610,106 @@ [nil nil t t] [nil nil t t t] ) - (list 'font-lock-emphasized-face + (list 'cperl-array-face ["blue" "yellow" nil "Gray80"] ["lightyellow2" ("navy" "os2blue" "darkgreen") "gray90"] t nil nil) - (list 'font-lock-other-emphasized-face + (list 'cperl-hash-face ["red" "red" nil "Gray80"] ["lightyellow2" ("navy" "os2blue" "darkgreen") "gray90"] t t nil)))) + ;; Do it the dull way, without choose-color (defvar cperl-guessed-background nil "Display characteristics as guessed by cperl.") - (or (fboundp 'x-color-defined-p) - (defalias 'x-color-defined-p - (cond ((fboundp 'color-defined-p) 'color-defined-p) - ;; XEmacs >= 19.12 - ((fboundp 'valid-color-name-p) 'valid-color-name-p) - ;; XEmacs 19.11 - (t 'x-valid-color-name-p)))) - (defvar font-lock-constant-face 'font-lock-constant-face) - (defvar font-lock-variable-name-face 'font-lock-variable-name-face) - (or (boundp 'font-lock-type-face) - (defconst font-lock-type-face - 'font-lock-type-face - "Face to use for data types.")) - (or (boundp 'font-lock-other-type-face) - (defconst font-lock-other-type-face - 'font-lock-other-type-face - "Face to use for data types from another group.")) - (if (not cperl-xemacs-p) nil - (or (boundp 'font-lock-comment-face) - (defconst font-lock-comment-face - 'font-lock-comment-face - "Face to use for comments.")) - (or (boundp 'font-lock-keyword-face) - (defconst font-lock-keyword-face - 'font-lock-keyword-face - "Face to use for keywords.")) - (or (boundp 'font-lock-function-name-face) - (defconst font-lock-function-name-face - 'font-lock-function-name-face - "Face to use for function names."))) - (or (boundp 'font-lock-other-emphasized-face) - (defconst font-lock-other-emphasized-face - 'font-lock-other-emphasized-face - "Face to use for another type of emphasizing.")) - (or (boundp 'font-lock-emphasized-face) - (defconst font-lock-emphasized-face - 'font-lock-emphasized-face - "Face to use for emphasizing.")) +;; (or (fboundp 'x-color-defined-p) +;; (defalias 'x-color-defined-p +;; (cond ((fboundp 'color-defined-p) 'color-defined-p) +;; ;; XEmacs >= 19.12 +;; ((fboundp 'valid-color-name-p) 'valid-color-name-p) +;; ;; XEmacs 19.11 +;; (t 'x-valid-color-name-p)))) + (cperl-force-face font-lock-constant-face + "Face for constant and label names") + (cperl-force-face font-lock-variable-name-face + "Face for variable names") + (cperl-force-face font-lock-type-face + "Face for data types") + (cperl-force-face cperl-nonoverridable-face + "Face for data types from another group") + (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-face + "Face for hashes") + (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) + ;;(or (boundp 'font-lock-type-face) + ;; (defconst font-lock-type-face + ;; 'font-lock-type-face + ;; "Face to use for data types.")) + ;;(or (boundp 'cperl-nonoverridable-face) + ;; (defconst cperl-nonoverridable-face + ;; 'cperl-nonoverridable-face + ;; "Face to use for data types from another group.")) + ;;(if (not cperl-xemacs-p) nil + ;; (or (boundp 'font-lock-comment-face) + ;; (defconst font-lock-comment-face + ;; 'font-lock-comment-face + ;; "Face to use for comments.")) + ;; (or (boundp 'font-lock-keyword-face) + ;; (defconst font-lock-keyword-face + ;; 'font-lock-keyword-face + ;; "Face to use for keywords.")) + ;; (or (boundp 'font-lock-function-name-face) + ;; (defconst font-lock-function-name-face + ;; 'font-lock-function-name-face + ;; "Face to use for function names."))) + (if (and + (not (cperl-is-face 'cperl-array-face)) + (cperl-is-face 'font-lock-emphasized-face)) + (copy-face 'font-lock-emphasized-face 'cperl-array-face)) + (if (and + (not (cperl-is-face 'cperl-hash-face)) + (cperl-is-face 'font-lock-other-emphasized-face)) + (copy-face 'font-lock-other-emphasized-face + 'cperl-hash-face)) + (if (and + (not (cperl-is-face 'cperl-nonoverridable-face)) + (cperl-is-face 'font-lock-other-type-face)) + (copy-face 'font-lock-other-type-face + 'cperl-nonoverridable-face)) + ;;(or (boundp 'cperl-hash-face) + ;; (defconst cperl-hash-face + ;; 'cperl-hash-face + ;; "Face to use for hashes.")) + ;;(or (boundp 'cperl-array-face) + ;; (defconst cperl-array-face + ;; 'cperl-array-face + ;; "Face to use for arrays.")) ;; Here we try to guess background (let ((background (if (boundp 'font-lock-background-mode) font-lock-background-mode 'light)) (face-list (and (fboundp 'face-list) (face-list))) - cperl-is-face) - (fset 'cperl-is-face - (cond ((fboundp 'find-face) - (symbol-function 'find-face)) - (face-list - (function (lambda (face) (member face face-list)))) - (t - (function (lambda (face) (boundp face)))))) + ;; cperl-is-face + ) +;;;; (fset 'cperl-is-face +;;;; (cond ((fboundp 'find-face) +;;;; (symbol-function 'find-face)) +;;;; (face-list +;;;; (function (lambda (face) (member face face-list)))) +;;;; (t +;;;; (function (lambda (face) (boundp face)))))) (defvar cperl-guessed-background (if (and (boundp 'font-lock-display-type) (eq font-lock-display-type 'grayscale)) @@ -4167,7 +4719,6 @@ (if (and (not (cperl-is-face 'font-lock-constant-face)) (cperl-is-face 'font-lock-reference-face)) - nil (copy-face 'font-lock-reference-face 'font-lock-constant-face)) (if (cperl-is-face 'font-lock-type-face) nil (copy-face 'default 'font-lock-type-face) @@ -4184,88 +4735,137 @@ "pink"))) (t (set-face-background 'font-lock-type-face "gray90")))) - (if (cperl-is-face 'font-lock-other-type-face) + (if (cperl-is-face 'cperl-nonoverridable-face) nil - (copy-face 'font-lock-type-face 'font-lock-other-type-face) + (copy-face 'font-lock-type-face 'cperl-nonoverridable-face) (cond ((eq background 'light) - (set-face-foreground 'font-lock-other-type-face + (set-face-foreground 'cperl-nonoverridable-face (if (x-color-defined-p "chartreuse3") "chartreuse3" "chartreuse"))) ((eq background 'dark) - (set-face-foreground 'font-lock-other-type-face + (set-face-foreground 'cperl-nonoverridable-face (if (x-color-defined-p "orchid1") "orchid1" "orange"))))) - (if (cperl-is-face 'font-lock-other-emphasized-face) nil - (copy-face 'bold-italic 'font-lock-other-emphasized-face) - (cond - ((eq background 'light) - (set-face-background 'font-lock-other-emphasized-face - (if (x-color-defined-p "lightyellow2") - "lightyellow2" - (if (x-color-defined-p "lightyellow") - "lightyellow" - "light yellow")))) - ((eq background 'dark) - (set-face-background 'font-lock-other-emphasized-face - (if (x-color-defined-p "navy") - "navy" - (if (x-color-defined-p "darkgreen") - "darkgreen" - "dark green")))) - (t (set-face-background 'font-lock-other-emphasized-face "gray90")))) - (if (cperl-is-face 'font-lock-emphasized-face) nil - (copy-face 'bold 'font-lock-emphasized-face) - (cond - ((eq background 'light) - (set-face-background 'font-lock-emphasized-face - (if (x-color-defined-p "lightyellow2") - "lightyellow2" - "lightyellow"))) - ((eq background 'dark) - (set-face-background 'font-lock-emphasized-face - (if (x-color-defined-p "navy") - "navy" - (if (x-color-defined-p "darkgreen") - "darkgreen" - "dark green")))) - (t (set-face-background 'font-lock-emphasized-face "gray90")))) +;;; (if (cperl-is-face 'font-lock-other-emphasized-face) nil +;;; (copy-face 'bold-italic 'font-lock-other-emphasized-face) +;;; (cond +;;; ((eq background 'light) +;;; (set-face-background 'font-lock-other-emphasized-face +;;; (if (x-color-defined-p "lightyellow2") +;;; "lightyellow2" +;;; (if (x-color-defined-p "lightyellow") +;;; "lightyellow" +;;; "light yellow")))) +;;; ((eq background 'dark) +;;; (set-face-background 'font-lock-other-emphasized-face +;;; (if (x-color-defined-p "navy") +;;; "navy" +;;; (if (x-color-defined-p "darkgreen") +;;; "darkgreen" +;;; "dark green")))) +;;; (t (set-face-background 'font-lock-other-emphasized-face "gray90")))) +;;; (if (cperl-is-face 'font-lock-emphasized-face) nil +;;; (copy-face 'bold 'font-lock-emphasized-face) +;;; (cond +;;; ((eq background 'light) +;;; (set-face-background 'font-lock-emphasized-face +;;; (if (x-color-defined-p "lightyellow2") +;;; "lightyellow2" +;;; "lightyellow"))) +;;; ((eq background 'dark) +;;; (set-face-background 'font-lock-emphasized-face +;;; (if (x-color-defined-p "navy") +;;; "navy" +;;; (if (x-color-defined-p "darkgreen") +;;; "darkgreen" +;;; "dark green")))) +;;; (t (set-face-background 'font-lock-emphasized-face "gray90")))) (if (cperl-is-face 'font-lock-variable-name-face) nil (copy-face 'italic 'font-lock-variable-name-face)) (if (cperl-is-face 'font-lock-constant-face) nil (copy-face 'italic 'font-lock-constant-face)))) (setq cperl-faces-init t)) - (error nil))) + (error (message "cperl-init-faces (ignored): %s" errs)))) (defun cperl-ps-print-init () "Initialization of `ps-print' components for faces used in CPerl." - ;; Guard against old versions - (defvar ps-underlined-faces nil) - (defvar ps-bold-faces nil) - (defvar ps-italic-faces nil) - (setq ps-bold-faces - (append '(font-lock-emphasized-face - font-lock-keyword-face - font-lock-variable-name-face - font-lock-constant-face - font-lock-reference-face - font-lock-other-emphasized-face) - ps-bold-faces)) - (setq ps-italic-faces - (append '(font-lock-other-type-face - font-lock-constant-face - font-lock-reference-face - font-lock-other-emphasized-face) - ps-italic-faces)) - (setq ps-underlined-faces - (append '(font-lock-emphasized-face - font-lock-other-emphasized-face - font-lock-other-type-face font-lock-type-face) - ps-underlined-faces)) - (cons 'font-lock-type-face ps-underlined-faces)) + (eval-after-load "ps-print" + '(setq ps-bold-faces + ;; font-lock-variable-name-face + ;; font-lock-constant-face + (append '(cperl-array-face + cperl-hash-face) + ps-bold-faces) + ps-italic-faces + ;; font-lock-constant-face + (append '(cperl-nonoverridable-face + cperl-hash-face) + ps-italic-faces) + ps-underlined-faces + ;; font-lock-type-face + (append '(cperl-array-face + cperl-hash-face + underline + cperl-nonoverridable-face) + ps-underlined-faces)))) + +(defvar ps-print-face-extension-alist) + +(defun cperl-ps-print (&optional file) + "Pretty-print in CPerl style. +If optional argument FILE is an empty string, prints to printer, otherwise +to the file FILE. If FILE is nil, prompts for a file name. + +Style of printout regulated by the variable `cperl-ps-print-face-properties'." + (interactive) + (or file + (setq file (read-from-minibuffer + "Print to file (if empty - to printer): " + (concat (buffer-file-name) ".ps") + nil nil 'file-name-history))) + (or (> (length file) 0) + (setq file nil)) + (require 'ps-print) ; To get ps-print-face-extension-alist + (let ((ps-print-color-p t) + (ps-print-face-extension-alist ps-print-face-extension-alist)) + (cperl-ps-extend-face-list cperl-ps-print-face-properties) + (ps-print-buffer-with-faces file))) + +;;; (defun cperl-ps-print-init () +;;; "Initialization of `ps-print' components for faces used in CPerl." +;;; ;; Guard against old versions +;;; (defvar ps-underlined-faces nil) +;;; (defvar ps-bold-faces nil) +;;; (defvar ps-italic-faces nil) +;;; (setq ps-bold-faces +;;; (append '(font-lock-emphasized-face +;;; 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-face) +;;; ps-bold-faces)) +;;; (setq ps-italic-faces +;;; (append '(cperl-nonoverridable-face +;;; font-lock-constant-face +;;; font-lock-reference-face +;;; font-lock-other-emphasized-face +;;; cperl-hash-face) +;;; ps-italic-faces)) +;;; (setq ps-underlined-faces +;;; (append '(font-lock-emphasized-face +;;; cperl-array-face +;;; font-lock-other-emphasized-face +;;; cperl-hash-face +;;; cperl-nonoverridable-face font-lock-type-face) +;;; ps-underlined-faces)) +;;; (cons 'font-lock-type-face ps-underlined-faces)) (if (cperl-enable-font-lock) (cperl-windowed-init)) @@ -4333,7 +4933,7 @@ ;;(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 CPerl menu.") +Should be used via `cperl-set-style' or via Perl menu.") (defun cperl-set-style (style) "Set CPerl-mode variables to use one of several different indentation styles. @@ -4675,7 +5275,9 @@ "Toggle whether `indent-region'/`indent-sexp' fix whitespace too." (interactive) (setq cperl-indent-region-fix-constructs - (not cperl-indent-region-fix-constructs)) + (if cperl-indent-region-fix-constructs + nil + 1)) (message "indent-region/indent-sexp will %sbe automatically fix whitespace." (if cperl-indent-region-fix-constructs "" "not "))) @@ -4765,8 +5367,10 @@ (lambda (elt) (cond ((string-match "^[_a-zA-Z]" (car elt)) (goto-char (cdr elt)) + (beginning-of-line) ; pos should be of the start of the line (list (car elt) - (point) (count-lines 1 (point)) + (point) + (1+ (count-lines 1 (point))) ; 1+ since at beg-o-l (buffer-substring (progn (skip-chars-forward ":_a-zA-Z0-9") @@ -4787,9 +5391,9 @@ (substring (car elt) 8) (car elt) ) 1 - (number-to-string (elt elt 1)) + (number-to-string (elt elt 2)) ; Line "," - (number-to-string (elt elt 2)) + (number-to-string (1- (elt elt 1))) ; Char pos 0-based "\n") (if (and (string-match "^[_a-zA-Z]+::" (car elt)) (string-match "^sub[ \t]+\\([_a-zA-Z]+\\)[^:_a-zA-Z]" @@ -4841,11 +5445,13 @@ (setq topdir default-directory)) (let ((tags-file-name "TAGS") (case-fold-search (eq system-type 'emx)) - xs) + xs rel) (save-excursion (cond (inbuffer nil) ; Already there ((file-exists-p tags-file-name) - (visit-tags-table-buffer tags-file-name)) + (if cperl-xemacs-p + (visit-tags-table-buffer) + (visit-tags-table-buffer tags-file-name))) (t (set-buffer (find-file-noselect tags-file-name)))) (cond (dir @@ -4876,7 +5482,12 @@ (erase (erase-buffer)) (t (goto-char 1) - (if (search-forward (concat "\f\n" file ",") nil t) + (setq rel file) + ;; On case-preserving filesystems (EMX on OS/2) case might be encoded in properties + (set-text-properties 0 (length rel) nil rel) + (and (equal topdir (substring rel 0 (length topdir))) + (setq rel (substring file (length topdir)))) + (if (search-forward (concat "\f\n" rel ",") nil t) (progn (search-backward "\f\n") (delete-region (point) @@ -4928,11 +5539,12 @@ (setq ;;str (buffer-substring (match-beginning 1) (match-end 1)) name (buffer-substring (match-beginning 2) (match-end 2)) ;;pos (buffer-substring (match-beginning 3) (match-end 3)) - line (buffer-substring (match-beginning 4) (match-end 4)) + line (buffer-substring (match-beginning 3) (match-end 3)) ord (if pack 1 0) - info (etags-snarf-tag) ; Moves to beginning of the next line file (file-of-tag) - fileind (format "%s:%s" file line)) + fileind (format "%s:%s" file line) + ;; Moves to beginning of the next line: + info (cperl-etags-snarf-tag file line)) ;; Move back (forward-char -1) ;; Make new member of hierarchy name ==> file ==> pos if needed @@ -4958,22 +5570,31 @@ (require 'etags) (require 'imenu) (if (or update (null (nth 2 cperl-hierarchy))) - (let (pack name cons1 to l1 l2 l3 l4 + (let (pack name cons1 to l1 l2 l3 l4 b (remover (function (lambda (elt) ; (name (file1...) (file2..)) (or (nthcdr 2 elt) ;; Only in one file (setcdr elt (cdr (nth 1 elt)))))))) ;; (setq cperl-hierarchy '(() () ())) ; Would write into '() later! (setq cperl-hierarchy (list l1 l2 l3)) - (or tags-table-list + (if cperl-xemacs-p ; Not checked + (progn + (or tags-file-name + ;; Does this work in XEmacs? (call-interactively 'visit-tags-table)) (message "Updating list of classes...") + (set-buffer (get-file-buffer tags-file-name)) + (cperl-tags-hier-fill)) + (or tags-table-list + (call-interactively 'visit-tags-table)) (mapcar (function (lambda (tagsfile) + (message "Updating list of classes... %s" tagsfile) (set-buffer (get-file-buffer tagsfile)) (cperl-tags-hier-fill))) tags-table-list) + (message "Updating list of classes... postprocessing...")) (mapcar remover (car cperl-hierarchy)) (mapcar remover (nth 1 cperl-hierarchy)) (setq to (list nil (cons "Packages: " (nth 1 cperl-hierarchy)) @@ -4998,7 +5619,7 @@ (if (vectorp update) (progn (find-file (elt update 0)) - (etags-goto-tag-location (elt update 1)))) + (cperl-etags-goto-tag-location (elt update 1)))) (if (eq update -999) (cperl-tags-hier-init t))) (defun cperl-tags-treeify (to level) @@ -5129,14 +5750,17 @@ "[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> - "-[a-zA-Z][ \t]+[_$\"'`]" ; -f file + "-[a-zA-Z][ \t]+[_$\"'`a-zA-Z]" ; -f file, -t STDIN "-[0-9]" ; -5 "\\+\\+" ; ++var "--" ; --var ".->" ; a->b "->" ; a SPACE ->b "\\[-" ; a[-1] + "\\\\[&$@*\\\\]" ; \&func "^=" ; =head + "\\$." ; $| + "<<[a-zA-Z_'\"`]" ; <<FOO, <<'FOO' "||" "&&" "[CBIXSLFZ]<\\(\\sw\\|\\s \\|\\s_\\|[\n]\\)*>" ; C<code like text> @@ -5407,6 +6031,7 @@ $^H The current set of syntax checks enabled by `use strict'. $^I The value of the in-place edit extension (perl -i option). $^L What formats output to perform a formfeed. Default is \f. +$^M A buffer for emergency memory allocation when running out of memory. $^O The operating system name under which this copy of Perl was built. $^P Internal debugging flag. $^T The time the script was started. Used by -A/-M/-C file tests. @@ -5945,11 +6570,11 @@ ;; Returns position of the start (save-excursion (or cperl-use-syntax-table-text-property - (error "I need to have regex marked!")) + (error "I need to have a regexp marked!")) ;; Find the start (if (looking-at "\\s|") nil ; good already - (if (looking-at "[smy]\\s|") + (if (looking-at "\\([smy]\\|qr\\)\\s|") (forward-char 1) (re-search-backward "\\s|"))) ; Assume it is scanned already. ;;(forward-char 1) @@ -5999,7 +6624,7 @@ (or done (forward-char -1))))) (defun cperl-contract-level () - "Find an enclosing group in regexp and contract it. Unfinished. + "Find an enclosing group in regexp and contract it. \(Experimental, may change semantics, recheck the result.) We suppose that the regexp is scanned already." (interactive) @@ -6022,7 +6647,7 @@ (just-one-space)))))) (defun cperl-contract-levels () - "Find an enclosing group in regexp and contract all the kids. Unfinished. + "Find an enclosing group in regexp and contract all the kids. \(Experimental, may change semantics, recheck the result.) We suppose that the regexp is scanned already." (interactive) @@ -6137,6 +6762,7 @@ (error "`%s' not with an (EXPR)" s0))) (error "Not at `if', `unless', `while', or `unless'"))) +;;; By Anthony Foiani <afoiani@uswest.com> ;;; Getting help on modules in C-h f ? ;;; This is a modified version of `man'. ;;; Need to teach it how to lookup functions @@ -6174,6 +6800,7 @@ :type 'file :group 'cperl) +;;; By Nick Roberts <Nick.Roberts@src.bae.co.uk> (with changes) (defun cperl-pod-to-manpage () "Create a virtual manpage in Emacs from the Perl Online Documentation." (interactive) @@ -6261,11 +6888,17 @@ (defvar cperl-d-l nil) (defun cperl-fontify-syntaxically (end) - (let ((start (point)) (dbg (point))) + ;; Some vars for debugging only + (let (start (dbg (point)) (iend end) + (istate (car cperl-syntax-state))) + (and cperl-syntaxify-unwind + (setq end (cperl-unwind-to-safe t end))) + (setq start (point)) (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)) + (eval 'font-lock-hot-pass) + t) ; Not debugged otherwise ;; Need to forget what is after `start' (setq start (min cperl-syntax-done-to start)) ;; Fontification without a change @@ -6279,11 +6912,38 @@ ;;(let ((standard-output (get-buffer "*Messages*"))) ;;(princ (format "Syntaxifying %s..%s from %s to %s\n" ;; dbg end start cperl-syntax-done-to))) - (if (eq cperl-syntaxify-by-font-lock 1) - (message "Syntaxifying %s..%s from %s to %s" - dbg end start cperl-syntax-done-to)) ; For debugging + (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 + istate (car cperl-syntax-state))) ; For debugging nil)) ; Do not iterate +(defun cperl-fontify-update (end) + (let ((pos (point)) prop posend) + (while (< pos end) + (setq prop (get-text-property pos 'cperl-postpone)) + (setq 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-update-syntaxification (from to) + (if (and cperl-use-syntax-table-text-property + cperl-syntaxify-by-font-lock + (or (null cperl-syntax-done-to) + (< cperl-syntax-done-to to))) + (progn + (save-excursion + (goto-char from) + (cperl-fontify-syntaxically to))))) + +(defvar cperl-version + (let ((v "Revision: 4.21")) + (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.") + (provide 'cperl-mode) ;;; cperl-mode.el ends here