+;;; cperl-mode.el --- Perl code editing commands for Emacs\r
+\r
+;; Copyright (C) 1985, 86, 87, 91, 92, 93, 94, 95, 96, 97, 98, 99, 2000, 2003\r
+;; Free Software Foundation, Inc.\r
+\r
+;; Author: Ilya Zakharevich and Bob Olson\r
+;; Maintainer: Ilya Zakharevich <cperl@ilyaz.org>\r
+;; Keywords: languages, Perl\r
+\r
+;; This file is part of GNU Emacs.\r
+\r
+;;; This code started from the following message of long time ago\r
+;;; (IZ), but Bob does not maintain this mode any more:\r
+\r
+;;; From: olson@mcs.anl.gov (Bob Olson)\r
+;;; Newsgroups: comp.lang.perl\r
+;;; Subject: cperl-mode: Another perl mode for Gnuemacs\r
+;;; Date: 14 Aug 91 15:20:01 GMT\r
+\r
+;; Copyright (C) Ilya Zakharevich and Bob Olson\r
+\r
+;; This file may be distributed\r
+;; either under the same terms as GNU Emacs, or under the same terms\r
+;; as Perl. You should have received a copy of Perl Artistic license\r
+;; along with the Perl distribution.\r
+\r
+;; GNU Emacs is free software; you can redistribute it and/or modify\r
+;; it under the terms of the GNU General Public License as published by\r
+;; the Free Software Foundation; either version 2, or (at your option)\r
+;; any later version.\r
+\r
+;; GNU Emacs is distributed in the hope that it will be useful,\r
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of\r
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\r
+;; GNU General Public License for more details.\r
+\r
+;; You should have received a copy of the GNU General Public License\r
+;; along with GNU Emacs; see the file COPYING. If not, write to the\r
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,\r
+;; Boston, MA 02111-1307, USA.\r
+\r
+;;; Corrections made by Ilya Zakharevich cperl@ilyaz.org\r
+;;; XEmacs changes by Peter Arius arius@informatik.uni-erlangen.de\r
+\r
+;;; Commentary:\r
+\r
+;; $Id: cperl-mode.el,v 5.0 2003/02/17 01:33:20 vera Exp vera $\r
+\r
+;;; If your Emacs does not default to `cperl-mode' on Perl files:\r
+;;; To use this mode put the following into\r
+;;; your .emacs file:\r
+\r
+;; (autoload 'perl-mode "cperl-mode" "alternate mode for editing Perl programs" t)\r
+\r
+;; You can either fine-tune the bells and whistles of this mode or\r
+;; bulk enable them by putting\r
+\r
+;; (setq cperl-hairy t)\r
+\r
+;; in your .emacs file. (Emacs rulers do not consider it politically\r
+;; correct to make whistles enabled by default.)\r
+\r
+;; DO NOT FORGET to read micro-docs (available from `Perl' menu) <<<<<<\r
+;; or as help on variables `cperl-tips', `cperl-problems', <<<<<<\r
+;; `cperl-non-problems', `cperl-praise', `cperl-speed'. <<<<<<\r
+\r
+;; Additional useful commands to put into your .emacs file (before\r
+;; RMS Emacs 20.3):\r
+\r
+;; (setq auto-mode-alist\r
+;; (append '(("\\.\\([pP][Llm]\\|al\\)$" . perl-mode)) auto-mode-alist ))\r
+;; (setq interpreter-mode-alist (append interpreter-mode-alist\r
+;; '(("miniperl" . perl-mode))))\r
+\r
+;; The mode information (on C-h m) provides some customization help.\r
+;; If you use font-lock feature of this mode, it is advisable to use\r
+;; either lazy-lock-mode or fast-lock-mode. I prefer lazy-lock.\r
+\r
+;; Faces used now: three faces for first-class and second-class keywords\r
+;; and control flow words, one for each: comments, string, labels,\r
+;; functions definitions and packages, arrays, hashes, and variable\r
+;; definitions. If you do not see all these faces, your font-lock does\r
+;; not define them, so you need to define them manually.\r
+;; Maybe you have an obsolete font-lock from 19.28 or earlier. Upgrade.\r
+\r
+;; If you have a grayscale monitor, and do not have the variable\r
+;; font-lock-display-type bound to 'grayscale, insert\r
+\r
+;; (setq font-lock-display-type 'grayscale)\r
+\r
+;; into your .emacs file (this is relevant before RMS Emacs 20).\r
+\r
+;; This mode supports font-lock, imenu and mode-compile. In the\r
+;; hairy version font-lock is on, but you should activate imenu\r
+;; yourself (note that mode-compile is not standard yet). Well, you\r
+;; can use imenu from keyboard anyway (M-x imenu), but it is better\r
+;; to bind it like that:\r
+\r
+;; (define-key global-map [M-S-down-mouse-3] 'imenu)\r
+\r
+;;; Font lock bugs as of v4.32:\r
+\r
+;; The following kinds of Perl code erroneously start strings:\r
+;; \$` \$' \$"\r
+;; $opt::s $opt_s $opt{s} (s => ...) /\s+.../\r
+;; likewise with m, tr, y, q, qX instead of s\r
+\r
+;;; In fact the version of font-lock that this version supports can be\r
+;;; much newer than the version you actually have. This means that a\r
+;;; lot of faces can be set up, but are not visible on your screen\r
+;;; since the coloring rules for this faces are not defined.\r
+\r
+;;; Updates: ========================================\r
+\r
+;;; Made less hairy by default: parentheses not electric,\r
+;;; linefeed not magic. Bug with abbrev-mode corrected.\r
+\r
+;;;; After 1.4:\r
+;;; Better indentation:\r
+;;; subs inside braces should work now,\r
+;;; Toplevel braces obey customization.\r
+;;; indent-for-comment knows about bad cases, cperl-indent-for-comment\r
+;;; moves cursor to a correct place.\r
+;;; cperl-indent-exp written from the scratch! Slow... (quadratic!) :-(\r
+;;; (50 secs on DB::DB (sub of 430 lines), 486/66)\r
+;;; Minor documentation fixes.\r
+;;; Imenu understands packages as prefixes (including nested).\r
+;;; Hairy options can be switched off one-by-one by setting to null.\r
+;;; Names of functions and variables changed to conform to `cperl-' style.\r
+\r
+;;;; After 1.5:\r
+;;; Some bugs with indentation of labels (and embedded subs) corrected.\r
+;;; `cperl-indent-region' done (slow :-()).\r
+;;; `cperl-fill-paragraph' done.\r
+;;; Better package support for `imenu'.\r
+;;; Progress indicator for indentation (with `imenu' loaded).\r
+;;; `Cperl-set' was busted, now setting the individual hairy option\r
+;;; should be better.\r
+\r
+;;;; After 1.6:\r
+;;; `cperl-set-style' done.\r
+;;; `cperl-check-syntax' done.\r
+;;; Menu done.\r
+;;; New config variables `cperl-close-paren-offset' and `cperl-comment-column'.\r
+;;; Bugs with `cperl-auto-newline' corrected.\r
+;;; `cperl-electric-lbrace' can work with `cperl-auto-newline' in situation\r
+;;; like $hash{.\r
+\r
+;;;; 1.7 XEmacs (arius@informatik.uni-erlangen.de):\r
+;;; - use `next-command-event', if `next-command-events' does not exist\r
+;;; - use `find-face' as def. of `is-face'\r
+;;; - corrected def. of `x-color-defined-p'\r
+;;; - added const defs for font-lock-comment-face,\r
+;;; font-lock-keyword-face and font-lock-function-name-face\r
+;;; - added def. of font-lock-variable-name-face\r
+;;; - added (require 'easymenu) inside an `eval-when-compile'\r
+;;; - replaced 4-argument `substitute-key-definition' with ordinary\r
+;;; `define-key's\r
+;;; - replaced `mark-active' in menu definition by `cperl-use-region-p'.\r
+;;; Todo (at least):\r
+;;; - use emacs-vers.el (http://www.cs.utah.edu/~eeide/emacs/emacs-vers.el.gz)\r
+;;; for portable code?\r
+;;; - should `cperl-mode' do a\r
+;;; (if (featurep 'easymenu) (easy-menu-add cperl-menu))\r
+;;; or should this be left to the user's `cperl-mode-hook'?\r
+\r
+;;; Some bugs introduced by the above fix corrected (IZ ;-).\r
+;;; Some bugs under XEmacs introduced by the correction corrected.\r
+\r
+;;; Some more can remain since there are two many different variants.\r
+;;; Please feedback!\r
+\r
+;;; We do not support fontification of arrays and hashes under\r
+;;; obsolete font-lock any more. Upgrade.\r
+\r
+;;;; after 1.8 Minor bug with parentheses.\r
+;;;; after 1.9 Improvements from Joe Marzot.\r
+;;;; after 1.10\r
+;;; Does not need easymenu to compile under XEmacs.\r
+;;; `vc-insert-headers' should work better.\r
+;;; Should work with 19.29 and 19.12.\r
+;;; Small improvements to fontification.\r
+;;; Expansion of keywords does not depend on C-? being backspace.\r
+\r
+;;; after 1.10+\r
+;;; 19.29 and 19.12 supported.\r
+;;; `cperl-font-lock-enhanced' deprecated. Use font-lock-extra.el.\r
+;;; Support for font-lock-extra.el.\r
+\r
+;;;; After 1.11:\r
+;;; Tools submenu.\r
+;;; Support for perl5-info.\r
+;;; `imenu-go-find-at-position' in Tools requires imenu-go.el (see hints above)\r
+;;; Imenu entries do not work with stock imenu.el. Patch sent to maintainers.\r
+;;; Fontifies `require a if b;', __DATA__.\r
+;;; Arglist for auto-fill-mode was incorrect.\r
+\r
+;;;; After 1.12:\r
+;;; `cperl-lineup-step' and `cperl-lineup' added: lineup constructions\r
+;;; vertically.\r
+;;; `cperl-do-auto-fill' updated for 19.29 style.\r
+;;; `cperl-info-on-command' now has a default.\r
+;;; Workaround for broken C-h on XEmacs.\r
+;;; VC strings escaped.\r
+;;; C-h f now may prompt for function name instead of going on,\r
+;;; controlled by `cperl-info-on-command-no-prompt'.\r
+\r
+;;;; After 1.13:\r
+;;; Msb buffer list includes perl files\r
+;;; Indent-for-comment uses indent-to\r
+;;; Can write tag files using etags.\r
+\r
+;;;; After 1.14:\r
+;;; Recognizes (tries to ;-) {...} which are not blocks during indentation.\r
+;;; `cperl-close-paren-offset' affects ?\] too (and ?\} if not block)\r
+;;; Bug with auto-filling comments started with "##" corrected.\r
+\r
+;;;; Very slow now: on DB::DB 0.91, 486/66:\r
+\r
+;;;Function Name Call Count Elapsed Time Average Time\r
+;;;======================================== ========== ============ ============\r
+;;;cperl-block-p 469 3.7799999999 0.0080597014\r
+;;;cperl-get-state 505 163.39000000 0.3235445544\r
+;;;cperl-comment-indent 12 0.0299999999 0.0024999999\r
+;;;cperl-backward-to-noncomment 939 4.4599999999 0.0047497337\r
+;;;cperl-calculate-indent 505 172.22000000 0.3410297029\r
+;;;cperl-indent-line 505 172.88000000 0.3423366336\r
+;;;cperl-use-region-p 40 0.0299999999 0.0007499999\r
+;;;cperl-indent-exp 1 177.97000000 177.97000000\r
+;;;cperl-to-comment-or-eol 1453 3.9800000000 0.0027391603\r
+;;;cperl-backward-to-start-of-continued-exp 9 0.0300000000 0.0033333333\r
+;;;cperl-indent-region 1 177.94000000 177.94000000\r
+\r
+;;;; After 1.15:\r
+;;; Takes into account white space after opening parentheses during indent.\r
+;;; May highlight pods and here-documents: see `cperl-pod-here-scan',\r
+;;; `cperl-pod-here-fontify', `cperl-pod-face'. Does not use this info\r
+;;; for indentation so far.\r
+;;; Fontification updated to 19.30 style.\r
+;;; The change 19.29->30 did not add all the required functionality,\r
+;;; but broke "font-lock-extra.el". Get "choose-color.el" from\r
+;;; ftp://ftp.math.ohio-state.edu/pub/users/ilya/emacs\r
+\r
+;;;; After 1.16:\r
+;;; else # comment\r
+;;; recognized as a start of a block.\r
+;;; Two different font-lock-levels provided.\r
+;;; `cperl-pod-head-face' introduced. Used for highlighting.\r
+;;; `imenu' marks pods, +Packages moved to the head.\r
+\r
+;;;; After 1.17:\r
+;;; Scan for pods highlights here-docs too.\r
+;;; Note that the tag of here-doc may be rehighlighted later by lazy-lock.\r
+;;; Only one here-doc-tag per line is supported, and one in comment\r
+;;; or a string may break fontification.\r
+;;; POD headers were supposed to fill one line only.\r
+\r
+;;;; After 1.18:\r
+;;; `font-lock-keywords' were set in 19.30 style _always_. Current scheme\r
+;;; may break under XEmacs.\r
+;;; `cperl-calculate-indent' dis suppose that `parse-start' was defined.\r
+;;; `fontified' tag is added to fontified text as well as `lazy-lock' (for\r
+;;; compatibility with older lazy-lock.el) (older one overfontifies\r
+;;; something nevertheless :-().\r
+;;; Will not indent something inside pod and here-documents.\r
+;;; Fontifies the package name after import/no/bootstrap.\r
+;;; Added new entry to menu with meta-info about the mode.\r
+\r
+;;;; After 1.19:\r
+;;; Prefontification works much better with 19.29. Should be checked\r
+;;; with 19.30 as well.\r
+;;; Some misprints in docs corrected.\r
+;;; Now $a{-text} and -text => "blah" are fontified as strings too.\r
+;;; Now the pod search is much stricter, so it can help you to find\r
+;;; pod sections which are broken because of whitespace before =blah\r
+;;; - just observe the fontification.\r
+\r
+;;;; After 1.20\r
+;;; Anonymous subs are indented with respect to the level of\r
+;;; indentation of `sub' now.\r
+;;; {} is recognized as hash after `bless' and `return'.\r
+;;; Anonymous subs are split by `cperl-linefeed' as well.\r
+;;; Electric parens embrace a region if present.\r
+;;; To make `cperl-auto-newline' useful,\r
+;;; `cperl-auto-newline-after-colon' is introduced.\r
+;;; `cperl-electric-parens' is now t or nul. The old meaning is moved to\r
+;;; `cperl-electric-parens-string'.\r
+;;; `cperl-toggle-auto-newline' introduced, put on C-c C-a.\r
+;;; `cperl-toggle-abbrev' introduced, put on C-c C-k.\r
+;;; `cperl-toggle-electric' introduced, put on C-c C-e.\r
+;;; Beginning-of-defun-regexp was not anchored.\r
+\r
+;;;; After 1.21\r
+;;; Auto-newline grants `cperl-extra-newline-before-brace' if "{" is typed\r
+;;; after ")".\r
+;;; {} is recognized as expression after `tr' and friends.\r
+\r
+;;;; After 1.22\r
+;;; Entry Hierarchy added to imenu. Very primitive so far.\r
+;;; One needs newer `imenu-go'.el. A patch to `imenu' is needed as well.\r
+;;; Writes its own TAGS files.\r
+;;; Class viewer based on TAGS files. Does not trace @ISA so far.\r
+;;; 19.31: Problems with scan for PODs corrected.\r
+;;; First POD header correctly fontified.\r
+;;; I needed (setq imenu-use-keymap-menu t) to get good imenu in 19.31.\r
+;;; Apparently it makes a lot of hierarchy code obsolete...\r
+\r
+;;;; After 1.23\r
+;;; Tags filler now scans *.xs as well.\r
+;;; The info from *.xs scan is used by the hierarchy viewer.\r
+;;; Hierarchy viewer documented.\r
+;;; Bug in 19.31 imenu documented.\r
+\r
+;;;; After 1.24\r
+;;; New location for info-files mentioned,\r
+;;; Electric-; should work better.\r
+;;; Minor bugs with POD marking.\r
+\r
+;;;; After 1.25 (probably not...)\r
+;;; `cperl-info-page' introduced.\r
+;;; To make `uncomment-region' working, `comment-region' would\r
+;;; not insert extra space.\r
+;;; Here documents delimiters better recognized\r
+;;; (empty one, and non-alphanums in quotes handled). May be wrong with 1<<14?\r
+;;; `cperl-db' added, used in menu.\r
+;;; imenu scan removes text-properties, for better debugging\r
+;;; - but the bug is in 19.31 imenu.\r
+;;; formats highlighted by font-lock and prescan, embedded comments\r
+;;; are not treated.\r
+;;; POD/friends scan merged in one pass.\r
+;;; Syntax class is not used for analyzing the code, only char-syntax\r
+;;; may be checked against _ or'ed with w.\r
+;;; Syntax class of `:' changed to be _.\r
+;;; `cperl-find-bad-style' added.\r
+\r
+;;;; After 1.25\r
+;;; When search for here-documents, we ignore commented << in simplest cases.\r
+;;; `cperl-get-help' added, available on C-h v and from menu.\r
+;;; Auto-help added. Default with `cperl-hairy', switchable on/off\r
+;;; with startup variable `cperl-lazy-help-time' and from\r
+;;; menu. Requires `run-with-idle-timer'.\r
+;;; Highlighting of @abc{@efg} was wrong - interchanged two regexps.\r
+\r
+;;;; After 1.27\r
+;;; Indentation: At toplevel after a label - fixed.\r
+;;; 1.27 was put to archives in binary mode ===> DOSish :-(\r
+\r
+;;;; After 1.28\r
+;;; Thanks to Martin Buchholz <mrb@Eng.Sun.COM>: misprints in\r
+;;; comments and docstrings corrected, XEmacs support cleaned up.\r
+;;; The closing parenths would enclose the region into matching\r
+;;; parens under the same conditions as the opening ones.\r
+;;; Minor updates to `cperl-short-docs'.\r
+;;; Will not consider <<= as start of here-doc.\r
+\r
+;;;; After 1.29\r
+;;; Added an extra advice to look into Micro-docs. ;-).\r
+;;; Enclosing of region when you press a closing parenth is regulated by\r
+;;; `cperl-electric-parens-string'.\r
+;;; Minor updates to `cperl-short-docs'.\r
+;;; `initialize-new-tags-table' called only if present (Does this help\r
+;;; with generation of tags under XEmacs?).\r
+;;; When creating/updating tag files, new info is written at the old place,\r
+;;; or at the end (is this a wanted behaviour? I need this in perl build directory).\r
+\r
+;;;; After 1.30\r
+;;; All the keywords from keywords.pl included (maybe with dummy explanation).\r
+;;; No auto-help inside strings, comment, here-docs, formats, and pods.\r
+;;; Shrinkwrapping of info, regulated by `cperl-max-help-size',\r
+;;; `cperl-shrink-wrap-info-frame'.\r
+;;; Info on variables as well.\r
+;;; Recognision of HERE-DOCS improved yet more.\r
+;;; Autonewline works on `}' without warnings.\r
+;;; Autohelp works again on $_[0].\r
+\r
+;;;; After 1.31\r
+;;; perl-descr.el found its author - hi, Johan!\r
+;;; Some support for correct indent after here-docs and friends (may\r
+;;; be superseeded by eminent change to Emacs internals).\r
+;;; Should work with older Emaxen as well ( `-style stuff removed).\r
+\r
+;;;; After 1.32\r
+\r
+;;; Started to add support for `syntax-table' property (should work\r
+;;; with patched Emaxen), controlled by\r
+;;; `cperl-use-syntax-table-text-property'. Currently recognized:\r
+;;; All quote-like operators: m, s, y, tr, qq, qw, qx, q,\r
+;;; // in most frequent context:\r
+;;; after block or\r
+;;; ~ { ( = | & + - * ! , ;\r
+;;; or\r
+;;; while if unless until and or not xor split grep map\r
+;;; Here-documents, formats, PODs,\r
+;;; ${...}\r
+;;; 'abc$'\r
+;;; sub a ($); sub a ($) {}\r
+;;; (provide 'cperl-mode) was missing!\r
+;;; `cperl-after-expr-p' is now much smarter after `}'.\r
+;;; `cperl-praise' added to mini-docs.\r
+;;; Utilities try to support subs-with-prototypes.\r
+\r
+;;;; After 1.32.1\r
+;;; `cperl-after-expr-p' is now much smarter after "() {}" and "word {}":\r
+;;; if word is "else, map, grep".\r
+;;; Updated for new values of syntax-table constants.\r
+;;; Uses `help-char' (at last!) (disabled, does not work?!)\r
+;;; A couple of regexps where missing _ in character classes.\r
+;;; -s could be considered as start of regexp, 1../blah/ was not,\r
+;;; as was not /blah/ at start of file.\r
+\r
+;;;; After 1.32.2\r
+;;; "\C-hv" was wrongly "\C-hf"\r
+;;; C-hv was not working on `[index()]' because of [] in skip-chars-*.\r
+;;; `__PACKAGE__' supported.\r
+;;; Thanks for Greg Badros: `cperl-lazy-unstall' is more complete,\r
+;;; `cperl-get-help' is made compatible with `query-replace'.\r
+\r
+;;;; As of Apr 15, development version of 19.34 supports\r
+;;;; `syntax-table' text properties. Try setting\r
+;;;; `cperl-use-syntax-table-text-property'.\r
+\r
+;;;; After 1.32.3\r
+;;; We scan for s{}[] as well (in simplest situations).\r
+;;; We scan for $blah'foo as well.\r
+;;; The default is to use `syntax-table' text property if Emacs is good enough.\r
+;;; `cperl-lineup' is put on C-M-| (=C-M-S-\\).\r
+;;; Start of `cperl-beautify-regexp'.\r
+\r
+;;;; After 1.32.4\r
+;;; `cperl-tags-hier-init' did not work in text-mode.\r
+;;; `cperl-noscan-files-regexp' had a misprint.\r
+;;; Generation of Class Hierarchy was broken due to a bug in `x-popup-menu'\r
+;;; in 19.34.\r
+\r
+;;;; After 1.33:\r
+;;; my,local highlight vars after {} too.\r
+;;; TAGS could not be created before imenu was loaded.\r
+;;; `cperl-indent-left-aligned-comments' created.\r
+;;; Logic of `cperl-indent-exp' changed a little bit, should be more\r
+;;; robust w.r.t. multiline strings.\r
+;;; Recognition of blah'foo takes into account strings.\r
+;;; Added '.al' to the list of Perl extensions.\r
+;;; Class hierarchy is "mostly" sorted (need to rethink algorthm\r
+;;; of pruning one-root-branch subtrees to get yet better sorting.)\r
+;;; Regeneration of TAGS was busted.\r
+;;; Can use `syntax-table' property when generating TAGS\r
+;;; (governed by `cperl-use-syntax-table-text-property-for-tags').\r
+\r
+;;;; After 1.35:\r
+;;; Can process several =pod/=cut sections one after another.\r
+;;; Knows of `extproc' when under `emx', indents with `__END__' and `__DATA__'.\r
+;;; `cperl-under-as-char' implemented (XEmacs people like broken behaviour).\r
+;;; Beautifier for regexps fixed.\r
+;;; `cperl-beautify-level', `cperl-contract-level' coded\r
+;;;\r
+;;;; Emacs's 20.2 problems:\r
+;;; `imenu.el' has bugs, `imenu-add-to-menubar' does not work.\r
+;;; Couple of others problems with 20.2 were reported, my ability to check/fix\r
+;;; them is very reduced now.\r
+\r
+;;;; After 1.36:\r
+;;; 'C-M-|' in XEmacs fixed\r
+\r
+;;;; After 1.37:\r
+;;; &&s was not recognized as start of regular expression;\r
+;;; Will "preprocess" the contents of //e part of s///e too;\r
+;;; What to do with s# blah # foo #e ?\r
+;;; Should handle s;blah;foo;; better.\r
+;;; Now the only known problems with regular expression recognition:\r
+;;;;;;; s<foo>/bar/ - different delimiters (end ignored)\r
+;;;;;;; s/foo/\\bar/ - backslash at start of subst (made into one chunk)\r
+;;;;;;; s/foo// - empty subst (made into one chunk + '/')\r
+;;;;;;; s/foo/(bar)/ - start-group at start of subst (internal group will not match backwards)\r
+\r
+;;;; After 1.38:\r
+;;; We highlight closing / of s/blah/foo/e;\r
+;;; This handles s# blah # foo #e too;\r
+;;; s//blah/, s///, s/blah// works again, and s#blah## too, the algorithm\r
+;;; is much simpler now;\r
+;;; Next round of changes: s\\\ works, s<blah>/foo/,\r
+;;; comments between the first and the second part allowed\r
+;;; Another problem discovered:\r
+;;;;;;; s[foo] <blah>e - e part delimited by different <> (will not match)\r
+;;; `cperl-find-pods-heres' somehow maybe called when string-face is undefined\r
+;;; - put a stupid workaround for 20.1\r
+\r
+;;;; After 1.39:\r
+;;; Could indent here-docs for comments;\r
+;;; These problems fixed:\r
+;;;;;;; s/foo/\\bar/ - backslash at start of subst (made into two chunk)\r
+;;;;;;; s[foo] <blah>e - "e" part delimited by "different" <> (will match)\r
+;;; Matching brackets honor prefices, may expand abbreviations;\r
+;;; When expanding abbrevs, will remove last char only after\r
+;;; self-inserted whitespace;\r
+;;; More convenient "Refress hard constructs" in menu;\r
+;;; `cperl-add-tags-recurse', `cperl-add-tags-recurse-noxs'\r
+;;; added (for -batch mode);\r
+;;; Better handling of errors when scanning for Perl constructs;\r
+;;;;;;; Possible "problem" with class hierarchy in Perl distribution\r
+;;;;;;; directory: ./ext duplicates ./lib;\r
+;;; Write relative paths for generated TAGS;\r
+\r
+;;;; After 1.40:\r
+;;; s /// may be separated by "\n\f" too;\r
+;;; `s #blah' recognized as a comment;\r
+;;; Would highlight s/abc//s wrong;\r
+;;; Debugging code in `cperl-electric-keywords' was leaking a message;\r
+\r
+;;;; After 1.41:\r
+;;; RMS changes for 20.3 merged\r
+\r
+;;;; 2.0.1.0: RMS mode (has 3 misprints)\r
+\r
+;;;; After 2.0:\r
+;;; RMS whitespace changes for 20.3 merged\r
+\r
+;;;; After 2.1:\r
+;;; History updated\r
+\r
+;;;; After 2.2:\r
+;;; Merge `c-style-alist' since `c-mode' is no more. (Somebody who\r
+;;; uses the styles should check that they work OK!)\r
+;;; All the variable warnings go away, some undef functions too.\r
+\r
+;;;; After 2.3:\r
+;;; Added `cperl-perldoc' (thanks to Anthony Foiani <afoiani@uswest.com>)\r
+;;; Added `cperl-pod-to-manpage' (thanks to Nick Roberts <Nick.Roberts@src.bae.co.uk>)\r
+;;; All the function warnings go away.\r
+\r
+;;;; After 2.4:\r
+;;; `Perl doc', `Regexp' submenus created (latter to allow short displays).\r
+;;; `cperl-clobber-lisp-bindings' added.\r
+;;; $a->y() is not y///.\r
+;;; `cperl-after-block-p' was missing a `save-excursion' => wrong results.\r
+;;; `cperl-val' was defined too late.\r
+;;; `cperl-init-faces' was failing.\r
+;;; Init faces when loading `ps-print'.\r
+\r
+;;;; After 2.4:\r
+;;; `cperl-toggle-autohelp' implemented.\r
+;;; `while SPACE LESS' was buggy.\r
+;;; `-text' in `[-text => 1]' was not highlighted.\r
+;;; `cperl-after-block-p' was FALSE after `sub f {}'.\r
+\r
+;;;; After 2.5:\r
+;;; `foreachmy', `formy' expanded too.\r
+;;; Expand `=pod-directive'.\r
+;;; `cperl-linefeed' behaves reasonable in POD-directive lines.\r
+;;; `cperl-electric-keyword' prints a message, governed by\r
+;;; `cperl-message-electric-keyword'.\r
+\r
+;;;; After 2.6:\r
+;;; Typing `}' was not checking for being block or not.\r
+;;; Beautifying levels in RE: Did not know about lookbehind;\r
+;;; finding *which* level was not intuitive;\r
+;;; `cperl-beautify-levels' added.\r
+;;; Allow here-docs contain `=head1' and friends (at least for keywords).\r
+\r
+;;;; After 2.7:\r
+;;; Fix for broken `font-lock-unfontify-region-function'. Should\r
+;;; preserve `syntax-table' properties even with `lazy-lock'.\r
+\r
+;;;; After 2.8:\r
+;;; Some more compile time warnings crept in.\r
+;;; `cperl-indent-region-fix-else' implemented.\r
+;;; `cperl-fix-line-spacing' implemented.\r
+;;; `cperl-invert-if-unless' implemented (C-c C-t and in Menu).\r
+;;; Upgraded hints to mention 20.2's goods/bads.\r
+;;; Started to use `cperl-extra-newline-before-brace-multiline',\r
+;;; `cperl-break-one-line-blocks-when-indent',\r
+;;; `cperl-fix-hanging-brace-when-indent', `cperl-merge-trailing-else'.\r
+\r
+;;;; After 2.9:\r
+;;; Workaround for another `font-lock's `syntax-table' text-property bug.\r
+;;; `zerop' could be applied to nil.\r
+;;; At last, may work with `font-lock' without setting `cperl-font-lock'.\r
+;;; (We expect that starting from 19.33, `font-lock' supports keywords\r
+;;; being a function - what is a correct version?)\r
+;;; Rename `cperl-indent-region-fix-else' to\r
+;;; `cperl-indent-region-fix-constructs'.\r
+;;; `cperl-fix-line-spacing' could be triggered inside strings, would not\r
+;;; know what to do with BLOCKs of map/printf/etc.\r
+;;; `cperl-merge-trailing-else' and `cperl-fix-line-spacing' handle\r
+;;; `continue' too.\r
+;;; Indentation after {BLOCK} knows about map/printf/etc.\r
+;;; Finally: treat after-comma lines as continuation lines.\r
+\r
+;;;; After 2.10:\r
+;;; `continue' made electric.\r
+;;; Electric `do' inserts `do/while'.\r
+;;; Some extra compile-time warnings crept in.\r
+;;; `font-lock' of 19.33 could not handle font-lock-keywords being a function\r
+;;; returning a symbol.\r
+\r
+;;;; After 2.11:\r
+;;; Changes to make syntaxification to be autoredone via `font-lock'.\r
+;;; Switched on by `cperl-syntaxify-by-font-lock', off by default so far.\r
+\r
+;;;; After 2.12:\r
+;;; Remove some commented out chunks.\r
+;;; Styles are slightly updated (a lot of work is needed, especially\r
+;;; with new `cperl-fix-line-spacing').\r
+\r
+;;;; After 2.13:\r
+;;; Old value of style is memorized when choosing a new style, may be\r
+;;; restored from the same menu.\r
+;;; Mode-documentation added to micro-docs.\r
+;;; `cperl-praise' updated.\r
+;;; `cperl-toggle-construct-fix' added on C-c C-w and menu.\r
+;;; `auto-fill-mode' added on C-c C-f and menu.\r
+;;; `PerlStyle' style added.\r
+;;; Message for termination of scan corrected.\r
+\r
+;;;; After 2.14:\r
+\r
+;;; Did not work with -q\r
+\r
+;;;; After 2.15:\r
+\r
+;;; `cperl-speed' hints added.\r
+;;; Minor style fixes.\r
+\r
+;;;; After 2.15:\r
+;;; Make backspace electric after expansion of `else/continue' too.\r
+\r
+;;;; After 2.16:\r
+;;; Starting to merge changes to RMS emacs version.\r
+\r
+;;;; After 2.17:\r
+;;; Merged custom stuff and darn `font-lock-constant-face'.\r
+\r
+;;;; After 2.18:\r
+;;; Bumped the version to 3.1\r
+\r
+;;;; After 3.1:\r
+;;; Fixed customization to honor cperl-hairy.\r
+;;; Created customization groups. Sent to RMS to include into 2.3.\r
+\r
+;;;; After 3.2:\r
+;;; Interaction of `font-lock-hot-pass' and `cperl-syntaxify-by-font-lock'.\r
+;;; (`cperl-after-block-and-statement-beg'):\r
+;;; (`cperl-after-block-p'):\r
+;;; (`cperl-after-expr-p'): It is BLOCK if we reach lim when backup sexp.\r
+;;; (`cperl-indent-region'): Make a marker for END - text added/removed.\r
+;;; (`cperl-style-alist', `cperl-styles-entries')\r
+;;; Include `cperl-merge-trailing-else' where the value is clear.\r
+\r
+;;;; After 3.3:\r
+;;; (`cperl-tips'):\r
+;;; (`cperl-problems'): Improvements to docs.\r
+\r
+;;;; After 3.4:\r
+;;; (`cperl-mode'): Make lazy syntaxification possible.\r
+;;; (`cperl-find-pods-heres'): Safe a position in buffer where it is safe to\r
+;;; restart syntaxification.\r
+;;; (`cperl-syntaxify-by-font-lock'): Set to t, should be safe now.\r
+\r
+;;;; After 3.5:\r
+;;; (`cperl-syntaxify-by-font-lock'): Better default, customizes to\r
+;;; `message' too.\r
+\r
+;;;; After 3.6:\r
+;;; (`cperl-find-pods-heres'): changed so that -d ?foo? is a RE.\r
+;;; (`cperl-array-face'): changed name from `font-lock-emphasized-face'.\r
+;;; (`cperl-hash-face'): changed name from `font-lock-other-emphasized-face'.\r
+;;; Use `defface' to define these two extra faces.\r
+\r
+;;;; After 3.7:\r
+;;; Can use linear algorithm for indentation if Emacs supports it:\r
+;;; indenting DB::DB (800+ lines) improved from 69 sec to 11 sec\r
+;;; (73 vs 15 with imenu).\r
+;;; (`cperl-emacs-can-parse'): New state.\r
+;;; (`cperl-indent-line'): Corrected to use global state.\r
+;;; (`cperl-calculate-indent'): Likewise.\r
+;;; (`cperl-fix-line-spacing'): Likewise (not used yet).\r
+\r
+;;;; After 3.8:\r
+;;; (`cperl-choose-color'): Converted to a function (to be compilable in text-mode).\r
+\r
+;;;; After 3.9:\r
+;;; (`cperl-dark-background '): Disable without window-system.\r
+\r
+;;;; After 3.10:\r
+;;; Do `defface' only if window-system.\r
+\r
+;;;; After 3.11:\r
+;;; (`cperl-fix-line-spacing'): sped up to bail out early.\r
+;;; (`cperl-indent-region'): Disable hooks during the call (how to call them later?).\r
+\r
+;;; Now indents 820-line-long function in 6.5 sec (including syntaxification) the first time\r
+;;; (when buffer has few properties), 7.1 sec the second time.\r
+\r
+;;;Function Name Call Count Elapsed Time Average Time\r
+;;;========================================= ========== ============ ============\r
+;;;cperl-indent-exp 1 10.039999999 10.039999999\r
+;;;cperl-indent-region 1 10.0 10.0\r
+;;;cperl-indent-line 821 6.2100000000 0.0075639464\r
+;;;cperl-calculate-indent 821 5.0199999999 0.0061144945\r
+;;;cperl-backward-to-noncomment 2856 2.0500000000 0.0007177871\r
+;;;cperl-fontify-syntaxically 2 1.78 0.8900000000\r
+;;;cperl-find-pods-heres 2 1.78 0.8900000000\r
+;;;cperl-update-syntaxification 1 1.78 1.78\r
+;;;cperl-fix-line-spacing 769 1.4800000000 0.0019245773\r
+;;;cperl-after-block-and-statement-beg 163 1.4100000000 0.0086503067\r
+;;;cperl-block-p 775 1.1800000000 0.0015225806\r
+;;;cperl-to-comment-or-eol 3652 1.1200000000 0.0003066812\r
+;;;cperl-after-block-p 165 1.0500000000 0.0063636363\r
+;;;cperl-commentify 141 0.22 0.0015602836\r
+;;;cperl-get-state 813 0.16 0.0001968019\r
+;;;cperl-backward-to-start-of-continued-exp 26 0.12 0.0046153846\r
+;;;cperl-delay-update-hook 2107 0.0899999999 4.271...e-05\r
+;;;cperl-protect-defun-start 141 0.0700000000 0.0004964539\r
+;;;cperl-after-label 407 0.0599999999 0.0001474201\r
+;;;cperl-forward-re 139 0.0299999999 0.0002158273\r
+;;;cperl-comment-indent 26 0.0299999999 0.0011538461\r
+;;;cperl-use-region-p 8 0.0 0.0\r
+;;;cperl-lazy-hook 15 0.0 0.0\r
+;;;cperl-after-expr-p 8 0.0 0.0\r
+;;;cperl-font-lock-unfontify-region-function 1 0.0 0.0\r
+\r
+;;;Function Name Call Count Elapsed Time Average Time\r
+;;;========================================= ========== ============ ============\r
+;;;cperl-fix-line-spacing 769 1.4500000000 0.0018855656\r
+;;;cperl-indent-line 13 0.3100000000 0.0238461538\r
+;;;cperl-after-block-and-statement-beg 69 0.2700000000 0.0039130434\r
+;;;cperl-after-block-p 69 0.2099999999 0.0030434782\r
+;;;cperl-calculate-indent 13 0.1000000000 0.0076923076\r
+;;;cperl-backward-to-noncomment 177 0.0700000000 0.0003954802\r
+;;;cperl-get-state 13 0.0 0.0\r
+;;;cperl-to-comment-or-eol 179 0.0 0.0\r
+;;;cperl-get-help-defer 1 0.0 0.0\r
+;;;cperl-lazy-hook 11 0.0 0.0\r
+;;;cperl-after-expr-p 2 0.0 0.0\r
+;;;cperl-block-p 13 0.0 0.0\r
+;;;cperl-after-label 5 0.0 0.0\r
+\r
+;;;; After 3.12:\r
+;;; (`cperl-find-pods-heres'): do not warn on `=cut' if doing a chunk only.\r
+\r
+;;;; After 3.13:\r
+;;; (`cperl-mode'): load pseudo-faces on `cperl-find-pods-heres' (for 19.30).\r
+;;; (`x-color-defined-p'): was not compiling on XEmacs\r
+;;; (`cperl-find-pods-heres'): 1 << 6 was OK, but 1<<6 was considered as HERE\r
+;;; <file/glob> made into a string.\r
+\r
+;;;; After 3.14:\r
+;;; (`cperl-find-pods-heres'): Postpone addition of faces after syntactic step\r
+;;; Recognition of <FH> was wrong.\r
+;;; (`cperl-clobber-lisp-bindings'): if set, C-c variants are the old ones\r
+;;; (`cperl-unwind-to-safe'): New function.\r
+;;; (`cperl-fontify-syntaxically'): Use `cperl-unwind-to-safe' to start at reasonable position.\r
+\r
+;;;; After 3.15:\r
+;;; (`cperl-forward-re'): Highlight the trailing / in s/foo// as string.\r
+;;; Highlight the starting // in s//foo/ as function-name.\r
+\r
+;;;; After 3.16:\r
+;;; (`cperl-find-pods-heres'): Highlight `gem' in s///gem as a keyword.\r
+\r
+;;;; After 4.0:\r
+;;; (`cperl-find-pods-heres'): `qr' added\r
+;;; (`cperl-electric-keyword'): Likewise\r
+;;; (`cperl-electric-else'): Likewise\r
+;;; (`cperl-to-comment-or-eol'): Likewise\r
+;;; (`cperl-make-regexp-x'): Likewise\r
+;;; (`cperl-init-faces'): Likewise, and `lock' (as overridable?).\r
+;;; (`cperl-find-pods-heres'): Knows that split// is null-RE.\r
+;;; Highlights separators in 3-parts expressions\r
+;;; as labels.\r
+\r
+;;;; After 4.1:\r
+;;; (`cperl-find-pods-heres'): <> was considered as a glob\r
+;;; (`cperl-syntaxify-unwind'): New configuration variable\r
+;;; (`cperl-fontify-m-as-s'): New configuration variable\r
+\r
+;;;; After 4.2:\r
+;;; (`cperl-find-pods-heres'): of the last line being `=head1' fixed.\r
+\r
+;;; Handling of a long construct is still buggy if only the part of\r
+;;; construct touches the updated region (we unwind to the start of\r
+;;; long construct, but the end may have residual properties).\r
+\r
+;;; (`cperl-unwind-to-safe'): would not go to beginning of buffer.\r
+;;; (`cperl-electric-pod'): check for after-expr was performed\r
+;;; inside of POD too.\r
+\r
+;;;; After 4.3:\r
+;;; (`cperl-backward-to-noncomment'): better treatment of PODs and HEREs.\r
+\r
+;;; Indent-line works good, but indent-region does not - at toplevel...\r
+;;; (`cperl-unwind-to-safe'): Signature changed.\r
+;;; (`x-color-defined-p'): was defmacro'ed with a tick. Remove another def.\r
+;;; (`cperl-clobber-mode-lists'): New configuration variable.\r
+;;; (`cperl-array-face'): One of definitions was garbled.\r
+\r
+;;;; After 4.4:\r
+;;; (`cperl-not-bad-style-regexp'): Updated.\r
+;;; (`cperl-make-regexp-x'): Misprint in a message.\r
+;;; (`cperl-find-pods-heres'): $a-1 ? foo : bar; was a regexp.\r
+;;; `<< (' was considered a start of POD.\r
+;;; Init: `cperl-is-face' was busted.\r
+;;; (`cperl-make-face'): New macros.\r
+;;; (`cperl-force-face'): New macros.\r
+;;; (`cperl-init-faces'): Corrected to use new macros;\r
+;;; `if' for copying `reference-face' to\r
+;;; `constant-face' was backward.\r
+;;; (`font-lock-other-type-face'): Done via `defface' too.\r
+\r
+;;;; After 4.5:\r
+;;; (`cperl-init-faces-weak'): use `cperl-force-face'.\r
+;;; (`cperl-after-block-p'): After END/BEGIN we are a block.\r
+;;; (`cperl-mode'): `font-lock-unfontify-region-function'\r
+;;; was set to a wrong function.\r
+;;; (`cperl-comment-indent'): Commenting __END__ was not working.\r
+;;; (`cperl-indent-for-comment'): Likewise.\r
+;;; (Indenting is still misbehaving at toplevel.)\r
+\r
+;;;; After 4.5:\r
+;;; (`cperl-unwind-to-safe'): Signature changed, unwinds end too.\r
+;;; (`cperl-find-pods-heres'): mark qq[]-etc sections as syntax-type=string\r
+;;; (`cperl-fontify-syntaxically'): Unwinds start and end to go out of\r
+;;; long strings (not very successful).\r
+\r
+;;; >>>> CPerl should be usable in write mode too now <<<<\r
+\r
+;;; (`cperl-syntaxify-by-font-lock'): Better default - off in text-mode.\r
+;;; (`cperl-tips'): Updated docs.\r
+;;; (`cperl-problems'): Updated docs.\r
+\r
+;;;; After 4.6:\r
+;;; (`cperl-calculate-indent'): Did not consider `,' as continuation mark for statements.\r
+;;; (`cperl-write-tags'): Correct for XEmacs's `visit-tags-table-buffer'.\r
+\r
+;;;; After 4.7:\r
+;;; (`cperl-calculate-indent'): Avoid parse-data optimization at toplevel.\r
+;;; Should indent correctly at toplevel too.\r
+;;; (`cperl-tags-hier-init'): Gross hack to pretend we work (are we?).\r
+;;; (`cperl-find-pods-heres'): Was not processing sub protos after a comment ine.\r
+;;; Was treating $a++ <= 5 as a glob.\r
+\r
+;;;; After 4.8:\r
+;;; (toplevel): require custom unprotected => failure on 19.28.\r
+;;; (`cperl-xemacs-p') defined when compile too\r
+;;; (`cperl-tags-hier-init'): Another try to work around XEmacs problems\r
+;;; Better progress messages.\r
+;;; (`cperl-find-tags'): Was writing line/pos in a wrong order,\r
+;;; pos off by 1 and not at beg-of-line.\r
+;;; (`cperl-etags-snarf-tag'): New macro\r
+;;; (`cperl-etags-goto-tag-location'): New macro\r
+;;; (`cperl-write-tags'): When removing old TAGS info was not\r
+;;; relativizing filename\r
+\r
+;;;; After 4.9:\r
+;;; (`cperl-version'): New variable. New menu entry\r
+\r
+;;;; After 4.10:\r
+;;; (`cperl-tips'): Updated.\r
+;;; (`cperl-non-problems'): Updated.\r
+;;; random: References to future 20.3 removed.\r
+\r
+;;;; After 4.11:\r
+;;; (`perl-font-lock-keywords'): Would not highlight `sub foo($$);'.\r
+;;; Docstrings: Menu was described as `CPerl' instead of `Perl'\r
+\r
+;;;; After 4.12:\r
+;;; (`cperl-toggle-construct-fix'): Was toggling to t instead of 1.\r
+;;; (`cperl-ps-print-init'): Associate `cperl-array-face', `cperl-hash-face'\r
+;;; remove `font-lock-emphasized-face'.\r
+;;; remove `font-lock-other-emphasized-face'.\r
+;;; remove `font-lock-reference-face'.\r
+;;; remove `font-lock-keyword-face'.\r
+;;; Use `eval-after-load'.\r
+;;; (`cperl-init-faces'): remove init `font-lock-other-emphasized-face'.\r
+;;; remove init `font-lock-emphasized-face'.\r
+;;; remove init `font-lock-keyword-face'.\r
+;;; (`cperl-tips-faces'): New variable and an entry into Mini-docs.\r
+;;; (`cperl-indent-region'): Do not indent whitespace lines\r
+;;; (`cperl-indent-exp'): Was not processing else-blocks.\r
+;;; (`cperl-calculate-indent'): Remove another parse-data optimization\r
+;;; at toplevel: would indent correctly.\r
+;;; (`cperl-get-state'): NOP line removed.\r
+\r
+;;;; After 4.13:\r
+;;; (`cperl-ps-print-init'): Remove not-CPerl-related faces.\r
+;;; (`cperl-ps-print'): New function and menu entry.\r
+;;; (`cperl-ps-print-face-properties'): New configuration variable.\r
+;;; (`cperl-invalid-face'): New configuration variable.\r
+;;; (`cperl-nonoverridable-face'): New face. Renamed from\r
+;;; `font-lock-other-type-face'.\r
+;;; (`perl-font-lock-keywords'): Highlight trailing whitespace\r
+;;; (`cperl-contract-levels'): Documentation corrected.\r
+;;; (`cperl-contract-level'): Likewise.\r
+\r
+;;;; After 4.14:\r
+;;; (`cperl-ps-print'): `ps-print-face-extension-alist' was not in old Emaxen,\r
+;;; same with `ps-extend-face-list'\r
+;;; (`cperl-ps-extend-face-list'): New macro.\r
+\r
+;;;; After 4.15:\r
+;;; (`cperl-init-faces'): Interpolate `cperl-invalid-face'.\r
+;;; (`cperl-forward-re'): Emit a meaningful error instead of a cryptic\r
+;;; one for uncomplete REx near end-of-buffer.\r
+;;; (`cperl-find-pods-heres'): Tolerate unfinished REx at end-of-buffer.\r
+\r
+;;;; After 4.16:\r
+;;; (`cperl-find-pods-heres'): `unwind-protect' was left commented.\r
+\r
+;;;; After 4.17:\r
+;;; (`cperl-invalid-face'): Change to ''underline.\r
+\r
+;;;; After 4.18:\r
+;;; (`cperl-find-pods-heres'): / and ? after : start a REx.\r
+;;; (`cperl-after-expr-p'): Skip labels when checking\r
+;;; (`cperl-calculate-indent'): Correct for labels when calculating\r
+;;; indentation of continuations.\r
+;;; Docstring updated.\r
+\r
+;;;; After 4.19:\r
+;;; Minor (mostly spelling) corrections from 20.3.3 merged.\r
+\r
+;;;; After 4.20:\r
+;;; (`cperl-tips'): Another workaround added. Sent to RMS for 20.4.\r
+\r
+;;;; After 4.21:\r
+;;; (`cperl-praise'): Mention linear-time indent.\r
+;;; (`cperl-find-pods-heres'): @if ? a : b was considered a REx.\r
+\r
+;;;; After 4.22:\r
+;;; (`cperl-after-expr-p'): Make true after __END__.\r
+;;; (`cperl-electric-pod'): "SYNOPSIS" was misspelled.\r
+\r
+;;;; After 4.23:\r
+;;; (`cperl-beautify-regexp-piece'): Was not allowing for *? after a class.\r
+;;; Allow for POSIX char-classes.\r
+;;; Remove trailing whitespace when\r
+;;; adding new linebreak.\r
+;;; Add a level counter to stop shallow.\r
+;;; Indents unprocessed groups rigidly.\r
+;;; (`cperl-beautify-regexp'): Add an optional count argument to go that\r
+;;; many levels deep.\r
+;;; (`cperl-beautify-level'): Likewise\r
+;;; Menu: Add new entries to Regexp menu to do one level\r
+;;; (`cperl-contract-level'): Was entering an infinite loop\r
+;;; (`cperl-find-pods-heres'): Typo (double quoting).\r
+;;; Was detecting < $file > as FH instead of glob.\r
+;;; Support for comments in RExen (except\r
+;;; for m#\#comment#x), governed by\r
+;;; `cperl-regexp-scan'.\r
+;;; (`cperl-regexp-scan'): New customization variable.\r
+;;; (`cperl-forward-re'): Improve logic of resetting syntax table.\r
+\r
+;;;; After 4.23 and: After 4.24:\r
+;;; (`cperl-contract-levels'): Restore position.\r
+;;; (`cperl-beautify-level'): Likewise.\r
+;;; (`cperl-beautify-regexp'): Likewise.\r
+;;; (`cperl-commentify'): Rudimental support for length=1 runs\r
+;;; (`cperl-find-pods-heres'): Process 1-char long REx comments too /a#/x\r
+;;; Processes REx-comments in #-delimited RExen.\r
+;;; MAJOR BUG CORRECTED: after a misparse\r
+;;; a body of a subroutine could be corrupted!!!\r
+;;; One might need to reeval the function body\r
+;;; to fix things. (A similar bug was\r
+;;; present in `cperl-indent-region' eons ago.)\r
+;;; To reproduce:\r
+;; (defun foo () (let ((a '(t))) (insert (format "%s" a)) (setcar a 'BUG) t))\r
+;; (foo)\r
+;; (foo)\r
+;;; C-x C-e the above three lines (at end-of-line). First evaluation\r
+;;; of `foo' inserts (t), second one inserts (BUG) ?!\r
+;;;\r
+;;; In CPerl it was triggered by inserting then deleting `/' at start of\r
+;;; / a (?# asdf {[(}asdf )ef,/;\r
+\r
+;;;; After 4.25:\r
+;;; (`cperl-commentify'): Was recognizing length=2 "strings" as length=1.\r
+;;; (`imenu-example--create-perl-index'):\r
+;;; Was not enforcing syntaxification-to-the-end.\r
+;;; (`cperl-invert-if-unless'): Allow `for', `foreach'.\r
+;;; (`cperl-find-pods-heres'): Quote `cperl-nonoverridable-face'.\r
+;;; Mark qw(), m()x as indentable.\r
+;;; (`cperl-init-faces'): Highlight `sysopen' too.\r
+;;; Highlight $var in `for my $var' too.\r
+;;; (`cperl-invert-if-unless'): Was leaving whitespace at end.\r
+;;; (`cperl-linefeed'): Was splitting $var{$foo} if point after `{'.\r
+;;; (`cperl-calculate-indent'): Remove old commented out code.\r
+;;; Support (primitive) indentation of qw(), m()x.\r
+\r
+\r
+;;;; After 4.26:\r
+;;; (`cperl-problems'): Mention `fill-paragraph' on comment. \"" and\r
+;;; q [] with intervening newlines.\r
+;;; (`cperl-autoindent-on-semi'): New customization variable.\r
+;;; (`cperl-electric-semi'): Use `cperl-autoindent-on-semi'.\r
+;;; (`cperl-tips'): Mention how to make CPerl the default mode.\r
+;;; (`cperl-mode'): Support `outline-minor-mode'\r
+;;; (Thanks to Mark A. Hershberger).\r
+;;; (`cperl-outline-level'): New function.\r
+;;; (`cperl-highlight-variables-indiscriminately'): New customization var.\r
+;;; (`cperl-init-faces'): Use `cperl-highlight-variables-indiscriminately'.\r
+;;; (Thanks to Sean Kamath <kamath@pogo.wv.tek.com>).\r
+;;; (`cperl-after-block-p'): Support CHECK and INIT.\r
+;;; (`cperl-init-faces'): Likewise and "our".\r
+;;; (Thanks to Doug MacEachern <dougm@covalent.net>).\r
+;;; (`cperl-short-docs'): Likewise and "our".\r
+\r
+\r
+;;;; After 4.27:\r
+;;; (`cperl-find-pods-heres'): Recognize \"" as a string.\r
+;;; Mark whitespace and comments between q and []\r
+;;; as `syntax-type' => `prestring'.\r
+;;; Allow whitespace between << and "FOO".\r
+;;; (`cperl-problems'): Remove \"" and q [] with intervening newlines.\r
+;;; Mention multiple <<EOF as unsupported.\r
+;;; (`cperl-highlight-variables-indiscriminately'): Doc misprint fixed.\r
+;;; (`cperl-indent-parens-as-block'): New configuration variable.\r
+;;; (`cperl-calculate-indent'): Merge cases of indenting non-BLOCK groups.\r
+;;; Use `cperl-indent-parens-as-block'.\r
+;;; (`cperl-find-pods-heres'): Test for =cut without empty line instead of\r
+;;; complaining about no =cut.\r
+;;; (`cperl-electric-pod'): Change the REx for POD from "\n\n=" to "^\n=".\r
+;;; (`cperl-find-pods-heres'): Likewise.\r
+;;; (`cperl-electric-pod'): Change `forward-sexp' to `forward-word':\r
+;;; POD could've been marked as comment already.\r
+;;; (`cperl-unwind-to-safe'): Unwind before start of POD too.\r
+\r
+;;;; After 4.28:\r
+;;; (`cperl-forward-re'): Throw an error at proper moment REx unfinished.\r
+\r
+;;;; After 4.29:\r
+;;; (`x-color-defined-p'): Make an extra case to peacify the warning.\r
+;;; Toplevel: `defvar' to peacify the warnings.\r
+;;; (`cperl-find-pods-heres'): Could access `font-lock-comment-face' in -nw.\r
+;;;; No -nw-compile time warnings now.\r
+;;; (`cperl-find-tags'): TAGS file had too short substring-to-search.\r
+;;; Be less verbose in non-interactive mode\r
+;;; (`imenu-example--create-perl-index'): Set index-marker after name\r
+;;; (`cperl-outline-regexp'): New variable.\r
+;;; (`cperl-outline-level'): Made compatible with `cperl-outline-regexp'.\r
+;;; (`cperl-mode'): Made use `cperl-outline-regexp'.\r
+\r
+;;;; After 4.30:\r
+;;; (`cperl-find-pods-heres'): =cut the last thing, no blank line, was error.\r
+;;; (`cperl-outline-level'): Make start-of-file same level as `package'.\r
+\r
+;;;; After 4.31:\r
+;;; (`cperl-electric-pod'): `head1' and `over' electric only if empty.\r
+;;; (`cperl-unreadable-ok'): New variable.\r
+;;; (`cperl-find-tags'): Use `cperl-unreadable-ok', do not fail\r
+;;; on an unreadable file\r
+;;; (`cperl-write-tags'): Use `cperl-unreadable-ok', do not fail\r
+;;; on an unreadable directory\r
+\r
+;;;; After 4.32:\r
+;;; Syncronized with v1.60 from Emacs 21.3.\r
+;;; Mostly docstring and formatting changes, and:\r
+\r
+;;; (`cperl-noscan-files-regexp'): Do not scan CVS subdirs\r
+;;; (`cperl-problems'): Note that newer XEmacsen may syntaxify too\r
+;;; (`imenu-example--create-perl-index'):\r
+;;; Renamed to `cperl-imenu--create-perl-index'\r
+;;; (`cperl-mode'): Replace `make-variable-buffer-local' by `make-local-variable'\r
+;;; (`cperl-setup-tmp-buf'): Likewise\r
+;;; (`cperl-fix-line-spacing'): Fix a misprint of "t" for "\t"\r
+;;; (`cperl-next-bad-style'): Fix misprints in character literals\r
+\r
+;;;; After 4.33:\r
+;;; (`cperl-font-lock-keywords'): +etc: Aliased to perl-font-lock-keywords.\r
+\r
+;;;; After 4.34:\r
+;;; Further updates of whitespace and spelling w.r.t. RMS version.\r
+;;; (`cperl-font-lock-keywords'): +etc: Avoid warnings when aliasing.\r
+;;; (`cperl-mode'): Use `normal-auto-fill-function' if present.\r
+;;; (`cperl-use-major-mode'): New variable\r
+;;; (`cperl-can-font-lock'): New variable; replaces `window-system'\r
+;;; (`cperl-tags-hier-init'): use `display-popup-menus-p' (if present)\r
+;;; to choose `x-popup-menu' vs `tmm-prompt'\r
+\r
+;;;; 4.35 has the following differences from version 1.40+ of RMS Emacs:\r
+\r
+;;; New variables `cperl-use-major-mode', `cperl-can-font-lock';\r
+;;; `cperl-use-major-mode' is (effectively) 'cperl-mode in RMS.\r
+;;; `cperl-under-as-char' is nil in RMS.\r
+;;; Minor differences in docstrings, and `cperl-non-problems'.\r
+;;; Backward compatibility addressed: (`); (function (lambda ...)); font-lock;\r
+;;; (:italic t bold t) vs (:slant italic :weight bold) in faces;\r
+;;; `normal-auto-fill-function'.\r
+;;; RMS version has wrong logic in `cperl-calculate-indent': $a = { } is\r
+;;; wrongly indented if the closing brace is on a separate line.\r
+;;; Different choice of ordering if's for is-x-REx and (eq (char-after b) ?\#)\r
+;;; in `cperl-find-pods-heres'. [Cosmetic]\r
+\r
+;;;; After 4.35:\r
+;;; (`cperl-find-pods-heres'): If no end of HERE-doc found, mark to the end\r
+;;; of buffer. This enables recognition of end\r
+;;; of HERE-doc "as one types".\r
+;;; Require "\n" after trailing tag of HERE-doc.\r
+;;; \( made non-quoting outside of string/comment\r
+;;; (gdj-contributed).\r
+;;; Likewise for \$.\r
+;;; Remove `here-doc-group' text property at start\r
+;;; (makes this property reliable).\r
+;;; Text property `first-format-line' ==> t.\r
+;;; Do not recognize $opt_s and $opt::s as s///.\r
+;;; (`cperl-perldoc'): Use case-sensitive search (contributed).\r
+;;; (`cperl-fix-line-spacing'): Allow "_" in $vars of foreach etc. when\r
+;;; underscore isn't a word char (gdj-contributed).\r
+;;; (`defun-prompt-regexp'): Allow prototypes.\r
+;;; (`cperl-vc-header-alist'): Extract numeric version from the Id.\r
+;;; Toplevel: Put toggle-autohelp into the mode menu.\r
+;;; Better docs for toggle/set/unset autohelp.\r
+;;; (`cperl-electric-backspace-untabify'): New customization variable\r
+;;; (`cperl-after-expr-p'): Works after here-docs, formats, and PODs too\r
+;;; (affects many electric constructs).\r
+;;; (`cperl-calculate-indent'): Takes into account `first-format-line' ==>\r
+;;; works after format.\r
+;;; (`cperl-short-docs'): Make it work with ... too.\r
+;;; "array context" ==> "list context"\r
+;;; (`cperl-electric-keyword'): make $if (etc: "$@%&*") non-electric\r
+;;; '(' after keyword would insert a doubled paren\r
+;;; (`cperl-electric-paren'): documented affected by `cperl-electric-parens'\r
+;;; (`cperl-electric-rparen'): Likewise\r
+;;; (`cperl-build-manpage'): New function by Nick Roberts\r
+;;; (`cperl-perldoc'): Make it work in XEmacs too\r
+\r
+;;;; After 4.36:\r
+;;; (`cperl-find-pods-heres'): Recognize s => 1 and {s} (as a key or varname),\r
+;;; { s:: } and { s::bar::baz } as varnames.\r
+;;; (`cperl-after-expr-p'): Updates syntaxification before checks\r
+;;; (`cperl-calculate-indent'): Likewise\r
+;;; Fix wrong indent of blocks starting with POD\r
+;;; (`cperl-after-block-p'): Optional argument for checking for a pre-block\r
+;;; Recognize `continue' blocks too.\r
+;;; (`cperl-electric-brace'): use `cperl-after-block-p' for detection;\r
+;;; Now works for else/continue/sub blocks\r
+;;; (`cperl-short-docs'): Minor edits; make messages fit 80-column screen\r
+\r
+;;; Code:\r
+\r
+\f\r
+(if (fboundp 'eval-when-compile)\r
+ (eval-when-compile\r
+ (condition-case nil\r
+ (require 'custom)\r
+ (error nil))\r
+ (condition-case nil\r
+ (require 'man)\r
+ (error nil))\r
+ (defconst cperl-xemacs-p (string-match "XEmacs\\|Lucid" emacs-version))\r
+ (defvar cperl-can-font-lock\r
+ (or cperl-xemacs-p\r
+ (and (boundp 'emacs-major-version)\r
+ (or window-system\r
+ (> emacs-major-version 20)))))\r
+ (if cperl-can-font-lock\r
+ (require 'font-lock))\r
+ (defvar msb-menu-cond)\r
+ (defvar gud-perldb-history)\r
+ (defvar font-lock-background-mode) ; not in Emacs\r
+ (defvar font-lock-display-type) ; ditto\r
+ (or (fboundp 'defgroup)\r
+ (defmacro defgroup (name val doc &rest arr)\r
+ nil))\r
+ (or (fboundp 'custom-declare-variable)\r
+ (defmacro defcustom (name val doc &rest arr)\r
+ (` (defvar (, name) (, val) (, doc)))))\r
+ (or (and (fboundp 'custom-declare-variable)\r
+ (string< "19.31" emacs-version)) ; Checked with 19.30: defface does not work\r
+ (defmacro defface (&rest arr)\r
+ nil))\r
+ ;; Avoid warning (tmp definitions)\r
+ (or (fboundp 'x-color-defined-p)\r
+ (defmacro x-color-defined-p (col)\r
+ (cond ((fboundp 'color-defined-p) (` (color-defined-p (, col))))\r
+ ;; XEmacs >= 19.12\r
+ ((fboundp 'valid-color-name-p) (` (valid-color-name-p (, col))))\r
+ ;; XEmacs 19.11\r
+ ((fboundp 'x-valid-color-name-p) (` (x-valid-color-name-p (, col))))\r
+ (t '(error "Cannot implement color-defined-p")))))\r
+ (defmacro cperl-is-face (arg) ; Takes quoted arg\r
+ (cond ((fboundp 'find-face)\r
+ (` (find-face (, arg))))\r
+ (;;(and (fboundp 'face-list)\r
+ ;; (face-list))\r
+ (fboundp 'face-list)\r
+ (` (member (, arg) (and (fboundp 'face-list)\r
+ (face-list)))))\r
+ (t\r
+ (` (boundp (, arg))))))\r
+ (defmacro cperl-make-face (arg descr) ; Takes unquoted arg\r
+ (cond ((fboundp 'make-face)\r
+ (` (make-face (quote (, arg)))))\r
+ (t\r
+ (` (defvar (, arg) (quote (, arg)) (, descr))))))\r
+ (defmacro cperl-force-face (arg descr) ; Takes unquoted arg\r
+ (` (progn\r
+ (or (cperl-is-face (quote (, arg)))\r
+ (cperl-make-face (, arg) (, descr)))\r
+ (or (boundp (quote (, arg))) ; We use unquoted variants too\r
+ (defvar (, arg) (quote (, arg)) (, descr))))))\r
+ (if cperl-xemacs-p\r
+ (defmacro cperl-etags-snarf-tag (file line)\r
+ (` (progn\r
+ (beginning-of-line 2)\r
+ (list (, file) (, line)))))\r
+ (defmacro cperl-etags-snarf-tag (file line)\r
+ (` (etags-snarf-tag))))\r
+ (if cperl-xemacs-p\r
+ (defmacro cperl-etags-goto-tag-location (elt)\r
+ (`;;(progn\r
+ ;; (switch-to-buffer (get-file-buffer (elt (, elt) 0)))\r
+ ;; (set-buffer (get-file-buffer (elt (, elt) 0)))\r
+ ;; Probably will not work due to some save-excursion???\r
+ ;; Or save-file-position?\r
+ ;; (message "Did I get to line %s?" (elt (, elt) 1))\r
+ (goto-line (string-to-int (elt (, elt) 1)))))\r
+ ;;)\r
+ (defmacro cperl-etags-goto-tag-location (elt)\r
+ (` (etags-goto-tag-location (, elt)))))))\r
+\r
+(defconst cperl-xemacs-p (string-match "XEmacs\\|Lucid" emacs-version))\r
+\r
+(defvar cperl-can-font-lock\r
+ (or cperl-xemacs-p\r
+ (and (boundp 'emacs-major-version)\r
+ (or window-system\r
+ (> emacs-major-version 20)))))\r
+\r
+(condition-case nil\r
+ (require 'custom)\r
+ (error nil)) ; Already fixed by eval-when-compile\r
+\r
+(defun cperl-choose-color (&rest list)\r
+ (let (answer)\r
+ (while list\r
+ (or answer\r
+ (if (or (x-color-defined-p (car list))\r
+ (null (cdr list)))\r
+ (setq answer (car list))))\r
+ (setq list (cdr list)))\r
+ answer))\r
+\r
+\f\r
+(defgroup cperl nil\r
+ "Major mode for editing Perl code."\r
+ :prefix "cperl-"\r
+ :group 'languages)\r
+\r
+(defgroup cperl-indentation-details nil\r
+ "Indentation."\r
+ :prefix "cperl-"\r
+ :group 'cperl)\r
+\r
+(defgroup cperl-affected-by-hairy nil\r
+ "Variables affected by `cperl-hairy'."\r
+ :prefix "cperl-"\r
+ :group 'cperl)\r
+\r
+(defgroup cperl-autoinsert-details nil\r
+ "Auto-insert tuneup."\r
+ :prefix "cperl-"\r
+ :group 'cperl)\r
+\r
+(defgroup cperl-faces nil\r
+ "Fontification colors."\r
+ :prefix "cperl-"\r
+ :group 'cperl)\r
+\r
+(defgroup cperl-speed nil\r
+ "Speed vs. validity tuneup."\r
+ :prefix "cperl-"\r
+ :group 'cperl)\r
+\r
+(defgroup cperl-help-system nil\r
+ "Help system tuneup."\r
+ :prefix "cperl-"\r
+ :group 'cperl)\r
+\r
+\f\r
+(defcustom cperl-extra-newline-before-brace nil\r
+ "*Non-nil means that if, elsif, while, until, else, for, foreach\r
+and do constructs look like:\r
+\r
+ if ()\r
+ {\r
+ }\r
+\r
+instead of:\r
+\r
+ if () {\r
+ }"\r
+ :type 'boolean\r
+ :group 'cperl-autoinsert-details)\r
+\r
+(defcustom cperl-extra-newline-before-brace-multiline\r
+ cperl-extra-newline-before-brace\r
+ "*Non-nil means the same as `cperl-extra-newline-before-brace', but\r
+for constructs with multiline if/unless/while/until/for/foreach condition."\r
+ :type 'boolean\r
+ :group 'cperl-autoinsert-details)\r
+\r
+(defcustom cperl-indent-level 2\r
+ "*Indentation of CPerl statements with respect to containing block."\r
+ :type 'integer\r
+ :group 'cperl-indentation-details)\r
+\r
+(defcustom cperl-lineup-step nil\r
+ "*`cperl-lineup' will always lineup at multiple of this number.\r
+If nil, the value of `cperl-indent-level' will be used."\r
+ :type '(choice (const nil) integer)\r
+ :group 'cperl-indentation-details)\r
+\r
+(defcustom cperl-brace-imaginary-offset 0\r
+ "*Imagined indentation of a Perl open brace that actually follows a statement.\r
+An open brace following other text is treated as if it were this far\r
+to the right of the start of its line."\r
+ :type 'integer\r
+ :group 'cperl-indentation-details)\r
+\r
+(defcustom cperl-brace-offset 0\r
+ "*Extra indentation for braces, compared with other text in same context."\r
+ :type 'integer\r
+ :group 'cperl-indentation-details)\r
+(defcustom cperl-label-offset -2\r
+ "*Offset of CPerl label lines relative to usual indentation."\r
+ :type 'integer\r
+ :group 'cperl-indentation-details)\r
+(defcustom cperl-min-label-indent 1\r
+ "*Minimal offset of CPerl label lines."\r
+ :type 'integer\r
+ :group 'cperl-indentation-details)\r
+(defcustom cperl-continued-statement-offset 2\r
+ "*Extra indent for lines not starting new statements."\r
+ :type 'integer\r
+ :group 'cperl-indentation-details)\r
+(defcustom cperl-continued-brace-offset 0\r
+ "*Extra indent for substatements that start with open-braces.\r
+This is in addition to cperl-continued-statement-offset."\r
+ :type 'integer\r
+ :group 'cperl-indentation-details)\r
+(defcustom cperl-close-paren-offset -1\r
+ "*Extra indent for substatements that start with close-parenthesis."\r
+ :type 'integer\r
+ :group 'cperl-indentation-details)\r
+\r
+(defcustom cperl-auto-newline nil\r
+ "*Non-nil means automatically newline before and after braces,\r
+and after colons and semicolons, inserted in CPerl code. The following\r
+\\[cperl-electric-backspace] will remove the inserted whitespace.\r
+Insertion after colons requires both this variable and\r
+`cperl-auto-newline-after-colon' set."\r
+ :type 'boolean\r
+ :group 'cperl-autoinsert-details)\r
+\r
+(defcustom cperl-autoindent-on-semi nil\r
+ "*Non-nil means automatically indent after insertion of (semi)colon.\r
+Active if `cperl-auto-newline' is false."\r
+ :type 'boolean\r
+ :group 'cperl-autoinsert-details)\r
+\r
+(defcustom cperl-auto-newline-after-colon nil\r
+ "*Non-nil means automatically newline even after colons.\r
+Subject to `cperl-auto-newline' setting."\r
+ :type 'boolean\r
+ :group 'cperl-autoinsert-details)\r
+\r
+(defcustom cperl-tab-always-indent t\r
+ "*Non-nil means TAB in CPerl mode should always reindent the current line,\r
+regardless of where in the line point is when the TAB command is used."\r
+ :type 'boolean\r
+ :group 'cperl-indentation-details)\r
+\r
+(defcustom cperl-font-lock nil\r
+ "*Non-nil (and non-null) means CPerl buffers will use `font-lock-mode'.\r
+Can be overwritten by `cperl-hairy' if nil."\r
+ :type '(choice (const null) boolean)\r
+ :group 'cperl-affected-by-hairy)\r
+\r
+(defcustom cperl-electric-lbrace-space nil\r
+ "*Non-nil (and non-null) means { after $ should be preceded by ` '.\r
+Can be overwritten by `cperl-hairy' if nil."\r
+ :type '(choice (const null) boolean)\r
+ :group 'cperl-affected-by-hairy)\r
+\r
+(defcustom cperl-electric-parens-string "({[]})<"\r
+ "*String of parentheses that should be electric in CPerl.\r
+Closing ones are electric only if the region is highlighted."\r
+ :type 'string\r
+ :group 'cperl-affected-by-hairy)\r
+\r
+(defcustom cperl-electric-parens nil\r
+ "*Non-nil (and non-null) means parentheses should be electric in CPerl.\r
+Can be overwritten by `cperl-hairy' if nil."\r
+ :type '(choice (const null) boolean)\r
+ :group 'cperl-affected-by-hairy)\r
+\r
+(defvar zmacs-regions) ; Avoid warning\r
+\r
+(defcustom cperl-electric-parens-mark\r
+ (and window-system\r
+ (or (and (boundp 'transient-mark-mode) ; For Emacs\r
+ transient-mark-mode)\r
+ (and (boundp 'zmacs-regions) ; For XEmacs\r
+ zmacs-regions)))\r
+ "*Not-nil means that electric parens look for active mark.\r
+Default is yes if there is visual feedback on mark."\r
+ :type 'boolean\r
+ :group 'cperl-autoinsert-details)\r
+\r
+(defcustom cperl-electric-linefeed nil\r
+ "*If true, LFD should be hairy in CPerl, otherwise C-c LFD is hairy.\r
+In any case these two mean plain and hairy linefeeds together.\r
+Can be overwritten by `cperl-hairy' if nil."\r
+ :type '(choice (const null) boolean)\r
+ :group 'cperl-affected-by-hairy)\r
+\r
+(defcustom cperl-electric-keywords nil\r
+ "*Not-nil (and non-null) means keywords are electric in CPerl.\r
+Can be overwritten by `cperl-hairy' if nil."\r
+ :type '(choice (const null) boolean)\r
+ :group 'cperl-affected-by-hairy)\r
+\r
+(defcustom cperl-electric-backspace-untabify t\r
+ "*Not-nil means electric-backspace will untabify in CPerl."\r
+ :type 'boolean\r
+ :group 'cperl-autoinsert-details)\r
+\r
+(defcustom cperl-hairy nil\r
+ "*Not-nil means most of the bells and whistles are enabled in CPerl.\r
+Affects: `cperl-font-lock', `cperl-electric-lbrace-space',\r
+`cperl-electric-parens', `cperl-electric-linefeed', `cperl-electric-keywords',\r
+`cperl-info-on-command-no-prompt', `cperl-clobber-lisp-bindings',\r
+`cperl-lazy-help-time'."\r
+ :type 'boolean\r
+ :group 'cperl-affected-by-hairy)\r
+\r
+(defcustom cperl-comment-column 32\r
+ "*Column to put comments in CPerl (use \\[cperl-indent] to lineup with code)."\r
+ :type 'integer\r
+ :group 'cperl-indentation-details)\r
+\r
+(defcustom cperl-vc-header-alist '((SCCS "($sccs) = ('%W\%' =~ /(\\d+(\\.\\d+)+)/) ;")\r
+ (RCS "($rcs) = (' $Id\$ ' =~ /(\\d+(\\.\\d+)+)/) ;"))\r
+ "*What to use as `vc-header-alist' in CPerl."\r
+ :type '(repeat (list symbol string))\r
+ :group 'cperl)\r
+\r
+(defcustom cperl-clobber-mode-lists\r
+ (not\r
+ (and\r
+ (boundp 'interpreter-mode-alist)\r
+ (assoc "miniperl" interpreter-mode-alist)\r
+ (assoc "\\.\\([pP][Llm]\\|al\\)$" auto-mode-alist)))\r
+ "*Whether to install us into `interpreter-' and `extension' mode lists."\r
+ :type 'boolean\r
+ :group 'cperl)\r
+\r
+(defcustom cperl-info-on-command-no-prompt nil\r
+ "*Not-nil (and non-null) means not to prompt on C-h f.\r
+The opposite behaviour is always available if prefixed with C-c.\r
+Can be overwritten by `cperl-hairy' if nil."\r
+ :type '(choice (const null) boolean)\r
+ :group 'cperl-affected-by-hairy)\r
+\r
+(defcustom cperl-clobber-lisp-bindings nil\r
+ "*Not-nil (and non-null) means not overwrite C-h f.\r
+The function is available on \\[cperl-info-on-command], \\[cperl-get-help].\r
+Can be overwritten by `cperl-hairy' if nil."\r
+ :type '(choice (const null) boolean)\r
+ :group 'cperl-affected-by-hairy)\r
+\r
+(defcustom cperl-lazy-help-time nil\r
+ "*Not-nil (and non-null) means to show lazy help after given idle time.\r
+Can be overwritten by `cperl-hairy' to be 5 sec if nil."\r
+ :type '(choice (const null) (const nil) integer)\r
+ :group 'cperl-affected-by-hairy)\r
+\r
+(defcustom cperl-pod-face 'font-lock-comment-face\r
+ "*The result of evaluation of this expression is used for POD highlighting."\r
+ :type 'face\r
+ :group 'cperl-faces)\r
+\r
+(defcustom cperl-pod-head-face 'font-lock-variable-name-face\r
+ "*The result of evaluation of this expression is used for POD highlighting.\r
+Font for POD headers."\r
+ :type 'face\r
+ :group 'cperl-faces)\r
+\r
+(defcustom cperl-here-face 'font-lock-string-face\r
+ "*The result of evaluation of this expression is used for here-docs highlighting."\r
+ :type 'face\r
+ :group 'cperl-faces)\r
+\r
+(defcustom cperl-invalid-face ''underline ; later evaluated by `font-lock'\r
+ "*The result of evaluation of this expression highlights trailing whitespace."\r
+ :type 'face\r
+ :group 'cperl-faces)\r
+\r
+(defcustom cperl-pod-here-fontify '(featurep 'font-lock)\r
+ "*Not-nil after evaluation means to highlight POD and here-docs sections."\r
+ :type 'boolean\r
+ :group 'cperl-faces)\r
+\r
+(defcustom cperl-fontify-m-as-s t\r
+ "*Not-nil means highlight 1arg regular expressions operators same as 2arg."\r
+ :type 'boolean\r
+ :group 'cperl-faces)\r
+\r
+(defcustom cperl-highlight-variables-indiscriminately nil\r
+ "*Non-nil means perform additional highlighting on variables.\r
+Currently only changes how scalar variables are highlighted.\r
+Note that that variable is only read at initialization time for\r
+the variable `perl-font-lock-keywords-2', so changing it after you've\r
+entered CPerl mode the first time will have no effect."\r
+ :type 'boolean\r
+ :group 'cperl)\r
+\r
+(defcustom cperl-pod-here-scan t\r
+ "*Not-nil means look for POD and here-docs sections during startup.\r
+You can always make lookup from menu or using \\[cperl-find-pods-heres]."\r
+ :type 'boolean\r
+ :group 'cperl-speed)\r
+\r
+(defcustom cperl-regexp-scan t\r
+ "*Not-nil means make marking of regular expression more thorough.\r
+Effective only with `cperl-pod-here-scan'. Not implemented yet."\r
+ :type 'boolean\r
+ :group 'cperl-speed)\r
+\r
+(defcustom cperl-imenu-addback nil\r
+ "*Not-nil means add backreferences to generated `imenu's.\r
+May require patched `imenu' and `imenu-go'. Obsolete."\r
+ :type 'boolean\r
+ :group 'cperl-help-system)\r
+\r
+(defcustom cperl-max-help-size 66\r
+ "*Non-nil means shrink-wrapping of info-buffer allowed up to these percents."\r
+ :type '(choice integer (const nil))\r
+ :group 'cperl-help-system)\r
+\r
+(defcustom cperl-shrink-wrap-info-frame t\r
+ "*Non-nil means shrink-wrapping of info-buffer-frame allowed."\r
+ :type 'boolean\r
+ :group 'cperl-help-system)\r
+\r
+(defcustom cperl-info-page "perl"\r
+ "*Name of the info page containing perl docs.\r
+Older version of this page was called `perl5', newer `perl'."\r
+ :type 'string\r
+ :group 'cperl-help-system)\r
+\r
+(defcustom cperl-use-syntax-table-text-property\r
+ (boundp 'parse-sexp-lookup-properties)\r
+ "*Non-nil means CPerl sets up and uses `syntax-table' text property."\r
+ :type 'boolean\r
+ :group 'cperl-speed)\r
+\r
+(defcustom cperl-use-syntax-table-text-property-for-tags\r
+ cperl-use-syntax-table-text-property\r
+ "*Non-nil means: set up and use `syntax-table' text property generating TAGS."\r
+ :type 'boolean\r
+ :group 'cperl-speed)\r
+\r
+(defcustom cperl-scan-files-regexp "\\.\\([pP][Llm]\\|xs\\)$"\r
+ "*Regexp to match files to scan when generating TAGS."\r
+ :type 'regexp\r
+ :group 'cperl)\r
+\r
+(defcustom cperl-noscan-files-regexp\r
+ "/\\(\\.\\.?\\|SCCS\\|RCS\\|CVS\\|blib\\)$"\r
+ "*Regexp to match files/dirs to skip when generating TAGS."\r
+ :type 'regexp\r
+ :group 'cperl)\r
+\r
+(defcustom cperl-regexp-indent-step nil\r
+ "*Indentation used when beautifying regexps.\r
+If nil, the value of `cperl-indent-level' will be used."\r
+ :type '(choice integer (const nil))\r
+ :group 'cperl-indentation-details)\r
+\r
+(defcustom cperl-indent-left-aligned-comments t\r
+ "*Non-nil means that the comment starting in leftmost column should indent."\r
+ :type 'boolean\r
+ :group 'cperl-indentation-details)\r
+\r
+(defcustom cperl-under-as-char t\r
+ "*Non-nil means that the _ (underline) should be treated as word char."\r
+ :type 'boolean\r
+ :group 'cperl)\r
+\r
+(defcustom cperl-extra-perl-args ""\r
+ "*Extra arguments to use when starting Perl.\r
+Currently used with `cperl-check-syntax' only."\r
+ :type 'string\r
+ :group 'cperl)\r
+\r
+(defcustom cperl-message-electric-keyword t\r
+ "*Non-nil means that the `cperl-electric-keyword' prints a help message."\r
+ :type 'boolean\r
+ :group 'cperl-help-system)\r
+\r
+(defcustom cperl-indent-region-fix-constructs 1\r
+ "*Amount of space to insert between `}' and `else' or `elsif'\r
+in `cperl-indent-region'. Set to nil to leave as is. Values other\r
+than 1 and nil will probably not work."\r
+ :type '(choice (const nil) (const 1))\r
+ :group 'cperl-indentation-details)\r
+\r
+(defcustom cperl-break-one-line-blocks-when-indent t\r
+ "*Non-nil means that one-line if/unless/while/until/for/foreach BLOCKs\r
+need to be reformatted into multiline ones when indenting a region."\r
+ :type 'boolean\r
+ :group 'cperl-indentation-details)\r
+\r
+(defcustom cperl-fix-hanging-brace-when-indent t\r
+ "*Non-nil means that BLOCK-end `}' may be put on a separate line\r
+when indenting a region.\r
+Braces followed by else/elsif/while/until are excepted."\r
+ :type 'boolean\r
+ :group 'cperl-indentation-details)\r
+\r
+(defcustom cperl-merge-trailing-else t\r
+ "*Non-nil means that BLOCK-end `}' followed by else/elsif/continue\r
+may be merged to be on the same line when indenting a region."\r
+ :type 'boolean\r
+ :group 'cperl-indentation-details)\r
+\r
+(defcustom cperl-indent-parens-as-block nil\r
+ "*Non-nil means that non-block ()-, {}- and []-groups are indented as blocks,\r
+but for trailing \",\" inside the group, which won't increase indentation.\r
+One should tune up `cperl-close-paren-offset' as well."\r
+ :type 'boolean\r
+ :group 'cperl-indentation-details)\r
+\r
+(defcustom cperl-syntaxify-by-font-lock\r
+ (and cperl-can-font-lock\r
+ (boundp 'parse-sexp-lookup-properties))\r
+ "*Non-nil means that CPerl uses `font-lock's routines for syntaxification."\r
+ :type '(choice (const message) boolean)\r
+ :group 'cperl-speed)\r
+\r
+(defcustom cperl-syntaxify-unwind\r
+ t\r
+ "*Non-nil means that CPerl unwinds to a start of a long construction\r
+when syntaxifying a chunk of buffer."\r
+ :type 'boolean\r
+ :group 'cperl-speed)\r
+\r
+(defcustom cperl-ps-print-face-properties\r
+ '((font-lock-keyword-face nil nil bold shadow)\r
+ (font-lock-variable-name-face nil nil bold)\r
+ (font-lock-function-name-face nil nil bold italic box)\r
+ (font-lock-constant-face nil "LightGray" bold)\r
+ (cperl-array-face nil "LightGray" bold underline)\r
+ (cperl-hash-face nil "LightGray" bold italic underline)\r
+ (font-lock-comment-face nil "LightGray" italic)\r
+ (font-lock-string-face nil nil italic underline)\r
+ (cperl-nonoverridable-face nil nil italic underline)\r
+ (font-lock-type-face nil nil underline)\r
+ (underline nil "LightGray" strikeout))\r
+ "List given as an argument to `ps-extend-face-list' in `cperl-ps-print'."\r
+ :type '(repeat (cons symbol\r
+ (cons (choice (const nil) string)\r
+ (cons (choice (const nil) string)\r
+ (repeat symbol)))))\r
+ :group 'cperl-faces)\r
+\r
+(if cperl-can-font-lock\r
+ (progn\r
+ (defvar cperl-dark-background\r
+ (cperl-choose-color "navy" "os2blue" "darkgreen"))\r
+ (defvar cperl-dark-foreground\r
+ (cperl-choose-color "orchid1" "orange"))\r
+\r
+ (defface cperl-nonoverridable-face\r
+ (` ((((class grayscale) (background light))\r
+ (:background "Gray90" :italic t :underline t))\r
+ (((class grayscale) (background dark))\r
+ (:foreground "Gray80" :italic t :underline t :bold t))\r
+ (((class color) (background light))\r
+ (:foreground "chartreuse3"))\r
+ (((class color) (background dark))\r
+ (:foreground (, cperl-dark-foreground)))\r
+ (t (:bold t :underline t))))\r
+ "Font Lock mode face used to highlight array names."\r
+ :group 'cperl-faces)\r
+\r
+ (defface cperl-array-face\r
+ (` ((((class grayscale) (background light))\r
+ (:background "Gray90" :bold t))\r
+ (((class grayscale) (background dark))\r
+ (:foreground "Gray80" :bold t))\r
+ (((class color) (background light))\r
+ (:foreground "Blue" :background "lightyellow2" :bold t))\r
+ (((class color) (background dark))\r
+ (:foreground "yellow" :background (, cperl-dark-background) :bold t))\r
+ (t (:bold t))))\r
+ "Font Lock mode face used to highlight array names."\r
+ :group 'cperl-faces)\r
+\r
+ (defface cperl-hash-face\r
+ (` ((((class grayscale) (background light))\r
+ (:background "Gray90" :bold t :italic t))\r
+ (((class grayscale) (background dark))\r
+ (:foreground "Gray80" :bold t :italic t))\r
+ (((class color) (background light))\r
+ (:foreground "Red" :background "lightyellow2" :bold t :italic t))\r
+ (((class color) (background dark))\r
+ (:foreground "Red" :background (, cperl-dark-background) :bold t :italic t))\r
+ (t (:bold t :italic t))))\r
+ "Font Lock mode face used to highlight hash names."\r
+ :group 'cperl-faces)))\r
+\r
+\f\r
+\r
+;;; Short extra-docs.\r
+\r
+(defvar cperl-tips 'please-ignore-this-line\r
+ "Get maybe newer version of this package from\r
+ ftp://ftp.math.ohio-state.edu/pub/users/ilya/emacs\r
+and/or\r
+ ftp://ftp.math.ohio-state.edu/pub/users/ilya/perl\r
+Subdirectory `cperl-mode' may contain yet newer development releases and/or\r
+patches to related files.\r
+\r
+For best results apply to an older Emacs the patches from\r
+ ftp://ftp.math.ohio-state.edu/pub/users/ilya/cperl-mode/patches\r
+\(this upgrades syntax-parsing abilities of RMS Emaxen v19.34 and \r
+v20.2 up to the level of RMS Emacs v20.3 - a must for a good Perl\r
+mode.) As of beginning of 2003, XEmacs may provide a similar ability.\r
+\r
+Get support packages choose-color.el (or font-lock-extra.el before\r
+19.30), imenu-go.el from the same place. \(Look for other files there\r
+too... ;-). Get a patch for imenu.el in 19.29. Note that for 19.30 and\r
+later you should use choose-color.el *instead* of font-lock-extra.el\r
+\(and you will not get smart highlighting in C :-().\r
+\r
+Note that to enable Compile choices in the menu you need to install\r
+mode-compile.el.\r
+\r
+If your Emacs does not default to `cperl-mode' on Perl files, and you\r
+want it to: put the following into your .emacs file:\r
+\r
+ (autoload 'perl-mode \"cperl-mode\" \"alternate mode for editing Perl programs\" t)\r
+\r
+or\r
+\r
+ (defalias 'perl-mode 'cperl-mode)\r
+\r
+Get perl5-info from\r
+ $CPAN/doc/manual/info/perl-info.tar.gz\r
+older version was on\r
+ http://www.metronet.com:70/9/perlinfo/perl5/manual/perl5-info.tar.gz\r
+\r
+If you use imenu-go, run imenu on perl5-info buffer (you can do it\r
+from Perl menu). If many files are related, generate TAGS files from\r
+Tools/Tags submenu in Perl menu.\r
+\r
+If some class structure is too complicated, use Tools/Hierarchy-view\r
+from Perl menu, or hierarchic view of imenu. The second one uses the\r
+current buffer only, the first one requires generation of TAGS from\r
+Perl/Tools/Tags menu beforehand.\r
+\r
+Run Perl/Tools/Insert-spaces-if-needed to fix your lazy typing.\r
+\r
+Switch auto-help on/off with Perl/Tools/Auto-help.\r
+\r
+Though with contemporary Emaxen CPerl mode should maintain the correct\r
+parsing of Perl even when editing, sometimes it may be lost. Fix this by\r
+\r
+ M-x norm RET\r
+\r
+or\r
+\r
+ \\[normal-mode]\r
+\r
+In cases of more severe confusion sometimes it is helpful to do\r
+\r
+ M-x load-l RET cperl-mode RET\r
+ M-x norm RET\r
+\r
+or\r
+\r
+ \\[load-library] cperl-mode RET\r
+ \\[normal-mode]\r
+\r
+Before reporting (non-)problems look in the problem section of online\r
+micro-docs on what I know about CPerl problems.")\r
+\r
+(defvar cperl-problems 'please-ignore-this-line\r
+ "Description of problems in CPerl mode.\r
+Some faces will not be shown on some versions of Emacs unless you\r
+install choose-color.el, available from\r
+ ftp://ftp.math.ohio-state.edu/pub/users/ilya/emacs/\r
+\r
+`fill-paragraph' on a comment may leave the point behind the\r
+paragraph. Parsing of lines with several <<EOF is not implemented\r
+yet.\r
+\r
+Emacs had a _very_ restricted syntax parsing engine until RMS's Emacs\r
+20.1. Most problems below are corrected starting from this version of\r
+Emacs, and all of them should be fixed in RMS's version 20.3. (Or apply\r
+patches to Emacs 19.33/34 - see tips.) XEmacs was very backward in\r
+this respect (until 2003).\r
+\r
+Note that even with newer Emacsen in some very rare cases the details\r
+of interaction of `font-lock' and syntaxification may be not cleaned\r
+up yet. You may get slightly different colors basing on the order of\r
+fontification and syntaxification. Say, the initial faces is correct,\r
+but editing the buffer breaks this.\r
+\r
+Even with older Emacsen CPerl mode tries to corrects some Emacs\r
+misunderstandings, however, for efficiency reasons the degree of\r
+correction is different for different operations. The partially\r
+corrected problems are: POD sections, here-documents, regexps. The\r
+operations are: highlighting, indentation, electric keywords, electric\r
+braces.\r
+\r
+This may be confusing, since the regexp s#//#/#\; may be highlighted\r
+as a comment, but it will be recognized as a regexp by the indentation\r
+code. Or the opposite case, when a POD section is highlighted, but\r
+may break the indentation of the following code (though indentation\r
+should work if the balance of delimiters is not broken by POD).\r
+\r
+The main trick (to make $ a \"backslash\") makes constructions like\r
+${aaa} look like unbalanced braces. The only trick I can think of is\r
+to insert it as $ {aaa} (legal in perl5, not in perl4).\r
+\r
+Similar problems arise in regexps, when /(\\s|$)/ should be rewritten\r
+as /($|\\s)/. Note that such a transposition is not always possible.\r
+\r
+The solution is to upgrade your Emacs or patch an older one. Note\r
+that RMS's 20.2 has some bugs related to `syntax-table' text\r
+properties. Patches are available on the main CPerl download site,\r
+and on CPAN.\r
+\r
+If these bugs cannot be fixed on your machine (say, you have an inferior\r
+environment and cannot recompile), you may still disable all the fancy stuff\r
+via `cperl-use-syntax-table-text-property'.")\r
+\r
+(defvar cperl-non-problems 'please-ignore-this-line\r
+"As you know from `problems' section, Perl syntax is too hard for CPerl on \r
+older Emacsen. Here is what you can do if you cannot upgrade, or if\r
+you want to switch off these capabilities on RMS Emacs 20.2 (+patches) or 20.3\r
+or better. Please skip this docs if you run a capable Emacs already.\r
+\r
+Most of the time, if you write your own code, you may find an equivalent\r
+\(and almost as readable) expression (what is discussed below is usually\r
+not relevant on newer Emacsen, since they can do it automatically).\r
+\r
+Try to help CPerl: add comments with embedded quotes to fix CPerl\r
+misunderstandings about the end of quotation:\r
+\r
+$a='500$'; # ';\r
+\r
+You won't need it too often. The reason: $ \"quotes\" the following\r
+character (this saves a life a lot of times in CPerl), thus due to\r
+Emacs parsing rules it does not consider tick (i.e., ' ) after a\r
+dollar as a closing one, but as a usual character. This is usually\r
+correct, but not in the above context.\r
+\r
+Even with older Emacsen the indentation code is pretty wise. The only\r
+drawback is that it relied on Emacs parsing to find matching\r
+parentheses. And Emacs *could not* match parentheses in Perl 100%\r
+correctly. So\r
+ 1 if s#//#/#;\r
+would not break indentation, but\r
+ 1 if ( s#//#/# );\r
+would. Upgrade.\r
+\r
+By similar reasons\r
+ s\"abc\"def\";\r
+could confuse CPerl a lot.\r
+\r
+If you still get wrong indentation in situation that you think the\r
+code should be able to parse, try:\r
+\r
+a) Check what Emacs thinks about balance of your parentheses.\r
+b) Supply the code to me (IZ).\r
+\r
+Pods were treated _very_ rudimentally. Here-documents were not\r
+treated at all (except highlighting and inhibiting indentation). Upgrade.\r
+\r
+To speed up coloring the following compromises exist:\r
+ a) sub in $mypackage::sub may be highlighted.\r
+ b) -z in [a-z] may be highlighted.\r
+ c) if your regexp contains a keyword (like \"s\"), it may be highlighted.\r
+\r
+\r
+Imenu in 19.31 is broken. Set `imenu-use-keymap-menu' to t, and remove\r
+`car' before `imenu-choose-buffer-index' in `imenu'.\r
+`imenu-add-to-menubar' in 20.2 is broken. \r
+A lot of things on XEmacs may be broken too, judging by bug reports I\r
+receive. Note that some releases of XEmacs are better than the others\r
+as far as bugs reports I see are concerned.")\r
+\r
+(defvar cperl-praise 'please-ignore-this-line\r
+ "Advantages of CPerl mode.\r
+\r
+0) It uses the newest `syntax-table' property ;-);\r
+\r
+1) It does 99% of Perl syntax correct (as opposed to 80-90% in Perl\r
+mode - but the latter number may have improved too in last years) even\r
+with old Emaxen which do not support `syntax-table' property.\r
+\r
+When using `syntax-table' property for syntax assist hints, it should\r
+handle 99.995% of lines correct - or somesuch. It automatically\r
+updates syntax assist hints when you edit your script.\r
+\r
+2) It is generally believed to be \"the most user-friendly Emacs\r
+package\" whatever it may mean (I doubt that the people who say similar\r
+things tried _all_ the rest of Emacs ;-), but this was not a lonely\r
+voice);\r
+\r
+3) Everything is customizable, one-by-one or in a big sweep;\r
+\r
+4) It has many easily-accessable \"tools\":\r
+ a) Can run program, check syntax, start debugger;\r
+ b) Can lineup vertically \"middles\" of rows, like `=' in\r
+ a = b;\r
+ cc = d;\r
+ c) Can insert spaces where this impoves readability (in one\r
+ interactive sweep over the buffer);\r
+ d) Has support for imenu, including:\r
+ 1) Separate unordered list of \"interesting places\";\r
+ 2) Separate TOC of POD sections;\r
+ 3) Separate list of packages;\r
+ 4) Hierarchical view of methods in (sub)packages;\r
+ 5) and functions (by the full name - with package);\r
+ e) Has an interface to INFO docs for Perl; The interface is\r
+ very flexible, including shrink-wrapping of\r
+ documentation buffer/frame;\r
+ f) Has a builtin list of one-line explanations for perl constructs.\r
+ g) Can show these explanations if you stay long enough at the\r
+ corresponding place (or on demand);\r
+ h) Has an enhanced fontification (using 3 or 4 additional faces\r
+ comparing to font-lock - basically, different\r
+ namespaces in Perl have different colors);\r
+ i) Can construct TAGS basing on its knowledge of Perl syntax,\r
+ the standard menu has 6 different way to generate\r
+ TAGS (if \"by directory\", .xs files - with C-language\r
+ bindings - are included in the scan);\r
+ j) Can build a hierarchical view of classes (via imenu) basing\r
+ on generated TAGS file;\r
+ k) Has electric parentheses, electric newlines, uses Abbrev\r
+ for electric logical constructs\r
+ while () {}\r
+ with different styles of expansion (context sensitive\r
+ to be not so bothering). Electric parentheses behave\r
+ \"as they should\" in a presence of a visible region.\r
+ l) Changes msb.el \"on the fly\" to insert a group \"Perl files\";\r
+ m) Can convert from\r
+ if (A) { B }\r
+ to\r
+ B if A;\r
+\r
+ n) Highlights (by user-choice) either 3-delimiters constructs\r
+ (such as tr/a/b/), or regular expressions and `y/tr';\r
+ o) Highlights trailing whitespace;\r
+ p) Is able to manipulate Perl Regular Expressions to ease\r
+ conversion to a more readable form.\r
+\r
+5) The indentation engine was very smart, but most of tricks may be\r
+not needed anymore with the support for `syntax-table' property. Has\r
+progress indicator for indentation (with `imenu' loaded).\r
+\r
+6) Indent-region improves inline-comments as well; also corrects\r
+whitespace *inside* the conditional/loop constructs.\r
+\r
+7) Fill-paragraph correctly handles multi-line comments;\r
+\r
+8) Can switch to different indentation styles by one command, and restore\r
+the settings present before the switch.\r
+\r
+9) When doing indentation of control constructs, may correct\r
+line-breaks/spacing between elements of the construct.\r
+\r
+10) Uses a linear-time algorith for indentation of regions (on Emaxen with\r
+capable syntax engines).")\r
+\r
+(defvar cperl-speed 'please-ignore-this-line\r
+ "This is an incomplete compendium of what is available in other parts\r
+of CPerl documentation. (Please inform me if I skept anything.)\r
+\r
+There is a perception that CPerl is slower than alternatives. This part\r
+of documentation is designed to overcome this misconception.\r
+\r
+*By default* CPerl tries to enable the most comfortable settings.\r
+From most points of view, correctly working package is infinitely more\r
+comfortable than a non-correctly working one, thus by default CPerl\r
+prefers correctness over speed. Below is the guide how to change\r
+settings if your preferences are different.\r
+\r
+A) Speed of loading the file. When loading file, CPerl may perform a\r
+scan which indicates places which cannot be parsed by primitive Emacs\r
+syntax-parsing routines, and marks them up so that either\r
+\r
+ A1) CPerl may work around these deficiencies (for big chunks, mostly\r
+ PODs and HERE-documents), or\r
+ A2) On capable Emaxen CPerl will use improved syntax-handlings\r
+ which reads mark-up hints directly.\r
+\r
+ The scan in case A2 is much more comprehensive, thus may be slower.\r
+\r
+ User can disable syntax-engine-helping scan of A2 by setting\r
+ `cperl-use-syntax-table-text-property'\r
+ variable to nil (if it is set to t).\r
+\r
+ One can disable the scan altogether (both A1 and A2) by setting\r
+ `cperl-pod-here-scan'\r
+ to nil.\r
+\r
+B) Speed of editing operations.\r
+\r
+ One can add a (minor) speedup to editing operations by setting\r
+ `cperl-use-syntax-table-text-property'\r
+ variable to nil (if it is set to t). This will disable\r
+ syntax-engine-helping scan, thus will make many more Perl\r
+ constructs be wrongly recognized by CPerl, thus may lead to\r
+ wrongly matched parentheses, wrong indentation, etc.\r
+\r
+ One can unset `cperl-syntaxify-unwind'. This might speed up editing\r
+ of, say, long POD sections.")\r
+\r
+(defvar cperl-tips-faces 'please-ignore-this-line\r
+ "CPerl mode uses following faces for highlighting:\r
+\r
+ `cperl-array-face' Array names\r
+ `cperl-hash-face' Hash names\r
+ `font-lock-comment-face' Comments, PODs and whatever is considered\r
+ syntaxically to be not code\r
+ `font-lock-constant-face' HERE-doc delimiters, labels, delimiters of\r
+ 2-arg operators s/y/tr/ or of RExen,\r
+ `font-lock-function-name-face' Special-cased m// and s//foo/, _ as\r
+ a target of a file tests, file tests,\r
+ subroutine names at the moment of definition\r
+ (except those conflicting with Perl operators),\r
+ package names (when recognized), format names\r
+ `font-lock-keyword-face' Control flow switch constructs, declarators\r
+ `cperl-nonoverridable-face' Non-overridable keywords, modifiers of RExen\r
+ `font-lock-string-face' Strings, qw() constructs, RExen, POD sections,\r
+ literal parts and the terminator of formats\r
+ and whatever is syntaxically considered\r
+ as string literals\r
+ `font-lock-type-face' Overridable keywords\r
+ `font-lock-variable-name-face' Variable declarations, indirect array and\r
+ hash names, POD headers/item names\r
+ `cperl-invalid-face' Trailing whitespace\r
+\r
+Note that in several situations the highlighting tries to inform about\r
+possible confusion, such as different colors for function names in\r
+declarations depending on what they (do not) override, or special cases\r
+m// and s/// which do not do what one would expect them to do.\r
+\r
+Help with best setup of these faces for printout requested (for each of\r
+the faces: please specify bold, italic, underline, shadow and box.)\r
+\r
+\(Not finished.)")\r
+\r
+\f\r
+\r
+;;; Portability stuff:\r
+\r
+(defmacro cperl-define-key (emacs-key definition &optional xemacs-key)\r
+ (` (define-key cperl-mode-map\r
+ (, (if xemacs-key\r
+ (` (if cperl-xemacs-p (, xemacs-key) (, emacs-key)))\r
+ emacs-key))\r
+ (, definition))))\r
+\r
+(defvar cperl-del-back-ch\r
+ (car (append (where-is-internal 'delete-backward-char)\r
+ (where-is-internal 'backward-delete-char-untabify)))\r
+ "Character generated by key bound to `delete-backward-char'.")\r
+\r
+(and (vectorp cperl-del-back-ch) (= (length cperl-del-back-ch) 1)\r
+ (setq cperl-del-back-ch (aref cperl-del-back-ch 0)))\r
+\r
+(defun cperl-mark-active () (mark)) ; Avoid undefined warning\r
+(if cperl-xemacs-p\r
+ (progn\r
+ ;; "Active regions" are on: use region only if active\r
+ ;; "Active regions" are off: use region unconditionally\r
+ (defun cperl-use-region-p ()\r
+ (if zmacs-regions (mark) t)))\r
+ (defun cperl-use-region-p ()\r
+ (if transient-mark-mode mark-active t))\r
+ (defun cperl-mark-active () mark-active))\r
+\r
+(defsubst cperl-enable-font-lock ()\r
+ cperl-can-font-lock)\r
+\r
+(defun cperl-putback-char (c) ; Emacs 19\r
+ (set 'unread-command-events (list c))) ; Avoid undefined warning\r
+\r
+(if (boundp 'unread-command-events)\r
+ (if cperl-xemacs-p\r
+ (defun cperl-putback-char (c) ; XEmacs >= 19.12\r
+ (setq unread-command-events (list (eval '(character-to-event c))))))\r
+ (defun cperl-putback-char (c) ; XEmacs <= 19.11\r
+ (set 'unread-command-event (eval '(character-to-event c))))) ; Avoid warnings\r
+\r
+(or (fboundp 'uncomment-region)\r
+ (defun uncomment-region (beg end)\r
+ (interactive "r")\r
+ (comment-region beg end -1)))\r
+\r
+(defvar cperl-do-not-fontify\r
+ (if (string< emacs-version "19.30")\r
+ 'fontified\r
+ 'lazy-lock)\r
+ "Text property which inhibits refontification.")\r
+\r
+(defsubst cperl-put-do-not-fontify (from to &optional post)\r
+ ;; If POST, do not do it with postponed fontification\r
+ (if (and post cperl-syntaxify-by-font-lock)\r
+ nil\r
+ (put-text-property (max (point-min) (1- from))\r
+ to cperl-do-not-fontify t)))\r
+\r
+(defcustom cperl-mode-hook nil\r
+ "Hook run by CPerl mode."\r
+ :type 'hook\r
+ :group 'cperl)\r
+\r
+(defvar cperl-syntax-state nil)\r
+(defvar cperl-syntax-done-to nil)\r
+(defvar cperl-emacs-can-parse (> (length (save-excursion\r
+ (parse-partial-sexp (point) (point)))) 9))\r
+\f\r
+;; Make customization possible "in reverse"\r
+(defsubst cperl-val (symbol &optional default hairy)\r
+ (cond\r
+ ((eq (symbol-value symbol) 'null) default)\r
+ (cperl-hairy (or hairy t))\r
+ (t (symbol-value symbol))))\r
+\f\r
+;;; Probably it is too late to set these guys already, but it can help later:\r
+\r
+(and cperl-clobber-mode-lists\r
+ (setq auto-mode-alist\r
+ (append '(("\\.\\([pP][Llm]\\|al\\)$" . perl-mode)) auto-mode-alist ))\r
+ (and (boundp 'interpreter-mode-alist)\r
+ (setq interpreter-mode-alist (append interpreter-mode-alist\r
+ '(("miniperl" . perl-mode))))))\r
+(if (fboundp 'eval-when-compile)\r
+ (eval-when-compile\r
+ (mapcar (lambda (p)\r
+ (condition-case nil\r
+ (require p)\r
+ (error nil)))\r
+ '(imenu easymenu etags timer man info))\r
+ (if (fboundp 'ps-extend-face-list)\r
+ (defmacro cperl-ps-extend-face-list (arg)\r
+ (` (ps-extend-face-list (, arg))))\r
+ (defmacro cperl-ps-extend-face-list (arg)\r
+ (` (error "This version of Emacs has no `ps-extend-face-list'"))))\r
+ ;; Calling `cperl-enable-font-lock' below doesn't compile on XEmacs,\r
+ ;; macros instead of defsubsts don't work on Emacs, so we do the\r
+ ;; expansion manually. Any other suggestions?\r
+ (if cperl-can-font-lock\r
+ (require 'font-lock))\r
+ (require 'cl)))\r
+\r
+(defvar cperl-mode-abbrev-table nil\r
+ "Abbrev table in use in CPerl mode buffers.")\r
+\r
+(add-hook 'edit-var-mode-alist '(perl-mode (regexp . "^cperl-")))\r
+\r
+(defvar cperl-mode-map () "Keymap used in CPerl mode.")\r
+\r
+(if cperl-mode-map nil\r
+ (setq cperl-mode-map (make-sparse-keymap))\r
+ (cperl-define-key "{" 'cperl-electric-lbrace)\r
+ (cperl-define-key "[" 'cperl-electric-paren)\r
+ (cperl-define-key "(" 'cperl-electric-paren)\r
+ (cperl-define-key "<" 'cperl-electric-paren)\r
+ (cperl-define-key "}" 'cperl-electric-brace)\r
+ (cperl-define-key "]" 'cperl-electric-rparen)\r
+ (cperl-define-key ")" 'cperl-electric-rparen)\r
+ (cperl-define-key ";" 'cperl-electric-semi)\r
+ (cperl-define-key ":" 'cperl-electric-terminator)\r
+ (cperl-define-key "\C-j" 'newline-and-indent)\r
+ (cperl-define-key "\C-c\C-j" 'cperl-linefeed)\r
+ (cperl-define-key "\C-c\C-t" 'cperl-invert-if-unless)\r
+ (cperl-define-key "\C-c\C-a" 'cperl-toggle-auto-newline)\r
+ (cperl-define-key "\C-c\C-k" 'cperl-toggle-abbrev)\r
+ (cperl-define-key "\C-c\C-w" 'cperl-toggle-construct-fix)\r
+ (cperl-define-key "\C-c\C-f" 'auto-fill-mode)\r
+ (cperl-define-key "\C-c\C-e" 'cperl-toggle-electric)\r
+ (cperl-define-key "\C-c\C-ha" 'cperl-toggle-autohelp)\r
+ (cperl-define-key "\e\C-q" 'cperl-indent-exp) ; Usually not bound\r
+ (cperl-define-key [?\C-\M-\|] 'cperl-lineup\r
+ [(control meta |)])\r
+ ;;(cperl-define-key "\M-q" 'cperl-fill-paragraph)\r
+ ;;(cperl-define-key "\e;" 'cperl-indent-for-comment)\r
+ (cperl-define-key "\177" 'cperl-electric-backspace)\r
+ (cperl-define-key "\t" 'cperl-indent-command)\r
+ ;; don't clobber the backspace binding:\r
+ (cperl-define-key "\C-c\C-hF" 'cperl-info-on-command\r
+ [(control c) (control h) F])\r
+ (if (cperl-val 'cperl-clobber-lisp-bindings)\r
+ (progn\r
+ (cperl-define-key "\C-hf"\r
+ ;;(concat (char-to-string help-char) "f") ; does not work\r
+ 'cperl-info-on-command\r
+ [(control h) f])\r
+ (cperl-define-key "\C-hv"\r
+ ;;(concat (char-to-string help-char) "v") ; does not work\r
+ 'cperl-get-help\r
+ [(control h) v])\r
+ (cperl-define-key "\C-c\C-hf"\r
+ ;;(concat (char-to-string help-char) "f") ; does not work\r
+ (key-binding "\C-hf")\r
+ [(control c) (control h) f])\r
+ (cperl-define-key "\C-c\C-hv"\r
+ ;;(concat (char-to-string help-char) "v") ; does not work\r
+ (key-binding "\C-hv")\r
+ [(control c) (control h) v]))\r
+ (cperl-define-key "\C-c\C-hf" 'cperl-info-on-current-command\r
+ [(control c) (control h) f])\r
+ (cperl-define-key "\C-c\C-hv"\r
+ ;;(concat (char-to-string help-char) "v") ; does not work\r
+ 'cperl-get-help\r
+ [(control c) (control h) v]))\r
+ (if (and cperl-xemacs-p\r
+ (<= emacs-minor-version 11) (<= emacs-major-version 19))\r
+ (progn\r
+ ;; substitute-key-definition is usefulness-deenhanced...\r
+ (cperl-define-key "\M-q" 'cperl-fill-paragraph)\r
+ (cperl-define-key "\e;" 'cperl-indent-for-comment)\r
+ (cperl-define-key "\e\C-\\" 'cperl-indent-region))\r
+ (substitute-key-definition\r
+ 'indent-sexp 'cperl-indent-exp\r
+ cperl-mode-map global-map)\r
+ (substitute-key-definition\r
+ 'fill-paragraph 'cperl-fill-paragraph\r
+ cperl-mode-map global-map)\r
+ (substitute-key-definition\r
+ 'indent-region 'cperl-indent-region\r
+ cperl-mode-map global-map)\r
+ (substitute-key-definition\r
+ 'indent-for-comment 'cperl-indent-for-comment\r
+ cperl-mode-map global-map)))\r
+\r
+(defvar cperl-menu)\r
+(defvar cperl-lazy-installed)\r
+(defvar cperl-old-style nil)\r
+(condition-case nil\r
+ (progn\r
+ (require 'easymenu)\r
+ (easy-menu-define\r
+ cperl-menu cperl-mode-map "Menu for CPerl mode"\r
+ '("Perl"\r
+ ["Beginning of function" beginning-of-defun t]\r
+ ["End of function" end-of-defun t]\r
+ ["Mark function" mark-defun t]\r
+ ["Indent expression" cperl-indent-exp t]\r
+ ["Fill paragraph/comment" cperl-fill-paragraph t]\r
+ "----"\r
+ ["Line up a construction" cperl-lineup (cperl-use-region-p)]\r
+ ["Invert if/unless/while etc" cperl-invert-if-unless t]\r
+ ("Regexp"\r
+ ["Beautify" cperl-beautify-regexp\r
+ cperl-use-syntax-table-text-property]\r
+ ["Beautify one level deep" (cperl-beautify-regexp 1)\r
+ cperl-use-syntax-table-text-property]\r
+ ["Beautify a group" cperl-beautify-level\r
+ cperl-use-syntax-table-text-property]\r
+ ["Beautify a group one level deep" (cperl-beautify-level 1)\r
+ cperl-use-syntax-table-text-property]\r
+ ["Contract a group" cperl-contract-level\r
+ cperl-use-syntax-table-text-property]\r
+ ["Contract groups" cperl-contract-levels\r
+ cperl-use-syntax-table-text-property])\r
+ ["Refresh \"hard\" constructions" cperl-find-pods-heres t]\r
+ "----"\r
+ ["Indent region" cperl-indent-region (cperl-use-region-p)]\r
+ ["Comment region" cperl-comment-region (cperl-use-region-p)]\r
+ ["Uncomment region" cperl-uncomment-region (cperl-use-region-p)]\r
+ "----"\r
+ ["Run" mode-compile (fboundp 'mode-compile)]\r
+ ["Kill" mode-compile-kill (and (fboundp 'mode-compile-kill)\r
+ (get-buffer "*compilation*"))]\r
+ ["Next error" next-error (get-buffer "*compilation*")]\r
+ ["Check syntax" cperl-check-syntax (fboundp 'mode-compile)]\r
+ "----"\r
+ ["Debugger" cperl-db t]\r
+ "----"\r
+ ("Tools"\r
+ ["Imenu" imenu (fboundp 'imenu)]\r
+ ["Insert spaces if needed" cperl-find-bad-style t]\r
+ ["Class Hierarchy from TAGS" cperl-tags-hier-init t]\r
+ ;;["Update classes" (cperl-tags-hier-init t) tags-table-list]\r
+ ["CPerl pretty print (exprmntl)" cperl-ps-print \r
+ (fboundp 'ps-extend-face-list)]\r
+ ["Imenu on info" cperl-imenu-on-info (featurep 'imenu)]\r
+ ("Tags"\r
+;;; ["Create tags for current file" cperl-etags t]\r
+;;; ["Add tags for current file" (cperl-etags t) t]\r
+;;; ["Create tags for Perl files in directory" (cperl-etags nil t) t]\r
+;;; ["Add tags for Perl files in directory" (cperl-etags t t) t]\r
+;;; ["Create tags for Perl files in (sub)directories"\r
+;;; (cperl-etags nil 'recursive) t]\r
+;;; ["Add tags for Perl files in (sub)directories"\r
+;;; (cperl-etags t 'recursive) t])\r
+;;;; cperl-write-tags (&optional file erase recurse dir inbuffer)\r
+ ["Create tags for current file" (cperl-write-tags nil t) t]\r
+ ["Add tags for current file" (cperl-write-tags) t]\r
+ ["Create tags for Perl files in directory"\r
+ (cperl-write-tags nil t nil t) t]\r
+ ["Add tags for Perl files in directory"\r
+ (cperl-write-tags nil nil nil t) t]\r
+ ["Create tags for Perl files in (sub)directories"\r
+ (cperl-write-tags nil t t t) t]\r
+ ["Add tags for Perl files in (sub)directories"\r
+ (cperl-write-tags nil nil t t) t]))\r
+ ("Perl docs"\r
+ ["Define word at point" imenu-go-find-at-position \r
+ (fboundp 'imenu-go-find-at-position)]\r
+ ["Help on function" cperl-info-on-command t]\r
+ ["Help on function at point" cperl-info-on-current-command t]\r
+ ["Help on symbol at point" cperl-get-help t]\r
+ ["Perldoc" cperl-perldoc t]\r
+ ["Perldoc on word at point" cperl-perldoc-at-point t]\r
+ ["View manpage of POD in this file" cperl-build-manpage t]\r
+ ["Auto-help on" cperl-lazy-install \r
+ (and (fboundp 'run-with-idle-timer)\r
+ (not cperl-lazy-installed))]\r
+ ["Auto-help off" cperl-lazy-unstall\r
+ (and (fboundp 'run-with-idle-timer)\r
+ cperl-lazy-installed)])\r
+ ("Toggle..."\r
+ ["Auto newline" cperl-toggle-auto-newline t]\r
+ ["Electric parens" cperl-toggle-electric t]\r
+ ["Electric keywords" cperl-toggle-abbrev t]\r
+ ["Fix whitespace on indent" cperl-toggle-construct-fix t]\r
+ ["Auto-help on Perl constructs" cperl-toggle-autohelp t]\r
+ ["Auto fill" auto-fill-mode t]) \r
+ ("Indent styles..."\r
+ ["CPerl" (cperl-set-style "CPerl") t]\r
+ ["PerlStyle" (cperl-set-style "PerlStyle") t]\r
+ ["GNU" (cperl-set-style "GNU") t]\r
+ ["C++" (cperl-set-style "C++") t]\r
+ ["FSF" (cperl-set-style "FSF") t]\r
+ ["BSD" (cperl-set-style "BSD") t]\r
+ ["Whitesmith" (cperl-set-style "Whitesmith") t]\r
+ ["Current" (cperl-set-style "Current") t]\r
+ ["Memorized" (cperl-set-style-back) cperl-old-style])\r
+ ("Micro-docs"\r
+ ["Tips" (describe-variable 'cperl-tips) t]\r
+ ["Problems" (describe-variable 'cperl-problems) t]\r
+ ["Non-problems" (describe-variable 'cperl-non-problems) t]\r
+ ["Speed" (describe-variable 'cperl-speed) t]\r
+ ["Praise" (describe-variable 'cperl-praise) t]\r
+ ["Faces" (describe-variable 'cperl-tips-faces) t]\r
+ ["CPerl mode" (describe-function 'cperl-mode) t]\r
+ ["CPerl version" \r
+ (message "The version of master-file for this CPerl is %s" \r
+ cperl-version) t]))))\r
+ (error nil))\r
+\r
+(autoload 'c-macro-expand "cmacexp"\r
+ "Display the result of expanding all C macros occurring in the region.\r
+The expansion is entirely correct because it uses the C preprocessor."\r
+ t)\r
+\r
+(defvar cperl-imenu--function-name-regexp-perl\r
+ (concat\r
+ "^\\("\r
+ "[ \t]*\\(sub\\|package\\)[ \t\n]+\\([a-zA-Z_0-9:']+\\)[ \t]*\\(([^()]*)[ \t]*\\)?"\r
+ "\\|"\r
+ "=head\\([12]\\)[ \t]+\\([^\n]+\\)$"\r
+ "\\)"))\r
+\r
+(defvar cperl-outline-regexp\r
+ (concat cperl-imenu--function-name-regexp-perl "\\|" "\\`"))\r
+\r
+(defvar cperl-mode-syntax-table nil\r
+ "Syntax table in use in CPerl mode buffers.")\r
+\r
+(defvar cperl-string-syntax-table nil\r
+ "Syntax table in use in CPerl mode string-like chunks.")\r
+\r
+(if cperl-mode-syntax-table\r
+ ()\r
+ (setq cperl-mode-syntax-table (make-syntax-table))\r
+ (modify-syntax-entry ?\\ "\\" cperl-mode-syntax-table)\r
+ (modify-syntax-entry ?/ "." cperl-mode-syntax-table)\r
+ (modify-syntax-entry ?* "." cperl-mode-syntax-table)\r
+ (modify-syntax-entry ?+ "." cperl-mode-syntax-table)\r
+ (modify-syntax-entry ?- "." cperl-mode-syntax-table)\r
+ (modify-syntax-entry ?= "." cperl-mode-syntax-table)\r
+ (modify-syntax-entry ?% "." cperl-mode-syntax-table)\r
+ (modify-syntax-entry ?< "." cperl-mode-syntax-table)\r
+ (modify-syntax-entry ?> "." cperl-mode-syntax-table)\r
+ (modify-syntax-entry ?& "." cperl-mode-syntax-table)\r
+ (modify-syntax-entry ?$ "\\" cperl-mode-syntax-table)\r
+ (modify-syntax-entry ?\n ">" cperl-mode-syntax-table)\r
+ (modify-syntax-entry ?# "<" cperl-mode-syntax-table)\r
+ (modify-syntax-entry ?' "\"" cperl-mode-syntax-table)\r
+ (modify-syntax-entry ?` "\"" cperl-mode-syntax-table)\r
+ (if cperl-under-as-char\r
+ (modify-syntax-entry ?_ "w" cperl-mode-syntax-table))\r
+ (modify-syntax-entry ?: "_" cperl-mode-syntax-table)\r
+ (modify-syntax-entry ?| "." cperl-mode-syntax-table)\r
+ (setq cperl-string-syntax-table (copy-syntax-table cperl-mode-syntax-table))\r
+ (modify-syntax-entry ?$ "." cperl-string-syntax-table)\r
+ (modify-syntax-entry ?# "." cperl-string-syntax-table)) ; (?# comment )\r
+\r
+\r
+\f\r
+;; provide an alias for working with emacs 19. the perl-mode that comes\r
+;; with it is really bad, and this lets us seamlessly replace it.\r
+;;;###autoload\r
+(fset 'perl-mode 'cperl-mode)\r
+(defvar cperl-faces-init nil)\r
+;; Fix for msb.el\r
+(defvar cperl-msb-fixed nil)\r
+(defvar font-lock-syntactic-keywords)\r
+(defvar perl-font-lock-keywords)\r
+(defvar perl-font-lock-keywords-1)\r
+(defvar perl-font-lock-keywords-2)\r
+(defvar outline-level)\r
+(if (fboundp 'defvaralias)\r
+ (let ((f 'defvaralias)) ; Some functions deduce stuff from the mode name...\r
+ (funcall f 'cperl-font-lock-keywords 'perl-font-lock-keywords)\r
+ (funcall f 'cperl-font-lock-keywords-1 'perl-font-lock-keywords-1)\r
+ (funcall f 'cperl-font-lock-keywords-2 'perl-font-lock-keywords-2)))\r
+\r
+(defvar cperl-use-major-mode 'perl-mode)\r
+\r
+;;;###autoload\r
+(defun cperl-mode ()\r
+ "Major mode for editing Perl code.\r
+Expression and list commands understand all C brackets.\r
+Tab indents for Perl code.\r
+Paragraphs are separated by blank lines only.\r
+Delete converts tabs to spaces as it moves back.\r
+\r
+Various characters in Perl almost always come in pairs: {}, (), [],\r
+sometimes <>. When the user types the first, she gets the second as\r
+well, with optional special formatting done on {}. (Disabled by\r
+default.) You can always quote (with \\[quoted-insert]) the left\r
+\"paren\" to avoid the expansion. The processing of < is special,\r
+since most the time you mean \"less\". CPerl mode tries to guess\r
+whether you want to type pair <>, and inserts is if it\r
+appropriate. You can set `cperl-electric-parens-string' to the string that\r
+contains the parenths from the above list you want to be electrical.\r
+Electricity of parenths is controlled by `cperl-electric-parens'.\r
+You may also set `cperl-electric-parens-mark' to have electric parens\r
+look for active mark and \"embrace\" a region if possible.'\r
+\r
+CPerl mode provides expansion of the Perl control constructs:\r
+\r
+ if, else, elsif, unless, while, until, continue, do,\r
+ for, foreach, formy and foreachmy.\r
+\r
+and POD directives (Disabled by default, see `cperl-electric-keywords'.)\r
+\r
+The user types the keyword immediately followed by a space, which\r
+causes the construct to be expanded, and the point is positioned where\r
+she is most likely to want to be. eg. when the user types a space\r
+following \"if\" the following appears in the buffer: if () { or if ()\r
+} { } and the cursor is between the parentheses. The user can then\r
+type some boolean expression within the parens. Having done that,\r
+typing \\[cperl-linefeed] places you - appropriately indented - on a\r
+new line between the braces (if you typed \\[cperl-linefeed] in a POD\r
+directive line, then appropriate number of new lines is inserted).\r
+\r
+If CPerl decides that you want to insert \"English\" style construct like\r
+\r
+ bite if angry;\r
+\r
+it will not do any expansion. See also help on variable\r
+`cperl-extra-newline-before-brace'. (Note that one can switch the\r
+help message on expansion by setting `cperl-message-electric-keyword'\r
+to nil.)\r
+\r
+\\[cperl-linefeed] is a convenience replacement for typing carriage\r
+return. It places you in the next line with proper indentation, or if\r
+you type it inside the inline block of control construct, like\r
+\r
+ foreach (@lines) {print; print}\r
+\r
+and you are on a boundary of a statement inside braces, it will\r
+transform the construct into a multiline and will place you into an\r
+appropriately indented blank line. If you need a usual\r
+`newline-and-indent' behaviour, it is on \\[newline-and-indent],\r
+see documentation on `cperl-electric-linefeed'.\r
+\r
+Use \\[cperl-invert-if-unless] to change a construction of the form\r
+\r
+ if (A) { B }\r
+\r
+into\r
+\r
+ B if A;\r
+\r
+\\{cperl-mode-map}\r
+\r
+Setting the variable `cperl-font-lock' to t switches on font-lock-mode\r
+\(even with older Emacsen), `cperl-electric-lbrace-space' to t switches\r
+on electric space between $ and {, `cperl-electric-parens-string' is\r
+the string that contains parentheses that should be electric in CPerl\r
+\(see also `cperl-electric-parens-mark' and `cperl-electric-parens'),\r
+setting `cperl-electric-keywords' enables electric expansion of\r
+control structures in CPerl. `cperl-electric-linefeed' governs which\r
+one of two linefeed behavior is preferable. You can enable all these\r
+options simultaneously (recommended mode of use) by setting\r
+`cperl-hairy' to t. In this case you can switch separate options off\r
+by setting them to `null'. Note that one may undo the extra\r
+whitespace inserted by semis and braces in `auto-newline'-mode by\r
+consequent \\[cperl-electric-backspace].\r
+\r
+If your site has perl5 documentation in info format, you can use commands\r
+\\[cperl-info-on-current-command] and \\[cperl-info-on-command] to access it.\r
+These keys run commands `cperl-info-on-current-command' and\r
+`cperl-info-on-command', which one is which is controlled by variable\r
+`cperl-info-on-command-no-prompt' and `cperl-clobber-lisp-bindings'\r
+\(in turn affected by `cperl-hairy').\r
+\r
+Even if you have no info-format documentation, short one-liner-style\r
+help is available on \\[cperl-get-help], and one can run perldoc or\r
+man via menu.\r
+\r
+It is possible to show this help automatically after some idle time.\r
+This is regulated by variable `cperl-lazy-help-time'. Default with\r
+`cperl-hairy' (if the value of `cperl-lazy-help-time' is nil) is 5\r
+secs idle time . It is also possible to switch this on/off from the\r
+menu, or via \\[cperl-toggle-autohelp]. Requires `run-with-idle-timer'.\r
+\r
+Use \\[cperl-lineup] to vertically lineup some construction - put the\r
+beginning of the region at the start of construction, and make region\r
+span the needed amount of lines.\r
+\r
+Variables `cperl-pod-here-scan', `cperl-pod-here-fontify',\r
+`cperl-pod-face', `cperl-pod-head-face' control processing of POD and\r
+here-docs sections. With capable Emaxen results of scan are used\r
+for indentation too, otherwise they are used for highlighting only.\r
+\r
+Variables controlling indentation style:\r
+ `cperl-tab-always-indent'\r
+ Non-nil means TAB in CPerl mode should always reindent the current line,\r
+ regardless of where in the line point is when the TAB command is used.\r
+ `cperl-indent-left-aligned-comments'\r
+ Non-nil means that the comment starting in leftmost column should indent.\r
+ `cperl-auto-newline'\r
+ Non-nil means automatically newline before and after braces,\r
+ and after colons and semicolons, inserted in Perl code. The following\r
+ \\[cperl-electric-backspace] will remove the inserted whitespace.\r
+ Insertion after colons requires both this variable and\r
+ `cperl-auto-newline-after-colon' set.\r
+ `cperl-auto-newline-after-colon'\r
+ Non-nil means automatically newline even after colons.\r
+ Subject to `cperl-auto-newline' setting.\r
+ `cperl-indent-level'\r
+ Indentation of Perl statements within surrounding block.\r
+ The surrounding block's indentation is the indentation\r
+ of the line on which the open-brace appears.\r
+ `cperl-continued-statement-offset'\r
+ Extra indentation given to a substatement, such as the\r
+ then-clause of an if, or body of a while, or just a statement continuation.\r
+ `cperl-continued-brace-offset'\r
+ Extra indentation given to a brace that starts a substatement.\r
+ This is in addition to `cperl-continued-statement-offset'.\r
+ `cperl-brace-offset'\r
+ Extra indentation for line if it starts with an open brace.\r
+ `cperl-brace-imaginary-offset'\r
+ An open brace following other text is treated as if it the line started\r
+ this far to the right of the actual line indentation.\r
+ `cperl-label-offset'\r
+ Extra indentation for line that is a label.\r
+ `cperl-min-label-indent'\r
+ Minimal indentation for line that is a label.\r
+\r
+Settings for K&R and BSD indentation styles are\r
+ `cperl-indent-level' 5 8\r
+ `cperl-continued-statement-offset' 5 8\r
+ `cperl-brace-offset' -5 -8\r
+ `cperl-label-offset' -5 -8\r
+\r
+CPerl knows several indentation styles, and may bulk set the\r
+corresponding variables. Use \\[cperl-set-style] to do this. Use\r
+\\[cperl-set-style-back] to restore the memorized preexisting values\r
+\(both available from menu).\r
+\r
+If `cperl-indent-level' is 0, the statement after opening brace in\r
+column 0 is indented on\r
+`cperl-brace-offset'+`cperl-continued-statement-offset'.\r
+\r
+Turning on CPerl mode calls the hooks in the variable `cperl-mode-hook'\r
+with no args.\r
+\r
+DO NOT FORGET to read micro-docs (available from `Perl' menu)\r
+or as help on variables `cperl-tips', `cperl-problems',\r
+`cperl-non-problems', `cperl-praise', `cperl-speed'."\r
+ (interactive)\r
+ (kill-all-local-variables)\r
+ (use-local-map cperl-mode-map)\r
+ (if (cperl-val 'cperl-electric-linefeed)\r
+ (progn\r
+ (local-set-key "\C-J" 'cperl-linefeed)\r
+ (local-set-key "\C-C\C-J" 'newline-and-indent)))\r
+ (if (and\r
+ (cperl-val 'cperl-clobber-lisp-bindings)\r
+ (cperl-val 'cperl-info-on-command-no-prompt))\r
+ (progn\r
+ ;; don't clobber the backspace binding:\r
+ (cperl-define-key "\C-hf" 'cperl-info-on-current-command [(control h) f])\r
+ (cperl-define-key "\C-c\C-hf" 'cperl-info-on-command\r
+ [(control c) (control h) f])))\r
+ (setq major-mode cperl-use-major-mode)\r
+ (setq mode-name "CPerl")\r
+ (if (not cperl-mode-abbrev-table)\r
+ (let ((prev-a-c abbrevs-changed))\r
+ (define-abbrev-table 'cperl-mode-abbrev-table '(\r
+ ("if" "if" cperl-electric-keyword 0)\r
+ ("elsif" "elsif" cperl-electric-keyword 0)\r
+ ("while" "while" cperl-electric-keyword 0)\r
+ ("until" "until" cperl-electric-keyword 0)\r
+ ("unless" "unless" cperl-electric-keyword 0)\r
+ ("else" "else" cperl-electric-else 0)\r
+ ("continue" "continue" cperl-electric-else 0)\r
+ ("for" "for" cperl-electric-keyword 0)\r
+ ("foreach" "foreach" cperl-electric-keyword 0)\r
+ ("formy" "formy" cperl-electric-keyword 0)\r
+ ("foreachmy" "foreachmy" cperl-electric-keyword 0)\r
+ ("do" "do" cperl-electric-keyword 0)\r
+ ("=pod" "=pod" cperl-electric-pod 0)\r
+ ("=over" "=over" cperl-electric-pod 0)\r
+ ("=head1" "=head1" cperl-electric-pod 0)\r
+ ("=head2" "=head2" cperl-electric-pod 0)\r
+ ("pod" "pod" cperl-electric-pod 0)\r
+ ("over" "over" cperl-electric-pod 0)\r
+ ("head1" "head1" cperl-electric-pod 0)\r
+ ("head2" "head2" cperl-electric-pod 0)))\r
+ (setq abbrevs-changed prev-a-c)))\r
+ (setq local-abbrev-table cperl-mode-abbrev-table)\r
+ (abbrev-mode (if (cperl-val 'cperl-electric-keywords) 1 0))\r
+ (set-syntax-table cperl-mode-syntax-table)\r
+ (make-local-variable 'outline-regexp)\r
+ ;; (setq outline-regexp imenu-example--function-name-regexp-perl)\r
+ (setq outline-regexp cperl-outline-regexp)\r
+ (make-local-variable 'outline-level)\r
+ (setq outline-level 'cperl-outline-level)\r
+ (make-local-variable 'paragraph-start)\r
+ (setq paragraph-start (concat "^$\\|" page-delimiter))\r
+ (make-local-variable 'paragraph-separate)\r
+ (setq paragraph-separate paragraph-start)\r
+ (make-local-variable 'paragraph-ignore-fill-prefix)\r
+ (setq paragraph-ignore-fill-prefix t)\r
+ (make-local-variable 'indent-line-function)\r
+ (setq indent-line-function 'cperl-indent-line)\r
+ (make-local-variable 'require-final-newline)\r
+ (setq require-final-newline t)\r
+ (make-local-variable 'comment-start)\r
+ (setq comment-start "# ")\r
+ (make-local-variable 'comment-end)\r
+ (setq comment-end "")\r
+ (make-local-variable 'comment-column)\r
+ (setq comment-column cperl-comment-column)\r
+ (make-local-variable 'comment-start-skip)\r
+ (setq comment-start-skip "#+ *")\r
+ (make-local-variable 'defun-prompt-regexp)\r
+ (setq defun-prompt-regexp "^[ \t]*sub[ \t]+\\([^ \t\n{(;]+\\)\\([ \t]*([^()]*)[ \t]*\\)?[ \t]*")\r
+ (make-local-variable 'comment-indent-function)\r
+ (setq comment-indent-function 'cperl-comment-indent)\r
+ (make-local-variable 'parse-sexp-ignore-comments)\r
+ (setq parse-sexp-ignore-comments t)\r
+ (make-local-variable 'indent-region-function)\r
+ (setq indent-region-function 'cperl-indent-region)\r
+ ;;(setq auto-fill-function 'cperl-do-auto-fill) ; Need to switch on and off!\r
+ (make-local-variable 'imenu-create-index-function)\r
+ (setq imenu-create-index-function\r
+ (function cperl-imenu--create-perl-index))\r
+ (make-local-variable 'imenu-sort-function)\r
+ (setq imenu-sort-function nil)\r
+ (make-local-variable 'vc-header-alist)\r
+ (set 'vc-header-alist cperl-vc-header-alist) ; Avoid warning\r
+ (make-local-variable 'font-lock-defaults)\r
+ (setq font-lock-defaults\r
+ (cond\r
+ ((string< emacs-version "19.30")\r
+ '(perl-font-lock-keywords-2))\r
+ ((string< emacs-version "19.33") ; Which one to use?\r
+ '((perl-font-lock-keywords\r
+ perl-font-lock-keywords-1\r
+ perl-font-lock-keywords-2)))\r
+ (t\r
+ '((cperl-load-font-lock-keywords\r
+ cperl-load-font-lock-keywords-1\r
+ cperl-load-font-lock-keywords-2)))))\r
+ (make-local-variable 'cperl-syntax-state)\r
+ (if cperl-use-syntax-table-text-property\r
+ (progn\r
+ (make-local-variable 'parse-sexp-lookup-properties)\r
+ ;; Do not introduce variable if not needed, we check it!\r
+ (set 'parse-sexp-lookup-properties t)\r
+ ;; Fix broken font-lock:\r
+ (or (boundp 'font-lock-unfontify-region-function)\r
+ (set 'font-lock-unfontify-region-function\r
+ 'font-lock-default-unfontify-region))\r
+ (make-local-variable 'font-lock-unfontify-region-function)\r
+ (set 'font-lock-unfontify-region-function ; not present with old Emacs\r
+ 'cperl-font-lock-unfontify-region-function)\r
+ (make-local-variable 'cperl-syntax-done-to)\r
+ ;; Another bug: unless font-lock-syntactic-keywords, font-lock\r
+ ;; ignores syntax-table text-property. (t) is a hack\r
+ ;; to make font-lock think that font-lock-syntactic-keywords\r
+ ;; are defined\r
+ (make-local-variable 'font-lock-syntactic-keywords)\r
+ (setq font-lock-syntactic-keywords\r
+ (if cperl-syntaxify-by-font-lock\r
+ '(t (cperl-fontify-syntaxically))\r
+ '(t)))))\r
+ (make-local-variable 'cperl-old-style)\r
+ (if (boundp 'normal-auto-fill-function) ; 19.33 and later\r
+ (set (make-local-variable 'normal-auto-fill-function)\r
+ 'cperl-do-auto-fill) ; RMS has it as #'cperl-do-auto-fill ???\r
+ (or (fboundp 'cperl-old-auto-fill-mode)\r
+ (progn\r
+ (fset 'cperl-old-auto-fill-mode (symbol-function 'auto-fill-mode))\r
+ (defun auto-fill-mode (&optional arg)\r
+ (interactive "P")\r
+ (eval '(cperl-old-auto-fill-mode arg)) ; Avoid a warning\r
+ (and auto-fill-function (memq major-mode '(perl-mode cperl-mode))\r
+ (setq auto-fill-function 'cperl-do-auto-fill))))))\r
+ (if (cperl-enable-font-lock)\r
+ (if (cperl-val 'cperl-font-lock)\r
+ (progn (or cperl-faces-init (cperl-init-faces))\r
+ (font-lock-mode 1))))\r
+ (and (boundp 'msb-menu-cond)\r
+ (not cperl-msb-fixed)\r
+ (cperl-msb-fix))\r
+ (if (featurep 'easymenu)\r
+ (easy-menu-add cperl-menu)) ; A NOP in RMS Emacs.\r
+ (run-hooks 'cperl-mode-hook)\r
+ ;; After hooks since fontification will break this\r
+ (if cperl-pod-here-scan\r
+ (or cperl-syntaxify-by-font-lock\r
+ (progn (or cperl-faces-init (cperl-init-faces-weak))\r
+ (cperl-find-pods-heres)))))\r
+\f\r
+;; Fix for perldb - make default reasonable\r
+(defun cperl-db ()\r
+ (interactive)\r
+ (require 'gud)\r
+ (perldb (read-from-minibuffer "Run perldb (like this): "\r
+ (if (consp gud-perldb-history)\r
+ (car gud-perldb-history)\r
+ (concat "perl " ;;(file-name-nondirectory\r
+ ;; I have problems\r
+ ;; in OS/2\r
+ ;; otherwise\r
+ (buffer-file-name)))\r
+ nil nil\r
+ '(gud-perldb-history . 1))))\r
+\f\r
+(defun cperl-msb-fix ()\r
+ ;; Adds perl files to msb menu, supposes that msb is already loaded\r
+ (setq cperl-msb-fixed t)\r
+ (let* ((l (length msb-menu-cond))\r
+ (last (nth (1- l) msb-menu-cond))\r
+ (precdr (nthcdr (- l 2) msb-menu-cond)) ; cdr of this is last\r
+ (handle (1- (nth 1 last))))\r
+ (setcdr precdr (list\r
+ (list\r
+ '(memq major-mode '(cperl-mode perl-mode))\r
+ handle\r
+ "Perl Files (%d)")\r
+ last))))\r
+\f\r
+;; This is used by indent-for-comment\r
+;; to decide how much to indent a comment in CPerl code\r
+;; based on its context. Do fallback if comment is found wrong.\r
+\r
+(defvar cperl-wrong-comment)\r
+(defvar cperl-st-cfence '(14)) ; Comment-fence\r
+(defvar cperl-st-sfence '(15)) ; String-fence\r
+(defvar cperl-st-punct '(1))\r
+(defvar cperl-st-word '(2))\r
+(defvar cperl-st-bra '(4 . ?\>))\r
+(defvar cperl-st-ket '(5 . ?\<))\r
+\r
+\r
+(defun cperl-comment-indent ()\r
+ (let ((p (point)) (c (current-column)) was phony)\r
+ (if (looking-at "^#") 0 ; Existing comment at bol stays there.\r
+ ;; Wrong comment found\r
+ (save-excursion\r
+ (setq was (cperl-to-comment-or-eol)\r
+ phony (eq (get-text-property (point) 'syntax-table)\r
+ cperl-st-cfence))\r
+ (if phony\r
+ (progn\r
+ (re-search-forward "#\\|$") ; Hmm, what about embedded #?\r
+ (if (eq (preceding-char) ?\#)\r
+ (forward-char -1))\r
+ (setq was nil)))\r
+ (if (= (point) p)\r
+ (progn\r
+ (skip-chars-backward " \t")\r
+ (max (1+ (current-column)) ; Else indent at comment column\r
+ comment-column))\r
+ (if was nil\r
+ (insert comment-start)\r
+ (backward-char (length comment-start)))\r
+ (setq cperl-wrong-comment t)\r
+ (indent-to comment-column 1) ; Indent minimum 1\r
+ c))))) ; except leave at least one space.\r
+\r
+;;;(defun cperl-comment-indent-fallback ()\r
+;;; "Is called if the standard comment-search procedure fails.\r
+;;;Point is at start of real comment."\r
+;;; (let ((c (current-column)) target cnt prevc)\r
+;;; (if (= c comment-column) nil\r
+;;; (setq cnt (skip-chars-backward "[ \t]"))\r
+;;; (setq target (max (1+ (setq prevc\r
+;;; (current-column))) ; Else indent at comment column\r
+;;; comment-column))\r
+;;; (if (= c comment-column) nil\r
+;;; (delete-backward-char cnt)\r
+;;; (while (< prevc target)\r
+;;; (insert "\t")\r
+;;; (setq prevc (current-column)))\r
+;;; (if (> prevc target) (progn (delete-char -1) (setq prevc (current-column))))\r
+;;; (while (< prevc target)\r
+;;; (insert " ")\r
+;;; (setq prevc (current-column)))))))\r
+\r
+(defun cperl-indent-for-comment ()\r
+ "Substitute for `indent-for-comment' in CPerl."\r
+ (interactive)\r
+ (let (cperl-wrong-comment)\r
+ (indent-for-comment)\r
+ (if cperl-wrong-comment\r
+ (progn (cperl-to-comment-or-eol)\r
+ (forward-char (length comment-start))))))\r
+\r
+(defun cperl-comment-region (b e arg)\r
+ "Comment or uncomment each line in the region in CPerl mode.\r
+See `comment-region'."\r
+ (interactive "r\np")\r
+ (let ((comment-start "#"))\r
+ (comment-region b e arg)))\r
+\r
+(defun cperl-uncomment-region (b e arg)\r
+ "Uncomment or comment each line in the region in CPerl mode.\r
+See `comment-region'."\r
+ (interactive "r\np")\r
+ (let ((comment-start "#"))\r
+ (comment-region b e (- arg))))\r
+\r
+(defvar cperl-brace-recursing nil)\r
+\r
+(defun cperl-electric-brace (arg &optional only-before)\r
+ "Insert character and correct line's indentation.\r
+If ONLY-BEFORE and `cperl-auto-newline', will insert newline before the\r
+place (even in empty line), but not after. If after \")\" and the inserted\r
+char is \"{\", insert extra newline before only if\r
+`cperl-extra-newline-before-brace'."\r
+ (interactive "P")\r
+ (let (insertpos\r
+ (other-end (if (and cperl-electric-parens-mark\r
+ (cperl-mark-active)\r
+ (< (mark) (point)))\r
+ (mark)\r
+ nil)))\r
+ (if (and other-end\r
+ (not cperl-brace-recursing)\r
+ (cperl-val 'cperl-electric-parens)\r
+ (>= (save-excursion (cperl-to-comment-or-eol) (point)) (point)))\r
+ ;; Need to insert a matching pair\r
+ (progn\r
+ (save-excursion\r
+ (setq insertpos (point-marker))\r
+ (goto-char other-end)\r
+ (setq last-command-char ?\{)\r
+ (cperl-electric-lbrace arg insertpos))\r
+ (forward-char 1))\r
+ ;; Check whether we close something "usual" with `}'\r
+ (if (and (eq last-command-char ?\})\r
+ (not\r
+ (condition-case nil\r
+ (save-excursion\r
+ (up-list (- (prefix-numeric-value arg)))\r
+ ;;(cperl-after-block-p (point-min))\r
+ (or (cperl-after-expr-p nil "{;)")\r
+ ;; after sub, else, continue\r
+ (cperl-after-block-p nil 'pre)))\r
+ (error nil))))\r
+ ;; Just insert the guy\r
+ (self-insert-command (prefix-numeric-value arg))\r
+ (if (and (not arg) ; No args, end (of empty line or auto)\r
+ (eolp)\r
+ (or (and (null only-before)\r
+ (save-excursion\r
+ (skip-chars-backward " \t")\r
+ (bolp)))\r
+ (and (eq last-command-char ?\{) ; Do not insert newline\r
+ ;; if after ")" and `cperl-extra-newline-before-brace'\r
+ ;; is nil, do not insert extra newline.\r
+ (not cperl-extra-newline-before-brace)\r
+ (save-excursion\r
+ (skip-chars-backward " \t")\r
+ (eq (preceding-char) ?\))))\r
+ (if cperl-auto-newline\r
+ (progn (cperl-indent-line) (newline) t) nil)))\r
+ (progn\r
+ (self-insert-command (prefix-numeric-value arg))\r
+ (cperl-indent-line)\r
+ (if cperl-auto-newline\r
+ (setq insertpos (1- (point))))\r
+ (if (and cperl-auto-newline (null only-before))\r
+ (progn\r
+ (newline)\r
+ (cperl-indent-line)))\r
+ (save-excursion\r
+ (if insertpos (progn (goto-char insertpos)\r
+ (search-forward (make-string\r
+ 1 last-command-char))\r
+ (setq insertpos (1- (point)))))\r
+ (delete-char -1))))\r
+ (if insertpos\r
+ (save-excursion\r
+ (goto-char insertpos)\r
+ (self-insert-command (prefix-numeric-value arg)))\r
+ (self-insert-command (prefix-numeric-value arg)))))))\r
+\r
+(defun cperl-electric-lbrace (arg &optional end)\r
+ "Insert character, correct line's indentation, correct quoting by space."\r
+ (interactive "P")\r
+ (let ((cperl-brace-recursing t)\r
+ (cperl-auto-newline cperl-auto-newline)\r
+ (other-end (or end\r
+ (if (and cperl-electric-parens-mark\r
+ (cperl-mark-active)\r
+ (> (mark) (point)))\r
+ (save-excursion\r
+ (goto-char (mark))\r
+ (point-marker))\r
+ nil)))\r
+ pos after)\r
+ (and (cperl-val 'cperl-electric-lbrace-space)\r
+ (eq (preceding-char) ?$)\r
+ (save-excursion\r
+ (skip-chars-backward "$")\r
+ (looking-at "\\(\\$\\$\\)*\\$\\([^\\$]\\|$\\)"))\r
+ (insert ?\ ))\r
+ ;; Check whether we are in comment\r
+ (if (and\r
+ (save-excursion\r
+ (beginning-of-line)\r
+ (not (looking-at "[ \t]*#")))\r
+ (cperl-after-expr-p nil "{;)"))\r
+ nil\r
+ (setq cperl-auto-newline nil))\r
+ (cperl-electric-brace arg)\r
+ (and (cperl-val 'cperl-electric-parens)\r
+ (eq last-command-char ?{)\r
+ (memq last-command-char\r
+ (append cperl-electric-parens-string nil))\r
+ (or (if other-end (goto-char (marker-position other-end)))\r
+ t)\r
+ (setq last-command-char ?} pos (point))\r
+ (progn (cperl-electric-brace arg t)\r
+ (goto-char pos)))))\r
+\r
+(defun cperl-electric-paren (arg)\r
+ "Insert an opening parenthesis or a matching pair of parentheses.\r
+See `cperl-electric-parens'."\r
+ (interactive "P")\r
+ (let ((beg (save-excursion (beginning-of-line) (point)))\r
+ (other-end (if (and cperl-electric-parens-mark\r
+ (cperl-mark-active)\r
+ (> (mark) (point)))\r
+ (save-excursion\r
+ (goto-char (mark))\r
+ (point-marker))\r
+ nil)))\r
+ (if (and (cperl-val 'cperl-electric-parens)\r
+ (memq last-command-char\r
+ (append cperl-electric-parens-string nil))\r
+ (>= (save-excursion (cperl-to-comment-or-eol) (point)) (point))\r
+ ;;(not (save-excursion (search-backward "#" beg t)))\r
+ (if (eq last-command-char ?<)\r
+ (progn\r
+ (and abbrev-mode ; later it is too late, may be after `for'\r
+ (expand-abbrev))\r
+ (cperl-after-expr-p nil "{;(,:="))\r
+ 1))\r
+ (progn\r
+ (self-insert-command (prefix-numeric-value arg))\r
+ (if other-end (goto-char (marker-position other-end)))\r
+ (insert (make-string\r
+ (prefix-numeric-value arg)\r
+ (cdr (assoc last-command-char '((?{ .?})\r
+ (?[ . ?])\r
+ (?( . ?))\r
+ (?< . ?>))))))\r
+ (forward-char (- (prefix-numeric-value arg))))\r
+ (self-insert-command (prefix-numeric-value arg)))))\r
+\r
+(defun cperl-electric-rparen (arg)\r
+ "Insert a matching pair of parentheses if marking is active.\r
+If not, or if we are not at the end of marking range, would self-insert.\r
+Affected by `cperl-electric-parens'."\r
+ (interactive "P")\r
+ (let ((beg (save-excursion (beginning-of-line) (point)))\r
+ (other-end (if (and cperl-electric-parens-mark\r
+ (cperl-val 'cperl-electric-parens)\r
+ (memq last-command-char\r
+ (append cperl-electric-parens-string nil))\r
+ (cperl-mark-active)\r
+ (< (mark) (point)))\r
+ (mark)\r
+ nil))\r
+ p)\r
+ (if (and other-end\r
+ (cperl-val 'cperl-electric-parens)\r
+ (memq last-command-char '( ?\) ?\] ?\} ?\> ))\r
+ (>= (save-excursion (cperl-to-comment-or-eol) (point)) (point))\r
+ ;;(not (save-excursion (search-backward "#" beg t)))\r
+ )\r
+ (progn\r
+ (self-insert-command (prefix-numeric-value arg))\r
+ (setq p (point))\r
+ (if other-end (goto-char other-end))\r
+ (insert (make-string\r
+ (prefix-numeric-value arg)\r
+ (cdr (assoc last-command-char '((?\} . ?\{)\r
+ (?\] . ?\[)\r
+ (?\) . ?\()\r
+ (?\> . ?\<))))))\r
+ (goto-char (1+ p)))\r
+ (self-insert-command (prefix-numeric-value arg)))))\r
+\r
+(defun cperl-electric-keyword ()\r
+ "Insert a construction appropriate after a keyword.\r
+Help message may be switched off by setting `cperl-message-electric-keyword'\r
+to nil."\r
+ (let ((beg (save-excursion (beginning-of-line) (point)))\r
+ (dollar (and (eq last-command-char ?$)\r
+ (eq this-command 'self-insert-command)))\r
+ (delete (and (memq last-command-char '(?\ ?\n ?\t ?\f))\r
+ (memq this-command '(self-insert-command newline))))\r
+ my do)\r
+ (and (save-excursion\r
+ (condition-case nil\r
+ (progn\r
+ (backward-sexp 1)\r
+ (setq do (looking-at "do\\>")))\r
+ (error nil))\r
+ (cperl-after-expr-p nil "{;:"))\r
+ (save-excursion\r
+ (not\r
+ (re-search-backward\r
+ "[#\"'`]\\|\\<q\\(\\|[wqxr]\\)\\>"\r
+ beg t)))\r
+ (save-excursion (or (not (re-search-backward "^=" nil t))\r
+ (or\r
+ (looking-at "=cut")\r
+ (and cperl-use-syntax-table-text-property\r
+ (not (eq (get-text-property (point)\r
+ 'syntax-type)\r
+ 'pod))))))\r
+ (save-excursion (forward-sexp -1) \r
+ (not (memq (following-char) (append "$@%&*" nil))))\r
+ (progn\r
+ (and (eq (preceding-char) ?y)\r
+ (progn ; "foreachmy"\r
+ (forward-char -2)\r
+ (insert " ")\r
+ (forward-char 2)\r
+ (setq my t dollar t\r
+ delete\r
+ (memq this-command '(self-insert-command newline)))))\r
+ (and dollar (insert " $"))\r
+ (cperl-indent-line)\r
+ ;;(insert " () {\n}")\r
+ (cond\r
+ (cperl-extra-newline-before-brace\r
+ (insert (if do "\n" " ()\n"))\r
+ (insert "{")\r
+ (cperl-indent-line)\r
+ (insert "\n")\r
+ (cperl-indent-line)\r
+ (insert "\n}")\r
+ (and do (insert " while ();")))\r
+ (t\r
+ (insert (if do " {\n} while ();" " () {\n}"))))\r
+ (or (looking-at "[ \t]\\|$") (insert " "))\r
+ (cperl-indent-line)\r
+ (if dollar (progn (search-backward "$")\r
+ (if my\r
+ (forward-char 1)\r
+ (delete-char 1)))\r
+ (search-backward ")")\r
+ (if (eq last-command-char ?\()\r
+ (progn ; Avoid "if (())"\r
+ (delete-backward-char 1)\r
+ (delete-backward-char -1))))\r
+ (if delete\r
+ (cperl-putback-char cperl-del-back-ch))\r
+ (if cperl-message-electric-keyword\r
+ (message "Precede char by C-q to avoid expansion"))))))\r
+\r
+(defun cperl-ensure-newlines (n &optional pos)\r
+ "Make sure there are N newlines after the point."\r
+ (or pos (setq pos (point)))\r
+ (if (looking-at "\n")\r
+ (forward-char 1)\r
+ (insert "\n"))\r
+ (if (> n 1)\r
+ (cperl-ensure-newlines (1- n) pos)\r
+ (goto-char pos)))\r
+\r
+(defun cperl-electric-pod ()\r
+ "Insert a POD chunk appropriate after a =POD directive."\r
+ (let ((delete (and (memq last-command-char '(?\ ?\n ?\t ?\f))\r
+ (memq this-command '(self-insert-command newline))))\r
+ head1 notlast name p really-delete over)\r
+ (and (save-excursion\r
+ (forward-word -1)\r
+ (and\r
+ (eq (preceding-char) ?=)\r
+ (progn\r
+ (setq head1 (looking-at "head1\\>[ \t]*$"))\r
+ (setq over (and (looking-at "over\\>[ \t]*$")\r
+ (not (looking-at "over[ \t]*\n\n\n*=item\\>"))))\r
+ (forward-char -1)\r
+ (bolp))\r
+ (or\r
+ (get-text-property (point) 'in-pod)\r
+ (cperl-after-expr-p nil "{;:")\r
+ (and (re-search-backward\r
+ ;; "\\(\\`\n?\\|\n\n\\)=\\sw+"\r
+ "\\(\\`\n?\\|^\n\\)=\\sw+"\r
+ (point-min) t)\r
+ (not (or\r
+ (looking-at "=cut")\r
+ (and cperl-use-syntax-table-text-property\r
+ (not (eq (get-text-property (point) 'syntax-type)\r
+ 'pod)))))))))\r
+ (progn\r
+ (save-excursion\r
+ (setq notlast (re-search-forward "^\n=" nil t)))\r
+ (or notlast\r
+ (progn\r
+ (insert "\n\n=cut")\r
+ (cperl-ensure-newlines 2)\r
+ (forward-word -2)\r
+ (if (and head1\r
+ (not\r
+ (save-excursion\r
+ (forward-char -1)\r
+ (re-search-backward "\\(\\`\n?\\|\n\n\\)=head1\\>"\r
+ nil t)))) ; Only one\r
+ (progn\r
+ (forward-word 1)\r
+ (setq name (file-name-sans-extension\r
+ (file-name-nondirectory (buffer-file-name)))\r
+ p (point))\r
+ (insert " NAME\n\n" name\r
+ " - \n\n=head1 SYNOPSIS\n\n\n\n"\r
+ "=head1 DESCRIPTION")\r
+ (cperl-ensure-newlines 4)\r
+ (goto-char p)\r
+ (forward-word 2)\r
+ (end-of-line)\r
+ (setq really-delete t))\r
+ (forward-word 1))))\r
+ (if over\r
+ (progn\r
+ (setq p (point))\r
+ (insert "\n\n=item \n\n\n\n"\r
+ "=back")\r
+ (cperl-ensure-newlines 2)\r
+ (goto-char p)\r
+ (forward-word 1)\r
+ (end-of-line)\r
+ (setq really-delete t)))\r
+ (if (and delete really-delete)\r
+ (cperl-putback-char cperl-del-back-ch))))))\r
+\r
+(defun cperl-electric-else ()\r
+ "Insert a construction appropriate after a keyword.\r
+Help message may be switched off by setting `cperl-message-electric-keyword'\r
+to nil."\r
+ (let ((beg (save-excursion (beginning-of-line) (point))))\r
+ (and (save-excursion\r
+ (backward-sexp 1)\r
+ (cperl-after-expr-p nil "{;:"))\r
+ (save-excursion\r
+ (not\r
+ (re-search-backward\r
+ "[#\"'`]\\|\\<q\\(\\|[wqxr]\\)\\>"\r
+ beg t)))\r
+ (save-excursion (or (not (re-search-backward "^=" nil t))\r
+ (looking-at "=cut")\r
+ (and cperl-use-syntax-table-text-property\r
+ (not (eq (get-text-property (point)\r
+ 'syntax-type)\r
+ 'pod)))))\r
+ (progn\r
+ (cperl-indent-line)\r
+ ;;(insert " {\n\n}")\r
+ (cond\r
+ (cperl-extra-newline-before-brace\r
+ (insert "\n")\r
+ (insert "{")\r
+ (cperl-indent-line)\r
+ (insert "\n\n}"))\r
+ (t\r
+ (insert " {\n\n}")))\r
+ (or (looking-at "[ \t]\\|$") (insert " "))\r
+ (cperl-indent-line)\r
+ (forward-line -1)\r
+ (cperl-indent-line)\r
+ (cperl-putback-char cperl-del-back-ch)\r
+ (setq this-command 'cperl-electric-else)\r
+ (if cperl-message-electric-keyword\r
+ (message "Precede char by C-q to avoid expansion"))))))\r
+\r
+(defun cperl-linefeed ()\r
+ "Go to end of line, open a new line and indent appropriately.\r
+If in POD, insert appropriate lines."\r
+ (interactive)\r
+ (let ((beg (save-excursion (beginning-of-line) (point)))\r
+ (end (save-excursion (end-of-line) (point)))\r
+ (pos (point)) start over cut res)\r
+ (if (and ; Check if we need to split:\r
+ ; i.e., on a boundary and inside "{...}"\r
+ (save-excursion (cperl-to-comment-or-eol)\r
+ (>= (point) pos)) ; Not in a comment\r
+ (or (save-excursion\r
+ (skip-chars-backward " \t" beg)\r
+ (forward-char -1)\r
+ (looking-at "[;{]")) ; After { or ; + spaces\r
+ (looking-at "[ \t]*}") ; Before }\r
+ (re-search-forward "\\=[ \t]*;" end t)) ; Before spaces + ;\r
+ (save-excursion\r
+ (and\r
+ (eq (car (parse-partial-sexp pos end -1)) -1)\r
+ ; Leave the level of parens\r
+ (looking-at "[,; \t]*\\($\\|#\\)") ; Comma to allow anon subr\r
+ ; Are at end\r
+ (cperl-after-block-p (point-min))\r
+ (progn\r
+ (backward-sexp 1)\r
+ (setq start (point-marker))\r
+ (<= start pos))))) ; Redundant? Are after the\r
+ ; start of parens group.\r
+ (progn\r
+ (skip-chars-backward " \t")\r
+ (or (memq (preceding-char) (append ";{" nil))\r
+ (insert ";"))\r
+ (insert "\n")\r
+ (forward-line -1)\r
+ (cperl-indent-line)\r
+ (goto-char start)\r
+ (or (looking-at "{[ \t]*$") ; If there is a statement\r
+ ; before, move it to separate line\r
+ (progn\r
+ (forward-char 1)\r
+ (insert "\n")\r
+ (cperl-indent-line)))\r
+ (forward-line 1) ; We are on the target line\r
+ (cperl-indent-line)\r
+ (beginning-of-line)\r
+ (or (looking-at "[ \t]*}[,; \t]*$") ; If there is a statement\r
+ ; after, move it to separate line\r
+ (progn\r
+ (end-of-line)\r
+ (search-backward "}" beg)\r
+ (skip-chars-backward " \t")\r
+ (or (memq (preceding-char) (append ";{" nil))\r
+ (insert ";"))\r
+ (insert "\n")\r
+ (cperl-indent-line)\r
+ (forward-line -1)))\r
+ (forward-line -1) ; We are on the line before target\r
+ (end-of-line)\r
+ (newline-and-indent))\r
+ (end-of-line) ; else - no splitting\r
+ (cond\r
+ ((and (looking-at "\n[ \t]*{$")\r
+ (save-excursion\r
+ (skip-chars-backward " \t")\r
+ (eq (preceding-char) ?\)))) ; Probably if () {} group\r
+ ; with an extra newline.\r
+ (forward-line 2)\r
+ (cperl-indent-line))\r
+ ((save-excursion ; In POD header\r
+ (forward-paragraph -1)\r
+ ;; (re-search-backward "\\(\\`\n?\\|\n\n\\)=head1\\b")\r
+ ;; We are after \n now, so look for the rest\r
+ (if (looking-at "\\(\\`\n?\\|\n\\)=\\sw+")\r
+ (progn\r
+ (setq cut (looking-at "\\(\\`\n?\\|\n\\)=cut\\>"))\r
+ (setq over (looking-at "\\(\\`\n?\\|\n\\)=over\\>"))\r
+ t)))\r
+ (if (and over\r
+ (progn\r
+ (forward-paragraph -1)\r
+ (forward-word 1)\r
+ (setq pos (point))\r
+ (setq cut (buffer-substring (point)\r
+ (save-excursion\r
+ (end-of-line)\r
+ (point))))\r
+ (delete-char (- (save-excursion (end-of-line) (point))\r
+ (point)))\r
+ (setq res (expand-abbrev))\r
+ (save-excursion\r
+ (goto-char pos)\r
+ (insert cut))\r
+ res))\r
+ nil\r
+ (cperl-ensure-newlines (if cut 2 4))\r
+ (forward-line 2)))\r
+ ((get-text-property (point) 'in-pod) ; In POD section\r
+ (cperl-ensure-newlines 4)\r
+ (forward-line 2))\r
+ ((looking-at "\n[ \t]*$") ; Next line is empty - use it.\r
+ (forward-line 1)\r
+ (cperl-indent-line))\r
+ (t\r
+ (newline-and-indent))))))\r
+\r
+(defun cperl-electric-semi (arg)\r
+ "Insert character and correct line's indentation."\r
+ (interactive "P")\r
+ (if cperl-auto-newline\r
+ (cperl-electric-terminator arg)\r
+ (self-insert-command (prefix-numeric-value arg))\r
+ (if cperl-autoindent-on-semi\r
+ (cperl-indent-line))))\r
+\r
+(defun cperl-electric-terminator (arg)\r
+ "Insert character and correct line's indentation."\r
+ (interactive "P")\r
+ (let ((end (point))\r
+ (auto (and cperl-auto-newline\r
+ (or (not (eq last-command-char ?:))\r
+ cperl-auto-newline-after-colon)))\r
+ insertpos)\r
+ (if (and ;;(not arg)\r
+ (eolp)\r
+ (not (save-excursion\r
+ (beginning-of-line)\r
+ (skip-chars-forward " \t")\r
+ (or\r
+ ;; Ignore in comment lines\r
+ (= (following-char) ?#)\r
+ ;; Colon is special only after a label\r
+ ;; So quickly rule out most other uses of colon\r
+ ;; and do no indentation for them.\r
+ (and (eq last-command-char ?:)\r
+ (save-excursion\r
+ (forward-word 1)\r
+ (skip-chars-forward " \t")\r
+ (and (< (point) end)\r
+ (progn (goto-char (- end 1))\r
+ (not (looking-at ":"))))))\r
+ (progn\r
+ (beginning-of-defun)\r
+ (let ((pps (parse-partial-sexp (point) end)))\r
+ (or (nth 3 pps) (nth 4 pps) (nth 5 pps))))))))\r
+ (progn\r
+ (self-insert-command (prefix-numeric-value arg))\r
+ ;;(forward-char -1)\r
+ (if auto (setq insertpos (point-marker)))\r
+ ;;(forward-char 1)\r
+ (cperl-indent-line)\r
+ (if auto\r
+ (progn\r
+ (newline)\r
+ (cperl-indent-line)))\r
+ (save-excursion\r
+ (if insertpos (goto-char (1- (marker-position insertpos)))\r
+ (forward-char -1))\r
+ (delete-char 1))))\r
+ (if insertpos\r
+ (save-excursion\r
+ (goto-char insertpos)\r
+ (self-insert-command (prefix-numeric-value arg)))\r
+ (self-insert-command (prefix-numeric-value arg)))))\r
+\r
+(defun cperl-electric-backspace (arg)\r
+ "Backspace, or remove the whitespace around the point inserted by an electric\r
+key. Will untabivy if `cperl-electric-backspace-untabify' is non-nil."\r
+ (interactive "p")\r
+ (if (and cperl-auto-newline\r
+ (memq last-command '(cperl-electric-semi\r
+ cperl-electric-terminator\r
+ cperl-electric-lbrace))\r
+ (memq (preceding-char) '(?\ ?\t ?\n)))\r
+ (let (p)\r
+ (if (eq last-command 'cperl-electric-lbrace)\r
+ (skip-chars-forward " \t\n"))\r
+ (setq p (point))\r
+ (skip-chars-backward " \t\n")\r
+ (delete-region (point) p))\r
+ (and (eq last-command 'cperl-electric-else)\r
+ ;; We are removing the whitespace *inside* cperl-electric-else\r
+ (setq this-command 'cperl-electric-else-really))\r
+ (if (and cperl-auto-newline\r
+ (eq last-command 'cperl-electric-else-really)\r
+ (memq (preceding-char) '(?\ ?\t ?\n)))\r
+ (let (p)\r
+ (skip-chars-forward " \t\n")\r
+ (setq p (point))\r
+ (skip-chars-backward " \t\n")\r
+ (delete-region (point) p))\r
+ (if cperl-electric-backspace-untabify\r
+ (backward-delete-char-untabify arg)\r
+ (delete-backward-char arg)))))\r
+\r
+(defun cperl-inside-parens-p ()\r
+ (condition-case ()\r
+ (save-excursion\r
+ (save-restriction\r
+ (narrow-to-region (point)\r
+ (progn (beginning-of-defun) (point)))\r
+ (goto-char (point-max))\r
+ (= (char-after (or (scan-lists (point) -1 1) (point-min))) ?\()))\r
+ (error nil)))\r
+\f\r
+(defun cperl-indent-command (&optional whole-exp)\r
+ "Indent current line as Perl code, or in some cases insert a tab character.\r
+If `cperl-tab-always-indent' is non-nil (the default), always indent current\r
+line. Otherwise, indent the current line only if point is at the left margin\r
+or in the line's indentation; otherwise insert a tab.\r
+\r
+A numeric argument, regardless of its value,\r
+means indent rigidly all the lines of the expression starting after point\r
+so that this line becomes properly indented.\r
+The relative indentation among the lines of the expression are preserved."\r
+ (interactive "P")\r
+ (cperl-update-syntaxification (point) (point))\r
+ (if whole-exp\r
+ ;; If arg, always indent this line as Perl\r
+ ;; and shift remaining lines of expression the same amount.\r
+ (let ((shift-amt (cperl-indent-line))\r
+ beg end)\r
+ (save-excursion\r
+ (if cperl-tab-always-indent\r
+ (beginning-of-line))\r
+ (setq beg (point))\r
+ (forward-sexp 1)\r
+ (setq end (point))\r
+ (goto-char beg)\r
+ (forward-line 1)\r
+ (setq beg (point)))\r
+ (if (and shift-amt (> end beg))\r
+ (indent-code-rigidly beg end shift-amt "#")))\r
+ (if (and (not cperl-tab-always-indent)\r
+ (save-excursion\r
+ (skip-chars-backward " \t")\r
+ (not (bolp))))\r
+ (insert-tab)\r
+ (cperl-indent-line))))\r
+\r
+(defun cperl-indent-line (&optional parse-data)\r
+ "Indent current line as Perl code.\r
+Return the amount the indentation changed by."\r
+ (let ((case-fold-search nil)\r
+ (pos (- (point-max) (point)))\r
+ indent i beg shift-amt)\r
+ (setq indent (cperl-calculate-indent parse-data)\r
+ i indent)\r
+ (beginning-of-line)\r
+ (setq beg (point))\r
+ (cond ((or (eq indent nil) (eq indent t))\r
+ (setq indent (current-indentation) i nil))\r
+ ;;((eq indent t) ; Never?\r
+ ;; (setq indent (cperl-calculate-indent-within-comment)))\r
+ ;;((looking-at "[ \t]*#")\r
+ ;; (setq indent 0))\r
+ (t\r
+ (skip-chars-forward " \t")\r
+ (if (listp indent) (setq indent (car indent)))\r
+ (cond ((looking-at "[A-Za-z_][A-Za-z_0-9]*:[^:]")\r
+ (and (> indent 0)\r
+ (setq indent (max cperl-min-label-indent\r
+ (+ indent cperl-label-offset)))))\r
+ ((= (following-char) ?})\r
+ (setq indent (- indent cperl-indent-level)))\r
+ ((memq (following-char) '(?\) ?\])) ; To line up with opening paren.\r
+ (setq indent (+ indent cperl-close-paren-offset)))\r
+ ((= (following-char) ?{)\r
+ (setq indent (+ indent cperl-brace-offset))))))\r
+ (skip-chars-forward " \t")\r
+ (setq shift-amt (and i (- indent (current-column))))\r
+ (if (or (not shift-amt)\r
+ (zerop shift-amt))\r
+ (if (> (- (point-max) pos) (point))\r
+ (goto-char (- (point-max) pos)))\r
+ (delete-region beg (point))\r
+ (indent-to indent)\r
+ ;; If initial point was within line's indentation,\r
+ ;; position after the indentation. Else stay at same point in text.\r
+ (if (> (- (point-max) pos) (point))\r
+ (goto-char (- (point-max) pos))))\r
+ shift-amt))\r
+\r
+(defun cperl-after-label ()\r
+ ;; Returns true if the point is after label. Does not do save-excursion.\r
+ (and (eq (preceding-char) ?:)\r
+ (memq (char-syntax (char-after (- (point) 2)))\r
+ '(?w ?_))\r
+ (progn\r
+ (backward-sexp)\r
+ (looking-at "[a-zA-Z_][a-zA-Z0-9_]*:[^:]"))))\r
+\r
+(defun cperl-get-state (&optional parse-start start-state)\r
+ ;; returns list (START STATE DEPTH PRESTART),\r
+ ;; START is a good place to start parsing, or equal to\r
+ ;; PARSE-START if preset,\r
+ ;; STATE is what is returned by `parse-partial-sexp'.\r
+ ;; DEPTH is true is we are immediately after end of block\r
+ ;; which contains START.\r
+ ;; PRESTART is the position basing on which START was found.\r
+ (save-excursion\r
+ (let ((start-point (point)) depth state start prestart)\r
+ (if (and parse-start\r
+ (<= parse-start start-point))\r
+ (goto-char parse-start)\r
+ (beginning-of-defun)\r
+ (setq start-state nil))\r
+ (setq prestart (point))\r
+ (if start-state nil\r
+ ;; Try to go out, if sub is not on the outermost level\r
+ (while (< (point) start-point)\r
+ (setq start (point) parse-start start depth nil\r
+ state (parse-partial-sexp start start-point -1))\r
+ (if (> (car state) -1) nil\r
+ ;; The current line could start like }}}, so the indentation\r
+ ;; corresponds to a different level than what we reached\r
+ (setq depth t)\r
+ (beginning-of-line 2))) ; Go to the next line.\r
+ (if start (goto-char start))) ; Not at the start of file\r
+ (setq start (point))\r
+ (or state (setq state (parse-partial-sexp start start-point -1 nil start-state)))\r
+ (list start state depth prestart))))\r
+\r
+(defun cperl-block-p () ; Do not C-M-q ! One string contains ";" !\r
+ ;; Positions is before ?\{. Checks whether it starts a block.\r
+ ;; No save-excursion!\r
+ (cperl-backward-to-noncomment (point-min))\r
+ (or (memq (preceding-char) (append ";){}$@&%\C-@" nil)) ; Or label! \C-@ at bobp\r
+ ; Label may be mixed up with `$blah :'\r
+ (save-excursion (cperl-after-label))\r
+ (and (memq (char-syntax (preceding-char)) '(?w ?_))\r
+ (progn\r
+ (backward-sexp)\r
+ ;; Need take into account `bless', `return', `tr',...\r
+ (or (and (looking-at "[a-zA-Z0-9_:]+[ \t\n\f]*[{#]") ; Method call syntax\r
+ (not (looking-at "\\(bless\\|return\\|q[wqrx]?\\|tr\\|[smy]\\)\\>")))\r
+ (progn\r
+ (skip-chars-backward " \t\n\f")\r
+ (and (memq (char-syntax (preceding-char)) '(?w ?_))\r
+ (progn\r
+ (backward-sexp)\r
+ (looking-at\r
+ "sub[ \t]+[a-zA-Z0-9_:]+[ \t\n\f]*\\(([^()]*)[ \t\n\f]*\\)?[#{]")))))))))\r
+\r
+(defvar cperl-look-for-prop '((pod in-pod) (here-doc-delim here-doc-group)))\r
+\r
+(defun cperl-calculate-indent (&optional parse-data) ; was parse-start\r
+ "Return appropriate indentation for current line as Perl code.\r
+In usual case returns an integer: the column to indent to.\r
+Returns nil if line starts inside a string, t if in a comment.\r
+\r
+Will not correct the indentation for labels, but will correct it for braces\r
+and closing parentheses and brackets."\r
+ (cperl-update-syntaxification (point) (point))\r
+ (save-excursion\r
+ (if (or\r
+ (and (memq (get-text-property (point) 'syntax-type)\r
+ '(pod here-doc here-doc-delim format))\r
+ (not (get-text-property (point) 'indentable)))\r
+ ;; before start of POD - whitespace found since do not have 'pod!\r
+ (and (looking-at "[ \t]*\n=")\r
+ (error "Spaces before POD section!"))\r
+ (and (not cperl-indent-left-aligned-comments)\r
+ (looking-at "^#")))\r
+ nil\r
+ (beginning-of-line)\r
+ (let ((indent-point (point))\r
+ (char-after (save-excursion\r
+ (skip-chars-forward " \t")\r
+ (following-char)))\r
+ (in-pod (get-text-property (point) 'in-pod))\r
+ (pre-indent-point (point))\r
+ p prop look-prop is-block delim)\r
+ (cond\r
+ (in-pod\r
+ ;; In the verbatim part, probably code example. What to do???\r
+ )\r
+ (t\r
+ (save-excursion\r
+ ;; Not in POD\r
+ (cperl-backward-to-noncomment nil)\r
+ (setq p (max (point-min) (1- (point)))\r
+ prop (get-text-property p 'syntax-type)\r
+ look-prop (or (nth 1 (assoc prop cperl-look-for-prop))\r
+ 'syntax-type))\r
+ (if (memq prop '(pod here-doc format here-doc-delim))\r
+ (progn\r
+ (goto-char (or (previous-single-property-change p look-prop)\r
+ (point-min)))\r
+ (beginning-of-line)\r
+ (setq pre-indent-point (point)))))))\r
+ (goto-char pre-indent-point)\r
+ (let* ((case-fold-search nil)\r
+ (s-s (cperl-get-state (car parse-data) (nth 1 parse-data)))\r
+ (start (or (nth 2 parse-data)\r
+ (nth 0 s-s)))\r
+ (state (nth 1 s-s))\r
+ (containing-sexp (car (cdr state)))\r
+ old-indent)\r
+ (if (and\r
+ ;;containing-sexp ;; We are buggy at toplevel :-(\r
+ parse-data)\r
+ (progn\r
+ (setcar parse-data pre-indent-point)\r
+ (setcar (cdr parse-data) state)\r
+ (or (nth 2 parse-data)\r
+ (setcar (cddr parse-data) start))\r
+ ;; Before this point: end of statement\r
+ (setq old-indent (nth 3 parse-data))))\r
+ (cond ((get-text-property (point) 'indentable)\r
+ ;; indent to just after the surrounding open,\r
+ ;; skip blanks if we do not close the expression.\r
+ (goto-char (1+ (previous-single-property-change (point) 'indentable)))\r
+ (or (memq char-after (append ")]}" nil))\r
+ (looking-at "[ \t]*\\(#\\|$\\)")\r
+ (skip-chars-forward " \t"))\r
+ (current-column))\r
+ ((or (nth 3 state) (nth 4 state))\r
+ ;; return nil or t if should not change this line\r
+ (nth 4 state))\r
+ ;; XXXX Do we need to special-case this?\r
+ ((null containing-sexp)\r
+ ;; Line is at top level. May be data or function definition,\r
+ ;; or may be function argument declaration.\r
+ ;; Indent like the previous top level line\r
+ ;; unless that ends in a closeparen without semicolon,\r
+ ;; in which case this line is the first argument decl.\r
+ (skip-chars-forward " \t")\r
+ (+ (save-excursion\r
+ (goto-char start)\r
+ (- (current-indentation)\r
+ (if (nth 2 s-s) cperl-indent-level 0)))\r
+ (if (= char-after ?{) cperl-continued-brace-offset 0)\r
+ (progn\r
+ (cperl-backward-to-noncomment (or old-indent (point-min)))\r
+ ;; Look at previous line that's at column 0\r
+ ;; to determine whether we are in top-level decls\r
+ ;; or function's arg decls. Set basic-indent accordingly.\r
+ ;; Now add a little if this is a continuation line.\r
+ (if (or (bobp)\r
+ (eq (point) old-indent) ; old-indent was at comment\r
+ (eq (preceding-char) ?\;)\r
+ ;; Had ?\) too\r
+ (and (eq (preceding-char) ?\})\r
+ (cperl-after-block-and-statement-beg\r
+ (point-min))) ; Was start - too close\r
+ (memq char-after (append ")]}" nil))\r
+ (and (eq (preceding-char) ?\:) ; label\r
+ (progn\r
+ (forward-sexp -1)\r
+ (skip-chars-backward " \t")\r
+ (looking-at "[ \t]*[a-zA-Z_][a-zA-Z_0-9]*[ \t]*:")))\r
+ (get-text-property (point) 'first-format-line))\r
+ (progn\r
+ (if (and parse-data\r
+ (not (eq char-after ?\C-j)))\r
+ (setcdr (cddr parse-data)\r
+ (list pre-indent-point)))\r
+ 0)\r
+ cperl-continued-statement-offset))))\r
+ ((not\r
+ (or (setq is-block\r
+ (and (setq delim (= (char-after containing-sexp) ?{))\r
+ (save-excursion ; Is it a hash?\r
+ (goto-char containing-sexp)\r
+ (cperl-block-p))))\r
+ cperl-indent-parens-as-block))\r
+ ;; group is an expression, not a block:\r
+ ;; indent to just after the surrounding open parens,\r
+ ;; skip blanks if we do not close the expression.\r
+ (goto-char (1+ containing-sexp))\r
+ (or (memq char-after\r
+ (append (if delim "}" ")]}") nil))\r
+ (looking-at "[ \t]*\\(#\\|$\\)")\r
+ (skip-chars-forward " \t"))\r
+ (+ (current-column)\r
+ (if (and delim\r
+ (eq char-after ?\}))\r
+ ;; Correct indentation of trailing ?\}\r
+ (+ cperl-indent-level cperl-close-paren-offset)\r
+ 0)))\r
+;;; ((and (/= (char-after containing-sexp) ?{)\r
+;;; (not cperl-indent-parens-as-block))\r
+;;; ;; line is expression, not statement:\r
+;;; ;; indent to just after the surrounding open,\r
+;;; ;; skip blanks if we do not close the expression.\r
+;;; (goto-char (1+ containing-sexp))\r
+;;; (or (memq char-after (append ")]}" nil))\r
+;;; (looking-at "[ \t]*\\(#\\|$\\)")\r
+;;; (skip-chars-forward " \t"))\r
+;;; (current-column))\r
+;;; ((progn\r
+;;; ;; Containing-expr starts with \{. Check whether it is a hash.\r
+;;; (goto-char containing-sexp)\r
+;;; (and (not (cperl-block-p))\r
+;;; (not cperl-indent-parens-as-block)))\r
+;;; (goto-char (1+ containing-sexp))\r
+;;; (or (eq char-after ?\})\r
+;;; (looking-at "[ \t]*\\(#\\|$\\)")\r
+;;; (skip-chars-forward " \t"))\r
+;;; (+ (current-column) ; Correct indentation of trailing ?\}\r
+;;; (if (eq char-after ?\}) (+ cperl-indent-level\r
+;;; cperl-close-paren-offset)\r
+;;; 0)))\r
+ (t\r
+ ;; Statement level. Is it a continuation or a new statement?\r
+ ;; Find previous non-comment character.\r
+ (goto-char pre-indent-point)\r
+ (cperl-backward-to-noncomment containing-sexp)\r
+ ;; Back up over label lines, since they don't\r
+ ;; affect whether our line is a continuation.\r
+ ;; (Had \, too)\r
+ (while ;;(or (eq (preceding-char) ?\,)\r
+ (and (eq (preceding-char) ?:)\r
+ (or ;;(eq (char-after (- (point) 2)) ?\') ; ????\r
+ (memq (char-syntax (char-after (- (point) 2)))\r
+ '(?w ?_))))\r
+ ;;)\r
+ (if (eq (preceding-char) ?\,)\r
+ ;; Will go to beginning of line, essentially.\r
+ ;; Will ignore embedded sexpr XXXX.\r
+ (cperl-backward-to-start-of-continued-exp containing-sexp))\r
+ (beginning-of-line)\r
+ (cperl-backward-to-noncomment containing-sexp))\r
+ ;; Now we get the answer.\r
+ (if (not (or (eq (1- (point)) containing-sexp)\r
+ (memq (preceding-char)\r
+ (append (if is-block " ;{" " ,;{") '(nil)))\r
+ (and (eq (preceding-char) ?\})\r
+ (cperl-after-block-and-statement-beg\r
+ containing-sexp))\r
+ (get-text-property (point) 'first-format-line)))\r
+ ;; This line is continuation of preceding line's statement;\r
+ ;; indent `cperl-continued-statement-offset' more than the\r
+ ;; previous line of the statement.\r
+ ;;\r
+ ;; There might be a label on this line, just\r
+ ;; consider it bad style and ignore it.\r
+ (progn\r
+ (cperl-backward-to-start-of-continued-exp containing-sexp)\r
+ (+ (if (memq char-after (append "}])" nil))\r
+ 0 ; Closing parenth\r
+ cperl-continued-statement-offset)\r
+ (if (or is-block\r
+ (not delim)\r
+ (not (eq char-after ?\})))\r
+ 0\r
+ ;; Now it is a hash reference\r
+ (+ cperl-indent-level cperl-close-paren-offset))\r
+ (if (looking-at "\\w+[ \t]*:")\r
+ (if (> (current-indentation) cperl-min-label-indent)\r
+ (- (current-indentation) cperl-label-offset)\r
+ ;; Do not move `parse-data', this should\r
+ ;; be quick anyway (this comment comes\r
+ ;; from different location):\r
+ (cperl-calculate-indent))\r
+ (current-column))\r
+ (if (eq char-after ?\{)\r
+ cperl-continued-brace-offset 0)))\r
+ ;; This line starts a new statement.\r
+ ;; Position following last unclosed open.\r
+ (goto-char containing-sexp)\r
+ ;; Is line first statement after an open-brace?\r
+ (or\r
+ ;; If no, find that first statement and indent like\r
+ ;; it. If the first statement begins with label, do\r
+ ;; not believe when the indentation of the label is too\r
+ ;; small.\r
+ (save-excursion\r
+ (forward-char 1)\r
+ (setq old-indent (current-indentation))\r
+ (let ((colon-line-end 0))\r
+ (while\r
+ (progn (skip-chars-forward " \t\n")\r
+ (looking-at "#\\|[a-zA-Z0-9_$]*:[^:]\\|=[a-zA-Z]"))\r
+ ;; Skip over comments and labels following openbrace.\r
+ (cond ((= (following-char) ?\#)\r
+ (forward-line 1))\r
+ ((= (following-char) ?\=)\r
+ (goto-char\r
+ (or (next-single-property-change (point) 'in-pod)\r
+ (point-max)))) ; do not loop if no syntaxification\r
+ ;; label:\r
+ (t\r
+ (save-excursion (end-of-line)\r
+ (setq colon-line-end (point)))\r
+ (search-forward ":"))))\r
+ ;; The first following code counts\r
+ ;; if it is before the line we want to indent.\r
+ (and (< (point) indent-point)\r
+ (if (> colon-line-end (point)) ; After label\r
+ (if (> (current-indentation)\r
+ cperl-min-label-indent)\r
+ (- (current-indentation) cperl-label-offset)\r
+ ;; Do not believe: `max' is involved\r
+ (+ old-indent cperl-indent-level))\r
+ (current-column)))))\r
+ ;; If no previous statement,\r
+ ;; indent it relative to line brace is on.\r
+ ;; For open brace in column zero, don't let statement\r
+ ;; start there too. If cperl-indent-level is zero,\r
+ ;; use cperl-brace-offset + cperl-continued-statement-offset instead.\r
+ ;; For open-braces not the first thing in a line,\r
+ ;; add in cperl-brace-imaginary-offset.\r
+\r
+ ;; If first thing on a line: ?????\r
+ (+ (if (and (bolp) (zerop cperl-indent-level))\r
+ (+ cperl-brace-offset cperl-continued-statement-offset)\r
+ cperl-indent-level)\r
+ (if (or is-block\r
+ (not delim)\r
+ (not (eq char-after ?\})))\r
+ 0\r
+ ;; Now it is a hash reference\r
+ (+ cperl-indent-level cperl-close-paren-offset))\r
+ ;; Move back over whitespace before the openbrace.\r
+ ;; If openbrace is not first nonwhite thing on the line,\r
+ ;; add the cperl-brace-imaginary-offset.\r
+ (progn (skip-chars-backward " \t")\r
+ (if (bolp) 0 cperl-brace-imaginary-offset))\r
+ ;; If the openbrace is preceded by a parenthesized exp,\r
+ ;; move to the beginning of that;\r
+ ;; possibly a different line\r
+ (progn\r
+ (if (eq (preceding-char) ?\))\r
+ (forward-sexp -1))\r
+ ;; In the case it starts a subroutine, indent with\r
+ ;; respect to `sub', not with respect to the\r
+ ;; first thing on the line, say in the case of\r
+ ;; anonymous sub in a hash.\r
+ ;;\r
+ (skip-chars-backward " \t")\r
+ (if (and (eq (preceding-char) ?b)\r
+ (progn\r
+ (forward-sexp -1)\r
+ (looking-at "sub\\>"))\r
+ (setq old-indent\r
+ (nth 1\r
+ (parse-partial-sexp\r
+ (save-excursion (beginning-of-line) (point))\r
+ (point)))))\r
+ (progn (goto-char (1+ old-indent))\r
+ (skip-chars-forward " \t")\r
+ (current-column))\r
+ ;; Get initial indentation of the line we are on.\r
+ ;; If line starts with label, calculate label indentation\r
+ (if (save-excursion\r
+ (beginning-of-line)\r
+ (looking-at "[ \t]*[a-zA-Z_][a-zA-Z_0-9]*:[^:]"))\r
+ (if (> (current-indentation) cperl-min-label-indent)\r
+ (- (current-indentation) cperl-label-offset)\r
+ ;; Do not move `parse-data', this should\r
+ ;; be quick anyway:\r
+ (cperl-calculate-indent))\r
+ (current-indentation))))))))))))))\r
+\r
+(defvar cperl-indent-alist\r
+ '((string nil)\r
+ (comment nil)\r
+ (toplevel 0)\r
+ (toplevel-after-parenth 2)\r
+ (toplevel-continued 2)\r
+ (expression 1))\r
+ "Alist of indentation rules for CPerl mode.\r
+The values mean:\r
+ nil: do not indent;\r
+ number: add this amount of indentation.\r
+\r
+Not finished, not used.")\r
+\r
+(defun cperl-where-am-i (&optional parse-start start-state)\r
+ ;; Unfinished\r
+ "Return a list of lists ((TYPE POS)...) of good points before the point.\r
+POS may be nil if it is hard to find, say, when TYPE is `string' or `comment'.\r
+\r
+Not finished, not used."\r
+ (save-excursion\r
+ (let* ((start-point (point))\r
+ (s-s (cperl-get-state))\r
+ (start (nth 0 s-s))\r
+ (state (nth 1 s-s))\r
+ (prestart (nth 3 s-s))\r
+ (containing-sexp (car (cdr state)))\r
+ (case-fold-search nil)\r
+ (res (list (list 'parse-start start) (list 'parse-prestart prestart))))\r
+ (cond ((nth 3 state) ; In string\r
+ (setq res (cons (list 'string nil (nth 3 state)) res))) ; What started string\r
+ ((nth 4 state) ; In comment\r
+ (setq res (cons '(comment) res)))\r
+ ((null containing-sexp)\r
+ ;; Line is at top level.\r
+ ;; Indent like the previous top level line\r
+ ;; unless that ends in a closeparen without semicolon,\r
+ ;; in which case this line is the first argument decl.\r
+ (cperl-backward-to-noncomment (or parse-start (point-min)))\r
+ ;;(skip-chars-backward " \t\f\n")\r
+ (cond\r
+ ((or (bobp)\r
+ (memq (preceding-char) (append ";}" nil)))\r
+ (setq res (cons (list 'toplevel start) res)))\r
+ ((eq (preceding-char) ?\) )\r
+ (setq res (cons (list 'toplevel-after-parenth start) res)))\r
+ (t\r
+ (setq res (cons (list 'toplevel-continued start) res)))))\r
+ ((/= (char-after containing-sexp) ?{)\r
+ ;; line is expression, not statement:\r
+ ;; indent to just after the surrounding open.\r
+ ;; skip blanks if we do not close the expression.\r
+ (setq res (cons (list 'expression-blanks\r
+ (progn\r
+ (goto-char (1+ containing-sexp))\r
+ (or (looking-at "[ \t]*\\(#\\|$\\)")\r
+ (skip-chars-forward " \t"))\r
+ (point)))\r
+ (cons (list 'expression containing-sexp) res))))\r
+ ((progn\r
+ ;; Containing-expr starts with \{. Check whether it is a hash.\r
+ (goto-char containing-sexp)\r
+ (not (cperl-block-p)))\r
+ (setq res (cons (list 'expression-blanks\r
+ (progn\r
+ (goto-char (1+ containing-sexp))\r
+ (or (looking-at "[ \t]*\\(#\\|$\\)")\r
+ (skip-chars-forward " \t"))\r
+ (point)))\r
+ (cons (list 'expression containing-sexp) res))))\r
+ (t\r
+ ;; Statement level.\r
+ (setq res (cons (list 'in-block containing-sexp) res))\r
+ ;; Is it a continuation or a new statement?\r
+ ;; Find previous non-comment character.\r
+ (cperl-backward-to-noncomment containing-sexp)\r
+ ;; Back up over label lines, since they don't\r
+ ;; affect whether our line is a continuation.\r
+ ;; Back up comma-delimited lines too ?????\r
+ (while (or (eq (preceding-char) ?\,)\r
+ (save-excursion (cperl-after-label)))\r
+ (if (eq (preceding-char) ?\,)\r
+ ;; Will go to beginning of line, essentially\r
+ ;; Will ignore embedded sexpr XXXX.\r
+ (cperl-backward-to-start-of-continued-exp containing-sexp))\r
+ (beginning-of-line)\r
+ (cperl-backward-to-noncomment containing-sexp))\r
+ ;; Now we get the answer.\r
+ (if (not (memq (preceding-char) (append ";}{" '(nil)))) ; Was ?\,\r
+ ;; This line is continuation of preceding line's statement.\r
+ (list (list 'statement-continued containing-sexp))\r
+ ;; This line starts a new statement.\r
+ ;; Position following last unclosed open.\r
+ (goto-char containing-sexp)\r
+ ;; Is line first statement after an open-brace?\r
+ (or\r
+ ;; If no, find that first statement and indent like\r
+ ;; it. If the first statement begins with label, do\r
+ ;; not believe when the indentation of the label is too\r
+ ;; small.\r
+ (save-excursion\r
+ (forward-char 1)\r
+ (let ((colon-line-end 0))\r
+ (while (progn (skip-chars-forward " \t\n" start-point)\r
+ (and (< (point) start-point)\r
+ (looking-at\r
+ "#\\|[a-zA-Z_][a-zA-Z0-9_]*:[^:]")))\r
+ ;; Skip over comments and labels following openbrace.\r
+ (cond ((= (following-char) ?\#)\r
+ ;;(forward-line 1)\r
+ (end-of-line))\r
+ ;; label:\r
+ (t\r
+ (save-excursion (end-of-line)\r
+ (setq colon-line-end (point)))\r
+ (search-forward ":"))))\r
+ ;; Now at the point, after label, or at start\r
+ ;; of first statement in the block.\r
+ (and (< (point) start-point)\r
+ (if (> colon-line-end (point))\r
+ ;; Before statement after label\r
+ (if (> (current-indentation)\r
+ cperl-min-label-indent)\r
+ (list (list 'label-in-block (point)))\r
+ ;; Do not believe: `max' is involved\r
+ (list\r
+ (list 'label-in-block-min-indent (point))))\r
+ ;; Before statement\r
+ (list 'statement-in-block (point))))))\r
+ ;; If no previous statement,\r
+ ;; indent it relative to line brace is on.\r
+ ;; For open brace in column zero, don't let statement\r
+ ;; start there too. If cperl-indent-level is zero,\r
+ ;; use cperl-brace-offset + cperl-continued-statement-offset instead.\r
+ ;; For open-braces not the first thing in a line,\r
+ ;; add in cperl-brace-imaginary-offset.\r
+\r
+ ;; If first thing on a line: ?????\r
+ (+ (if (and (bolp) (zerop cperl-indent-level))\r
+ (+ cperl-brace-offset cperl-continued-statement-offset)\r
+ cperl-indent-level)\r
+ ;; Move back over whitespace before the openbrace.\r
+ ;; If openbrace is not first nonwhite thing on the line,\r
+ ;; add the cperl-brace-imaginary-offset.\r
+ (progn (skip-chars-backward " \t")\r
+ (if (bolp) 0 cperl-brace-imaginary-offset))\r
+ ;; If the openbrace is preceded by a parenthesized exp,\r
+ ;; move to the beginning of that;\r
+ ;; possibly a different line\r
+ (progn\r
+ (if (eq (preceding-char) ?\))\r
+ (forward-sexp -1))\r
+ ;; Get initial indentation of the line we are on.\r
+ ;; If line starts with label, calculate label indentation\r
+ (if (save-excursion\r
+ (beginning-of-line)\r
+ (looking-at "[ \t]*[a-zA-Z_][a-zA-Z_0-9]*:[^:]"))\r
+ (if (> (current-indentation) cperl-min-label-indent)\r
+ (- (current-indentation) cperl-label-offset)\r
+ (cperl-calculate-indent))\r
+ (current-indentation))))))))\r
+ res)))\r
+\r
+(defun cperl-calculate-indent-within-comment ()\r
+ "Return the indentation amount for line, assuming that\r
+the current line is to be regarded as part of a block comment."\r
+ (let (end star-start)\r
+ (save-excursion\r
+ (beginning-of-line)\r
+ (skip-chars-forward " \t")\r
+ (setq end (point))\r
+ (and (= (following-char) ?#)\r
+ (forward-line -1)\r
+ (cperl-to-comment-or-eol)\r
+ (setq end (point)))\r
+ (goto-char end)\r
+ (current-column))))\r
+\r
+\r
+(defun cperl-to-comment-or-eol ()\r
+ "Go to position before comment on the current line, or to end of line.\r
+Returns true if comment is found."\r
+ (let (state stop-in cpoint (lim (progn (end-of-line) (point))))\r
+ (beginning-of-line)\r
+ (if (or\r
+ (eq (get-text-property (point) 'syntax-type) 'pod)\r
+ (re-search-forward "\\=[ \t]*\\(#\\|$\\)" lim t))\r
+ (if (eq (preceding-char) ?\#) (progn (backward-char 1) t))\r
+ ;; Else\r
+ (while (not stop-in)\r
+ (setq state (parse-partial-sexp (point) lim nil nil nil t))\r
+ ; stop at comment\r
+ ;; If fails (beginning-of-line inside sexp), then contains not-comment\r
+ (if (nth 4 state) ; After `#';\r
+ ; (nth 2 state) can be\r
+ ; beginning of m,s,qq and so\r
+ ; on\r
+ (if (nth 2 state)\r
+ (progn\r
+ (setq cpoint (point))\r
+ (goto-char (nth 2 state))\r
+ (cond\r
+ ((looking-at "\\(s\\|tr\\)\\>")\r
+ (or (re-search-forward\r
+ "\\=\\w+[ \t]*#\\([^\n\\\\#]\\|\\\\[\\\\#]\\)*#\\([^\n\\\\#]\\|\\\\[\\\\#]\\)*"\r
+ lim 'move)\r
+ (setq stop-in t)))\r
+ ((looking-at "\\(m\\|q\\([qxwr]\\)?\\)\\>")\r
+ (or (re-search-forward\r
+ "\\=\\w+[ \t]*#\\([^\n\\\\#]\\|\\\\[\\\\#]\\)*#"\r
+ lim 'move)\r
+ (setq stop-in t)))\r
+ (t ; It was fair comment\r
+ (setq stop-in t) ; Finish\r
+ (goto-char (1- cpoint)))))\r
+ (setq stop-in t) ; Finish\r
+ (forward-char -1))\r
+ (setq stop-in t))) ; Finish \r
+ (nth 4 state))))\r
+\r
+(defsubst cperl-1- (p)\r
+ (max (point-min) (1- p)))\r
+\r
+(defsubst cperl-1+ (p)\r
+ (min (point-max) (1+ p)))\r
+\r
+(defsubst cperl-modify-syntax-type (at how)\r
+ (if (< at (point-max))\r
+ (progn\r
+ (put-text-property at (1+ at) 'syntax-table how)\r
+ (put-text-property at (1+ at) 'rear-nonsticky t))))\r
+\r
+(defun cperl-protect-defun-start (s e)\r
+ ;; C code looks for "^\\s(" to skip comment backward in "hard" situations\r
+ (save-excursion\r
+ (goto-char s)\r
+ (while (re-search-forward "^\\s(" e 'to-end)\r
+ (put-text-property (1- (point)) (point) 'syntax-table cperl-st-punct))))\r
+\r
+(defun cperl-commentify (bb e string &optional noface)\r
+ (if cperl-use-syntax-table-text-property\r
+ (if (eq noface 'n) ; Only immediate\r
+ nil\r
+ ;; We suppose that e is _after_ the end of construction, as after eol.\r
+ (setq string (if string cperl-st-sfence cperl-st-cfence))\r
+ (if (> bb (- e 2))\r
+ ;; one-char string/comment?!\r
+ (cperl-modify-syntax-type bb cperl-st-punct)\r
+ (cperl-modify-syntax-type bb string)\r
+ (cperl-modify-syntax-type (1- e) string))\r
+ (if (and (eq string cperl-st-sfence) (> (- e 2) bb))\r
+ (put-text-property (1+ bb) (1- e)\r
+ 'syntax-table cperl-string-syntax-table))\r
+ (cperl-protect-defun-start bb e))\r
+ ;; Fontify\r
+ (or noface\r
+ (not cperl-pod-here-fontify)\r
+ (put-text-property bb e 'face (if string 'font-lock-string-face\r
+ 'font-lock-comment-face)))))\r
+\r
+(defvar cperl-starters '(( ?\( . ?\) )\r
+ ( ?\[ . ?\] )\r
+ ( ?\{ . ?\} )\r
+ ( ?\< . ?\> )))\r
+\r
+(defun cperl-forward-re (lim end is-2arg set-st st-l err-l argument\r
+ &optional ostart oend)\r
+ ;; Works *before* syntax recognition is done\r
+ ;; May modify syntax-type text property if the situation is too hard\r
+ (let (b starter ender st i i2 go-forward reset-st)\r
+ (skip-chars-forward " \t")\r
+ ;; ender means matching-char matcher.\r
+ (setq b (point)\r
+ starter (if (eobp) 0 (char-after b))\r
+ ender (cdr (assoc starter cperl-starters)))\r
+ ;; What if starter == ?\\ ????\r
+ (if set-st\r
+ (if (car st-l)\r
+ (setq st (car st-l))\r
+ (setcar st-l (make-syntax-table))\r
+ (setq i 0 st (car st-l))\r
+ (while (< i 256)\r
+ (modify-syntax-entry i "." st)\r
+ (setq i (1+ i)))\r
+ (modify-syntax-entry ?\\ "\\" st)))\r
+ (setq set-st t)\r
+ ;; Whether we have an intermediate point\r
+ (setq i nil)\r
+ ;; Prepare the syntax table:\r
+ (and set-st\r
+ (if (not ender) ; m/blah/, s/x//, s/x/y/\r
+ (modify-syntax-entry starter "$" st)\r
+ (modify-syntax-entry starter (concat "(" (list ender)) st)\r
+ (modify-syntax-entry ender (concat ")" (list starter)) st)))\r
+ (condition-case bb\r
+ (progn\r
+ ;; We use `$' syntax class to find matching stuff, but $$\r
+ ;; is recognized the same as $, so we need to check this manually.\r
+ (if (and (eq starter (char-after (cperl-1+ b)))\r
+ (not ender))\r
+ ;; $ has TeXish matching rules, so $$ equiv $...\r
+ (forward-char 2)\r
+ (setq reset-st (syntax-table))\r
+ (set-syntax-table st)\r
+ (forward-sexp 1)\r
+ (if (<= (point) (1+ b))\r
+ (error "Unfinished regular expression"))\r
+ (set-syntax-table reset-st)\r
+ (setq reset-st nil)\r
+ ;; Now the problem is with m;blah;;\r
+ (and (not ender)\r
+ (eq (preceding-char)\r
+ (char-after (- (point) 2)))\r
+ (save-excursion\r
+ (forward-char -2)\r
+ (= 0 (% (skip-chars-backward "\\\\") 2)))\r
+ (forward-char -1)))\r
+ ;; Now we are after the first part.\r
+ (and is-2arg ; Have trailing part\r
+ (not ender)\r
+ (eq (following-char) starter) ; Empty trailing part\r
+ (progn\r
+ (or (eq (char-syntax (following-char)) ?.)\r
+ ;; Make trailing letter into punctuation\r
+ (cperl-modify-syntax-type (point) cperl-st-punct))\r
+ (setq is-2arg nil go-forward t))) ; Ignore the tail\r
+ (if is-2arg ; Not number => have second part\r
+ (progn\r
+ (setq i (point) i2 i)\r
+ (if ender\r
+ (if (memq (following-char) '(?\ ?\t ?\n ?\f))\r
+ (progn\r
+ (if (looking-at "[ \t\n\f]+\\(#[^\n]*\n[ \t\n\f]*\\)+")\r
+ (goto-char (match-end 0))\r
+ (skip-chars-forward " \t\n\f"))\r
+ (setq i2 (point))))\r
+ (forward-char -1))\r
+ (modify-syntax-entry starter (if (eq starter ?\\) "\\" ".") st)\r
+ (if ender (modify-syntax-entry ender "." st))\r
+ (setq set-st nil)\r
+ (setq ender (cperl-forward-re lim end nil t st-l err-l\r
+ argument starter ender)\r
+ ender (nth 2 ender)))))\r
+ (error (goto-char lim)\r
+ (setq set-st nil)\r
+ (if reset-st\r
+ (set-syntax-table reset-st))\r
+ (or end\r
+ (message\r
+ "End of `%s%s%c ... %c' string/RE not found: %s"\r
+ argument\r
+ (if ostart (format "%c ... %c" ostart (or oend ostart)) "")\r
+ starter (or ender starter) bb)\r
+ (or (car err-l) (setcar err-l b)))))\r
+ (if set-st\r
+ (progn\r
+ (modify-syntax-entry starter (if (eq starter ?\\) "\\" ".") st)\r
+ (if ender (modify-syntax-entry ender "." st))))\r
+ ;; i: have 2 args, after end of the first arg\r
+ ;; i2: start of the second arg, if any (before delim iff `ender').\r
+ ;; ender: the last arg bounded by parens-like chars, the second one of them\r
+ ;; starter: the starting delimiter of the first arg\r
+ ;; go-forward: has 2 args, and the second part is empty\r
+ (list i i2 ender starter go-forward)))\r
+\r
+(defvar font-lock-string-face)\r
+;;(defvar font-lock-reference-face)\r
+(defvar font-lock-constant-face)\r
+(defsubst cperl-postpone-fontification (b e type val &optional now)\r
+ ;; Do after syntactic fontification?\r
+ (if cperl-syntaxify-by-font-lock\r
+ (or now (put-text-property b e 'cperl-postpone (cons type val)))\r
+ (put-text-property b e type val)))\r
+\r
+;;; Here is how the global structures (those which cannot be\r
+;;; recognized locally) are marked:\r
+;; a) PODs:\r
+;; Start-to-end is marked `in-pod' ==> t\r
+;; Each non-literal part is marked `syntax-type' ==> `pod'\r
+;; Each literal part is marked `syntax-type' ==> `in-pod'\r
+;; b) HEREs:\r
+;; Start-to-end is marked `here-doc-group' ==> t\r
+;; The body is marked `syntax-type' ==> `here-doc'\r
+;; The delimiter is marked `syntax-type' ==> `here-doc-delim'\r
+;; c) FORMATs:\r
+;; First line (to =) marked `first-format-line' ==> t\r
+;; After-this--to-end is marked `syntax-type' ==> `format'\r
+;; d) 'Q'uoted string:\r
+;; part between markers inclusive is marked `syntax-type' ==> `string'\r
+;; part between `q' and the first marker is marked `syntax-type' ==> `prestring'\r
+\r
+(defun cperl-unwind-to-safe (before &optional end)\r
+ ;; if BEFORE, go to the previous start-of-line on each step of unwinding\r
+ (let ((pos (point)) opos)\r
+ (setq opos pos)\r
+ (while (and pos (get-text-property pos 'syntax-type))\r
+ (setq pos (previous-single-property-change pos 'syntax-type))\r
+ (if pos\r
+ (if before\r
+ (progn\r
+ (goto-char (cperl-1- pos))\r
+ (beginning-of-line)\r
+ (setq pos (point)))\r
+ (goto-char (setq pos (cperl-1- pos))))\r
+ ;; Up to the start\r
+ (goto-char (point-min))))\r
+ ;; Skip empty lines\r
+ (and (looking-at "\n*=")\r
+ (/= 0 (skip-chars-backward "\n"))\r
+ (forward-char))\r
+ (setq pos (point))\r
+ (if end\r
+ ;; Do the same for end, going small steps\r
+ (progn\r
+ (while (and end (get-text-property end 'syntax-type))\r
+ (setq pos end\r
+ end (next-single-property-change end 'syntax-type)))\r
+ (or end pos)))))\r
+\r
+(defvar cperl-nonoverridable-face)\r
+(defvar font-lock-function-name-face)\r
+(defvar font-lock-comment-face)\r
+\r
+(defun cperl-find-pods-heres (&optional min max non-inter end ignore-max)\r
+ "Scans the buffer for hard-to-parse Perl constructions.\r
+If `cperl-pod-here-fontify' is not-nil after evaluation, will fontify\r
+the sections using `cperl-pod-head-face', `cperl-pod-face',\r
+`cperl-here-face'."\r
+ (interactive)\r
+ (or min (setq min (point-min)\r
+ cperl-syntax-state nil\r
+ cperl-syntax-done-to min))\r
+ (or max (setq max (point-max)))\r
+ (let* ((cperl-pod-here-fontify (eval cperl-pod-here-fontify)) go tmpend\r
+ face head-face here-face b e bb tag qtag b1 e1 argument i c tail tb\r
+ is-REx is-x-REx REx-comment-start REx-comment-end was-comment i2\r
+ (case-fold-search nil) (inhibit-read-only t) (buffer-undo-list t)\r
+ (modified (buffer-modified-p))\r
+ (after-change-functions nil)\r
+ (use-syntax-state (and cperl-syntax-state\r
+ (>= min (car cperl-syntax-state))))\r
+ (state-point (if use-syntax-state\r
+ (car cperl-syntax-state)\r
+ (point-min)))\r
+ (state (if use-syntax-state\r
+ (cdr cperl-syntax-state)))\r
+ ;; (st-l '(nil)) (err-l '(nil)) ; Would overwrite - propagates from a function call to a function call!\r
+ (st-l (list nil)) (err-l (list nil))\r
+ ;; Somehow font-lock may be not loaded yet...\r
+ (font-lock-string-face (if (boundp 'font-lock-string-face)\r
+ font-lock-string-face\r
+ 'font-lock-string-face))\r
+ (font-lock-constant-face (if (boundp 'font-lock-constant-face)\r
+ font-lock-constant-face\r
+ 'font-lock-constant-face))\r
+ (font-lock-function-name-face\r
+ (if (boundp 'font-lock-function-name-face)\r
+ font-lock-function-name-face\r
+ 'font-lock-function-name-face))\r
+ (font-lock-comment-face\r
+ (if (boundp 'font-lock-comment-face)\r
+ font-lock-comment-face\r
+ 'font-lock-comment-face))\r
+ (cperl-nonoverridable-face\r
+ (if (boundp 'cperl-nonoverridable-face)\r
+ cperl-nonoverridable-face\r
+ 'cperl-nonoverridable-face))\r
+ (stop-point (if ignore-max\r
+ (point-max)\r
+ max))\r
+ (search\r
+ (concat\r
+ "\\(\\`\n?\\|^\n\\)="\r
+ "\\|"\r
+ ;; One extra () before this:\r
+ "<<"\r
+ "\\(" ; 1 + 1\r
+ ;; First variant "BLAH" or just ``.\r
+ "[ \t]*" ; Yes, whitespace is allowed!\r
+ "\\([\"'`]\\)" ; 2 + 1 = 3\r
+ "\\([^\"'`\n]*\\)" ; 3 + 1\r
+ "\\3"\r
+ "\\|"\r
+ ;; Second variant: Identifier or \ID (same as 'ID') or empty\r
+ "\\\\?\\(\\([a-zA-Z_][a-zA-Z_0-9]*\\)?\\)" ; 4 + 1, 5 + 1\r
+ ;; Do not have <<= or << 30 or <<30 or << $blah.\r
+ ;; "\\([^= \t0-9$@%&]\\|[ \t]+[^ \t\n0-9$@%&]\\)" ; 6 + 1\r
+ "\\(\\)" ; To preserve count of pars :-( 6 + 1\r
+ "\\)"\r
+ "\\|"\r
+ ;; 1+6 extra () before this:\r
+ "^[ \t]*\\(format\\)[ \t]*\\([a-zA-Z0-9_]+\\)?[ \t]*=[ \t]*$"\r
+ (if cperl-use-syntax-table-text-property\r
+ (concat\r
+ "\\|"\r
+ ;; 1+6+2=9 extra () before this:\r
+ "\\<\\(q[wxqr]?\\|[msy]\\|tr\\)\\>"\r
+ "\\|"\r
+ ;; 1+6+2+1=10 extra () before this:\r
+ "\\([?/<]\\)" ; /blah/ or ?blah? or <file*glob>\r
+ "\\|"\r
+ ;; 1+6+2+1+1=11 extra () before this:\r
+ "\\<sub\\>[ \t]*\\([a-zA-Z_:'0-9]+[ \t]*\\)?\\(([^()]*)\\)"\r
+ "\\|"\r
+ ;; 1+6+2+1+1+2=13 extra () before this:\r
+ "\\$\\(['{]\\)"\r
+ "\\|"\r
+ ;; 1+6+2+1+1+2+1=14 extra () before this:\r
+ "\\(\\<sub[ \t\n\f]+\\|[&*$@%]\\)[a-zA-Z0-9_]*'"\r
+ ;; 1+6+2+1+1+2+1+1=15 extra () before this:\r
+ "\\|"\r
+ "__\\(END\\|DATA\\)__"\r
+ ;; 1+6+2+1+1+2+1+1+1=16 extra () before this:\r
+ "\\|"\r
+ "\\\\\\(['`\"($]\\)")\r
+ ""))))\r
+ (unwind-protect\r
+ (progn\r
+ (save-excursion\r
+ (or non-inter\r
+ (message "Scanning for \"hard\" Perl constructions..."))\r
+ (and cperl-pod-here-fontify\r
+ ;; We had evals here, do not know why...\r
+ (setq face cperl-pod-face\r
+ head-face cperl-pod-head-face\r
+ here-face cperl-here-face))\r
+ (remove-text-properties min max\r
+ '(syntax-type t in-pod t syntax-table t\r
+ cperl-postpone t\r
+ syntax-subtype t\r
+ rear-nonsticky t\r
+ here-doc-group t\r
+ first-format-line t\r
+ indentable t))\r
+ ;; Need to remove face as well...\r
+ (goto-char min)\r
+ (and (eq system-type 'emx)\r
+ (looking-at "extproc[ \t]") ; Analogue of #!\r
+ (cperl-commentify min\r
+ (save-excursion (end-of-line) (point))\r
+ nil))\r
+ (while (and\r
+ (< (point) max)\r
+ (re-search-forward search max t))\r
+ (setq tmpend nil) ; Valid for most cases\r
+ (cond\r
+ ((match-beginning 1) ; POD section\r
+ ;; "\\(\\`\n?\\|^\n\\)="\r
+ (if (looking-at "cut\\>")\r
+ (if ignore-max\r
+ nil ; Doing a chunk only\r
+ (message "=cut is not preceded by a POD section")\r
+ (or (car err-l) (setcar err-l (point))))\r
+ (beginning-of-line)\r
+\r
+ (setq b (point)\r
+ bb b\r
+ tb (match-beginning 0)\r
+ b1 nil) ; error condition\r
+ ;; We do not search to max, since we may be called from\r
+ ;; some hook of fontification, and max is random\r
+ (or (re-search-forward "^\n=cut\\>" stop-point 'toend)\r
+ (progn\r
+ (goto-char b)\r
+ (if (re-search-forward "\n=cut\\>" stop-point 'toend)\r
+ (progn\r
+ (message "=cut is not preceded by an empty line")\r
+ (setq b1 t)\r
+ (or (car err-l) (setcar err-l b))))))\r
+ (beginning-of-line 2) ; An empty line after =cut is not POD!\r
+ (setq e (point))\r
+ (and (> e max)\r
+ (progn\r
+ (remove-text-properties\r
+ max e '(syntax-type t in-pod t syntax-table t\r
+ cperl-postpone t\r
+ syntax-subtype t\r
+ here-doc-group t\r
+ rear-nonsticky t\r
+ first-format-line t\r
+ indentable t))\r
+ (setq tmpend tb)))\r
+ (put-text-property b e 'in-pod t)\r
+ (put-text-property b e 'syntax-type 'in-pod)\r
+ (goto-char b)\r
+ (while (re-search-forward "\n\n[ \t]" e t)\r
+ ;; We start 'pod 1 char earlier to include the preceding line\r
+ (beginning-of-line)\r
+ (put-text-property (cperl-1- b) (point) 'syntax-type 'pod)\r
+ (cperl-put-do-not-fontify b (point) t)\r
+ ;; mark the non-literal parts as PODs\r
+ (if cperl-pod-here-fontify\r
+ (cperl-postpone-fontification b (point) 'face face t))\r
+ (re-search-forward "\n\n[^ \t\f\n]" e 'toend)\r
+ (beginning-of-line)\r
+ (setq b (point)))\r
+ (put-text-property (cperl-1- (point)) e 'syntax-type 'pod)\r
+ (cperl-put-do-not-fontify (point) e t)\r
+ (if cperl-pod-here-fontify\r
+ (progn\r
+ ;; mark the non-literal parts as PODs\r
+ (cperl-postpone-fontification (point) e 'face face t)\r
+ (goto-char bb)\r
+ (if (looking-at\r
+ "=[a-zA-Z0-9_]+\\>[ \t]*\\(\\(\n?[^\n]\\)+\\)$")\r
+ ;; mark the headers\r
+ (cperl-postpone-fontification\r
+ (match-beginning 1) (match-end 1)\r
+ 'face head-face))\r
+ (while (re-search-forward\r
+ ;; One paragraph\r
+ "^\n=[a-zA-Z0-9_]+\\>[ \t]*\\(\\(\n?[^\n]\\)+\\)$"\r
+ e 'toend)\r
+ ;; mark the headers\r
+ (cperl-postpone-fontification\r
+ (match-beginning 1) (match-end 1)\r
+ 'face head-face))))\r
+ (cperl-commentify bb e nil)\r
+ (goto-char e)\r
+ (or (eq e (point-max))\r
+ (forward-char -1)))) ; Prepare for immediate POD start.\r
+ ;; Here document\r
+ ;; We do only one here-per-line\r
+ ;; ;; One extra () before this:\r
+ ;;"<<"\r
+ ;; "\\(" ; 1 + 1\r
+ ;; ;; First variant "BLAH" or just ``.\r
+ ;; "[ \t]*" ; Yes, whitespace is allowed!\r
+ ;; "\\([\"'`]\\)" ; 2 + 1\r
+ ;; "\\([^\"'`\n]*\\)" ; 3 + 1\r
+ ;; "\\3"\r
+ ;; "\\|"\r
+ ;; ;; Second variant: Identifier or \ID or empty\r
+ ;; "\\\\?\\(\\([a-zA-Z_][a-zA-Z_0-9]*\\)?\\)" ; 4 + 1, 5 + 1\r
+ ;; ;; Do not have <<= or << 30 or <<30 or << $blah.\r
+ ;; ;; "\\([^= \t0-9$@%&]\\|[ \t]+[^ \t\n0-9$@%&]\\)" ; 6 + 1\r
+ ;; "\\(\\)" ; To preserve count of pars :-( 6 + 1\r
+ ;; "\\)"\r
+ ((match-beginning 2) ; 1 + 1\r
+ ;; Abort in comment:\r
+ (setq b (point))\r
+ (setq state (parse-partial-sexp state-point b nil nil state)\r
+ state-point b\r
+ tb (match-beginning 0)\r
+ i (or (nth 3 state) (nth 4 state)))\r
+ (if i\r
+ (setq c t)\r
+ (setq c (and\r
+ (match-beginning 5)\r
+ (not (match-beginning 6)) ; Empty\r
+ (looking-at\r
+ "[ \t]*[=0-9$@%&(]"))))\r
+ (if c ; Not here-doc\r
+ nil ; Skip it.\r
+ (if (match-beginning 5) ;4 + 1\r
+ (setq b1 (match-beginning 5) ; 4 + 1\r
+ e1 (match-end 5)) ; 4 + 1\r
+ (setq b1 (match-beginning 4) ; 3 + 1\r
+ e1 (match-end 4))) ; 3 + 1\r
+ (setq tag (buffer-substring b1 e1)\r
+ qtag (regexp-quote tag))\r
+ (cond (cperl-pod-here-fontify\r
+ ;; Highlight the starting delimiter\r
+ (cperl-postpone-fontification b1 e1 'face font-lock-constant-face)\r
+ (cperl-put-do-not-fontify b1 e1 t)))\r
+ (forward-line)\r
+ (setq b (point))\r
+ ;; We do not search to max, since we may be called from\r
+ ;; some hook of fontification, and max is random\r
+ (or (and (re-search-forward (concat "^" qtag "$")\r
+ stop-point 'toend)\r
+ (eq (following-char) ?\n))\r
+ (progn ; Pretend we matched at the end\r
+ (goto-char (point-max))\r
+ (re-search-forward "\\'")\r
+ (message "End of here-document `%s' not found." tag)\r
+ (or (car err-l) (setcar err-l b))))\r
+ (if cperl-pod-here-fontify\r
+ (progn\r
+ ;; Highlight the ending delimiter\r
+ (cperl-postpone-fontification (match-beginning 0) (match-end 0)\r
+ 'face font-lock-constant-face)\r
+ (cperl-put-do-not-fontify b (match-end 0) t)\r
+ ;; Highlight the HERE-DOC\r
+ (cperl-postpone-fontification b (match-beginning 0)\r
+ 'face here-face)))\r
+ (setq e1 (cperl-1+ (match-end 0)))\r
+ (put-text-property b (match-beginning 0)\r
+ 'syntax-type 'here-doc)\r
+ (put-text-property (match-beginning 0) e1\r
+ 'syntax-type 'here-doc-delim)\r
+ (put-text-property b e1\r
+ 'here-doc-group t)\r
+ (cperl-commentify b e1 nil)\r
+ (cperl-put-do-not-fontify b (match-end 0) t)\r
+ (if (> e1 max)\r
+ (setq tmpend tb))))\r
+ ;; format\r
+ ((match-beginning 8)\r
+ ;; 1+6=7 extra () before this:\r
+ ;;"^[ \t]*\\(format\\)[ \t]*\\([a-zA-Z0-9_]+\\)?[ \t]*=[ \t]*$"\r
+ (setq b (point)\r
+ name (if (match-beginning 8) ; 7 + 1\r
+ (buffer-substring (match-beginning 8) ; 7 + 1\r
+ (match-end 8)) ; 7 + 1\r
+ "")\r
+ tb (match-beginning 0))\r
+ (setq argument nil)\r
+ (put-text-property (save-excursion\r
+ (beginning-of-line)\r
+ (point))\r
+ b 'first-format-line 't)\r
+ (if cperl-pod-here-fontify\r
+ (while (and (eq (forward-line) 0)\r
+ (not (looking-at "^[.;]$")))\r
+ (cond\r
+ ((looking-at "^#")) ; Skip comments\r
+ ((and argument ; Skip argument multi-lines\r
+ (looking-at "^[ \t]*{"))\r
+ (forward-sexp 1)\r
+ (setq argument nil))\r
+ (argument ; Skip argument lines\r
+ (setq argument nil))\r
+ (t ; Format line\r
+ (setq b1 (point))\r
+ (setq argument (looking-at "^[^\n]*[@^]"))\r
+ (end-of-line)\r
+ ;; Highlight the format line\r
+ (cperl-postpone-fontification b1 (point)\r
+ 'face font-lock-string-face)\r
+ (cperl-commentify b1 (point) nil)\r
+ (cperl-put-do-not-fontify b1 (point) t))))\r
+ ;; We do not search to max, since we may be called from\r
+ ;; some hook of fontification, and max is random\r
+ (re-search-forward "^[.;]$" stop-point 'toend))\r
+ (beginning-of-line)\r
+ (if (looking-at "^\\.$") ; ";" is not supported yet\r
+ (progn\r
+ ;; Highlight the ending delimiter\r
+ (cperl-postpone-fontification (point) (+ (point) 2)\r
+ 'face font-lock-string-face)\r
+ (cperl-commentify (point) (+ (point) 2) nil)\r
+ (cperl-put-do-not-fontify (point) (+ (point) 2) t))\r
+ (message "End of format `%s' not found." name)\r
+ (or (car err-l) (setcar err-l b)))\r
+ (forward-line)\r
+ (if (> (point) max)\r
+ (setq tmpend tb))\r
+ (put-text-property b (point) 'syntax-type 'format))\r
+ ;; Regexp:\r
+ ((or (match-beginning 10) (match-beginning 11))\r
+ ;; 1+6+2=9 extra () before this:\r
+ ;; "\\<\\(q[wxqr]?\\|[msy]\\|tr\\)\\>"\r
+ ;; "\\|"\r
+ ;; "\\([?/<]\\)" ; /blah/ or ?blah? or <file*glob>\r
+ (setq b1 (if (match-beginning 10) 10 11)\r
+ argument (buffer-substring\r
+ (match-beginning b1) (match-end b1))\r
+ b (point)\r
+ i b\r
+ c (char-after (match-beginning b1))\r
+ bb (char-after (1- (match-beginning b1))) ; tmp holder\r
+ ;; bb == "Not a stringy"\r
+ bb (if (eq b1 10) ; user variables/whatever\r
+ (and (memq bb (append "$@%*#_:-&>" nil)) ; $#y)\r
+ (cond ((eq bb ?-) (eq c ?s)) ; -s file test\r
+ ((eq bb ?\:) ; $opt::s\r
+ (eq (char-after\r
+ (- (match-beginning b1) 2))\r
+ ?\:))\r
+ ((eq bb ?\>) ; $foo->s\r
+ (eq (char-after\r
+ (- (match-beginning b1) 2))\r
+ ?\-))\r
+ ((eq bb ?\&)\r
+ (not (eq (char-after ; &&m/blah/\r
+ (- (match-beginning b1) 2))\r
+ ?\&)))\r
+ (t t)))\r
+ ;; <file> or <$file>\r
+ (and (eq c ?\<)\r
+ ;; Do not stringify <FH>, <$fh> :\r
+ (save-match-data\r
+ (looking-at\r
+ "\\$?\\([_a-zA-Z:][_a-zA-Z0-9:]*\\)?>"))))\r
+ tb (match-beginning 0))\r
+ (goto-char (match-beginning b1))\r
+ (cperl-backward-to-noncomment (point-min))\r
+ (or bb\r
+ (if (eq b1 11) ; bare /blah/ or ?blah? or <foo>\r
+ (setq argument ""\r
+ b1 nil\r
+ bb ; Not a regexp?\r
+ (progn\r
+ (not\r
+ ;; What is below: regexp-p?\r
+ (and\r
+ (or (memq (preceding-char)\r
+ (append (if (memq c '(?\? ?\<))\r
+ ;; $a++ ? 1 : 2\r
+ "~{(=|&*!,;:"\r
+ "~{(=|&+-*!,;:") nil))\r
+ (and (eq (preceding-char) ?\})\r
+ (cperl-after-block-p (point-min)))\r
+ (and (eq (char-syntax (preceding-char)) ?w)\r
+ (progn\r
+ (forward-sexp -1)\r
+;;; After these keywords `/' starts a RE. One should add all the\r
+;;; functions/builtins which expect an argument, but ...\r
+ (if (eq (preceding-char) ?-)\r
+ ;; -d ?foo? is a RE\r
+ (looking-at "[a-zA-Z]\\>")\r
+ (and\r
+ (not (memq (preceding-char)\r
+ '(?$ ?@ ?& ?%)))\r
+ (looking-at\r
+ "\\(while\\|if\\|unless\\|until\\|and\\|or\\|not\\|xor\\|split\\|grep\\|map\\|print\\)\\>")))))\r
+ (and (eq (preceding-char) ?.)\r
+ (eq (char-after (- (point) 2)) ?.))\r
+ (bobp))\r
+ ;; m|blah| ? foo : bar;\r
+ (not\r
+ (and (eq c ?\?)\r
+ cperl-use-syntax-table-text-property\r
+ (not (bobp))\r
+ (progn\r
+ (forward-char -1)\r
+ (looking-at "\\s|")))))))\r
+ b (1- b))\r
+ ;; s y tr m\r
+ ;; Check for $a -> y\r
+ (setq b1 (preceding-char)\r
+ go (point))\r
+ (if (and (eq b1 ?>)\r
+ (eq (char-after (- go 2)) ?-))\r
+ ;; Not a regexp\r
+ (setq bb t))))\r
+ (or bb (setq state (parse-partial-sexp\r
+ state-point b nil nil state)\r
+ state-point b))\r
+ (setq bb (or bb (nth 3 state) (nth 4 state)))\r
+ (goto-char b)\r
+ (or bb\r
+ (progn\r
+ (if (looking-at "[ \t\n\f]+\\(#[^\n]*\n[ \t\n\f]*\\)+")\r
+ (goto-char (match-end 0))\r
+ (skip-chars-forward " \t\n\f"))\r
+ (cond ((and (eq (following-char) ?\})\r
+ (eq b1 ?\{))\r
+ ;; Check for $a[23]->{ s }, @{s} and *{s::foo}\r
+ (goto-char (1- go))\r
+ (skip-chars-backward " \t\n\f")\r
+ (if (memq (preceding-char) (append "$@%&*" nil))\r
+ (setq bb t) ; @{y}\r
+ (condition-case nil\r
+ (forward-sexp -1)\r
+ (error nil)))\r
+ (if (or bb\r
+ (looking-at ; $foo -> {s}\r
+ "[$@]\\$*\\([a-zA-Z0-9_:]+\\|[^{]\\)\\([ \t\n]*->\\)?[ \t\n]*{")\r
+ (and ; $foo[12] -> {s}\r
+ (memq (following-char) '(?\{ ?\[))\r
+ (progn\r
+ (forward-sexp 1)\r
+ (looking-at "\\([ \t\n]*->\\)?[ \t\n]*{"))))\r
+ (setq bb t)\r
+ (goto-char b)))\r
+ ((and (eq (following-char) ?=)\r
+ (eq (char-after (1+ (point))) ?\>))\r
+ ;; Check for { foo => 1, s => 2 }\r
+ ;; Apparently s=> is never a substitution...\r
+ (setq bb t))\r
+ ((and (eq (following-char) ?:)\r
+ (eq b1 ?\{) ; Check for $ { s::bar }\r
+ (looking-at "::[a-zA-Z0-9_:]*[ \t\n\f]*}")\r
+ (progn \r
+ (goto-char (1- go))\r
+ (skip-chars-backward " \t\n\f")\r
+ (memq (preceding-char)\r
+ (append "$@%&*" nil))))\r
+ (setq bb t)))))\r
+ (if bb\r
+ (goto-char i)\r
+ ;; Skip whitespace and comments...\r
+ (if (looking-at "[ \t\n\f]+\\(#[^\n]*\n[ \t\n\f]*\\)+")\r
+ (goto-char (match-end 0))\r
+ (skip-chars-forward " \t\n\f"))\r
+ (if (> (point) b)\r
+ (put-text-property b (point) 'syntax-type 'prestring))\r
+ ;; qtag means two-arg matcher, may be reset to\r
+ ;; 2 or 3 later if some special quoting is needed.\r
+ ;; e1 means matching-char matcher.\r
+ (setq b (point)\r
+ ;; has 2 args\r
+ i2 (string-match "^\\([sy]\\|tr\\)$" argument)\r
+ ;; We do not search to max, since we may be called from\r
+ ;; some hook of fontification, and max is random\r
+ i (cperl-forward-re stop-point end\r
+ i2\r
+ t st-l err-l argument)\r
+ ;; Note that if `go', then it is considered as 1-arg\r
+ b1 (nth 1 i) ; start of the second part\r
+ tag (nth 2 i) ; ender-char, true if second part\r
+ ; is with matching chars []\r
+ go (nth 4 i) ; There is a 1-char part after the end\r
+ i (car i) ; intermediate point\r
+ e1 (point) ; end\r
+ ;; Before end of the second part if non-matching: ///\r
+ tail (if (and i (not tag))\r
+ (1- e1))\r
+ e (if i i e1) ; end of the first part\r
+ qtag nil ; need to preserve backslashitis\r
+ is-x-REx nil) ; REx has //x modifier\r
+ ;; Commenting \\ is dangerous, what about ( ?\r
+ (and i tail\r
+ (eq (char-after i) ?\\)\r
+ (setq qtag t))\r
+ (if (looking-at "\\sw*x") ; qr//x\r
+ (setq is-x-REx t))\r
+ (if (null i)\r
+ ;; Considered as 1arg form\r
+ (progn\r
+ (cperl-commentify b (point) t)\r
+ (put-text-property b (point) 'syntax-type 'string)\r
+ (if (or is-x-REx\r
+ ;; ignore other text properties:\r
+ (string-match "^qw$" argument))\r
+ (put-text-property b (point) 'indentable t))\r
+ (and go\r
+ (setq e1 (cperl-1+ e1))\r
+ (or (eobp)\r
+ (forward-char 1))))\r
+ (cperl-commentify b i t)\r
+ (if (looking-at "\\sw*e") ; s///e\r
+ (progn\r
+ (and\r
+ ;; silent:\r
+ (cperl-find-pods-heres b1 (1- (point)) t end)\r
+ ;; Error\r
+ (goto-char (1+ max)))\r
+ (if (and tag (eq (preceding-char) ?\>))\r
+ (progn\r
+ (cperl-modify-syntax-type (1- (point)) cperl-st-ket)\r
+ (cperl-modify-syntax-type i cperl-st-bra)))\r
+ (put-text-property b i 'syntax-type 'string)\r
+ (if is-x-REx\r
+ (put-text-property b i 'indentable t)))\r
+ (cperl-commentify b1 (point) t)\r
+ (put-text-property b (point) 'syntax-type 'string)\r
+ (if is-x-REx\r
+ (put-text-property b i 'indentable t))\r
+ (if qtag\r
+ (cperl-modify-syntax-type (1+ i) cperl-st-punct))\r
+ (setq tail nil)))\r
+ ;; Now: tail: if the second part is non-matching without ///e\r
+ (if (eq (char-syntax (following-char)) ?w)\r
+ (progn\r
+ (forward-word 1) ; skip modifiers s///s\r
+ (if tail (cperl-commentify tail (point) t))\r
+ (cperl-postpone-fontification\r
+ e1 (point) 'face 'cperl-nonoverridable-face)))\r
+ ;; Check whether it is m// which means "previous match"\r
+ ;; and highlight differently\r
+ (setq is-REx\r
+ (and (string-match "^\\([sm]?\\|qr\\)$" argument)\r
+ (or (not (= (length argument) 0))\r
+ (not (eq c ?\<)))))\r
+ (if (and is-REx\r
+ (eq e (+ 2 b))\r
+ ;; split // *is* using zero-pattern\r
+ (save-excursion\r
+ (condition-case nil\r
+ (progn\r
+ (goto-char tb)\r
+ (forward-sexp -1)\r
+ (not (looking-at "split\\>")))\r
+ (error t))))\r
+ (cperl-postpone-fontification\r
+ b e 'face font-lock-function-name-face)\r
+ (if (or i2 ; Has 2 args\r
+ (and cperl-fontify-m-as-s\r
+ (or\r
+ (string-match "^\\(m\\|qr\\)$" argument)\r
+ (and (eq 0 (length argument))\r
+ (not (eq ?\< (char-after b)))))))\r
+ (progn\r
+ (cperl-postpone-fontification\r
+ b (cperl-1+ b) 'face font-lock-constant-face)\r
+ (cperl-postpone-fontification\r
+ (1- e) e 'face font-lock-constant-face)))\r
+ (if (and is-REx cperl-regexp-scan)\r
+ ;; Process RExen better\r
+ (save-excursion\r
+ (goto-char (1+ b))\r
+ (while\r
+ (and (< (point) e)\r
+ (re-search-forward\r
+ (if is-x-REx\r
+ (if (eq (char-after b) ?\#)\r
+ "\\((\\?\\\\#\\)\\|\\(\\\\#\\)"\r
+ "\\((\\?#\\)\\|\\(#\\)")\r
+ (if (eq (char-after b) ?\#)\r
+ "\\((\\?\\\\#\\)"\r
+ "\\((\\?#\\)"))\r
+ (1- e) 'to-end))\r
+ (goto-char (match-beginning 0))\r
+ (setq REx-comment-start (point)\r
+ was-comment t)\r
+ (if (save-excursion\r
+ (and\r
+ ;; XXX not working if outside delimiter is #\r
+ (eq (preceding-char) ?\\)\r
+ (= (% (skip-chars-backward "$\\\\") 2) -1)))\r
+ ;; Not a comment, avoid loop:\r
+ (progn (setq was-comment nil)\r
+ (forward-char 1))\r
+ (if (match-beginning 2)\r
+ (progn\r
+ (beginning-of-line 2)\r
+ (if (> (point) e)\r
+ (goto-char (1- e))))\r
+ ;; Works also if the outside delimiters are ().\r
+ (or (search-forward ")" (1- e) 'toend)\r
+ (message\r
+ "Couldn't find end of (?#...)-comment in a REx, pos=%s"\r
+ REx-comment-start))))\r
+ (if (>= (point) e)\r
+ (goto-char (1- e)))\r
+ (if was-comment\r
+ (progn\r
+ (setq REx-comment-end (point))\r
+ (cperl-commentify\r
+ REx-comment-start REx-comment-end nil)\r
+ (cperl-postpone-fontification\r
+ REx-comment-start REx-comment-end\r
+ 'face font-lock-comment-face))))))\r
+ (if (and is-REx is-x-REx)\r
+ (put-text-property (1+ b) (1- e)\r
+ 'syntax-subtype 'x-REx)))\r
+ (if i2\r
+ (progn\r
+ (cperl-postpone-fontification\r
+ (1- e1) e1 'face font-lock-constant-face)\r
+ (if (assoc (char-after b) cperl-starters)\r
+ (cperl-postpone-fontification\r
+ b1 (1+ b1) 'face font-lock-constant-face))))\r
+ (if (> (point) max)\r
+ (setq tmpend tb))))\r
+ ((match-beginning 13) ; sub with prototypes\r
+ (setq b (match-beginning 0))\r
+ (if (memq (char-after (1- b))\r
+ '(?\$ ?\@ ?\% ?\& ?\*))\r
+ nil\r
+ (setq state (parse-partial-sexp\r
+ state-point b nil nil state)\r
+ state-point b)\r
+ (if (or (nth 3 state) (nth 4 state))\r
+ nil\r
+ ;; Mark as string\r
+ (cperl-commentify (match-beginning 13) (match-end 13) t))\r
+ (goto-char (match-end 0))))\r
+ ;; 1+6+2+1+1+2=13 extra () before this:\r
+ ;; "\\$\\(['{]\\)"\r
+ ((and (match-beginning 14)\r
+ (eq (preceding-char) ?\')) ; $'\r
+ (setq b (1- (point))\r
+ state (parse-partial-sexp\r
+ state-point (1- b) nil nil state)\r
+ state-point (1- b))\r
+ (if (nth 3 state) ; in string\r
+ (cperl-modify-syntax-type (1- b) cperl-st-punct))\r
+ (goto-char (1+ b)))\r
+ ;; 1+6+2+1+1+2=13 extra () before this:\r
+ ;; "\\$\\(['{]\\)"\r
+ ((match-beginning 14) ; ${\r
+ (setq bb (match-beginning 0))\r
+ (cperl-modify-syntax-type bb cperl-st-punct))\r
+ ;; 1+6+2+1+1+2+1=14 extra () before this:\r
+ ;; "\\(\\<sub[ \t\n\f]+\\|[&*$@%]\\)[a-zA-Z0-9_]*'")\r
+ ((match-beginning 15) ; old $abc'efg syntax\r
+ (setq bb (match-end 0)\r
+ b (match-beginning 0)\r
+ state (parse-partial-sexp\r
+ state-point b nil nil state)\r
+ state-point b)\r
+ (if (nth 3 state) ; in string\r
+ nil\r
+ (put-text-property (1- bb) bb 'syntax-table cperl-st-word))\r
+ (goto-char bb))\r
+ ;; 1+6+2+1+1+2+1+1=15 extra () before this:\r
+ ;; "__\\(END\\|DATA\\)__"\r
+ ((match-beginning 16) ; __END__, __DATA__\r
+ (setq bb (match-end 0)\r
+ b (match-beginning 0)\r
+ state (parse-partial-sexp\r
+ state-point b nil nil state)\r
+ state-point b)\r
+ (if (or (nth 3 state) (nth 4 state))\r
+ nil\r
+ ;; (put-text-property b (1+ bb) 'syntax-type 'pod) ; Cheat\r
+ (cperl-commentify b bb nil)\r
+ (setq end t))\r
+ (goto-char bb))\r
+ ((match-beginning 17) ; "\\\\\\(['`\"($]\\)"\r
+ ;; Trailing backslash ==> non-quoting outside string/comment\r
+ (setq bb (match-end 0)\r
+ b (match-beginning 0))\r
+ (goto-char b)\r
+ (skip-chars-backward "\\\\")\r
+ ;;;(setq i2 (= (% (skip-chars-backward "\\\\") 2) -1))\r
+ (setq state (parse-partial-sexp\r
+ state-point b nil nil state)\r
+ state-point b)\r
+ (if (or (nth 3 state) (nth 4 state) )\r
+ nil\r
+ (cperl-modify-syntax-type b cperl-st-punct))\r
+ (goto-char bb))\r
+ (t (error "Error in regexp of the sniffer")))\r
+ (if (> (point) stop-point)\r
+ (progn\r
+ (if end\r
+ (message "Garbage after __END__/__DATA__ ignored")\r
+ (message "Unbalanced syntax found while scanning")\r
+ (or (car err-l) (setcar err-l b)))\r
+ (goto-char stop-point))))\r
+ (setq cperl-syntax-state (cons state-point state)\r
+ cperl-syntax-done-to (or tmpend (max (point) max))))\r
+ (if (car err-l) (goto-char (car err-l))\r
+ (or non-inter\r
+ (message "Scanning for \"hard\" Perl constructions... done"))))\r
+ (and (buffer-modified-p)\r
+ (not modified)\r
+ (set-buffer-modified-p nil))\r
+ (set-syntax-table cperl-mode-syntax-table))\r
+ (car err-l)))\r
+\r
+(defun cperl-backward-to-noncomment (lim)\r
+ ;; Stops at lim or after non-whitespace that is not in comment\r
+ (let (stop p pr)\r
+ (while (and (not stop) (> (point) (or lim 1)))\r
+ (skip-chars-backward " \t\n\f" lim)\r
+ (setq p (point))\r
+ (beginning-of-line)\r
+ (if (memq (setq pr (get-text-property (point) 'syntax-type))\r
+ '(pod here-doc here-doc-delim))\r
+ (cperl-unwind-to-safe nil)\r
+ (or (looking-at "^[ \t]*\\(#\\|$\\)")\r
+ (progn (cperl-to-comment-or-eol) (bolp))\r
+ (progn\r
+ (skip-chars-backward " \t")\r
+ (if (< p (point)) (goto-char p))\r
+ (setq stop t)))))))\r
+\r
+(defun cperl-after-block-p (lim &optional pre-block)\r
+ "Return true if the preceeding } ends a block or a following { starts one.\r
+Would not look before LIM. If PRE-BLOCK is nil checks preceeding }.\r
+otherwise following {."\r
+ ;; We suppose that the preceding char is }.\r
+ (save-excursion\r
+ (condition-case nil\r
+ (progn\r
+ (or pre-block (forward-sexp -1))\r
+ (cperl-backward-to-noncomment lim)\r
+ (or (eq (point) lim)\r
+ (eq (preceding-char) ?\) ) ; if () {} sub f () {}\r
+ (if (eq (char-syntax (preceding-char)) ?w) ; else {}\r
+ (save-excursion\r
+ (forward-sexp -1)\r
+ (or (looking-at "\\(else\\|continue\\|grep\\|map\\|BEGIN\\|END\\|CHECK\\|INIT\\)\\>")\r
+ ;; sub f {}\r
+ (progn\r
+ (cperl-backward-to-noncomment lim)\r
+ (and (eq (char-syntax (preceding-char)) ?w)\r
+ (progn\r
+ (forward-sexp -1)\r
+ (looking-at "sub\\>"))))))\r
+ (cperl-after-expr-p lim))))\r
+ (error nil))))\r
+\r
+(defun cperl-after-expr-p (&optional lim chars test)\r
+ "Return true if the position is good for start of expression.\r
+TEST is the expression to evaluate at the found position. If absent,\r
+CHARS is a string that contains good characters to have before us (however,\r
+`}' is treated \"smartly\" if it is not in the list)."\r
+ (let ((lim (or lim (point-min)))\r
+ stop p pr)\r
+ (cperl-update-syntaxification (point) (point))\r
+ (save-excursion\r
+ (while (and (not stop) (> (point) lim))\r
+ (skip-chars-backward " \t\n\f" lim)\r
+ (setq p (point))\r
+ (beginning-of-line)\r
+ ;;(memq (setq pr (get-text-property (point) 'syntax-type))\r
+ ;; '(pod here-doc here-doc-delim))\r
+ (if (get-text-property (point) 'here-doc-group)\r
+ (progn\r
+ (goto-char\r
+ (previous-single-property-change (point) 'here-doc-group))\r
+ (beginning-of-line 0)))\r
+ (if (get-text-property (point) 'in-pod)\r
+ (progn\r
+ (goto-char\r
+ (previous-single-property-change (point) 'in-pod))\r
+ (beginning-of-line 0)))\r
+ (if (looking-at "^[ \t]*\\(#\\|$\\)") nil ; Only comment, skip\r
+ ;; Else: last iteration, or a label\r
+ (cperl-to-comment-or-eol) ; Will not move past "." after a format\r
+ (skip-chars-backward " \t")\r
+ (if (< p (point)) (goto-char p))\r
+ (setq p (point))\r
+ (if (and (eq (preceding-char) ?:)\r
+ (progn\r
+ (forward-char -1)\r
+ (skip-chars-backward " \t\n\f" lim)\r
+ (eq (char-syntax (preceding-char)) ?w)))\r
+ (forward-sexp -1) ; Possibly label. Skip it\r
+ (goto-char p)\r
+ (setq stop t))))\r
+ (or (bobp) ; ???? Needed\r
+ (eq (point) lim)\r
+ (looking-at "[ \t]*__\\(END\\|DATA\\)__") ; After this anything goes\r
+ (progn\r
+ (if test (eval test)\r
+ (or (memq (preceding-char) (append (or chars "{;") nil))\r
+ (and (eq (preceding-char) ?\})\r
+ (cperl-after-block-p lim))\r
+ (and (eq (following-char) ?.) ; in format: see comment above\r
+ (eq (get-text-property (point) 'syntax-type)\r
+ 'format)))))))))\r
+\r
+(defun cperl-backward-to-start-of-continued-exp (lim)\r
+ (if (memq (preceding-char) (append ")]}\"'`" nil))\r
+ (forward-sexp -1))\r
+ (beginning-of-line)\r
+ (if (<= (point) lim)\r
+ (goto-char (1+ lim)))\r
+ (skip-chars-forward " \t"))\r
+\r
+(defun cperl-after-block-and-statement-beg (lim)\r
+ ;; We assume that we are after ?\}\r
+ (and\r
+ (cperl-after-block-p lim)\r
+ (save-excursion\r
+ (forward-sexp -1)\r
+ (cperl-backward-to-noncomment (point-min))\r
+ (or (bobp)\r
+ (eq (point) lim)\r
+ (not (= (char-syntax (preceding-char)) ?w))\r
+ (progn\r
+ (forward-sexp -1)\r
+ (not\r
+ (looking-at\r
+ "\\(map\\|grep\\|printf?\\|system\\|exec\\|tr\\|s\\)\\>")))))))\r
+\r
+\f\r
+(defvar innerloop-done nil)\r
+(defvar last-depth nil)\r
+\r
+(defun cperl-indent-exp ()\r
+ "Simple variant of indentation of continued-sexp.\r
+\r
+Will not indent comment if it starts at `comment-indent' or looks like\r
+continuation of the comment on the previous line.\r
+\r
+If `cperl-indent-region-fix-constructs', will improve spacing on\r
+conditional/loop constructs."\r
+ (interactive)\r
+ (save-excursion\r
+ (let ((tmp-end (progn (end-of-line) (point))) top done)\r
+ (save-excursion\r
+ (beginning-of-line)\r
+ (while (null done)\r
+ (setq top (point))\r
+ (while (= (nth 0 (parse-partial-sexp (point) tmp-end\r
+ -1)) -1)\r
+ (setq top (point))) ; Get the outermost parenths in line\r
+ (goto-char top)\r
+ (while (< (point) tmp-end)\r
+ (parse-partial-sexp (point) tmp-end nil t) ; To start-sexp or eol\r
+ (or (eolp) (forward-sexp 1)))\r
+ (if (> (point) tmp-end)\r
+ (save-excursion\r
+ (end-of-line)\r
+ (setq tmp-end (point)))\r
+ (setq done t)))\r
+ (goto-char tmp-end)\r
+ (setq tmp-end (point-marker)))\r
+ (if cperl-indent-region-fix-constructs\r
+ (cperl-fix-line-spacing tmp-end))\r
+ (cperl-indent-region (point) tmp-end))))\r
+\r
+(defun cperl-fix-line-spacing (&optional end parse-data)\r
+ "Improve whitespace in a conditional/loop construct.\r
+Returns some position at the last line."\r
+ (interactive)\r
+ (or end\r
+ (setq end (point-max)))\r
+ (let ((ee (save-excursion (end-of-line) (point)))\r
+ (cperl-indent-region-fix-constructs\r
+ (or cperl-indent-region-fix-constructs 1))\r
+ p pp ml have-brace ret)\r
+ (save-excursion\r
+ (beginning-of-line)\r
+ (setq ret (point))\r
+ ;; }? continue\r
+ ;; blah; }\r
+ (if (not\r
+ (or (looking-at "[ \t]*\\(els\\(e\\|if\\)\\|continue\\|if\\|while\\|for\\(each\\)?\\|until\\)")\r
+ (setq have-brace (save-excursion (search-forward "}" ee t)))))\r
+ nil ; Do not need to do anything\r
+ ;; Looking at:\r
+ ;; }\r
+ ;; else\r
+ (if (and cperl-merge-trailing-else\r
+ (looking-at\r
+ "[ \t]*}[ \t]*\n[ \t\n]*\\(els\\(e\\|if\\)\\|continue\\)\\>"))\r
+ (progn\r
+ (search-forward "}")\r
+ (setq p (point))\r
+ (skip-chars-forward " \t\n")\r
+ (delete-region p (point))\r
+ (insert (make-string cperl-indent-region-fix-constructs ?\ ))\r
+ (beginning-of-line)))\r
+ ;; Looking at:\r
+ ;; } else\r
+ (if (looking-at "[ \t]*}\\(\t*\\|[ \t][ \t]+\\)\\<\\(els\\(e\\|if\\)\\|continue\\)\\>")\r
+ (progn\r
+ (search-forward "}")\r
+ (delete-horizontal-space)\r
+ (insert (make-string cperl-indent-region-fix-constructs ?\ ))\r
+ (beginning-of-line)))\r
+ ;; Looking at:\r
+ ;; else {\r
+ (if (looking-at\r
+ "[ \t]*}?[ \t]*\\<\\(\\els\\(e\\|if\\)\\|continue\\|unless\\|if\\|while\\|for\\(each\\)?\\|until\\)\\>\\(\t*\\|[ \t][ \t]+\\)[^ \t\n#]")\r
+ (progn\r
+ (forward-word 1)\r
+ (delete-horizontal-space)\r
+ (insert (make-string cperl-indent-region-fix-constructs ?\ ))\r
+ (beginning-of-line)))\r
+ ;; Looking at:\r
+ ;; foreach my $var\r
+ (if (looking-at\r
+ "[ \t]*\\<for\\(each\\)?[ \t]+\\(my\\|local\\|our\\)\\(\t*\\|[ \t][ \t]+\\)[^ \t\n]")\r
+ (progn\r
+ (forward-word 2)\r
+ (delete-horizontal-space)\r
+ (insert (make-string cperl-indent-region-fix-constructs ?\ ))\r
+ (beginning-of-line)))\r
+ ;; Looking at:\r
+ ;; foreach my $var (\r
+ (if (looking-at\r
+ "[ \t]*\\<for\\(each\\)?[ \t]+\\(my\\|local\\|our\\)[ \t]*\\$[_a-zA-Z0-9]+\\(\t*\\|[ \t][ \t]+\\)[^ \t\n#]")\r
+ (progn\r
+ (forward-sexp 3)\r
+ (delete-horizontal-space)\r
+ (insert\r
+ (make-string cperl-indent-region-fix-constructs ?\ ))\r
+ (beginning-of-line)))\r
+ ;; Looking at:\r
+ ;; } foreach my $var () {\r
+ (if (looking-at\r
+ "[ \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]*{")\r
+ (progn\r
+ (setq ml (match-beginning 8))\r
+ (re-search-forward "[({]")\r
+ (forward-char -1)\r
+ (setq p (point))\r
+ (if (eq (following-char) ?\( )\r
+ (progn\r
+ (forward-sexp 1)\r
+ (setq pp (point)))\r
+ ;; after `else' or nothing\r
+ (if ml ; after `else'\r
+ (skip-chars-backward " \t\n")\r
+ (beginning-of-line))\r
+ (setq pp nil))\r
+ ;; Now after the sexp before the brace\r
+ ;; Multiline expr should be special\r
+ (setq ml (and pp (save-excursion (goto-char p)\r
+ (search-forward "\n" pp t))))\r
+ (if (and (or (not pp) (< pp end))\r
+ (looking-at "[ \t\n]*{"))\r
+ (progn\r
+ (cond\r
+ ((bolp) ; Were before `{', no if/else/etc\r
+ nil)\r
+ ((looking-at "\\(\t*\\| [ \t]+\\){")\r
+ (delete-horizontal-space)\r
+ (if (if ml\r
+ cperl-extra-newline-before-brace-multiline\r
+ cperl-extra-newline-before-brace)\r
+ (progn\r
+ (delete-horizontal-space)\r
+ (insert "\n")\r
+ (setq ret (point))\r
+ (if (cperl-indent-line parse-data)\r
+ (progn\r
+ (cperl-fix-line-spacing end parse-data)\r
+ (setq ret (point)))))\r
+ (insert\r
+ (make-string cperl-indent-region-fix-constructs ?\ ))))\r
+ ((and (looking-at "[ \t]*\n")\r
+ (not (if ml\r
+ cperl-extra-newline-before-brace-multiline\r
+ cperl-extra-newline-before-brace)))\r
+ (setq pp (point))\r
+ (skip-chars-forward " \t\n")\r
+ (delete-region pp (point))\r
+ (insert\r
+ (make-string cperl-indent-region-fix-constructs ?\ ))))\r
+ ;; Now we are before `{'\r
+ (if (looking-at "[ \t\n]*{[ \t]*[^ \t\n#]")\r
+ (progn\r
+ (skip-chars-forward " \t\n")\r
+ (setq pp (point))\r
+ (forward-sexp 1)\r
+ (setq p (point))\r
+ (goto-char pp)\r
+ (setq ml (search-forward "\n" p t))\r
+ (if (or cperl-break-one-line-blocks-when-indent ml)\r
+ ;; not good: multi-line BLOCK\r
+ (progn\r
+ (goto-char (1+ pp))\r
+ (delete-horizontal-space)\r
+ (insert "\n")\r
+ (setq ret (point))\r
+ (if (cperl-indent-line parse-data)\r
+ (setq ret (cperl-fix-line-spacing end parse-data)))))))))))\r
+ (beginning-of-line)\r
+ (setq p (point) pp (save-excursion (end-of-line) (point))) ; May be different from ee.\r
+ ;; Now check whether there is a hanging `}'\r
+ ;; Looking at:\r
+ ;; } blah\r
+ (if (and\r
+ cperl-fix-hanging-brace-when-indent\r
+ have-brace\r
+ (not (looking-at "[ \t]*}[ \t]*\\(\\<\\(els\\(if\\|e\\)\\|continue\\|while\\|until\\)\\>\\|$\\|#\\)"))\r
+ (condition-case nil\r
+ (progn\r
+ (up-list 1)\r
+ (if (and (<= (point) pp)\r
+ (eq (preceding-char) ?\} )\r
+ (cperl-after-block-and-statement-beg (point-min)))\r
+ t\r
+ (goto-char p)\r
+ nil))\r
+ (error nil)))\r
+ (progn\r
+ (forward-char -1)\r
+ (skip-chars-backward " \t")\r
+ (if (bolp)\r
+ ;; `}' was the first thing on the line, insert NL *after* it.\r
+ (progn\r
+ (cperl-indent-line parse-data)\r
+ (search-forward "}")\r
+ (delete-horizontal-space)\r
+ (insert "\n"))\r
+ (delete-horizontal-space)\r
+ (or (eq (preceding-char) ?\;)\r
+ (bolp)\r
+ (and (eq (preceding-char) ?\} )\r
+ (cperl-after-block-p (point-min)))\r
+ (insert ";"))\r
+ (insert "\n")\r
+ (setq ret (point)))\r
+ (if (cperl-indent-line parse-data)\r
+ (setq ret (cperl-fix-line-spacing end parse-data)))\r
+ (beginning-of-line)))))\r
+ ret))\r
+\r
+(defvar cperl-update-start) ; Do not need to make them local\r
+(defvar cperl-update-end)\r
+(defun cperl-delay-update-hook (beg end old-len)\r
+ (setq cperl-update-start (min beg (or cperl-update-start (point-max))))\r
+ (setq cperl-update-end (max end (or cperl-update-end (point-min)))))\r
+\r
+(defun cperl-indent-region (start end)\r
+ "Simple variant of indentation of region in CPerl mode.\r
+Should be slow. Will not indent comment if it starts at `comment-indent'\r
+or looks like continuation of the comment on the previous line.\r
+Indents all the lines whose first character is between START and END\r
+inclusive.\r
+\r
+If `cperl-indent-region-fix-constructs', will improve spacing on\r
+conditional/loop constructs."\r
+ (interactive "r")\r
+ (cperl-update-syntaxification end end)\r
+ (save-excursion\r
+ (let (cperl-update-start cperl-update-end (h-a-c after-change-functions))\r
+ (let ((indent-info (if cperl-emacs-can-parse\r
+ (list nil nil nil) ; Cannot use '(), since will modify\r
+ nil))\r
+ (pm 0) (imenu-scanning-message "Indenting... (%3d%%)")\r
+ after-change-functions ; Speed it up!\r
+ st comm old-comm-indent new-comm-indent p pp i empty)\r
+ (if h-a-c (add-hook 'after-change-functions 'cperl-delay-update-hook))\r
+ (goto-char start)\r
+ (setq old-comm-indent (and (cperl-to-comment-or-eol)\r
+ (current-column))\r
+ new-comm-indent old-comm-indent)\r
+ (goto-char start)\r
+ (setq end (set-marker (make-marker) end)) ; indentation changes pos\r
+ (or (bolp) (beginning-of-line 2))\r
+ (or (fboundp 'imenu-progress-message)\r
+ (message "Indenting... For feedback load `imenu'..."))\r
+ (while (and (<= (point) end) (not (eobp))) ; bol to check start\r
+ (and (fboundp 'imenu-progress-message)\r
+ (imenu-progress-message\r
+ pm (/ (* 100 (- (point) start)) (- end start -1))))\r
+ (setq st (point))\r
+ (if (or\r
+ (setq empty (looking-at "[ \t]*\n"))\r
+ (and (setq comm (looking-at "[ \t]*#"))\r
+ (or (eq (current-indentation) (or old-comm-indent\r
+ comment-column))\r
+ (setq old-comm-indent nil))))\r
+ (if (and old-comm-indent\r
+ (not empty)\r
+ (= (current-indentation) old-comm-indent)\r
+ (not (eq (get-text-property (point) 'syntax-type) 'pod))\r
+ (not (eq (get-text-property (point) 'syntax-table)\r
+ cperl-st-cfence)))\r
+ (let ((comment-column new-comm-indent))\r
+ (indent-for-comment)))\r
+ (progn\r
+ (setq i (cperl-indent-line indent-info))\r
+ (or comm\r
+ (not i)\r
+ (progn\r
+ (if cperl-indent-region-fix-constructs\r
+ (goto-char (cperl-fix-line-spacing end indent-info)))\r
+ (if (setq old-comm-indent\r
+ (and (cperl-to-comment-or-eol)\r
+ (not (memq (get-text-property (point)\r
+ 'syntax-type)\r
+ '(pod here-doc)))\r
+ (not (eq (get-text-property (point)\r
+ 'syntax-table)\r
+ cperl-st-cfence))\r
+ (current-column)))\r
+ (progn (indent-for-comment)\r
+ (skip-chars-backward " \t")\r
+ (skip-chars-backward "#")\r
+ (setq new-comm-indent (current-column))))))))\r
+ (beginning-of-line 2))\r
+ (if (fboundp 'imenu-progress-message)\r
+ (imenu-progress-message pm 100)\r
+ (message nil)))\r
+ ;; Now run the update hooks\r
+ (and after-change-functions\r
+ cperl-update-end\r
+ (save-excursion\r
+ (goto-char cperl-update-end)\r
+ (insert " ")\r
+ (delete-char -1)\r
+ (goto-char cperl-update-start)\r
+ (insert " ")\r
+ (delete-char -1))))))\r
+\r
+;; Stolen from lisp-mode with a lot of improvements\r
+\r
+(defun cperl-fill-paragraph (&optional justify iteration)\r
+ "Like \\[fill-paragraph], but handle CPerl comments.\r
+If any of the current line is a comment, fill the comment or the\r
+block of it that point is in, preserving the comment's initial\r
+indentation and initial hashes. Behaves usually outside of comment."\r
+ (interactive "P")\r
+ (let (;; Non-nil if the current line contains a comment.\r
+ has-comment\r
+\r
+ ;; If has-comment, the appropriate fill-prefix for the comment.\r
+ comment-fill-prefix\r
+ ;; Line that contains code and comment (or nil)\r
+ start\r
+ c spaces len dc (comment-column comment-column))\r
+ ;; Figure out what kind of comment we are looking at.\r
+ (save-excursion\r
+ (beginning-of-line)\r
+ (cond\r
+\r
+ ;; A line with nothing but a comment on it?\r
+ ((looking-at "[ \t]*#[# \t]*")\r
+ (setq has-comment t\r
+ comment-fill-prefix (buffer-substring (match-beginning 0)\r
+ (match-end 0))))\r
+\r
+ ;; A line with some code, followed by a comment? Remember that the\r
+ ;; semi which starts the comment shouldn't be part of a string or\r
+ ;; character.\r
+ ((cperl-to-comment-or-eol)\r
+ (setq has-comment t)\r
+ (looking-at "#+[ \t]*")\r
+ (setq start (point) c (current-column)\r
+ comment-fill-prefix\r
+ (concat (make-string (current-column) ?\ )\r
+ (buffer-substring (match-beginning 0) (match-end 0)))\r
+ spaces (progn (skip-chars-backward " \t")\r
+ (buffer-substring (point) start))\r
+ dc (- c (current-column)) len (- start (point))\r
+ start (point-marker))\r
+ (delete-char len)\r
+ (insert (make-string dc ?-)))))\r
+ (if (not has-comment)\r
+ (fill-paragraph justify) ; Do the usual thing outside of comment\r
+ ;; Narrow to include only the comment, and then fill the region.\r
+ (save-restriction\r
+ (narrow-to-region\r
+ ;; Find the first line we should include in the region to fill.\r
+ (if start (progn (beginning-of-line) (point))\r
+ (save-excursion\r
+ (while (and (zerop (forward-line -1))\r
+ (looking-at "^[ \t]*#+[ \t]*[^ \t\n#]")))\r
+ ;; We may have gone to far. Go forward again.\r
+ (or (looking-at "^[ \t]*#+[ \t]*[^ \t\n#]")\r
+ (forward-line 1))\r
+ (point)))\r
+ ;; Find the beginning of the first line past the region to fill.\r
+ (save-excursion\r
+ (while (progn (forward-line 1)\r
+ (looking-at "^[ \t]*#+[ \t]*[^ \t\n#]")))\r
+ (point)))\r
+ ;; Remove existing hashes\r
+ (goto-char (point-min))\r
+ (while (progn (forward-line 1) (< (point) (point-max)))\r
+ (skip-chars-forward " \t")\r
+ (and (looking-at "#+")\r
+ (delete-char (- (match-end 0) (match-beginning 0)))))\r
+\r
+ ;; Lines with only hashes on them can be paragraph boundaries.\r
+ (let ((paragraph-start (concat paragraph-start "\\|^[ \t#]*$"))\r
+ (paragraph-separate (concat paragraph-start "\\|^[ \t#]*$"))\r
+ (fill-prefix comment-fill-prefix))\r
+ (fill-paragraph justify)))\r
+ (if (and start)\r
+ (progn\r
+ (goto-char start)\r
+ (if (> dc 0)\r
+ (progn (delete-char dc) (insert spaces)))\r
+ (if (or (= (current-column) c) iteration) nil\r
+ (setq comment-column c)\r
+ (indent-for-comment)\r
+ ;; Repeat once more, flagging as iteration\r
+ (cperl-fill-paragraph justify t)))))))\r
+\r
+(defun cperl-do-auto-fill ()\r
+ ;; Break out if the line is short enough\r
+ (if (> (save-excursion\r
+ (end-of-line)\r
+ (current-column))\r
+ fill-column)\r
+ (let ((c (save-excursion (beginning-of-line)\r
+ (cperl-to-comment-or-eol) (point)))\r
+ (s (memq (following-char) '(?\ ?\t))) marker)\r
+ (if (>= c (point)) nil\r
+ (setq marker (point-marker))\r
+ (cperl-fill-paragraph)\r
+ (goto-char marker)\r
+ ;; Is not enough, sometimes marker is a start of line\r
+ (if (bolp) (progn (re-search-forward "#+[ \t]*")\r
+ (goto-char (match-end 0))))\r
+ ;; Following space could have gone:\r
+ (if (or (not s) (memq (following-char) '(?\ ?\t))) nil\r
+ (insert " ")\r
+ (backward-char 1))\r
+ ;; Previous space could have gone:\r
+ (or (memq (preceding-char) '(?\ ?\t)) (insert " "))))))\r
+\r
+(defun cperl-imenu-addback (lst &optional isback name)\r
+ ;; We suppose that the lst is a DAG, unless the first element only\r
+ ;; loops back, and ISBACK is set. Thus this function cannot be\r
+ ;; applied twice without ISBACK set.\r
+ (cond ((not cperl-imenu-addback) lst)\r
+ (t\r
+ (or name\r
+ (setq name "+++BACK+++"))\r
+ (mapcar (lambda (elt)\r
+ (if (and (listp elt) (listp (cdr elt)))\r
+ (progn\r
+ ;; In the other order it goes up\r
+ ;; one level only ;-(\r
+ (setcdr elt (cons (cons name lst)\r
+ (cdr elt)))\r
+ (cperl-imenu-addback (cdr elt) t name))))\r
+ (if isback (cdr lst) lst))\r
+ lst)))\r
+\r
+(defun cperl-imenu--create-perl-index (&optional regexp)\r
+ (require 'cl)\r
+ (require 'imenu) ; May be called from TAGS creator\r
+ (let ((index-alist '()) (index-pack-alist '()) (index-pod-alist '())\r
+ (index-unsorted-alist '()) (i-s-f (default-value 'imenu-sort-function))\r
+ (index-meth-alist '()) meth\r
+ packages ends-ranges p marker\r
+ (prev-pos 0) char fchar index index1 name (end-range 0) package)\r
+ (goto-char (point-min))\r
+ (if noninteractive\r
+ (message "Scanning Perl for index")\r
+ (imenu-progress-message prev-pos 0))\r
+ (cperl-update-syntaxification (point-max) (point-max))\r
+ ;; Search for the function\r
+ (progn ;;save-match-data\r
+ (while (re-search-forward\r
+ (or regexp cperl-imenu--function-name-regexp-perl)\r
+ nil t)\r
+ (or noninteractive\r
+ (imenu-progress-message prev-pos))\r
+ (cond\r
+ ((and ; Skip some noise if building tags\r
+ (match-beginning 2) ; package or sub\r
+ (eq (char-after (match-beginning 2)) ?p) ; package\r
+ (not (save-match-data\r
+ (looking-at "[ \t\n]*;")))) ; Plain text word 'package'\r
+ nil)\r
+ ((and\r
+ (match-beginning 2) ; package or sub\r
+ ;; Skip if quoted (will not skip multi-line ''-strings :-():\r
+ (null (get-text-property (match-beginning 1) 'syntax-table))\r
+ (null (get-text-property (match-beginning 1) 'syntax-type))\r
+ (null (get-text-property (match-beginning 1) 'in-pod)))\r
+ (save-excursion\r
+ (goto-char (match-beginning 2))\r
+ (setq fchar (following-char)))\r
+ ;; (if (looking-at "([^()]*)[ \t\n\f]*")\r
+ ;; (goto-char (match-end 0))) ; Messes what follows\r
+ (setq char (following-char) ; ?\; for "sub foo () ;"\r
+ meth nil\r
+ p (point))\r
+ (while (and ends-ranges (>= p (car ends-ranges)))\r
+ ;; delete obsolete entries\r
+ (setq ends-ranges (cdr ends-ranges) packages (cdr packages)))\r
+ (setq package (or (car packages) "")\r
+ end-range (or (car ends-ranges) 0))\r
+ (if (eq fchar ?p)\r
+ (setq name (buffer-substring (match-beginning 3) (match-end 3))\r
+ name (progn\r
+ (set-text-properties 0 (length name) nil name)\r
+ name)\r
+ package (concat name "::")\r
+ name (concat "package " name)\r
+ end-range\r
+ (save-excursion\r
+ (parse-partial-sexp (point) (point-max) -1) (point))\r
+ ends-ranges (cons end-range ends-ranges)\r
+ packages (cons package packages)))\r
+ ;; )\r
+ ;; Skip this function name if it is a prototype declaration.\r
+ (if (and (eq fchar ?s) (eq char ?\;)) nil\r
+ (setq name (buffer-substring (match-beginning 3) (match-end 3))\r
+ marker (make-marker))\r
+ (set-text-properties 0 (length name) nil name)\r
+ (set-marker marker (match-end 3))\r
+ (if (eq fchar ?p)\r
+ (setq name (concat "package " name))\r
+ (cond ((string-match "[:']" name)\r
+ (setq meth t))\r
+ ((> p end-range) nil)\r
+ (t\r
+ (setq name (concat package name) meth t))))\r
+ (setq index (cons name marker))\r
+ (if (eq fchar ?p)\r
+ (push index index-pack-alist)\r
+ (push index index-alist))\r
+ (if meth (push index index-meth-alist))\r
+ (push index index-unsorted-alist)))\r
+ ((match-beginning 5) ; POD section\r
+ ;; (beginning-of-line)\r
+ (setq index (imenu-example--name-and-position)\r
+ name (buffer-substring (match-beginning 6) (match-end 6)))\r
+ (set-text-properties 0 (length name) nil name)\r
+ (if (eq (char-after (match-beginning 5)) ?2)\r
+ (setq name (concat " " name)))\r
+ (setcar index name)\r
+ (setq index1 (cons (concat "=" name) (cdr index)))\r
+ (push index index-pod-alist)\r
+ (push index1 index-unsorted-alist)))))\r
+ (or noninteractive\r
+ (imenu-progress-message prev-pos 100))\r
+ (setq index-alist\r
+ (if (default-value 'imenu-sort-function)\r
+ (sort index-alist (default-value 'imenu-sort-function))\r
+ (nreverse index-alist)))\r
+ (and index-pod-alist\r
+ (push (cons "+POD headers+..."\r
+ (nreverse index-pod-alist))\r
+ index-alist))\r
+ (and (or index-pack-alist index-meth-alist)\r
+ (let ((lst index-pack-alist) hier-list pack elt group name)\r
+ ;; Remove "package ", reverse and uniquify.\r
+ (while lst\r
+ (setq elt (car lst) lst (cdr lst) name (substring (car elt) 8))\r
+ (if (assoc name hier-list) nil\r
+ (setq hier-list (cons (cons name (cdr elt)) hier-list))))\r
+ (setq lst index-meth-alist)\r
+ (while lst\r
+ (setq elt (car lst) lst (cdr lst))\r
+ (cond ((string-match "\\(::\\|'\\)[_a-zA-Z0-9]+$" (car elt))\r
+ (setq pack (substring (car elt) 0 (match-beginning 0)))\r
+ (if (setq group (assoc pack hier-list))\r
+ (if (listp (cdr group))\r
+ ;; Have some functions already\r
+ (setcdr group\r
+ (cons (cons (substring\r
+ (car elt)\r
+ (+ 2 (match-beginning 0)))\r
+ (cdr elt))\r
+ (cdr group)))\r
+ (setcdr group (list (cons (substring\r
+ (car elt)\r
+ (+ 2 (match-beginning 0)))\r
+ (cdr elt)))))\r
+ (setq hier-list\r
+ (cons (cons pack\r
+ (list (cons (substring\r
+ (car elt)\r
+ (+ 2 (match-beginning 0)))\r
+ (cdr elt))))\r
+ hier-list))))))\r
+ (push (cons "+Hierarchy+..."\r
+ hier-list)\r
+ index-alist)))\r
+ (and index-pack-alist\r
+ (push (cons "+Packages+..."\r
+ (nreverse index-pack-alist))\r
+ index-alist))\r
+ (and (or index-pack-alist index-pod-alist\r
+ (default-value 'imenu-sort-function))\r
+ index-unsorted-alist\r
+ (push (cons "+Unsorted List+..."\r
+ (nreverse index-unsorted-alist))\r
+ index-alist))\r
+ (cperl-imenu-addback index-alist)))\r
+\r
+\f\r
+;; Suggested by Mark A. Hershberger\r
+(defun cperl-outline-level ()\r
+ (looking-at outline-regexp)\r
+ (cond ((not (match-beginning 1)) 0) ; beginning-of-file\r
+ ((match-beginning 2)\r
+ (if (eq (char-after (match-beginning 2)) ?p)\r
+ 0 ; package\r
+ 1)) ; sub\r
+ ((match-beginning 5)\r
+ (if (eq (char-after (match-beginning 5)) ?1)\r
+ 1 ; head1\r
+ 2)) ; head2\r
+ (t 3))) ; should not happen\r
+\r
+\f\r
+(defvar cperl-compilation-error-regexp-alist\r
+ ;; This look like a paranoiac regexp: could anybody find a better one? (which WORK).\r
+ '(("^[^\n]* \\(file\\|at\\) \\([^ \t\n]+\\) [^\n]*line \\([0-9]+\\)[\\., \n]"\r
+ 2 3))\r
+ "Alist that specifies how to match errors in perl output.")\r
+\r
+(if (fboundp 'eval-after-load)\r
+ (eval-after-load\r
+ "mode-compile"\r
+ '(setq perl-compilation-error-regexp-alist\r
+ cperl-compilation-error-regexp-alist)))\r
+\r
+\r
+(defun cperl-windowed-init ()\r
+ "Initialization under windowed version."\r
+ (if (or (featurep 'ps-print) cperl-faces-init)\r
+ ;; Need to init anyway:\r
+ (or cperl-faces-init (cperl-init-faces))\r
+ (add-hook 'font-lock-mode-hook\r
+ (function\r
+ (lambda ()\r
+ (if (memq major-mode '(perl-mode cperl-mode))\r
+ (progn\r
+ (or cperl-faces-init (cperl-init-faces)))))))\r
+ (if (fboundp 'eval-after-load)\r
+ (eval-after-load\r
+ "ps-print"\r
+ '(or cperl-faces-init (cperl-init-faces))))))\r
+\r
+(defun cperl-load-font-lock-keywords ()\r
+ (or cperl-faces-init (cperl-init-faces))\r
+ perl-font-lock-keywords)\r
+\r
+(defun cperl-load-font-lock-keywords-1 ()\r
+ (or cperl-faces-init (cperl-init-faces))\r
+ perl-font-lock-keywords-1)\r
+\r
+(defun cperl-load-font-lock-keywords-2 ()\r
+ (or cperl-faces-init (cperl-init-faces))\r
+ perl-font-lock-keywords-2)\r
+\r
+(defvar perl-font-lock-keywords-1 nil\r
+ "Additional expressions to highlight in Perl mode. Minimal set.")\r
+(defvar perl-font-lock-keywords nil\r
+ "Additional expressions to highlight in Perl mode. Default set.")\r
+(defvar perl-font-lock-keywords-2 nil\r
+ "Additional expressions to highlight in Perl mode. Maximal set")\r
+\r
+(defvar font-lock-background-mode)\r
+(defvar font-lock-display-type)\r
+(defun cperl-init-faces-weak ()\r
+ ;; Allow `cperl-find-pods-heres' to run.\r
+ (or (boundp 'font-lock-constant-face)\r
+ (cperl-force-face font-lock-constant-face\r
+ "Face for constant and label names")\r
+ ;;(setq font-lock-constant-face 'font-lock-constant-face)\r
+ ))\r
+\r
+(defun cperl-init-faces ()\r
+ (condition-case errs\r
+ (progn\r
+ (require 'font-lock)\r
+ (and (fboundp 'font-lock-fontify-anchored-keywords)\r
+ (featurep 'font-lock-extra)\r
+ (message "You have an obsolete package `font-lock-extra'. Install `choose-color'."))\r
+ (let (t-font-lock-keywords t-font-lock-keywords-1 font-lock-anchored)\r
+ (if (fboundp 'font-lock-fontify-anchored-keywords)\r
+ (setq font-lock-anchored t))\r
+ (setq\r
+ t-font-lock-keywords\r
+ (list\r
+ (list "[ \t]+$" 0 cperl-invalid-face t)\r
+ (cons\r
+ (concat\r
+ "\\(^\\|[^$@%&\\]\\)\\<\\("\r
+ (mapconcat\r
+ 'identity\r
+ '("if" "until" "while" "elsif" "else" "unless" "for"\r
+ "foreach" "continue" "exit" "die" "last" "goto" "next"\r
+ "redo" "return" "local" "exec" "sub" "do" "dump" "use"\r
+ "require" "package" "eval" "my" "BEGIN" "END" "CHECK" "INIT")\r
+ "\\|") ; Flow control\r
+ "\\)\\>") 2) ; was "\\)[ \n\t;():,\|&]"\r
+ ; In what follows we use `type' style\r
+ ; for overwritable builtins\r
+ (list\r
+ (concat\r
+ "\\(^\\|[^$@%&\\]\\)\\<\\("\r
+ ;; "CORE" "__FILE__" "__LINE__" "abs" "accept" "alarm"\r
+ ;; "and" "atan2" "bind" "binmode" "bless" "caller"\r
+ ;; "chdir" "chmod" "chown" "chr" "chroot" "close"\r
+ ;; "closedir" "cmp" "connect" "continue" "cos" "crypt"\r
+ ;; "dbmclose" "dbmopen" "die" "dump" "endgrent"\r
+ ;; "endhostent" "endnetent" "endprotoent" "endpwent"\r
+ ;; "endservent" "eof" "eq" "exec" "exit" "exp" "fcntl"\r
+ ;; "fileno" "flock" "fork" "formline" "ge" "getc"\r
+ ;; "getgrent" "getgrgid" "getgrnam" "gethostbyaddr"\r
+ ;; "gethostbyname" "gethostent" "getlogin"\r
+ ;; "getnetbyaddr" "getnetbyname" "getnetent"\r
+ ;; "getpeername" "getpgrp" "getppid" "getpriority"\r
+ ;; "getprotobyname" "getprotobynumber" "getprotoent"\r
+ ;; "getpwent" "getpwnam" "getpwuid" "getservbyname"\r
+ ;; "getservbyport" "getservent" "getsockname"\r
+ ;; "getsockopt" "glob" "gmtime" "gt" "hex" "index" "int"\r
+ ;; "ioctl" "join" "kill" "lc" "lcfirst" "le" "length"\r
+ ;; "link" "listen" "localtime" "lock" "log" "lstat" "lt"\r
+ ;; "mkdir" "msgctl" "msgget" "msgrcv" "msgsnd" "ne"\r
+ ;; "not" "oct" "open" "opendir" "or" "ord" "pack" "pipe"\r
+ ;; "quotemeta" "rand" "read" "readdir" "readline"\r
+ ;; "readlink" "readpipe" "recv" "ref" "rename" "require"\r
+ ;; "reset" "reverse" "rewinddir" "rindex" "rmdir" "seek"\r
+ ;; "seekdir" "select" "semctl" "semget" "semop" "send"\r
+ ;; "setgrent" "sethostent" "setnetent" "setpgrp"\r
+ ;; "setpriority" "setprotoent" "setpwent" "setservent"\r
+ ;; "setsockopt" "shmctl" "shmget" "shmread" "shmwrite"\r
+ ;; "shutdown" "sin" "sleep" "socket" "socketpair"\r
+ ;; "sprintf" "sqrt" "srand" "stat" "substr" "symlink"\r
+ ;; "syscall" "sysopen" "sysread" "system" "syswrite" "tell"\r
+ ;; "telldir" "time" "times" "truncate" "uc" "ucfirst"\r
+ ;; "umask" "unlink" "unpack" "utime" "values" "vec"\r
+ ;; "wait" "waitpid" "wantarray" "warn" "write" "x" "xor"\r
+ "a\\(bs\\|ccept\\|tan2\\|larm\\|nd\\)\\|"\r
+ "b\\(in\\(d\\|mode\\)\\|less\\)\\|"\r
+ "c\\(h\\(r\\(\\|oot\\)\\|dir\\|mod\\|own\\)\\|aller\\|rypt\\|"\r
+ "lose\\(\\|dir\\)\\|mp\\|o\\(s\\|n\\(tinue\\|nect\\)\\)\\)\\|"\r
+ "CORE\\|d\\(ie\\|bm\\(close\\|open\\)\\|ump\\)\\|"\r
+ "e\\(x\\(p\\|it\\|ec\\)\\|q\\|nd\\(p\\(rotoent\\|went\\)\\|"\r
+ "hostent\\|servent\\|netent\\|grent\\)\\|of\\)\\|"\r
+ "f\\(ileno\\|cntl\\|lock\\|or\\(k\\|mline\\)\\)\\|"\r
+ "g\\(t\\|lob\\|mtime\\|e\\(\\|t\\(p\\(pid\\|r\\(iority\\|"\r
+ "oto\\(byn\\(ame\\|umber\\)\\|ent\\)\\)\\|eername\\|w"\r
+ "\\(uid\\|ent\\|nam\\)\\|grp\\)\\|host\\(by\\(addr\\|name\\)\\|"\r
+ "ent\\)\\|s\\(erv\\(by\\(port\\|name\\)\\|ent\\)\\|"\r
+ "ock\\(name\\|opt\\)\\)\\|c\\|login\\|net\\(by\\(addr\\|name\\)\\|"\r
+ "ent\\)\\|gr\\(ent\\|nam\\|gid\\)\\)\\)\\)\\|"\r
+ "hex\\|i\\(n\\(t\\|dex\\)\\|octl\\)\\|join\\|kill\\|"\r
+ "l\\(i\\(sten\\|nk\\)\\|stat\\|c\\(\\|first\\)\\|t\\|e"\r
+ "\\(\\|ngth\\)\\|o\\(c\\(altime\\|k\\)\\|g\\)\\)\\|m\\(sg\\(rcv\\|snd\\|"\r
+ "ctl\\|get\\)\\|kdir\\)\\|n\\(e\\|ot\\)\\|o\\(pen\\(\\|dir\\)\\|"\r
+ "r\\(\\|d\\)\\|ct\\)\\|p\\(ipe\\|ack\\)\\|quotemeta\\|"\r
+ "r\\(index\\|and\\|mdir\\|e\\(quire\\|ad\\(pipe\\|\\|lin"\r
+ "\\(k\\|e\\)\\|dir\\)\\|set\\|cv\\|verse\\|f\\|winddir\\|name"\r
+ "\\)\\)\\|s\\(printf\\|qrt\\|rand\\|tat\\|ubstr\\|e\\(t\\(p\\(r"\r
+ "\\(iority\\|otoent\\)\\|went\\|grp\\)\\|hostent\\|s\\(ervent\\|"\r
+ "ockopt\\)\\|netent\\|grent\\)\\|ek\\(\\|dir\\)\\|lect\\|"\r
+ "m\\(ctl\\|op\\|get\\)\\|nd\\)\\|h\\(utdown\\|m\\(read\\|ctl\\|"\r
+ "write\\|get\\)\\)\\|y\\(s\\(read\\|call\\|open\\|tem\\|write\\)\\|"\r
+ "mlink\\)\\|in\\|leep\\|ocket\\(pair\\|\\)\\)\\|t\\(runcate\\|"\r
+ "ell\\(\\|dir\\)\\|ime\\(\\|s\\)\\)\\|u\\(c\\(\\|first\\)\\|"\r
+ "time\\|mask\\|n\\(pack\\|link\\)\\)\\|v\\(alues\\|ec\\)\\|"\r
+ "w\\(a\\(rn\\|it\\(pid\\|\\)\\|ntarray\\)\\|rite\\)\\|"\r
+ "x\\(\\|or\\)\\|__\\(FILE__\\|LINE__\\|PACKAGE__\\)"\r
+ "\\)\\>") 2 'font-lock-type-face)\r
+ ;; In what follows we use `other' style\r
+ ;; for nonoverwritable builtins\r
+ ;; Somehow 's', 'm' are not auto-generated???\r
+ (list\r
+ (concat\r
+ "\\(^\\|[^$@%&\\]\\)\\<\\("\r
+ ;; "AUTOLOAD" "BEGIN" "CHECK" "DESTROY" "END" "INIT" "__END__" "chomp"\r
+ ;; "chop" "defined" "delete" "do" "each" "else" "elsif"\r
+ ;; "eval" "exists" "for" "foreach" "format" "goto"\r
+ ;; "grep" "if" "keys" "last" "local" "map" "my" "next"\r
+ ;; "no" "package" "pop" "pos" "print" "printf" "push"\r
+ ;; "q" "qq" "qw" "qx" "redo" "return" "scalar" "shift"\r
+ ;; "sort" "splice" "split" "study" "sub" "tie" "tr"\r
+ ;; "undef" "unless" "unshift" "untie" "until" "use"\r
+ ;; "while" "y"\r
+ "AUTOLOAD\\|BEGIN\\|CHECK\\|cho\\(p\\|mp\\)\\|d\\(e\\(fined\\|lete\\)\\|"\r
+ "o\\)\\|DESTROY\\|e\\(ach\\|val\\|xists\\|ls\\(e\\|if\\)\\)\\|"\r
+ "END\\|for\\(\\|each\\|mat\\)\\|g\\(rep\\|oto\\)\\|INIT\\|if\\|keys\\|"\r
+ "l\\(ast\\|ocal\\)\\|m\\(ap\\|y\\)\\|n\\(ext\\|o\\)\\|our\\|"\r
+ "p\\(ackage\\|rint\\(\\|f\\)\\|ush\\|o\\(p\\|s\\)\\)\\|"\r
+ "q\\(\\|q\\|w\\|x\\|r\\)\\|re\\(turn\\|do\\)\\|s\\(pli\\(ce\\|t\\)\\|"\r
+ "calar\\|tudy\\|ub\\|hift\\|ort\\)\\|t\\(r\\|ie\\)\\|"\r
+ "u\\(se\\|n\\(shift\\|ti\\(l\\|e\\)\\|def\\|less\\)\\)\\|"\r
+ "while\\|y\\|__\\(END\\|DATA\\)__" ;__DATA__ added manually\r
+ "\\|[sm]" ; Added manually\r
+ "\\)\\>") 2 'cperl-nonoverridable-face)\r
+ ;; (mapconcat 'identity\r
+ ;; '("#endif" "#else" "#ifdef" "#ifndef" "#if"\r
+ ;; "#include" "#define" "#undef")\r
+ ;; "\\|")\r
+ '("-[rwxoRWXOezsfdlpSbctugkTBMAC]\\>\\([ \t]+_\\>\\)?" 0\r
+ font-lock-function-name-face keep) ; Not very good, triggers at "[a-z]"\r
+ '("\\<sub[ \t]+\\([^ \t{;()]+\\)[ \t]*\\(([^()]*)[ \t]*\\)?[#{\n]" 1\r
+ font-lock-function-name-face)\r
+ '("\\<\\(package\\|require\\|use\\|import\\|no\\|bootstrap\\)[ \t]+\\([a-zA-z_][a-zA-z_0-9:]*\\)[ \t;]" ; require A if B;\r
+ 2 font-lock-function-name-face)\r
+ '("^[ \t]*format[ \t]+\\([a-zA-z_][a-zA-z_0-9:]*\\)[ \t]*=[ \t]*$"\r
+ 1 font-lock-function-name-face)\r
+ (cond ((featurep 'font-lock-extra)\r
+ '("\\([]}\\\\%@>*&]\\|\\$[a-zA-Z0-9_:]*\\)[ \t]*{[ \t]*\\(-?[a-zA-Z0-9_:]+\\)[ \t]*}"\r
+ (2 font-lock-string-face t)\r
+ (0 '(restart 2 t)))) ; To highlight $a{bc}{ef}\r
+ (font-lock-anchored\r
+ '("\\([]}\\\\%@>*&]\\|\\$[a-zA-Z0-9_:]*\\)[ \t]*{[ \t]*\\(-?[a-zA-Z0-9_:]+\\)[ \t]*}"\r
+ (2 font-lock-string-face t)\r
+ ("\\=[ \t]*{[ \t]*\\(-?[a-zA-Z0-9_:]+\\)[ \t]*}"\r
+ nil nil\r
+ (1 font-lock-string-face t))))\r
+ (t '("\\([]}\\\\%@>*&]\\|\\$[a-zA-Z0-9_:]*\\)[ \t]*{[ \t]*\\(-?[a-zA-Z0-9_:]+\\)[ \t]*}"\r
+ 2 font-lock-string-face t)))\r
+ '("[\[ \t{,(]\\(-?[a-zA-Z0-9_:]+\\)[ \t]*=>" 1\r
+ font-lock-string-face t)\r
+ '("^[ \t]*\\([a-zA-Z0-9_]+[ \t]*:\\)[ \t]*\\($\\|{\\|\\<\\(until\\|while\\|for\\(each\\)?\\|do\\)\\>\\)" 1\r
+ font-lock-constant-face) ; labels\r
+ '("\\<\\(continue\\|next\\|last\\|redo\\|goto\\)\\>[ \t]+\\([a-zA-Z0-9_:]+\\)" ; labels as targets\r
+ 2 font-lock-constant-face)\r
+ ;; Uncomment to get perl-mode-like vars\r
+ ;;; '("[$*]{?\\(\\sw+\\)" 1 font-lock-variable-name-face)\r
+ ;;; '("\\([@%]\\|\\$#\\)\\(\\sw+\\)"\r
+ ;;; (2 (cons font-lock-variable-name-face '(underline))))\r
+ (cond ((featurep 'font-lock-extra)\r
+ '("^[ \t]*\\(my\\|local\\|our\\)[ \t]*\\(([ \t]*\\)?\\([$@%*][a-zA-Z0-9_:]+\\)\\([ \t]*,\\)?"\r
+ (3 font-lock-variable-name-face)\r
+ (4 '(another 4 nil\r
+ ("\\=[ \t]*,[ \t]*\\([$@%*][a-zA-Z0-9_:]+\\)\\([ \t]*,\\)?"\r
+ (1 font-lock-variable-name-face)\r
+ (2 '(restart 2 nil) nil t)))\r
+ nil t))) ; local variables, multiple\r
+ (font-lock-anchored\r
+ '("^[ \t{}]*\\(my\\|local\\|our\\)[ \t]*\\(([ \t]*\\)?\\([$@%*][a-zA-Z0-9_:]+\\)"\r
+ (3 font-lock-variable-name-face)\r
+ ("\\=[ \t]*,[ \t]*\\([$@%*][a-zA-Z0-9_:]+\\)"\r
+ nil nil\r
+ (1 font-lock-variable-name-face))))\r
+ (t '("^[ \t{}]*\\(my\\|local\\our\\)[ \t]*\\(([ \t]*\\)?\\([$@%*][a-zA-Z0-9_:]+\\)"\r
+ 3 font-lock-variable-name-face)))\r
+ '("\\<for\\(each\\)?\\([ \t]+\\(my\\|local\\|our\\)\\)?[ \t]*\\(\\$[a-zA-Z_][a-zA-Z_0-9]*\\)[ \t]*("\r
+ 4 font-lock-variable-name-face)))\r
+ (setq\r
+ t-font-lock-keywords-1\r
+ (and (fboundp 'turn-on-font-lock) ; Check for newer font-lock\r
+ (not cperl-xemacs-p) ; not yet as of XEmacs 19.12\r
+ '(\r
+ ("\\(\\([@%]\\|\$#\\)[a-zA-Z_:][a-zA-Z0-9_:]*\\)" 1\r
+ (if (eq (char-after (match-beginning 2)) ?%)\r
+ cperl-hash-face\r
+ cperl-array-face)\r
+ t) ; arrays and hashes\r
+ ("\\(\\([$@]+\\)[a-zA-Z_:][a-zA-Z0-9_:]*\\)[ \t]*\\([[{]\\)"\r
+ 1\r
+ (if (= (- (match-end 2) (match-beginning 2)) 1)\r
+ (if (eq (char-after (match-beginning 3)) ?{)\r
+ cperl-hash-face\r
+ cperl-array-face) ; arrays and hashes\r
+ font-lock-variable-name-face) ; Just to put something\r
+ t)\r
+ ;;("\\([smy]\\|tr\\)\\([^a-z_A-Z0-9]\\)\\(\\([^\n\\]*||\\)\\)\\2")\r
+ ;;; Too much noise from \s* @s[ and friends\r
+ ;;("\\(\\<\\([msy]\\|tr\\)[ \t]*\\([^ \t\na-zA-Z0-9_]\\)\\|\\(/\\)\\)"\r
+ ;;(3 font-lock-function-name-face t t)\r
+ ;;(4\r
+ ;; (if (cperl-slash-is-regexp)\r
+ ;; font-lock-function-name-face 'default) nil t))\r
+ )))\r
+ (if cperl-highlight-variables-indiscriminately\r
+ (setq t-font-lock-keywords-1\r
+ (append t-font-lock-keywords-1\r
+ (list '("[$*]{?\\(\\sw+\\)" 1\r
+ font-lock-variable-name-face)))))\r
+ (setq perl-font-lock-keywords-1 \r
+ (if cperl-syntaxify-by-font-lock\r
+ (cons 'cperl-fontify-update\r
+ t-font-lock-keywords)\r
+ t-font-lock-keywords)\r
+ perl-font-lock-keywords perl-font-lock-keywords-1\r
+ perl-font-lock-keywords-2 (append\r
+ perl-font-lock-keywords-1\r
+ t-font-lock-keywords-1)))\r
+ (if (fboundp 'ps-print-buffer) (cperl-ps-print-init))\r
+ (if (or (featurep 'choose-color) (featurep 'font-lock-extra))\r
+ (eval ; Avoid a warning\r
+ '(font-lock-require-faces\r
+ (list\r
+ ;; Color-light Color-dark Gray-light Gray-dark Mono\r
+ (list 'font-lock-comment-face\r
+ ["Firebrick" "OrangeRed" "DimGray" "Gray80"]\r
+ nil\r
+ [nil nil t t t]\r
+ [nil nil t t t]\r
+ nil)\r
+ (list 'font-lock-string-face\r
+ ["RosyBrown" "LightSalmon" "Gray50" "LightGray"]\r
+ nil\r
+ nil\r
+ [nil nil t t t]\r
+ nil)\r
+ (list 'font-lock-function-name-face\r
+ (vector\r
+ "Blue" "LightSkyBlue" "Gray50" "LightGray"\r
+ (cdr (assq 'background-color ; if mono\r
+ (frame-parameters))))\r
+ (vector\r
+ nil nil nil nil\r
+ (cdr (assq 'foreground-color ; if mono\r
+ (frame-parameters))))\r
+ [nil nil t t t]\r
+ nil\r
+ nil)\r
+ (list 'font-lock-variable-name-face\r
+ ["DarkGoldenrod" "LightGoldenrod" "DimGray" "Gray90"]\r
+ nil\r
+ [nil nil t t t]\r
+ [nil nil t t t]\r
+ nil)\r
+ (list 'font-lock-type-face\r
+ ["DarkOliveGreen" "PaleGreen" "DimGray" "Gray80"]\r
+ nil\r
+ [nil nil t t t]\r
+ nil\r
+ [nil nil t t t])\r
+ (list 'font-lock-constant-face\r
+ ["CadetBlue" "Aquamarine" "Gray50" "LightGray"]\r
+ nil\r
+ [nil nil t t t]\r
+ nil\r
+ [nil nil t t t])\r
+ (list 'cperl-nonoverridable-face\r
+ ["chartreuse3" ("orchid1" "orange")\r
+ nil "Gray80"]\r
+ [nil nil "gray90"]\r
+ [nil nil nil t t]\r
+ [nil nil t t]\r
+ [nil nil t t t])\r
+ (list 'cperl-array-face\r
+ ["blue" "yellow" nil "Gray80"]\r
+ ["lightyellow2" ("navy" "os2blue" "darkgreen")\r
+ "gray90"]\r
+ t\r
+ nil\r
+ nil)\r
+ (list 'cperl-hash-face\r
+ ["red" "red" nil "Gray80"]\r
+ ["lightyellow2" ("navy" "os2blue" "darkgreen")\r
+ "gray90"]\r
+ t\r
+ t\r
+ nil))))\r
+ ;; Do it the dull way, without choose-color\r
+ (defvar cperl-guessed-background nil\r
+ "Display characteristics as guessed by cperl.")\r
+ ;; (or (fboundp 'x-color-defined-p)\r
+ ;; (defalias 'x-color-defined-p \r
+ ;; (cond ((fboundp 'color-defined-p) 'color-defined-p)\r
+ ;; ;; XEmacs >= 19.12\r
+ ;; ((fboundp 'valid-color-name-p) 'valid-color-name-p)\r
+ ;; ;; XEmacs 19.11\r
+ ;; (t 'x-valid-color-name-p))))\r
+ (cperl-force-face font-lock-constant-face\r
+ "Face for constant and label names")\r
+ (cperl-force-face font-lock-variable-name-face\r
+ "Face for variable names")\r
+ (cperl-force-face font-lock-type-face\r
+ "Face for data types")\r
+ (cperl-force-face cperl-nonoverridable-face\r
+ "Face for data types from another group")\r
+ (cperl-force-face font-lock-comment-face\r
+ "Face for comments")\r
+ (cperl-force-face font-lock-function-name-face\r
+ "Face for function names")\r
+ (cperl-force-face cperl-hash-face\r
+ "Face for hashes")\r
+ (cperl-force-face cperl-array-face\r
+ "Face for arrays")\r
+ ;;(defvar font-lock-constant-face 'font-lock-constant-face)\r
+ ;;(defvar font-lock-variable-name-face 'font-lock-variable-name-face)\r
+ ;;(or (boundp 'font-lock-type-face)\r
+ ;; (defconst font-lock-type-face\r
+ ;; 'font-lock-type-face\r
+ ;; "Face to use for data types."))\r
+ ;;(or (boundp 'cperl-nonoverridable-face)\r
+ ;; (defconst cperl-nonoverridable-face\r
+ ;; 'cperl-nonoverridable-face\r
+ ;; "Face to use for data types from another group."))\r
+ ;;(if (not cperl-xemacs-p) nil\r
+ ;; (or (boundp 'font-lock-comment-face)\r
+ ;; (defconst font-lock-comment-face\r
+ ;; 'font-lock-comment-face\r
+ ;; "Face to use for comments."))\r
+ ;; (or (boundp 'font-lock-keyword-face)\r
+ ;; (defconst font-lock-keyword-face\r
+ ;; 'font-lock-keyword-face\r
+ ;; "Face to use for keywords."))\r
+ ;; (or (boundp 'font-lock-function-name-face)\r
+ ;; (defconst font-lock-function-name-face\r
+ ;; 'font-lock-function-name-face\r
+ ;; "Face to use for function names.")))\r
+ (if (and\r
+ (not (cperl-is-face 'cperl-array-face))\r
+ (cperl-is-face 'font-lock-emphasized-face))\r
+ (copy-face 'font-lock-emphasized-face 'cperl-array-face))\r
+ (if (and\r
+ (not (cperl-is-face 'cperl-hash-face))\r
+ (cperl-is-face 'font-lock-other-emphasized-face))\r
+ (copy-face 'font-lock-other-emphasized-face\r
+ 'cperl-hash-face))\r
+ (if (and\r
+ (not (cperl-is-face 'cperl-nonoverridable-face))\r
+ (cperl-is-face 'font-lock-other-type-face))\r
+ (copy-face 'font-lock-other-type-face\r
+ 'cperl-nonoverridable-face))\r
+ ;;(or (boundp 'cperl-hash-face)\r
+ ;; (defconst cperl-hash-face\r
+ ;; 'cperl-hash-face\r
+ ;; "Face to use for hashes."))\r
+ ;;(or (boundp 'cperl-array-face)\r
+ ;; (defconst cperl-array-face\r
+ ;; 'cperl-array-face\r
+ ;; "Face to use for arrays."))\r
+ ;; Here we try to guess background\r
+ (let ((background\r
+ (if (boundp 'font-lock-background-mode)\r
+ font-lock-background-mode\r
+ 'light))\r
+ (face-list (and (fboundp 'face-list) (face-list))))\r
+;;;; (fset 'cperl-is-face\r
+;;;; (cond ((fboundp 'find-face)\r
+;;;; (symbol-function 'find-face))\r
+;;;; (face-list\r
+;;;; (function (lambda (face) (member face face-list))))\r
+;;;; (t\r
+;;;; (function (lambda (face) (boundp face))))))\r
+ (defvar cperl-guessed-background\r
+ (if (and (boundp 'font-lock-display-type)\r
+ (eq font-lock-display-type 'grayscale))\r
+ 'gray\r
+ background)\r
+ "Background as guessed by CPerl mode")\r
+ (and (not (cperl-is-face 'font-lock-constant-face))\r
+ (cperl-is-face 'font-lock-reference-face)\r
+ (copy-face 'font-lock-reference-face 'font-lock-constant-face))\r
+ (if (cperl-is-face 'font-lock-type-face) nil\r
+ (copy-face 'default 'font-lock-type-face)\r
+ (cond\r
+ ((eq background 'light)\r
+ (set-face-foreground 'font-lock-type-face\r
+ (if (x-color-defined-p "seagreen")\r
+ "seagreen"\r
+ "sea green")))\r
+ ((eq background 'dark)\r
+ (set-face-foreground 'font-lock-type-face\r
+ (if (x-color-defined-p "os2pink")\r
+ "os2pink"\r
+ "pink")))\r
+ (t\r
+ (set-face-background 'font-lock-type-face "gray90"))))\r
+ (if (cperl-is-face 'cperl-nonoverridable-face)\r
+ nil\r
+ (copy-face 'font-lock-type-face 'cperl-nonoverridable-face)\r
+ (cond\r
+ ((eq background 'light)\r
+ (set-face-foreground 'cperl-nonoverridable-face\r
+ (if (x-color-defined-p "chartreuse3")\r
+ "chartreuse3"\r
+ "chartreuse")))\r
+ ((eq background 'dark)\r
+ (set-face-foreground 'cperl-nonoverridable-face\r
+ (if (x-color-defined-p "orchid1")\r
+ "orchid1"\r
+ "orange")))))\r
+;;; (if (cperl-is-face 'font-lock-other-emphasized-face) nil\r
+;;; (copy-face 'bold-italic 'font-lock-other-emphasized-face)\r
+;;; (cond\r
+;;; ((eq background 'light)\r
+;;; (set-face-background 'font-lock-other-emphasized-face\r
+;;; (if (x-color-defined-p "lightyellow2")\r
+;;; "lightyellow2"\r
+;;; (if (x-color-defined-p "lightyellow")\r
+;;; "lightyellow"\r
+;;; "light yellow"))))\r
+;;; ((eq background 'dark)\r
+;;; (set-face-background 'font-lock-other-emphasized-face\r
+;;; (if (x-color-defined-p "navy")\r
+;;; "navy"\r
+;;; (if (x-color-defined-p "darkgreen")\r
+;;; "darkgreen"\r
+;;; "dark green"))))\r
+;;; (t (set-face-background 'font-lock-other-emphasized-face "gray90"))))\r
+;;; (if (cperl-is-face 'font-lock-emphasized-face) nil\r
+;;; (copy-face 'bold 'font-lock-emphasized-face)\r
+;;; (cond\r
+;;; ((eq background 'light)\r
+;;; (set-face-background 'font-lock-emphasized-face\r
+;;; (if (x-color-defined-p "lightyellow2")\r
+;;; "lightyellow2"\r
+;;; "lightyellow")))\r
+;;; ((eq background 'dark)\r
+;;; (set-face-background 'font-lock-emphasized-face\r
+;;; (if (x-color-defined-p "navy")\r
+;;; "navy"\r
+;;; (if (x-color-defined-p "darkgreen")\r
+;;; "darkgreen"\r
+;;; "dark green"))))\r
+;;; (t (set-face-background 'font-lock-emphasized-face "gray90"))))\r
+ (if (cperl-is-face 'font-lock-variable-name-face) nil\r
+ (copy-face 'italic 'font-lock-variable-name-face))\r
+ (if (cperl-is-face 'font-lock-constant-face) nil\r
+ (copy-face 'italic 'font-lock-constant-face))))\r
+ (setq cperl-faces-init t))\r
+ (error (message "cperl-init-faces (ignored): %s" errs))))\r
+\r
+\r
+(defun cperl-ps-print-init ()\r
+ "Initialization of `ps-print' components for faces used in CPerl."\r
+ (eval-after-load "ps-print"\r
+ '(setq ps-bold-faces\r
+ ;; font-lock-variable-name-face\r
+ ;; font-lock-constant-face\r
+ (append '(cperl-array-face\r
+ cperl-hash-face)\r
+ ps-bold-faces)\r
+ ps-italic-faces\r
+ ;; font-lock-constant-face\r
+ (append '(cperl-nonoverridable-face\r
+ cperl-hash-face)\r
+ ps-italic-faces)\r
+ ps-underlined-faces\r
+ ;; font-lock-type-face\r
+ (append '(cperl-array-face\r
+ cperl-hash-face\r
+ underline\r
+ cperl-nonoverridable-face)\r
+ ps-underlined-faces))))\r
+\r
+(defvar ps-print-face-extension-alist)\r
+\r
+(defun cperl-ps-print (&optional file)\r
+ "Pretty-print in CPerl style.\r
+If optional argument FILE is an empty string, prints to printer, otherwise\r
+to the file FILE. If FILE is nil, prompts for a file name.\r
+\r
+Style of printout regulated by the variable `cperl-ps-print-face-properties'."\r
+ (interactive)\r
+ (or file\r
+ (setq file (read-from-minibuffer\r
+ "Print to file (if empty - to printer): "\r
+ (concat (buffer-file-name) ".ps")\r
+ nil nil 'file-name-history)))\r
+ (or (> (length file) 0)\r
+ (setq file nil))\r
+ (require 'ps-print) ; To get ps-print-face-extension-alist\r
+ (let ((ps-print-color-p t)\r
+ (ps-print-face-extension-alist ps-print-face-extension-alist))\r
+ (cperl-ps-extend-face-list cperl-ps-print-face-properties)\r
+ (ps-print-buffer-with-faces file)))\r
+\r
+;;; (defun cperl-ps-print-init ()\r
+;;; "Initialization of `ps-print' components for faces used in CPerl."\r
+;;; ;; Guard against old versions\r
+;;; (defvar ps-underlined-faces nil)\r
+;;; (defvar ps-bold-faces nil)\r
+;;; (defvar ps-italic-faces nil)\r
+;;; (setq ps-bold-faces\r
+;;; (append '(font-lock-emphasized-face\r
+;;; cperl-array-face\r
+;;; font-lock-keyword-face\r
+;;; font-lock-variable-name-face\r
+;;; font-lock-constant-face\r
+;;; font-lock-reference-face\r
+;;; font-lock-other-emphasized-face\r
+;;; cperl-hash-face)\r
+;;; ps-bold-faces))\r
+;;; (setq ps-italic-faces\r
+;;; (append '(cperl-nonoverridable-face\r
+;;; font-lock-constant-face\r
+;;; font-lock-reference-face\r
+;;; font-lock-other-emphasized-face\r
+;;; cperl-hash-face)\r
+;;; ps-italic-faces))\r
+;;; (setq ps-underlined-faces\r
+;;; (append '(font-lock-emphasized-face\r
+;;; cperl-array-face\r
+;;; font-lock-other-emphasized-face\r
+;;; cperl-hash-face\r
+;;; cperl-nonoverridable-face font-lock-type-face)\r
+;;; ps-underlined-faces))\r
+;;; (cons 'font-lock-type-face ps-underlined-faces))\r
+\r
+\r
+(if (cperl-enable-font-lock) (cperl-windowed-init))\r
+\r
+(defconst cperl-styles-entries\r
+ '(cperl-indent-level cperl-brace-offset cperl-continued-brace-offset\r
+ cperl-label-offset cperl-extra-newline-before-brace\r
+ cperl-merge-trailing-else\r
+ cperl-continued-statement-offset))\r
+\r
+(defconst cperl-style-alist\r
+ '(("CPerl" ; =GNU without extra-newline-before-brace\r
+ (cperl-indent-level . 2)\r
+ (cperl-brace-offset . 0)\r
+ (cperl-continued-brace-offset . 0)\r
+ (cperl-label-offset . -2)\r
+ (cperl-extra-newline-before-brace . nil)\r
+ (cperl-merge-trailing-else . t)\r
+ (cperl-continued-statement-offset . 2))\r
+ ("PerlStyle" ; CPerl with 4 as indent\r
+ (cperl-indent-level . 4)\r
+ (cperl-brace-offset . 0)\r
+ (cperl-continued-brace-offset . 0)\r
+ (cperl-label-offset . -4)\r
+ (cperl-extra-newline-before-brace . nil)\r
+ (cperl-merge-trailing-else . t)\r
+ (cperl-continued-statement-offset . 4))\r
+ ("GNU"\r
+ (cperl-indent-level . 2)\r
+ (cperl-brace-offset . 0)\r
+ (cperl-continued-brace-offset . 0)\r
+ (cperl-label-offset . -2)\r
+ (cperl-extra-newline-before-brace . t)\r
+ (cperl-merge-trailing-else . nil)\r
+ (cperl-continued-statement-offset . 2))\r
+ ("K&R"\r
+ (cperl-indent-level . 5)\r
+ (cperl-brace-offset . 0)\r
+ (cperl-continued-brace-offset . -5)\r
+ (cperl-label-offset . -5)\r
+ ;;(cperl-extra-newline-before-brace . nil) ; ???\r
+ (cperl-merge-trailing-else . nil)\r
+ (cperl-continued-statement-offset . 5))\r
+ ("BSD"\r
+ (cperl-indent-level . 4)\r
+ (cperl-brace-offset . 0)\r
+ (cperl-continued-brace-offset . -4)\r
+ (cperl-label-offset . -4)\r
+ ;;(cperl-extra-newline-before-brace . nil) ; ???\r
+ (cperl-continued-statement-offset . 4))\r
+ ("C++"\r
+ (cperl-indent-level . 4)\r
+ (cperl-brace-offset . 0)\r
+ (cperl-continued-brace-offset . -4)\r
+ (cperl-label-offset . -4)\r
+ (cperl-continued-statement-offset . 4)\r
+ (cperl-merge-trailing-else . nil)\r
+ (cperl-extra-newline-before-brace . t))\r
+ ("Current")\r
+ ("Whitesmith"\r
+ (cperl-indent-level . 4)\r
+ (cperl-brace-offset . 0)\r
+ (cperl-continued-brace-offset . 0)\r
+ (cperl-label-offset . -4)\r
+ ;;(cperl-extra-newline-before-brace . nil) ; ???\r
+ (cperl-continued-statement-offset . 4)))\r
+ "(Experimental) list of variables to set to get a particular indentation style.\r
+Should be used via `cperl-set-style' or via Perl menu.")\r
+\r
+(defun cperl-set-style (style)\r
+ "Set CPerl mode variables to use one of several different indentation styles.\r
+The arguments are a string representing the desired style.\r
+The list of styles is in `cperl-style-alist', available styles\r
+are GNU, K&R, BSD, C++ and Whitesmith.\r
+\r
+The current value of style is memorized (unless there is a memorized\r
+data already), may be restored by `cperl-set-style-back'.\r
+\r
+Chosing \"Current\" style will not change style, so this may be used for\r
+side-effect of memorizing only."\r
+ (interactive\r
+ (let ((list (mapcar (function (lambda (elt) (list (car elt)))) \r
+ cperl-style-alist)))\r
+ (list (completing-read "Enter style: " list nil 'insist))))\r
+ (or cperl-old-style\r
+ (setq cperl-old-style\r
+ (mapcar (function\r
+ (lambda (name)\r
+ (cons name (eval name))))\r
+ cperl-styles-entries)))\r
+ (let ((style (cdr (assoc style cperl-style-alist))) setting str sym)\r
+ (while style\r
+ (setq setting (car style) style (cdr style))\r
+ (set (car setting) (cdr setting)))))\r
+\r
+(defun cperl-set-style-back ()\r
+ "Restore a style memorised by `cperl-set-style'."\r
+ (interactive)\r
+ (or cperl-old-style (error "The style was not changed"))\r
+ (let (setting)\r
+ (while cperl-old-style\r
+ (setq setting (car cperl-old-style)\r
+ cperl-old-style (cdr cperl-old-style))\r
+ (set (car setting) (cdr setting)))))\r
+\r
+(defun cperl-check-syntax ()\r
+ (interactive)\r
+ (require 'mode-compile)\r
+ (let ((perl-dbg-flags (concat cperl-extra-perl-args " -wc")))\r
+ (eval '(mode-compile)))) ; Avoid a warning\r
+\r
+(defun cperl-info-buffer (type)\r
+ ;; Returns buffer with documentation. Creates if missing.\r
+ ;; If TYPE, this vars buffer.\r
+ ;; Special care is taken to not stomp over an existing info buffer\r
+ (let* ((bname (if type "*info-perl-var*" "*info-perl*"))\r
+ (info (get-buffer bname))\r
+ (oldbuf (get-buffer "*info*")))\r
+ (if info info\r
+ (save-window-excursion\r
+ ;; Get Info running\r
+ (require 'info)\r
+ (cond (oldbuf\r
+ (set-buffer oldbuf)\r
+ (rename-buffer "*info-perl-tmp*")))\r
+ (save-window-excursion\r
+ (info))\r
+ (Info-find-node cperl-info-page (if type "perlvar" "perlfunc"))\r
+ (set-buffer "*info*")\r
+ (rename-buffer bname)\r
+ (cond (oldbuf\r
+ (set-buffer "*info-perl-tmp*")\r
+ (rename-buffer "*info*")\r
+ (set-buffer bname)))\r
+ (make-local-variable 'window-min-height)\r
+ (setq window-min-height 2)\r
+ (current-buffer)))))\r
+\r
+(defun cperl-word-at-point (&optional p)\r
+ "Return the word at point or at P."\r
+ (save-excursion\r
+ (if p (goto-char p))\r
+ (or (cperl-word-at-point-hard)\r
+ (progn\r
+ (require 'etags)\r
+ (funcall (or (and (boundp 'find-tag-default-function)\r
+ find-tag-default-function)\r
+ (get major-mode 'find-tag-default-function)\r
+ ;; XEmacs 19.12 has `find-tag-default-hook'; it is\r
+ ;; automatically used within `find-tag-default':\r
+ 'find-tag-default))))))\r
+\r
+(defun cperl-info-on-command (command)\r
+ "Show documentation for Perl command COMMAND in other window.\r
+If perl-info buffer is shown in some frame, uses this frame.\r
+Customized by setting variables `cperl-shrink-wrap-info-frame',\r
+`cperl-max-help-size'."\r
+ (interactive\r
+ (let* ((default (cperl-word-at-point))\r
+ (read (read-string\r
+ (format "Find doc for Perl function (default %s): "\r
+ default))))\r
+ (list (if (equal read "")\r
+ default\r
+ read))))\r
+\r
+ (let ((buffer (current-buffer))\r
+ (cmd-desc (concat "^" (regexp-quote command) "[^a-zA-Z_0-9]")) ; "tr///"\r
+ pos isvar height iniheight frheight buf win fr1 fr2 iniwin not-loner\r
+ max-height char-height buf-list)\r
+ (if (string-match "^-[a-zA-Z]$" command)\r
+ (setq cmd-desc "^-X[ \t\n]"))\r
+ (setq isvar (string-match "^[$@%]" command)\r
+ buf (cperl-info-buffer isvar)\r
+ iniwin (selected-window)\r
+ fr1 (window-frame iniwin))\r
+ (set-buffer buf)\r
+ (beginning-of-buffer)\r
+ (or isvar\r
+ (progn (re-search-forward "^-X[ \t\n]")\r
+ (forward-line -1)))\r
+ (if (re-search-forward cmd-desc nil t)\r
+ (progn\r
+ ;; Go back to beginning of the group (ex, for qq)\r
+ (if (re-search-backward "^[ \t\n\f]")\r
+ (forward-line 1))\r
+ (beginning-of-line)\r
+ ;; Get some of\r
+ (setq pos (point)\r
+ buf-list (list buf "*info-perl-var*" "*info-perl*"))\r
+ (while (and (not win) buf-list)\r
+ (setq win (get-buffer-window (car buf-list) t))\r
+ (setq buf-list (cdr buf-list)))\r
+ (or (not win)\r
+ (eq (window-buffer win) buf)\r
+ (set-window-buffer win buf))\r
+ (and win (setq fr2 (window-frame win)))\r
+ (if (or (not fr2) (eq fr1 fr2))\r
+ (pop-to-buffer buf)\r
+ (special-display-popup-frame buf) ; Make it visible\r
+ (select-window win))\r
+ (goto-char pos) ; Needed (?!).\r
+ ;; Resize\r
+ (setq iniheight (window-height)\r
+ frheight (frame-height)\r
+ not-loner (< iniheight (1- frheight))) ; Are not alone\r
+ (cond ((if not-loner cperl-max-help-size\r
+ cperl-shrink-wrap-info-frame)\r
+ (setq height\r
+ (+ 2\r
+ (count-lines\r
+ pos\r
+ (save-excursion\r
+ (if (re-search-forward\r
+ "^[ \t][^\n]*\n+\\([^ \t\n\f]\\|\\'\\)" nil t)\r
+ (match-beginning 0) (point-max)))))\r
+ max-height\r
+ (if not-loner\r
+ (/ (* (- frheight 3) cperl-max-help-size) 100)\r
+ (setq char-height (frame-char-height))\r
+ ;; Non-functioning under OS/2:\r
+ (if (eq char-height 1) (setq char-height 18))\r
+ ;; Title, menubar, + 2 for slack\r
+ (- (/ (x-display-pixel-height) char-height) 4)))\r
+ (if (> height max-height) (setq height max-height))\r
+ ;;(message "was %s doing %s" iniheight height)\r
+ (if not-loner\r
+ (enlarge-window (- height iniheight))\r
+ (set-frame-height (window-frame win) (1+ height)))))\r
+ (set-window-start (selected-window) pos))\r
+ (message "No entry for %s found." command))\r
+ ;;(pop-to-buffer buffer)\r
+ (select-window iniwin)))\r
+\r
+(defun cperl-info-on-current-command ()\r
+ "Show documentation for Perl command at point in other window."\r
+ (interactive)\r
+ (cperl-info-on-command (cperl-word-at-point)))\r
+\r
+(defun cperl-imenu-info-imenu-search ()\r
+ (if (looking-at "^-X[ \t\n]") nil\r
+ (re-search-backward\r
+ "^\n\\([-a-zA-Z_]+\\)[ \t\n]")\r
+ (forward-line 1)))\r
+\r
+(defun cperl-imenu-info-imenu-name ()\r
+ (buffer-substring\r
+ (match-beginning 1) (match-end 1)))\r
+\r
+(defun cperl-imenu-on-info ()\r
+ (interactive)\r
+ (let* ((buffer (current-buffer))\r
+ imenu-create-index-function\r
+ imenu-prev-index-position-function\r
+ imenu-extract-index-name-function\r
+ (index-item (save-restriction\r
+ (save-window-excursion\r
+ (set-buffer (cperl-info-buffer nil))\r
+ (setq imenu-create-index-function\r
+ 'imenu-default-create-index-function\r
+ imenu-prev-index-position-function\r
+ 'cperl-imenu-info-imenu-search\r
+ imenu-extract-index-name-function\r
+ 'cperl-imenu-info-imenu-name)\r
+ (imenu-choose-buffer-index)))))\r
+ (and index-item\r
+ (progn\r
+ (push-mark)\r
+ (pop-to-buffer "*info-perl*")\r
+ (cond\r
+ ((markerp (cdr index-item))\r
+ (goto-char (marker-position (cdr index-item))))\r
+ (t\r
+ (goto-char (cdr index-item))))\r
+ (set-window-start (selected-window) (point))\r
+ (pop-to-buffer buffer)))))\r
+\r
+(defun cperl-lineup (beg end &optional step minshift)\r
+ "Lineup construction in a region.\r
+Beginning of region should be at the start of a construction.\r
+All first occurrences of this construction in the lines that are\r
+partially contained in the region are lined up at the same column.\r
+\r
+MINSHIFT is the minimal amount of space to insert before the construction.\r
+STEP is the tabwidth to position constructions.\r
+If STEP is nil, `cperl-lineup-step' will be used\r
+\(or `cperl-indent-level', if `cperl-lineup-step' is `nil').\r
+Will not move the position at the start to the left."\r
+ (interactive "r")\r
+ (let (search col tcol seen b e)\r
+ (save-excursion\r
+ (goto-char end)\r
+ (end-of-line)\r
+ (setq end (point-marker))\r
+ (goto-char beg)\r
+ (skip-chars-forward " \t\f")\r
+ (setq beg (point-marker))\r
+ (indent-region beg end nil)\r
+ (goto-char beg)\r
+ (setq col (current-column))\r
+ (if (looking-at "[a-zA-Z0-9_]")\r
+ (if (looking-at "\\<[a-zA-Z0-9_]+\\>")\r
+ (setq search\r
+ (concat "\\<"\r
+ (regexp-quote\r
+ (buffer-substring (match-beginning 0)\r
+ (match-end 0))) "\\>"))\r
+ (error "Cannot line up in a middle of the word"))\r
+ (if (looking-at "$")\r
+ (error "Cannot line up end of line"))\r
+ (setq search (regexp-quote (char-to-string (following-char)))))\r
+ (setq step (or step cperl-lineup-step cperl-indent-level))\r
+ (or minshift (setq minshift 1))\r
+ (while (progn\r
+ (beginning-of-line 2)\r
+ (and (< (point) end)\r
+ (re-search-forward search end t)\r
+ (goto-char (match-beginning 0))))\r
+ (setq tcol (current-column) seen t)\r
+ (if (> tcol col) (setq col tcol)))\r
+ (or seen\r
+ (error "The construction to line up occurred only once"))\r
+ (goto-char beg)\r
+ (setq col (+ col minshift))\r
+ (if (/= (% col step) 0) (setq step (* step (1+ (/ col step)))))\r
+ (while\r
+ (progn\r
+ (setq e (point))\r
+ (skip-chars-backward " \t")\r
+ (delete-region (point) e)\r
+ (indent-to-column col) ;(make-string (- col (current-column)) ?\ ))\r
+ (beginning-of-line 2)\r
+ (and (< (point) end)\r
+ (re-search-forward search end t)\r
+ (goto-char (match-beginning 0)))))))) ; No body\r
+\r
+(defun cperl-etags (&optional add all files)\r
+ "Run etags with appropriate options for Perl files.\r
+If optional argument ALL is `recursive', will process Perl files\r
+in subdirectories too."\r
+ (interactive)\r
+ (let ((cmd "etags")\r
+ (args '("-l" "none" "-r" "/\\<\\(package\\|sub\\)[ \\t]+\\(\\([a-zA-Z0-9:_]*::\\)?\\([a-zA-Z0-9_]+\\)[ \\t]*\\(([^()]*)[ \t]*\\)?\\([{#]\\|$\\)\\)/\\4/"))\r
+ res)\r
+ (if add (setq args (cons "-a" args)))\r
+ (or files (setq files (list buffer-file-name)))\r
+ (cond\r
+ ((eq all 'recursive)\r
+ ;;(error "Not implemented: recursive")\r
+ (setq args (append (list "-e"\r
+ "sub wanted {push @ARGV, $File::Find::name if /\\.[pP][Llm]$/}\r
+ use File::Find;\r
+ find(\\&wanted, '.');\r
+ exec @ARGV;"\r
+ cmd) args)\r
+ cmd "perl"))\r
+ (all\r
+ ;;(error "Not implemented: all")\r
+ (setq args (append (list "-e"\r
+ "push @ARGV, <*.PL *.pl *.pm>;\r
+ exec @ARGV;"\r
+ cmd) args)\r
+ cmd "perl"))\r
+ (t\r
+ (setq args (append args files))))\r
+ (setq res (apply 'call-process cmd nil nil nil args))\r
+ (or (eq res 0)\r
+ (message "etags returned \"%s\"" res))))\r
+\r
+(defun cperl-toggle-auto-newline ()\r
+ "Toggle the state of `cperl-auto-newline'."\r
+ (interactive)\r
+ (setq cperl-auto-newline (not cperl-auto-newline))\r
+ (message "Newlines will %sbe auto-inserted now."\r
+ (if cperl-auto-newline "" "not ")))\r
+\r
+(defun cperl-toggle-abbrev ()\r
+ "Toggle the state of automatic keyword expansion in CPerl mode."\r
+ (interactive)\r
+ (abbrev-mode (if abbrev-mode 0 1))\r
+ (message "Perl control structure will %sbe auto-inserted now."\r
+ (if abbrev-mode "" "not ")))\r
+\r
+\r
+(defun cperl-toggle-electric ()\r
+ "Toggle the state of parentheses doubling in CPerl mode."\r
+ (interactive)\r
+ (setq cperl-electric-parens (if (cperl-val 'cperl-electric-parens) 'null t))\r
+ (message "Parentheses will %sbe auto-doubled now."\r
+ (if (cperl-val 'cperl-electric-parens) "" "not ")))\r
+\r
+(defun cperl-toggle-autohelp ()\r
+ "Toggle the state of Auto-Help on Perl constructs (put in the message area).\r
+Delay of auto-help controlled by `cperl-lazy-help-time'."\r
+ (interactive)\r
+ (if (fboundp 'run-with-idle-timer)\r
+ (progn\r
+ (if cperl-lazy-installed\r
+ (cperl-lazy-unstall)\r
+ (cperl-lazy-install))\r
+ (message "Perl help messages will %sbe automatically shown now."\r
+ (if cperl-lazy-installed "" "not ")))\r
+ (message "Cannot automatically show Perl help messages - run-with-idle-timer missing.")))\r
+\r
+(defun cperl-toggle-construct-fix ()\r
+ "Toggle whether `indent-region'/`indent-sexp' fix whitespace too."\r
+ (interactive)\r
+ (setq cperl-indent-region-fix-constructs\r
+ (if cperl-indent-region-fix-constructs\r
+ nil\r
+ 1))\r
+ (message "indent-region/indent-sexp will %sbe automatically fix whitespace."\r
+ (if cperl-indent-region-fix-constructs "" "not ")))\r
+\r
+;;;; Tags file creation.\r
+\r
+(defvar cperl-tmp-buffer " *cperl-tmp*")\r
+\r
+(defun cperl-setup-tmp-buf ()\r
+ (set-buffer (get-buffer-create cperl-tmp-buffer))\r
+ (set-syntax-table cperl-mode-syntax-table)\r
+ (buffer-disable-undo)\r
+ (auto-fill-mode 0)\r
+ (if cperl-use-syntax-table-text-property-for-tags\r
+ (progn\r
+ (make-local-variable 'parse-sexp-lookup-properties)\r
+ ;; Do not introduce variable if not needed, we check it!\r
+ (set 'parse-sexp-lookup-properties t))))\r
+\r
+(defun cperl-xsub-scan ()\r
+ (require 'cl)\r
+ (require 'imenu)\r
+ (let ((index-alist '())\r
+ (prev-pos 0) index index1 name package prefix)\r
+ (goto-char (point-min))\r
+ (if noninteractive\r
+ (message "Scanning XSUB for index")\r
+ (imenu-progress-message prev-pos 0))\r
+ ;; Search for the function\r
+ (progn ;;save-match-data\r
+ (while (re-search-forward\r
+ "^\\([ \t]*MODULE\\>[^\n]*\\<PACKAGE[ \t]*=[ \t]*\\([a-zA-Z_][a-zA-Z_0-9:]*\\)\\>\\|\\([a-zA-Z_][a-zA-Z_0-9]*\\)(\\|[ \t]*BOOT:\\)"\r
+ nil t)\r
+ (or noninteractive\r
+ (imenu-progress-message prev-pos))\r
+ (cond\r
+ ((match-beginning 2) ; SECTION\r
+ (setq package (buffer-substring (match-beginning 2) (match-end 2)))\r
+ (goto-char (match-beginning 0))\r
+ (skip-chars-forward " \t")\r
+ (forward-char 1)\r
+ (if (looking-at "[^\n]*\\<PREFIX[ \t]*=[ \t]*\\([a-zA-Z_][a-zA-Z_0-9]*\\)\\>")\r
+ (setq prefix (buffer-substring (match-beginning 1) (match-end 1)))\r
+ (setq prefix nil)))\r
+ ((not package) nil) ; C language section\r
+ ((match-beginning 3) ; XSUB\r
+ (goto-char (1+ (match-beginning 3)))\r
+ (setq index (imenu-example--name-and-position))\r
+ (setq name (buffer-substring (match-beginning 3) (match-end 3)))\r
+ (if (and prefix (string-match (concat "^" prefix) name))\r
+ (setq name (substring name (length prefix))))\r
+ (cond ((string-match "::" name) nil)\r
+ (t\r
+ (setq index1 (cons (concat package "::" name) (cdr index)))\r
+ (push index1 index-alist)))\r
+ (setcar index name)\r
+ (push index index-alist))\r
+ (t ; BOOT: section\r
+ ;; (beginning-of-line)\r
+ (setq index (imenu-example--name-and-position))\r
+ (setcar index (concat package "::BOOT:"))\r
+ (push index index-alist)))))\r
+ (or noninteractive\r
+ (imenu-progress-message prev-pos 100))\r
+ index-alist))\r
+\r
+(defvar cperl-unreadable-ok nil)\r
+\r
+(defun cperl-find-tags (ifile xs topdir)\r
+ (let ((b (get-buffer cperl-tmp-buffer)) ind lst elt pos ret rel\r
+ (cperl-pod-here-fontify nil) f file)\r
+ (save-excursion\r
+ (if b (set-buffer b)\r
+ (cperl-setup-tmp-buf))\r
+ (erase-buffer)\r
+ (condition-case err\r
+ (setq file (car (insert-file-contents ifile)))\r
+ (error (if cperl-unreadable-ok nil\r
+ (if (y-or-n-p\r
+ (format "File %s unreadable. Continue? " ifile))\r
+ (setq cperl-unreadable-ok t)\r
+ (error "Aborting: unreadable file %s" ifile)))))\r
+ (if (not file)\r
+ (message "Unreadable file %s" ifile)\r
+ (message "Scanning file %s ..." file)\r
+ (if (and cperl-use-syntax-table-text-property-for-tags\r
+ (not xs))\r
+ (condition-case err ; after __END__ may have garbage\r
+ (cperl-find-pods-heres nil nil noninteractive)\r
+ (error (message "While scanning for syntax: %s" err))))\r
+ (if xs\r
+ (setq lst (cperl-xsub-scan))\r
+ (setq ind (cperl-imenu--create-perl-index))\r
+ (setq lst (cdr (assoc "+Unsorted List+..." ind))))\r
+ (setq lst\r
+ (mapcar\r
+ (function\r
+ (lambda (elt)\r
+ (cond ((string-match "^[_a-zA-Z]" (car elt))\r
+ (goto-char (cdr elt))\r
+ (beginning-of-line) ; pos should be of the start of the line\r
+ (list (car elt)\r
+ (point)\r
+ (1+ (count-lines 1 (point))) ; 1+ since at beg-o-l\r
+ (buffer-substring (progn\r
+ (goto-char (cdr elt))\r
+ ;; After name now...\r
+ (or (eolp) (forward-char 1))\r
+ (point))\r
+ (progn\r
+ (beginning-of-line)\r
+ (point))))))))\r
+ lst))\r
+ (erase-buffer)\r
+ (while lst\r
+ (setq elt (car lst) lst (cdr lst))\r
+ (if elt\r
+ (progn\r
+ (insert (elt elt 3)\r
+ 127\r
+ (if (string-match "^package " (car elt))\r
+ (substring (car elt) 8)\r
+ (car elt) )\r
+ 1\r
+ (number-to-string (elt elt 2)) ; Line\r
+ ","\r
+ (number-to-string (1- (elt elt 1))) ; Char pos 0-based\r
+ "\n")\r
+ (if (and (string-match "^[_a-zA-Z]+::" (car elt))\r
+ (string-match "^sub[ \t]+\\([_a-zA-Z]+\\)[^:_a-zA-Z]"\r
+ (elt elt 3)))\r
+ ;; Need to insert the name without package as well\r
+ (setq lst (cons (cons (substring (elt elt 3) \r
+ (match-beginning 1)\r
+ (match-end 1))\r
+ (cdr elt))\r
+ lst))))))\r
+ (setq pos (point))\r
+ (goto-char 1)\r
+ (setq rel file)\r
+ ;; On case-preserving filesystems (EMX on OS/2) case might be encoded in properties\r
+ (set-text-properties 0 (length rel) nil rel)\r
+ (and (equal topdir (substring rel 0 (length topdir)))\r
+ (setq rel (substring file (length topdir))))\r
+ (insert "\f\n" rel "," (number-to-string (1- pos)) "\n")\r
+ (setq ret (buffer-substring 1 (point-max)))\r
+ (erase-buffer)\r
+ (or noninteractive\r
+ (message "Scanning file %s finished" file))\r
+ ret))))\r
+\r
+(defun cperl-add-tags-recurse-noxs ()\r
+ "Add to TAGS data for Perl and XSUB files in the current directory and kids.\r
+Use as\r
+ emacs -batch -q -no-site-file -l emacs/cperl-mode.el \\r
+ -f cperl-add-tags-recurse\r
+"\r
+ (cperl-write-tags nil nil t t nil t))\r
+\r
+(defun cperl-add-tags-recurse ()\r
+ "Add to TAGS file data for Perl files in the current directory and kids.\r
+Use as\r
+ emacs -batch -q -no-site-file -l emacs/cperl-mode.el \\r
+ -f cperl-add-tags-recurse\r
+"\r
+ (cperl-write-tags nil nil t t))\r
+\r
+(defun cperl-write-tags (&optional file erase recurse dir inbuffer noxs topdir)\r
+ ;; If INBUFFER, do not select buffer, and do not save\r
+ ;; If ERASE is `ignore', do not erase, and do not try to delete old info.\r
+ (require 'etags)\r
+ (if file nil\r
+ (setq file (if dir default-directory (buffer-file-name)))\r
+ (if (and (not dir) (buffer-modified-p)) (error "Save buffer first!")))\r
+ (or topdir\r
+ (setq topdir default-directory))\r
+ (let ((tags-file-name "TAGS")\r
+ (case-fold-search (eq system-type 'emx))\r
+ xs rel tm)\r
+ (save-excursion\r
+ (cond (inbuffer nil) ; Already there\r
+ ((file-exists-p tags-file-name)\r
+ (if cperl-xemacs-p\r
+ (visit-tags-table-buffer)\r
+ (visit-tags-table-buffer tags-file-name)))\r
+ (t (set-buffer (find-file-noselect tags-file-name))))\r
+ (cond\r
+ (dir\r
+ (cond ((eq erase 'ignore))\r
+ (erase\r
+ (erase-buffer)\r
+ (setq erase 'ignore)))\r
+ (let ((files\r
+ (condition-case err\r
+ (directory-files file t\r
+ (if recurse nil cperl-scan-files-regexp)\r
+ t)\r
+ (error\r
+ (if cperl-unreadable-ok nil\r
+ (if (y-or-n-p\r
+ (format "Directory %s unreadable. Continue? " file))\r
+ (setq cperl-unreadable-ok t\r
+ tm nil) ; Return empty list\r
+ (error "Aborting: unreadable directory %s" file)))))))\r
+ (mapcar (function \r
+ (lambda (file)\r
+ (cond\r
+ ((string-match cperl-noscan-files-regexp file)\r
+ nil)\r
+ ((not (file-directory-p file))\r
+ (if (string-match cperl-scan-files-regexp file)\r
+ (cperl-write-tags file erase recurse nil t noxs topdir)))\r
+ ((not recurse) nil)\r
+ (t (cperl-write-tags file erase recurse t t noxs topdir)))))\r
+ files)))\r
+ (t\r
+ (setq xs (string-match "\\.xs$" file))\r
+ (if (not (and xs noxs))\r
+ (progn\r
+ (cond ((eq erase 'ignore) (goto-char (point-max)))\r
+ (erase (erase-buffer))\r
+ (t\r
+ (goto-char 1)\r
+ (setq rel file)\r
+ ;; On case-preserving filesystems (EMX on OS/2) case might be encoded in properties\r
+ (set-text-properties 0 (length rel) nil rel)\r
+ (and (equal topdir (substring rel 0 (length topdir)))\r
+ (setq rel (substring file (length topdir))))\r
+ (if (search-forward (concat "\f\n" rel ",") nil t)\r
+ (progn\r
+ (search-backward "\f\n")\r
+ (delete-region (point)\r
+ (save-excursion\r
+ (forward-char 1)\r
+ (if (search-forward "\f\n"\r
+ nil 'toend)\r
+ (- (point) 2)\r
+ (point-max)))))\r
+ (goto-char (point-max)))))\r
+ (insert (cperl-find-tags file xs topdir))))))\r
+ (if inbuffer nil ; Delegate to the caller\r
+ (save-buffer 0) ; No backup\r
+ (if (fboundp 'initialize-new-tags-table) ; Do we need something special in XEmacs?\r
+ (initialize-new-tags-table))))))\r
+\r
+(defvar cperl-tags-hier-regexp-list\r
+ (concat\r
+ "^\\("\r
+ "\\(package\\)\\>"\r
+ "\\|"\r
+ "sub\\>[^\n]+::"\r
+ "\\|"\r
+ "[a-zA-Z_][a-zA-Z_0-9:]*(\C-?[^\n]+::" ; XSUB?\r
+ "\\|"\r
+ "[ \t]*BOOT:\C-?[^\n]+::" ; BOOT section\r
+ "\\)"))\r
+\r
+(defvar cperl-hierarchy '(() ())\r
+ "Global hierarchy of classes.")\r
+\r
+(defun cperl-tags-hier-fill ()\r
+ ;; Suppose we are in a tag table cooked by cperl.\r
+ (goto-char 1)\r
+ (let (type pack name pos line chunk ord cons1 file str info fileind)\r
+ (while (re-search-forward cperl-tags-hier-regexp-list nil t)\r
+ (setq pos (match-beginning 0)\r
+ pack (match-beginning 2))\r
+ (beginning-of-line)\r
+ (if (looking-at (concat\r
+ "\\([^\n]+\\)"\r
+ "\C-?"\r
+ "\\([^\n]+\\)"\r
+ "\C-a"\r
+ "\\([0-9]+\\)"\r
+ ","\r
+ "\\([0-9]+\\)"))\r
+ (progn\r
+ (setq ;;str (buffer-substring (match-beginning 1) (match-end 1))\r
+ name (buffer-substring (match-beginning 2) (match-end 2))\r
+ ;;pos (buffer-substring (match-beginning 3) (match-end 3))\r
+ line (buffer-substring (match-beginning 3) (match-end 3))\r
+ ord (if pack 1 0)\r
+ file (file-of-tag)\r
+ fileind (format "%s:%s" file line)\r
+ ;; Moves to beginning of the next line:\r
+ info (cperl-etags-snarf-tag file line))\r
+ ;; Move back\r
+ (forward-char -1)\r
+ ;; Make new member of hierarchy name ==> file ==> pos if needed\r
+ (if (setq cons1 (assoc name (nth ord cperl-hierarchy)))\r
+ ;; Name known\r
+ (setcdr cons1 (cons (cons fileind (vector file info))\r
+ (cdr cons1)))\r
+ ;; First occurrence of the name, start alist\r
+ (setq cons1 (cons name (list (cons fileind (vector file info)))))\r
+ (if pack\r
+ (setcar (cdr cperl-hierarchy)\r
+ (cons cons1 (nth 1 cperl-hierarchy)))\r
+ (setcar cperl-hierarchy\r
+ (cons cons1 (car cperl-hierarchy)))))))\r
+ (end-of-line))))\r
+\r
+(defun cperl-tags-hier-init (&optional update)\r
+ "Show hierarchical menu of classes and methods.\r
+Finds info about classes by a scan of loaded TAGS files.\r
+Supposes that the TAGS files contain fully qualified function names.\r
+One may build such TAGS files from CPerl mode menu."\r
+ (interactive)\r
+ (require 'etags)\r
+ (require 'imenu)\r
+ (if (or update (null (nth 2 cperl-hierarchy)))\r
+ (let ((remover (function (lambda (elt) ; (name (file1...) (file2..))\r
+ (or (nthcdr 2 elt)\r
+ ;; Only in one file\r
+ (setcdr elt (cdr (nth 1 elt)))))))\r
+ pack name cons1 to l1 l2 l3 l4 b)\r
+ ;; (setq cperl-hierarchy '(() () ())) ; Would write into '() later!\r
+ (setq cperl-hierarchy (list l1 l2 l3))\r
+ (if cperl-xemacs-p ; Not checked\r
+ (progn\r
+ (or tags-file-name\r
+ ;; Does this work in XEmacs?\r
+ (call-interactively 'visit-tags-table))\r
+ (message "Updating list of classes...")\r
+ (set-buffer (get-file-buffer tags-file-name))\r
+ (cperl-tags-hier-fill))\r
+ (or tags-table-list\r
+ (call-interactively 'visit-tags-table))\r
+ (mapcar \r
+ (function\r
+ (lambda (tagsfile)\r
+ (message "Updating list of classes... %s" tagsfile)\r
+ (set-buffer (get-file-buffer tagsfile))\r
+ (cperl-tags-hier-fill)))\r
+ tags-table-list)\r
+ (message "Updating list of classes... postprocessing..."))\r
+ (mapcar remover (car cperl-hierarchy))\r
+ (mapcar remover (nth 1 cperl-hierarchy))\r
+ (setq to (list nil (cons "Packages: " (nth 1 cperl-hierarchy))\r
+ (cons "Methods: " (car cperl-hierarchy))))\r
+ (cperl-tags-treeify to 1)\r
+ (setcar (nthcdr 2 cperl-hierarchy)\r
+ (cperl-menu-to-keymap (cons '("+++UPDATE+++" . -999) (cdr to))))\r
+ (message "Updating list of classes: done, requesting display...")\r
+ ;;(cperl-imenu-addback (nth 2 cperl-hierarchy))\r
+ ))\r
+ (or (nth 2 cperl-hierarchy)\r
+ (error "No items found"))\r
+ (setq update\r
+;;; (imenu-choose-buffer-index "Packages: " (nth 2 cperl-hierarchy))\r
+ (if (if (boundp 'display-popup-menus-p)\r
+ (let ((f 'display-popup-menus-p))\r
+ (funcall f))\r
+ window-system)\r
+ (x-popup-menu t (nth 2 cperl-hierarchy))\r
+ (require 'tmm)\r
+ (tmm-prompt (nth 2 cperl-hierarchy))))\r
+ (if (and update (listp update))\r
+ (progn (while (cdr update) (setq update (cdr update)))\r
+ (setq update (car update)))) ; Get the last from the list\r
+ (if (vectorp update)\r
+ (progn\r
+ (find-file (elt update 0))\r
+ (cperl-etags-goto-tag-location (elt update 1))))\r
+ (if (eq update -999) (cperl-tags-hier-init t)))\r
+\r
+(defun cperl-tags-treeify (to level)\r
+ ;; cadr of `to' is read-write. On start it is a cons\r
+ (let* ((regexp (concat "^\\(" (mapconcat\r
+ 'identity\r
+ (make-list level "[_a-zA-Z0-9]+")\r
+ "::")\r
+ "\\)\\(::\\)?"))\r
+ (packages (cdr (nth 1 to)))\r
+ (methods (cdr (nth 2 to)))\r
+ l1 head tail cons1 cons2 ord writeto packs recurse\r
+ root-packages root-functions ms many_ms same_name ps\r
+ (move-deeper\r
+ (function \r
+ (lambda (elt)\r
+ (cond ((and (string-match regexp (car elt))\r
+ (or (eq ord 1) (match-end 2)))\r
+ (setq head (substring (car elt) 0 (match-end 1))\r
+ tail (if (match-end 2) (substring (car elt) \r
+ (match-end 2)))\r
+ recurse t)\r
+ (if (setq cons1 (assoc head writeto)) nil\r
+ ;; Need to init new head\r
+ (setcdr writeto (cons (list head (list "Packages: ")\r
+ (list "Methods: "))\r
+ (cdr writeto)))\r
+ (setq cons1 (nth 1 writeto)))\r
+ (setq cons2 (nth ord cons1)) ; Either packs or meths\r
+ (setcdr cons2 (cons elt (cdr cons2))))\r
+ ((eq ord 2)\r
+ (setq root-functions (cons elt root-functions)))\r
+ (t\r
+ (setq root-packages (cons elt root-packages))))))))\r
+ (setcdr to l1) ; Init to dynamic space\r
+ (setq writeto to)\r
+ (setq ord 1)\r
+ (mapcar move-deeper packages)\r
+ (setq ord 2)\r
+ (mapcar move-deeper methods)\r
+ (if recurse\r
+ (mapcar (function (lambda (elt)\r
+ (cperl-tags-treeify elt (1+ level))))\r
+ (cdr to)))\r
+ ;;Now clean up leaders with one child only\r
+ (mapcar (function (lambda (elt)\r
+ (if (not (and (listp (cdr elt)) \r
+ (eq (length elt) 2))) nil\r
+ (setcar elt (car (nth 1 elt)))\r
+ (setcdr elt (cdr (nth 1 elt))))))\r
+ (cdr to))\r
+ ;; Sort the roots of subtrees\r
+ (if (default-value 'imenu-sort-function)\r
+ (setcdr to\r
+ (sort (cdr to) (default-value 'imenu-sort-function))))\r
+ ;; Now add back functions removed from display\r
+ (mapcar (function (lambda (elt)\r
+ (setcdr to (cons elt (cdr to)))))\r
+ (if (default-value 'imenu-sort-function)\r
+ (nreverse\r
+ (sort root-functions (default-value 'imenu-sort-function)))\r
+ root-functions))\r
+ ;; Now add back packages removed from display\r
+ (mapcar (function (lambda (elt)\r
+ (setcdr to (cons (cons (concat "package " (car elt)) \r
+ (cdr elt)) \r
+ (cdr to)))))\r
+ (if (default-value 'imenu-sort-function)\r
+ (nreverse\r
+ (sort root-packages (default-value 'imenu-sort-function)))\r
+ root-packages))))\r
+\r
+;;;(x-popup-menu t\r
+;;; '(keymap "Name1"\r
+;;; ("Ret1" "aa")\r
+;;; ("Head1" "ab"\r
+;;; keymap "Name2"\r
+;;; ("Tail1" "x") ("Tail2" "y"))))\r
+\r
+(defun cperl-list-fold (list name limit)\r
+ (let (list1 list2 elt1 (num 0))\r
+ (if (<= (length list) limit) list\r
+ (setq list1 nil list2 nil)\r
+ (while list\r
+ (setq num (1+ num)\r
+ elt1 (car list)\r
+ list (cdr list))\r
+ (if (<= num imenu-max-items)\r
+ (setq list2 (cons elt1 list2))\r
+ (setq list1 (cons (cons name\r
+ (nreverse list2))\r
+ list1)\r
+ list2 (list elt1)\r
+ num 1)))\r
+ (nreverse (cons (cons name\r
+ (nreverse list2))\r
+ list1)))))\r
+\r
+(defun cperl-menu-to-keymap (menu &optional name)\r
+ (let (list)\r
+ (cons 'keymap\r
+ (mapcar\r
+ (function\r
+ (lambda (elt)\r
+ (cond ((listp (cdr elt))\r
+ (setq list (cperl-list-fold\r
+ (cdr elt) (car elt) imenu-max-items))\r
+ (cons nil\r
+ (cons (car elt)\r
+ (cperl-menu-to-keymap list))))\r
+ (t\r
+ (list (cdr elt) (car elt) t))))) ; t is needed in 19.34\r
+ (cperl-list-fold menu "Root" imenu-max-items)))))\r
+\r
+\f\r
+(defvar cperl-bad-style-regexp\r
+ (mapconcat 'identity\r
+ '("[^-\n\t <>=+!.&|(*/'`\"#^][-=+<>!|&^]" ; char sign\r
+ "[-<>=+^&|]+[^- \t\n=+<>~]") ; sign+ char \r
+ "\\|")\r
+ "Finds places such that insertion of a whitespace may help a lot.")\r
+\r
+(defvar cperl-not-bad-style-regexp\r
+ (mapconcat \r
+ 'identity\r
+ '("[^-\t <>=+]\\(--\\|\\+\\+\\)" ; var-- var++\r
+ "[a-zA-Z0-9_][|&][a-zA-Z0-9_$]" ; abc|def abc&def are often used.\r
+ "&[(a-zA-Z0-9_$]" ; &subroutine &(var->field)\r
+ "<\\$?\\sw+\\(\\.\\sw+\\)?>" ; <IN> <stdin.h>\r
+ "-[a-zA-Z][ \t]+[_$\"'`a-zA-Z]" ; -f file, -t STDIN\r
+ "-[0-9]" ; -5\r
+ "\\+\\+" ; ++var\r
+ "--" ; --var\r
+ ".->" ; a->b\r
+ "->" ; a SPACE ->b\r
+ "\\[-" ; a[-1]\r
+ "\\\\[&$@*\\\\]" ; \&func\r
+ "^=" ; =head\r
+ "\\$." ; $|\r
+ "<<[a-zA-Z_'\"`]" ; <<FOO, <<'FOO'\r
+ "||"\r
+ "&&"\r
+ "[CBIXSLFZ]<\\(\\sw\\|\\s \\|\\s_\\|[\n]\\)*>" ; C<code like text>\r
+ "-[a-zA-Z_0-9]+[ \t]*=>" ; -option => value\r
+ ;; Unaddressed trouble spots: = -abc, f(56, -abc) --- specialcased below\r
+ ;;"[*/+-|&<.]+="\r
+ )\r
+ "\\|")\r
+ "If matches at the start of match found by `my-bad-c-style-regexp',\r
+insertion of a whitespace will not help.")\r
+\r
+(defvar found-bad)\r
+\r
+(defun cperl-find-bad-style ()\r
+ "Find places in the buffer where insertion of a whitespace may help.\r
+Prompts user for insertion of spaces.\r
+Currently it is tuned to C and Perl syntax."\r
+ (interactive)\r
+ (let (found-bad (p (point)))\r
+ (setq last-nonmenu-event 13) ; To disable popup\r
+ (beginning-of-buffer)\r
+ (map-y-or-n-p "Insert space here? "\r
+ (lambda (arg) (insert " "))\r
+ 'cperl-next-bad-style\r
+ '("location" "locations" "insert a space into")\r
+ '((?\C-r (lambda (arg)\r
+ (let ((buffer-quit-function\r
+ 'exit-recursive-edit))\r
+ (message "Exit with Esc Esc")\r
+ (recursive-edit)\r
+ t)) ; Consider acted upon\r
+ "edit, exit with Esc Esc")\r
+ (?e (lambda (arg)\r
+ (let ((buffer-quit-function\r
+ 'exit-recursive-edit))\r
+ (message "Exit with Esc Esc")\r
+ (recursive-edit)\r
+ t)) ; Consider acted upon\r
+ "edit, exit with Esc Esc"))\r
+ t)\r
+ (if found-bad (goto-char found-bad)\r
+ (goto-char p)\r
+ (message "No appropriate place found"))))\r
+\r
+(defun cperl-next-bad-style ()\r
+ (let (p (not-found t) (point (point)) found)\r
+ (while (and not-found\r
+ (re-search-forward cperl-bad-style-regexp nil 'to-end))\r
+ (setq p (point))\r
+ (goto-char (match-beginning 0))\r
+ (if (or\r
+ (looking-at cperl-not-bad-style-regexp)\r
+ ;; Check for a < -b and friends\r
+ (and (eq (following-char) ?\-)\r
+ (save-excursion\r
+ (skip-chars-backward " \t\n")\r
+ (memq (preceding-char) '(?\= ?\> ?\< ?\, ?\( ?\[ ?\{))))\r
+ ;; Now check for syntax type\r
+ (save-match-data\r
+ (setq found (point))\r
+ (beginning-of-defun)\r
+ (let ((pps (parse-partial-sexp (point) found)))\r
+ (or (nth 3 pps) (nth 4 pps) (nth 5 pps)))))\r
+ (goto-char (match-end 0))\r
+ (goto-char (1- p))\r
+ (setq not-found nil\r
+ found-bad found)))\r
+ (not not-found)))\r
+\r
+\f\r
+;;; Getting help\r
+(defvar cperl-have-help-regexp\r
+ ;;(concat "\\("\r
+ (mapconcat\r
+ 'identity\r
+ '("[$@%*&][0-9a-zA-Z_:]+\\([ \t]*[[{]\\)?" ; Usual variable\r
+ "[$@]\\^[a-zA-Z]" ; Special variable\r
+ "[$@][^ \n\t]" ; Special variable\r
+ "-[a-zA-Z]" ; File test\r
+ "\\\\[a-zA-Z0]" ; Special chars\r
+ "^=[a-z][a-zA-Z0-9_]*" ; POD sections\r
+ "[-!&*+,-./<=>?\\\\^|~]+" ; Operator\r
+ "[a-zA-Z_0-9:]+" ; symbol or number\r
+ "x="\r
+ "#!")\r
+ ;;"\\)\\|\\("\r
+ "\\|")\r
+ ;;"\\)"\r
+ ;;)\r
+ "Matches places in the buffer we can find help for.")\r
+\r
+(defvar cperl-message-on-help-error t)\r
+(defvar cperl-help-from-timer nil)\r
+\r
+(defun cperl-word-at-point-hard ()\r
+ ;; Does not save-excursion\r
+ ;; Get to the something meaningful\r
+ (or (eobp) (eolp) (forward-char 1))\r
+ (re-search-backward "[-a-zA-Z0-9_:!&*+,-./<=>?\\\\^|~$%@]"\r
+ (save-excursion (beginning-of-line) (point))\r
+ 'to-beg)\r
+ ;; (cond\r
+ ;; ((or (eobp) (looking-at "[][ \t\n{}();,]")) ; Not at a symbol\r
+ ;; (skip-chars-backward " \n\t\r({[]});,")\r
+ ;; (or (bobp) (backward-char 1))))\r
+ ;; Try to backtrace\r
+ (cond\r
+ ((looking-at "[a-zA-Z0-9_:]") ; symbol\r
+ (skip-chars-backward "a-zA-Z0-9_:")\r
+ (cond\r
+ ((and (eq (preceding-char) ?^) ; $^I\r
+ (eq (char-after (- (point) 2)) ?\$))\r
+ (forward-char -2))\r
+ ((memq (preceding-char) (append "*$@%&\\" nil)) ; *glob\r
+ (forward-char -1))\r
+ ((and (eq (preceding-char) ?\=)\r
+ (eq (current-column) 1))\r
+ (forward-char -1))) ; =head1\r
+ (if (and (eq (preceding-char) ?\<)\r
+ (looking-at "\\$?[a-zA-Z0-9_:]+>")) ; <FH>\r
+ (forward-char -1)))\r
+ ((and (looking-at "=") (eq (preceding-char) ?x)) ; x=\r
+ (forward-char -1))\r
+ ((and (looking-at "\\^") (eq (preceding-char) ?\$)) ; $^I\r
+ (forward-char -1))\r
+ ((looking-at "[-!&*+,-./<=>?\\\\^|~]")\r
+ (skip-chars-backward "-!&*+,-./<=>?\\\\^|~")\r
+ (cond\r
+ ((and (eq (preceding-char) ?\$)\r
+ (not (eq (char-after (- (point) 2)) ?\$))) ; $-\r
+ (forward-char -1))\r
+ ((and (eq (following-char) ?\>)\r
+ (string-match "[a-zA-Z0-9_]" (char-to-string (preceding-char)))\r
+ (save-excursion\r
+ (forward-sexp -1)\r
+ (and (eq (preceding-char) ?\<)\r
+ (looking-at "\\$?[a-zA-Z0-9_:]+>")))) ; <FH>\r
+ (search-backward "<"))))\r
+ ((and (eq (following-char) ?\$)\r
+ (eq (preceding-char) ?\<)\r
+ (looking-at "\\$?[a-zA-Z0-9_:]+>")) ; <$fh>\r
+ (forward-char -1)))\r
+ (if (looking-at cperl-have-help-regexp)\r
+ (buffer-substring (match-beginning 0) (match-end 0))))\r
+\r
+(defun cperl-get-help ()\r
+ "Get one-line docs on the symbol at the point.\r
+The data for these docs is a little bit obsolete and may be in fact longer\r
+than a line. Your contribution to update/shorten it is appreciated."\r
+ (interactive)\r
+ (save-match-data ; May be called "inside" query-replace\r
+ (save-excursion\r
+ (let ((word (cperl-word-at-point-hard)))\r
+ (if word\r
+ (if (and cperl-help-from-timer ; Bail out if not in mainland\r
+ (not (string-match "^#!\\|\\\\\\|^=" word)) ; Show help even in comments/strings.\r
+ (or (memq (get-text-property (point) 'face)\r
+ '(font-lock-comment-face font-lock-string-face))\r
+ (memq (get-text-property (point) 'syntax-type)\r
+ '(pod here-doc format))))\r
+ nil\r
+ (cperl-describe-perl-symbol word))\r
+ (if cperl-message-on-help-error\r
+ (message "Nothing found for %s..."\r
+ (buffer-substring (point) (min (+ 5 (point)) (point-max))))))))))\r
+\r
+;;; Stolen from perl-descr.el by Johan Vromans:\r
+\r
+(defvar cperl-doc-buffer " *perl-doc*"\r
+ "Where the documentation can be found.")\r
+\r
+(defun cperl-describe-perl-symbol (val)\r
+ "Display the documentation of symbol at point, a Perl operator."\r
+ (let ((enable-recursive-minibuffers t)\r
+ args-file regexp)\r
+ (cond\r
+ ((string-match "^[&*][a-zA-Z_]" val)\r
+ (setq val (concat (substring val 0 1) "NAME")))\r
+ ((string-match "^[$@]\\([a-zA-Z_:0-9]+\\)[ \t]*\\[" val)\r
+ (setq val (concat "@" (substring val 1 (match-end 1)))))\r
+ ((string-match "^[$@]\\([a-zA-Z_:0-9]+\\)[ \t]*{" val)\r
+ (setq val (concat "%" (substring val 1 (match-end 1)))))\r
+ ((and (string= val "x") (string-match "^x=" val))\r
+ (setq val "x="))\r
+ ((string-match "^\\$[\C-a-\C-z]" val)\r
+ (setq val (concat "$^" (char-to-string (+ ?A -1 (aref val 1))))))\r
+ ((string-match "^CORE::" val)\r
+ (setq val "CORE::"))\r
+ ((string-match "^SUPER::" val)\r
+ (setq val "SUPER::"))\r
+ ((and (string= "<" val) (string-match "^<\\$?[a-zA-Z0-9_:]+>" val))\r
+ (setq val "<NAME>")))\r
+ (setq regexp (concat "^"\r
+ "\\([^a-zA-Z0-9_:]+[ \t]+\\)?"\r
+ (regexp-quote val)\r
+ "\\([ \t([/]\\|$\\)"))\r
+\r
+ ;; get the buffer with the documentation text\r
+ (cperl-switch-to-doc-buffer)\r
+\r
+ ;; lookup in the doc\r
+ (goto-char (point-min))\r
+ (let ((case-fold-search nil))\r
+ (list\r
+ (if (re-search-forward regexp (point-max) t)\r
+ (save-excursion\r
+ (beginning-of-line 1)\r
+ (let ((lnstart (point)))\r
+ (end-of-line)\r
+ (message "%s" (buffer-substring lnstart (point)))))\r
+ (if cperl-message-on-help-error\r
+ (message "No definition for %s" val)))))))\r
+\r
+(defvar cperl-short-docs 'please-ignore-this-line\r
+ ;; Perl4 version was written by Johan Vromans (jvromans@squirrel.nl)\r
+ "# based on '@(#)@ perl-descr.el 1.9 - describe-perl-symbol' [Perl 5]\r
+... Range (list context); flip/flop [no flop when flip] (scalar context).\r
+! ... Logical negation.\r
+... != ... Numeric inequality.\r
+... !~ ... Search pattern, substitution, or translation (negated).\r
+$! In numeric context: errno. In a string context: error string.\r
+$\" The separator which joins elements of arrays interpolated in strings.\r
+$# The output format for printed numbers. Default is %.15g or close.\r
+$$ Process number of this script. Changes in the fork()ed child process.\r
+$% The current page number of the currently selected output channel.\r
+\r
+ The following variables are always local to the current block:\r
+\r
+$1 Match of the 1st set of parentheses in the last match (auto-local).\r
+$2 Match of the 2nd set of parentheses in the last match (auto-local).\r
+$3 Match of the 3rd set of parentheses in the last match (auto-local).\r
+$4 Match of the 4th set of parentheses in the last match (auto-local).\r
+$5 Match of the 5th set of parentheses in the last match (auto-local).\r
+$6 Match of the 6th set of parentheses in the last match (auto-local).\r
+$7 Match of the 7th set of parentheses in the last match (auto-local).\r
+$8 Match of the 8th set of parentheses in the last match (auto-local).\r
+$9 Match of the 9th set of parentheses in the last match (auto-local).\r
+$& The string matched by the last pattern match (auto-local).\r
+$' The string after what was matched by the last match (auto-local).\r
+$` The string before what was matched by the last match (auto-local).\r
+\r
+$( The real gid of this process.\r
+$) The effective gid of this process.\r
+$* Deprecated: Set to 1 to do multiline matching within a string.\r
+$+ The last bracket matched by the last search pattern.\r
+$, The output field separator for the print operator.\r
+$- The number of lines left on the page.\r
+$. The current input line number of the last filehandle that was read.\r
+$/ The input record separator, newline by default.\r
+$0 Name of the file containing the current perl script (read/write).\r
+$: String may be broken after these characters to fill ^-lines in a format.\r
+$; Subscript separator for multi-dim array emulation. Default \"\\034\".\r
+$< The real uid of this process.\r
+$= The page length of the current output channel. Default is 60 lines.\r
+$> The effective uid of this process.\r
+$? The status returned by the last ``, pipe close or `system'.\r
+$@ The perl error message from the last eval or do @var{EXPR} command.\r
+$ARGV The name of the current file used with <> .\r
+$[ Deprecated: The index of the first element/char in an array/string.\r
+$\\ The output record separator for the print operator.\r
+$] The perl version string as displayed with perl -v.\r
+$^ The name of the current top-of-page format.\r
+$^A The current value of the write() accumulator for format() lines.\r
+$^D The value of the perl debug (-D) flags.\r
+$^E Information about the last system error other than that provided by $!.\r
+$^F The highest system file descriptor, ordinarily 2.\r
+$^H The current set of syntax checks enabled by `use strict'.\r
+$^I The value of the in-place edit extension (perl -i option).\r
+$^L What formats output to perform a formfeed. Default is \f.\r
+$^M A buffer for emergency memory allocation when running out of memory.\r
+$^O The operating system name under which this copy of Perl was built.\r
+$^P Internal debugging flag.\r
+$^T The time the script was started. Used by -A/-M/-C file tests.\r
+$^W True if warnings are requested (perl -w flag).\r
+$^X The name under which perl was invoked (argv[0] in C-speech).\r
+$_ The default input and pattern-searching space.\r
+$| Auto-flush after write/print on current output channel? Default 0.\r
+$~ The name of the current report format.\r
+... % ... Modulo division.\r
+... %= ... Modulo division assignment.\r
+%ENV Contains the current environment.\r
+%INC List of files that have been require-d or do-ne.\r
+%SIG Used to set signal handlers for various signals.\r
+... & ... Bitwise and.\r
+... && ... Logical and.\r
+... &&= ... Logical and assignment.\r
+... &= ... Bitwise and assignment.\r
+... * ... Multiplication.\r
+... ** ... Exponentiation.\r
+*NAME Glob: all objects refered by NAME. *NAM1 = *NAM2 aliases NAM1 to NAM2.\r
+&NAME(arg0, ...) Subroutine call. Arguments go to @_.\r
+... + ... Addition. +EXPR Makes EXPR into scalar context.\r
+++ Auto-increment (magical on strings). ++EXPR EXPR++\r
+... += ... Addition assignment.\r
+, Comma operator.\r
+... - ... Subtraction.\r
+-- Auto-decrement (NOT magical on strings). --EXPR EXPR--\r
+... -= ... Subtraction assignment.\r
+-A Access time in days since script started.\r
+-B File is a non-text (binary) file.\r
+-C Inode change time in days since script started.\r
+-M Age in days since script started.\r
+-O File is owned by real uid.\r
+-R File is readable by real uid.\r
+-S File is a socket .\r
+-T File is a text file.\r
+-W File is writable by real uid.\r
+-X File is executable by real uid.\r
+-b File is a block special file.\r
+-c File is a character special file.\r
+-d File is a directory.\r
+-e File exists .\r
+-f File is a plain file.\r
+-g File has setgid bit set.\r
+-k File has sticky bit set.\r
+-l File is a symbolic link.\r
+-o File is owned by effective uid.\r
+-p File is a named pipe (FIFO).\r
+-r File is readable by effective uid.\r
+-s File has non-zero size.\r
+-t Tests if filehandle (STDIN by default) is opened to a tty.\r
+-u File has setuid bit set.\r
+-w File is writable by effective uid.\r
+-x File is executable by effective uid.\r
+-z File has zero size.\r
+. Concatenate strings.\r
+.. Range (list context); flip/flop (scalar context) operator.\r
+.= Concatenate assignment strings\r
+... / ... Division. /PATTERN/ioxsmg Pattern match\r
+... /= ... Division assignment.\r
+/PATTERN/ioxsmg Pattern match.\r
+... < ... Numeric less than. <pattern> Glob. See <NAME>, <> as well.\r
+<NAME> Reads line from filehandle NAME (a bareword or dollar-bareword).\r
+<pattern> Glob (Unless pattern is bareword/dollar-bareword - see <NAME>).\r
+<> Reads line from union of files in @ARGV (= command line) and STDIN.\r
+... << ... Bitwise shift left. << start of HERE-DOCUMENT.\r
+... <= ... Numeric less than or equal to.\r
+... <=> ... Numeric compare.\r
+... = ... Assignment.\r
+... == ... Numeric equality.\r
+... =~ ... Search pattern, substitution, or translation\r
+... > ... Numeric greater than.\r
+... >= ... Numeric greater than or equal to.\r
+... >> ... Bitwise shift right.\r
+... >>= ... Bitwise shift right assignment.\r
+... ? ... : ... Condition=if-then-else operator. ?PAT? One-time pattern match.\r
+?PATTERN? One-time pattern match.\r
+@ARGV Command line arguments (not including the command name - see $0).\r
+@INC List of places to look for perl scripts during do/include/use.\r
+@_ Parameter array for subroutines; result of split() unless in list context.\r
+\\ Creates reference to what follows, like \$var, or quotes non-\w in strings.\r
+\\0 Octal char, e.g. \\033.\r
+\\E Case modification terminator. See \\Q, \\L, and \\U.\r
+\\L Lowercase until \\E . See also \l, lc.\r
+\\U Upcase until \\E . See also \u, uc.\r
+\\Q Quote metacharacters until \\E . See also quotemeta.\r
+\\a Alarm character (octal 007).\r
+\\b Backspace character (octal 010).\r
+\\c Control character, e.g. \\c[ .\r
+\\e Escape character (octal 033).\r
+\\f Formfeed character (octal 014).\r
+\\l Lowercase the next character. See also \\L and \\u, lcfirst.\r
+\\n Newline character (octal 012 on most systems).\r
+\\r Return character (octal 015 on most systems).\r
+\\t Tab character (octal 011).\r
+\\u Upcase the next character. See also \\U and \\l, ucfirst.\r
+\\x Hex character, e.g. \\x1b.\r
+... ^ ... Bitwise exclusive or.\r
+__END__ Ends program source.\r
+__DATA__ Ends program source.\r
+__FILE__ Current (source) filename.\r
+__LINE__ Current line in current source.\r
+__PACKAGE__ Current package.\r
+ARGV Default multi-file input filehandle. <ARGV> is a synonym for <>.\r
+ARGVOUT Output filehandle with -i flag.\r
+BEGIN { ... } Immediately executed (during compilation) piece of code.\r
+END { ... } Pseudo-subroutine executed after the script finishes.\r
+CHECK { ... } Pseudo-subroutine executed after the script is compiled.\r
+INIT { ... } Pseudo-subroutine executed before the script starts running.\r
+DATA Input filehandle for what follows after __END__ or __DATA__.\r
+accept(NEWSOCKET,GENERICSOCKET)\r
+alarm(SECONDS)\r
+atan2(X,Y)\r
+bind(SOCKET,NAME)\r
+binmode(FILEHANDLE)\r
+caller[(LEVEL)]\r
+chdir(EXPR)\r
+chmod(LIST)\r
+chop[(LIST|VAR)]\r
+chown(LIST)\r
+chroot(FILENAME)\r
+close(FILEHANDLE)\r
+closedir(DIRHANDLE)\r
+... cmp ... String compare.\r
+connect(SOCKET,NAME)\r
+continue of { block } continue { block }. Is executed after `next' or at end.\r
+cos(EXPR)\r
+crypt(PLAINTEXT,SALT)\r
+dbmclose(%HASH)\r
+dbmopen(%HASH,DBNAME,MODE)\r
+defined(EXPR)\r
+delete($HASH{KEY})\r
+die(LIST)\r
+do { ... }|SUBR while|until EXPR executes at least once\r
+do(EXPR|SUBR([LIST])) (with while|until executes at least once)\r
+dump LABEL\r
+each(%HASH)\r
+endgrent\r
+endhostent\r
+endnetent\r
+endprotoent\r
+endpwent\r
+endservent\r
+eof[([FILEHANDLE])]\r
+... eq ... String equality.\r
+eval(EXPR) or eval { BLOCK }\r
+exec(LIST)\r
+exit(EXPR)\r
+exp(EXPR)\r
+fcntl(FILEHANDLE,FUNCTION,SCALAR)\r
+fileno(FILEHANDLE)\r
+flock(FILEHANDLE,OPERATION)\r
+for (EXPR;EXPR;EXPR) { ... }\r
+foreach [VAR] (@ARRAY) { ... }\r
+fork\r
+... ge ... String greater than or equal.\r
+getc[(FILEHANDLE)]\r
+getgrent\r
+getgrgid(GID)\r
+getgrnam(NAME)\r
+gethostbyaddr(ADDR,ADDRTYPE)\r
+gethostbyname(NAME)\r
+gethostent\r
+getlogin\r
+getnetbyaddr(ADDR,ADDRTYPE)\r
+getnetbyname(NAME)\r
+getnetent\r
+getpeername(SOCKET)\r
+getpgrp(PID)\r
+getppid\r
+getpriority(WHICH,WHO)\r
+getprotobyname(NAME)\r
+getprotobynumber(NUMBER)\r
+getprotoent\r
+getpwent\r
+getpwnam(NAME)\r
+getpwuid(UID)\r
+getservbyname(NAME,PROTO)\r
+getservbyport(PORT,PROTO)\r
+getservent\r
+getsockname(SOCKET)\r
+getsockopt(SOCKET,LEVEL,OPTNAME)\r
+gmtime(EXPR)\r
+goto LABEL\r
+... gt ... String greater than.\r
+hex(EXPR)\r
+if (EXPR) { ... } [ elsif (EXPR) { ... } ... ] [ else { ... } ] or EXPR if EXPR\r
+index(STR,SUBSTR[,OFFSET])\r
+int(EXPR)\r
+ioctl(FILEHANDLE,FUNCTION,SCALAR)\r
+join(EXPR,LIST)\r
+keys(%HASH)\r
+kill(LIST)\r
+last [LABEL]\r
+... le ... String less than or equal.\r
+length(EXPR)\r
+link(OLDFILE,NEWFILE)\r
+listen(SOCKET,QUEUESIZE)\r
+local(LIST)\r
+localtime(EXPR)\r
+log(EXPR)\r
+lstat(EXPR|FILEHANDLE|VAR)\r
+... lt ... String less than.\r
+m/PATTERN/iogsmx\r
+mkdir(FILENAME,MODE)\r
+msgctl(ID,CMD,ARG)\r
+msgget(KEY,FLAGS)\r
+msgrcv(ID,VAR,SIZE,TYPE.FLAGS)\r
+msgsnd(ID,MSG,FLAGS)\r
+my VAR or my (VAR1,...) Introduces a lexical variable ($VAR, @ARR, or %HASH).\r
+our VAR or our (VAR1,...) Lexically enable a global variable ($V, @A, or %H).\r
+... ne ... String inequality.\r
+next [LABEL]\r
+oct(EXPR)\r
+open(FILEHANDLE[,EXPR])\r
+opendir(DIRHANDLE,EXPR)\r
+ord(EXPR) ASCII value of the first char of the string.\r
+pack(TEMPLATE,LIST)\r
+package NAME Introduces package context.\r
+pipe(READHANDLE,WRITEHANDLE) Create a pair of filehandles on ends of a pipe.\r
+pop(ARRAY)\r
+print [FILEHANDLE] [(LIST)]\r
+printf [FILEHANDLE] (FORMAT,LIST)\r
+push(ARRAY,LIST)\r
+q/STRING/ Synonym for 'STRING'\r
+qq/STRING/ Synonym for \"STRING\"\r
+qx/STRING/ Synonym for `STRING`\r
+rand[(EXPR)]\r
+read(FILEHANDLE,SCALAR,LENGTH[,OFFSET])\r
+readdir(DIRHANDLE)\r
+readlink(EXPR)\r
+recv(SOCKET,SCALAR,LEN,FLAGS)\r
+redo [LABEL]\r
+rename(OLDNAME,NEWNAME)\r
+require [FILENAME | PERL_VERSION]\r
+reset[(EXPR)]\r
+return(LIST)\r
+reverse(LIST)\r
+rewinddir(DIRHANDLE)\r
+rindex(STR,SUBSTR[,OFFSET])\r
+rmdir(FILENAME)\r
+s/PATTERN/REPLACEMENT/gieoxsm\r
+scalar(EXPR)\r
+seek(FILEHANDLE,POSITION,WHENCE)\r
+seekdir(DIRHANDLE,POS)\r
+select(FILEHANDLE | RBITS,WBITS,EBITS,TIMEOUT)\r
+semctl(ID,SEMNUM,CMD,ARG)\r
+semget(KEY,NSEMS,SIZE,FLAGS)\r
+semop(KEY,...)\r
+send(SOCKET,MSG,FLAGS[,TO])\r
+setgrent\r
+sethostent(STAYOPEN)\r
+setnetent(STAYOPEN)\r
+setpgrp(PID,PGRP)\r
+setpriority(WHICH,WHO,PRIORITY)\r
+setprotoent(STAYOPEN)\r
+setpwent\r
+setservent(STAYOPEN)\r
+setsockopt(SOCKET,LEVEL,OPTNAME,OPTVAL)\r
+shift[(ARRAY)]\r
+shmctl(ID,CMD,ARG)\r
+shmget(KEY,SIZE,FLAGS)\r
+shmread(ID,VAR,POS,SIZE)\r
+shmwrite(ID,STRING,POS,SIZE)\r
+shutdown(SOCKET,HOW)\r
+sin(EXPR)\r
+sleep[(EXPR)]\r
+socket(SOCKET,DOMAIN,TYPE,PROTOCOL)\r
+socketpair(SOCKET1,SOCKET2,DOMAIN,TYPE,PROTOCOL)\r
+sort [SUBROUTINE] (LIST)\r
+splice(ARRAY,OFFSET[,LENGTH[,LIST]])\r
+split[(/PATTERN/[,EXPR[,LIMIT]])]\r
+sprintf(FORMAT,LIST)\r
+sqrt(EXPR)\r
+srand(EXPR)\r
+stat(EXPR|FILEHANDLE|VAR)\r
+study[(SCALAR)]\r
+sub [NAME [(format)]] { BODY } sub NAME [(format)]; sub [(format)] {...}\r
+substr(EXPR,OFFSET[,LEN])\r
+symlink(OLDFILE,NEWFILE)\r
+syscall(LIST)\r
+sysread(FILEHANDLE,SCALAR,LENGTH[,OFFSET])\r
+system(LIST)\r
+syswrite(FILEHANDLE,SCALAR,LENGTH[,OFFSET])\r
+tell[(FILEHANDLE)]\r
+telldir(DIRHANDLE)\r
+time\r
+times\r
+tr/SEARCHLIST/REPLACEMENTLIST/cds\r
+truncate(FILE|EXPR,LENGTH)\r
+umask[(EXPR)]\r
+undef[(EXPR)]\r
+unless (EXPR) { ... } [ else { ... } ] or EXPR unless EXPR\r
+unlink(LIST)\r
+unpack(TEMPLATE,EXPR)\r
+unshift(ARRAY,LIST)\r
+until (EXPR) { ... } EXPR until EXPR\r
+utime(LIST)\r
+values(%HASH)\r
+vec(EXPR,OFFSET,BITS)\r
+wait\r
+waitpid(PID,FLAGS)\r
+wantarray Returns true if the sub/eval is called in list context.\r
+warn(LIST)\r
+while (EXPR) { ... } EXPR while EXPR\r
+write[(EXPR|FILEHANDLE)]\r
+... x ... Repeat string or array.\r
+x= ... Repetition assignment.\r
+y/SEARCHLIST/REPLACEMENTLIST/\r
+... | ... Bitwise or.\r
+... || ... Logical or.\r
+~ ... Unary bitwise complement.\r
+#! OS interpreter indicator. If contains `perl', used for options, and -x.\r
+AUTOLOAD {...} Shorthand for `sub AUTOLOAD {...}'.\r
+CORE:: Prefix to access builtin function if imported sub obscures it.\r
+SUPER:: Prefix to lookup for a method in @ISA classes.\r
+DESTROY Shorthand for `sub DESTROY {...}'.\r
+... EQ ... Obsolete synonym of `eq'.\r
+... GE ... Obsolete synonym of `ge'.\r
+... GT ... Obsolete synonym of `gt'.\r
+... LE ... Obsolete synonym of `le'.\r
+... LT ... Obsolete synonym of `lt'.\r
+... NE ... Obsolete synonym of `ne'.\r
+abs [ EXPR ] absolute value\r
+... and ... Low-precedence synonym for &&.\r
+bless REFERENCE [, PACKAGE] Makes reference into an object of a package.\r
+chomp [LIST] Strips $/ off LIST/$_. Returns count. Special if $/ eq ''!\r
+chr Converts a number to char with the same ordinal.\r
+else Part of if/unless {BLOCK} elsif {BLOCK} else {BLOCK}.\r
+elsif Part of if/unless {BLOCK} elsif {BLOCK} else {BLOCK}.\r
+exists $HASH{KEY} True if the key exists.\r
+format [NAME] = Start of output format. Ended by a single dot (.) on a line.\r
+formline PICTURE, LIST Backdoor into \"format\" processing.\r
+glob EXPR Synonym of <EXPR>.\r
+lc [ EXPR ] Returns lowercased EXPR.\r
+lcfirst [ EXPR ] Returns EXPR with lower-cased first letter.\r
+grep EXPR,LIST or grep {BLOCK} LIST Filters LIST via EXPR/BLOCK.\r
+map EXPR, LIST or map {BLOCK} LIST Applies EXPR/BLOCK to elts of LIST.\r
+no PACKAGE [SYMBOL1, ...] Partial reverse for `use'. Runs `unimport' method.\r
+not ... Low-precedence synonym for ! - negation.\r
+... or ... Low-precedence synonym for ||.\r
+pos STRING Set/Get end-position of the last match over this string, see \\G.\r
+quotemeta [ EXPR ] Quote regexp metacharacters.\r
+qw/WORD1 .../ Synonym of split('', 'WORD1 ...')\r
+readline FH Synonym of <FH>.\r
+readpipe CMD Synonym of `CMD`.\r
+ref [ EXPR ] Type of EXPR when dereferenced.\r
+sysopen FH, FILENAME, MODE [, PERM] (MODE is numeric, see Fcntl.)\r
+tie VAR, PACKAGE, LIST Hide an object behind a simple Perl variable.\r
+tied Returns internal object for a tied data.\r
+uc [ EXPR ] Returns upcased EXPR.\r
+ucfirst [ EXPR ] Returns EXPR with upcased first letter.\r
+untie VAR Unlink an object from a simple Perl variable.\r
+use PACKAGE [SYMBOL1, ...] Compile-time `require' with consequent `import'.\r
+... xor ... Low-precedence synonym for exclusive or.\r
+prototype \&SUB Returns prototype of the function given a reference.\r
+=head1 Top-level heading.\r
+=head2 Second-level heading.\r
+=head3 Third-level heading (is there such?).\r
+=over [ NUMBER ] Start list.\r
+=item [ TITLE ] Start new item in the list.\r
+=back End list.\r
+=cut Switch from POD to Perl.\r
+=pod Switch from Perl to POD.\r
+")\r
+\r
+(defun cperl-switch-to-doc-buffer ()\r
+ "Go to the perl documentation buffer and insert the documentation."\r
+ (interactive)\r
+ (let ((buf (get-buffer-create cperl-doc-buffer)))\r
+ (if (interactive-p)\r
+ (switch-to-buffer-other-window buf)\r
+ (set-buffer buf))\r
+ (if (= (buffer-size) 0)\r
+ (progn\r
+ (insert (documentation-property 'cperl-short-docs\r
+ 'variable-documentation))\r
+ (setq buffer-read-only t)))))\r
+\r
+(defun cperl-beautify-regexp-piece (b e embed level)\r
+ ;; b is before the starting delimiter, e before the ending\r
+ ;; e should be a marker, may be changed, but remains "correct".\r
+ ;; EMBED is nil iff we process the whole REx.\r
+ ;; The REx is guarantied to have //x\r
+ ;; LEVEL shows how many levels deep to go\r
+ ;; position at enter and at leave is not defined\r
+ (let (s c tmp (m (make-marker)) (m1 (make-marker)) c1 spaces inline code pos)\r
+ (if (not embed)\r
+ (goto-char (1+ b))\r
+ (goto-char b)\r
+ (cond ((looking-at "(\\?\\\\#") ; (?#) wrongly commented when //x-ing\r
+ (forward-char 2)\r
+ (delete-char 1)\r
+ (forward-char 1))\r
+ ((looking-at "(\\?[^a-zA-Z]")\r
+ (forward-char 3))\r
+ ((looking-at "(\\?") ; (?i)\r
+ (forward-char 2))\r
+ (t\r
+ (forward-char 1))))\r
+ (setq c (if embed (current-indentation) (1- (current-column)))\r
+ c1 (+ c (or cperl-regexp-indent-step cperl-indent-level)))\r
+ (or (looking-at "[ \t]*[\n#]")\r
+ (progn\r
+ (insert "\n")))\r
+ (goto-char e)\r
+ (beginning-of-line)\r
+ (if (re-search-forward "[^ \t]" e t)\r
+ (progn ; Something before the ending delimiter\r
+ (goto-char e)\r
+ (delete-horizontal-space)\r
+ (insert "\n")\r
+ (indent-to-column c)\r
+ (set-marker e (point))))\r
+ (goto-char b)\r
+ (end-of-line 2)\r
+ (while (< (point) (marker-position e))\r
+ (beginning-of-line)\r
+ (setq s (point)\r
+ inline t)\r
+ (skip-chars-forward " \t")\r
+ (delete-region s (point))\r
+ (indent-to-column c1)\r
+ (while (and\r
+ inline\r
+ (looking-at\r
+ (concat "\\([a-zA-Z0-9]+[^*+{?]\\)" ; 1 word\r
+ "\\|" ; Embedded variable\r
+ "\\$\\([a-zA-Z0-9_]+\\([[{]\\)?\\|[^\n \t)|]\\)" ; 2 3\r
+ "\\|" ; $ ^\r
+ "[$^]"\r
+ "\\|" ; simple-code simple-code*?\r
+ "\\(\\\\.\\|[^][()#|*+?\n]\\)\\([*+{?]\\??\\)?" ; 4 5\r
+ "\\|" ; Class\r
+ "\\(\\[\\)" ; 6\r
+ "\\|" ; Grouping\r
+ "\\((\\(\\?\\)?\\)" ; 7 8\r
+ "\\|" ; |\r
+ "\\(|\\)"))) ; 9\r
+ (goto-char (match-end 0))\r
+ (setq spaces t)\r
+ (cond ((match-beginning 1) ; Alphanum word + junk\r
+ (forward-char -1))\r
+ ((or (match-beginning 3) ; $ab[12]\r
+ (and (match-beginning 5) ; X* X+ X{2,3}\r
+ (eq (preceding-char) ?\{)))\r
+ (forward-char -1)\r
+ (forward-sexp 1))\r
+ ((match-beginning 6) ; []\r
+ (setq tmp (point))\r
+ (if (looking-at "\\^?\\]")\r
+ (goto-char (match-end 0)))\r
+ ;; XXXX POSIX classes?!\r
+ (while (and (not pos)\r
+ (re-search-forward "\\[:\\|\\]" e t))\r
+ (if (eq (preceding-char) ?:)\r
+ (or (re-search-forward ":\\]" e t)\r
+ (error "[:POSIX:]-group in []-group not terminated"))\r
+ (setq pos t)))\r
+ (or (eq (preceding-char) ?\])\r
+ (error "[]-group not terminated"))\r
+ (if (eq (following-char) ?\{)\r
+ (progn\r
+ (forward-sexp 1)\r
+ (and (eq (following-char) ??)\r
+ (forward-char 1)))\r
+ (re-search-forward "\\=\\([*+?]\\??\\)" e t)))\r
+ ((match-beginning 7) ; ()\r
+ (goto-char (match-beginning 0))\r
+ (setq pos (current-column))\r
+ (or (eq pos c1)\r
+ (progn\r
+ (delete-horizontal-space)\r
+ (insert "\n")\r
+ (indent-to-column c1)))\r
+ (setq tmp (point))\r
+ (forward-sexp 1)\r
+ ;; (or (forward-sexp 1)\r
+ ;; (progn\r
+ ;; (goto-char tmp)\r
+ ;; (error "()-group not terminated")))\r
+ (set-marker m (1- (point)))\r
+ (set-marker m1 (point))\r
+ (if (= level 1)\r
+ (if (progn ; indent rigidly if multiline\r
+ ;; In fact does not make a lot of sense, since\r
+ ;; the starting position can be already lost due\r
+ ;; to insertion of "\n" and " "\r
+ (goto-char tmp)\r
+ (search-forward "\n" m1 t))\r
+ (indent-rigidly (point) m1 (- c1 pos)))\r
+ (setq level (1- level))\r
+ (cond\r
+ ((not (match-beginning 8))\r
+ (cperl-beautify-regexp-piece tmp m t level))\r
+ ((eq (char-after (+ 2 tmp)) ?\{) ; Code\r
+ t)\r
+ ((eq (char-after (+ 2 tmp)) ?\() ; Conditional\r
+ (goto-char (+ 2 tmp))\r
+ (forward-sexp 1)\r
+ (cperl-beautify-regexp-piece (point) m t level))\r
+ ((eq (char-after (+ 2 tmp)) ?<) ; Lookbehind\r
+ (goto-char (+ 3 tmp))\r
+ (cperl-beautify-regexp-piece (point) m t level))\r
+ (t\r
+ (cperl-beautify-regexp-piece tmp m t level))))\r
+ (goto-char m1)\r
+ (cond ((looking-at "[*+?]\\??")\r
+ (goto-char (match-end 0)))\r
+ ((eq (following-char) ?\{)\r
+ (forward-sexp 1)\r
+ (if (eq (following-char) ?\?)\r
+ (forward-char))))\r
+ (skip-chars-forward " \t")\r
+ (setq spaces nil)\r
+ (if (looking-at "[#\n]")\r
+ (progn\r
+ (or (eolp) (indent-for-comment))\r
+ (beginning-of-line 2))\r
+ (delete-horizontal-space)\r
+ (insert "\n"))\r
+ (end-of-line)\r
+ (setq inline nil))\r
+ ((match-beginning 9) ; |\r
+ (forward-char -1)\r
+ (setq tmp (point))\r
+ (beginning-of-line)\r
+ (if (re-search-forward "[^ \t]" tmp t)\r
+ (progn\r
+ (goto-char tmp)\r
+ (delete-horizontal-space)\r
+ (insert "\n"))\r
+ ;; first at line\r
+ (delete-region (point) tmp))\r
+ (indent-to-column c)\r
+ (forward-char 1)\r
+ (skip-chars-forward " \t")\r
+ (setq spaces nil)\r
+ (if (looking-at "[#\n]")\r
+ (beginning-of-line 2)\r
+ (delete-horizontal-space)\r
+ (insert "\n"))\r
+ (end-of-line)\r
+ (setq inline nil)))\r
+ (or (looking-at "[ \t\n]")\r
+ (not spaces)\r
+ (insert " "))\r
+ (skip-chars-forward " \t"))\r
+ (or (looking-at "[#\n]")\r
+ (error "Unknown code `%s' in a regexp"\r
+ (buffer-substring (point) (1+ (point)))))\r
+ (and inline (end-of-line 2)))\r
+ ;; Special-case the last line of group\r
+ (if (and (>= (point) (marker-position e))\r
+ (/= (current-indentation) c))\r
+ (progn\r
+ (beginning-of-line)\r
+ (setq s (point))\r
+ (skip-chars-forward " \t")\r
+ (delete-region s (point))\r
+ (indent-to-column c)))))\r
+\r
+(defun cperl-make-regexp-x ()\r
+ ;; Returns position of the start\r
+ ;; XXX this is called too often! Need to cache the result!\r
+ (save-excursion\r
+ (or cperl-use-syntax-table-text-property\r
+ (error "I need to have a regexp marked!"))\r
+ ;; Find the start\r
+ (if (looking-at "\\s|")\r
+ nil ; good already\r
+ (if (looking-at "\\([smy]\\|qr\\)\\s|")\r
+ (forward-char 1)\r
+ (re-search-backward "\\s|"))) ; Assume it is scanned already.\r
+ ;;(forward-char 1)\r
+ (let ((b (point)) (e (make-marker)) have-x delim (c (current-column))\r
+ (sub-p (eq (preceding-char) ?s)) s)\r
+ (forward-sexp 1)\r
+ (set-marker e (1- (point)))\r
+ (setq delim (preceding-char))\r
+ (if (and sub-p (eq delim (char-after (- (point) 2))))\r
+ (error "Possible s/blah// - do not know how to deal with"))\r
+ (if sub-p (forward-sexp 1))\r
+ (if (looking-at "\\sw*x")\r
+ (setq have-x t)\r
+ (insert "x"))\r
+ ;; Protect fragile " ", "#"\r
+ (if have-x nil\r
+ (goto-char (1+ b))\r
+ (while (re-search-forward "\\(\\=\\|[^\\\\]\\)\\(\\\\\\\\\\)*[ \t\n#]" e t) ; Need to include (?#) too?\r
+ (forward-char -1)\r
+ (insert "\\")\r
+ (forward-char 1)))\r
+ b)))\r
+\r
+(defun cperl-beautify-regexp (&optional deep)\r
+ "Do it. (Experimental, may change semantics, recheck the result.)\r
+We suppose that the regexp is scanned already."\r
+ (interactive "P")\r
+ (setq deep (if deep (prefix-numeric-value deep) -1))\r
+ (save-excursion\r
+ (goto-char (cperl-make-regexp-x))\r
+ (let ((b (point)) (e (make-marker)))\r
+ (forward-sexp 1)\r
+ (set-marker e (1- (point)))\r
+ (cperl-beautify-regexp-piece b e nil deep))))\r
+\r
+(defun cperl-regext-to-level-start ()\r
+ "Goto start of an enclosing group in regexp.\r
+We suppose that the regexp is scanned already."\r
+ (interactive)\r
+ (let ((limit (cperl-make-regexp-x)) done)\r
+ (while (not done)\r
+ (or (eq (following-char) ?\()\r
+ (search-backward "(" (1+ limit) t)\r
+ (error "Cannot find `(' which starts a group"))\r
+ (setq done\r
+ (save-excursion\r
+ (skip-chars-backward "\\")\r
+ (looking-at "\\(\\\\\\\\\\)*(")))\r
+ (or done (forward-char -1)))))\r
+\r
+(defun cperl-contract-level ()\r
+ "Find an enclosing group in regexp and contract it.\r
+\(Experimental, may change semantics, recheck the result.)\r
+We suppose that the regexp is scanned already."\r
+ (interactive)\r
+ ;; (save-excursion ; Can't, breaks `cperl-contract-levels'\r
+ (cperl-regext-to-level-start)\r
+ (let ((b (point)) (e (make-marker)) s c)\r
+ (forward-sexp 1)\r
+ (set-marker e (1- (point)))\r
+ (goto-char b)\r
+ (while (re-search-forward "\\(#\\)\\|\n" e 'to-end)\r
+ (cond\r
+ ((match-beginning 1) ; #-comment\r
+ (or c (setq c (current-indentation)))\r
+ (beginning-of-line 2) ; Skip\r
+ (setq s (point))\r
+ (skip-chars-forward " \t")\r
+ (delete-region s (point))\r
+ (indent-to-column c))\r
+ (t\r
+ (delete-char -1)\r
+ (just-one-space))))))\r
+\r
+(defun cperl-contract-levels ()\r
+ "Find an enclosing group in regexp and contract all the kids.\r
+\(Experimental, may change semantics, recheck the result.)\r
+We suppose that the regexp is scanned already."\r
+ (interactive)\r
+ (save-excursion\r
+ (condition-case nil\r
+ (cperl-regext-to-level-start)\r
+ (error ; We are outside outermost group\r
+ (goto-char (cperl-make-regexp-x))))\r
+ (let ((b (point)) (e (make-marker)) s c)\r
+ (forward-sexp 1)\r
+ (set-marker e (1- (point)))\r
+ (goto-char (1+ b))\r
+ (while (re-search-forward "\\(\\\\\\\\\\)\\|(" e t)\r
+ (cond\r
+ ((match-beginning 1) ; Skip\r
+ nil)\r
+ (t ; Group\r
+ (cperl-contract-level)))))))\r
+\r
+(defun cperl-beautify-level (&optional deep)\r
+ "Find an enclosing group in regexp and beautify it.\r
+\(Experimental, may change semantics, recheck the result.)\r
+We suppose that the regexp is scanned already."\r
+ (interactive "P")\r
+ (setq deep (if deep (prefix-numeric-value deep) -1))\r
+ (save-excursion\r
+ (cperl-regext-to-level-start)\r
+ (let ((b (point)) (e (make-marker)))\r
+ (forward-sexp 1)\r
+ (set-marker e (1- (point)))\r
+ (cperl-beautify-regexp-piece b e nil deep))))\r
+\r
+(defun cperl-invert-if-unless ()\r
+ "Change `if (A) {B}' into `B if A;' etc if possible."\r
+ (interactive)\r
+ (or (looking-at "\\<")\r
+ (forward-sexp -1))\r
+ (if (looking-at "\\<\\(if\\|unless\\|while\\|until\\|for\\|foreach\\)\\>")\r
+ (let ((pos1 (point))\r
+ pos2 pos3 pos4 pos5 s1 s2 state p pos45\r
+ (s0 (buffer-substring (match-beginning 0) (match-end 0))))\r
+ (forward-sexp 2)\r
+ (setq pos3 (point))\r
+ (forward-sexp -1)\r
+ (setq pos2 (point))\r
+ (if (eq (following-char) ?\( )\r
+ (progn\r
+ (goto-char pos3)\r
+ (forward-sexp 1)\r
+ (setq pos5 (point))\r
+ (forward-sexp -1)\r
+ (setq pos4 (point))\r
+ ;; XXXX In fact may be `A if (B); {C}' ...\r
+ (if (and (eq (following-char) ?\{ )\r
+ (progn\r
+ (cperl-backward-to-noncomment pos3)\r
+ (eq (preceding-char) ?\) )))\r
+ (if (condition-case nil\r
+ (progn\r
+ (goto-char pos5)\r
+ (forward-sexp 1)\r
+ (forward-sexp -1)\r
+ (looking-at "\\<els\\(e\\|if\\)\\>"))\r
+ (error nil))\r
+ (error\r
+ "`%s' (EXPR) {BLOCK} with `else'/`elsif'" s0)\r
+ (goto-char (1- pos5))\r
+ (cperl-backward-to-noncomment pos4)\r
+ (if (eq (preceding-char) ?\;)\r
+ (forward-char -1))\r
+ (setq pos45 (point))\r
+ (goto-char pos4)\r
+ (while (re-search-forward "\\<\\(for\\|foreach\\|if\\|unless\\|while\\|until\\)\\>\\|;" pos45 t)\r
+ (setq p (match-beginning 0)\r
+ s1 (buffer-substring p (match-end 0))\r
+ state (parse-partial-sexp pos4 p))\r
+ (or (nth 3 state)\r
+ (nth 4 state)\r
+ (nth 5 state)\r
+ (error "`%s' inside `%s' BLOCK" s1 s0))\r
+ (goto-char (match-end 0)))\r
+ ;; Finally got it\r
+ (goto-char (1+ pos4))\r
+ (skip-chars-forward " \t\n")\r
+ (setq s2 (buffer-substring (point) pos45))\r
+ (goto-char pos45)\r
+ (or (looking-at ";?[ \t\n]*}")\r
+ (progn\r
+ (skip-chars-forward "; \t\n")\r
+ (setq s2 (concat s2 "\n" (buffer-substring (point) (1- pos5))))))\r
+ (and (equal s2 "")\r
+ (setq s2 "1"))\r
+ (goto-char (1- pos3))\r
+ (cperl-backward-to-noncomment pos2)\r
+ (or (looking-at "[ \t\n]*)")\r
+ (goto-char (1- pos3)))\r
+ (setq p (point))\r
+ (goto-char (1+ pos2))\r
+ (skip-chars-forward " \t\n")\r
+ (setq s1 (buffer-substring (point) p))\r
+ (delete-region pos4 pos5)\r
+ (delete-region pos2 pos3)\r
+ (goto-char pos1)\r
+ (insert s2 " ")\r
+ (just-one-space)\r
+ (forward-word 1)\r
+ (setq pos1 (point))\r
+ (insert " " s1 ";")\r
+ (delete-horizontal-space)\r
+ (forward-char -1)\r
+ (delete-horizontal-space)\r
+ (goto-char pos1)\r
+ (just-one-space)\r
+ (cperl-indent-line))\r
+ (error "`%s' (EXPR) not with an {BLOCK}" s0)))\r
+ (error "`%s' not with an (EXPR)" s0)))\r
+ (error "Not at `if', `unless', `while', `until', `for' or `foreach'")))\r
+\r
+;;; By Anthony Foiani <afoiani@uswest.com>\r
+;;; Getting help on modules in C-h f ?\r
+;;; This is a modified version of `man'.\r
+;;; Need to teach it how to lookup functions\r
+(defun cperl-perldoc (word)\r
+ "Run `perldoc' on WORD."\r
+ (interactive\r
+ (list (let* ((default-entry (cperl-word-at-point))\r
+ (input (read-string\r
+ (format "perldoc entry%s: "\r
+ (if (string= default-entry "")\r
+ ""\r
+ (format " (default %s)" default-entry))))))\r
+ (if (string= input "")\r
+ (if (string= default-entry "")\r
+ (error "No perldoc args given")\r
+ default-entry)\r
+ input))))\r
+ (require 'man)\r
+ (let* ((case-fold-search nil)\r
+ (is-func (and\r
+ (string-match "^[a-z]+$" word)\r
+ (string-match (concat "^" word "\\>")\r
+ (documentation-property\r
+ 'cperl-short-docs\r
+ 'variable-documentation))))\r
+ (manual-program (if is-func "perldoc -f" "perldoc")))\r
+ (cond\r
+ (cperl-xemacs-p\r
+ (let ((Manual-program "perldoc")\r
+ (Manual-switches (if is-func (list "-f"))))\r
+ (manual-entry word)))\r
+ (t\r
+ (Man-getpage-in-background word)))))\r
+\r
+(defun cperl-perldoc-at-point ()\r
+ "Run a `perldoc' on the word around point."\r
+ (interactive)\r
+ (cperl-perldoc (cperl-word-at-point)))\r
+\r
+(defcustom pod2man-program "pod2man"\r
+ "*File name for `pod2man'."\r
+ :type 'file\r
+ :group 'cperl)\r
+\r
+;;; By Nick Roberts <Nick.Roberts@src.bae.co.uk> (with changes)\r
+(defun cperl-pod-to-manpage ()\r
+ "Create a virtual manpage in Emacs from the Perl Online Documentation."\r
+ (interactive)\r
+ (require 'man)\r
+ (let* ((pod2man-args (concat buffer-file-name " | nroff -man "))\r
+ (bufname (concat "Man " buffer-file-name))\r
+ (buffer (generate-new-buffer bufname)))\r
+ (save-excursion\r
+ (set-buffer buffer)\r
+ (let ((process-environment (copy-sequence process-environment)))\r
+ ;; Prevent any attempt to use display terminal fanciness.\r
+ (setenv "TERM" "dumb")\r
+ (set-process-sentinel\r
+ (start-process pod2man-program buffer "sh" "-c"\r
+ (format (cperl-pod2man-build-command) pod2man-args))\r
+ 'Man-bgproc-sentinel)))))\r
+\r
+;;; Updated version by him too\r
+(defun cperl-build-manpage ()\r
+ "Create a virtual manpage in Emacs from the POD in the file."\r
+ (interactive)\r
+ (require 'man)\r
+ (cond\r
+ (cperl-xemacs-p\r
+ (let ((Manual-program "perldoc"))\r
+ (manual-entry buffer-file-name)))\r
+ (t\r
+ (let* ((manual-program "perldoc"))\r
+ (Man-getpage-in-background buffer-file-name)))))\r
+\r
+(defun cperl-pod2man-build-command ()\r
+ "Builds the entire background manpage and cleaning command."\r
+ (let ((command (concat pod2man-program " %s 2>/dev/null"))\r
+ (flist Man-filter-list))\r
+ (while (and flist (car flist))\r
+ (let ((pcom (car (car flist)))\r
+ (pargs (cdr (car flist))))\r
+ (setq command\r
+ (concat command " | " pcom " "\r
+ (mapconcat '(lambda (phrase)\r
+ (if (not (stringp phrase))\r
+ (error "Malformed Man-filter-list"))\r
+ phrase)\r
+ pargs " ")))\r
+ (setq flist (cdr flist))))\r
+ command))\r
+\r
+(defun cperl-lazy-install ()) ; Avoid a warning\r
+(defun cperl-lazy-unstall ()) ; Avoid a warning\r
+\r
+(if (fboundp 'run-with-idle-timer)\r
+ (progn\r
+ (defvar cperl-help-shown nil\r
+ "Non-nil means that the help was already shown now.")\r
+\r
+ (defvar cperl-lazy-installed nil\r
+ "Non-nil means that the lazy-help handlers are installed now.")\r
+\r
+ (defun cperl-lazy-install ()\r
+ "Switches on Auto-Help on Perl constructs (put in the message area).\r
+Delay of auto-help controlled by `cperl-lazy-help-time'."\r
+ (interactive)\r
+ (make-variable-buffer-local 'cperl-help-shown)\r
+ (if (and (cperl-val 'cperl-lazy-help-time)\r
+ (not cperl-lazy-installed))\r
+ (progn\r
+ (add-hook 'post-command-hook 'cperl-lazy-hook)\r
+ (run-with-idle-timer\r
+ (cperl-val 'cperl-lazy-help-time 1000000 5)\r
+ t\r
+ 'cperl-get-help-defer)\r
+ (setq cperl-lazy-installed t))))\r
+\r
+ (defun cperl-lazy-unstall ()\r
+ "Switches off Auto-Help on Perl constructs (put in the message area).\r
+Delay of auto-help controlled by `cperl-lazy-help-time'."\r
+ (interactive)\r
+ (remove-hook 'post-command-hook 'cperl-lazy-hook)\r
+ (cancel-function-timers 'cperl-get-help-defer)\r
+ (setq cperl-lazy-installed nil))\r
+\r
+ (defun cperl-lazy-hook ()\r
+ (setq cperl-help-shown nil))\r
+\r
+ (defun cperl-get-help-defer ()\r
+ (if (not (memq major-mode '(perl-mode cperl-mode))) nil\r
+ (let ((cperl-message-on-help-error nil) (cperl-help-from-timer t))\r
+ (cperl-get-help)\r
+ (setq cperl-help-shown t))))\r
+ (cperl-lazy-install)))\r
+\r
+\r
+;;; Plug for wrong font-lock:\r
+\r
+(defun cperl-font-lock-unfontify-region-function (beg end)\r
+ (let* ((modified (buffer-modified-p)) (buffer-undo-list t)\r
+ (inhibit-read-only t) (inhibit-point-motion-hooks t)\r
+ before-change-functions after-change-functions\r
+ deactivate-mark buffer-file-name buffer-file-truename)\r
+ (remove-text-properties beg end '(face nil))\r
+ (when (and (not modified) (buffer-modified-p))\r
+ (set-buffer-modified-p nil))))\r
+\r
+(defvar cperl-d-l nil)\r
+(defun cperl-fontify-syntaxically (end)\r
+ ;; Some vars for debugging only\r
+ ;; (message "Syntaxifying...")\r
+ (let ((dbg (point)) (iend end)\r
+ (istate (car cperl-syntax-state))\r
+ start)\r
+ (and cperl-syntaxify-unwind\r
+ (setq end (cperl-unwind-to-safe t end)))\r
+ (setq start (point))\r
+ (or cperl-syntax-done-to\r
+ (setq cperl-syntax-done-to (point-min)))\r
+ (if (or (not (boundp 'font-lock-hot-pass))\r
+ (eval 'font-lock-hot-pass)\r
+ t) ; Not debugged otherwise\r
+ ;; Need to forget what is after `start'\r
+ (setq start (min cperl-syntax-done-to start))\r
+ ;; Fontification without a change\r
+ (setq start (max cperl-syntax-done-to start)))\r
+ (and (> end start)\r
+ (setq cperl-syntax-done-to start) ; In case what follows fails\r
+ (cperl-find-pods-heres start end t nil t))\r
+ (if (eq cperl-syntaxify-by-font-lock 'message)\r
+ (message "Syntaxified %s..%s from %s to %s(%s), state %s-->%s"\r
+ dbg iend\r
+ start end cperl-syntax-done-to\r
+ istate (car cperl-syntax-state))) ; For debugging\r
+ nil)) ; Do not iterate\r
+\r
+(defun cperl-fontify-update (end)\r
+ (let ((pos (point)) prop posend)\r
+ (while (< pos end)\r
+ (setq prop (get-text-property pos 'cperl-postpone))\r
+ (setq posend (next-single-property-change pos 'cperl-postpone nil end))\r
+ (and prop (put-text-property pos posend (car prop) (cdr prop)))\r
+ (setq pos posend)))\r
+ nil) ; Do not iterate\r
+\r
+(defun cperl-update-syntaxification (from to)\r
+ (if (and cperl-use-syntax-table-text-property\r
+ cperl-syntaxify-by-font-lock\r
+ (or (null cperl-syntax-done-to)\r
+ (< cperl-syntax-done-to to)))\r
+ (progn\r
+ (save-excursion\r
+ (goto-char from)\r
+ (cperl-fontify-syntaxically to)))))\r
+\r
+(defvar cperl-version\r
+ (let ((v "$Revision: 5.0 $"))\r
+ (string-match ":\\s *\\([0-9.]+\\)" v)\r
+ (substring v (match-beginning 1) (match-end 1)))\r
+ "Version of IZ-supported CPerl package this file is based on.")\r
+\r
+(provide 'cperl-mode)\r
+\r
+;;; cperl-mode.el ends here\r