+++ /dev/null
-;;; 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
projects / lib.git / blobdiff