|
209
|
1 ;;; cperl-mode.el --- Perl code editing commands for XEmacs
|
|
|
2
|
|
4
|
3 ;; Copyright (C) 1985-1996 Bob Olson, Ilya Zakharevich
|
|
193
|
4 ;; Copyright (C) 1997 granted to FSF for changes made by
|
|
|
5 ;; Karl M. Hegbloom <karlheg@inetarena.com>
|
|
|
6
|
|
209
|
7 ;; Author: Bob Olson, Ilya Zakharevich
|
|
|
8 ;; Maintainer: Karl M. Hegbloom <karlheg@inetarena.com>
|
|
|
9 ;; Keywords: languages
|
|
|
10
|
|
193
|
11 ;; This file is part of XEmacs. It may be distributed either under the
|
|
|
12 ;; same terms as XEmacs, or under the same terms as Perl. You should
|
|
|
13 ;; have received a copy of Perl Artistic license along with the Perl
|
|
|
14 ;; distribution.
|
|
|
15
|
|
|
16 ;; XEmacs is free software; you can redistribute it and/or modify
|
|
0
|
17 ;; it under the terms of the GNU General Public License as published by
|
|
|
18 ;; the Free Software Foundation; either version 2, or (at your option)
|
|
|
19 ;; any later version.
|
|
|
20
|
|
|
21 ;; GNU Emacs is distributed in the hope that it will be useful,
|
|
|
22 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
|
23 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
|
24 ;; GNU General Public License for more details.
|
|
|
25
|
|
|
26 ;; You should have received a copy of the GNU General Public License
|
|
4
|
27 ;; along with GNU Emacs; see the file COPYING. If not, write to the
|
|
|
28 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
|
|
29 ;; Boston, MA 02111-1307, USA.
|
|
|
30
|
|
0
|
31 ;;; Corrections made by Ilya Zakharevich ilya@math.mps.ohio-state.edu
|
|
|
32 ;;; XEmacs changes by Peter Arius arius@informatik.uni-erlangen.de
|
|
167
|
33 ;;; XEmacs 'delete key behavior handling added for XEmacs 20.x by
|
|
|
34 ;;; Gary D. Foster <Gary.Foster@corp.sun.com>
|
|
203
|
35 ;;; Karl M. Hegbloom <karlheg@inetarena.com>
|
|
167
|
36
|
|
193
|
37 ;; Original Vendor Version Number: (mostly based on...)
|
|
209
|
38 ;; $Id: cperl-mode.el,v 1.16 1997/11/08 23:36:57 steve Exp $
|
|
193
|
39
|
|
|
40 ;; Increment the final digit once per XEmacs-only revision, the other
|
|
|
41 ;; for merges. (sound ok?)
|
|
|
42 ;;; XEmacs Version Number: 1.35-1
|
|
|
43
|
|
209
|
44 ;;; Commentary:
|
|
|
45
|
|
|
46 ;; This code started from the following message of long time ago (IZ):
|
|
|
47
|
|
|
48 ;; From: olson@mcs.anl.gov (Bob Olson)
|
|
|
49 ;; Newsgroups: comp.lang.perl
|
|
|
50 ;; Subject: cperl-mode: Another perl mode for Gnuemacs
|
|
|
51 ;; Date: 14 Aug 91 15:20:01 GMT
|
|
|
52
|
|
193
|
53 ;; This mode should autoload when you edit a perl file under XEmacs.
|
|
0
|
54
|
|
110
|
55 ;;; DO NOT FORGET to read micro-docs. (available from `Perl' menu). <<<<<<
|
|
|
56 ;;; or as help on variables `cperl-tips', `cperl-problems', <<<<<<
|
|
193
|
57 ;;; `cperl-non-problems', `cperl-praise'. <<<<<<
|
|
|
58
|
|
|
59 ;;; The mode information (on C-h m) provides some customization help.
|
|
0
|
60 ;;; If you use font-lock feature of this mode, it is advisable to use
|
|
4
|
61 ;;; either lazy-lock-mode or fast-lock-mode (available on ELisp
|
|
0
|
62 ;;; archive in files lazy-lock.el and fast-lock.el). I prefer lazy-lock.
|
|
|
63
|
|
|
64 ;;; Faces used now: three faces for first-class and second-class keywords
|
|
|
65 ;;; and control flow words, one for each: comments, string, labels,
|
|
|
66 ;;; functions definitions and packages, arrays, hashes, and variable
|
|
|
67 ;;; definitions. If you do not see all these faces, your font-lock does
|
|
193
|
68 ;;; not define them, so you need to define them manually.
|
|
0
|
69
|
|
4
|
70 ;;; If you have a grayscale monitor, and do not have the variable
|
|
0
|
71 ;;; font-lock-display-type bound to 'grayscale, insert
|
|
|
72
|
|
|
73 ;;; (setq font-lock-display-type 'grayscale)
|
|
|
74
|
|
193
|
75 ;;; into your .xemacs/init.el file.
|
|
|
76
|
|
|
77 ;;;; ? what about this `imenu' stuff? Is it worth it?
|
|
0
|
78
|
|
|
79 ;;;; This mode supports font-lock, imenu and mode-compile. In the
|
|
|
80 ;;;; hairy version font-lock is on, but you should activate imenu
|
|
|
81 ;;;; yourself (note that mode-compile is not standard yet). Well, you
|
|
|
82 ;;;; can use imenu from keyboard anyway (M-x imenu), but it is better
|
|
|
83 ;;;; to bind it like that:
|
|
|
84
|
|
|
85 ;; (define-key global-map [M-S-down-mouse-3] 'imenu)
|
|
|
86
|
|
|
87 ;;; In fact the version of font-lock that this version supports can be
|
|
|
88 ;;; much newer than the version you actually have. This means that a
|
|
|
89 ;;; lot of faces can be set up, but are not visible on your screen
|
|
|
90 ;;; since the coloring rules for this faces are not defined.
|
|
|
91
|
|
|
92 ;;; Updates: ========================================
|
|
|
93
|
|
|
94 ;;; Made less hairy by default: parentheses not electric,
|
|
|
95 ;;; linefeed not magic. Bug with abbrev-mode corrected.
|
|
|
96
|
|
|
97 ;;;; After 1.4:
|
|
|
98 ;;; Better indentation:
|
|
|
99 ;;; subs inside braces should work now,
|
|
|
100 ;;; Toplevel braces obey customization.
|
|
|
101 ;;; indent-for-comment knows about bad cases, cperl-indent-for-comment
|
|
|
102 ;;; moves cursor to a correct place.
|
|
|
103 ;;; cperl-indent-exp written from the scratch! Slow... (quadratic!) :-(
|
|
|
104 ;;; (50 secs on DB::DB (sub of 430 lines), 486/66)
|
|
|
105 ;;; Minor documentation fixes.
|
|
|
106 ;;; Imenu understands packages as prefixes (including nested).
|
|
|
107 ;;; Hairy options can be switched off one-by-one by setting to null.
|
|
|
108 ;;; Names of functions and variables changed to conform to `cperl-' style.
|
|
|
109
|
|
|
110 ;;;; After 1.5:
|
|
|
111 ;;; Some bugs with indentation of labels (and embedded subs) corrected.
|
|
|
112 ;;; `cperl-indent-region' done (slow :-()).
|
|
|
113 ;;; `cperl-fill-paragraph' done.
|
|
|
114 ;;; Better package support for `imenu'.
|
|
|
115 ;;; Progress indicator for indentation (with `imenu' loaded).
|
|
|
116 ;;; `Cperl-set' was busted, now setting the individual hairy option
|
|
|
117 ;;; should be better.
|
|
|
118
|
|
|
119 ;;;; After 1.6:
|
|
|
120 ;;; `cperl-set-style' done.
|
|
|
121 ;;; `cperl-check-syntax' done.
|
|
|
122 ;;; Menu done.
|
|
|
123 ;;; New config variables `cperl-close-paren-offset' and `cperl-comment-column'.
|
|
|
124 ;;; Bugs with `cperl-auto-newline' corrected.
|
|
|
125 ;;; `cperl-electric-lbrace' can work with `cperl-auto-newline' in situation
|
|
|
126 ;;; like $hash{.
|
|
|
127
|
|
|
128 ;;;; 1.7 XEmacs (arius@informatik.uni-erlangen.de):
|
|
|
129 ;;; - use `next-command-event', if `next-command-events' does not exist
|
|
|
130 ;;; - use `find-face' as def. of `is-face'
|
|
|
131 ;;; - corrected def. of `x-color-defined-p'
|
|
|
132 ;;; - added const defs for font-lock-comment-face,
|
|
|
133 ;;; font-lock-keyword-face and font-lock-function-name-face
|
|
|
134 ;;; - added def. of font-lock-variable-name-face
|
|
|
135 ;;; - added (require 'easymenu) inside an `eval-when-compile'
|
|
|
136 ;;; - replaced 4-argument `substitute-key-definition' with ordinary
|
|
|
137 ;;; `define-key's
|
|
|
138 ;;; - replaced `mark-active' in menu definition by `cperl-use-region-p'.
|
|
|
139 ;;; Todo (at least):
|
|
|
140 ;;; - use emacs-vers.el (http://www.cs.utah.edu/~eeide/emacs/emacs-vers.el.gz)
|
|
|
141 ;;; for portable code?
|
|
|
142 ;;; - should `cperl-mode' do a
|
|
|
143 ;;; (if (featurep 'easymenu) (easy-menu-add cperl-menu))
|
|
|
144 ;;; or should this be left to the user's `cperl-mode-hook'?
|
|
|
145
|
|
|
146 ;;; Some bugs introduced by the above fix corrected (IZ ;-).
|
|
|
147 ;;; Some bugs under XEmacs introduced by the correction corrected.
|
|
|
148
|
|
|
149 ;;; Some more can remain since there are two many different variants.
|
|
|
150 ;;; Please feedback!
|
|
|
151
|
|
|
152 ;;; We do not support fontification of arrays and hashes under
|
|
|
153 ;;; obsolete font-lock any more. Upgrade.
|
|
|
154
|
|
|
155 ;;;; after 1.8 Minor bug with parentheses.
|
|
|
156 ;;;; after 1.9 Improvements from Joe Marzot.
|
|
|
157 ;;;; after 1.10
|
|
|
158 ;;; Does not need easymenu to compile under XEmacs.
|
|
|
159 ;;; `vc-insert-headers' should work better.
|
|
|
160 ;;; Should work with 19.29 and 19.12.
|
|
|
161 ;;; Small improvements to fontification.
|
|
|
162 ;;; Expansion of keywords does not depend on C-? being backspace.
|
|
|
163
|
|
|
164 ;;; after 1.10+
|
|
|
165 ;;; 19.29 and 19.12 supported.
|
|
|
166 ;;; `cperl-font-lock-enhanced' deprecated. Use font-lock-extra.el.
|
|
|
167 ;;; Support for font-lock-extra.el.
|
|
|
168
|
|
|
169 ;;;; After 1.11:
|
|
|
170 ;;; Tools submenu.
|
|
|
171 ;;; Support for perl5-info.
|
|
|
172 ;;; `imenu-go-find-at-position' in Tools requires imenu-go.el (see hints above)
|
|
|
173 ;;; Imenu entries do not work with stock imenu.el. Patch sent to maintainers.
|
|
|
174 ;;; Fontifies `require a if b;', __DATA__.
|
|
|
175 ;;; Arglist for auto-fill-mode was incorrect.
|
|
|
176
|
|
|
177 ;;;; After 1.12:
|
|
|
178 ;;; `cperl-lineup-step' and `cperl-lineup' added: lineup constructions
|
|
|
179 ;;; vertically.
|
|
|
180 ;;; `cperl-do-auto-fill' updated for 19.29 style.
|
|
|
181 ;;; `cperl-info-on-command' now has a default.
|
|
|
182 ;;; Workaround for broken C-h on XEmacs.
|
|
|
183 ;;; VC strings escaped.
|
|
|
184 ;;; C-h f now may prompt for function name instead of going on,
|
|
|
185 ;;; controlled by `cperl-info-on-command-no-prompt'.
|
|
|
186
|
|
|
187 ;;;; After 1.13:
|
|
|
188 ;;; Msb buffer list includes perl files
|
|
|
189 ;;; Indent-for-comment uses indent-to
|
|
|
190 ;;; Can write tag files using etags.
|
|
|
191
|
|
|
192 ;;;; After 1.14:
|
|
|
193 ;;; Recognizes (tries to ;-) {...} which are not blocks during indentation.
|
|
|
194 ;;; `cperl-close-paren-offset' affects ?\] too (and ?\} if not block)
|
|
|
195 ;;; Bug with auto-filling comments started with "##" corrected.
|
|
|
196
|
|
|
197 ;;;; Very slow now: on DB::DB 0.91, 486/66:
|
|
|
198
|
|
|
199 ;;;Function Name Call Count Elapsed Time Average Time
|
|
|
200 ;;;======================================== ========== ============ ============
|
|
|
201 ;;;cperl-block-p 469 3.7799999999 0.0080597014
|
|
|
202 ;;;cperl-get-state 505 163.39000000 0.3235445544
|
|
|
203 ;;;cperl-comment-indent 12 0.0299999999 0.0024999999
|
|
|
204 ;;;cperl-backward-to-noncomment 939 4.4599999999 0.0047497337
|
|
|
205 ;;;cperl-calculate-indent 505 172.22000000 0.3410297029
|
|
|
206 ;;;cperl-indent-line 505 172.88000000 0.3423366336
|
|
|
207 ;;;cperl-use-region-p 40 0.0299999999 0.0007499999
|
|
|
208 ;;;cperl-indent-exp 1 177.97000000 177.97000000
|
|
|
209 ;;;cperl-to-comment-or-eol 1453 3.9800000000 0.0027391603
|
|
|
210 ;;;cperl-backward-to-start-of-continued-exp 9 0.0300000000 0.0033333333
|
|
|
211 ;;;cperl-indent-region 1 177.94000000 177.94000000
|
|
|
212
|
|
|
213 ;;;; After 1.15:
|
|
|
214 ;;; Takes into account white space after opening parentheses during indent.
|
|
|
215 ;;; May highlight pods and here-documents: see `cperl-pod-here-scan',
|
|
|
216 ;;; `cperl-pod-here-fontify', `cperl-pod-face'. Does not use this info
|
|
|
217 ;;; for indentation so far.
|
|
|
218 ;;; Fontification updated to 19.30 style.
|
|
|
219 ;;; The change 19.29->30 did not add all the required functionality,
|
|
|
220 ;;; but broke "font-lock-extra.el". Get "choose-color.el" from
|
|
|
221 ;;; ftp://ftp.math.ohio-state.edu/pub/users/ilya/emacs
|
|
|
222
|
|
|
223 ;;;; After 1.16:
|
|
|
224 ;;; else # comment
|
|
|
225 ;;; recognized as a start of a block.
|
|
|
226 ;;; Two different font-lock-levels provided.
|
|
|
227 ;;; `cperl-pod-head-face' introduced. Used for highlighting.
|
|
|
228 ;;; `imenu' marks pods, +Packages moved to the head.
|
|
|
229
|
|
|
230 ;;;; After 1.17:
|
|
|
231 ;;; Scan for pods highlights here-docs too.
|
|
|
232 ;;; Note that the tag of here-doc may be rehighlighted later by lazy-lock.
|
|
|
233 ;;; Only one here-doc-tag per line is supported, and one in comment
|
|
|
234 ;;; or a string may break fontification.
|
|
|
235 ;;; POD headers were supposed to fill one line only.
|
|
|
236
|
|
|
237 ;;;; After 1.18:
|
|
|
238 ;;; `font-lock-keywords' were set in 19.30 style _always_. Current scheme
|
|
|
239 ;;; may break under XEmacs.
|
|
|
240 ;;; `cperl-calculate-indent' dis suppose that `parse-start' was defined.
|
|
|
241 ;;; `fontified' tag is added to fontified text as well as `lazy-lock' (for
|
|
|
242 ;;; compatibility with older lazy-lock.el) (older one overfontifies
|
|
|
243 ;;; something nevertheless :-().
|
|
|
244 ;;; Will not indent something inside pod and here-documents.
|
|
|
245 ;;; Fontifies the package name after import/no/bootstrap.
|
|
|
246 ;;; Added new entry to menu with meta-info about the mode.
|
|
|
247
|
|
|
248 ;;;; After 1.19:
|
|
|
249 ;;; Prefontification works much better with 19.29. Should be checked
|
|
|
250 ;;; with 19.30 as well.
|
|
|
251 ;;; Some misprints in docs corrected.
|
|
|
252 ;;; Now $a{-text} and -text => "blah" are fontified as strings too.
|
|
|
253 ;;; Now the pod search is much stricter, so it can help you to find
|
|
|
254 ;;; pod sections which are broken because of whitespace before =blah
|
|
|
255 ;;; - just observe the fontification.
|
|
|
256
|
|
|
257 ;;;; After 1.20
|
|
|
258 ;;; Anonymous subs are indented with respect to the level of
|
|
|
259 ;;; indentation of `sub' now.
|
|
|
260 ;;; {} is recognized as hash after `bless' and `return'.
|
|
|
261 ;;; Anonymous subs are split by `cperl-linefeed' as well.
|
|
|
262 ;;; Electric parens embrace a region if present.
|
|
|
263 ;;; To make `cperl-auto-newline' useful,
|
|
|
264 ;;; `cperl-auto-newline-after-colon' is introduced.
|
|
|
265 ;;; `cperl-electric-parens' is now t or nul. The old meaning is moved to
|
|
|
266 ;;; `cperl-electric-parens-string'.
|
|
|
267 ;;; `cperl-toggle-auto-newline' introduced, put on C-c C-a.
|
|
|
268 ;;; `cperl-toggle-abbrev' introduced, put on C-c C-k.
|
|
|
269 ;;; `cperl-toggle-electric' introduced, put on C-c C-e.
|
|
|
270 ;;; Beginning-of-defun-regexp was not anchored.
|
|
|
271
|
|
|
272 ;;;; After 1.21
|
|
|
273 ;;; Auto-newline grants `cperl-extra-newline-before-brace' if "{" is typed
|
|
|
274 ;;; after ")".
|
|
|
275 ;;; {} is recognized as expression after `tr' and friends.
|
|
4
|
276
|
|
|
277 ;;;; After 1.22
|
|
|
278 ;;; Entry Hierarchy added to imenu. Very primitive so far.
|
|
|
279 ;;; One needs newer `imenu-go'.el. A patch to `imenu' is needed as well.
|
|
|
280 ;;; Writes its own TAGS files.
|
|
|
281 ;;; Class viewer based on TAGS files. Does not trace @ISA so far.
|
|
|
282 ;;; 19.31: Problems with scan for PODs corrected.
|
|
|
283 ;;; First POD header correctly fontified.
|
|
|
284 ;;; I needed (setq imenu-use-keymap-menu t) to get good imenu in 19.31.
|
|
|
285 ;;; Apparently it makes a lot of hierarchy code obsolete...
|
|
|
286
|
|
|
287 ;;;; After 1.23
|
|
|
288 ;;; Tags filler now scans *.xs as well.
|
|
|
289 ;;; The info from *.xs scan is used by the hierarchy viewer.
|
|
|
290 ;;; Hierarchy viewer documented.
|
|
|
291 ;;; Bug in 19.31 imenu documented.
|
|
|
292
|
|
|
293 ;;;; After 1.24
|
|
|
294 ;;; New location for info-files mentioned,
|
|
|
295 ;;; Electric-; should work better.
|
|
|
296 ;;; Minor bugs with POD marking.
|
|
|
297
|
|
|
298 ;;;; After 1.25 (probably not...)
|
|
|
299 ;;; `cperl-info-page' introduced.
|
|
|
300 ;;; To make `uncomment-region' working, `comment-region' would
|
|
|
301 ;;; not insert extra space.
|
|
|
302 ;;; Here documents delimiters better recognized
|
|
|
303 ;;; (empty one, and non-alphanums in quotes handled). May be wrong with 1<<14?
|
|
|
304 ;;; `cperl-db' added, used in menu.
|
|
|
305 ;;; imenu scan removes text-properties, for better debugging
|
|
|
306 ;;; - but the bug is in 19.31 imenu.
|
|
|
307 ;;; formats highlighted by font-lock and prescan, embedded comments
|
|
|
308 ;;; are not treated.
|
|
|
309 ;;; POD/friends scan merged in one pass.
|
|
|
310 ;;; Syntax class is not used for analyzing the code, only char-syntax
|
|
|
311 ;;; may be checked against _ or'ed with w.
|
|
|
312 ;;; Syntax class of `:' changed to be _.
|
|
|
313 ;;; `cperl-find-bad-style' added.
|
|
|
314
|
|
|
315 ;;;; After 1.25
|
|
|
316 ;;; When search for here-documents, we ignore commented << in simplest cases.
|
|
|
317 ;;; `cperl-get-help' added, available on C-h v and from menu.
|
|
|
318 ;;; Auto-help added. Default with `cperl-hairy', switchable on/off
|
|
|
319 ;;; with startup variable `cperl-lazy-help-time' and from
|
|
|
320 ;;; menu. Requires `run-with-idle-timer'.
|
|
|
321 ;;; Highlighting of @abc{@efg} was wrong - interchanged two regexps.
|
|
|
322
|
|
|
323 ;;;; After 1.27
|
|
|
324 ;;; Indentation: At toplevel after a label - fixed.
|
|
|
325 ;;; 1.27 was put to archives in binary mode ===> DOSish :-(
|
|
|
326
|
|
|
327 ;;;; After 1.28
|
|
|
328 ;;; Thanks to Martin Buchholz <mrb@Eng.Sun.COM>: misprints in
|
|
|
329 ;;; comments and docstrings corrected, XEmacs support cleaned up.
|
|
|
330 ;;; The closing parenths would enclose the region into matching
|
|
|
331 ;;; parens under the same conditions as the opening ones.
|
|
|
332 ;;; Minor updates to `cperl-short-docs'.
|
|
|
333 ;;; Will not consider <<= as start of here-doc.
|
|
0
|
334
|
|
110
|
335 ;;;; After 1.29
|
|
|
336 ;;; Added an extra advice to look into Micro-docs. ;-).
|
|
|
337 ;;; Enclosing of region when you press a closing parenth is regulated by
|
|
|
338 ;;; `cperl-electric-parens-string'.
|
|
|
339 ;;; Minor updates to `cperl-short-docs'.
|
|
|
340 ;;; `initialize-new-tags-table' called only if present (Does this help
|
|
|
341 ;;; with generation of tags under XEmacs?).
|
|
|
342 ;;; When creating/updating tag files, new info is written at the old place,
|
|
|
343 ;;; or at the end (is this a wanted behaviour? I need this in perl build directory).
|
|
|
344
|
|
|
345 ;;;; After 1.30
|
|
|
346 ;;; All the keywords from keywords.pl included (maybe with dummy explanation).
|
|
|
347 ;;; No auto-help inside strings, comment, here-docs, formats, and pods.
|
|
193
|
348 ;;; Shrinkwrapping of info, regulated by `cperl-max-help-size',
|
|
|
349 ;;; `cperl-shrink-wrap-info-frame'.
|
|
110
|
350 ;;; Info on variables as well.
|
|
|
351 ;;; Recognision of HERE-DOCS improved yet more.
|
|
|
352 ;;; Autonewline works on `}' without warnings.
|
|
|
353 ;;; Autohelp works again on $_[0].
|
|
|
354
|
|
|
355 ;;;; After 1.31
|
|
|
356 ;;; perl-descr.el found its author - hi, Johan!
|
|
193
|
357 ;;; Some support for correct indent after here-docs and friends (may
|
|
|
358 ;;; be superseeded by eminent change to Emacs internals).
|
|
|
359 ;;; Should work with older Emaxen as well ( `-style stuff removed).
|
|
|
360
|
|
|
361 ;;;; After 1.32
|
|
|
362
|
|
|
363 ;;; Started to add support for `syntax-table' property (should work
|
|
|
364 ;;; with patched Emaxen), controlled by
|
|
|
365 ;;; `cperl-use-syntax-table-text-property'. Currently recognized:
|
|
|
366 ;;; All quote-like operators: m, s, y, tr, qq, qw, qx, q,
|
|
|
367 ;;; // in most frequent context:
|
|
|
368 ;;; after block or
|
|
|
369 ;;; ~ { ( = | & + - * ! , ;
|
|
|
370 ;;; or
|
|
|
371 ;;; while if unless until and or not xor split grep map
|
|
|
372 ;;; Here-documents, formats, PODs,
|
|
|
373 ;;; ${...}
|
|
|
374 ;;; 'abc$'
|
|
|
375 ;;; sub a ($); sub a ($) {}
|
|
|
376 ;;; (provide 'cperl-mode) was missing!
|
|
|
377 ;;; `cperl-after-expr-p' is now much smarter after `}'.
|
|
|
378 ;;; `cperl-praise' added to mini-docs.
|
|
|
379 ;;; Utilities try to support subs-with-prototypes.
|
|
|
380
|
|
|
381 ;;;; After 1.32.1
|
|
|
382 ;;; `cperl-after-expr-p' is now much smarter after "() {}" and "word {}":
|
|
|
383 ;;; if word is "else, map, grep".
|
|
|
384 ;;; Updated for new values of syntax-table constants.
|
|
|
385 ;;; Uses `help-char' (at last!) (disabled, does not work?!)
|
|
|
386 ;;; A couple of regexps where missing _ in character classes.
|
|
|
387 ;;; -s could be considered as start of regexp, 1../blah/ was not,
|
|
|
388 ;;; as was not /blah/ at start of file.
|
|
|
389
|
|
|
390 ;;;; After 1.32.2
|
|
|
391 ;;; "\C-hv" was wrongly "\C-hf"
|
|
|
392 ;;; C-hv was not working on `[index()]' because of [] in skip-chars-*.
|
|
|
393 ;;; `__PACKAGE__' supported.
|
|
|
394 ;;; Thanks for Greg Badros: `cperl-lazy-unstall' is more complete,
|
|
|
395 ;;; `cperl-get-help' is made compatible with `query-replace'.
|
|
|
396
|
|
|
397 ;;;; As of Apr 15, development version of 19.34 supports
|
|
|
398 ;;;; `syntax-table' text properties. Try setting
|
|
|
399 ;;;; `cperl-use-syntax-table-text-property'.
|
|
|
400
|
|
|
401 ;;;; After 1.32.3
|
|
|
402 ;;; We scan for s{}[] as well.
|
|
|
403 ;;; We scan for $blah'foo as well.
|
|
|
404 ;;; The default is to use `syntax-table' text property if Emacs is good enough.
|
|
|
405 ;;; `cperl-lineup' is put on C-M-| (=C-M-S-\\).
|
|
|
406 ;;; Start of `cperl-beautify-regexp'.
|
|
|
407
|
|
|
408 ;;;; After 1.32.4
|
|
|
409 ;;; `cperl-tags-hier-init' did not work in text-mode.
|
|
|
410 ;;; `cperl-noscan-files-regexp' had a misprint.
|
|
|
411 ;;; Generation of Class Hierarchy was broken due to a bug in `x-popup-menu'
|
|
|
412 ;;; in 19.34.
|
|
|
413
|
|
|
414 ;;;; After 1.33:
|
|
|
415 ;;; my,local highlight vars after {} too.
|
|
|
416 ;;; TAGS could not be created before imenu was loaded.
|
|
|
417 ;;; `cperl-indent-left-aligned-comments' created.
|
|
|
418 ;;; Logic of `cperl-indent-exp' changed a little bit, should be more
|
|
|
419 ;;; robust w.r.t. multiline strings.
|
|
|
420 ;;; Recognition of blah'foo takes into account strings.
|
|
|
421 ;;; Added '.al' to the list of Perl extensions.
|
|
|
422 ;;; Class hierarchy is "mostly" sorted (need to rethink algorthm
|
|
|
423 ;;; of pruning one-root-branch subtrees to get yet better sorting.)
|
|
|
424 ;;; Regeneration of TAGS was busted.
|
|
|
425 ;;; Can use `syntax-table' property when generating TAGS
|
|
|
426 ;;; (governed by `cperl-use-syntax-table-text-property-for-tags').
|
|
|
427
|
|
209
|
428 ;;; Code:
|
|
|
429
|
|
193
|
430 (defconst cperl-xemacs-p (string-match "XEmacs\\|Lucid" emacs-version))
|
|
|
431
|
|
|
432
|
|
|
433 ;;---------------------------------------------------------
|
|
|
434 (defgroup perl nil
|
|
|
435 "CPerl mode 1.35 with XEmacs enhancements."
|
|
|
436 :prefix "cperl"
|
|
|
437 :group 'languages)
|
|
|
438
|
|
|
439 ;;-----------------------------------------------
|
|
|
440 (defgroup cperl-indent nil
|
|
|
441 "CPerl indention control variables."
|
|
|
442 :prefix "cperl"
|
|
|
443 :group 'perl)
|
|
|
444
|
|
|
445 (defcustom cperl-tab-always-indent t
|
|
|
446 "*Non-nil means TAB in CPerl mode should always reindent the current line,
|
|
|
447 regardless of where in the line point is when the TAB command is used."
|
|
|
448 :type 'boolean
|
|
|
449 :group 'cperl-indent)
|
|
|
450
|
|
|
451 (defcustom cperl-extra-newline-before-brace nil
|
|
0
|
452 "*Non-nil means that if, elsif, while, until, else, for, foreach
|
|
|
453 and do constructs look like:
|
|
|
454
|
|
|
455 if ()
|
|
|
456 {
|
|
|
457 }
|
|
|
458
|
|
|
459 instead of:
|
|
|
460
|
|
|
461 if () {
|
|
|
462 }
|
|
193
|
463 "
|
|
|
464 :type 'boolean
|
|
|
465 :group 'cperl-indent)
|
|
|
466
|
|
|
467 (defcustom cperl-indent-level 2
|
|
|
468 "*Indentation of CPerl statements with respect to containing block."
|
|
|
469 :type '(choice (const 1) (const 2) (const 4) (const 6) (const 8))
|
|
|
470 :group 'cperl-indent)
|
|
|
471
|
|
|
472 (defcustom cperl-lineup-step nil
|
|
0
|
473 "*`cperl-lineup' will always lineup at multiple of this number.
|
|
193
|
474 If `nil', the value of `cperl-indent-level' will be used."
|
|
|
475 :type '(choice (const nil) (const 1) (const 2) (const 4) (const 6) (const 8))
|
|
|
476 :group 'cperl-indent)
|
|
|
477
|
|
|
478 (defcustom cperl-brace-imaginary-offset 0
|
|
0
|
479 "*Imagined indentation of a Perl open brace that actually follows a statement.
|
|
|
480 An open brace following other text is treated as if it were this far
|
|
193
|
481 to the right of the start of its line."
|
|
|
482 :type '(choice (const 0) (const 1) (const 2) (const 4) (const 6) (const 8))
|
|
|
483 :group 'cperl-indent)
|
|
|
484
|
|
|
485 (defcustom cperl-brace-offset 0
|
|
|
486 "*Extra indentation for braces, compared with other text in same context."
|
|
|
487 :type '(choice (const 0) (const 1) (const 2) (const 4) (const 6) (const 8))
|
|
|
488 :group 'cperl-indent)
|
|
|
489
|
|
|
490 (defcustom cperl-label-offset -2
|
|
|
491 "*Offset of CPerl label lines relative to usual indentation."
|
|
|
492 :type '(choice (const -4) (const -2) (const -1))
|
|
|
493 :group 'cperl-indent)
|
|
|
494
|
|
|
495 (defcustom cperl-min-label-indent 1
|
|
|
496 "*Minimal offset of CPerl label lines."
|
|
|
497 :type '(choice (const 1) (const 2) (const 4))
|
|
|
498 :group 'cperl-indent)
|
|
|
499
|
|
|
500 (defcustom cperl-continued-statement-offset 2
|
|
|
501 "*Extra indent for lines not starting new statements."
|
|
|
502 :type '(choice (const 2) (const 4) (const 6) (const 8))
|
|
|
503 :group 'cperl-indent)
|
|
|
504
|
|
|
505 (defcustom cperl-continued-brace-offset 0
|
|
0
|
506 "*Extra indent for substatements that start with open-braces.
|
|
193
|
507 This is in addition to cperl-continued-statement-offset."
|
|
|
508 :type '(choice (const 0) (const 1) (const 2) (const 4) (const 6) (const 8))
|
|
|
509 :group 'cperl-indent)
|
|
|
510
|
|
|
511 (defcustom cperl-close-paren-offset -1
|
|
|
512 "*Extra indent for substatements that start with close-parenthesis."
|
|
|
513 :type '(choice (const -4) (const -3) (const -2) (const -1) (const 0))
|
|
|
514 :group 'cperl-indent)
|
|
|
515
|
|
|
516 (defcustom cperl-regexp-indent-step nil
|
|
|
517 "*indentation used when beautifying regexps.
|
|
|
518 If `nil', the value of `cperl-indent-level' will be used."
|
|
|
519 :type '(choice (const nil) (const 0) (const 2) (const 4) (const 6) (const 8))
|
|
|
520 :group 'cperl-indent)
|
|
|
521
|
|
|
522 (defcustom cperl-indent-left-aligned-comments t
|
|
|
523 "*Non-nil means that the comment starting in leftmost column should indent."
|
|
|
524 :type 'boolean
|
|
|
525 :group 'cperl-indent)
|
|
|
526
|
|
|
527 ;;-------------------------------------------
|
|
|
528
|
|
|
529 (defcustom cperl-hairy nil
|
|
|
530 "*Not-nil means all the bells and whistles are enabled in CPerl."
|
|
|
531 :type 'boolean
|
|
|
532 :group 'perl)
|
|
|
533
|
|
|
534 (defcustom cperl-auto-newline nil
|
|
0
|
535 "*Non-nil means automatically newline before and after braces,
|
|
|
536 and after colons and semicolons, inserted in CPerl code. The following
|
|
|
537 \\[cperl-electric-backspace] will remove the inserted whitespace.
|
|
|
538 Insertion after colons requires both this variable and
|
|
193
|
539 `cperl-auto-newline-after-colon' set."
|
|
|
540 :type 'boolean
|
|
|
541 :group 'perl)
|
|
|
542
|
|
|
543 (defcustom cperl-auto-newline-after-colon nil
|
|
0
|
544 "*Non-nil means automatically newline even after colons.
|
|
193
|
545 Subject to `cperl-auto-newline' setting."
|
|
|
546 :type 'boolean
|
|
|
547 :group 'perl)
|
|
|
548
|
|
|
549 ;;--------------------------------------
|
|
|
550 (defgroup cperl-electric nil
|
|
|
551 "Customizable electric behaviour."
|
|
|
552 :prefix "cperl"
|
|
|
553 :group 'perl)
|
|
|
554
|
|
|
555 (defcustom cperl-electric-lbrace-space nil
|
|
|
556 "*Non-nil (and non-null) means { after $ in CPerl buffers should be preceded by ` '.
|
|
|
557 Can be overwritten by `cperl-hairy' if nil."
|
|
|
558 :type 'boolean
|
|
|
559 :group 'cperl-electric)
|
|
|
560
|
|
|
561 (defcustom cperl-electric-parens-string "({[]})<"
|
|
|
562 "*String of parentheses that should be electric in CPerl."
|
|
|
563 :type 'string
|
|
|
564 :group 'cperl-electric)
|
|
|
565
|
|
|
566 (defcustom cperl-electric-parens nil
|
|
0
|
567 "*Non-nil (and non-null) means parentheses should be electric in CPerl.
|
|
193
|
568 Can be overwritten by `cperl-hairy' if nil."
|
|
|
569 :type 'boolean
|
|
|
570 :group 'cperl-electric)
|
|
|
571
|
|
|
572 (defcustom cperl-electric-parens-mark (and window-system
|
|
|
573 (boundp 'zmacs-regions)
|
|
|
574 zmacs-regions)
|
|
4
|
575 "*Not-nil means that electric parens look for active mark.
|
|
193
|
576 Default is yes if there is visual feedback on mark."
|
|
|
577 :type 'boolean
|
|
|
578 :group 'cperl-electric)
|
|
|
579
|
|
|
580 (defcustom cperl-electric-linefeed nil
|
|
0
|
581 "*If true, LFD should be hairy in CPerl, otherwise C-c LFD is hairy.
|
|
|
582 In any case these two mean plain and hairy linefeeds together.
|
|
193
|
583 Can be overwritten by `cperl-hairy' if nil."
|
|
|
584 :type 'boolean
|
|
|
585 :group 'cperl-electric)
|
|
|
586
|
|
|
587 (defcustom cperl-electric-keywords nil
|
|
0
|
588 "*Not-nil (and non-null) means keywords are electric in CPerl.
|
|
193
|
589 Can be overwritten by `cperl-hairy' if nil."
|
|
|
590 :type 'boolean
|
|
|
591 :group 'cperl-electric)
|
|
|
592 ;;-------------------------
|
|
|
593
|
|
|
594 (defcustom cperl-comment-column 32
|
|
|
595 "*Column to put comments in CPerl (use \\[cperl-indent]' to lineup with code)."
|
|
|
596 :type 'integer
|
|
|
597 :group 'perl)
|
|
|
598
|
|
|
599 (defcustom cperl-vc-header-alist '((RCS "$rcs = ' $Id\$ ' ;")
|
|
|
600 (CVS "$cvs = ' $Id\$ ' ;")
|
|
|
601 (SCCS "$sccs = '%W\%' ;"))
|
|
0
|
602 "*What to use as `vc-header-alist' in CPerl.")
|
|
|
603
|
|
193
|
604
|
|
|
605 (defcustom cperl-info-on-command-no-prompt nil
|
|
0
|
606 "*Not-nil (and non-null) means not to prompt on C-h f.
|
|
|
607 The opposite behaviour is always available if prefixed with C-c.
|
|
193
|
608 Can be overwritten by `cperl-hairy' if nil."
|
|
|
609 :type 'boolean
|
|
|
610 :group 'perl)
|
|
|
611
|
|
|
612 (defcustom cperl-help nil
|
|
|
613 "*Not-nil (and non-null) means to show Auto help."
|
|
|
614 :type 'boolean
|
|
|
615 :group 'perl)
|
|
|
616
|
|
|
617
|
|
|
618 (defcustom cperl-font-lock (and (boundp 'font-lock-auto-fontify)
|
|
|
619 font-lock-auto-fontify)
|
|
|
620 "*Non-nil (and non-null) means CPerl buffers will use font-lock-mode.
|
|
|
621 Can be overwritten by `cperl-hairy' if nil. If never set, it will be
|
|
|
622 set to the value of `font-lock-auto-fontify'."
|
|
|
623 :type 'boolean
|
|
|
624 :group 'perl)
|
|
|
625
|
|
|
626 ;;--------------------------------------------
|
|
|
627 (defgroup cperl-faces nil
|
|
|
628 "Font lock faces for CPerl mode."
|
|
|
629 :group 'perl
|
|
|
630 :group 'faces)
|
|
|
631
|
|
|
632 (defface cperl-pod-face
|
|
|
633 '(( ((class color) (background light)) (:foreground "brown4") )
|
|
|
634 ( ((class color) (background dark)) (:foreground "brown1") ))
|
|
|
635 "*The face used for POD highlighting."
|
|
|
636 :group 'cperl-faces)
|
|
|
637
|
|
|
638 (defface cperl-pod-head-face
|
|
|
639 '(( ((class color)) (:foreground "steelblue")))
|
|
|
640 "*The face used for POD headers."
|
|
|
641 :group 'cperl-faces)
|
|
|
642
|
|
|
643 (defface cperl-here-face
|
|
207
|
644 '((((type x) (class color) (background light))
|
|
|
645 (:foreground "green4" :background "grey85"))
|
|
|
646 (t (:foreground "green")))
|
|
193
|
647 "*The result of evaluation of this expression is used for here-docs highlighting."
|
|
|
648 :group 'cperl-faces)
|
|
|
649
|
|
|
650 (defcustom cperl-pod-here-fontify '(featurep 'font-lock)
|
|
|
651 "*Not-nil after evaluation means to highlight pod and here-docs sections."
|
|
|
652 :type 'boolean
|
|
|
653 :group 'perl)
|
|
|
654
|
|
|
655 (defcustom cperl-pod-here-scan t
|
|
0
|
656 "*Not-nil means look for pod and here-docs sections during startup.
|
|
193
|
657 You can always make lookup from menu or using \\[cperl-find-pods-heres]."
|
|
|
658 :type 'boolean
|
|
|
659 :group 'perl)
|
|
|
660
|
|
|
661 ;; ToDo: perhaps `imenu' should be ported to XEmacs?
|
|
|
662 ;;(defcustom cperl-imenu-addback nil
|
|
|
663 ;; "*Not-nil means add backreferences to generated `imenu's.
|
|
|
664 ;;May require patched `imenu' and `imenu-go'."
|
|
|
665 ;; :type 'boolean
|
|
|
666 ;; :group 'perl)
|
|
|
667
|
|
|
668 (defcustom cperl-max-help-size 66
|
|
|
669 "*Non-nil means shrink-wrapping of info-buffer allowed up to these percents."
|
|
|
670 :type 'integer
|
|
|
671 :group 'perl)
|
|
|
672
|
|
|
673 (defcustom cperl-shrink-wrap-info-frame t
|
|
|
674 "*Non-nil means shrink-wrapping of info-buffer-frame allowed."
|
|
|
675 :type 'boolean
|
|
|
676 :group 'perl)
|
|
|
677
|
|
|
678 (defcustom cperl-info-page "perl"
|
|
|
679 "*Name of the info page containing perl docs.
|
|
|
680 Older version of this page was called `perl5', newer `perl'."
|
|
|
681 :type 'string
|
|
|
682 :group 'perl)
|
|
|
683
|
|
|
684 (defvar cperl-use-syntax-table-text-property nil
|
|
|
685 "Temporary kludge until I find everything connected to this so I can
|
|
|
686 rip it out.")
|
|
|
687
|
|
|
688 ;;(defcustom cperl-use-syntax-table-text-property
|
|
|
689 ;; (boundp 'parse-sexp-lookup-properties)
|
|
|
690 ;; "*Non-nil means CPerl sets up and uses `syntax-table' text property."
|
|
|
691 ;; :type 'boolean
|
|
|
692 ;; :group 'perl)
|
|
|
693
|
|
|
694 (defvar cperl-use-syntax-table-text-property-for-tags
|
|
|
695 cperl-use-syntax-table-text-property
|
|
|
696 "*Non-nil means: set up and use `syntax-table' text property generating TAGS.")
|
|
|
697
|
|
|
698 (defcustom cperl-scan-files-regexp "\\.\\([pP][Llm]\\|xs\\)$"
|
|
|
699 "*Regexp to match files to scan when generating TAGS."
|
|
|
700 :type 'regexp
|
|
|
701 :group 'perl)
|
|
|
702
|
|
|
703 (defcustom cperl-noscan-files-regexp "/\\(\\.\\.?\\|SCCS\\|RCS\\|blib\\)$"
|
|
|
704 "*Regexp to match files/dirs to skip when generating TAGS."
|
|
|
705 :type 'regexp
|
|
|
706 :group 'perl)
|
|
4
|
707
|
|
0
|
708
|
|
|
709
|
|
|
710 ;;; Short extra-docs.
|
|
|
711
|
|
|
712 (defvar cperl-tips 'please-ignore-this-line
|
|
|
713 "Get newest version of this package from
|
|
|
714 ftp://ftp.math.ohio-state.edu/pub/users/ilya/emacs
|
|
|
715 and/or
|
|
|
716 ftp://ftp.math.ohio-state.edu/pub/users/ilya/perl
|
|
|
717
|
|
193
|
718 This particular version has been modified for XEmacs 20.
|
|
|
719
|
|
4
|
720 Get support packages choose-color.el (or font-lock-extra.el before
|
|
|
721 19.30), imenu-go.el from the same place. \(Look for other files there
|
|
|
722 too... ;-) Get a patch for imenu.el in 19.29. Note that for 19.30 and
|
|
|
723 later you should use choose-color.el *instead* of font-lock-extra.el
|
|
|
724 \(and you will not get smart highlighting in C :-().
|
|
0
|
725
|
|
|
726 Note that to enable Compile choices in the menu you need to install
|
|
|
727 mode-compile.el.
|
|
|
728
|
|
|
729 Get perl5-info from
|
|
4
|
730 $CPAN/doc/manual/info/perl-info.tar.gz
|
|
|
731 older version was on
|
|
0
|
732 http://www.metronet.com:70/9/perlinfo/perl5/manual/perl5-info.tar.gz
|
|
4
|
733
|
|
|
734 If you use imenu-go, run imenu on perl5-info buffer (you can do it
|
|
|
735 from CPerl menu). If many files are related, generate TAGS files from
|
|
|
736 Tools/Tags submenu in CPerl menu.
|
|
|
737
|
|
|
738 If some class structure is too complicated, use Tools/Hierarchy-view
|
|
|
739 from CPerl menu, or hierarchic view of imenu. The second one uses the
|
|
|
740 current buffer only, the first one requires generation of TAGS from
|
|
|
741 CPerl/Tools/Tags menu beforehand.
|
|
|
742
|
|
|
743 Run CPerl/Tools/Insert-spaces-if-needed to fix your lazy typing.
|
|
|
744
|
|
|
745 Switch auto-help on/off with CPerl/Tools/Auto-help.
|
|
0
|
746
|
|
|
747 Before reporting (non-)problems look in the problem section on what I
|
|
|
748 know about them.")
|
|
|
749
|
|
|
750 (defvar cperl-problems 'please-ignore-this-line
|
|
|
751 "Emacs has a _very_ restricted syntax parsing engine.
|
|
|
752
|
|
|
753 It may be corrected on the level of C code, please look in the
|
|
|
754 `non-problems' section if you want to volunteer.
|
|
|
755
|
|
|
756 CPerl mode tries to corrects some Emacs misunderstandings, however,
|
|
4
|
757 for efficiency reasons the degree of correction is different for
|
|
0
|
758 different operations. The partially corrected problems are: POD
|
|
|
759 sections, here-documents, regexps. The operations are: highlighting,
|
|
|
760 indentation, electric keywords, electric braces.
|
|
|
761
|
|
|
762 This may be confusing, since the regexp s#//#/#\; may be highlighted
|
|
4
|
763 as a comment, but it will be recognized as a regexp by the indentation
|
|
0
|
764 code. Or the opposite case, when a pod section is highlighted, but
|
|
193
|
765 may break the indentation of the following code (though indentation
|
|
|
766 should work if the balance of delimiters is not broken by POD).
|
|
0
|
767
|
|
|
768 The main trick (to make $ a \"backslash\") makes constructions like
|
|
4
|
769 ${aaa} look like unbalanced braces. The only trick I can think of is
|
|
0
|
770 to insert it as $ {aaa} (legal in perl5, not in perl4).
|
|
|
771
|
|
|
772 Similar problems arise in regexps, when /(\\s|$)/ should be rewritten
|
|
4
|
773 as /($|\\s)/. Note that such a transposition is not always possible
|
|
0
|
774 :-(. " )
|
|
|
775
|
|
|
776 (defvar cperl-non-problems 'please-ignore-this-line
|
|
4
|
777 "As you know from `problems' section, Perl syntax is too hard for CPerl.
|
|
0
|
778
|
|
|
779 Most the time, if you write your own code, you may find an equivalent
|
|
|
780 \(and almost as readable) expression.
|
|
|
781
|
|
193
|
782 Try to help CPerl: add comments with embedded quotes to fix CPerl
|
|
0
|
783 misunderstandings about the end of quotation:
|
|
|
784
|
|
|
785 $a='500$'; # ';
|
|
|
786
|
|
|
787 You won't need it too often. The reason: $ \"quotes\" the following
|
|
|
788 character (this saves a life a lot of times in CPerl), thus due to
|
|
193
|
789 Emacs parsing rules it does not consider tick (i.e., ' ) after a
|
|
|
790 dollar as a closing one, but as a usual character.
|
|
0
|
791
|
|
|
792 Now the indentation code is pretty wise. The only drawback is that it
|
|
|
793 relies on Emacs parsing to find matching parentheses. And Emacs
|
|
|
794 *cannot* match parentheses in Perl 100% correctly. So
|
|
|
795 1 if s#//#/#;
|
|
|
796 will not break indentation, but
|
|
|
797 1 if ( s#//#/# );
|
|
|
798 will.
|
|
|
799
|
|
110
|
800 By similar reasons
|
|
|
801 s\"abc\"def\";
|
|
|
802 will confuse CPerl a lot.
|
|
|
803
|
|
0
|
804 If you still get wrong indentation in situation that you think the
|
|
|
805 code should be able to parse, try:
|
|
|
806
|
|
|
807 a) Check what Emacs thinks about balance of your parentheses.
|
|
|
808 b) Supply the code to me (IZ).
|
|
|
809
|
|
|
810 Pods are treated _very_ rudimentally. Here-documents are not treated
|
|
|
811 at all (except highlighting and inhibiting indentation). (This may
|
|
|
812 change some time. RMS approved making syntax lookup recognize text
|
|
4
|
813 attributes, but volunteers are needed to change Emacs C code.)
|
|
0
|
814
|
|
|
815 To speed up coloring the following compromises exist:
|
|
|
816 a) sub in $mypackage::sub may be highlighted.
|
|
|
817 b) -z in [a-z] may be highlighted.
|
|
|
818 c) if your regexp contains a keyword (like \"s\"), it may be highlighted.
|
|
4
|
819
|
|
|
820
|
|
|
821 Imenu in 19.31 is broken. Set `imenu-use-keymap-menu' to t, and remove
|
|
|
822 `car' before `imenu-choose-buffer-index' in `imenu'.
|
|
0
|
823 ")
|
|
|
824
|
|
193
|
825 (defvar cperl-praise 'please-ignore-this-line
|
|
|
826 "RMS asked me to list good things about CPerl. Here they go:
|
|
|
827
|
|
|
828 0) It uses the newest `syntax-table' property ;-);
|
|
|
829
|
|
|
830 1) It does 99% of Perl syntax correct (as opposed to 80-90% in Perl
|
|
|
831 mode - but the latter number may have improved too in last years) even
|
|
|
832 without `syntax-table' property; When using this property, it should
|
|
|
833 handle 99.995% of lines correct - or somesuch.
|
|
|
834
|
|
|
835 2) It is generally belived to be \"the most user-friendly Emacs
|
|
|
836 package\" whatever it may mean (I doubt that the people who say similar
|
|
|
837 things tried _all_ the rest of Emacs ;-), but this was not a lonely
|
|
|
838 voice);
|
|
|
839
|
|
|
840 3) Everything is customizable, one-by-one or in a big sweep;
|
|
|
841
|
|
|
842 4) It has many easily-accessable \"tools\":
|
|
|
843 a) Can run program, check syntax, start debugger;
|
|
|
844 b) Can lineup vertically \"middles\" of rows, like `=' in
|
|
|
845 a = b;
|
|
|
846 cc = d;
|
|
|
847 c) Can insert spaces where this impoves readability (in one
|
|
|
848 interactive sweep over the buffer);
|
|
|
849 d) Has support for imenu, including:
|
|
|
850 1) Separate unordered list of \"interesting places\";
|
|
|
851 2) Separate TOC of POD sections;
|
|
|
852 3) Separate list of packages;
|
|
|
853 4) Hierarchical view of methods in (sub)packages;
|
|
|
854 5) and functions (by the full name - with package);
|
|
|
855 e) Has an interface to INFO docs for Perl; The interface is
|
|
|
856 very flexible, including shrink-wrapping of
|
|
|
857 documentation buffer/frame;
|
|
|
858 f) Has a builtin list of one-line explanations for perl constructs.
|
|
|
859 g) Can show these explanations if you stay long enough at the
|
|
|
860 corresponding place (or on demand);
|
|
|
861 h) Has an enhanced fontification (using 3 or 4 additional faces
|
|
|
862 comparing to font-lock - basically, different
|
|
|
863 namespaces in Perl have different colors);
|
|
|
864 i) Can construct TAGS basing on its knowledge of Perl syntax,
|
|
|
865 the standard menu has 6 different way to generate
|
|
|
866 TAGS (if by directory, .xs files - with C-language
|
|
|
867 bindings - are included in the scan);
|
|
|
868 j) Can build a hierarchical view of classes (via imenu) basing
|
|
|
869 on generated TAGS file;
|
|
|
870 k) Has electric parentheses, electric newlines, uses Abbrev
|
|
|
871 for electric logical constructs
|
|
|
872 while () {}
|
|
|
873 with different styles of expansion (context sensitive
|
|
|
874 to be not so bothering). Electric parentheses behave
|
|
|
875 \"as they should\" in a presence of a visible region.
|
|
|
876 l) Changes msb.el \"on the fly\" to insert a group \"Perl files\";
|
|
|
877
|
|
|
878 5) The indentation engine was very smart, but most of tricks may be
|
|
|
879 not needed anymore with the support for `syntax-table' property. Has
|
|
|
880 progress indicator for indentation (with `imenu' loaded).
|
|
|
881
|
|
|
882 6) Indent-region improves inline-comments as well;
|
|
|
883
|
|
|
884 7) Fill-paragraph correctly handles multi-line comments;
|
|
|
885 ")
|
|
|
886
|
|
0
|
887
|
|
|
888
|
|
|
889 ;;; Portability stuff:
|
|
|
890
|
|
4
|
891 (defmacro cperl-define-key (fsf-key definition &optional xemacs-key)
|
|
193
|
892 (` (define-key cperl-mode-map
|
|
|
893 (, (if xemacs-key
|
|
|
894 (` (if cperl-xemacs-p (, xemacs-key) (, fsf-key)))
|
|
|
895 fsf-key))
|
|
|
896 (, definition))))
|
|
0
|
897
|
|
|
898 (defvar del-back-ch (car (append (where-is-internal 'delete-backward-char)
|
|
|
899 (where-is-internal 'backward-delete-char-untabify)))
|
|
|
900 "Character generated by key bound to delete-backward-char.")
|
|
|
901
|
|
|
902 (and (vectorp del-back-ch) (= (length del-back-ch) 1)
|
|
|
903 (setq del-back-ch (aref del-back-ch 0)))
|
|
|
904
|
|
4
|
905 (if cperl-xemacs-p
|
|
0
|
906 (progn
|
|
|
907 ;; "Active regions" are on: use region only if active
|
|
|
908 ;; "Active regions" are off: use region unconditionally
|
|
|
909 (defun cperl-use-region-p ()
|
|
|
910 (if zmacs-regions (mark) t))
|
|
|
911 (defun cperl-mark-active () (mark)))
|
|
|
912 (defun cperl-use-region-p ()
|
|
|
913 (if transient-mark-mode mark-active t))
|
|
|
914 (defun cperl-mark-active () mark-active))
|
|
|
915
|
|
|
916 (defsubst cperl-enable-font-lock ()
|
|
4
|
917 (or cperl-xemacs-p window-system))
|
|
0
|
918
|
|
|
919 (if (boundp 'unread-command-events)
|
|
4
|
920 (if cperl-xemacs-p
|
|
0
|
921 (defun cperl-putback-char (c) ; XEmacs >= 19.12
|
|
|
922 (setq unread-command-events (list (character-to-event c))))
|
|
|
923 (defun cperl-putback-char (c) ; Emacs 19
|
|
|
924 (setq unread-command-events (list c))))
|
|
|
925 (defun cperl-putback-char (c) ; XEmacs <= 19.11
|
|
|
926 (setq unread-command-event (character-to-event c))))
|
|
|
927
|
|
|
928 (or (fboundp 'uncomment-region)
|
|
|
929 (defun uncomment-region (beg end)
|
|
|
930 (interactive "r")
|
|
|
931 (comment-region beg end -1)))
|
|
|
932
|
|
|
933 (defvar cperl-do-not-fontify
|
|
|
934 (if (string< emacs-version "19.30")
|
|
|
935 'fontified
|
|
|
936 'lazy-lock)
|
|
|
937 "Text property which inhibits refontification.")
|
|
|
938
|
|
4
|
939 (defsubst cperl-put-do-not-fontify (from to)
|
|
|
940 (put-text-property (max (point-min) (1- from))
|
|
|
941 to cperl-do-not-fontify t))
|
|
|
942
|
|
193
|
943 (defcustom cperl-mode-hook nil
|
|
|
944 "Hook run by `cperl-mode'."
|
|
|
945 :type 'sexp
|
|
|
946 :group 'perl)
|
|
|
947
|
|
0
|
948
|
|
|
949 ;;; Probably it is too late to set these guys already, but it can help later:
|
|
203
|
950 ;;; ####
|
|
0
|
951 (setq auto-mode-alist
|
|
193
|
952 (append '(("\\.\\([pP][Llm]\\|al\\)\\'" . perl-mode)) auto-mode-alist ))
|
|
0
|
953 (and (boundp 'interpreter-mode-alist)
|
|
|
954 (setq interpreter-mode-alist (append interpreter-mode-alist
|
|
|
955 '(("miniperl" . perl-mode)))))
|
|
|
956 (if (fboundp 'eval-when-compile)
|
|
|
957 (eval-when-compile
|
|
|
958 (condition-case nil
|
|
|
959 (require 'imenu)
|
|
|
960 (error nil))
|
|
|
961 (condition-case nil
|
|
|
962 (require 'easymenu)
|
|
|
963 (error nil))
|
|
|
964 ;; Calling `cperl-enable-font-lock' below doesn't compile on XEmacs,
|
|
|
965 ;; macros instead of defsubsts don't work on Emacs, so we do the
|
|
|
966 ;; expansion manually. Any other suggestions?
|
|
|
967 (if (or (string-match "XEmacs\\|Lucid" emacs-version)
|
|
|
968 window-system)
|
|
|
969 (require 'font-lock))
|
|
|
970 (require 'cl)
|
|
|
971 ))
|
|
|
972
|
|
|
973 (defvar cperl-mode-abbrev-table nil
|
|
|
974 "Abbrev table in use in Cperl-mode buffers.")
|
|
|
975
|
|
|
976 (add-hook 'edit-var-mode-alist '(perl-mode (regexp . "^cperl-")))
|
|
|
977
|
|
|
978 (defvar cperl-mode-map () "Keymap used in CPerl mode.")
|
|
|
979
|
|
|
980 (if cperl-mode-map nil
|
|
|
981 (setq cperl-mode-map (make-sparse-keymap))
|
|
4
|
982 (cperl-define-key "{" 'cperl-electric-lbrace)
|
|
|
983 (cperl-define-key "[" 'cperl-electric-paren)
|
|
|
984 (cperl-define-key "(" 'cperl-electric-paren)
|
|
|
985 (cperl-define-key "<" 'cperl-electric-paren)
|
|
|
986 (cperl-define-key "}" 'cperl-electric-brace)
|
|
|
987 (cperl-define-key "]" 'cperl-electric-rparen)
|
|
|
988 (cperl-define-key ")" 'cperl-electric-rparen)
|
|
|
989 (cperl-define-key ";" 'cperl-electric-semi)
|
|
|
990 (cperl-define-key ":" 'cperl-electric-terminator)
|
|
193
|
991 (cperl-define-key "\C-cf" 'cperl-find-pods-heres)
|
|
4
|
992 (cperl-define-key "\C-j" 'newline-and-indent)
|
|
|
993 (cperl-define-key "\C-c\C-j" 'cperl-linefeed)
|
|
|
994 (cperl-define-key "\C-c\C-a" 'cperl-toggle-auto-newline)
|
|
|
995 (cperl-define-key "\C-c\C-k" 'cperl-toggle-abbrev)
|
|
|
996 (cperl-define-key "\C-c\C-e" 'cperl-toggle-electric)
|
|
|
997 (cperl-define-key "\e\C-q" 'cperl-indent-exp) ; Usually not bound
|
|
193
|
998 (cperl-define-key [?\C-\M-\|] 'cperl-lineup)
|
|
4
|
999 ;;(cperl-define-key "\M-q" 'cperl-fill-paragraph)
|
|
|
1000 ;;(cperl-define-key "\e;" 'cperl-indent-for-comment)
|
|
193
|
1001 (if cperl-xemacs-p
|
|
|
1002 (progn
|
|
|
1003 (cperl-define-key 'backspace 'cperl-electric-backspace)
|
|
|
1004 (cperl-define-key 'delete 'cperl-electric-delete))
|
|
|
1005 (cperl-define-key "\177" 'cperl-electric-backspace))
|
|
4
|
1006 (cperl-define-key "\t" 'cperl-indent-command)
|
|
|
1007 ;; don't clobber the backspace binding:
|
|
|
1008 (cperl-define-key "\C-c\C-hf" 'cperl-info-on-current-command
|
|
|
1009 [(control c) (control h) f])
|
|
193
|
1010 (cperl-define-key "\C-hf"
|
|
|
1011 ;;(concat (char-to-string help-char) "f") ; does not work
|
|
|
1012 'cperl-info-on-command
|
|
|
1013 [(control h) f])
|
|
|
1014 (cperl-define-key "\C-hv"
|
|
|
1015 ;;(concat (char-to-string help-char) "v") ; does not work
|
|
|
1016 'cperl-get-help
|
|
|
1017 [(control h) v])
|
|
4
|
1018 (if (and cperl-xemacs-p
|
|
0
|
1019 (<= emacs-minor-version 11) (<= emacs-major-version 19))
|
|
|
1020 (progn
|
|
|
1021 ;; substitute-key-definition is usefulness-deenhanced...
|
|
4
|
1022 (cperl-define-key "\M-q" 'cperl-fill-paragraph)
|
|
|
1023 (cperl-define-key "\e;" 'cperl-indent-for-comment)
|
|
|
1024 (cperl-define-key "\e\C-\\" 'cperl-indent-region))
|
|
0
|
1025 (substitute-key-definition
|
|
|
1026 'indent-sexp 'cperl-indent-exp
|
|
|
1027 cperl-mode-map global-map)
|
|
|
1028 (substitute-key-definition
|
|
|
1029 'fill-paragraph 'cperl-fill-paragraph
|
|
|
1030 cperl-mode-map global-map)
|
|
|
1031 (substitute-key-definition
|
|
|
1032 'indent-region 'cperl-indent-region
|
|
|
1033 cperl-mode-map global-map)
|
|
|
1034 (substitute-key-definition
|
|
|
1035 'indent-for-comment 'cperl-indent-for-comment
|
|
|
1036 cperl-mode-map global-map)))
|
|
|
1037
|
|
|
1038 (condition-case nil
|
|
|
1039 (progn
|
|
|
1040 (require 'easymenu)
|
|
|
1041 (easy-menu-define cperl-menu cperl-mode-map "Menu for CPerl mode"
|
|
|
1042 '("Perl"
|
|
|
1043 ["Beginning of function" beginning-of-defun t]
|
|
|
1044 ["End of function" end-of-defun t]
|
|
|
1045 ["Mark function" mark-defun t]
|
|
|
1046 ["Indent expression" cperl-indent-exp t]
|
|
|
1047 ["Fill paragraph/comment" cperl-fill-paragraph t]
|
|
193
|
1048 "----"
|
|
0
|
1049 ["Line up a construction" cperl-lineup (cperl-use-region-p)]
|
|
193
|
1050 ["Beautify a regexp" cperl-beautify-regexp
|
|
|
1051 cperl-use-syntax-table-text-property]
|
|
0
|
1052 "----"
|
|
|
1053 ["Indent region" cperl-indent-region (cperl-use-region-p)]
|
|
4
|
1054 ["Comment region" cperl-comment-region (cperl-use-region-p)]
|
|
|
1055 ["Uncomment region" cperl-uncomment-region (cperl-use-region-p)]
|
|
0
|
1056 "----"
|
|
|
1057 ["Run" mode-compile (fboundp 'mode-compile)]
|
|
|
1058 ["Kill" mode-compile-kill (and (fboundp 'mode-compile-kill)
|
|
|
1059 (get-buffer "*compilation*"))]
|
|
|
1060 ["Next error" next-error (get-buffer "*compilation*")]
|
|
|
1061 ["Check syntax" cperl-check-syntax (fboundp 'mode-compile)]
|
|
|
1062 "----"
|
|
4
|
1063 ["Debugger" cperl-db t]
|
|
0
|
1064 "----"
|
|
|
1065 ("Tools"
|
|
193
|
1066 ;;; ["Imenu" imenu (fboundp 'imenu)]
|
|
4
|
1067 ["Insert spaces if needed" cperl-find-bad-style t]
|
|
|
1068 ["Class Hierarchy from TAGS" cperl-tags-hier-init t]
|
|
|
1069 ;;["Update classes" (cperl-tags-hier-init t) tags-table-list]
|
|
193
|
1070 ;;; ["Imenu on info" cperl-imenu-on-info (featurep 'imenu)]
|
|
0
|
1071 ("Tags"
|
|
193
|
1072 ["Create tags for current file" cperl-etags t]
|
|
|
1073 ["Add tags for current file" (cperl-etags t) t]
|
|
|
1074 ["Create tags for Perl files in directory" (cperl-etags nil t) t]
|
|
|
1075 ["Add tags for Perl files in directory" (cperl-etags t t) t]
|
|
|
1076 ["Create tags for Perl files in (sub)directories"
|
|
|
1077 (cperl-etags nil 'recursive) t]
|
|
|
1078 ["Add tags for Perl files in (sub)directories"
|
|
|
1079 (cperl-etags t 'recursive) t])
|
|
4
|
1080 ;;;; cperl-write-tags (&optional file erase recurse dir inbuffer)
|
|
193
|
1081 ;;; ["Create tags for current file" (cperl-write-tags nil t) t]
|
|
|
1082 ;;; ["Add tags for current file" (cperl-write-tags) t]
|
|
|
1083 ;;; ["Create tags for Perl files in directory"
|
|
|
1084 ;;; (cperl-write-tags nil t nil t) t]
|
|
|
1085 ;;; ["Add tags for Perl files in directory"
|
|
|
1086 ;;; (cperl-write-tags nil nil nil t) t]
|
|
|
1087 ;;; ["Create tags for Perl files in (sub)directories"
|
|
|
1088 ;;; (cperl-write-tags nil t t t) t]
|
|
|
1089 ;;; ["Add tags for Perl files in (sub)directories"
|
|
|
1090 ;;; (cperl-write-tags nil nil t t) t])
|
|
4
|
1091 ["Recalculate PODs and HEREs" cperl-find-pods-heres t]
|
|
193
|
1092 ;;; ["Define word at point" imenu-go-find-at-position
|
|
|
1093 ;;; (fboundp 'imenu-go-find-at-position)]
|
|
0
|
1094 ["Help on function" cperl-info-on-command t]
|
|
4
|
1095 ["Help on function at point" cperl-info-on-current-command t]
|
|
|
1096 ["Help on symbol at point" cperl-get-help t]
|
|
193
|
1097 )
|
|
0
|
1098 ("Toggle..."
|
|
193
|
1099 ["Auto-help" cperl-toggle-help :style toggle :selected cperl-help]
|
|
0
|
1100 ["Auto newline" cperl-toggle-auto-newline t]
|
|
|
1101 ["Electric parens" cperl-toggle-electric t]
|
|
|
1102 ["Electric keywords" cperl-toggle-abbrev t]
|
|
|
1103 )
|
|
|
1104 ("Indent styles..."
|
|
|
1105 ["GNU" (cperl-set-style "GNU") t]
|
|
|
1106 ["C++" (cperl-set-style "C++") t]
|
|
|
1107 ["FSF" (cperl-set-style "FSF") t]
|
|
|
1108 ["BSD" (cperl-set-style "BSD") t]
|
|
193
|
1109 ["Whitesmith" (cperl-set-style "Whitesmith") t]
|
|
|
1110 )
|
|
0
|
1111 ("Micro-docs"
|
|
|
1112 ["Tips" (describe-variable 'cperl-tips) t]
|
|
|
1113 ["Problems" (describe-variable 'cperl-problems) t]
|
|
193
|
1114 ["Non-problems" (describe-variable 'cperl-non-problems) t]
|
|
|
1115 ["Praise" (describe-variable 'cperl-praise) t]))))
|
|
0
|
1116 (error nil))
|
|
|
1117
|
|
|
1118 (autoload 'c-macro-expand "cmacexp"
|
|
|
1119 "Display the result of expanding all C macros occurring in the region.
|
|
|
1120 The expansion is entirely correct because it uses the C preprocessor."
|
|
|
1121 t)
|
|
|
1122
|
|
|
1123 (defvar cperl-mode-syntax-table nil
|
|
|
1124 "Syntax table in use in Cperl-mode buffers.")
|
|
|
1125
|
|
193
|
1126 (defvar cperl-string-syntax-table nil
|
|
|
1127 "Syntax table in use in Cperl-mode string-like chunks.")
|
|
|
1128
|
|
0
|
1129 (if cperl-mode-syntax-table
|
|
|
1130 ()
|
|
|
1131 (setq cperl-mode-syntax-table (make-syntax-table))
|
|
|
1132 (modify-syntax-entry ?\\ "\\" cperl-mode-syntax-table)
|
|
|
1133 (modify-syntax-entry ?/ "." cperl-mode-syntax-table)
|
|
|
1134 (modify-syntax-entry ?* "." cperl-mode-syntax-table)
|
|
|
1135 (modify-syntax-entry ?+ "." cperl-mode-syntax-table)
|
|
|
1136 (modify-syntax-entry ?- "." cperl-mode-syntax-table)
|
|
|
1137 (modify-syntax-entry ?= "." cperl-mode-syntax-table)
|
|
|
1138 (modify-syntax-entry ?% "." cperl-mode-syntax-table)
|
|
|
1139 (modify-syntax-entry ?< "." cperl-mode-syntax-table)
|
|
|
1140 (modify-syntax-entry ?> "." cperl-mode-syntax-table)
|
|
|
1141 (modify-syntax-entry ?& "." cperl-mode-syntax-table)
|
|
|
1142 (modify-syntax-entry ?$ "\\" cperl-mode-syntax-table)
|
|
|
1143 (modify-syntax-entry ?\n ">" cperl-mode-syntax-table)
|
|
|
1144 (modify-syntax-entry ?# "<" cperl-mode-syntax-table)
|
|
|
1145 (modify-syntax-entry ?' "\"" cperl-mode-syntax-table)
|
|
|
1146 (modify-syntax-entry ?` "\"" cperl-mode-syntax-table)
|
|
193
|
1147 (modify-syntax-entry ?_ "w" cperl-mode-syntax-table)
|
|
4
|
1148 (modify-syntax-entry ?: "_" cperl-mode-syntax-table)
|
|
193
|
1149 (modify-syntax-entry ?| "." cperl-mode-syntax-table)
|
|
|
1150 (setq cperl-string-syntax-table (copy-syntax-table cperl-mode-syntax-table))
|
|
|
1151 (modify-syntax-entry ?$ "." cperl-string-syntax-table)
|
|
|
1152 (modify-syntax-entry ?# "." cperl-string-syntax-table) ; (?# comment )
|
|
|
1153 )
|
|
0
|
1154
|
|
|
1155
|
|
|
1156
|
|
|
1157 ;; Make customization possible "in reverse"
|
|
|
1158 ;;(defun cperl-set (symbol to)
|
|
|
1159 ;; (or (eq (symbol-value symbol) 'null) (set symbol to)))
|
|
|
1160 (defsubst cperl-val (symbol &optional default hairy)
|
|
|
1161 (cond
|
|
|
1162 ((eq (symbol-value symbol) 'null) default)
|
|
|
1163 (cperl-hairy (or hairy t))
|
|
|
1164 (t (symbol-value symbol))))
|
|
|
1165
|
|
|
1166 ;; provide an alias for working with emacs 19. the perl-mode that comes
|
|
|
1167 ;; with it is really bad, and this lets us seamlessly replace it.
|
|
203
|
1168 ;;;###autoload
|
|
|
1169 (defalias 'perl-mode 'cperl-mode)
|
|
|
1170 ;;;###autoload
|
|
0
|
1171 (defun cperl-mode ()
|
|
|
1172 "Major mode for editing Perl code.
|
|
|
1173 Expression and list commands understand all C brackets.
|
|
|
1174 Tab indents for Perl code.
|
|
|
1175 Paragraphs are separated by blank lines only.
|
|
|
1176 Delete converts tabs to spaces as it moves back.
|
|
|
1177
|
|
|
1178 Various characters in Perl almost always come in pairs: {}, (), [],
|
|
|
1179 sometimes <>. When the user types the first, she gets the second as
|
|
|
1180 well, with optional special formatting done on {}. (Disabled by
|
|
|
1181 default.) You can always quote (with \\[quoted-insert]) the left
|
|
|
1182 \"paren\" to avoid the expansion. The processing of < is special,
|
|
|
1183 since most the time you mean \"less\". Cperl mode tries to guess
|
|
|
1184 whether you want to type pair <>, and inserts is if it
|
|
|
1185 appropriate. You can set `cperl-electric-parens-string' to the string that
|
|
|
1186 contains the parenths from the above list you want to be electrical.
|
|
|
1187 Electricity of parenths is controlled by `cperl-electric-parens'.
|
|
|
1188 You may also set `cperl-electric-parens-mark' to have electric parens
|
|
|
1189 look for active mark and \"embrace\" a region if possible.'
|
|
|
1190
|
|
|
1191 CPerl mode provides expansion of the Perl control constructs:
|
|
|
1192 if, else, elsif, unless, while, until, for, and foreach.
|
|
|
1193 =========(Disabled by default, see `cperl-electric-keywords'.)
|
|
|
1194 The user types the keyword immediately followed by a space, which causes
|
|
|
1195 the construct to be expanded, and the user is positioned where she is most
|
|
|
1196 likely to want to be.
|
|
|
1197 eg. when the user types a space following \"if\" the following appears in
|
|
|
1198 the buffer:
|
|
|
1199 if () { or if ()
|
|
|
1200 } {
|
|
|
1201 }
|
|
|
1202 and the cursor is between the parentheses. The user can then type some
|
|
|
1203 boolean expression within the parens. Having done that, typing
|
|
|
1204 \\[cperl-linefeed] places you, appropriately indented on a new line
|
|
|
1205 between the braces. If CPerl decides that you want to insert
|
|
|
1206 \"English\" style construct like
|
|
|
1207 bite if angry;
|
|
|
1208 it will not do any expansion. See also help on variable
|
|
|
1209 `cperl-extra-newline-before-brace'.
|
|
|
1210
|
|
4
|
1211 \\[cperl-linefeed] is a convenience replacement for typing carriage
|
|
0
|
1212 return. It places you in the next line with proper indentation, or if
|
|
|
1213 you type it inside the inline block of control construct, like
|
|
|
1214 foreach (@lines) {print; print}
|
|
|
1215 and you are on a boundary of a statement inside braces, it will
|
|
|
1216 transform the construct into a multiline and will place you into an
|
|
4
|
1217 appropriately indented blank line. If you need a usual
|
|
0
|
1218 `newline-and-indent' behaviour, it is on \\[newline-and-indent],
|
|
|
1219 see documentation on `cperl-electric-linefeed'.
|
|
|
1220
|
|
|
1221 \\{cperl-mode-map}
|
|
|
1222
|
|
|
1223 Setting the variable `cperl-font-lock' to t switches on
|
|
|
1224 font-lock-mode, `cperl-electric-lbrace-space' to t switches on
|
|
|
1225 electric space between $ and {, `cperl-electric-parens-string' is the
|
|
|
1226 string that contains parentheses that should be electric in CPerl (see
|
|
|
1227 also `cperl-electric-parens-mark' and `cperl-electric-parens'),
|
|
|
1228 setting `cperl-electric-keywords' enables electric expansion of
|
|
|
1229 control structures in CPerl. `cperl-electric-linefeed' governs which
|
|
|
1230 one of two linefeed behavior is preferable. You can enable all these
|
|
|
1231 options simultaneously (recommended mode of use) by setting
|
|
|
1232 `cperl-hairy' to t. In this case you can switch separate options off
|
|
|
1233 by setting them to `null'. Note that one may undo the extra whitespace
|
|
|
1234 inserted by semis and braces in `auto-newline'-mode by consequent
|
|
|
1235 \\[cperl-electric-backspace].
|
|
|
1236
|
|
|
1237 If your site has perl5 documentation in info format, you can use commands
|
|
|
1238 \\[cperl-info-on-current-command] and \\[cperl-info-on-command] to access it.
|
|
|
1239 These keys run commands `cperl-info-on-current-command' and
|
|
|
1240 `cperl-info-on-command', which one is which is controlled by variable
|
|
|
1241 `cperl-info-on-command-no-prompt' (in turn affected by `cperl-hairy').
|
|
|
1242
|
|
4
|
1243 Even if you have no info-format documentation, short one-liner-style
|
|
|
1244 help is available on \\[cperl-get-help].
|
|
|
1245
|
|
|
1246 It is possible to show this help automatically after some idle
|
|
|
1247 time. This is regulated by variable `cperl-lazy-help-time'. Default
|
|
|
1248 with `cperl-hairy' is 5 secs idle time if the value of this variable
|
|
|
1249 is nil. It is also possible to switch this on/off from the
|
|
|
1250 menu. Requires `run-with-idle-timer'.
|
|
|
1251
|
|
193
|
1252 Use \\[cperl-lineup] to vertically lineup some construction - put the
|
|
|
1253 beginning of the region at the start of construction, and make region
|
|
|
1254 span the needed amount of lines.
|
|
|
1255
|
|
0
|
1256 Variables `cperl-pod-here-scan', `cperl-pod-here-fontify',
|
|
|
1257 `cperl-pod-face', `cperl-pod-head-face' control processing of pod and
|
|
|
1258 here-docs sections. In a future version results of scan may be used
|
|
|
1259 for indentation too, currently they are used for highlighting only.
|
|
|
1260
|
|
|
1261 Variables controlling indentation style:
|
|
|
1262 `cperl-tab-always-indent'
|
|
|
1263 Non-nil means TAB in CPerl mode should always reindent the current line,
|
|
|
1264 regardless of where in the line point is when the TAB command is used.
|
|
|
1265 `cperl-auto-newline'
|
|
|
1266 Non-nil means automatically newline before and after braces,
|
|
|
1267 and after colons and semicolons, inserted in Perl code. The following
|
|
|
1268 \\[cperl-electric-backspace] will remove the inserted whitespace.
|
|
|
1269 Insertion after colons requires both this variable and
|
|
|
1270 `cperl-auto-newline-after-colon' set.
|
|
|
1271 `cperl-auto-newline-after-colon'
|
|
|
1272 Non-nil means automatically newline even after colons.
|
|
|
1273 Subject to `cperl-auto-newline' setting.
|
|
|
1274 `cperl-indent-level'
|
|
|
1275 Indentation of Perl statements within surrounding block.
|
|
|
1276 The surrounding block's indentation is the indentation
|
|
|
1277 of the line on which the open-brace appears.
|
|
|
1278 `cperl-continued-statement-offset'
|
|
|
1279 Extra indentation given to a substatement, such as the
|
|
|
1280 then-clause of an if, or body of a while, or just a statement continuation.
|
|
|
1281 `cperl-continued-brace-offset'
|
|
|
1282 Extra indentation given to a brace that starts a substatement.
|
|
|
1283 This is in addition to `cperl-continued-statement-offset'.
|
|
|
1284 `cperl-brace-offset'
|
|
|
1285 Extra indentation for line if it starts with an open brace.
|
|
|
1286 `cperl-brace-imaginary-offset'
|
|
|
1287 An open brace following other text is treated as if it the line started
|
|
|
1288 this far to the right of the actual line indentation.
|
|
|
1289 `cperl-label-offset'
|
|
|
1290 Extra indentation for line that is a label.
|
|
|
1291 `cperl-min-label-indent'
|
|
|
1292 Minimal indentation for line that is a label.
|
|
|
1293
|
|
|
1294 Settings for K&R and BSD indentation styles are
|
|
|
1295 `cperl-indent-level' 5 8
|
|
|
1296 `cperl-continued-statement-offset' 5 8
|
|
|
1297 `cperl-brace-offset' -5 -8
|
|
|
1298 `cperl-label-offset' -5 -8
|
|
|
1299
|
|
|
1300 If `cperl-indent-level' is 0, the statement after opening brace in column 0 is indented on `cperl-brace-offset'+`cperl-continued-statement-offset'.
|
|
|
1301
|
|
|
1302 Turning on CPerl mode calls the hooks in the variable `cperl-mode-hook'
|
|
|
1303 with no args."
|
|
|
1304 (interactive)
|
|
|
1305 (kill-all-local-variables)
|
|
|
1306 ;;(if cperl-hairy
|
|
|
1307 ;; (progn
|
|
|
1308 ;; (cperl-set 'cperl-font-lock cperl-hairy)
|
|
|
1309 ;; (cperl-set 'cperl-electric-lbrace-space cperl-hairy)
|
|
|
1310 ;; (cperl-set 'cperl-electric-parens "{[(<")
|
|
|
1311 ;; (cperl-set 'cperl-electric-keywords cperl-hairy)
|
|
|
1312 ;; (cperl-set 'cperl-electric-linefeed cperl-hairy)))
|
|
|
1313 (use-local-map cperl-mode-map)
|
|
|
1314 (if (cperl-val 'cperl-electric-linefeed)
|
|
|
1315 (progn
|
|
|
1316 (local-set-key "\C-J" 'cperl-linefeed)
|
|
|
1317 (local-set-key "\C-C\C-J" 'newline-and-indent)))
|
|
|
1318 (if (cperl-val 'cperl-info-on-command-no-prompt)
|
|
|
1319 (progn
|
|
193
|
1320 ;; don't clobber the backspace binding for Ye Olde Emacs
|
|
|
1321 ;;(cperl-define-key "\C-hf" 'cperl-info-on-current-command [(control h) f])
|
|
|
1322 (cperl-define-key "\C-hf" 'cperl-info-on-current-command [f1 f])
|
|
4
|
1323 (cperl-define-key "\C-hf" 'cperl-info-on-current-command [(control h) f])
|
|
|
1324 (cperl-define-key "\C-c\C-hf" 'cperl-info-on-command
|
|
|
1325 [(control c) (control h) f])))
|
|
193
|
1326 (setq major-mode 'perl-mode
|
|
|
1327 mode-name "CPerl"
|
|
|
1328 cperl-mode t)
|
|
0
|
1329 (if (not cperl-mode-abbrev-table)
|
|
|
1330 (let ((prev-a-c abbrevs-changed))
|
|
|
1331 (define-abbrev-table 'cperl-mode-abbrev-table '(
|
|
|
1332 ("if" "if" cperl-electric-keyword 0)
|
|
|
1333 ("elsif" "elsif" cperl-electric-keyword 0)
|
|
|
1334 ("while" "while" cperl-electric-keyword 0)
|
|
|
1335 ("until" "until" cperl-electric-keyword 0)
|
|
|
1336 ("unless" "unless" cperl-electric-keyword 0)
|
|
|
1337 ("else" "else" cperl-electric-else 0)
|
|
|
1338 ("for" "for" cperl-electric-keyword 0)
|
|
|
1339 ("foreach" "foreach" cperl-electric-keyword 0)
|
|
|
1340 ("do" "do" cperl-electric-keyword 0)))
|
|
|
1341 (setq abbrevs-changed prev-a-c)))
|
|
|
1342 (setq local-abbrev-table cperl-mode-abbrev-table)
|
|
|
1343 (abbrev-mode (if (cperl-val 'cperl-electric-keywords) 1 0))
|
|
|
1344 (set-syntax-table cperl-mode-syntax-table)
|
|
|
1345 (make-local-variable 'paragraph-start)
|
|
|
1346 (setq paragraph-start (concat "^$\\|" page-delimiter))
|
|
|
1347 (make-local-variable 'paragraph-separate)
|
|
|
1348 (setq paragraph-separate paragraph-start)
|
|
|
1349 (make-local-variable 'paragraph-ignore-fill-prefix)
|
|
|
1350 (setq paragraph-ignore-fill-prefix t)
|
|
|
1351 (make-local-variable 'indent-line-function)
|
|
|
1352 (setq indent-line-function 'cperl-indent-line)
|
|
|
1353 (make-local-variable 'require-final-newline)
|
|
|
1354 (setq require-final-newline t)
|
|
|
1355 (make-local-variable 'comment-start)
|
|
|
1356 (setq comment-start "# ")
|
|
|
1357 (make-local-variable 'comment-end)
|
|
|
1358 (setq comment-end "")
|
|
|
1359 (make-local-variable 'comment-column)
|
|
|
1360 (setq comment-column cperl-comment-column)
|
|
|
1361 (make-local-variable 'comment-start-skip)
|
|
|
1362 (setq comment-start-skip "#+ *")
|
|
|
1363 (make-local-variable 'defun-prompt-regexp)
|
|
193
|
1364 (setq defun-prompt-regexp "^[ \t]*sub[ \t]+\\([^ \t\n{(;]+\\)[ \t]*")
|
|
0
|
1365 (make-local-variable 'comment-indent-function)
|
|
|
1366 (setq comment-indent-function 'cperl-comment-indent)
|
|
|
1367 (make-local-variable 'parse-sexp-ignore-comments)
|
|
|
1368 (setq parse-sexp-ignore-comments t)
|
|
|
1369 (make-local-variable 'indent-region-function)
|
|
|
1370 (setq indent-region-function 'cperl-indent-region)
|
|
|
1371 ;;(setq auto-fill-function 'cperl-do-auto-fill) ; Need to switch on and off!
|
|
|
1372 (make-local-variable 'imenu-create-index-function)
|
|
|
1373 (setq imenu-create-index-function
|
|
|
1374 (function imenu-example--create-perl-index))
|
|
|
1375 (make-local-variable 'imenu-sort-function)
|
|
|
1376 (setq imenu-sort-function nil)
|
|
|
1377 (make-local-variable 'vc-header-alist)
|
|
|
1378 (setq vc-header-alist cperl-vc-header-alist)
|
|
|
1379 (make-local-variable 'font-lock-defaults)
|
|
|
1380 (setq font-lock-defaults
|
|
|
1381 (if (string< emacs-version "19.30")
|
|
|
1382 '(perl-font-lock-keywords-2)
|
|
|
1383 '((perl-font-lock-keywords
|
|
|
1384 perl-font-lock-keywords-1
|
|
|
1385 perl-font-lock-keywords-2))))
|
|
193
|
1386 (if cperl-use-syntax-table-text-property
|
|
|
1387 (progn
|
|
|
1388 (make-variable-buffer-local 'parse-sexp-lookup-properties)
|
|
|
1389 ;; Do not introduce variable if not needed, we check it!
|
|
|
1390 (set 'parse-sexp-lookup-properties t)))
|
|
0
|
1391 (or (fboundp 'cperl-old-auto-fill-mode)
|
|
|
1392 (progn
|
|
|
1393 (fset 'cperl-old-auto-fill-mode (symbol-function 'auto-fill-mode))
|
|
|
1394 (defun auto-fill-mode (&optional arg)
|
|
|
1395 (interactive "P")
|
|
|
1396 (cperl-old-auto-fill-mode arg)
|
|
|
1397 (and auto-fill-function (eq major-mode 'perl-mode)
|
|
|
1398 (setq auto-fill-function 'cperl-do-auto-fill)))))
|
|
|
1399 (if (cperl-enable-font-lock)
|
|
|
1400 (if (cperl-val 'cperl-font-lock)
|
|
|
1401 (progn (or cperl-faces-init (cperl-init-faces))
|
|
|
1402 (font-lock-mode 1))))
|
|
|
1403 (and (boundp 'msb-menu-cond)
|
|
|
1404 (not cperl-msb-fixed)
|
|
|
1405 (cperl-msb-fix))
|
|
4
|
1406 (if (featurep 'easymenu)
|
|
|
1407 (easy-menu-add cperl-menu)) ; A NOP under FSF Emacs.
|
|
0
|
1408 (run-hooks 'cperl-mode-hook)
|
|
|
1409 ;; After hooks since fontification will break this
|
|
|
1410 (if cperl-pod-here-scan (cperl-find-pods-heres)))
|
|
|
1411
|
|
4
|
1412 ;; Fix for perldb - make default reasonable
|
|
|
1413 (defun cperl-db ()
|
|
|
1414 (interactive)
|
|
|
1415 (require 'gud)
|
|
|
1416 (perldb (read-from-minibuffer "Run perldb (like this): "
|
|
|
1417 (if (consp gud-perldb-history)
|
|
|
1418 (car gud-perldb-history)
|
|
|
1419 (concat "perl " ;;(file-name-nondirectory
|
|
|
1420 ;; I have problems
|
|
|
1421 ;; in OS/2
|
|
|
1422 ;; otherwise
|
|
|
1423 (buffer-file-name)))
|
|
|
1424 nil nil
|
|
|
1425 '(gud-perldb-history . 1))))
|
|
|
1426
|
|
0
|
1427 ;; Fix for msb.el
|
|
|
1428 (defvar cperl-msb-fixed nil)
|
|
|
1429
|
|
|
1430 (defun cperl-msb-fix ()
|
|
|
1431 ;; Adds perl files to msb menu, supposes that msb is already loaded
|
|
|
1432 (setq cperl-msb-fixed t)
|
|
|
1433 (let* ((l (length msb-menu-cond))
|
|
|
1434 (last (nth (1- l) msb-menu-cond))
|
|
|
1435 (precdr (nthcdr (- l 2) msb-menu-cond)) ; cdr of this is last
|
|
|
1436 (handle (1- (nth 1 last))))
|
|
|
1437 (setcdr precdr (list
|
|
|
1438 (list
|
|
|
1439 '(eq major-mode 'perl-mode)
|
|
|
1440 handle
|
|
|
1441 "Perl Files (%d)")
|
|
|
1442 last))))
|
|
|
1443
|
|
|
1444 ;; This is used by indent-for-comment
|
|
|
1445 ;; to decide how much to indent a comment in CPerl code
|
|
|
1446 ;; based on its context. Do fallback if comment is found wrong.
|
|
|
1447
|
|
|
1448 (defvar cperl-wrong-comment)
|
|
|
1449
|
|
|
1450 (defun cperl-comment-indent ()
|
|
|
1451 (let ((p (point)) (c (current-column)) was)
|
|
|
1452 (if (looking-at "^#") 0 ; Existing comment at bol stays there.
|
|
|
1453 ;; Wrong comment found
|
|
|
1454 (save-excursion
|
|
|
1455 (setq was (cperl-to-comment-or-eol))
|
|
|
1456 (if (= (point) p)
|
|
|
1457 (progn
|
|
|
1458 (skip-chars-backward " \t")
|
|
|
1459 (max (1+ (current-column)) ; Else indent at comment column
|
|
|
1460 comment-column))
|
|
|
1461 (if was nil
|
|
|
1462 (insert comment-start)
|
|
|
1463 (backward-char (length comment-start)))
|
|
|
1464 (setq cperl-wrong-comment t)
|
|
|
1465 (indent-to comment-column 1) ; Indent minimum 1
|
|
|
1466 c))))) ; except leave at least one space.
|
|
|
1467
|
|
|
1468 ;;;(defun cperl-comment-indent-fallback ()
|
|
|
1469 ;;; "Is called if the standard comment-search procedure fails.
|
|
|
1470 ;;;Point is at start of real comment."
|
|
|
1471 ;;; (let ((c (current-column)) target cnt prevc)
|
|
|
1472 ;;; (if (= c comment-column) nil
|
|
|
1473 ;;; (setq cnt (skip-chars-backward "[ \t]"))
|
|
|
1474 ;;; (setq target (max (1+ (setq prevc
|
|
|
1475 ;;; (current-column))) ; Else indent at comment column
|
|
|
1476 ;;; comment-column))
|
|
|
1477 ;;; (if (= c comment-column) nil
|
|
|
1478 ;;; (delete-backward-char cnt)
|
|
|
1479 ;;; (while (< prevc target)
|
|
|
1480 ;;; (insert "\t")
|
|
|
1481 ;;; (setq prevc (current-column)))
|
|
|
1482 ;;; (if (> prevc target) (progn (delete-char -1) (setq prevc (current-column))))
|
|
|
1483 ;;; (while (< prevc target)
|
|
|
1484 ;;; (insert " ")
|
|
|
1485 ;;; (setq prevc (current-column)))))))
|
|
|
1486
|
|
|
1487 (defun cperl-indent-for-comment ()
|
|
4
|
1488 "Substitute for `indent-for-comment' in CPerl."
|
|
0
|
1489 (interactive)
|
|
|
1490 (let (cperl-wrong-comment)
|
|
|
1491 (indent-for-comment)
|
|
|
1492 (if cperl-wrong-comment
|
|
|
1493 (progn (cperl-to-comment-or-eol)
|
|
|
1494 (forward-char (length comment-start))))))
|
|
|
1495
|
|
4
|
1496 (defun cperl-comment-region (b e arg)
|
|
|
1497 "Comment or uncomment each line in the region in CPerl mode.
|
|
|
1498 See `comment-region'."
|
|
|
1499 (interactive "r\np")
|
|
|
1500 (let ((comment-start "#"))
|
|
|
1501 (comment-region b e arg)))
|
|
|
1502
|
|
|
1503 (defun cperl-uncomment-region (b e arg)
|
|
|
1504 "Uncomment or comment each line in the region in CPerl mode.
|
|
|
1505 See `comment-region'."
|
|
|
1506 (interactive "r\np")
|
|
|
1507 (let ((comment-start "#"))
|
|
|
1508 (comment-region b e (- arg))))
|
|
|
1509
|
|
|
1510 (defvar cperl-brace-recursing nil)
|
|
|
1511
|
|
0
|
1512 (defun cperl-electric-brace (arg &optional only-before)
|
|
|
1513 "Insert character and correct line's indentation.
|
|
|
1514 If ONLY-BEFORE and `cperl-auto-newline', will insert newline before the
|
|
|
1515 place (even in empty line), but not after. If after \")\" and the inserted
|
|
|
1516 char is \"{\", insert extra newline before only if
|
|
|
1517 `cperl-extra-newline-before-brace'."
|
|
|
1518 (interactive "P")
|
|
4
|
1519 (let (insertpos
|
|
|
1520 (other-end (if (and cperl-electric-parens-mark
|
|
|
1521 (cperl-mark-active)
|
|
|
1522 (< (mark) (point)))
|
|
|
1523 (mark)
|
|
|
1524 nil)))
|
|
|
1525 (if (and other-end
|
|
|
1526 (not cperl-brace-recursing)
|
|
|
1527 (cperl-val 'cperl-electric-parens)
|
|
|
1528 (>= (save-excursion (cperl-to-comment-or-eol) (point)) (point)))
|
|
|
1529 ;; Need to insert a matching pair
|
|
0
|
1530 (progn
|
|
|
1531 (save-excursion
|
|
4
|
1532 (setq insertpos (point-marker))
|
|
|
1533 (goto-char other-end)
|
|
|
1534 (setq last-command-char ?\{)
|
|
|
1535 (cperl-electric-lbrace arg insertpos))
|
|
|
1536 (forward-char 1))
|
|
|
1537 (if (and (not arg) ; No args, end (of empty line or auto)
|
|
|
1538 (eolp)
|
|
|
1539 (or (and (null only-before)
|
|
|
1540 (save-excursion
|
|
|
1541 (skip-chars-backward " \t")
|
|
|
1542 (bolp)))
|
|
|
1543 (and (eq last-command-char ?\{) ; Do not insert newline
|
|
|
1544 ;; if after ")" and `cperl-extra-newline-before-brace'
|
|
|
1545 ;; is nil, do not insert extra newline.
|
|
|
1546 (not cperl-extra-newline-before-brace)
|
|
|
1547 (save-excursion
|
|
|
1548 (skip-chars-backward " \t")
|
|
|
1549 (eq (preceding-char) ?\))))
|
|
|
1550 (if cperl-auto-newline
|
|
|
1551 (progn (cperl-indent-line) (newline) t) nil)))
|
|
|
1552 (progn
|
|
|
1553 (insert last-command-char)
|
|
|
1554 (cperl-indent-line)
|
|
110
|
1555 (if cperl-auto-newline
|
|
|
1556 (setq insertpos (1- (point))))
|
|
4
|
1557 (if (and cperl-auto-newline (null only-before))
|
|
|
1558 (progn
|
|
|
1559 (newline)
|
|
|
1560 (cperl-indent-line)))
|
|
|
1561 (save-excursion
|
|
|
1562 (if insertpos (progn (goto-char insertpos)
|
|
|
1563 (search-forward (make-string
|
|
|
1564 1 last-command-char))
|
|
|
1565 (setq insertpos (1- (point)))))
|
|
|
1566 (delete-char -1))))
|
|
|
1567 (if insertpos
|
|
|
1568 (save-excursion
|
|
|
1569 (goto-char insertpos)
|
|
|
1570 (self-insert-command (prefix-numeric-value arg)))
|
|
|
1571 (self-insert-command (prefix-numeric-value arg))))))
|
|
|
1572
|
|
|
1573 (defun cperl-electric-lbrace (arg &optional end)
|
|
0
|
1574 "Insert character, correct line's indentation, correct quoting by space."
|
|
|
1575 (interactive "P")
|
|
|
1576 (let (pos after
|
|
4
|
1577 (cperl-brace-recursing t)
|
|
0
|
1578 (cperl-auto-newline cperl-auto-newline)
|
|
4
|
1579 (other-end (or end
|
|
|
1580 (if (and cperl-electric-parens-mark
|
|
|
1581 (cperl-mark-active)
|
|
|
1582 (> (mark) (point)))
|
|
|
1583 (save-excursion
|
|
|
1584 (goto-char (mark))
|
|
|
1585 (point-marker))
|
|
|
1586 nil))))
|
|
0
|
1587 (and (cperl-val 'cperl-electric-lbrace-space)
|
|
|
1588 (eq (preceding-char) ?$)
|
|
|
1589 (save-excursion
|
|
|
1590 (skip-chars-backward "$")
|
|
|
1591 (looking-at "\\(\\$\\$\\)*\\$\\([^\\$]\\|$\\)"))
|
|
|
1592 (insert ? ))
|
|
193
|
1593 (if (cperl-after-expr-p nil "{;)") nil (setq cperl-auto-newline nil))
|
|
0
|
1594 (cperl-electric-brace arg)
|
|
|
1595 (and (cperl-val 'cperl-electric-parens)
|
|
|
1596 (eq last-command-char ?{)
|
|
|
1597 (memq last-command-char
|
|
|
1598 (append cperl-electric-parens-string nil))
|
|
|
1599 (or (if other-end (goto-char (marker-position other-end)))
|
|
|
1600 t)
|
|
|
1601 (setq last-command-char ?} pos (point))
|
|
|
1602 (progn (cperl-electric-brace arg t)
|
|
|
1603 (goto-char pos)))))
|
|
|
1604
|
|
|
1605 (defun cperl-electric-paren (arg)
|
|
|
1606 "Insert a matching pair of parentheses."
|
|
|
1607 (interactive "P")
|
|
|
1608 (let ((beg (save-excursion (beginning-of-line) (point)))
|
|
|
1609 (other-end (if (and cperl-electric-parens-mark
|
|
|
1610 (cperl-mark-active)
|
|
|
1611 (> (mark) (point)))
|
|
|
1612 (save-excursion
|
|
|
1613 (goto-char (mark))
|
|
|
1614 (point-marker))
|
|
|
1615 nil)))
|
|
|
1616 (if (and (cperl-val 'cperl-electric-parens)
|
|
|
1617 (memq last-command-char
|
|
|
1618 (append cperl-electric-parens-string nil))
|
|
|
1619 (>= (save-excursion (cperl-to-comment-or-eol) (point)) (point))
|
|
|
1620 ;;(not (save-excursion (search-backward "#" beg t)))
|
|
|
1621 (if (eq last-command-char ?<)
|
|
193
|
1622 (cperl-after-expr-p nil "{;(,:=")
|
|
0
|
1623 1))
|
|
|
1624 (progn
|
|
|
1625 (insert last-command-char)
|
|
|
1626 (if other-end (goto-char (marker-position other-end)))
|
|
|
1627 (insert (cdr (assoc last-command-char '((?{ .?})
|
|
|
1628 (?[ . ?])
|
|
|
1629 (?( . ?))
|
|
|
1630 (?< . ?>)))))
|
|
|
1631 (forward-char -1))
|
|
|
1632 (insert last-command-char)
|
|
|
1633 )))
|
|
|
1634
|
|
4
|
1635 (defun cperl-electric-rparen (arg)
|
|
|
1636 "Insert a matching pair of parentheses if marking is active.
|
|
|
1637 If not, or if we are not at the end of marking range, would self-insert."
|
|
|
1638 (interactive "P")
|
|
|
1639 (let ((beg (save-excursion (beginning-of-line) (point)))
|
|
|
1640 (other-end (if (and cperl-electric-parens-mark
|
|
110
|
1641 (cperl-val 'cperl-electric-parens)
|
|
|
1642 (memq last-command-char
|
|
|
1643 (append cperl-electric-parens-string nil))
|
|
4
|
1644 (cperl-mark-active)
|
|
|
1645 (< (mark) (point)))
|
|
|
1646 (mark)
|
|
|
1647 nil))
|
|
|
1648 p)
|
|
|
1649 (if (and other-end
|
|
|
1650 (cperl-val 'cperl-electric-parens)
|
|
|
1651 (memq last-command-char '( ?\) ?\] ?\} ?\> ))
|
|
|
1652 (>= (save-excursion (cperl-to-comment-or-eol) (point)) (point))
|
|
|
1653 ;;(not (save-excursion (search-backward "#" beg t)))
|
|
|
1654 )
|
|
|
1655 (progn
|
|
|
1656 (insert last-command-char)
|
|
|
1657 (setq p (point))
|
|
|
1658 (if other-end (goto-char other-end))
|
|
|
1659 (insert (cdr (assoc last-command-char '((?\} . ?\{)
|
|
|
1660 (?\] . ?\[)
|
|
|
1661 (?\) . ?\()
|
|
|
1662 (?\> . ?\<)))))
|
|
|
1663 (goto-char (1+ p)))
|
|
|
1664 (call-interactively 'self-insert-command)
|
|
|
1665 )))
|
|
|
1666
|
|
0
|
1667 (defun cperl-electric-keyword ()
|
|
|
1668 "Insert a construction appropriate after a keyword."
|
|
|
1669 (let ((beg (save-excursion (beginning-of-line) (point)))
|
|
4
|
1670 (dollar (eq last-command-char ?$)))
|
|
0
|
1671 (and (save-excursion
|
|
|
1672 (backward-sexp 1)
|
|
193
|
1673 (cperl-after-expr-p nil "{;:"))
|
|
0
|
1674 (save-excursion
|
|
|
1675 (not
|
|
|
1676 (re-search-backward
|
|
|
1677 "[#\"'`]\\|\\<q\\(\\|[wqx]\\)\\>"
|
|
|
1678 beg t)))
|
|
|
1679 (save-excursion (or (not (re-search-backward "^=" nil t))
|
|
|
1680 (looking-at "=cut")))
|
|
|
1681 (progn
|
|
|
1682 (and dollar (insert " $"))
|
|
|
1683 (cperl-indent-line)
|
|
|
1684 ;;(insert " () {\n}")
|
|
|
1685 (cond
|
|
|
1686 (cperl-extra-newline-before-brace
|
|
|
1687 (insert " ()\n")
|
|
|
1688 (insert "{")
|
|
|
1689 (cperl-indent-line)
|
|
|
1690 (insert "\n")
|
|
|
1691 (cperl-indent-line)
|
|
|
1692 (insert "\n}"))
|
|
|
1693 (t
|
|
|
1694 (insert " () {\n}"))
|
|
|
1695 )
|
|
|
1696 (or (looking-at "[ \t]\\|$") (insert " "))
|
|
|
1697 (cperl-indent-line)
|
|
|
1698 (if dollar (progn (search-backward "$")
|
|
|
1699 (forward-char 1))
|
|
|
1700 (search-backward ")"))
|
|
|
1701 (cperl-putback-char del-back-ch)))))
|
|
|
1702
|
|
|
1703 (defun cperl-electric-else ()
|
|
|
1704 "Insert a construction appropriate after a keyword."
|
|
|
1705 (let ((beg (save-excursion (beginning-of-line) (point))))
|
|
|
1706 (and (save-excursion
|
|
|
1707 (backward-sexp 1)
|
|
193
|
1708 (cperl-after-expr-p nil "{;:"))
|
|
0
|
1709 (save-excursion
|
|
|
1710 (not
|
|
|
1711 (re-search-backward
|
|
|
1712 "[#\"'`]\\|\\<q\\(\\|[wqx]\\)\\>"
|
|
|
1713 beg t)))
|
|
|
1714 (save-excursion (or (not (re-search-backward "^=" nil t))
|
|
|
1715 (looking-at "=cut")))
|
|
|
1716 (progn
|
|
|
1717 (cperl-indent-line)
|
|
|
1718 ;;(insert " {\n\n}")
|
|
|
1719 (cond
|
|
|
1720 (cperl-extra-newline-before-brace
|
|
|
1721 (insert "\n")
|
|
|
1722 (insert "{")
|
|
|
1723 (cperl-indent-line)
|
|
|
1724 (insert "\n\n}"))
|
|
|
1725 (t
|
|
|
1726 (insert " {\n\n}"))
|
|
|
1727 )
|
|
|
1728 (or (looking-at "[ \t]\\|$") (insert " "))
|
|
|
1729 (cperl-indent-line)
|
|
|
1730 (forward-line -1)
|
|
|
1731 (cperl-indent-line)
|
|
|
1732 (cperl-putback-char del-back-ch)))))
|
|
|
1733
|
|
|
1734 (defun cperl-linefeed ()
|
|
|
1735 "Go to end of line, open a new line and indent appropriately."
|
|
|
1736 (interactive)
|
|
|
1737 (let ((beg (save-excursion (beginning-of-line) (point)))
|
|
|
1738 (end (save-excursion (end-of-line) (point)))
|
|
|
1739 (pos (point)) start)
|
|
|
1740 (if (and ; Check if we need to split:
|
|
|
1741 ; i.e., on a boundary and inside "{...}"
|
|
|
1742 (save-excursion (cperl-to-comment-or-eol)
|
|
4
|
1743 (>= (point) pos)) ; Not in a comment
|
|
0
|
1744 (or (save-excursion
|
|
|
1745 (skip-chars-backward " \t" beg)
|
|
|
1746 (forward-char -1)
|
|
4
|
1747 (looking-at "[;{]")) ; After { or ; + spaces
|
|
|
1748 (looking-at "[ \t]*}") ; Before }
|
|
|
1749 (re-search-forward "\\=[ \t]*;" end t)) ; Before spaces + ;
|
|
0
|
1750 (save-excursion
|
|
|
1751 (and
|
|
4
|
1752 (eq (car (parse-partial-sexp pos end -1)) -1)
|
|
|
1753 ; Leave the level of parens
|
|
0
|
1754 (looking-at "[,; \t]*\\($\\|#\\)") ; Comma to allow anon subr
|
|
4
|
1755 ; Are at end
|
|
0
|
1756 (progn
|
|
|
1757 (backward-sexp 1)
|
|
|
1758 (setq start (point-marker))
|
|
4
|
1759 (<= start pos))))) ; Redundant? Are after the
|
|
|
1760 ; start of parens group.
|
|
0
|
1761 (progn
|
|
|
1762 (skip-chars-backward " \t")
|
|
|
1763 (or (memq (preceding-char) (append ";{" nil))
|
|
|
1764 (insert ";"))
|
|
|
1765 (insert "\n")
|
|
|
1766 (forward-line -1)
|
|
|
1767 (cperl-indent-line)
|
|
|
1768 (goto-char start)
|
|
|
1769 (or (looking-at "{[ \t]*$") ; If there is a statement
|
|
|
1770 ; before, move it to separate line
|
|
|
1771 (progn
|
|
|
1772 (forward-char 1)
|
|
|
1773 (insert "\n")
|
|
|
1774 (cperl-indent-line)))
|
|
|
1775 (forward-line 1) ; We are on the target line
|
|
|
1776 (cperl-indent-line)
|
|
|
1777 (beginning-of-line)
|
|
|
1778 (or (looking-at "[ \t]*}[,; \t]*$") ; If there is a statement
|
|
|
1779 ; after, move it to separate line
|
|
|
1780 (progn
|
|
|
1781 (end-of-line)
|
|
|
1782 (search-backward "}" beg)
|
|
|
1783 (skip-chars-backward " \t")
|
|
|
1784 (or (memq (preceding-char) (append ";{" nil))
|
|
|
1785 (insert ";"))
|
|
|
1786 (insert "\n")
|
|
|
1787 (cperl-indent-line)
|
|
|
1788 (forward-line -1)))
|
|
|
1789 (forward-line -1) ; We are on the line before target
|
|
|
1790 (end-of-line)
|
|
|
1791 (newline-and-indent))
|
|
|
1792 (end-of-line) ; else
|
|
4
|
1793 (cond
|
|
|
1794 ((and (looking-at "\n[ \t]*{$")
|
|
|
1795 (save-excursion
|
|
|
1796 (skip-chars-backward " \t")
|
|
|
1797 (eq (preceding-char) ?\)))) ; Probably if () {} group
|
|
|
1798 ; with an extra newline.
|
|
|
1799 (forward-line 2)
|
|
|
1800 (cperl-indent-line))
|
|
|
1801 ((looking-at "\n[ \t]*$") ; Next line is empty - use it.
|
|
|
1802 (forward-line 1)
|
|
|
1803 (cperl-indent-line))
|
|
|
1804 (t
|
|
|
1805 (newline-and-indent))))))
|
|
0
|
1806
|
|
|
1807 (defun cperl-electric-semi (arg)
|
|
|
1808 "Insert character and correct line's indentation."
|
|
|
1809 (interactive "P")
|
|
|
1810 (if cperl-auto-newline
|
|
|
1811 (cperl-electric-terminator arg)
|
|
|
1812 (self-insert-command (prefix-numeric-value arg))))
|
|
|
1813
|
|
|
1814 (defun cperl-electric-terminator (arg)
|
|
|
1815 "Insert character and correct line's indentation."
|
|
|
1816 (interactive "P")
|
|
|
1817 (let (insertpos (end (point))
|
|
|
1818 (auto (and cperl-auto-newline
|
|
|
1819 (or (not (eq last-command-char ?:))
|
|
|
1820 cperl-auto-newline-after-colon))))
|
|
4
|
1821 (if (and ;;(not arg)
|
|
|
1822 (eolp)
|
|
0
|
1823 (not (save-excursion
|
|
|
1824 (beginning-of-line)
|
|
|
1825 (skip-chars-forward " \t")
|
|
|
1826 (or
|
|
|
1827 ;; Ignore in comment lines
|
|
|
1828 (= (following-char) ?#)
|
|
|
1829 ;; Colon is special only after a label
|
|
|
1830 ;; So quickly rule out most other uses of colon
|
|
|
1831 ;; and do no indentation for them.
|
|
|
1832 (and (eq last-command-char ?:)
|
|
|
1833 (save-excursion
|
|
|
1834 (forward-word 1)
|
|
|
1835 (skip-chars-forward " \t")
|
|
|
1836 (and (< (point) end)
|
|
|
1837 (progn (goto-char (- end 1))
|
|
|
1838 (not (looking-at ":"))))))
|
|
|
1839 (progn
|
|
|
1840 (beginning-of-defun)
|
|
|
1841 (let ((pps (parse-partial-sexp (point) end)))
|
|
|
1842 (or (nth 3 pps) (nth 4 pps) (nth 5 pps))))))))
|
|
|
1843 (progn
|
|
|
1844 (insert last-command-char)
|
|
4
|
1845 ;;(forward-char -1)
|
|
0
|
1846 (if auto (setq insertpos (point-marker)))
|
|
4
|
1847 ;;(forward-char 1)
|
|
0
|
1848 (cperl-indent-line)
|
|
|
1849 (if auto
|
|
|
1850 (progn
|
|
|
1851 (newline)
|
|
|
1852 (cperl-indent-line)))
|
|
|
1853 ;; (save-excursion
|
|
|
1854 ;; (if insertpos (progn (goto-char (marker-position insertpos))
|
|
|
1855 ;; (search-forward (make-string
|
|
|
1856 ;; 1 last-command-char))
|
|
|
1857 ;; (setq insertpos (1- (point)))))
|
|
|
1858 ;; (delete-char -1))))
|
|
|
1859 (save-excursion
|
|
4
|
1860 (if insertpos (goto-char (1- (marker-position insertpos)))
|
|
0
|
1861 (forward-char -1))
|
|
|
1862 (delete-char 1))))
|
|
|
1863 (if insertpos
|
|
|
1864 (save-excursion
|
|
|
1865 (goto-char insertpos)
|
|
|
1866 (self-insert-command (prefix-numeric-value arg)))
|
|
|
1867 (self-insert-command (prefix-numeric-value arg)))))
|
|
|
1868
|
|
|
1869 (defun cperl-electric-backspace (arg)
|
|
|
1870 "Backspace-untabify, or remove the whitespace inserted by an electric key."
|
|
193
|
1871 (interactive "p")
|
|
161
|
1872 (if (and cperl-auto-newline
|
|
|
1873 (memq last-command '(cperl-electric-semi
|
|
|
1874 cperl-electric-terminator
|
|
|
1875 cperl-electric-lbrace))
|
|
|
1876 (memq (preceding-char) '(? ?\t ?\n)))
|
|
|
1877 (let (p)
|
|
|
1878 (if (eq last-command 'cperl-electric-lbrace)
|
|
|
1879 (skip-chars-forward " \t\n"))
|
|
|
1880 (setq p (point))
|
|
|
1881 (skip-chars-backward " \t\n")
|
|
|
1882 (delete-region (point) p))
|
|
|
1883 (backward-delete-char-untabify arg)))
|
|
|
1884
|
|
167
|
1885 ;; helper function for deletion, which honors the desired delete direction
|
|
|
1886 ;; behavior. Added by Gary D. Foster, <Gary.Foster@corp.sun.com> and bound
|
|
|
1887 ;; to the 'delete keysym by default.
|
|
|
1888
|
|
161
|
1889 (defun cperl-electric-delete (arg)
|
|
167
|
1890 "Delete, or remove the whitespace inserted by an electric key.
|
|
|
1891 Delete direction is controlled by the setting of `delete-key-deletes-forward'."
|
|
161
|
1892 (interactive "*p")
|
|
0
|
1893 (if (and cperl-auto-newline
|
|
|
1894 (memq last-command '(cperl-electric-semi
|
|
|
1895 cperl-electric-terminator
|
|
|
1896 cperl-electric-lbrace))
|
|
|
1897 (memq (preceding-char) '(? ?\t ?\n)))
|
|
|
1898 (let (p)
|
|
|
1899 (if (eq last-command 'cperl-electric-lbrace)
|
|
|
1900 (skip-chars-forward " \t\n"))
|
|
|
1901 (setq p (point))
|
|
|
1902 (skip-chars-backward " \t\n")
|
|
|
1903 (delete-region (point) p))
|
|
159
|
1904 (if (fboundp 'backward-or-forward-delete-char)
|
|
161
|
1905 (backward-or-forward-delete-char arg)
|
|
|
1906 (backward-delete-char-untabify arg))))
|
|
0
|
1907
|
|
|
1908 (defun cperl-inside-parens-p ()
|
|
|
1909 (condition-case ()
|
|
|
1910 (save-excursion
|
|
|
1911 (save-restriction
|
|
|
1912 (narrow-to-region (point)
|
|
|
1913 (progn (beginning-of-defun) (point)))
|
|
|
1914 (goto-char (point-max))
|
|
|
1915 (= (char-after (or (scan-lists (point) -1 1) (point-min))) ?\()))
|
|
|
1916 (error nil)))
|
|
|
1917
|
|
|
1918 (defun cperl-indent-command (&optional whole-exp)
|
|
|
1919 "Indent current line as Perl code, or in some cases insert a tab character.
|
|
|
1920 If `cperl-tab-always-indent' is non-nil (the default), always indent current line.
|
|
|
1921 Otherwise, indent the current line only if point is at the left margin
|
|
|
1922 or in the line's indentation; otherwise insert a tab.
|
|
|
1923
|
|
|
1924 A numeric argument, regardless of its value,
|
|
|
1925 means indent rigidly all the lines of the expression starting after point
|
|
|
1926 so that this line becomes properly indented.
|
|
|
1927 The relative indentation among the lines of the expression are preserved."
|
|
4
|
1928 (interactive "P")
|
|
0
|
1929 (if whole-exp
|
|
|
1930 ;; If arg, always indent this line as Perl
|
|
|
1931 ;; and shift remaining lines of expression the same amount.
|
|
|
1932 (let ((shift-amt (cperl-indent-line))
|
|
|
1933 beg end)
|
|
|
1934 (save-excursion
|
|
|
1935 (if cperl-tab-always-indent
|
|
|
1936 (beginning-of-line))
|
|
|
1937 (setq beg (point))
|
|
|
1938 (forward-sexp 1)
|
|
|
1939 (setq end (point))
|
|
|
1940 (goto-char beg)
|
|
|
1941 (forward-line 1)
|
|
|
1942 (setq beg (point)))
|
|
|
1943 (if (> end beg)
|
|
|
1944 (indent-code-rigidly beg end shift-amt "#")))
|
|
|
1945 (if (and (not cperl-tab-always-indent)
|
|
|
1946 (save-excursion
|
|
|
1947 (skip-chars-backward " \t")
|
|
|
1948 (not (bolp))))
|
|
|
1949 (insert-tab)
|
|
|
1950 (cperl-indent-line))))
|
|
|
1951
|
|
|
1952 (defun cperl-indent-line (&optional symbol)
|
|
|
1953 "Indent current line as Perl code.
|
|
|
1954 Return the amount the indentation changed by."
|
|
|
1955 (let (indent
|
|
|
1956 beg shift-amt
|
|
|
1957 (case-fold-search nil)
|
|
|
1958 (pos (- (point-max) (point))))
|
|
|
1959 (setq indent (cperl-calculate-indent nil symbol))
|
|
|
1960 (beginning-of-line)
|
|
|
1961 (setq beg (point))
|
|
193
|
1962 (cond ((or (eq indent nil) (eq indent t))
|
|
0
|
1963 (setq indent (current-indentation)))
|
|
|
1964 ;;((eq indent t) ; Never?
|
|
|
1965 ;; (setq indent (cperl-calculate-indent-within-comment)))
|
|
|
1966 ;;((looking-at "[ \t]*#")
|
|
|
1967 ;; (setq indent 0))
|
|
|
1968 (t
|
|
|
1969 (skip-chars-forward " \t")
|
|
|
1970 (if (listp indent) (setq indent (car indent)))
|
|
193
|
1971 (cond ((looking-at "[A-Za-z_][A-Za-z_0-9]*:[^:]")
|
|
0
|
1972 (and (> indent 0)
|
|
|
1973 (setq indent (max cperl-min-label-indent
|
|
|
1974 (+ indent cperl-label-offset)))))
|
|
|
1975 ((= (following-char) ?})
|
|
|
1976 (setq indent (- indent cperl-indent-level)))
|
|
|
1977 ((memq (following-char) '(?\) ?\])) ; To line up with opening paren.
|
|
|
1978 (setq indent (+ indent cperl-close-paren-offset)))
|
|
|
1979 ((= (following-char) ?{)
|
|
|
1980 (setq indent (+ indent cperl-brace-offset))))))
|
|
|
1981 (skip-chars-forward " \t")
|
|
|
1982 (setq shift-amt (- indent (current-column)))
|
|
|
1983 (if (zerop shift-amt)
|
|
|
1984 (if (> (- (point-max) pos) (point))
|
|
|
1985 (goto-char (- (point-max) pos)))
|
|
|
1986 (delete-region beg (point))
|
|
|
1987 (indent-to indent)
|
|
|
1988 ;; If initial point was within line's indentation,
|
|
|
1989 ;; position after the indentation. Else stay at same point in text.
|
|
|
1990 (if (> (- (point-max) pos) (point))
|
|
|
1991 (goto-char (- (point-max) pos))))
|
|
|
1992 shift-amt))
|
|
|
1993
|
|
|
1994 (defun cperl-after-label ()
|
|
|
1995 ;; Returns true if the point is after label. Does not do save-excursion.
|
|
|
1996 (and (eq (preceding-char) ?:)
|
|
|
1997 (memq (char-syntax (char-after (- (point) 2)))
|
|
|
1998 '(?w ?_))
|
|
|
1999 (progn
|
|
|
2000 (backward-sexp)
|
|
4
|
2001 (looking-at "[a-zA-Z_][a-zA-Z0-9_]*:[^:]"))))
|
|
0
|
2002
|
|
|
2003 (defun cperl-get-state (&optional parse-start start-state)
|
|
|
2004 ;; returns list (START STATE DEPTH PRESTART), START is a good place
|
|
|
2005 ;; to start parsing, STATE is what is returned by
|
|
|
2006 ;; `parse-partial-sexp'. DEPTH is true is we are immediately after
|
|
|
2007 ;; end of block which contains START. PRESTART is the position
|
|
|
2008 ;; basing on which START was found.
|
|
|
2009 (save-excursion
|
|
|
2010 (let ((start-point (point)) depth state start prestart)
|
|
|
2011 (if parse-start
|
|
|
2012 (goto-char parse-start)
|
|
|
2013 (beginning-of-defun))
|
|
|
2014 (setq prestart (point))
|
|
|
2015 (if start-state nil
|
|
|
2016 ;; Try to go out, if sub is not on the outermost level
|
|
|
2017 (while (< (point) start-point)
|
|
|
2018 (setq start (point) parse-start start depth nil
|
|
|
2019 state (parse-partial-sexp start start-point -1))
|
|
|
2020 (if (> (car state) -1) nil
|
|
|
2021 ;; The current line could start like }}}, so the indentation
|
|
|
2022 ;; corresponds to a different level than what we reached
|
|
|
2023 (setq depth t)
|
|
|
2024 (beginning-of-line 2))) ; Go to the next line.
|
|
|
2025 (if start (goto-char start))) ; Not at the start of file
|
|
|
2026 (setq start (point))
|
|
|
2027 (if (< start start-point) (setq parse-start start))
|
|
|
2028 (or state (setq state (parse-partial-sexp start start-point -1 nil start-state)))
|
|
|
2029 (list start state depth prestart))))
|
|
|
2030
|
|
|
2031 (defun cperl-block-p () ; Do not C-M-q ! One string contains ";" !
|
|
|
2032 ;; Positions is before ?\{. Checks whether it starts a block.
|
|
|
2033 ;; No save-excursion!
|
|
|
2034 (cperl-backward-to-noncomment (point-min))
|
|
|
2035 ;;(skip-chars-backward " \t\n\f")
|
|
|
2036 (or (memq (preceding-char) (append ";){}$@&%\C-@" nil)) ; Or label! \C-@ at bobp
|
|
|
2037 ; Label may be mixed up with `$blah :'
|
|
|
2038 (save-excursion (cperl-after-label))
|
|
4
|
2039 (and (memq (char-syntax (preceding-char)) '(?w ?_))
|
|
0
|
2040 (progn
|
|
|
2041 (backward-sexp)
|
|
|
2042 ;; Need take into account `bless', `return', `tr',...
|
|
4
|
2043 (or (and (looking-at "[a-zA-Z0-9_:]+[ \t\n\f]*[{#]") ; Method call syntax
|
|
0
|
2044 (not (looking-at "\\(bless\\|return\\|qw\\|tr\\|[smy]\\)\\>")))
|
|
|
2045 (progn
|
|
|
2046 (skip-chars-backward " \t\n\f")
|
|
4
|
2047 (and (memq (char-syntax (preceding-char)) '(?w ?_))
|
|
0
|
2048 (progn
|
|
|
2049 (backward-sexp)
|
|
|
2050 (looking-at
|
|
193
|
2051 "sub[ \t]+[a-zA-Z0-9_:]+[ \t\n\f]*\\(([^()]*)[ \t\n\f]*\\)?[#{]")))))))))
|
|
|
2052
|
|
|
2053 (defvar cperl-look-for-prop '((pod in-pod) (here-doc-delim here-doc-group)))
|
|
0
|
2054
|
|
|
2055 (defun cperl-calculate-indent (&optional parse-start symbol)
|
|
|
2056 "Return appropriate indentation for current line as Perl code.
|
|
|
2057 In usual case returns an integer: the column to indent to.
|
|
|
2058 Returns nil if line starts inside a string, t if in a comment."
|
|
|
2059 (save-excursion
|
|
193
|
2060 (if (or
|
|
|
2061 (memq (get-text-property (point) 'syntax-type)
|
|
|
2062 '(pod here-doc here-doc-delim format))
|
|
|
2063 ;; before start of POD - whitespace found since do not have 'pod!
|
|
|
2064 (and (looking-at "[ \t]*\n=")
|
|
|
2065 (error "Spaces before pod section!"))
|
|
|
2066 (and (not cperl-indent-left-aligned-comments)
|
|
|
2067 (looking-at "^#")))
|
|
|
2068 nil
|
|
|
2069 (beginning-of-line)
|
|
|
2070 (let ((indent-point (point))
|
|
|
2071 (char-after (save-excursion
|
|
|
2072 (skip-chars-forward " \t")
|
|
|
2073 (following-char)))
|
|
|
2074 (in-pod (get-text-property (point) 'in-pod))
|
|
|
2075 (pre-indent-point (point))
|
|
|
2076 p prop look-prop)
|
|
|
2077 (cond
|
|
|
2078 (in-pod
|
|
|
2079 ;; In the verbatim part, probably code example. What to do???
|
|
|
2080 )
|
|
|
2081 (t
|
|
|
2082 (save-excursion
|
|
|
2083 ;; Not in pod
|
|
|
2084 (cperl-backward-to-noncomment nil)
|
|
|
2085 (setq p (max (point-min) (1- (point)))
|
|
|
2086 prop (get-text-property p 'syntax-type)
|
|
|
2087 look-prop (or (nth 1 (assoc prop cperl-look-for-prop))
|
|
|
2088 'syntax-type))
|
|
|
2089 (if (memq prop '(pod here-doc format here-doc-delim))
|
|
|
2090 (progn
|
|
|
2091 (goto-char (or (previous-single-property-change p look-prop)
|
|
|
2092 (point-min)))
|
|
|
2093 (beginning-of-line)
|
|
|
2094 (setq pre-indent-point (point)))))))
|
|
|
2095 (goto-char pre-indent-point)
|
|
|
2096 (let* ((case-fold-search nil)
|
|
0
|
2097 (s-s (cperl-get-state))
|
|
|
2098 (start (nth 0 s-s))
|
|
|
2099 (state (nth 1 s-s))
|
|
|
2100 (containing-sexp (car (cdr state)))
|
|
|
2101 (start-indent (save-excursion
|
|
|
2102 (goto-char start)
|
|
|
2103 (- (current-indentation)
|
|
|
2104 (if (nth 2 s-s) cperl-indent-level 0))))
|
|
|
2105 old-indent)
|
|
|
2106 ;; (or parse-start (null symbol)
|
|
|
2107 ;; (setq parse-start (symbol-value symbol)
|
|
|
2108 ;; start-indent (nth 2 parse-start)
|
|
|
2109 ;; parse-start (car parse-start)))
|
|
|
2110 ;; (if parse-start
|
|
|
2111 ;; (goto-char parse-start)
|
|
|
2112 ;; (beginning-of-defun))
|
|
|
2113 ;; ;; Try to go out
|
|
|
2114 ;; (while (< (point) indent-point)
|
|
|
2115 ;; (setq start (point) parse-start start moved nil
|
|
|
2116 ;; state (parse-partial-sexp start indent-point -1))
|
|
|
2117 ;; (if (> (car state) -1) nil
|
|
|
2118 ;; ;; The current line could start like }}}, so the indentation
|
|
|
2119 ;; ;; corresponds to a different level than what we reached
|
|
|
2120 ;; (setq moved t)
|
|
|
2121 ;; (beginning-of-line 2))) ; Go to the next line.
|
|
|
2122 ;; (if start ; Not at the start of file
|
|
|
2123 ;; (progn
|
|
|
2124 ;; (goto-char start)
|
|
|
2125 ;; (setq start-indent (current-indentation))
|
|
|
2126 ;; (if moved ; Should correct...
|
|
|
2127 ;; (setq start-indent (- start-indent cperl-indent-level))))
|
|
|
2128 ;; (setq start-indent 0))
|
|
|
2129 ;; (if (< (point) indent-point) (setq parse-start (point)))
|
|
|
2130 ;; (or state (setq state (parse-partial-sexp
|
|
|
2131 ;; (point) indent-point -1 nil start-state)))
|
|
|
2132 ;; (setq containing-sexp
|
|
|
2133 ;; (or (car (cdr state))
|
|
|
2134 ;; (and (>= (nth 6 state) 0) old-containing-sexp))
|
|
|
2135 ;; old-containing-sexp nil start-state nil)
|
|
|
2136 ;;;; (while (< (point) indent-point)
|
|
|
2137 ;;;; (setq parse-start (point))
|
|
|
2138 ;;;; (setq state (parse-partial-sexp (point) indent-point -1 nil start-state))
|
|
|
2139 ;;;; (setq containing-sexp
|
|
|
2140 ;;;; (or (car (cdr state))
|
|
|
2141 ;;;; (and (>= (nth 6 state) 0) old-containing-sexp))
|
|
|
2142 ;;;; old-containing-sexp nil start-state nil))
|
|
|
2143 ;; (if symbol (set symbol (list indent-point state start-indent)))
|
|
|
2144 ;; (goto-char indent-point)
|
|
|
2145 (cond ((or (nth 3 state) (nth 4 state))
|
|
|
2146 ;; return nil or t if should not change this line
|
|
|
2147 (nth 4 state))
|
|
|
2148 ((null containing-sexp)
|
|
|
2149 ;; Line is at top level. May be data or function definition,
|
|
|
2150 ;; or may be function argument declaration.
|
|
|
2151 ;; Indent like the previous top level line
|
|
|
2152 ;; unless that ends in a closeparen without semicolon,
|
|
|
2153 ;; in which case this line is the first argument decl.
|
|
|
2154 (skip-chars-forward " \t")
|
|
|
2155 (+ start-indent
|
|
|
2156 (if (= (following-char) ?{) cperl-continued-brace-offset 0)
|
|
|
2157 (progn
|
|
|
2158 (cperl-backward-to-noncomment (or parse-start (point-min)))
|
|
|
2159 ;;(skip-chars-backward " \t\f\n")
|
|
|
2160 ;; Look at previous line that's at column 0
|
|
|
2161 ;; to determine whether we are in top-level decls
|
|
|
2162 ;; or function's arg decls. Set basic-indent accordingly.
|
|
|
2163 ;; Now add a little if this is a continuation line.
|
|
|
2164 (if (or (bobp)
|
|
|
2165 (memq (preceding-char) (append " ;}" nil)) ; Was ?\)
|
|
4
|
2166 (memq char-after (append ")]}" nil))
|
|
|
2167 (and (eq (preceding-char) ?\:) ; label
|
|
|
2168 (progn
|
|
|
2169 (forward-sexp -1)
|
|
|
2170 (skip-chars-backward " \t")
|
|
|
2171 (looking-at "[ \t]*[a-zA-Z_][a-zA-Z_0-9]*[ \t]*:"))))
|
|
0
|
2172 0
|
|
|
2173 cperl-continued-statement-offset))))
|
|
|
2174 ((/= (char-after containing-sexp) ?{)
|
|
|
2175 ;; line is expression, not statement:
|
|
|
2176 ;; indent to just after the surrounding open,
|
|
|
2177 ;; skip blanks if we do not close the expression.
|
|
|
2178 (goto-char (1+ containing-sexp))
|
|
|
2179 (or (memq char-after (append ")]}" nil))
|
|
|
2180 (looking-at "[ \t]*\\(#\\|$\\)")
|
|
|
2181 (skip-chars-forward " \t"))
|
|
|
2182 (current-column))
|
|
|
2183 ((progn
|
|
|
2184 ;; Containing-expr starts with \{. Check whether it is a hash.
|
|
|
2185 (goto-char containing-sexp)
|
|
|
2186 (not (cperl-block-p)))
|
|
|
2187 (goto-char (1+ containing-sexp))
|
|
|
2188 (or (eq char-after ?\})
|
|
|
2189 (looking-at "[ \t]*\\(#\\|$\\)")
|
|
|
2190 (skip-chars-forward " \t"))
|
|
|
2191 (+ (current-column) ; Correct indentation of trailing ?\}
|
|
|
2192 (if (eq char-after ?\}) (+ cperl-indent-level
|
|
|
2193 cperl-close-paren-offset)
|
|
|
2194 0)))
|
|
|
2195 (t
|
|
|
2196 ;; Statement level. Is it a continuation or a new statement?
|
|
|
2197 ;; Find previous non-comment character.
|
|
193
|
2198 (goto-char pre-indent-point)
|
|
0
|
2199 (cperl-backward-to-noncomment containing-sexp)
|
|
|
2200 ;; Back up over label lines, since they don't
|
|
|
2201 ;; affect whether our line is a continuation.
|
|
|
2202 (while (or (eq (preceding-char) ?\,)
|
|
|
2203 (and (eq (preceding-char) ?:)
|
|
|
2204 (or;;(eq (char-after (- (point) 2)) ?\') ; ????
|
|
|
2205 (memq (char-syntax (char-after (- (point) 2)))
|
|
|
2206 '(?w ?_)))))
|
|
|
2207 (if (eq (preceding-char) ?\,)
|
|
|
2208 ;; Will go to beginning of line, essentially.
|
|
|
2209 ;; Will ignore embedded sexpr XXXX.
|
|
|
2210 (cperl-backward-to-start-of-continued-exp containing-sexp))
|
|
|
2211 (beginning-of-line)
|
|
|
2212 (cperl-backward-to-noncomment containing-sexp))
|
|
|
2213 ;; Now we get the answer.
|
|
|
2214 (if (not (memq (preceding-char) (append ", ;}{" '(nil)))) ; Was ?\,
|
|
|
2215 ;; This line is continuation of preceding line's statement;
|
|
|
2216 ;; indent `cperl-continued-statement-offset' more than the
|
|
|
2217 ;; previous line of the statement.
|
|
|
2218 (progn
|
|
|
2219 (cperl-backward-to-start-of-continued-exp containing-sexp)
|
|
|
2220 (+ (if (memq char-after (append "}])" nil))
|
|
|
2221 0 ; Closing parenth
|
|
|
2222 cperl-continued-statement-offset)
|
|
|
2223 (current-column)
|
|
|
2224 (if (eq char-after ?\{)
|
|
|
2225 cperl-continued-brace-offset 0)))
|
|
|
2226 ;; This line starts a new statement.
|
|
|
2227 ;; Position following last unclosed open.
|
|
|
2228 (goto-char containing-sexp)
|
|
|
2229 ;; Is line first statement after an open-brace?
|
|
|
2230 (or
|
|
|
2231 ;; If no, find that first statement and indent like
|
|
|
2232 ;; it. If the first statement begins with label, do
|
|
4
|
2233 ;; not believe when the indentation of the label is too
|
|
0
|
2234 ;; small.
|
|
|
2235 (save-excursion
|
|
|
2236 (forward-char 1)
|
|
|
2237 (setq old-indent (current-indentation))
|
|
|
2238 (let ((colon-line-end 0))
|
|
|
2239 (while (progn (skip-chars-forward " \t\n")
|
|
|
2240 (looking-at "#\\|[a-zA-Z0-9_$]*:[^:]"))
|
|
|
2241 ;; Skip over comments and labels following openbrace.
|
|
|
2242 (cond ((= (following-char) ?\#)
|
|
|
2243 (forward-line 1))
|
|
|
2244 ;; label:
|
|
|
2245 (t
|
|
|
2246 (save-excursion (end-of-line)
|
|
|
2247 (setq colon-line-end (point)))
|
|
|
2248 (search-forward ":"))))
|
|
|
2249 ;; The first following code counts
|
|
|
2250 ;; if it is before the line we want to indent.
|
|
|
2251 (and (< (point) indent-point)
|
|
|
2252 (if (> colon-line-end (point)) ; After label
|
|
|
2253 (if (> (current-indentation)
|
|
|
2254 cperl-min-label-indent)
|
|
|
2255 (- (current-indentation) cperl-label-offset)
|
|
4
|
2256 ;; Do not believe: `max' is involved
|
|
0
|
2257 (+ old-indent cperl-indent-level))
|
|
|
2258 (current-column)))))
|
|
|
2259 ;; If no previous statement,
|
|
|
2260 ;; indent it relative to line brace is on.
|
|
|
2261 ;; For open brace in column zero, don't let statement
|
|
|
2262 ;; start there too. If cperl-indent-level is zero,
|
|
|
2263 ;; use cperl-brace-offset + cperl-continued-statement-offset instead.
|
|
|
2264 ;; For open-braces not the first thing in a line,
|
|
|
2265 ;; add in cperl-brace-imaginary-offset.
|
|
|
2266
|
|
|
2267 ;; If first thing on a line: ?????
|
|
|
2268 (+ (if (and (bolp) (zerop cperl-indent-level))
|
|
|
2269 (+ cperl-brace-offset cperl-continued-statement-offset)
|
|
|
2270 cperl-indent-level)
|
|
|
2271 ;; Move back over whitespace before the openbrace.
|
|
|
2272 ;; If openbrace is not first nonwhite thing on the line,
|
|
|
2273 ;; add the cperl-brace-imaginary-offset.
|
|
|
2274 (progn (skip-chars-backward " \t")
|
|
|
2275 (if (bolp) 0 cperl-brace-imaginary-offset))
|
|
|
2276 ;; If the openbrace is preceded by a parenthesized exp,
|
|
|
2277 ;; move to the beginning of that;
|
|
|
2278 ;; possibly a different line
|
|
|
2279 (progn
|
|
|
2280 (if (eq (preceding-char) ?\))
|
|
|
2281 (forward-sexp -1))
|
|
|
2282 ;; In the case it starts a subroutine, indent with
|
|
4
|
2283 ;; respect to `sub', not with respect to the the
|
|
0
|
2284 ;; first thing on the line, say in the case of
|
|
|
2285 ;; anonymous sub in a hash.
|
|
|
2286 ;;
|
|
|
2287 (skip-chars-backward " \t")
|
|
|
2288 (if (and (eq (preceding-char) ?b)
|
|
|
2289 (progn
|
|
193
|
2290 (forward-sexp -1)
|
|
0
|
2291 (looking-at "sub\\>"))
|
|
|
2292 (setq old-indent
|
|
|
2293 (nth 1
|
|
|
2294 (parse-partial-sexp
|
|
|
2295 (save-excursion (beginning-of-line) (point))
|
|
|
2296 (point)))))
|
|
|
2297 (progn (goto-char (1+ old-indent))
|
|
|
2298 (skip-chars-forward " \t")
|
|
|
2299 (current-column))
|
|
|
2300 ;; Get initial indentation of the line we are on.
|
|
|
2301 ;; If line starts with label, calculate label indentation
|
|
|
2302 (if (save-excursion
|
|
|
2303 (beginning-of-line)
|
|
193
|
2304 (looking-at "[ \t]*[a-zA-Z_][a-zA-Z_0-9]*:[^:]"))
|
|
0
|
2305 (if (> (current-indentation) cperl-min-label-indent)
|
|
|
2306 (- (current-indentation) cperl-label-offset)
|
|
|
2307 (cperl-calculate-indent
|
|
|
2308 (if (and parse-start (<= parse-start (point)))
|
|
|
2309 parse-start)))
|
|
193
|
2310 (current-indentation))))))))))))))
|
|
0
|
2311
|
|
|
2312 (defvar cperl-indent-alist
|
|
|
2313 '((string nil)
|
|
|
2314 (comment nil)
|
|
|
2315 (toplevel 0)
|
|
|
2316 (toplevel-after-parenth 2)
|
|
|
2317 (toplevel-continued 2)
|
|
|
2318 (expression 1))
|
|
|
2319 "Alist of indentation rules for CPerl mode.
|
|
|
2320 The values mean:
|
|
|
2321 nil: do not indent;
|
|
|
2322 number: add this amount of indentation.")
|
|
|
2323
|
|
|
2324 (defun cperl-where-am-i (&optional parse-start start-state)
|
|
|
2325 ;; Unfinished
|
|
|
2326 "Return a list of lists ((TYPE POS)...) of good points before the point.
|
|
|
2327 POS may be nil if it is hard to find, say, when TYPE is `string' or `comment'."
|
|
|
2328 (save-excursion
|
|
|
2329 (let* ((start-point (point))
|
|
|
2330 (s-s (cperl-get-state))
|
|
|
2331 (start (nth 0 s-s))
|
|
|
2332 (state (nth 1 s-s))
|
|
|
2333 (prestart (nth 3 s-s))
|
|
|
2334 (containing-sexp (car (cdr state)))
|
|
|
2335 (case-fold-search nil)
|
|
|
2336 (res (list (list 'parse-start start) (list 'parse-prestart prestart))))
|
|
|
2337 (cond ((nth 3 state) ; In string
|
|
|
2338 (setq res (cons (list 'string nil (nth 3 state)) res))) ; What started string
|
|
|
2339 ((nth 4 state) ; In comment
|
|
|
2340 (setq res (cons '(comment) res)))
|
|
|
2341 ((null containing-sexp)
|
|
|
2342 ;; Line is at top level.
|
|
|
2343 ;; Indent like the previous top level line
|
|
|
2344 ;; unless that ends in a closeparen without semicolon,
|
|
|
2345 ;; in which case this line is the first argument decl.
|
|
|
2346 (cperl-backward-to-noncomment (or parse-start (point-min)))
|
|
|
2347 ;;(skip-chars-backward " \t\f\n")
|
|
|
2348 (cond
|
|
|
2349 ((or (bobp)
|
|
|
2350 (memq (preceding-char) (append ";}" nil)))
|
|
|
2351 (setq res (cons (list 'toplevel start) res)))
|
|
|
2352 ((eq (preceding-char) ?\) )
|
|
|
2353 (setq res (cons (list 'toplevel-after-parenth start) res)))
|
|
|
2354 (t
|
|
|
2355 (setq res (cons (list 'toplevel-continued start) res)))))
|
|
|
2356 ((/= (char-after containing-sexp) ?{)
|
|
|
2357 ;; line is expression, not statement:
|
|
|
2358 ;; indent to just after the surrounding open.
|
|
|
2359 ;; skip blanks if we do not close the expression.
|
|
|
2360 (setq res (cons (list 'expression-blanks
|
|
|
2361 (progn
|
|
|
2362 (goto-char (1+ containing-sexp))
|
|
|
2363 (or (looking-at "[ \t]*\\(#\\|$\\)")
|
|
|
2364 (skip-chars-forward " \t"))
|
|
|
2365 (point)))
|
|
|
2366 (cons (list 'expression containing-sexp) res))))
|
|
|
2367 ((progn
|
|
|
2368 ;; Containing-expr starts with \{. Check whether it is a hash.
|
|
|
2369 (goto-char containing-sexp)
|
|
|
2370 (not (cperl-block-p)))
|
|
|
2371 (setq res (cons (list 'expression-blanks
|
|
|
2372 (progn
|
|
|
2373 (goto-char (1+ containing-sexp))
|
|
|
2374 (or (looking-at "[ \t]*\\(#\\|$\\)")
|
|
|
2375 (skip-chars-forward " \t"))
|
|
|
2376 (point)))
|
|
|
2377 (cons (list 'expression containing-sexp) res))))
|
|
|
2378 (t
|
|
|
2379 ;; Statement level.
|
|
|
2380 (setq res (cons (list 'in-block containing-sexp) res))
|
|
|
2381 ;; Is it a continuation or a new statement?
|
|
|
2382 ;; Find previous non-comment character.
|
|
|
2383 (cperl-backward-to-noncomment containing-sexp)
|
|
|
2384 ;; Back up over label lines, since they don't
|
|
|
2385 ;; affect whether our line is a continuation.
|
|
|
2386 ;; Back up comma-delimited lines too ?????
|
|
|
2387 (while (or (eq (preceding-char) ?\,)
|
|
|
2388 (save-excursion (cperl-after-label)))
|
|
|
2389 (if (eq (preceding-char) ?\,)
|
|
|
2390 ;; Will go to beginning of line, essentially
|
|
|
2391 ;; Will ignore embedded sexpr XXXX.
|
|
|
2392 (cperl-backward-to-start-of-continued-exp containing-sexp))
|
|
|
2393 (beginning-of-line)
|
|
|
2394 (cperl-backward-to-noncomment containing-sexp))
|
|
|
2395 ;; Now we get the answer.
|
|
|
2396 (if (not (memq (preceding-char) (append ";}{" '(nil)))) ; Was ?\,
|
|
|
2397 ;; This line is continuation of preceding line's statement.
|
|
|
2398 (list (list 'statement-continued containing-sexp))
|
|
|
2399 ;; This line starts a new statement.
|
|
|
2400 ;; Position following last unclosed open.
|
|
|
2401 (goto-char containing-sexp)
|
|
|
2402 ;; Is line first statement after an open-brace?
|
|
|
2403 (or
|
|
|
2404 ;; If no, find that first statement and indent like
|
|
|
2405 ;; it. If the first statement begins with label, do
|
|
4
|
2406 ;; not believe when the indentation of the label is too
|
|
0
|
2407 ;; small.
|
|
|
2408 (save-excursion
|
|
|
2409 (forward-char 1)
|
|
|
2410 (let ((colon-line-end 0))
|
|
|
2411 (while (progn (skip-chars-forward " \t\n" start-point)
|
|
|
2412 (and (< (point) start-point)
|
|
|
2413 (looking-at
|
|
|
2414 "#\\|[a-zA-Z_][a-zA-Z0-9_]*:[^:]")))
|
|
|
2415 ;; Skip over comments and labels following openbrace.
|
|
|
2416 (cond ((= (following-char) ?\#)
|
|
|
2417 ;;(forward-line 1)
|
|
|
2418 (end-of-line))
|
|
|
2419 ;; label:
|
|
|
2420 (t
|
|
|
2421 (save-excursion (end-of-line)
|
|
|
2422 (setq colon-line-end (point)))
|
|
|
2423 (search-forward ":"))))
|
|
|
2424 ;; Now at the point, after label, or at start
|
|
|
2425 ;; of first statement in the block.
|
|
|
2426 (and (< (point) start-point)
|
|
|
2427 (if (> colon-line-end (point))
|
|
|
2428 ;; Before statement after label
|
|
|
2429 (if (> (current-indentation)
|
|
|
2430 cperl-min-label-indent)
|
|
|
2431 (list (list 'label-in-block (point)))
|
|
4
|
2432 ;; Do not believe: `max' is involved
|
|
0
|
2433 (list
|
|
|
2434 (list 'label-in-block-min-indent (point))))
|
|
|
2435 ;; Before statement
|
|
|
2436 (list 'statement-in-block (point))))))
|
|
|
2437 ;; If no previous statement,
|
|
|
2438 ;; indent it relative to line brace is on.
|
|
|
2439 ;; For open brace in column zero, don't let statement
|
|
|
2440 ;; start there too. If cperl-indent-level is zero,
|
|
|
2441 ;; use cperl-brace-offset + cperl-continued-statement-offset instead.
|
|
|
2442 ;; For open-braces not the first thing in a line,
|
|
|
2443 ;; add in cperl-brace-imaginary-offset.
|
|
|
2444
|
|
|
2445 ;; If first thing on a line: ?????
|
|
|
2446 (+ (if (and (bolp) (zerop cperl-indent-level))
|
|
|
2447 (+ cperl-brace-offset cperl-continued-statement-offset)
|
|
|
2448 cperl-indent-level)
|
|
|
2449 ;; Move back over whitespace before the openbrace.
|
|
|
2450 ;; If openbrace is not first nonwhite thing on the line,
|
|
|
2451 ;; add the cperl-brace-imaginary-offset.
|
|
|
2452 (progn (skip-chars-backward " \t")
|
|
|
2453 (if (bolp) 0 cperl-brace-imaginary-offset))
|
|
|
2454 ;; If the openbrace is preceded by a parenthesized exp,
|
|
|
2455 ;; move to the beginning of that;
|
|
|
2456 ;; possibly a different line
|
|
|
2457 (progn
|
|
|
2458 (if (eq (preceding-char) ?\))
|
|
|
2459 (forward-sexp -1))
|
|
|
2460 ;; Get initial indentation of the line we are on.
|
|
|
2461 ;; If line starts with label, calculate label indentation
|
|
|
2462 (if (save-excursion
|
|
|
2463 (beginning-of-line)
|
|
193
|
2464 (looking-at "[ \t]*[a-zA-Z_][a-zA-Z_0-9]*:[^:]"))
|
|
0
|
2465 (if (> (current-indentation) cperl-min-label-indent)
|
|
|
2466 (- (current-indentation) cperl-label-offset)
|
|
|
2467 (cperl-calculate-indent
|
|
|
2468 (if (and parse-start (<= parse-start (point)))
|
|
|
2469 parse-start)))
|
|
|
2470 (current-indentation))))))))
|
|
|
2471 res)))
|
|
|
2472
|
|
|
2473 (defun cperl-calculate-indent-within-comment ()
|
|
|
2474 "Return the indentation amount for line, assuming that
|
|
|
2475 the current line is to be regarded as part of a block comment."
|
|
|
2476 (let (end star-start)
|
|
|
2477 (save-excursion
|
|
|
2478 (beginning-of-line)
|
|
|
2479 (skip-chars-forward " \t")
|
|
|
2480 (setq end (point))
|
|
|
2481 (and (= (following-char) ?#)
|
|
|
2482 (forward-line -1)
|
|
|
2483 (cperl-to-comment-or-eol)
|
|
|
2484 (setq end (point)))
|
|
|
2485 (goto-char end)
|
|
|
2486 (current-column))))
|
|
|
2487
|
|
|
2488
|
|
|
2489 (defun cperl-to-comment-or-eol ()
|
|
|
2490 "Goes to position before comment on the current line, or to end of line.
|
|
|
2491 Returns true if comment is found."
|
|
|
2492 (let (state stop-in cpoint (lim (progn (end-of-line) (point))))
|
|
|
2493 (beginning-of-line)
|
|
193
|
2494 (if (or
|
|
|
2495 (eq (get-text-property (point) 'syntax-type) 'pod)
|
|
|
2496 (re-search-forward "\\=[ \t]*\\(#\\|$\\)" lim t))
|
|
0
|
2497 (if (eq (preceding-char) ?\#) (progn (backward-char 1) t))
|
|
|
2498 ;; Else
|
|
|
2499 (while (not stop-in)
|
|
|
2500 (setq state (parse-partial-sexp (point) lim nil nil nil t))
|
|
|
2501 ; stop at comment
|
|
|
2502 ;; If fails (beginning-of-line inside sexp), then contains not-comment
|
|
|
2503 ;; Do simplified processing
|
|
|
2504 ;;(if (re-search-forward "[^$]#" lim 1)
|
|
|
2505 ;; (progn
|
|
|
2506 ;; (forward-char -1)
|
|
|
2507 ;; (skip-chars-backward " \t\n\f" lim))
|
|
|
2508 ;; (goto-char lim)) ; No `#' at all
|
|
|
2509 ;;)
|
|
|
2510 (if (nth 4 state) ; After `#';
|
|
|
2511 ; (nth 2 state) can be
|
|
|
2512 ; beginning of m,s,qq and so
|
|
|
2513 ; on
|
|
|
2514 (if (nth 2 state)
|
|
|
2515 (progn
|
|
|
2516 (setq cpoint (point))
|
|
|
2517 (goto-char (nth 2 state))
|
|
|
2518 (cond
|
|
|
2519 ((looking-at "\\(s\\|tr\\)\\>")
|
|
|
2520 (or (re-search-forward
|
|
|
2521 "\\=\\w+[ \t]*#\\([^\n\\\\#]\\|\\\\[\\\\#]\\)*#\\([^\n\\\\#]\\|\\\\[\\\\#]\\)*"
|
|
|
2522 lim 'move)
|
|
|
2523 (setq stop-in t)))
|
|
|
2524 ((looking-at "\\(m\\|q\\([qxw]\\)?\\)\\>")
|
|
|
2525 (or (re-search-forward
|
|
|
2526 "\\=\\w+[ \t]*#\\([^\n\\\\#]\\|\\\\[\\\\#]\\)*#"
|
|
|
2527 lim 'move)
|
|
|
2528 (setq stop-in t)))
|
|
|
2529 (t ; It was fair comment
|
|
|
2530 (setq stop-in t) ; Finish
|
|
|
2531 (goto-char (1- cpoint)))))
|
|
|
2532 (setq stop-in t) ; Finish
|
|
|
2533 (forward-char -1))
|
|
|
2534 (setq stop-in t)) ; Finish
|
|
|
2535 )
|
|
|
2536 (nth 4 state))))
|
|
|
2537
|
|
193
|
2538 (defsubst cperl-1- (p)
|
|
|
2539 (max (point-min) (1- p)))
|
|
|
2540
|
|
|
2541 (defsubst cperl-1+ (p)
|
|
|
2542 (min (point-max) (1+ p)))
|
|
|
2543
|
|
|
2544 (defvar cperl-st-cfence '(14)) ; Comment-fence
|
|
|
2545 (defvar cperl-st-sfence '(15)) ; String-fence
|
|
|
2546 (defvar cperl-st-punct '(1))
|
|
|
2547 (defvar cperl-st-word '(2))
|
|
|
2548
|
|
|
2549 (defun cperl-protect-defun-start (s e)
|
|
|
2550 ;; C code looks for "^\\s(" to skip comment backward in "hard" situations
|
|
|
2551 (save-excursion
|
|
|
2552 (goto-char s)
|
|
|
2553 (while (re-search-forward "^\\s(" e 'to-end)
|
|
|
2554 (put-text-property (1- (point)) (point) 'syntax-table cperl-st-punct))))
|
|
|
2555
|
|
|
2556 (defun cperl-commentify (bb e string)
|
|
|
2557 (if cperl-use-syntax-table-text-property
|
|
|
2558 (progn
|
|
|
2559 ;; We suppose that e is _after_ the end of construction, as after eol.
|
|
|
2560 (setq string (if string cperl-st-sfence cperl-st-cfence))
|
|
|
2561 (put-text-property bb (1+ bb) 'syntax-table string)
|
|
|
2562 (put-text-property bb (1+ bb) 'rear-nonsticky t)
|
|
|
2563 (put-text-property (1- e) e 'syntax-table string)
|
|
|
2564 (put-text-property (1- e) e 'rear-nonsticky t)
|
|
|
2565 (if (and (eq string cperl-st-sfence) (> (- e 2) bb))
|
|
|
2566 (put-text-property (1+ bb) (1- e)
|
|
|
2567 'syntax-table cperl-string-syntax-table))
|
|
|
2568 (cperl-protect-defun-start bb e))))
|
|
|
2569
|
|
0
|
2570 (defun cperl-find-pods-heres (&optional min max)
|
|
|
2571 "Scans the buffer for POD sections and here-documents.
|
|
|
2572 If `cperl-pod-here-fontify' is not-nil after evaluation, will fontify
|
|
|
2573 the sections using `cperl-pod-head-face', `cperl-pod-face',
|
|
|
2574 `cperl-here-face'."
|
|
|
2575 (interactive)
|
|
|
2576 (or min (setq min (point-min)))
|
|
|
2577 (or max (setq max (point-max)))
|
|
193
|
2578 (let (face head-face here-face b e bb tag qtag err b1 e1 argument st i c
|
|
0
|
2579 (cperl-pod-here-fontify (eval cperl-pod-here-fontify))
|
|
|
2580 (case-fold-search nil) (inhibit-read-only t) (buffer-undo-list t)
|
|
4
|
2581 (modified (buffer-modified-p))
|
|
|
2582 (after-change-functions nil)
|
|
193
|
2583 (state-point (point-min)) state
|
|
4
|
2584 (search
|
|
|
2585 (concat
|
|
|
2586 "\\(\\`\n?\\|\n\n\\)="
|
|
|
2587 "\\|"
|
|
|
2588 ;; One extra () before this:
|
|
110
|
2589 "<<"
|
|
|
2590 "\\("
|
|
|
2591 ;; First variant "BLAH" or just ``.
|
|
|
2592 "\\([\"'`]\\)"
|
|
|
2593 "\\([^\"'`\n]*\\)"
|
|
|
2594 "\\3"
|
|
|
2595 "\\|"
|
|
|
2596 ;; Second variant: Identifier or empty
|
|
|
2597 "\\(\\([a-zA-Z_][a-zA-Z_0-9]*\\)?\\)"
|
|
|
2598 ;; Check that we do not have <<= or << 30 or << $blah.
|
|
|
2599 "\\([^= \t$@%&]\\|[ \t]+[^ \t\n0-9$@%&]\\)"
|
|
|
2600 "\\)"
|
|
4
|
2601 "\\|"
|
|
110
|
2602 ;; 1+6 extra () before this:
|
|
193
|
2603 "^[ \t]*\\(format\\)[ \t]*\\([a-zA-Z0-9_]+\\)?[ \t]*=[ \t]*$"
|
|
|
2604 (if cperl-use-syntax-table-text-property
|
|
|
2605 (concat
|
|
|
2606 "\\|"
|
|
|
2607 ;; 1+6+2=9 extra () before this:
|
|
|
2608 "\\<\\(q[wxq]?\\|[msy]\\|tr\\)\\>"
|
|
|
2609 "\\|"
|
|
|
2610 ;; 1+6+2+1=10 extra () before this:
|
|
|
2611 "\\([?/]\\)" ; /blah/ or ?blah?
|
|
|
2612 "\\|"
|
|
|
2613 ;; 1+6+2+1+1=11 extra () before this:
|
|
|
2614 "\\<sub\\>[ \t]*\\([a-zA-Z_:'0-9]+[ \t]*\\)?\\(([^()]*)\\)"
|
|
|
2615 "\\|"
|
|
|
2616 ;; 1+6+2+1+1+2=13 extra () before this:
|
|
|
2617 "\\$\\(['{]\\)"
|
|
|
2618 "\\|"
|
|
|
2619 ;; 1+6+2+1+1+2+1=14 extra () before this:
|
|
|
2620 "\\(\\<sub[ \t\n\f]+\\|[&*$@%]\\)[a-zA-Z0-9_]*'")
|
|
|
2621 ""))))
|
|
0
|
2622 (unwind-protect
|
|
|
2623 (progn
|
|
|
2624 (save-excursion
|
|
4
|
2625 (message "Scanning for pods, formats and here-docs...")
|
|
0
|
2626 (if cperl-pod-here-fontify
|
|
4
|
2627 ;; We had evals here, do not know why...
|
|
193
|
2628 (setq face `cperl-pod-face
|
|
|
2629 head-face `cperl-pod-head-face
|
|
|
2630 here-face `cperl-here-face))
|
|
|
2631 (remove-text-properties min max
|
|
|
2632 '(syntax-type t in-pod t syntax-table t))
|
|
0
|
2633 ;; Need to remove face as well...
|
|
|
2634 (goto-char min)
|
|
4
|
2635 (while (re-search-forward search max t)
|
|
|
2636 (cond
|
|
|
2637 ((match-beginning 1) ; POD section
|
|
|
2638 ;; "\\(\\`\n?\\|\n\n\\)="
|
|
|
2639 (if (looking-at "\n*cut\\>")
|
|
|
2640 (progn
|
|
193
|
2641 (message "=cut is not preceded by a pod section")
|
|
|
2642 (or err (setq err (point))))
|
|
0
|
2643 (beginning-of-line)
|
|
4
|
2644
|
|
|
2645 (setq b (point) bb b)
|
|
|
2646 (or (re-search-forward "\n\n=cut\\>" max 'toend)
|
|
193
|
2647 (progn
|
|
|
2648 (message "Cannot find the end of a pod section")
|
|
|
2649 (or err (setq err b))))
|
|
|
2650 (beginning-of-line 2) ; An empty line after =cut is not POD!
|
|
4
|
2651 (setq e (point))
|
|
|
2652 (put-text-property b e 'in-pod t)
|
|
|
2653 (goto-char b)
|
|
|
2654 (while (re-search-forward "\n\n[ \t]" e t)
|
|
193
|
2655 ;; We start 'pod 1 char earlier to include the preceding line
|
|
4
|
2656 (beginning-of-line)
|
|
193
|
2657 (put-text-property (cperl-1- b) (point) 'syntax-type 'pod)
|
|
4
|
2658 (cperl-put-do-not-fontify b (point))
|
|
|
2659 ;;(put-text-property (max (point-min) (1- b))
|
|
|
2660 ;; (point) cperl-do-not-fontify t)
|
|
|
2661 (if cperl-pod-here-fontify (put-text-property b (point) 'face face))
|
|
|
2662 (re-search-forward "\n\n[^ \t\f\n]" e 'toend)
|
|
|
2663 (beginning-of-line)
|
|
|
2664 (setq b (point)))
|
|
193
|
2665 (put-text-property (cperl-1- (point)) e 'syntax-type 'pod)
|
|
4
|
2666 (cperl-put-do-not-fontify (point) e)
|
|
|
2667 ;;(put-text-property (max (point-min) (1- (point)))
|
|
|
2668 ;; e cperl-do-not-fontify t)
|
|
|
2669 (if cperl-pod-here-fontify
|
|
|
2670 (progn (put-text-property (point) e 'face face)
|
|
|
2671 (goto-char bb)
|
|
|
2672 (if (looking-at
|
|
193
|
2673 "=[a-zA-Z0-9_]+\\>[ \t]*\\(\\(\n?[^\n]\\)+\\)$")
|
|
4
|
2674 (put-text-property
|
|
|
2675 (match-beginning 1) (match-end 1)
|
|
|
2676 'face head-face))
|
|
|
2677 (while (re-search-forward
|
|
|
2678 ;; One paragraph
|
|
193
|
2679 "\n\n=[a-zA-Z0-9_]+\\>[ \t]*\\(\\(\n?[^\n]\\)+\\)$"
|
|
4
|
2680 e 'toend)
|
|
|
2681 (put-text-property
|
|
|
2682 (match-beginning 1) (match-end 1)
|
|
|
2683 'face head-face))))
|
|
193
|
2684 (cperl-commentify bb e nil)
|
|
4
|
2685 (goto-char e)))
|
|
|
2686 ;; Here document
|
|
193
|
2687 ;; We do only one here-per-line
|
|
4
|
2688 ;; 1 () ahead
|
|
|
2689 ;; "<<\\(\\([\"'`]\\)\\([^\"'`\n]*\\)\\3\\|\\(\\([a-zA-Z_][a-zA-Z_0-9]*\\)?\\)\\)"
|
|
|
2690 ((match-beginning 2) ; 1 + 1
|
|
193
|
2691 ;; Abort in comment:
|
|
4
|
2692 (setq b (point))
|
|
193
|
2693 (setq state (parse-partial-sexp state-point b nil nil state)
|
|
|
2694 state-point b)
|
|
|
2695 (if ;;(save-excursion
|
|
|
2696 ;; (beginning-of-line)
|
|
|
2697 ;; (search-forward "#" b t))
|
|
|
2698 (or (nth 3 state) (nth 4 state))
|
|
|
2699 (goto-char (match-end 2))
|
|
4
|
2700 (if (match-beginning 5) ;4 + 1
|
|
|
2701 (setq b1 (match-beginning 5) ; 4 + 1
|
|
|
2702 e1 (match-end 5)) ; 4 + 1
|
|
|
2703 (setq b1 (match-beginning 4) ; 3 + 1
|
|
|
2704 e1 (match-end 4))) ; 3 + 1
|
|
|
2705 (setq tag (buffer-substring b1 e1)
|
|
|
2706 qtag (regexp-quote tag))
|
|
|
2707 (cond (cperl-pod-here-fontify
|
|
|
2708 (put-text-property b1 e1 'face font-lock-reference-face)
|
|
|
2709 (cperl-put-do-not-fontify b1 e1)))
|
|
|
2710 (forward-line)
|
|
|
2711 (setq b (point))
|
|
|
2712 (cond ((re-search-forward (concat "^" qtag "$") max 'toend)
|
|
|
2713 (if cperl-pod-here-fontify
|
|
|
2714 (progn
|
|
|
2715 (put-text-property (match-beginning 0) (match-end 0)
|
|
|
2716 'face font-lock-reference-face)
|
|
|
2717 (cperl-put-do-not-fontify b (match-end 0))
|
|
|
2718 ;;(put-text-property (max (point-min) (1- b))
|
|
|
2719 ;; (min (point-max)
|
|
|
2720 ;; (1+ (match-end 0)))
|
|
|
2721 ;; cperl-do-not-fontify t)
|
|
|
2722 (put-text-property b (match-beginning 0)
|
|
|
2723 'face here-face)))
|
|
193
|
2724 (setq e1 (cperl-1+ (match-end 0)))
|
|
4
|
2725 (put-text-property b (match-beginning 0)
|
|
|
2726 'syntax-type 'here-doc)
|
|
193
|
2727 (put-text-property (match-beginning 0) e1
|
|
|
2728 'syntax-type 'here-doc-delim)
|
|
|
2729 (put-text-property b e1
|
|
|
2730 'here-doc-group t)
|
|
|
2731 (cperl-commentify b e1 nil)
|
|
|
2732 (cperl-put-do-not-fontify b (match-end 0)))
|
|
|
2733 (t (message "End of here-document `%s' not found." tag)
|
|
|
2734 (or err (setq err b))))))
|
|
4
|
2735 ;; format
|
|
193
|
2736 ((match-beginning 8)
|
|
110
|
2737 ;; 1+6=7 extra () before this:
|
|
193
|
2738 ;;"^[ \t]*\\(format\\)[ \t]*\\([a-zA-Z0-9_]+\\)?[ \t]*=[ \t]*$"
|
|
4
|
2739 (setq b (point)
|
|
110
|
2740 name (if (match-beginning 8) ; 7 + 1
|
|
|
2741 (buffer-substring (match-beginning 8) ; 7 + 1
|
|
|
2742 (match-end 8)) ; 7 + 1
|
|
4
|
2743 ""))
|
|
|
2744 (setq argument nil)
|
|
0
|
2745 (if cperl-pod-here-fontify
|
|
4
|
2746 (while (and (eq (forward-line) 0)
|
|
|
2747 (not (looking-at "^[.;]$")))
|
|
|
2748 (cond
|
|
|
2749 ((looking-at "^#")) ; Skip comments
|
|
|
2750 ((and argument ; Skip argument multi-lines
|
|
|
2751 (looking-at "^[ \t]*{"))
|
|
|
2752 (forward-sexp 1)
|
|
|
2753 (setq argument nil))
|
|
|
2754 (argument ; Skip argument lines
|
|
|
2755 (setq argument nil))
|
|
|
2756 (t ; Format line
|
|
|
2757 (setq b1 (point))
|
|
|
2758 (setq argument (looking-at "^[^\n]*[@^]"))
|
|
|
2759 (end-of-line)
|
|
|
2760 (put-text-property b1 (point)
|
|
|
2761 'face font-lock-string-face)
|
|
193
|
2762 (cperl-commentify b1 (point) nil)
|
|
4
|
2763 (cperl-put-do-not-fontify b1 (point)))))
|
|
|
2764 (re-search-forward (concat "^[.;]$") max 'toend))
|
|
|
2765 (beginning-of-line)
|
|
|
2766 (if (looking-at "^[.;]$")
|
|
|
2767 (progn
|
|
|
2768 (put-text-property (point) (+ (point) 2)
|
|
|
2769 'face font-lock-string-face)
|
|
193
|
2770 (cperl-commentify (point) (+ (point) 2) nil)
|
|
4
|
2771 (cperl-put-do-not-fontify (point) (+ (point) 2)))
|
|
193
|
2772 (message "End of format `%s' not found." name)
|
|
|
2773 (or err (setq err b)))
|
|
4
|
2774 (forward-line)
|
|
|
2775 (put-text-property b (point) 'syntax-type 'format)
|
|
|
2776 ;;; (cond ((re-search-forward (concat "^[.;]$") max 'toend)
|
|
|
2777 ;;; (if cperl-pod-here-fontify
|
|
|
2778 ;;; (progn
|
|
|
2779 ;;; (put-text-property b (match-end 0)
|
|
|
2780 ;;; 'face font-lock-string-face)
|
|
|
2781 ;;; (cperl-put-do-not-fontify b (match-end 0))))
|
|
|
2782 ;;; (put-text-property b (match-end 0)
|
|
|
2783 ;;; 'syntax-type 'format)
|
|
|
2784 ;;; (cperl-put-do-not-fontify b (match-beginning 0)))
|
|
|
2785 ;;; (t (message "End of format `%s' not found." name)))
|
|
193
|
2786 )
|
|
|
2787 ;; Regexp:
|
|
|
2788 ((or (match-beginning 10) (match-beginning 11))
|
|
|
2789 ;; 1+6+2=9 extra () before this:
|
|
|
2790 ;; "\\<\\(q[wxq]?\\|[msy]\\|tr\\)\\>"
|
|
|
2791 ;; "\\|"
|
|
|
2792 ;; "\\([?/]\\)" ; /blah/ or ?blah?
|
|
|
2793 (setq b1 (if (match-beginning 10) 10 11)
|
|
|
2794 argument (buffer-substring
|
|
|
2795 (match-beginning b1) (match-end b1))
|
|
|
2796 b (point)
|
|
|
2797 i b
|
|
|
2798 c (char-after (match-beginning b1))
|
|
|
2799 bb (or
|
|
|
2800 (memq (char-after (1- (match-beginning b1)))
|
|
|
2801 '(?\$ ?\@ ?\% ?\& ?\*))
|
|
|
2802 (and
|
|
|
2803 (eq (char-after (1- (match-beginning b1))) ?-)
|
|
|
2804 (eq c ?s))))
|
|
|
2805 (or bb
|
|
|
2806 (if (eq b1 11) ; bare /blah/ or ?blah?
|
|
|
2807 (setq argument ""
|
|
|
2808 bb ; Not a regexp
|
|
|
2809 (progn
|
|
|
2810 (goto-char (match-beginning b1))
|
|
|
2811 (cperl-backward-to-noncomment (point-min))
|
|
|
2812 (not (or (memq (preceding-char)
|
|
|
2813 (append (if (eq c ?\?)
|
|
|
2814 ;; $a++ ? 1 : 2
|
|
|
2815 "~{(=|&*!,;"
|
|
|
2816 "~{(=|&+-*!,;") nil))
|
|
|
2817 (and (eq (preceding-char) ?\})
|
|
|
2818 (cperl-after-block-p (point-min)))
|
|
|
2819 (and (eq (char-syntax (preceding-char)) ?w)
|
|
|
2820 (progn
|
|
|
2821 (forward-sexp -1)
|
|
|
2822 (looking-at
|
|
|
2823 "\\(while\\|if\\|unless\\|until\\|and\\|or\\|not\\|xor\\|split\\|grep\\|map\\)\\>")))
|
|
|
2824 (and (eq (preceding-char) ?.)
|
|
|
2825 (eq (char-after (- (point) 2)) ?.))
|
|
|
2826 (bobp))))
|
|
|
2827 b (1- b))))
|
|
|
2828 (or bb (setq state (parse-partial-sexp
|
|
|
2829 state-point b nil nil state)
|
|
|
2830 state-point b))
|
|
|
2831 (goto-char b)
|
|
|
2832 (if (or bb (nth 3 state) (nth 4 state))
|
|
|
2833 (goto-char i)
|
|
|
2834 (skip-chars-forward " \t")
|
|
|
2835 ;; qtag means two-arg matcher, may be reset to
|
|
|
2836 ;; 2 or 3 later if some special quoting is needed.
|
|
|
2837 ;; e1 means matching-char matcher.
|
|
|
2838 (setq b (point)
|
|
|
2839 tag (char-after b)
|
|
|
2840 qtag (if (string-match "^\\([sy]\\|tr\\)$" argument) t)
|
|
|
2841 e1 (cdr (assoc tag '(( ?\( . ?\) )
|
|
|
2842 ( ?\[ . ?\] )
|
|
|
2843 ( ?\{ . ?\} )
|
|
|
2844 ( ?\< . ?\> )
|
|
|
2845 ))))
|
|
|
2846 ;; What if tag == ?\\ ????
|
|
|
2847 (or st
|
|
|
2848 (progn
|
|
|
2849 (setq st (make-syntax-table) i 0)
|
|
|
2850 (while (< i 256)
|
|
|
2851 (modify-syntax-entry i "." st)
|
|
|
2852 (setq i (1+ i)))
|
|
|
2853 (modify-syntax-entry ?\\ "\\" st)))
|
|
|
2854 ;; Whether we have an intermediate point
|
|
|
2855 (setq i nil)
|
|
|
2856 ;; Prepare the syntax table:
|
|
|
2857 (cond
|
|
|
2858 ;; $ has TeXish matching rules, so $$ equiv $...
|
|
|
2859 ((and qtag
|
|
|
2860 (not e1)
|
|
|
2861 (eq tag (char-after (cperl-1+ b)))
|
|
|
2862 (eq tag (char-after (+ 2 b))))
|
|
|
2863 (setq qtag 3)) ; s///
|
|
|
2864 ((and qtag
|
|
|
2865 (not e1)
|
|
|
2866 (eq tag (char-after (cperl-1+ b))))
|
|
|
2867 (setq qtag nil)) ; s//blah/, will work anyway
|
|
|
2868 ((and (not e1)
|
|
|
2869 (eq tag (char-after (cperl-1+ b))))
|
|
|
2870 (setq qtag 2)) ; m//
|
|
|
2871 ((not e1)
|
|
|
2872 (modify-syntax-entry tag "$" st)) ; m/blah/, s/x//, s/x/y/
|
|
|
2873 (t ; s{}(), m[]
|
|
|
2874 (modify-syntax-entry tag (concat "(" (list e1)) st)
|
|
|
2875 (modify-syntax-entry e1 (concat ")" (list tag)) st)))
|
|
|
2876 (if (numberp qtag)
|
|
|
2877 (forward-char qtag)
|
|
|
2878 (condition-case bb
|
|
|
2879 (progn
|
|
|
2880 (set-syntax-table st)
|
|
|
2881 (forward-sexp 1) ; Wrong if m// - taken care of...
|
|
|
2882 (if qtag
|
|
|
2883 (if e1
|
|
|
2884 (progn
|
|
|
2885 (setq i (point))
|
|
|
2886 (set-syntax-table cperl-mode-syntax-table)
|
|
|
2887 (forward-sexp 1)) ; Should be smarter?
|
|
|
2888 ;; "$" has funny matching rules
|
|
|
2889 (if (/= (char-after (- (point) 2))
|
|
|
2890 (preceding-char))
|
|
|
2891 (progn
|
|
|
2892 ;; Commenting \\ is dangerous, what about ( ?
|
|
|
2893 (if (eq (following-char) ?\\) nil
|
|
|
2894 (setq i (point)))
|
|
|
2895 (forward-char -1)
|
|
|
2896 (forward-sexp 1)))
|
|
|
2897 )))
|
|
|
2898 (error (goto-char (point-max))
|
|
|
2899 (message
|
|
|
2900 "End of `%s%c ... %c' string not found: %s"
|
|
|
2901 argument tag (or e1 tag) bb)
|
|
|
2902 (or err (setq err b)))))
|
|
|
2903 (set-syntax-table cperl-mode-syntax-table)
|
|
|
2904 (if (null i)
|
|
|
2905 (cperl-commentify b (point) t)
|
|
|
2906 (cperl-commentify b i t)
|
|
|
2907 (if (looking-at "\\sw*e") nil ; s///e
|
|
|
2908 (cperl-commentify i (point) t)))
|
|
|
2909 (if (eq (char-syntax (following-char)) ?w)
|
|
|
2910 (forward-word 1)) ; skip modifiers s///s
|
|
|
2911 (modify-syntax-entry tag "." st)
|
|
|
2912 (if e1 (modify-syntax-entry e1 "." st))))
|
|
|
2913 ((match-beginning 13) ; sub with prototypes
|
|
|
2914 (setq b (match-beginning 0))
|
|
|
2915 (if (memq (char-after (1- b))
|
|
|
2916 '(?\$ ?\@ ?\% ?\& ?\*))
|
|
|
2917 nil
|
|
|
2918 (setq state (parse-partial-sexp
|
|
|
2919 state-point (1- b) nil nil state)
|
|
|
2920 state-point (1- b))
|
|
|
2921 (if (or (nth 3 state) (nth 4 state))
|
|
|
2922 nil
|
|
|
2923 ;; Mark as string
|
|
|
2924 (cperl-commentify (match-beginning 13) (match-end 13) t))
|
|
|
2925 (goto-char (match-end 0))))
|
|
|
2926 ;; 1+6+2+1+1+2=13 extra () before this:
|
|
|
2927 ;; "\\$\\(['{]\\)"
|
|
|
2928 ((and (match-beginning 14)
|
|
|
2929 (eq (preceding-char) ?\')) ; $'
|
|
|
2930 (setq b (1- (point))
|
|
|
2931 state (parse-partial-sexp
|
|
|
2932 state-point (1- b) nil nil state)
|
|
|
2933 state-point (1- b))
|
|
|
2934 (if (nth 3 state) ; in string
|
|
|
2935 (progn
|
|
|
2936 (put-text-property (1- b) b 'syntax-table cperl-st-punct)
|
|
|
2937 (put-text-property (1- b) b 'rear-nonsticky t)))
|
|
|
2938 (goto-char (1+ b)))
|
|
|
2939 ;; 1+6+2+1+1+2=13 extra () before this:
|
|
|
2940 ;; "\\$\\(['{]\\)"
|
|
|
2941 ((match-beginning 14) ; ${
|
|
|
2942 (setq bb (match-beginning 0))
|
|
|
2943 (put-text-property bb (1+ bb) 'syntax-table cperl-st-punct)
|
|
|
2944 (put-text-property bb (1+ bb) 'rear-nonsticky t))
|
|
|
2945 ;; 1+6+2+1+1+2+1=14 extra () before this:
|
|
|
2946 ;; "\\(\\<sub[ \t\n\f]+\\|[&*$@%]\\)[a-zA-Z0-9_]*'")
|
|
|
2947 (t ; old $abc'efg syntax
|
|
|
2948 (setq bb (match-end 0)
|
|
|
2949 b (match-beginning 0)
|
|
|
2950 state (parse-partial-sexp
|
|
|
2951 state-point b nil nil state)
|
|
|
2952 state-point b)
|
|
|
2953 (if (nth 3 state) ; in string
|
|
|
2954 nil
|
|
|
2955 (put-text-property (1- bb) bb 'syntax-table cperl-st-word))
|
|
|
2956 (goto-char bb))))
|
|
4
|
2957 ;;; (while (re-search-forward "\\(\\`\n?\\|\n\n\\)=" max t)
|
|
|
2958 ;;; (if (looking-at "\n*cut\\>")
|
|
|
2959 ;;; (progn
|
|
193
|
2960 ;;; (message "=cut is not preceded by a pod section")
|
|
4
|
2961 ;;; (setq err (point)))
|
|
|
2962 ;;; (beginning-of-line)
|
|
|
2963
|
|
|
2964 ;;; (setq b (point) bb b)
|
|
|
2965 ;;; (or (re-search-forward "\n\n=cut\\>" max 'toend)
|
|
|
2966 ;;; (message "Cannot find the end of a pod section"))
|
|
|
2967 ;;; (beginning-of-line 3)
|
|
|
2968 ;;; (setq e (point))
|
|
|
2969 ;;; (put-text-property b e 'in-pod t)
|
|
|
2970 ;;; (goto-char b)
|
|
|
2971 ;;; (while (re-search-forward "\n\n[ \t]" e t)
|
|
|
2972 ;;; (beginning-of-line)
|
|
|
2973 ;;; (put-text-property b (point) 'syntax-type 'pod)
|
|
|
2974 ;;; (cperl-put-do-not-fontify b (point))
|
|
|
2975 ;;; ;;(put-text-property (max (point-min) (1- b))
|
|
|
2976 ;;; ;; (point) cperl-do-not-fontify t)
|
|
|
2977 ;;; (if cperl-pod-here-fontify (put-text-property b (point) 'face face))
|
|
|
2978 ;;; (re-search-forward "\n\n[^ \t\f\n]" e 'toend)
|
|
|
2979 ;;; (beginning-of-line)
|
|
|
2980 ;;; (setq b (point)))
|
|
|
2981 ;;; (put-text-property (point) e 'syntax-type 'pod)
|
|
|
2982 ;;; (cperl-put-do-not-fontify (point) e)
|
|
|
2983 ;;; ;;(put-text-property (max (point-min) (1- (point)))
|
|
|
2984 ;;; ;; e cperl-do-not-fontify t)
|
|
|
2985 ;;; (if cperl-pod-here-fontify
|
|
|
2986 ;;; (progn (put-text-property (point) e 'face face)
|
|
|
2987 ;;; (goto-char bb)
|
|
|
2988 ;;; (if (looking-at
|
|
|
2989 ;;; "=[a-zA-Z0-9]+\\>[ \t]*\\(\\(\n?[^\n]\\)+\\)$")
|
|
|
2990 ;;; (put-text-property
|
|
|
2991 ;;; (match-beginning 1) (match-end 1)
|
|
|
2992 ;;; 'face head-face))
|
|
|
2993 ;;; (while (re-search-forward
|
|
|
2994 ;;; ;; One paragraph
|
|
|
2995 ;;; "\n\n=[a-zA-Z0-9]+\\>[ \t]*\\(\\(\n?[^\n]\\)+\\)$"
|
|
|
2996 ;;; e 'toend)
|
|
|
2997 ;;; (put-text-property
|
|
|
2998 ;;; (match-beginning 1) (match-end 1)
|
|
|
2999 ;;; 'face head-face))))
|
|
|
3000 ;;; (goto-char e)))
|
|
|
3001 ;;; (goto-char min)
|
|
|
3002 ;;; (while (re-search-forward
|
|
|
3003 ;;; ;; We exclude \n to avoid misrecognition inside quotes.
|
|
|
3004 ;;; "<<\\(\\([\"'`]\\)\\([^\"'`\n]*\\)\\2\\|\\(\\([a-zA-Z_][a-zA-Z_0-9]*\\)?\\)\\)"
|
|
|
3005 ;;; max t)
|
|
|
3006 ;;; (if (match-beginning 4)
|
|
|
3007 ;;; (setq b1 (match-beginning 4)
|
|
|
3008 ;;; e1 (match-end 4))
|
|
|
3009 ;;; (setq b1 (match-beginning 3)
|
|
|
3010 ;;; e1 (match-end 3)))
|
|
|
3011 ;;; (setq tag (buffer-substring b1 e1)
|
|
|
3012 ;;; qtag (regexp-quote tag))
|
|
|
3013 ;;; (cond (cperl-pod-here-fontify
|
|
|
3014 ;;; (put-text-property b1 e1 'face font-lock-reference-face)
|
|
|
3015 ;;; (cperl-put-do-not-fontify b1 e1)))
|
|
|
3016 ;;; (forward-line)
|
|
|
3017 ;;; (setq b (point))
|
|
|
3018 ;;; (cond ((re-search-forward (concat "^" qtag "$") max 'toend)
|
|
|
3019 ;;; (if cperl-pod-here-fontify
|
|
|
3020 ;;; (progn
|
|
|
3021 ;;; (put-text-property (match-beginning 0) (match-end 0)
|
|
|
3022 ;;; 'face font-lock-reference-face)
|
|
|
3023 ;;; (cperl-put-do-not-fontify b (match-end 0))
|
|
|
3024 ;;; ;;(put-text-property (max (point-min) (1- b))
|
|
|
3025 ;;; ;; (min (point-max)
|
|
|
3026 ;;; ;; (1+ (match-end 0)))
|
|
|
3027 ;;; ;; cperl-do-not-fontify t)
|
|
|
3028 ;;; (put-text-property b (match-beginning 0)
|
|
|
3029 ;;; 'face here-face)))
|
|
|
3030 ;;; (put-text-property b (match-beginning 0)
|
|
|
3031 ;;; 'syntax-type 'here-doc)
|
|
|
3032 ;;; (cperl-put-do-not-fontify b (match-beginning 0)))
|
|
|
3033 ;;; (t (message "End of here-document `%s' not found." tag))))
|
|
|
3034 ;;; (goto-char min)
|
|
|
3035 ;;; (while (re-search-forward
|
|
|
3036 ;;; "^[ \t]*format[ \t]*\\(\\([a-zA-Z0-9_]+[ \t]*\\)?\\)=[ \t]*$"
|
|
|
3037 ;;; max t)
|
|
|
3038 ;;; (setq b (point)
|
|
|
3039 ;;; name (buffer-substring (match-beginning 1)
|
|
|
3040 ;;; (match-end 1)))
|
|
|
3041 ;;; (cond ((re-search-forward (concat "^[.;]$") max 'toend)
|
|
|
3042 ;;; (if cperl-pod-here-fontify
|
|
|
3043 ;;; (progn
|
|
|
3044 ;;; (put-text-property b (match-end 0)
|
|
|
3045 ;;; 'face font-lock-string-face)
|
|
|
3046 ;;; (cperl-put-do-not-fontify b (match-end 0))))
|
|
|
3047 ;;; (put-text-property b (match-end 0)
|
|
|
3048 ;;; 'syntax-type 'format)
|
|
|
3049 ;;; (cperl-put-do-not-fontify b (match-beginning 0)))
|
|
|
3050 ;;; (t (message "End of format `%s' not found." name))))
|
|
|
3051 )
|
|
0
|
3052 (if err (goto-char err)
|
|
4
|
3053 (message "Scan for pods, formats and here-docs completed.")))
|
|
0
|
3054 (and (buffer-modified-p)
|
|
|
3055 (not modified)
|
|
193
|
3056 (set-buffer-modified-p nil))
|
|
|
3057 (set-syntax-table cperl-mode-syntax-table))))
|
|
0
|
3058
|
|
|
3059 (defun cperl-backward-to-noncomment (lim)
|
|
|
3060 ;; Stops at lim or after non-whitespace that is not in comment
|
|
|
3061 (let (stop p)
|
|
|
3062 (while (and (not stop) (> (point) (or lim 1)))
|
|
|
3063 (skip-chars-backward " \t\n\f" lim)
|
|
|
3064 (setq p (point))
|
|
|
3065 (beginning-of-line)
|
|
|
3066 (if (looking-at "^[ \t]*\\(#\\|$\\)") nil ; Only comment, skip
|
|
|
3067 ;; Else
|
|
|
3068 (cperl-to-comment-or-eol)
|
|
|
3069 (skip-chars-backward " \t")
|
|
|
3070 (if (< p (point)) (goto-char p))
|
|
|
3071 (setq stop t)))))
|
|
|
3072
|
|
193
|
3073 (defun cperl-after-block-p (lim)
|
|
|
3074 ;; We suppose that the preceding char is }.
|
|
|
3075 (save-excursion
|
|
|
3076 (condition-case nil
|
|
|
3077 (progn
|
|
|
3078 (forward-sexp -1)
|
|
|
3079 (cperl-backward-to-noncomment lim)
|
|
|
3080 (or (eq (preceding-char) ?\) ) ; if () {}
|
|
|
3081 (and (eq (char-syntax (preceding-char)) ?w) ; else {}
|
|
|
3082 (progn
|
|
|
3083 (forward-sexp -1)
|
|
|
3084 (looking-at "\\(else\\|grep\\|map\\)\\>")))
|
|
|
3085 (cperl-after-expr-p lim)))
|
|
|
3086 (error nil))))
|
|
|
3087
|
|
0
|
3088 (defun cperl-after-expr-p (&optional lim chars test)
|
|
|
3089 "Returns true if the position is good for start of expression.
|
|
|
3090 TEST is the expression to evaluate at the found position. If absent,
|
|
193
|
3091 CHARS is a string that contains good characters to have before us (however,
|
|
|
3092 `}' is treated \"smartly\" if it is not in the list)."
|
|
|
3093 (let (stop p
|
|
|
3094 (lim (or lim (point-min))))
|
|
0
|
3095 (save-excursion
|
|
193
|
3096 (while (and (not stop) (> (point) lim))
|
|
0
|
3097 (skip-chars-backward " \t\n\f" lim)
|
|
|
3098 (setq p (point))
|
|
|
3099 (beginning-of-line)
|
|
|
3100 (if (looking-at "^[ \t]*\\(#\\|$\\)") nil ; Only comment, skip
|
|
|
3101 ;; Else: last iteration (What to do with labels?)
|
|
|
3102 (cperl-to-comment-or-eol)
|
|
|
3103 (skip-chars-backward " \t")
|
|
|
3104 (if (< p (point)) (goto-char p))
|
|
|
3105 (setq stop t)))
|
|
|
3106 (or (bobp)
|
|
|
3107 (progn
|
|
|
3108 (if test (eval test)
|
|
193
|
3109 (or (memq (preceding-char) (append (or chars "{;") nil))
|
|
|
3110 (and (eq (preceding-char) ?\})
|
|
|
3111 (cperl-after-block-p lim)))))))))
|
|
0
|
3112
|
|
|
3113 (defun cperl-backward-to-start-of-continued-exp (lim)
|
|
|
3114 (if (memq (preceding-char) (append ")]}\"'`" nil))
|
|
|
3115 (forward-sexp -1))
|
|
|
3116 (beginning-of-line)
|
|
|
3117 (if (<= (point) lim)
|
|
|
3118 (goto-char (1+ lim)))
|
|
|
3119 (skip-chars-forward " \t"))
|
|
|
3120
|
|
|
3121
|
|
|
3122 (defvar innerloop-done nil)
|
|
|
3123 (defvar last-depth nil)
|
|
|
3124
|
|
|
3125 (defun cperl-indent-exp ()
|
|
|
3126 "Simple variant of indentation of continued-sexp.
|
|
|
3127 Should be slow. Will not indent comment if it starts at `comment-indent'
|
|
|
3128 or looks like continuation of the comment on the previous line."
|
|
|
3129 (interactive)
|
|
|
3130 (save-excursion
|
|
|
3131 (let ((tmp-end (progn (end-of-line) (point))) top done)
|
|
|
3132 (save-excursion
|
|
193
|
3133 (beginning-of-line)
|
|
0
|
3134 (while (null done)
|
|
|
3135 (setq top (point))
|
|
|
3136 (while (= (nth 0 (parse-partial-sexp (point) tmp-end
|
|
|
3137 -1)) -1)
|
|
|
3138 (setq top (point))) ; Get the outermost parenths in line
|
|
|
3139 (goto-char top)
|
|
|
3140 (while (< (point) tmp-end)
|
|
|
3141 (parse-partial-sexp (point) tmp-end nil t) ; To start-sexp or eol
|
|
|
3142 (or (eolp) (forward-sexp 1)))
|
|
|
3143 (if (> (point) tmp-end) (progn (end-of-line) (setq tmp-end (point)))
|
|
|
3144 (setq done t)))
|
|
|
3145 (goto-char tmp-end)
|
|
|
3146 (setq tmp-end (point-marker)))
|
|
|
3147 (cperl-indent-region (point) tmp-end))))
|
|
|
3148
|
|
|
3149 (defun cperl-indent-region (start end)
|
|
|
3150 "Simple variant of indentation of region in CPerl mode.
|
|
|
3151 Should be slow. Will not indent comment if it starts at `comment-indent'
|
|
|
3152 or looks like continuation of the comment on the previous line.
|
|
|
3153 Indents all the lines whose first character is between START and END
|
|
|
3154 inclusive."
|
|
|
3155 (interactive "r")
|
|
|
3156 (save-excursion
|
|
|
3157 (let (st comm indent-info old-comm-indent new-comm-indent
|
|
|
3158 (pm 0) (imenu-scanning-message "Indenting... (%3d%%)"))
|
|
|
3159 (goto-char start)
|
|
|
3160 (setq old-comm-indent (and (cperl-to-comment-or-eol)
|
|
|
3161 (current-column))
|
|
|
3162 new-comm-indent old-comm-indent)
|
|
|
3163 (goto-char start)
|
|
|
3164 (or (bolp) (beginning-of-line 2))
|
|
|
3165 (or (fboundp 'imenu-progress-message)
|
|
|
3166 (message "Indenting... For feedback load `imenu'..."))
|
|
|
3167 (while (and (<= (point) end) (not (eobp))) ; bol to check start
|
|
|
3168 (and (fboundp 'imenu-progress-message)
|
|
|
3169 (imenu-progress-message
|
|
|
3170 pm (/ (* 100 (- (point) start)) (- end start -1))))
|
|
|
3171 (setq st (point)
|
|
|
3172 indent-info nil
|
|
|
3173 ) ; Believe indentation of the current
|
|
|
3174 (if (and (setq comm (looking-at "[ \t]*#"))
|
|
|
3175 (or (eq (current-indentation) (or old-comm-indent
|
|
|
3176 comment-column))
|
|
|
3177 (setq old-comm-indent nil)))
|
|
|
3178 (if (and old-comm-indent
|
|
193
|
3179 (= (current-indentation) old-comm-indent)
|
|
|
3180 (not (eq (get-text-property (point) 'syntax-type) 'pod)))
|
|
0
|
3181 (let ((comment-column new-comm-indent))
|
|
|
3182 (indent-for-comment)))
|
|
|
3183 (progn
|
|
|
3184 (cperl-indent-line 'indent-info)
|
|
|
3185 (or comm
|
|
|
3186 (progn
|
|
|
3187 (if (setq old-comm-indent (and (cperl-to-comment-or-eol)
|
|
193
|
3188 (not (eq (get-text-property (point) 'syntax-type) 'pod))
|
|
0
|
3189 (current-column)))
|
|
|
3190 (progn (indent-for-comment)
|
|
|
3191 (skip-chars-backward " \t")
|
|
|
3192 (skip-chars-backward "#")
|
|
|
3193 (setq new-comm-indent (current-column))))))))
|
|
|
3194 (beginning-of-line 2))
|
|
|
3195 (if (fboundp 'imenu-progress-message)
|
|
|
3196 (imenu-progress-message pm 100)
|
|
|
3197 (message nil)))))
|
|
|
3198
|
|
193
|
3199 ;;(defun cperl-slash-is-regexp (&optional pos)
|
|
|
3200 ;; (save-excursion
|
|
|
3201 ;; (goto-char (if pos pos (1- (point))))
|
|
|
3202 ;; (and
|
|
|
3203 ;; (not (memq (get-text-property (point) 'face)
|
|
|
3204 ;; '(font-lock-string-face font-lock-comment-face)))
|
|
|
3205 ;; (cperl-after-expr-p nil nil '
|
|
|
3206 ;; (or (looking-at "[^]a-zA-Z0-9_)}]")
|
|
|
3207 ;; (eq (get-text-property (point) 'face)
|
|
|
3208 ;; 'font-lock-keyword-face))))))
|
|
0
|
3209
|
|
|
3210 ;; Stolen from lisp-mode with a lot of improvements
|
|
|
3211
|
|
|
3212 (defun cperl-fill-paragraph (&optional justify iteration)
|
|
|
3213 "Like \\[fill-paragraph], but handle CPerl comments.
|
|
|
3214 If any of the current line is a comment, fill the comment or the
|
|
|
3215 block of it that point is in, preserving the comment's initial
|
|
|
3216 indentation and initial hashes. Behaves usually outside of comment."
|
|
|
3217 (interactive "P")
|
|
|
3218 (let (
|
|
|
3219 ;; Non-nil if the current line contains a comment.
|
|
|
3220 has-comment
|
|
|
3221
|
|
|
3222 ;; If has-comment, the appropriate fill-prefix for the comment.
|
|
|
3223 comment-fill-prefix
|
|
|
3224 ;; Line that contains code and comment (or nil)
|
|
|
3225 start
|
|
|
3226 c spaces len dc (comment-column comment-column))
|
|
|
3227 ;; Figure out what kind of comment we are looking at.
|
|
|
3228 (save-excursion
|
|
|
3229 (beginning-of-line)
|
|
|
3230 (cond
|
|
|
3231
|
|
|
3232 ;; A line with nothing but a comment on it?
|
|
|
3233 ((looking-at "[ \t]*#[# \t]*")
|
|
|
3234 (setq has-comment t
|
|
|
3235 comment-fill-prefix (buffer-substring (match-beginning 0)
|
|
|
3236 (match-end 0))))
|
|
|
3237
|
|
|
3238 ;; A line with some code, followed by a comment? Remember that the
|
|
|
3239 ;; semi which starts the comment shouldn't be part of a string or
|
|
|
3240 ;; character.
|
|
|
3241 ((cperl-to-comment-or-eol)
|
|
|
3242 (setq has-comment t)
|
|
|
3243 (looking-at "#+[ \t]*")
|
|
|
3244 (setq start (point) c (current-column)
|
|
|
3245 comment-fill-prefix
|
|
|
3246 (concat (make-string (current-column) ?\ )
|
|
|
3247 (buffer-substring (match-beginning 0) (match-end 0)))
|
|
|
3248 spaces (progn (skip-chars-backward " \t")
|
|
|
3249 (buffer-substring (point) start))
|
|
|
3250 dc (- c (current-column)) len (- start (point))
|
|
|
3251 start (point-marker))
|
|
|
3252 (delete-char len)
|
|
|
3253 (insert (make-string dc ?-)))))
|
|
|
3254 (if (not has-comment)
|
|
|
3255 (fill-paragraph justify) ; Do the usual thing outside of comment
|
|
|
3256 ;; Narrow to include only the comment, and then fill the region.
|
|
|
3257 (save-restriction
|
|
|
3258 (narrow-to-region
|
|
|
3259 ;; Find the first line we should include in the region to fill.
|
|
|
3260 (if start (progn (beginning-of-line) (point))
|
|
|
3261 (save-excursion
|
|
|
3262 (while (and (zerop (forward-line -1))
|
|
|
3263 (looking-at "^[ \t]*#+[ \t]*[^ \t\n#]")))
|
|
|
3264 ;; We may have gone to far. Go forward again.
|
|
|
3265 (or (looking-at "^[ \t]*#+[ \t]*[^ \t\n#]")
|
|
|
3266 (forward-line 1))
|
|
|
3267 (point)))
|
|
|
3268 ;; Find the beginning of the first line past the region to fill.
|
|
|
3269 (save-excursion
|
|
|
3270 (while (progn (forward-line 1)
|
|
|
3271 (looking-at "^[ \t]*#+[ \t]*[^ \t\n#]")))
|
|
|
3272 (point)))
|
|
|
3273 ;; Remove existing hashes
|
|
|
3274 (goto-char (point-min))
|
|
|
3275 (while (progn (forward-line 1) (< (point) (point-max)))
|
|
|
3276 (skip-chars-forward " \t")
|
|
|
3277 (and (looking-at "#+")
|
|
|
3278 (delete-char (- (match-end 0) (match-beginning 0)))))
|
|
|
3279
|
|
|
3280 ;; Lines with only hashes on them can be paragraph boundaries.
|
|
|
3281 (let ((paragraph-start (concat paragraph-start "\\|^[ \t#]*$"))
|
|
|
3282 (paragraph-separate (concat paragraph-start "\\|^[ \t#]*$"))
|
|
|
3283 (fill-prefix comment-fill-prefix))
|
|
|
3284 (fill-paragraph justify)))
|
|
|
3285 (if (and start)
|
|
|
3286 (progn
|
|
|
3287 (goto-char start)
|
|
|
3288 (if (> dc 0)
|
|
|
3289 (progn (delete-char dc) (insert spaces)))
|
|
|
3290 (if (or (= (current-column) c) iteration) nil
|
|
|
3291 (setq comment-column c)
|
|
|
3292 (indent-for-comment)
|
|
|
3293 ;; Repeat once more, flagging as iteration
|
|
|
3294 (cperl-fill-paragraph justify t)))))))
|
|
|
3295
|
|
|
3296 (defun cperl-do-auto-fill ()
|
|
|
3297 ;; Break out if the line is short enough
|
|
|
3298 (if (> (save-excursion
|
|
|
3299 (end-of-line)
|
|
|
3300 (current-column))
|
|
|
3301 fill-column)
|
|
|
3302 (let ((c (save-excursion (beginning-of-line)
|
|
|
3303 (cperl-to-comment-or-eol) (point)))
|
|
|
3304 (s (memq (following-char) '(?\ ?\t))) marker)
|
|
|
3305 (if (>= c (point)) nil
|
|
|
3306 (setq marker (point-marker))
|
|
|
3307 (cperl-fill-paragraph)
|
|
|
3308 (goto-char marker)
|
|
|
3309 ;; Is not enough, sometimes marker is a start of line
|
|
|
3310 (if (bolp) (progn (re-search-forward "#+[ \t]*")
|
|
|
3311 (goto-char (match-end 0))))
|
|
|
3312 ;; Following space could have gone:
|
|
|
3313 (if (or (not s) (memq (following-char) '(?\ ?\t))) nil
|
|
|
3314 (insert " ")
|
|
|
3315 (backward-char 1))
|
|
|
3316 ;; Previous space could have gone:
|
|
|
3317 (or (memq (preceding-char) '(?\ ?\t)) (insert " "))))))
|
|
|
3318
|
|
193
|
3319 ;;(defvar imenu-example--function-name-regexp-perl
|
|
|
3320 ;; (concat
|
|
|
3321 ;; "^\\("
|
|
|
3322 ;; "[ \t]*\\(sub\\|package\\)[ \t\n]+\\([a-zA-Z_0-9:']+\\)[ \t]*\\(([^()]*)[ \t]*\\)?"
|
|
|
3323 ;; "\\|"
|
|
|
3324 ;; "=head\\([12]\\)[ \t]+\\([^\n]+\\)$"
|
|
|
3325 ;; "\\)"))
|
|
|
3326
|
|
|
3327 ;;(defun cperl-imenu-addback (lst &optional isback name)
|
|
|
3328 ;; ;; We suppose that the lst is a DAG, unless the first element only
|
|
|
3329 ;; ;; loops back, and ISBACK is set. Thus this function cannot be
|
|
|
3330 ;; ;; applied twice without ISBACK set.
|
|
|
3331 ;; (cond ((not cperl-imenu-addback) lst)
|
|
|
3332 ;; (t
|
|
|
3333 ;; (or name
|
|
|
3334 ;; (setq name "+++BACK+++"))
|
|
|
3335 ;; (mapcar (function (lambda (elt)
|
|
|
3336 ;; (if (and (listp elt) (listp (cdr elt)))
|
|
|
3337 ;; (progn
|
|
|
3338 ;; ;; In the other order it goes up
|
|
|
3339 ;; ;; one level only ;-(
|
|
|
3340 ;; (setcdr elt (cons (cons name lst)
|
|
|
3341 ;; (cdr elt)))
|
|
|
3342 ;; (cperl-imenu-addback (cdr elt) t name)
|
|
|
3343 ;; ))))
|
|
|
3344 ;; (if isback (cdr lst) lst))
|
|
|
3345 ;; lst)))
|
|
|
3346
|
|
|
3347 ;;(defun imenu-example--create-perl-index (&optional regexp)
|
|
|
3348 ;; (require 'cl)
|
|
|
3349 ;; ;; ####
|
|
|
3350 ;; (require 'imenu) ; May be called from TAGS creator
|
|
|
3351 ;; (let ((index-alist '()) (index-pack-alist '()) (index-pod-alist '())
|
|
|
3352 ;; (index-unsorted-alist '()) (i-s-f (default-value 'imenu-sort-function))
|
|
|
3353 ;; (index-meth-alist '()) meth
|
|
|
3354 ;; packages ends-ranges p
|
|
|
3355 ;; (prev-pos 0) char fchar index index1 name (end-range 0) package)
|
|
|
3356 ;; (goto-char (point-min))
|
|
|
3357 ;; (imenu-progress-message prev-pos 0)
|
|
|
3358 ;; ;; Search for the function
|
|
|
3359 ;; (progn ;;save-match-data
|
|
|
3360 ;; (while (re-search-forward
|
|
|
3361 ;; (or regexp imenu-example--function-name-regexp-perl)
|
|
|
3362 ;; nil t)
|
|
|
3363 ;; (imenu-progress-message prev-pos)
|
|
|
3364 ;; ;;(backward-up-list 1)
|
|
|
3365 ;; (cond
|
|
|
3366 ;; ((and ; Skip some noise if building tags
|
|
|
3367 ;; (match-beginning 2) ; package or sub
|
|
|
3368 ;; (eq (char-after (match-beginning 2)) ?p) ; package
|
|
|
3369 ;; (not (save-match-data
|
|
|
3370 ;; (looking-at "[ \t\n]*;")))) ; Plain text word 'package'
|
|
|
3371 ;; nil)
|
|
|
3372 ;; ((and
|
|
|
3373 ;; (match-beginning 2) ; package or sub
|
|
|
3374 ;; ;; Skip if quoted (will not skip multi-line ''-comments :-():
|
|
|
3375 ;; (null (get-text-property (match-beginning 1) 'syntax-table))
|
|
|
3376 ;; (null (get-text-property (match-beginning 1) 'syntax-type))
|
|
|
3377 ;; (null (get-text-property (match-beginning 1) 'in-pod)))
|
|
|
3378 ;; (save-excursion
|
|
|
3379 ;; (goto-char (match-beginning 2))
|
|
|
3380 ;; (setq fchar (following-char))
|
|
|
3381 ;; )
|
|
|
3382 ;; ;; (if (looking-at "([^()]*)[ \t\n\f]*")
|
|
|
3383 ;; ;; (goto-char (match-end 0))) ; Messes what follows
|
|
|
3384 ;; (setq char (following-char)
|
|
|
3385 ;; meth nil
|
|
|
3386 ;; p (point))
|
|
|
3387 ;; (while (and ends-ranges (>= p (car ends-ranges)))
|
|
|
3388 ;; ;; delete obsolete entries
|
|
|
3389 ;; (setq ends-ranges (cdr ends-ranges) packages (cdr packages)))
|
|
|
3390 ;; (setq package (or (car packages) "")
|
|
|
3391 ;; end-range (or (car ends-ranges) 0))
|
|
|
3392 ;; (if (eq fchar ?p)
|
|
|
3393 ;; (setq name (buffer-substring (match-beginning 3) (match-end 3))
|
|
|
3394 ;; name (progn
|
|
|
3395 ;; (set-text-properties 0 (length name) nil name)
|
|
|
3396 ;; name)
|
|
|
3397 ;; package (concat name "::")
|
|
|
3398 ;; name (concat "package " name)
|
|
|
3399 ;; end-range
|
|
|
3400 ;; (save-excursion
|
|
|
3401 ;; (parse-partial-sexp (point) (point-max) -1) (point))
|
|
|
3402 ;; ends-ranges (cons end-range ends-ranges)
|
|
|
3403 ;; packages (cons package packages)))
|
|
|
3404 ;; ;; )
|
|
|
3405 ;; ;; Skip this function name if it is a prototype declaration.
|
|
|
3406 ;; (if (and (eq fchar ?s) (eq char ?\;)) nil
|
|
|
3407 ;; (setq index (imenu-example--name-and-position))
|
|
|
3408 ;; (if (eq fchar ?p) nil
|
|
|
3409 ;; (setq name (buffer-substring (match-beginning 3) (match-end 3)))
|
|
|
3410 ;; (set-text-properties 0 (length name) nil name)
|
|
|
3411 ;; (cond ((string-match "[:']" name)
|
|
|
3412 ;; (setq meth t))
|
|
|
3413 ;; ((> p end-range) nil)
|
|
|
3414 ;; (t
|
|
|
3415 ;; (setq name (concat package name) meth t))))
|
|
|
3416 ;; (setcar index name)
|
|
|
3417 ;; (if (eq fchar ?p)
|
|
|
3418 ;; (push index index-pack-alist)
|
|
|
3419 ;; (push index index-alist))
|
|
|
3420 ;; (if meth (push index index-meth-alist))
|
|
|
3421 ;; (push index index-unsorted-alist)))
|
|
|
3422 ;; ((match-beginning 5) ; Pod section
|
|
|
3423 ;; ;; (beginning-of-line)
|
|
|
3424 ;; (setq index (imenu-example--name-and-position)
|
|
|
3425 ;; name (buffer-substring (match-beginning 6) (match-end 6)))
|
|
|
3426 ;; (set-text-properties 0 (length name) nil name)
|
|
|
3427 ;; (if (eq (char-after (match-beginning 5)) ?2)
|
|
|
3428 ;; (setq name (concat " " name)))
|
|
|
3429 ;; (setcar index name)
|
|
|
3430 ;; (setq index1 (cons (concat "=" name) (cdr index)))
|
|
|
3431 ;; (push index index-pod-alist)
|
|
|
3432 ;; (push index1 index-unsorted-alist)))))
|
|
|
3433 ;; (imenu-progress-message prev-pos 100)
|
|
|
3434 ;; (setq index-alist
|
|
|
3435 ;; (if (default-value 'imenu-sort-function)
|
|
|
3436 ;; (sort index-alist (default-value 'imenu-sort-function))
|
|
|
3437 ;; (nreverse index-alist)))
|
|
|
3438 ;; (and index-pod-alist
|
|
|
3439 ;; (push (cons "+POD headers+..."
|
|
|
3440 ;; (nreverse index-pod-alist))
|
|
|
3441 ;; index-alist))
|
|
|
3442 ;; (and (or index-pack-alist index-meth-alist)
|
|
|
3443 ;; (let ((lst index-pack-alist) hier-list pack elt group name)
|
|
|
3444 ;; ;; Remove "package ", reverse and uniquify.
|
|
|
3445 ;; (while lst
|
|
|
3446 ;; (setq elt (car lst) lst (cdr lst) name (substring (car elt) 8))
|
|
|
3447 ;; (if (assoc name hier-list) nil
|
|
|
3448 ;; (setq hier-list (cons (cons name (cdr elt)) hier-list))))
|
|
|
3449 ;; (setq lst index-meth-alist)
|
|
|
3450 ;; (while lst
|
|
|
3451 ;; (setq elt (car lst) lst (cdr lst))
|
|
|
3452 ;; (cond ((string-match "\\(::\\|'\\)[_a-zA-Z0-9]+$" (car elt))
|
|
|
3453 ;; (setq pack (substring (car elt) 0 (match-beginning 0)))
|
|
|
3454 ;; (if (setq group (assoc pack hier-list))
|
|
|
3455 ;; (if (listp (cdr group))
|
|
|
3456 ;; ;; Have some functions already
|
|
|
3457 ;; (setcdr group
|
|
|
3458 ;; (cons (cons (substring
|
|
|
3459 ;; (car elt)
|
|
|
3460 ;; (+ 2 (match-beginning 0)))
|
|
|
3461 ;; (cdr elt))
|
|
|
3462 ;; (cdr group)))
|
|
|
3463 ;; (setcdr group (list (cons (substring
|
|
|
3464 ;; (car elt)
|
|
|
3465 ;; (+ 2 (match-beginning 0)))
|
|
|
3466 ;; (cdr elt)))))
|
|
|
3467 ;; (setq hier-list
|
|
|
3468 ;; (cons (cons pack
|
|
|
3469 ;; (list (cons (substring
|
|
|
3470 ;; (car elt)
|
|
|
3471 ;; (+ 2 (match-beginning 0)))
|
|
|
3472 ;; (cdr elt))))
|
|
|
3473 ;; hier-list))))))
|
|
|
3474 ;; (push (cons "+Hierarchy+..."
|
|
|
3475 ;; hier-list)
|
|
|
3476 ;; index-alist)))
|
|
|
3477 ;; (and index-pack-alist
|
|
|
3478 ;; (push (cons "+Packages+..."
|
|
|
3479 ;; (nreverse index-pack-alist))
|
|
|
3480 ;; index-alist))
|
|
|
3481 ;; (and (or index-pack-alist index-pod-alist
|
|
|
3482 ;; (default-value 'imenu-sort-function))
|
|
|
3483 ;; index-unsorted-alist
|
|
|
3484 ;; (push (cons "+Unsorted List+..."
|
|
|
3485 ;; (nreverse index-unsorted-alist))
|
|
|
3486 ;; index-alist))
|
|
|
3487 ;; (cperl-imenu-addback index-alist)))
|
|
0
|
3488
|
|
|
3489 (defvar cperl-compilation-error-regexp-alist
|
|
|
3490 ;; This look like a paranoiac regexp: could anybody find a better one? (which WORK).
|
|
|
3491 '(("^[^\n]* \\(file\\|at\\) \\([^ \t\n]+\\) [^\n]*line \\([0-9]+\\)[\\., \n]"
|
|
|
3492 2 3))
|
|
|
3493 "Alist that specifies how to match errors in perl output.")
|
|
|
3494
|
|
|
3495 (if (fboundp 'eval-after-load)
|
|
|
3496 (eval-after-load
|
|
|
3497 "mode-compile"
|
|
|
3498 '(setq perl-compilation-error-regexp-alist
|
|
|
3499 cperl-compilation-error-regexp-alist)))
|
|
|
3500
|
|
|
3501
|
|
|
3502 (defvar cperl-faces-init nil)
|
|
|
3503
|
|
|
3504 (defun cperl-windowed-init ()
|
|
|
3505 "Initialization under windowed version."
|
|
|
3506 (add-hook 'font-lock-mode-hook
|
|
|
3507 (function
|
|
|
3508 (lambda ()
|
|
|
3509 (if (or
|
|
|
3510 (eq major-mode 'perl-mode)
|
|
|
3511 (eq major-mode 'cperl-mode))
|
|
|
3512 (progn
|
|
|
3513 (or cperl-faces-init (cperl-init-faces))))))))
|
|
|
3514
|
|
|
3515 (defvar perl-font-lock-keywords-1 nil
|
|
|
3516 "Additional expressions to highlight in Perl mode. Minimal set.")
|
|
|
3517 (defvar perl-font-lock-keywords nil
|
|
|
3518 "Additional expressions to highlight in Perl mode. Default set.")
|
|
|
3519 (defvar perl-font-lock-keywords-2 nil
|
|
|
3520 "Additional expressions to highlight in Perl mode. Maximal set")
|
|
|
3521
|
|
|
3522 (defun cperl-init-faces ()
|
|
|
3523 (condition-case nil
|
|
|
3524 (progn
|
|
|
3525 (require 'font-lock)
|
|
|
3526 (and (fboundp 'font-lock-fontify-anchored-keywords)
|
|
|
3527 (featurep 'font-lock-extra)
|
|
|
3528 (message "You have an obsolete package `font-lock-extra'. Install `choose-color'."))
|
|
|
3529 (let (t-font-lock-keywords t-font-lock-keywords-1 font-lock-anchored)
|
|
|
3530 ;;(defvar cperl-font-lock-enhanced nil
|
|
|
3531 ;; "Set to be non-nil if font-lock allows active highlights.")
|
|
|
3532 (if (fboundp 'font-lock-fontify-anchored-keywords)
|
|
|
3533 (setq font-lock-anchored t))
|
|
|
3534 (setq
|
|
|
3535 t-font-lock-keywords
|
|
|
3536 (list
|
|
|
3537 (cons
|
|
|
3538 (concat
|
|
|
3539 "\\(^\\|[^$@%&\\]\\)\\<\\("
|
|
|
3540 (mapconcat
|
|
|
3541 'identity
|
|
|
3542 '("if" "until" "while" "elsif" "else" "unless" "for"
|
|
|
3543 "foreach" "continue" "exit" "die" "last" "goto" "next"
|
|
|
3544 "redo" "return" "local" "exec" "sub" "do" "dump" "use"
|
|
|
3545 "require" "package" "eval" "my" "BEGIN" "END")
|
|
|
3546 "\\|") ; Flow control
|
|
|
3547 "\\)\\>") 2) ; was "\\)[ \n\t;():,\|&]"
|
|
|
3548 ; In what follows we use `type' style
|
|
4
|
3549 ; for overwritable builtins
|
|
0
|
3550 (list
|
|
|
3551 (concat
|
|
|
3552 "\\(^\\|[^$@%&\\]\\)\\<\\("
|
|
4
|
3553 ;; "CORE" "__FILE__" "__LINE__" "abs" "accept" "alarm"
|
|
|
3554 ;; "and" "atan2" "bind" "binmode" "bless" "caller"
|
|
|
3555 ;; "chdir" "chmod" "chown" "chr" "chroot" "close"
|
|
|
3556 ;; "closedir" "cmp" "connect" "continue" "cos" "crypt"
|
|
|
3557 ;; "dbmclose" "dbmopen" "die" "dump" "endgrent"
|
|
|
3558 ;; "endhostent" "endnetent" "endprotoent" "endpwent"
|
|
|
3559 ;; "endservent" "eof" "eq" "exec" "exit" "exp" "fcntl"
|
|
|
3560 ;; "fileno" "flock" "fork" "formline" "ge" "getc"
|
|
|
3561 ;; "getgrent" "getgrgid" "getgrnam" "gethostbyaddr"
|
|
|
3562 ;; "gethostbyname" "gethostent" "getlogin"
|
|
|
3563 ;; "getnetbyaddr" "getnetbyname" "getnetent"
|
|
|
3564 ;; "getpeername" "getpgrp" "getppid" "getpriority"
|
|
|
3565 ;; "getprotobyname" "getprotobynumber" "getprotoent"
|
|
|
3566 ;; "getpwent" "getpwnam" "getpwuid" "getservbyname"
|
|
|
3567 ;; "getservbyport" "getservent" "getsockname"
|
|
|
3568 ;; "getsockopt" "glob" "gmtime" "gt" "hex" "index" "int"
|
|
|
3569 ;; "ioctl" "join" "kill" "lc" "lcfirst" "le" "length"
|
|
|
3570 ;; "link" "listen" "localtime" "log" "lstat" "lt"
|
|
|
3571 ;; "mkdir" "msgctl" "msgget" "msgrcv" "msgsnd" "ne"
|
|
|
3572 ;; "not" "oct" "open" "opendir" "or" "ord" "pack" "pipe"
|
|
|
3573 ;; "quotemeta" "rand" "read" "readdir" "readline"
|
|
|
3574 ;; "readlink" "readpipe" "recv" "ref" "rename" "require"
|
|
|
3575 ;; "reset" "reverse" "rewinddir" "rindex" "rmdir" "seek"
|
|
|
3576 ;; "seekdir" "select" "semctl" "semget" "semop" "send"
|
|
|
3577 ;; "setgrent" "sethostent" "setnetent" "setpgrp"
|
|
|
3578 ;; "setpriority" "setprotoent" "setpwent" "setservent"
|
|
|
3579 ;; "setsockopt" "shmctl" "shmget" "shmread" "shmwrite"
|
|
|
3580 ;; "shutdown" "sin" "sleep" "socket" "socketpair"
|
|
|
3581 ;; "sprintf" "sqrt" "srand" "stat" "substr" "symlink"
|
|
|
3582 ;; "syscall" "sysread" "system" "syswrite" "tell"
|
|
|
3583 ;; "telldir" "time" "times" "truncate" "uc" "ucfirst"
|
|
|
3584 ;; "umask" "unlink" "unpack" "utime" "values" "vec"
|
|
|
3585 ;; "wait" "waitpid" "wantarray" "warn" "write" "x" "xor"
|
|
0
|
3586 "a\\(bs\\|ccept\\|tan2\\|larm\\|nd\\)\\|"
|
|
|
3587 "b\\(in\\(d\\|mode\\)\\|less\\)\\|"
|
|
|
3588 "c\\(h\\(r\\(\\|oot\\)\\|dir\\|mod\\|own\\)\\|aller\\|rypt\\|"
|
|
|
3589 "lose\\(\\|dir\\)\\|mp\\|o\\(s\\|n\\(tinue\\|nect\\)\\)\\)\\|"
|
|
|
3590 "CORE\\|d\\(ie\\|bm\\(close\\|open\\)\\|ump\\)\\|"
|
|
|
3591 "e\\(x\\(p\\|it\\|ec\\)\\|q\\|nd\\(p\\(rotoent\\|went\\)\\|"
|
|
|
3592 "hostent\\|servent\\|netent\\|grent\\)\\|of\\)\\|"
|
|
|
3593 "f\\(ileno\\|cntl\\|lock\\|or\\(k\\|mline\\)\\)\\|"
|
|
|
3594 "g\\(t\\|lob\\|mtime\\|e\\(\\|t\\(p\\(pid\\|r\\(iority\\|"
|
|
|
3595 "oto\\(byn\\(ame\\|umber\\)\\|ent\\)\\)\\|eername\\|w"
|
|
|
3596 "\\(uid\\|ent\\|nam\\)\\|grp\\)\\|host\\(by\\(addr\\|name\\)\\|"
|
|
|
3597 "ent\\)\\|s\\(erv\\(by\\(port\\|name\\)\\|ent\\)\\|"
|
|
|
3598 "ock\\(name\\|opt\\)\\)\\|c\\|login\\|net\\(by\\(addr\\|name\\)\\|"
|
|
|
3599 "ent\\)\\|gr\\(ent\\|nam\\|gid\\)\\)\\)\\)\\|"
|
|
|
3600 "hex\\|i\\(n\\(t\\|dex\\)\\|octl\\)\\|join\\|kill\\|"
|
|
|
3601 "l\\(i\\(sten\\|nk\\)\\|stat\\|c\\(\\|first\\)\\|t\\|e"
|
|
|
3602 "\\(\\|ngth\\)\\|o\\(caltime\\|g\\)\\)\\|m\\(sg\\(rcv\\|snd\\|"
|
|
|
3603 "ctl\\|get\\)\\|kdir\\)\\|n\\(e\\|ot\\)\\|o\\(pen\\(\\|dir\\)\\|"
|
|
|
3604 "r\\(\\|d\\)\\|ct\\)\\|p\\(ipe\\|ack\\)\\|quotemeta\\|"
|
|
|
3605 "r\\(index\\|and\\|mdir\\|e\\(quire\\|ad\\(pipe\\|\\|lin"
|
|
|
3606 "\\(k\\|e\\)\\|dir\\)\\|set\\|cv\\|verse\\|f\\|winddir\\|name"
|
|
|
3607 "\\)\\)\\|s\\(printf\\|qrt\\|rand\\|tat\\|ubstr\\|e\\(t\\(p\\(r"
|
|
|
3608 "\\(iority\\|otoent\\)\\|went\\|grp\\)\\|hostent\\|s\\(ervent\\|"
|
|
|
3609 "ockopt\\)\\|netent\\|grent\\)\\|ek\\(\\|dir\\)\\|lect\\|"
|
|
|
3610 "m\\(ctl\\|op\\|get\\)\\|nd\\)\\|h\\(utdown\\|m\\(read\\|ctl\\|"
|
|
|
3611 "write\\|get\\)\\)\\|y\\(s\\(read\\|call\\|tem\\|write\\)\\|"
|
|
|
3612 "mlink\\)\\|in\\|leep\\|ocket\\(pair\\|\\)\\)\\|t\\(runcate\\|"
|
|
|
3613 "ell\\(\\|dir\\)\\|ime\\(\\|s\\)\\)\\|u\\(c\\(\\|first\\)\\|"
|
|
|
3614 "time\\|mask\\|n\\(pack\\|link\\)\\)\\|v\\(alues\\|ec\\)\\|"
|
|
|
3615 "w\\(a\\(rn\\|it\\(pid\\|\\)\\|ntarray\\)\\|rite\\)\\|"
|
|
193
|
3616 "x\\(\\|or\\)\\|__\\(FILE__\\|LINE__\\|PACKAGE__\\)"
|
|
0
|
3617 "\\)\\>") 2 'font-lock-type-face)
|
|
|
3618 ;; In what follows we use `other' style
|
|
4
|
3619 ;; for nonoverwritable builtins
|
|
|
3620 ;; Somehow 's', 'm' are not auto-generated???
|
|
0
|
3621 (list
|
|
|
3622 (concat
|
|
|
3623 "\\(^\\|[^$@%&\\]\\)\\<\\("
|
|
4
|
3624 ;; "AUTOLOAD" "BEGIN" "DESTROY" "END" "__END__" "chomp"
|
|
|
3625 ;; "chop" "defined" "delete" "do" "each" "else" "elsif"
|
|
|
3626 ;; "eval" "exists" "for" "foreach" "format" "goto"
|
|
|
3627 ;; "grep" "if" "keys" "last" "local" "map" "my" "next"
|
|
|
3628 ;; "no" "package" "pop" "pos" "print" "printf" "push"
|
|
|
3629 ;; "q" "qq" "qw" "qx" "redo" "return" "scalar" "shift"
|
|
|
3630 ;; "sort" "splice" "split" "study" "sub" "tie" "tr"
|
|
|
3631 ;; "undef" "unless" "unshift" "untie" "until" "use"
|
|
|
3632 ;; "while" "y"
|
|
0
|
3633 "AUTOLOAD\\|BEGIN\\|cho\\(p\\|mp\\)\\|d\\(e\\(fined\\|lete\\)\\|"
|
|
|
3634 "o\\)\\|DESTROY\\|e\\(ach\\|val\\|xists\\|ls\\(e\\|if\\)\\)\\|"
|
|
|
3635 "END\\|for\\(\\|each\\|mat\\)\\|g\\(rep\\|oto\\)\\|if\\|keys\\|"
|
|
|
3636 "l\\(ast\\|ocal\\)\\|m\\(ap\\|y\\)\\|n\\(ext\\|o\\)\\|"
|
|
|
3637 "p\\(ackage\\|rint\\(\\|f\\)\\|ush\\|o\\(p\\|s\\)\\)\\|"
|
|
|
3638 "q\\(\\|q\\|w\\|x\\)\\|re\\(turn\\|do\\)\\|s\\(pli\\(ce\\|t\\)\\|"
|
|
|
3639 "calar\\|tudy\\|ub\\|hift\\|ort\\)\\|t\\(r\\|ie\\)\\|"
|
|
|
3640 "u\\(se\\|n\\(shift\\|ti\\(l\\|e\\)\\|def\\|less\\)\\)\\|"
|
|
|
3641 "while\\|y\\|__\\(END\\|DATA\\)__" ;__DATA__ added manually
|
|
|
3642 "\\|[sm]" ; Added manually
|
|
|
3643 "\\)\\>") 2 'font-lock-other-type-face)
|
|
|
3644 ;; (mapconcat 'identity
|
|
|
3645 ;; '("#endif" "#else" "#ifdef" "#ifndef" "#if"
|
|
|
3646 ;; "#include" "#define" "#undef")
|
|
|
3647 ;; "\\|")
|
|
|
3648 '("-[rwxoRWXOezsfdlpSbctugkTBMAC]\\>\\([ \t]+_\\>\\)?" 0
|
|
4
|
3649 font-lock-function-name-face keep) ; Not very good, triggers at "[a-z]"
|
|
193
|
3650 '("\\<sub[ \t]+\\([^ \t{;]+\\)[ \t]*\\(([^()]*)[ \t]*\\)?[#{\n]" 1
|
|
0
|
3651 font-lock-function-name-face)
|
|
|
3652 '("\\<\\(package\\|require\\|use\\|import\\|no\\|bootstrap\\)[ \t]+\\([a-zA-z_][a-zA-z_0-9:]*\\)[ \t;]" ; require A if B;
|
|
|
3653 2 font-lock-function-name-face)
|
|
4
|
3654 '("^[ \t]*format[ \t]+\\([a-zA-z_][a-zA-z_0-9:]*\\)[ \t]*=[ \t]*$"
|
|
|
3655 1 font-lock-function-name-face)
|
|
0
|
3656 (cond ((featurep 'font-lock-extra)
|
|
|
3657 '("\\([]}\\\\%@>*&]\\|\\$[a-zA-Z0-9_:]*\\)[ \t]*{[ \t]*\\(-?[a-zA-Z0-9_:]+\\)[ \t]*}"
|
|
|
3658 (2 font-lock-string-face t)
|
|
|
3659 (0 '(restart 2 t)))) ; To highlight $a{bc}{ef}
|
|
|
3660 (font-lock-anchored
|
|
|
3661 '("\\([]}\\\\%@>*&]\\|\\$[a-zA-Z0-9_:]*\\)[ \t]*{[ \t]*\\(-?[a-zA-Z0-9_:]+\\)[ \t]*}"
|
|
|
3662 (2 font-lock-string-face t)
|
|
|
3663 ("\\=[ \t]*{[ \t]*\\(-?[a-zA-Z0-9_:]+\\)[ \t]*}"
|
|
|
3664 nil nil
|
|
|
3665 (1 font-lock-string-face t))))
|
|
|
3666 (t '("\\([]}\\\\%@>*&]\\|\\$[a-zA-Z0-9_:]*\\)[ \t]*{[ \t]*\\(-?[a-zA-Z0-9_:]+\\)[ \t]*}"
|
|
|
3667 2 font-lock-string-face t)))
|
|
|
3668 '("[ \t{,(]\\(-?[a-zA-Z0-9_:]+\\)[ \t]*=>" 1
|
|
|
3669 font-lock-string-face t)
|
|
|
3670 '("^[ \t]*\\([a-zA-Z0-9_]+[ \t]*:\\)[ \t]*\\($\\|{\\|\\<\\(until\\|while\\|for\\(each\\)?\\|do\\)\\>\\)" 1
|
|
|
3671 font-lock-reference-face) ; labels
|
|
|
3672 '("\\<\\(continue\\|next\\|last\\|redo\\|goto\\)\\>[ \t]+\\([a-zA-Z0-9_:]+\\)" ; labels as targets
|
|
|
3673 2 font-lock-reference-face)
|
|
|
3674 (cond ((featurep 'font-lock-extra)
|
|
|
3675 '("^[ \t]*\\(my\\|local\\)[ \t]*\\(([ \t]*\\)?\\([$@%*][a-zA-Z0-9_:]+\\)\\([ \t]*,\\)?"
|
|
|
3676 (3 font-lock-variable-name-face)
|
|
|
3677 (4 '(another 4 nil
|
|
|
3678 ("\\=[ \t]*,[ \t]*\\([$@%*][a-zA-Z0-9_:]+\\)\\([ \t]*,\\)?"
|
|
|
3679 (1 font-lock-variable-name-face)
|
|
|
3680 (2 '(restart 2 nil) nil t)))
|
|
|
3681 nil t))) ; local variables, multiple
|
|
|
3682 (font-lock-anchored
|
|
193
|
3683 '("^[ \t{}]*\\(my\\|local\\)[ \t]*\\(([ \t]*\\)?\\([$@%*][a-zA-Z0-9_:]+\\)"
|
|
0
|
3684 (3 font-lock-variable-name-face)
|
|
|
3685 ("\\=[ \t]*,[ \t]*\\([$@%*][a-zA-Z0-9_:]+\\)"
|
|
|
3686 nil nil
|
|
|
3687 (1 font-lock-variable-name-face))))
|
|
193
|
3688 (t '("^[ \t{}]*\\(my\\|local\\)[ \t]*\\(([ \t]*\\)?\\([$@%*][a-zA-Z0-9_:]+\\)"
|
|
0
|
3689 3 font-lock-variable-name-face)))
|
|
|
3690 '("\\<for\\(each\\)?[ \t]*\\(\\$[a-zA-Z_][a-zA-Z_0-9]*\\)[ \t]*("
|
|
|
3691 2 font-lock-variable-name-face)))
|
|
|
3692 (setq
|
|
|
3693 t-font-lock-keywords-1
|
|
|
3694 (and (fboundp 'turn-on-font-lock) ; Check for newer font-lock
|
|
4
|
3695 (not cperl-xemacs-p) ; not yet as of XEmacs 19.12
|
|
|
3696 '(
|
|
|
3697 ("\\(\\([@%]\\|\$#\\)[a-zA-Z_:][a-zA-Z0-9_:]*\\)" 1
|
|
|
3698 (if (eq (char-after (match-beginning 2)) ?%)
|
|
|
3699 font-lock-other-emphasized-face
|
|
|
3700 font-lock-emphasized-face)
|
|
|
3701 t) ; arrays and hashes
|
|
|
3702 ("\\(\\([$@]+\\)[a-zA-Z_:][a-zA-Z0-9_:]*\\)[ \t]*\\([[{]\\)"
|
|
0
|
3703 1
|
|
|
3704 (if (= (- (match-end 2) (match-beginning 2)) 1)
|
|
|
3705 (if (eq (char-after (match-beginning 3)) ?{)
|
|
|
3706 font-lock-other-emphasized-face
|
|
|
3707 font-lock-emphasized-face) ; arrays and hashes
|
|
|
3708 font-lock-variable-name-face) ; Just to put something
|
|
|
3709 t)
|
|
|
3710 ;;("\\([smy]\\|tr\\)\\([^a-z_A-Z0-9]\\)\\(\\([^\n\\]*||\\)\\)\\2")
|
|
|
3711 ;;; Too much noise from \s* @s[ and friends
|
|
|
3712 ;;("\\(\\<\\([msy]\\|tr\\)[ \t]*\\([^ \t\na-zA-Z0-9_]\\)\\|\\(/\\)\\)"
|
|
|
3713 ;;(3 font-lock-function-name-face t t)
|
|
|
3714 ;;(4
|
|
|
3715 ;; (if (cperl-slash-is-regexp)
|
|
|
3716 ;; font-lock-function-name-face 'default) nil t))
|
|
|
3717 )))
|
|
|
3718 (setq perl-font-lock-keywords-1 t-font-lock-keywords
|
|
|
3719 perl-font-lock-keywords perl-font-lock-keywords-1
|
|
|
3720 perl-font-lock-keywords-2 (append
|
|
|
3721 t-font-lock-keywords
|
|
|
3722 t-font-lock-keywords-1)))
|
|
|
3723 (if (fboundp 'ps-print-buffer) (cperl-ps-print-init))
|
|
|
3724 (if (or (featurep 'choose-color) (featurep 'font-lock-extra))
|
|
|
3725 (font-lock-require-faces
|
|
|
3726 (list
|
|
|
3727 ;; Color-light Color-dark Gray-light Gray-dark Mono
|
|
|
3728 (list 'font-lock-comment-face
|
|
|
3729 ["Firebrick" "OrangeRed" "DimGray" "Gray80"]
|
|
|
3730 nil
|
|
|
3731 [nil nil t t t]
|
|
|
3732 [nil nil t t t]
|
|
|
3733 nil)
|
|
|
3734 (list 'font-lock-string-face
|
|
|
3735 ["RosyBrown" "LightSalmon" "Gray50" "LightGray"]
|
|
|
3736 nil
|
|
|
3737 nil
|
|
|
3738 [nil nil t t t]
|
|
|
3739 nil)
|
|
|
3740 (list 'font-lock-keyword-face
|
|
|
3741 ["Purple" "LightSteelBlue" "DimGray" "Gray90"]
|
|
|
3742 nil
|
|
|
3743 [nil nil t t t]
|
|
|
3744 nil
|
|
|
3745 nil)
|
|
|
3746 (list 'font-lock-function-name-face
|
|
|
3747 (vector
|
|
|
3748 "Blue" "LightSkyBlue" "Gray50" "LightGray"
|
|
|
3749 (cdr (assq 'background-color ; if mono
|
|
|
3750 (frame-parameters))))
|
|
|
3751 (vector
|
|
|
3752 nil nil nil nil
|
|
|
3753 (cdr (assq 'foreground-color ; if mono
|
|
|
3754 (frame-parameters))))
|
|
|
3755 [nil nil t t t]
|
|
|
3756 nil
|
|
|
3757 nil)
|
|
|
3758 (list 'font-lock-variable-name-face
|
|
|
3759 ["DarkGoldenrod" "LightGoldenrod" "DimGray" "Gray90"]
|
|
|
3760 nil
|
|
|
3761 [nil nil t t t]
|
|
|
3762 [nil nil t t t]
|
|
|
3763 nil)
|
|
|
3764 (list 'font-lock-type-face
|
|
|
3765 ["DarkOliveGreen" "PaleGreen" "DimGray" "Gray80"]
|
|
|
3766 nil
|
|
|
3767 [nil nil t t t]
|
|
|
3768 nil
|
|
|
3769 [nil nil t t t]
|
|
|
3770 )
|
|
|
3771 (list 'font-lock-reference-face
|
|
|
3772 ["CadetBlue" "Aquamarine" "Gray50" "LightGray"]
|
|
|
3773 nil
|
|
|
3774 [nil nil t t t]
|
|
|
3775 nil
|
|
|
3776 [nil nil t t t]
|
|
|
3777 )
|
|
|
3778 (list 'font-lock-other-type-face
|
|
|
3779 ["chartreuse3" ("orchid1" "orange")
|
|
|
3780 nil "Gray80"]
|
|
|
3781 [nil nil "gray90"]
|
|
|
3782 [nil nil nil t t]
|
|
|
3783 [nil nil t t]
|
|
|
3784 [nil nil t t t]
|
|
|
3785 )
|
|
|
3786 (list 'font-lock-emphasized-face
|
|
|
3787 ["blue" "yellow" nil "Gray80"]
|
|
|
3788 ["lightyellow2" ("navy" "os2blue" "darkgreen")
|
|
|
3789 "gray90"]
|
|
|
3790 t
|
|
|
3791 nil
|
|
|
3792 nil)
|
|
|
3793 (list 'font-lock-other-emphasized-face
|
|
|
3794 ["red" "red" nil "Gray80"]
|
|
|
3795 ["lightyellow2" ("navy" "os2blue" "darkgreen")
|
|
|
3796 "gray90"]
|
|
|
3797 t
|
|
|
3798 t
|
|
|
3799 nil)))
|
|
|
3800 (defvar cperl-guessed-background nil
|
|
|
3801 "Display characteristics as guessed by cperl.")
|
|
|
3802 (or (fboundp 'x-color-defined-p)
|
|
|
3803 (defalias 'x-color-defined-p
|
|
|
3804 (cond ((fboundp 'color-defined-p) 'color-defined-p)
|
|
|
3805 ;; XEmacs >= 19.12
|
|
|
3806 ((fboundp 'valid-color-name-p) 'valid-color-name-p)
|
|
|
3807 ;; XEmacs 19.11
|
|
|
3808 (t 'x-valid-color-name-p))))
|
|
|
3809 (defvar font-lock-reference-face 'font-lock-reference-face)
|
|
|
3810 (defvar font-lock-variable-name-face 'font-lock-variable-name-face)
|
|
|
3811 (or (boundp 'font-lock-type-face)
|
|
|
3812 (defconst font-lock-type-face
|
|
|
3813 'font-lock-type-face
|
|
|
3814 "Face to use for data types.")
|
|
|
3815 )
|
|
|
3816 (or (boundp 'font-lock-other-type-face)
|
|
|
3817 (defconst font-lock-other-type-face
|
|
|
3818 'font-lock-other-type-face
|
|
|
3819 "Face to use for data types from another group.")
|
|
|
3820 )
|
|
4
|
3821 (if (not cperl-xemacs-p) nil
|
|
0
|
3822 (or (boundp 'font-lock-comment-face)
|
|
|
3823 (defconst font-lock-comment-face
|
|
|
3824 'font-lock-comment-face
|
|
|
3825 "Face to use for comments.")
|
|
|
3826 )
|
|
|
3827 (or (boundp 'font-lock-keyword-face)
|
|
|
3828 (defconst font-lock-keyword-face
|
|
|
3829 'font-lock-keyword-face
|
|
|
3830 "Face to use for keywords.")
|
|
|
3831 )
|
|
|
3832 (or (boundp 'font-lock-function-name-face)
|
|
|
3833 (defconst font-lock-function-name-face
|
|
|
3834 'font-lock-function-name-face
|
|
|
3835 "Face to use for function names.")
|
|
|
3836 )
|
|
|
3837 )
|
|
|
3838 ;;(if (featurep 'font-lock)
|
|
|
3839 (if (face-equal font-lock-type-face font-lock-comment-face)
|
|
|
3840 (defconst font-lock-type-face
|
|
|
3841 'font-lock-type-face
|
|
|
3842 "Face to use for basic data types.")
|
|
|
3843 )
|
|
|
3844 ;;; (if (fboundp 'eval-after-load)
|
|
|
3845 ;;; (eval-after-load "font-lock"
|
|
|
3846 ;;; '(if (face-equal font-lock-type-face
|
|
|
3847 ;;; font-lock-comment-face)
|
|
|
3848 ;;; (defconst font-lock-type-face
|
|
|
3849 ;;; 'font-lock-type-face
|
|
|
3850 ;;; "Face to use for basic data types.")
|
|
|
3851 ;;; ))) ; This does not work :-( Why?!
|
|
|
3852 ;;; ; Workaround: added to font-lock-m-h
|
|
|
3853 ;;; )
|
|
|
3854 (or (boundp 'font-lock-other-emphasized-face)
|
|
|
3855 (defconst font-lock-other-emphasized-face
|
|
|
3856 'font-lock-other-emphasized-face
|
|
|
3857 "Face to use for another type of emphasizing.")
|
|
|
3858 )
|
|
|
3859 (or (boundp 'font-lock-emphasized-face)
|
|
|
3860 (defconst font-lock-emphasized-face
|
|
|
3861 'font-lock-emphasized-face
|
|
|
3862 "Face to use for emphasizing.")
|
|
|
3863 )
|
|
|
3864 ;; Here we try to guess background
|
|
|
3865 (let ((background
|
|
|
3866 (if (boundp 'font-lock-background-mode)
|
|
|
3867 font-lock-background-mode
|
|
|
3868 'light))
|
|
|
3869 (face-list (and (fboundp 'face-list) (face-list)))
|
|
|
3870 is-face)
|
|
|
3871 (fset 'is-face
|
|
|
3872 (cond ((fboundp 'find-face)
|
|
|
3873 (symbol-function 'find-face))
|
|
|
3874 (face-list
|
|
|
3875 (function (lambda (face) (member face face-list))))
|
|
|
3876 (t
|
|
|
3877 (function (lambda (face) (boundp face))))))
|
|
|
3878 (defvar cperl-guessed-background
|
|
|
3879 (if (and (boundp 'font-lock-display-type)
|
|
|
3880 (eq font-lock-display-type 'grayscale))
|
|
|
3881 'gray
|
|
|
3882 background)
|
|
|
3883 "Background as guessed by CPerl mode")
|
|
|
3884 (if (is-face 'font-lock-type-face) nil
|
|
|
3885 (copy-face 'default 'font-lock-type-face)
|
|
|
3886 (cond
|
|
|
3887 ((eq background 'light)
|
|
|
3888 (set-face-foreground 'font-lock-type-face
|
|
|
3889 (if (x-color-defined-p "seagreen")
|
|
|
3890 "seagreen"
|
|
|
3891 "sea green")))
|
|
|
3892 ((eq background 'dark)
|
|
|
3893 (set-face-foreground 'font-lock-type-face
|
|
|
3894 (if (x-color-defined-p "os2pink")
|
|
|
3895 "os2pink"
|
|
|
3896 "pink")))
|
|
|
3897 (t
|
|
|
3898 (set-face-background 'font-lock-type-face "gray90"))))
|
|
|
3899 (if (is-face 'font-lock-other-type-face)
|
|
|
3900 nil
|
|
|
3901 (copy-face 'font-lock-type-face 'font-lock-other-type-face)
|
|
|
3902 (cond
|
|
|
3903 ((eq background 'light)
|
|
|
3904 (set-face-foreground 'font-lock-other-type-face
|
|
|
3905 (if (x-color-defined-p "chartreuse3")
|
|
|
3906 "chartreuse3"
|
|
|
3907 "chartreuse")))
|
|
|
3908 ((eq background 'dark)
|
|
|
3909 (set-face-foreground 'font-lock-other-type-face
|
|
|
3910 (if (x-color-defined-p "orchid1")
|
|
|
3911 "orchid1"
|
|
|
3912 "orange")))))
|
|
|
3913 (if (is-face 'font-lock-other-emphasized-face) nil
|
|
|
3914 (copy-face 'bold-italic 'font-lock-other-emphasized-face)
|
|
|
3915 (cond
|
|
|
3916 ((eq background 'light)
|
|
|
3917 (set-face-background 'font-lock-other-emphasized-face
|
|
|
3918 (if (x-color-defined-p "lightyellow2")
|
|
|
3919 "lightyellow2"
|
|
|
3920 (if (x-color-defined-p "lightyellow")
|
|
|
3921 "lightyellow"
|
|
|
3922 "light yellow"))))
|
|
|
3923 ((eq background 'dark)
|
|
|
3924 (set-face-background 'font-lock-other-emphasized-face
|
|
|
3925 (if (x-color-defined-p "navy")
|
|
|
3926 "navy"
|
|
|
3927 (if (x-color-defined-p "darkgreen")
|
|
|
3928 "darkgreen"
|
|
|
3929 "dark green"))))
|
|
|
3930 (t (set-face-background 'font-lock-other-emphasized-face "gray90"))))
|
|
|
3931 (if (is-face 'font-lock-emphasized-face) nil
|
|
|
3932 (copy-face 'bold 'font-lock-emphasized-face)
|
|
|
3933 (cond
|
|
|
3934 ((eq background 'light)
|
|
|
3935 (set-face-background 'font-lock-emphasized-face
|
|
|
3936 (if (x-color-defined-p "lightyellow2")
|
|
|
3937 "lightyellow2"
|
|
|
3938 "lightyellow")))
|
|
|
3939 ((eq background 'dark)
|
|
|
3940 (set-face-background 'font-lock-emphasized-face
|
|
|
3941 (if (x-color-defined-p "navy")
|
|
|
3942 "navy"
|
|
|
3943 (if (x-color-defined-p "darkgreen")
|
|
|
3944 "darkgreen"
|
|
|
3945 "dark green"))))
|
|
|
3946 (t (set-face-background 'font-lock-emphasized-face "gray90"))))
|
|
|
3947 (if (is-face 'font-lock-variable-name-face) nil
|
|
|
3948 (copy-face 'italic 'font-lock-variable-name-face))
|
|
|
3949 (if (is-face 'font-lock-reference-face) nil
|
|
|
3950 (copy-face 'italic 'font-lock-reference-face))))
|
|
|
3951 (setq cperl-faces-init t))
|
|
|
3952 (error nil)))
|
|
|
3953
|
|
|
3954
|
|
|
3955 (defun cperl-ps-print-init ()
|
|
|
3956 "Initialization of `ps-print' components for faces used in CPerl."
|
|
|
3957 ;; Guard against old versions
|
|
|
3958 (defvar ps-underlined-faces nil)
|
|
|
3959 (defvar ps-bold-faces nil)
|
|
|
3960 (defvar ps-italic-faces nil)
|
|
|
3961 (setq ps-bold-faces
|
|
|
3962 (append '(font-lock-emphasized-face
|
|
|
3963 font-lock-keyword-face
|
|
|
3964 font-lock-variable-name-face
|
|
|
3965 font-lock-reference-face
|
|
|
3966 font-lock-other-emphasized-face)
|
|
|
3967 ps-bold-faces))
|
|
|
3968 (setq ps-italic-faces
|
|
|
3969 (append '(font-lock-other-type-face
|
|
|
3970 font-lock-reference-face
|
|
|
3971 font-lock-other-emphasized-face)
|
|
|
3972 ps-italic-faces))
|
|
|
3973 (setq ps-underlined-faces
|
|
|
3974 (append '(font-lock-emphasized-face
|
|
|
3975 font-lock-other-emphasized-face
|
|
|
3976 font-lock-other-type-face font-lock-type-face)
|
|
|
3977 ps-underlined-faces))
|
|
|
3978 (cons 'font-lock-type-face ps-underlined-faces))
|
|
|
3979
|
|
|
3980
|
|
|
3981 (if (cperl-enable-font-lock) (cperl-windowed-init))
|
|
|
3982
|
|
|
3983 (defun cperl-set-style (style)
|
|
|
3984 "Set CPerl-mode variables to use one of several different indentation styles.
|
|
|
3985 The arguments are a string representing the desired style.
|
|
|
3986 Available styles are GNU, K&R, BSD and Whitesmith."
|
|
|
3987 (interactive
|
|
193
|
3988 (let ((list (progn
|
|
|
3989 (require 'cc-styles)
|
|
|
3990 (mapcar (function (lambda (elt) (list (car elt))))
|
|
|
3991 c-style-alist))))
|
|
0
|
3992 (list (completing-read "Enter style: " list nil 'insist))))
|
|
|
3993 (let ((style (cdr (assoc style c-style-alist))) setting str sym)
|
|
|
3994 (while style
|
|
|
3995 (setq setting (car style) style (cdr style))
|
|
|
3996 (setq str (symbol-name (car setting)))
|
|
|
3997 (and (string-match "^c-" str)
|
|
|
3998 (setq str (concat "cperl-" (substring str 2)))
|
|
|
3999 (setq sym (intern-soft str))
|
|
|
4000 (boundp sym)
|
|
|
4001 (set sym (cdr setting))))))
|
|
|
4002
|
|
|
4003 (defun cperl-check-syntax ()
|
|
|
4004 (interactive)
|
|
|
4005 (require 'mode-compile)
|
|
|
4006 (let ((perl-dbg-flags "-wc"))
|
|
|
4007 (mode-compile)))
|
|
|
4008
|
|
110
|
4009 (defun cperl-info-buffer (type)
|
|
|
4010 ;; Returns buffer with documentation. Creates if missing.
|
|
|
4011 ;; If TYPE, this vars buffer.
|
|
|
4012 ;; Special care is taken to not stomp over an existing info buffer
|
|
|
4013 (let* ((bname (if type "*info-perl-var*" "*info-perl*"))
|
|
|
4014 (info (get-buffer bname))
|
|
|
4015 (oldbuf (get-buffer "*info*")))
|
|
0
|
4016 (if info info
|
|
|
4017 (save-window-excursion
|
|
|
4018 ;; Get Info running
|
|
|
4019 (require 'info)
|
|
110
|
4020 (cond (oldbuf
|
|
|
4021 (set-buffer oldbuf)
|
|
|
4022 (rename-buffer "*info-perl-tmp*")))
|
|
0
|
4023 (save-window-excursion
|
|
|
4024 (info))
|
|
110
|
4025 (Info-find-node cperl-info-page (if type "perlvar" "perlfunc"))
|
|
0
|
4026 (set-buffer "*info*")
|
|
110
|
4027 (rename-buffer bname)
|
|
|
4028 (cond (oldbuf
|
|
|
4029 (set-buffer "*info-perl-tmp*")
|
|
|
4030 (rename-buffer "*info*")
|
|
|
4031 (set-buffer bname)))
|
|
|
4032 (make-variable-buffer-local 'window-min-height)
|
|
|
4033 (setq window-min-height 2)
|
|
0
|
4034 (current-buffer)))))
|
|
|
4035
|
|
|
4036 (defun cperl-word-at-point (&optional p)
|
|
|
4037 ;; Returns the word at point or at P.
|
|
|
4038 (save-excursion
|
|
|
4039 (if p (goto-char p))
|
|
110
|
4040 (or (cperl-word-at-point-hard)
|
|
|
4041 (progn
|
|
|
4042 (require 'etags)
|
|
|
4043 (funcall (or (and (boundp 'find-tag-default-function)
|
|
|
4044 find-tag-default-function)
|
|
|
4045 (get major-mode 'find-tag-default-function)
|
|
|
4046 ;; XEmacs 19.12 has `find-tag-default-hook'; it is
|
|
|
4047 ;; automatically used within `find-tag-default':
|
|
|
4048 'find-tag-default))))))
|
|
0
|
4049
|
|
|
4050 (defun cperl-info-on-command (command)
|
|
110
|
4051 "Shows documentation for Perl command in other window.
|
|
|
4052 If perl-info buffer is shown in some frame, uses this frame.
|
|
|
4053 Customized by setting variables `cperl-shrink-wrap-info-frame',
|
|
|
4054 `cperl-max-help-size'."
|
|
0
|
4055 (interactive
|
|
|
4056 (let* ((default (cperl-word-at-point))
|
|
|
4057 (read (read-string
|
|
|
4058 (format "Find doc for Perl function (default %s): "
|
|
|
4059 default))))
|
|
|
4060 (list (if (equal read "")
|
|
|
4061 default
|
|
|
4062 read))))
|
|
|
4063
|
|
|
4064 (let ((buffer (current-buffer))
|
|
|
4065 (cmd-desc (concat "^" (regexp-quote command) "[^a-zA-Z_0-9]")) ; "tr///"
|
|
110
|
4066 pos isvar height iniheight frheight buf win fr1 fr2 iniwin not-loner
|
|
|
4067 max-height char-height buf-list)
|
|
0
|
4068 (if (string-match "^-[a-zA-Z]$" command)
|
|
|
4069 (setq cmd-desc "^-X[ \t\n]"))
|
|
110
|
4070 (setq isvar (string-match "^[$@%]" command)
|
|
|
4071 buf (cperl-info-buffer isvar)
|
|
|
4072 iniwin (selected-window)
|
|
|
4073 fr1 (window-frame iniwin))
|
|
|
4074 (set-buffer buf)
|
|
0
|
4075 (beginning-of-buffer)
|
|
110
|
4076 (or isvar
|
|
|
4077 (progn (re-search-forward "^-X[ \t\n]")
|
|
|
4078 (forward-line -1)))
|
|
0
|
4079 (if (re-search-forward cmd-desc nil t)
|
|
|
4080 (progn
|
|
110
|
4081 ;; Go back to beginning of the group (ex, for qq)
|
|
|
4082 (if (re-search-backward "^[ \t\n\f]")
|
|
|
4083 (forward-line 1))
|
|
|
4084 (beginning-of-line)
|
|
|
4085 ;; Get some of
|
|
|
4086 (setq pos (point)
|
|
|
4087 buf-list (list buf "*info-perl-var*" "*info-perl*"))
|
|
|
4088 (while (and (not win) buf-list)
|
|
|
4089 (setq win (get-buffer-window (car buf-list) t))
|
|
|
4090 (setq buf-list (cdr buf-list)))
|
|
|
4091 (or (not win)
|
|
|
4092 (eq (window-buffer win) buf)
|
|
|
4093 (set-window-buffer win buf))
|
|
|
4094 (and win (setq fr2 (window-frame win)))
|
|
|
4095 (if (or (not fr2) (eq fr1 fr2))
|
|
|
4096 (pop-to-buffer buf)
|
|
|
4097 (special-display-popup-frame buf) ; Make it visible
|
|
|
4098 (select-window win))
|
|
|
4099 (goto-char pos) ; Needed (?!).
|
|
|
4100 ;; Resize
|
|
|
4101 (setq iniheight (window-height)
|
|
|
4102 frheight (frame-height)
|
|
|
4103 not-loner (< iniheight (1- frheight))) ; Are not alone
|
|
|
4104 (cond ((if not-loner cperl-max-help-size
|
|
|
4105 cperl-shrink-wrap-info-frame)
|
|
|
4106 (setq height
|
|
|
4107 (+ 2
|
|
|
4108 (count-lines
|
|
|
4109 pos
|
|
|
4110 (save-excursion
|
|
|
4111 (if (re-search-forward
|
|
|
4112 "^[ \t][^\n]*\n+\\([^ \t\n\f]\\|\\'\\)" nil t)
|
|
|
4113 (match-beginning 0) (point-max)))))
|
|
|
4114 max-height
|
|
|
4115 (if not-loner
|
|
|
4116 (/ (* (- frheight 3) cperl-max-help-size) 100)
|
|
|
4117 (setq char-height (frame-char-height))
|
|
|
4118 ;; Non-functioning under OS/2:
|
|
|
4119 (if (eq char-height 1) (setq char-height 18))
|
|
|
4120 ;; Title, menubar, + 2 for slack
|
|
|
4121 (- (/ (x-display-pixel-height) char-height) 4)
|
|
|
4122 ))
|
|
|
4123 (if (> height max-height) (setq height max-height))
|
|
|
4124 ;;(message "was %s doing %s" iniheight height)
|
|
|
4125 (if not-loner
|
|
|
4126 (enlarge-window (- height iniheight))
|
|
|
4127 (set-frame-height (window-frame win) (1+ height)))))
|
|
0
|
4128 (set-window-start (selected-window) pos))
|
|
|
4129 (message "No entry for %s found." command))
|
|
110
|
4130 ;;(pop-to-buffer buffer)
|
|
|
4131 (select-window iniwin)))
|
|
0
|
4132
|
|
|
4133 (defun cperl-info-on-current-command ()
|
|
|
4134 "Shows documentation for Perl command at point in other window."
|
|
|
4135 (interactive)
|
|
|
4136 (cperl-info-on-command (cperl-word-at-point)))
|
|
|
4137
|
|
193
|
4138 ;;(defun cperl-imenu-info-imenu-search ()
|
|
|
4139 ;; (if (looking-at "^-X[ \t\n]") nil
|
|
|
4140 ;; (re-search-backward
|
|
|
4141 ;; "^\n\\([-a-zA-Z_]+\\)[ \t\n]")
|
|
|
4142 ;; (forward-line 1)))
|
|
|
4143
|
|
|
4144 ;;(defun cperl-imenu-info-imenu-name ()
|
|
|
4145 ;; (buffer-substring
|
|
|
4146 ;; (match-beginning 1) (match-end 1)))
|
|
|
4147
|
|
|
4148 ;;(defun cperl-imenu-on-info ()
|
|
|
4149 ;; (interactive)
|
|
|
4150 ;; (let* ((buffer (current-buffer))
|
|
|
4151 ;; imenu-create-index-function
|
|
|
4152 ;; imenu-prev-index-position-function
|
|
|
4153 ;; imenu-extract-index-name-function
|
|
|
4154 ;; (index-item (save-restriction
|
|
|
4155 ;; (save-window-excursion
|
|
|
4156 ;; (set-buffer (cperl-info-buffer nil))
|
|
|
4157 ;; (setq imenu-create-index-function
|
|
|
4158 ;; 'imenu-default-create-index-function
|
|
|
4159 ;; imenu-prev-index-position-function
|
|
|
4160 ;; 'cperl-imenu-info-imenu-search
|
|
|
4161 ;; imenu-extract-index-name-function
|
|
|
4162 ;; 'cperl-imenu-info-imenu-name)
|
|
|
4163 ;; (imenu-choose-buffer-index)))))
|
|
|
4164 ;; (and index-item
|
|
|
4165 ;; (progn
|
|
|
4166 ;; (push-mark)
|
|
|
4167 ;; (pop-to-buffer "*info-perl*")
|
|
|
4168 ;; (cond
|
|
|
4169 ;; ((markerp (cdr index-item))
|
|
|
4170 ;; (goto-char (marker-position (cdr index-item))))
|
|
|
4171 ;; (t
|
|
|
4172 ;; (goto-char (cdr index-item))))
|
|
|
4173 ;; (set-window-start (selected-window) (point))
|
|
|
4174 ;; (pop-to-buffer buffer)))))
|
|
0
|
4175
|
|
|
4176 (defun cperl-lineup (beg end &optional step minshift)
|
|
|
4177 "Lineup construction in a region.
|
|
|
4178 Beginning of region should be at the start of a construction.
|
|
4
|
4179 All first occurrences of this construction in the lines that are
|
|
0
|
4180 partially contained in the region are lined up at the same column.
|
|
|
4181
|
|
|
4182 MINSHIFT is the minimal amount of space to insert before the construction.
|
|
|
4183 STEP is the tabwidth to position constructions.
|
|
|
4184 If STEP is `nil', `cperl-lineup-step' will be used
|
|
|
4185 \(or `cperl-indent-level', if `cperl-lineup-step' is `nil').
|
|
|
4186 Will not move the position at the start to the left."
|
|
|
4187 (interactive "r")
|
|
|
4188 (let (search col tcol seen b e)
|
|
|
4189 (save-excursion
|
|
|
4190 (goto-char end)
|
|
|
4191 (end-of-line)
|
|
|
4192 (setq end (point-marker))
|
|
|
4193 (goto-char beg)
|
|
|
4194 (skip-chars-forward " \t\f")
|
|
|
4195 (setq beg (point-marker))
|
|
|
4196 (indent-region beg end nil)
|
|
|
4197 (goto-char beg)
|
|
|
4198 (setq col (current-column))
|
|
4
|
4199 (if (looking-at "[a-zA-Z0-9_]")
|
|
|
4200 (if (looking-at "\\<[a-zA-Z0-9_]+\\>")
|
|
0
|
4201 (setq search
|
|
|
4202 (concat "\\<"
|
|
|
4203 (regexp-quote
|
|
|
4204 (buffer-substring (match-beginning 0)
|
|
|
4205 (match-end 0))) "\\>"))
|
|
|
4206 (error "Cannot line up in a middle of the word"))
|
|
|
4207 (if (looking-at "$")
|
|
|
4208 (error "Cannot line up end of line"))
|
|
|
4209 (setq search (regexp-quote (char-to-string (following-char)))))
|
|
|
4210 (setq step (or step cperl-lineup-step cperl-indent-level))
|
|
|
4211 (or minshift (setq minshift 1))
|
|
|
4212 (while (progn
|
|
|
4213 (beginning-of-line 2)
|
|
|
4214 (and (< (point) end)
|
|
|
4215 (re-search-forward search end t)
|
|
|
4216 (goto-char (match-beginning 0))))
|
|
|
4217 (setq tcol (current-column) seen t)
|
|
|
4218 (if (> tcol col) (setq col tcol)))
|
|
|
4219 (or seen
|
|
4
|
4220 (error "The construction to line up occurred only once"))
|
|
0
|
4221 (goto-char beg)
|
|
|
4222 (setq col (+ col minshift))
|
|
|
4223 (if (/= (% col step) 0) (setq step (* step (1+ (/ col step)))))
|
|
|
4224 (while
|
|
|
4225 (progn
|
|
|
4226 (setq e (point))
|
|
|
4227 (skip-chars-backward " \t")
|
|
|
4228 (delete-region (point) e)
|
|
|
4229 (indent-to-column col); (make-string (- col (current-column)) ?\ ))
|
|
|
4230 (beginning-of-line 2)
|
|
|
4231 (and (< (point) end)
|
|
|
4232 (re-search-forward search end t)
|
|
|
4233 (goto-char (match-beginning 0)))))))) ; No body
|
|
|
4234
|
|
|
4235 (defun cperl-etags (&optional add all files)
|
|
|
4236 "Run etags with appropriate options for Perl files.
|
|
|
4237 If optional argument ALL is `recursive', will process Perl files
|
|
|
4238 in subdirectories too."
|
|
|
4239 (interactive)
|
|
|
4240 (let ((cmd "etags")
|
|
193
|
4241 (args '("-l" "none" "-r" "/\\<\\(package\\|sub\\)[ \\t]+\\(\\([a-zA-Z0-9:_]*::\\)?\\([a-zA-Z0-9_]+\\)[ \\t]*\\(([^()]*)[ \t]*\\)?\\([{#]\\|$\\)\\)/\\4/"))
|
|
0
|
4242 res)
|
|
|
4243 (if add (setq args (cons "-a" args)))
|
|
|
4244 (or files (setq files (list buffer-file-name)))
|
|
|
4245 (cond
|
|
|
4246 ((eq all 'recursive)
|
|
|
4247 ;;(error "Not implemented: recursive")
|
|
|
4248 (setq args (append (list "-e"
|
|
193
|
4249 "sub wanted {push @ARGV, $File::Find::name if /\\.[pP][Llm]$/}
|
|
0
|
4250 use File::Find;
|
|
|
4251 find(\\&wanted, '.');
|
|
|
4252 exec @ARGV;"
|
|
|
4253 cmd) args)
|
|
|
4254 cmd "perl"))
|
|
|
4255 (all
|
|
|
4256 ;;(error "Not implemented: all")
|
|
|
4257 (setq args (append (list "-e"
|
|
|
4258 "push @ARGV, <*.PL *.pl *.pm>;
|
|
|
4259 exec @ARGV;"
|
|
|
4260 cmd) args)
|
|
|
4261 cmd "perl"))
|
|
|
4262 (t
|
|
|
4263 (setq args (append args files))))
|
|
|
4264 (setq res (apply 'call-process cmd nil nil nil args))
|
|
|
4265 (or (eq res 0)
|
|
|
4266 (message "etags returned \"%s\"" res))))
|
|
|
4267
|
|
|
4268 (defun cperl-toggle-auto-newline ()
|
|
|
4269 "Toggle the state of `cperl-auto-newline'."
|
|
|
4270 (interactive)
|
|
|
4271 (setq cperl-auto-newline (not cperl-auto-newline))
|
|
|
4272 (message "Newlines will %sbe auto-inserted now."
|
|
|
4273 (if cperl-auto-newline "" "not ")))
|
|
|
4274
|
|
|
4275 (defun cperl-toggle-abbrev ()
|
|
|
4276 "Toggle the state of automatic keyword expansion in CPerl mode."
|
|
|
4277 (interactive)
|
|
|
4278 (abbrev-mode (if abbrev-mode 0 1))
|
|
|
4279 (message "Perl control structure will %sbe auto-inserted now."
|
|
|
4280 (if abbrev-mode "" "not ")))
|
|
|
4281
|
|
|
4282
|
|
|
4283 (defun cperl-toggle-electric ()
|
|
|
4284 "Toggle the state of parentheses doubling in CPerl mode."
|
|
|
4285 (interactive)
|
|
|
4286 (setq cperl-electric-parens (if (cperl-val 'cperl-electric-parens) 'null t))
|
|
|
4287 (message "Parentheses will %sbe auto-doubled now."
|
|
|
4288 (if (cperl-val 'cperl-electric-parens) "" "not ")))
|
|
|
4289
|
|
4
|
4290 ;;;; Tags file creation.
|
|
|
4291
|
|
|
4292 (defvar cperl-tmp-buffer " *cperl-tmp*")
|
|
|
4293
|
|
|
4294 (defun cperl-setup-tmp-buf ()
|
|
|
4295 (set-buffer (get-buffer-create cperl-tmp-buffer))
|
|
|
4296 (set-syntax-table cperl-mode-syntax-table)
|
|
|
4297 (buffer-disable-undo)
|
|
193
|
4298 (auto-fill-mode 0)
|
|
|
4299 (if cperl-use-syntax-table-text-property-for-tags
|
|
|
4300 (progn
|
|
|
4301 (make-variable-buffer-local 'parse-sexp-lookup-properties)
|
|
|
4302 ;; Do not introduce variable if not needed, we check it!
|
|
|
4303 (set 'parse-sexp-lookup-properties t))))
|
|
4
|
4304
|
|
|
4305 (defun cperl-xsub-scan ()
|
|
|
4306 (require 'cl)
|
|
|
4307 (require 'imenu)
|
|
|
4308 (let ((index-alist '())
|
|
|
4309 (prev-pos 0) index index1 name package prefix)
|
|
|
4310 (goto-char (point-min))
|
|
|
4311 (imenu-progress-message prev-pos 0)
|
|
|
4312 ;; Search for the function
|
|
|
4313 (progn ;;save-match-data
|
|
|
4314 (while (re-search-forward
|
|
|
4315 "^\\([ \t]*MODULE\\>[^\n]*\\<PACKAGE[ \t]*=[ \t]*\\([a-zA-Z_][a-zA-Z_0-9:]*\\)\\>\\|\\([a-zA-Z_][a-zA-Z_0-9]*\\)(\\|[ \t]*BOOT:\\)"
|
|
|
4316 nil t)
|
|
|
4317 (imenu-progress-message prev-pos)
|
|
|
4318 (cond
|
|
|
4319 ((match-beginning 2) ; SECTION
|
|
|
4320 (setq package (buffer-substring (match-beginning 2) (match-end 2)))
|
|
|
4321 (goto-char (match-beginning 0))
|
|
|
4322 (skip-chars-forward " \t")
|
|
|
4323 (forward-char 1)
|
|
|
4324 (if (looking-at "[^\n]*\\<PREFIX[ \t]*=[ \t]*\\([a-zA-Z_][a-zA-Z_0-9]*\\)\\>")
|
|
|
4325 (setq prefix (buffer-substring (match-beginning 1) (match-end 1)))
|
|
|
4326 (setq prefix nil)))
|
|
|
4327 ((not package) nil) ; C language section
|
|
|
4328 ((match-beginning 3) ; XSUB
|
|
|
4329 (goto-char (1+ (match-beginning 3)))
|
|
|
4330 (setq index (imenu-example--name-and-position))
|
|
|
4331 (setq name (buffer-substring (match-beginning 3) (match-end 3)))
|
|
|
4332 (if (and prefix (string-match (concat "^" prefix) name))
|
|
|
4333 (setq name (substring name (length prefix))))
|
|
|
4334 (cond ((string-match "::" name) nil)
|
|
|
4335 (t
|
|
|
4336 (setq index1 (cons (concat package "::" name) (cdr index)))
|
|
|
4337 (push index1 index-alist)))
|
|
|
4338 (setcar index name)
|
|
|
4339 (push index index-alist))
|
|
|
4340 (t ; BOOT: section
|
|
|
4341 ;; (beginning-of-line)
|
|
|
4342 (setq index (imenu-example--name-and-position))
|
|
|
4343 (setcar index (concat package "::BOOT:"))
|
|
|
4344 (push index index-alist)))))
|
|
|
4345 (imenu-progress-message prev-pos 100)
|
|
|
4346 ;;(setq index-alist
|
|
|
4347 ;; (if (default-value 'imenu-sort-function)
|
|
|
4348 ;; (sort index-alist (default-value 'imenu-sort-function))
|
|
|
4349 ;; (nreverse index-alist)))
|
|
|
4350 index-alist))
|
|
|
4351
|
|
|
4352 (defun cperl-find-tags (file xs)
|
|
193
|
4353 (let (ind (b (get-buffer cperl-tmp-buffer)) lst elt pos ret
|
|
|
4354 (cperl-pod-here-fontify nil))
|
|
4
|
4355 (save-excursion
|
|
|
4356 (if b (set-buffer b)
|
|
|
4357 (cperl-setup-tmp-buf))
|
|
|
4358 (erase-buffer)
|
|
|
4359 (setq file (car (insert-file-contents file)))
|
|
|
4360 (message "Scanning file %s..." file)
|
|
193
|
4361 (if cperl-use-syntax-table-text-property-for-tags
|
|
|
4362 (cperl-find-pods-heres))
|
|
4
|
4363 (if xs
|
|
|
4364 (setq lst (cperl-xsub-scan))
|
|
|
4365 (setq ind (imenu-example--create-perl-index))
|
|
|
4366 (setq lst (cdr (assoc "+Unsorted List+..." ind))))
|
|
|
4367 (setq lst
|
|
|
4368 (mapcar
|
|
|
4369 (function
|
|
|
4370 (lambda (elt)
|
|
|
4371 (cond ((string-match "^[_a-zA-Z]" (car elt))
|
|
|
4372 (goto-char (cdr elt))
|
|
|
4373 (list (car elt)
|
|
|
4374 (point) (count-lines 1 (point))
|
|
|
4375 (buffer-substring (progn
|
|
|
4376 (skip-chars-forward
|
|
|
4377 ":_a-zA-Z0-9")
|
|
|
4378 (or (eolp) (forward-char 1))
|
|
|
4379 (point))
|
|
|
4380 (progn
|
|
|
4381 (beginning-of-line)
|
|
|
4382 (point))))))))
|
|
|
4383 lst))
|
|
|
4384 (erase-buffer)
|
|
|
4385 (while lst
|
|
|
4386 (setq elt (car lst) lst (cdr lst))
|
|
|
4387 (if elt
|
|
|
4388 (progn
|
|
|
4389 (insert (elt elt 3)
|
|
|
4390 127
|
|
|
4391 (if (string-match "^package " (car elt))
|
|
|
4392 (substring (car elt) 8)
|
|
|
4393 (car elt) )
|
|
|
4394 1
|
|
|
4395 (number-to-string (elt elt 1))
|
|
|
4396 ","
|
|
|
4397 (number-to-string (elt elt 2))
|
|
|
4398 "\n")
|
|
|
4399 (if (and (string-match "^[_a-zA-Z]+::" (car elt))
|
|
|
4400 (string-match "^sub[ \t]+\\([_a-zA-Z]+\\)[^:_a-zA-Z]"
|
|
|
4401 (elt elt 3)))
|
|
|
4402 ;; Need to insert the name without package as well
|
|
|
4403 (setq lst (cons (cons (substring (elt elt 3)
|
|
|
4404 (match-beginning 1)
|
|
|
4405 (match-end 1))
|
|
|
4406 (cdr elt))
|
|
|
4407 lst))))))
|
|
|
4408 (setq pos (point))
|
|
|
4409 (goto-char 1)
|
|
|
4410 (insert "\f\n" file "," (number-to-string (1- pos)) "\n")
|
|
|
4411 (setq ret (buffer-substring 1 (point-max)))
|
|
|
4412 (erase-buffer)
|
|
|
4413 (message "Scanning file %s finished" file)
|
|
|
4414 ret)))
|
|
|
4415
|
|
|
4416 (defun cperl-write-tags (&optional file erase recurse dir inbuffer)
|
|
|
4417 ;; If INBUFFER, do not select buffer, and do not save
|
|
|
4418 ;; If ERASE is `ignore', do not erase, and do not try to delete old info.
|
|
|
4419 (require 'etags)
|
|
|
4420 (if file nil
|
|
|
4421 (setq file (if dir default-directory (buffer-file-name)))
|
|
|
4422 (if (and (not dir) (buffer-modified-p)) (error "Save buffer first!")))
|
|
|
4423 (let ((tags-file-name "TAGS")
|
|
|
4424 (case-fold-search (eq system-type 'emx))
|
|
|
4425 xs)
|
|
|
4426 (save-excursion
|
|
|
4427 (cond (inbuffer nil) ; Already there
|
|
|
4428 ((file-exists-p tags-file-name)
|
|
203
|
4429 (visit-tags-table-buffer))
|
|
4
|
4430 (t (set-buffer (find-file-noselect tags-file-name))))
|
|
|
4431 (cond
|
|
|
4432 (dir
|
|
|
4433 (cond ((eq erase 'ignore))
|
|
|
4434 (erase
|
|
|
4435 (erase-buffer)
|
|
|
4436 (setq erase 'ignore)))
|
|
|
4437 (let ((files
|
|
193
|
4438 (directory-files file t
|
|
|
4439 (if recurse nil cperl-scan-files-regexp)
|
|
|
4440 t)))
|
|
4
|
4441 (mapcar (function (lambda (file)
|
|
|
4442 (cond
|
|
193
|
4443 ((string-match cperl-noscan-files-regexp file)
|
|
|
4444 nil)
|
|
4
|
4445 ((not (file-directory-p file))
|
|
193
|
4446 (if (string-match cperl-scan-files-regexp file)
|
|
4
|
4447 (cperl-write-tags file erase recurse nil t)))
|
|
|
4448 ((not recurse) nil)
|
|
|
4449 (t (cperl-write-tags file erase recurse t t)))))
|
|
|
4450 files))
|
|
|
4451 )
|
|
|
4452 (t
|
|
|
4453 (setq xs (string-match "\\.xs$" file))
|
|
110
|
4454 (cond ((eq erase 'ignore) (goto-char (point-max)))
|
|
4
|
4455 (erase (erase-buffer))
|
|
|
4456 (t
|
|
|
4457 (goto-char 1)
|
|
|
4458 (if (search-forward (concat "\f\n" file ",") nil t)
|
|
|
4459 (progn
|
|
|
4460 (search-backward "\f\n")
|
|
|
4461 (delete-region (point)
|
|
193
|
4462 (save-excursion
|
|
4
|
4463 (forward-char 1)
|
|
193
|
4464 (if (search-forward "\f\n" nil 'toend)
|
|
|
4465 (- (point) 2)
|
|
|
4466 (point-max)))))
|
|
110
|
4467 (goto-char (point-max)))))
|
|
4
|
4468 (insert (cperl-find-tags file xs))))
|
|
|
4469 (if inbuffer nil ; Delegate to the caller
|
|
|
4470 (save-buffer 0) ; No backup
|
|
110
|
4471 (if (fboundp 'initialize-new-tags-table) ; Do we need something special in XEmacs?
|
|
|
4472 (initialize-new-tags-table))))))
|
|
4
|
4473
|
|
|
4474 (defvar cperl-tags-hier-regexp-list
|
|
193
|
4475 (concat
|
|
|
4476 "^\\("
|
|
|
4477 "\\(package\\)\\>"
|
|
|
4478 "\\|"
|
|
|
4479 "sub\\>[^\n]+::"
|
|
|
4480 "\\|"
|
|
|
4481 "[a-zA-Z_][a-zA-Z_0-9:]*(\C-?[^\n]+::" ; XSUB?
|
|
|
4482 "\\|"
|
|
|
4483 "[ \t]*BOOT:\C-?[^\n]+::" ; BOOT section
|
|
|
4484 "\\)"))
|
|
4
|
4485
|
|
|
4486 (defvar cperl-hierarchy '(() ())
|
|
|
4487 "Global hierarchy of classes")
|
|
|
4488
|
|
|
4489 (defun cperl-tags-hier-fill ()
|
|
|
4490 ;; Suppose we are in a tag table cooked by cperl.
|
|
|
4491 (goto-char 1)
|
|
|
4492 (let (type pack name pos line chunk ord cons1 file str info fileind)
|
|
|
4493 (while (re-search-forward cperl-tags-hier-regexp-list nil t)
|
|
|
4494 (setq pos (match-beginning 0)
|
|
|
4495 pack (match-beginning 2))
|
|
|
4496 (beginning-of-line)
|
|
193
|
4497 (if (looking-at (concat
|
|
|
4498 "\\([^\n]+\\)"
|
|
|
4499 "\C-?"
|
|
|
4500 "\\([^\n]+\\)"
|
|
|
4501 "\C-a"
|
|
|
4502 "\\([0-9]+\\)"
|
|
|
4503 ","
|
|
|
4504 "\\([0-9]+\\)"))
|
|
4
|
4505 (progn
|
|
|
4506 (setq ;;str (buffer-substring (match-beginning 1) (match-end 1))
|
|
|
4507 name (buffer-substring (match-beginning 2) (match-end 2))
|
|
|
4508 ;;pos (buffer-substring (match-beginning 3) (match-end 3))
|
|
|
4509 line (buffer-substring (match-beginning 4) (match-end 4))
|
|
|
4510 ord (if pack 1 0)
|
|
|
4511 info (etags-snarf-tag) ; Moves to beginning of the next line
|
|
|
4512 file (file-of-tag)
|
|
|
4513 fileind (format "%s:%s" file line))
|
|
|
4514 ;; Move back
|
|
|
4515 (forward-char -1)
|
|
|
4516 ;; Make new member of hierarchy name ==> file ==> pos if needed
|
|
|
4517 (if (setq cons1 (assoc name (nth ord cperl-hierarchy)))
|
|
|
4518 ;; Name known
|
|
|
4519 (setcdr cons1 (cons (cons fileind (vector file info))
|
|
|
4520 (cdr cons1)))
|
|
|
4521 ;; First occurrence of the name, start alist
|
|
|
4522 (setq cons1 (cons name (list (cons fileind (vector file info)))))
|
|
|
4523 (if pack
|
|
|
4524 (setcar (cdr cperl-hierarchy)
|
|
|
4525 (cons cons1 (nth 1 cperl-hierarchy)))
|
|
|
4526 (setcar cperl-hierarchy
|
|
|
4527 (cons cons1 (car cperl-hierarchy)))))))
|
|
|
4528 (end-of-line))))
|
|
|
4529
|
|
|
4530 (defun cperl-tags-hier-init (&optional update)
|
|
|
4531 "Show hierarchical menu of classes and methods.
|
|
|
4532 Finds info about classes by a scan of loaded TAGS files.
|
|
|
4533 Supposes that the TAGS files contain fully qualified function names.
|
|
|
4534 One may build such TAGS files from CPerl mode menu."
|
|
|
4535 (interactive)
|
|
|
4536 (require 'etags)
|
|
|
4537 (require 'imenu)
|
|
|
4538 (if (or update (null (nth 2 cperl-hierarchy)))
|
|
|
4539 (let (pack name cons1 to l1 l2 l3 l4
|
|
|
4540 (remover (function (lambda (elt) ; (name (file1...) (file2..))
|
|
|
4541 (or (nthcdr 2 elt)
|
|
|
4542 ;; Only in one file
|
|
|
4543 (setcdr elt (cdr (nth 1 elt))))))))
|
|
|
4544 ;; (setq cperl-hierarchy '(() () ())) ; Would write into '() later!
|
|
|
4545 (setq cperl-hierarchy (list l1 l2 l3))
|
|
|
4546 (or tags-table-list
|
|
|
4547 (call-interactively 'visit-tags-table))
|
|
|
4548 (message "Updating list of classes...")
|
|
|
4549 (mapcar
|
|
|
4550 (function
|
|
|
4551 (lambda (tagsfile)
|
|
|
4552 (set-buffer (get-file-buffer tagsfile))
|
|
|
4553 (cperl-tags-hier-fill)))
|
|
|
4554 tags-table-list)
|
|
|
4555 (mapcar remover (car cperl-hierarchy))
|
|
|
4556 (mapcar remover (nth 1 cperl-hierarchy))
|
|
|
4557 (setq to (list nil (cons "Packages: " (nth 1 cperl-hierarchy))
|
|
|
4558 (cons "Methods: " (car cperl-hierarchy))))
|
|
|
4559 (cperl-tags-treeify to 1)
|
|
|
4560 (setcar (nthcdr 2 cperl-hierarchy)
|
|
|
4561 (cperl-menu-to-keymap (cons '("+++UPDATE+++" . -999) (cdr to))))
|
|
|
4562 (message "Updating list of classes: done, requesting display...")
|
|
|
4563 ;;(cperl-imenu-addback (nth 2 cperl-hierarchy))
|
|
|
4564 ))
|
|
|
4565 (or (nth 2 cperl-hierarchy)
|
|
|
4566 (error "No items found"))
|
|
|
4567 (setq update
|
|
|
4568 ;;; (imenu-choose-buffer-index "Packages: " (nth 2 cperl-hierarchy))
|
|
|
4569 (if window-system
|
|
|
4570 (x-popup-menu t (nth 2 cperl-hierarchy))
|
|
|
4571 (require 'tmm)
|
|
193
|
4572 (tmm-prompt (nth 2 cperl-hierarchy))))
|
|
4
|
4573 (if (and update (listp update))
|
|
|
4574 (progn (while (cdr update) (setq update (cdr update)))
|
|
|
4575 (setq update (car update)))) ; Get the last from the list
|
|
|
4576 (if (vectorp update)
|
|
|
4577 (progn
|
|
|
4578 (find-file (elt update 0))
|
|
|
4579 (etags-goto-tag-location (elt update 1))))
|
|
|
4580 (if (eq update -999) (cperl-tags-hier-init t)))
|
|
|
4581
|
|
|
4582 (defun cperl-tags-treeify (to level)
|
|
193
|
4583 ;; cadr of `to' is read-write. On start it is a cons
|
|
4
|
4584 (let* ((regexp (concat "^\\(" (mapconcat
|
|
|
4585 'identity
|
|
|
4586 (make-list level "[_a-zA-Z0-9]+")
|
|
|
4587 "::")
|
|
|
4588 "\\)\\(::\\)?"))
|
|
|
4589 (packages (cdr (nth 1 to)))
|
|
|
4590 (methods (cdr (nth 2 to)))
|
|
|
4591 l1 head tail cons1 cons2 ord writeto packs recurse
|
|
|
4592 root-packages root-functions ms many_ms same_name ps
|
|
|
4593 (move-deeper
|
|
|
4594 (function
|
|
|
4595 (lambda (elt)
|
|
|
4596 (cond ((and (string-match regexp (car elt))
|
|
|
4597 (or (eq ord 1) (match-end 2)))
|
|
|
4598 (setq head (substring (car elt) 0 (match-end 1))
|
|
|
4599 tail (if (match-end 2) (substring (car elt)
|
|
|
4600 (match-end 2)))
|
|
|
4601 recurse t)
|
|
|
4602 (if (setq cons1 (assoc head writeto)) nil
|
|
|
4603 ;; Need to init new head
|
|
|
4604 (setcdr writeto (cons (list head (list "Packages: ")
|
|
|
4605 (list "Methods: "))
|
|
|
4606 (cdr writeto)))
|
|
|
4607 (setq cons1 (nth 1 writeto)))
|
|
|
4608 (setq cons2 (nth ord cons1)) ; Either packs or meths
|
|
|
4609 (setcdr cons2 (cons elt (cdr cons2))))
|
|
|
4610 ((eq ord 2)
|
|
|
4611 (setq root-functions (cons elt root-functions)))
|
|
|
4612 (t
|
|
|
4613 (setq root-packages (cons elt root-packages))))))))
|
|
|
4614 (setcdr to l1) ; Init to dynamic space
|
|
|
4615 (setq writeto to)
|
|
|
4616 (setq ord 1)
|
|
|
4617 (mapcar move-deeper packages)
|
|
|
4618 (setq ord 2)
|
|
|
4619 (mapcar move-deeper methods)
|
|
|
4620 (if recurse
|
|
|
4621 (mapcar (function (lambda (elt)
|
|
|
4622 (cperl-tags-treeify elt (1+ level))))
|
|
|
4623 (cdr to)))
|
|
|
4624 ;;Now clean up leaders with one child only
|
|
|
4625 (mapcar (function (lambda (elt)
|
|
|
4626 (if (not (and (listp (cdr elt))
|
|
|
4627 (eq (length elt) 2))) nil
|
|
|
4628 (setcar elt (car (nth 1 elt)))
|
|
|
4629 (setcdr elt (cdr (nth 1 elt))))))
|
|
|
4630 (cdr to))
|
|
193
|
4631 ;; Sort the roots of subtrees
|
|
|
4632 (if (default-value 'imenu-sort-function)
|
|
|
4633 (setcdr to
|
|
|
4634 (sort (cdr to) (default-value 'imenu-sort-function))))
|
|
|
4635 ;; Now add back functions removed from display
|
|
|
4636 (mapcar (function (lambda (elt)
|
|
|
4637 (setcdr to (cons elt (cdr to)))))
|
|
|
4638 (if (default-value 'imenu-sort-function)
|
|
|
4639 (nreverse
|
|
|
4640 (sort root-functions (default-value 'imenu-sort-function)))
|
|
|
4641 root-functions))
|
|
|
4642 ;; Now add back packages removed from display
|
|
|
4643 (mapcar (function (lambda (elt)
|
|
|
4644 (setcdr to (cons (cons (concat "package " (car elt))
|
|
|
4645 (cdr elt))
|
|
|
4646 (cdr to)))))
|
|
|
4647 (if (default-value 'imenu-sort-function)
|
|
|
4648 (nreverse
|
|
|
4649 (sort root-packages (default-value 'imenu-sort-function)))
|
|
|
4650 root-packages))
|
|
4
|
4651 ))
|
|
|
4652
|
|
|
4653 ;;;(x-popup-menu t
|
|
|
4654 ;;; '(keymap "Name1"
|
|
|
4655 ;;; ("Ret1" "aa")
|
|
|
4656 ;;; ("Head1" "ab"
|
|
|
4657 ;;; keymap "Name2"
|
|
|
4658 ;;; ("Tail1" "x") ("Tail2" "y"))))
|
|
|
4659
|
|
|
4660 (defun cperl-list-fold (list name limit)
|
|
|
4661 (let (list1 list2 elt1 (num 0))
|
|
|
4662 (if (<= (length list) limit) list
|
|
|
4663 (setq list1 nil list2 nil)
|
|
|
4664 (while list
|
|
|
4665 (setq num (1+ num)
|
|
|
4666 elt1 (car list)
|
|
|
4667 list (cdr list))
|
|
|
4668 (if (<= num imenu-max-items)
|
|
|
4669 (setq list2 (cons elt1 list2))
|
|
|
4670 (setq list1 (cons (cons name
|
|
|
4671 (nreverse list2))
|
|
|
4672 list1)
|
|
|
4673 list2 (list elt1)
|
|
|
4674 num 1)))
|
|
|
4675 (nreverse (cons (cons name
|
|
|
4676 (nreverse list2))
|
|
|
4677 list1)))))
|
|
|
4678
|
|
|
4679 (defun cperl-menu-to-keymap (menu &optional name)
|
|
|
4680 (let (list)
|
|
|
4681 (cons 'keymap
|
|
|
4682 (mapcar
|
|
|
4683 (function
|
|
|
4684 (lambda (elt)
|
|
|
4685 (cond ((listp (cdr elt))
|
|
|
4686 (setq list (cperl-list-fold
|
|
|
4687 (cdr elt) (car elt) imenu-max-items))
|
|
|
4688 (cons nil
|
|
|
4689 (cons (car elt)
|
|
|
4690 (cperl-menu-to-keymap list))))
|
|
|
4691 (t
|
|
193
|
4692 (list (cdr elt) (car elt) t))))) ; t is needed in 19.34
|
|
4
|
4693 (cperl-list-fold menu "Root" imenu-max-items)))))
|
|
|
4694
|
|
|
4695
|
|
|
4696 (defvar cperl-bad-style-regexp
|
|
|
4697 (mapconcat 'identity
|
|
|
4698 '("[^-\n\t <>=+!.&|(*/'`\"#^][-=+<>!|&^]" ; char sign
|
|
|
4699 "[-<>=+^&|]+[^- \t\n=+<>~]" ; sign+ char
|
|
|
4700 )
|
|
|
4701 "\\|")
|
|
|
4702 "Finds places such that insertion of a whitespace may help a lot.")
|
|
|
4703
|
|
|
4704 (defvar cperl-not-bad-style-regexp
|
|
|
4705 (mapconcat 'identity
|
|
|
4706 '("[^-\t <>=+]\\(--\\|\\+\\+\\)" ; var-- var++
|
|
193
|
4707 "[a-zA-Z0-9_][|&][a-zA-Z0-9_$]" ; abc|def abc&def are often used.
|
|
|
4708 "&[(a-zA-Z0-9_$]" ; &subroutine &(var->field)
|
|
4
|
4709 "<\\$?\\sw+\\(\\.\\sw+\\)?>" ; <IN> <stdin.h>
|
|
|
4710 "-[a-zA-Z][ \t]+[_$\"'`]" ; -f file
|
|
|
4711 "-[0-9]" ; -5
|
|
|
4712 "\\+\\+" ; ++var
|
|
|
4713 "--" ; --var
|
|
|
4714 ".->" ; a->b
|
|
|
4715 "->" ; a SPACE ->b
|
|
|
4716 "\\[-" ; a[-1]
|
|
|
4717 "^=" ; =head
|
|
|
4718 "||"
|
|
|
4719 "&&"
|
|
|
4720 "[CBIXSLFZ]<\\(\\sw\\|\\s \\|\\s_\\|[\n]\\)*>" ; C<code like text>
|
|
193
|
4721 "-[a-zA-Z_0-9]+[ \t]*=>" ; -option => value
|
|
4
|
4722 ;; Unaddressed trouble spots: = -abc, f(56, -abc) --- specialcased below
|
|
|
4723 ;;"[*/+-|&<.]+="
|
|
|
4724 )
|
|
|
4725 "\\|")
|
|
|
4726 "If matches at the start of match found by `my-bad-c-style-regexp',
|
|
|
4727 insertion of a whitespace will not help.")
|
|
|
4728
|
|
|
4729 (defvar found-bad)
|
|
|
4730
|
|
|
4731 (defun cperl-find-bad-style ()
|
|
|
4732 "Find places in the buffer where insertion of a whitespace may help.
|
|
|
4733 Prompts user for insertion of spaces.
|
|
|
4734 Currently it is tuned to C and Perl syntax."
|
|
|
4735 (interactive)
|
|
|
4736 (let (found-bad (p (point)))
|
|
|
4737 (setq last-nonmenu-event 13) ; To disable popup
|
|
|
4738 (beginning-of-buffer)
|
|
|
4739 (map-y-or-n-p "Insert space here? "
|
|
|
4740 (function (lambda (arg) (insert " ")))
|
|
|
4741 'cperl-next-bad-style
|
|
|
4742 '("location" "locations" "insert a space into")
|
|
|
4743 '((?\C-r (lambda (arg)
|
|
|
4744 (let ((buffer-quit-function
|
|
|
4745 'exit-recursive-edit))
|
|
|
4746 (message "Exit with Esc Esc")
|
|
|
4747 (recursive-edit)
|
|
|
4748 t)) ; Consider acted upon
|
|
|
4749 "edit, exit with Esc Esc")
|
|
|
4750 (?e (lambda (arg)
|
|
|
4751 (let ((buffer-quit-function
|
|
|
4752 'exit-recursive-edit))
|
|
|
4753 (message "Exit with Esc Esc")
|
|
|
4754 (recursive-edit)
|
|
|
4755 t)) ; Consider acted upon
|
|
|
4756 "edit, exit with Esc Esc"))
|
|
|
4757 t)
|
|
|
4758 (if found-bad (goto-char found-bad)
|
|
|
4759 (goto-char p)
|
|
|
4760 (message "No appropriate place found"))))
|
|
|
4761
|
|
|
4762 (defun cperl-next-bad-style ()
|
|
|
4763 (let (p (not-found t) (point (point)) found)
|
|
|
4764 (while (and not-found
|
|
|
4765 (re-search-forward cperl-bad-style-regexp nil 'to-end))
|
|
|
4766 (setq p (point))
|
|
|
4767 (goto-char (match-beginning 0))
|
|
|
4768 (if (or
|
|
|
4769 (looking-at cperl-not-bad-style-regexp)
|
|
|
4770 ;; Check for a < -b and friends
|
|
|
4771 (and (eq (following-char) ?\-)
|
|
|
4772 (save-excursion
|
|
|
4773 (skip-chars-backward " \t\n")
|
|
|
4774 (memq (preceding-char) '(?\= ?\> ?\< ?\, ?\(, ?\[, ?\{))))
|
|
|
4775 ;; Now check for syntax type
|
|
|
4776 (save-match-data
|
|
|
4777 (setq found (point))
|
|
|
4778 (beginning-of-defun)
|
|
|
4779 (let ((pps (parse-partial-sexp (point) found)))
|
|
|
4780 (or (nth 3 pps) (nth 4 pps) (nth 5 pps)))))
|
|
|
4781 (goto-char (match-end 0))
|
|
|
4782 (goto-char (1- p))
|
|
|
4783 (setq not-found nil
|
|
|
4784 found-bad found)))
|
|
|
4785 (not not-found)))
|
|
|
4786
|
|
|
4787
|
|
|
4788 ;;; Getting help
|
|
|
4789 (defvar cperl-have-help-regexp
|
|
|
4790 ;;(concat "\\("
|
|
|
4791 (mapconcat
|
|
|
4792 'identity
|
|
110
|
4793 '("[$@%*&][0-9a-zA-Z_:]+\\([ \t]*[[{]\\)?" ; Usual variable
|
|
4
|
4794 "[$@]\\^[a-zA-Z]" ; Special variable
|
|
|
4795 "[$@][^ \n\t]" ; Special variable
|
|
|
4796 "-[a-zA-Z]" ; File test
|
|
|
4797 "\\\\[a-zA-Z0]" ; Special chars
|
|
110
|
4798 "^=[a-z][a-zA-Z0-9_]*" ; Pod sections
|
|
4
|
4799 "[-!&*+,-./<=>?\\\\^|~]+" ; Operator
|
|
|
4800 "[a-zA-Z_0-9:]+" ; symbol or number
|
|
|
4801 "x="
|
|
|
4802 "#!"
|
|
|
4803 )
|
|
|
4804 ;;"\\)\\|\\("
|
|
|
4805 "\\|"
|
|
|
4806 )
|
|
|
4807 ;;"\\)"
|
|
|
4808 ;;)
|
|
|
4809 "Matches places in the buffer we can find help for.")
|
|
|
4810
|
|
|
4811 (defvar cperl-message-on-help-error t)
|
|
193
|
4812 (defvar cperl-help-from-hook nil)
|
|
110
|
4813
|
|
|
4814 (defun cperl-word-at-point-hard ()
|
|
|
4815 ;; Does not save-excursion
|
|
|
4816 ;; Get to the something meaningful
|
|
|
4817 (or (eobp) (eolp) (forward-char 1))
|
|
|
4818 (re-search-backward "[-a-zA-Z0-9_:!&*+,-./<=>?\\\\^|~$%@]"
|
|
|
4819 (save-excursion (beginning-of-line) (point))
|
|
|
4820 'to-beg)
|
|
|
4821 ;; (cond
|
|
|
4822 ;; ((or (eobp) (looking-at "[][ \t\n{}();,]")) ; Not at a symbol
|
|
|
4823 ;; (skip-chars-backward " \n\t\r({[]});,")
|
|
|
4824 ;; (or (bobp) (backward-char 1))))
|
|
|
4825 ;; Try to backtrace
|
|
|
4826 (cond
|
|
|
4827 ((looking-at "[a-zA-Z0-9_:]") ; symbol
|
|
193
|
4828 (skip-chars-backward "a-zA-Z0-9_:")
|
|
110
|
4829 (cond
|
|
|
4830 ((and (eq (preceding-char) ?^) ; $^I
|
|
|
4831 (eq (char-after (- (point) 2)) ?\$))
|
|
|
4832 (forward-char -2))
|
|
|
4833 ((memq (preceding-char) (append "*$@%&\\" nil)) ; *glob
|
|
|
4834 (forward-char -1))
|
|
|
4835 ((and (eq (preceding-char) ?\=)
|
|
|
4836 (eq (current-column) 1))
|
|
|
4837 (forward-char -1))) ; =head1
|
|
|
4838 (if (and (eq (preceding-char) ?\<)
|
|
|
4839 (looking-at "\\$?[a-zA-Z0-9_:]+>")) ; <FH>
|
|
|
4840 (forward-char -1)))
|
|
|
4841 ((and (looking-at "=") (eq (preceding-char) ?x)) ; x=
|
|
|
4842 (forward-char -1))
|
|
|
4843 ((and (looking-at "\\^") (eq (preceding-char) ?\$)) ; $^I
|
|
|
4844 (forward-char -1))
|
|
|
4845 ((looking-at "[-!&*+,-./<=>?\\\\^|~]")
|
|
193
|
4846 (skip-chars-backward "-!&*+,-./<=>?\\\\^|~")
|
|
110
|
4847 (cond
|
|
|
4848 ((and (eq (preceding-char) ?\$)
|
|
|
4849 (not (eq (char-after (- (point) 2)) ?\$))) ; $-
|
|
|
4850 (forward-char -1))
|
|
|
4851 ((and (eq (following-char) ?\>)
|
|
|
4852 (string-match "[a-zA-Z0-9_]" (char-to-string (preceding-char)))
|
|
|
4853 (save-excursion
|
|
|
4854 (forward-sexp -1)
|
|
|
4855 (and (eq (preceding-char) ?\<)
|
|
|
4856 (looking-at "\\$?[a-zA-Z0-9_:]+>")))) ; <FH>
|
|
|
4857 (search-backward "<"))))
|
|
|
4858 ((and (eq (following-char) ?\$)
|
|
|
4859 (eq (preceding-char) ?\<)
|
|
|
4860 (looking-at "\\$?[a-zA-Z0-9_:]+>")) ; <$fh>
|
|
|
4861 (forward-char -1)))
|
|
|
4862 (if (looking-at cperl-have-help-regexp)
|
|
|
4863 (buffer-substring (match-beginning 0) (match-end 0))))
|
|
4
|
4864
|
|
|
4865 (defun cperl-get-help ()
|
|
|
4866 "Get one-line docs on the symbol at the point.
|
|
|
4867 The data for these docs is a little bit obsolete and may be in fact longer
|
|
|
4868 than a line. Your contribution to update/shorten it is appreciated."
|
|
|
4869 (interactive)
|
|
193
|
4870 (save-match-data ; May be called "inside" query-replace
|
|
|
4871 (save-excursion
|
|
|
4872 (let ((word (cperl-word-at-point-hard)))
|
|
|
4873 (if word
|
|
|
4874 (if (and cperl-help-from-hook ; Bail out if not in mainland
|
|
|
4875 (not (string-match "^#!\\|\\\\\\|^=" word)) ; Show help even in comments/strings.
|
|
|
4876 (or (memq (get-text-property (point) 'face)
|
|
|
4877 '(font-lock-comment-face font-lock-string-face))
|
|
|
4878 (memq (get-text-property (point) 'syntax-type)
|
|
|
4879 '(pod here-doc format))))
|
|
|
4880 nil
|
|
|
4881 (cperl-describe-perl-symbol word))
|
|
|
4882 (if cperl-message-on-help-error
|
|
|
4883 (message "Nothing found for %s..."
|
|
|
4884 (buffer-substring (point) (min (+ 5 (point)) (point-max))))))))))
|
|
4
|
4885
|
|
|
4886 ;;; Stolen from perl-descr.el by Johan Vromans:
|
|
|
4887
|
|
|
4888 (defvar cperl-doc-buffer " *perl-doc*"
|
|
|
4889 "Where the documentation can be found.")
|
|
193
|
4890 (defvar cperl-last-help nil
|
|
|
4891 "The last help message, for echo area refresh.")
|
|
|
4892 (make-variable-buffer-local 'cperl-last-help)
|
|
4
|
4893
|
|
|
4894 (defun cperl-describe-perl-symbol (val)
|
|
|
4895 "Display the documentation of symbol at point, a Perl operator."
|
|
110
|
4896 (let ((enable-recursive-minibuffers t)
|
|
4
|
4897 args-file regexp)
|
|
|
4898 (cond
|
|
|
4899 ((string-match "^[&*][a-zA-Z_]" val)
|
|
|
4900 (setq val (concat (substring val 0 1) "NAME")))
|
|
110
|
4901 ((string-match "^[$@]\\([a-zA-Z_:0-9]+\\)[ \t]*\\[" val)
|
|
|
4902 (setq val (concat "@" (substring val 1 (match-end 1)))))
|
|
|
4903 ((string-match "^[$@]\\([a-zA-Z_:0-9]+\\)[ \t]*{" val)
|
|
|
4904 (setq val (concat "%" (substring val 1 (match-end 1)))))
|
|
|
4905 ((and (string= val "x") (string-match "^x=" val))
|
|
4
|
4906 (setq val "x="))
|
|
|
4907 ((string-match "^\\$[\C-a-\C-z]" val)
|
|
|
4908 (setq val (concat "$^" (char-to-string (+ ?A -1 (aref val 1))))))
|
|
110
|
4909 ((string-match "^CORE::" val)
|
|
|
4910 (setq val "CORE::"))
|
|
|
4911 ((string-match "^SUPER::" val)
|
|
|
4912 (setq val "SUPER::"))
|
|
|
4913 ((and (string= "<" val) (string-match "^<\\$?[a-zA-Z0-9_:]+>" val))
|
|
4
|
4914 (setq val "<NAME>")))
|
|
110
|
4915 (setq regexp (concat "^"
|
|
|
4916 "\\([^a-zA-Z0-9_:]+[ \t]+\\)?"
|
|
4
|
4917 (regexp-quote val)
|
|
|
4918 "\\([ \t([/]\\|$\\)"))
|
|
|
4919
|
|
|
4920 ;; get the buffer with the documentation text
|
|
|
4921 (cperl-switch-to-doc-buffer)
|
|
|
4922
|
|
|
4923 ;; lookup in the doc
|
|
|
4924 (goto-char (point-min))
|
|
|
4925 (let ((case-fold-search nil))
|
|
|
4926 (list
|
|
|
4927 (if (re-search-forward regexp (point-max) t)
|
|
|
4928 (save-excursion
|
|
|
4929 (beginning-of-line 1)
|
|
|
4930 (let ((lnstart (point)))
|
|
|
4931 (end-of-line)
|
|
193
|
4932 (setq cperl-last-help
|
|
|
4933 (cperl-message "%s" (buffer-substring lnstart (point))))))
|
|
4
|
4934 (if cperl-message-on-help-error
|
|
193
|
4935 (cperl-message "No definition for %s" val)))))))
|
|
4
|
4936
|
|
|
4937 (defvar cperl-short-docs "Ignore my value"
|
|
110
|
4938 ;; Perl4 version was written by Johan Vromans (jvromans@squirrel.nl)
|
|
4
|
4939 "# based on '@(#)@ perl-descr.el 1.9 - describe-perl-symbol' [Perl 5]
|
|
110
|
4940 ! ... Logical negation.
|
|
|
4941 ... != ... Numeric inequality.
|
|
|
4942 ... !~ ... Search pattern, substitution, or translation (negated).
|
|
4
|
4943 $! In numeric context: errno. In a string context: error string.
|
|
|
4944 $\" The separator which joins elements of arrays interpolated in strings.
|
|
|
4945 $# The output format for printed numbers. Initial value is %.20g.
|
|
110
|
4946 $$ Process number of this script. Changes in the fork()ed child process.
|
|
4
|
4947 $% The current page number of the currently selected output channel.
|
|
|
4948
|
|
|
4949 The following variables are always local to the current block:
|
|
|
4950
|
|
|
4951 $1 Match of the 1st set of parentheses in the last match (auto-local).
|
|
|
4952 $2 Match of the 2nd set of parentheses in the last match (auto-local).
|
|
|
4953 $3 Match of the 3rd set of parentheses in the last match (auto-local).
|
|
|
4954 $4 Match of the 4th set of parentheses in the last match (auto-local).
|
|
|
4955 $5 Match of the 5th set of parentheses in the last match (auto-local).
|
|
|
4956 $6 Match of the 6th set of parentheses in the last match (auto-local).
|
|
|
4957 $7 Match of the 7th set of parentheses in the last match (auto-local).
|
|
|
4958 $8 Match of the 8th set of parentheses in the last match (auto-local).
|
|
|
4959 $9 Match of the 9th set of parentheses in the last match (auto-local).
|
|
|
4960 $& The string matched by the last pattern match (auto-local).
|
|
|
4961 $' The string after what was matched by the last match (auto-local).
|
|
|
4962 $` The string before what was matched by the last match (auto-local).
|
|
|
4963
|
|
|
4964 $( The real gid of this process.
|
|
|
4965 $) The effective gid of this process.
|
|
|
4966 $* Deprecated: Set to 1 to do multiline matching within a string.
|
|
|
4967 $+ The last bracket matched by the last search pattern.
|
|
|
4968 $, The output field separator for the print operator.
|
|
|
4969 $- The number of lines left on the page.
|
|
|
4970 $. The current input line number of the last filehandle that was read.
|
|
|
4971 $/ The input record separator, newline by default.
|
|
110
|
4972 $0 Name of the file containing the perl script being executed. May be set.
|
|
|
4973 $: String may be broken after these characters to fill ^-lines in a format.
|
|
|
4974 $; Subscript separator for multi-dim array emulation. Default \"\\034\".
|
|
4
|
4975 $< The real uid of this process.
|
|
|
4976 $= The page length of the current output channel. Default is 60 lines.
|
|
|
4977 $> The effective uid of this process.
|
|
|
4978 $? The status returned by the last ``, pipe close or `system'.
|
|
|
4979 $@ The perl error message from the last eval or do @var{EXPR} command.
|
|
|
4980 $ARGV The name of the current file used with <> .
|
|
|
4981 $[ Deprecated: The index of the first element/char in an array/string.
|
|
|
4982 $\\ The output record separator for the print operator.
|
|
|
4983 $] The perl version string as displayed with perl -v.
|
|
|
4984 $^ The name of the current top-of-page format.
|
|
|
4985 $^A The current value of the write() accumulator for format() lines.
|
|
|
4986 $^D The value of the perl debug (-D) flags.
|
|
|
4987 $^E Information about the last system error other than that provided by $!.
|
|
|
4988 $^F The highest system file descriptor, ordinarily 2.
|
|
|
4989 $^H The current set of syntax checks enabled by `use strict'.
|
|
|
4990 $^I The value of the in-place edit extension (perl -i option).
|
|
|
4991 $^L What formats output to perform a formfeed. Default is \f.
|
|
|
4992 $^O The operating system name under which this copy of Perl was built.
|
|
|
4993 $^P Internal debugging flag.
|
|
|
4994 $^T The time the script was started. Used by -A/-M/-C file tests.
|
|
|
4995 $^W True if warnings are requested (perl -w flag).
|
|
|
4996 $^X The name under which perl was invoked (argv[0] in C-speech).
|
|
|
4997 $_ The default input and pattern-searching space.
|
|
110
|
4998 $| Auto-flush after write/print on the current output channel? Default 0.
|
|
4
|
4999 $~ The name of the current report format.
|
|
110
|
5000 ... % ... Modulo division.
|
|
|
5001 ... %= ... Modulo division assignment.
|
|
4
|
5002 %ENV Contains the current environment.
|
|
|
5003 %INC List of files that have been require-d or do-ne.
|
|
|
5004 %SIG Used to set signal handlers for various signals.
|
|
110
|
5005 ... & ... Bitwise and.
|
|
|
5006 ... && ... Logical and.
|
|
|
5007 ... &&= ... Logical and assignment.
|
|
|
5008 ... &= ... Bitwise and assignment.
|
|
|
5009 ... * ... Multiplication.
|
|
|
5010 ... ** ... Exponentiation.
|
|
|
5011 *NAME Glob: all objects refered by NAME. *NAM1 = *NAM2 aliases NAM1 to NAM2.
|
|
4
|
5012 &NAME(arg0, ...) Subroutine call. Arguments go to @_.
|
|
110
|
5013 ... + ... Addition. +EXPR Makes EXPR into scalar context.
|
|
|
5014 ++ Auto-increment (magical on strings). ++EXPR EXPR++
|
|
|
5015 ... += ... Addition assignment.
|
|
4
|
5016 , Comma operator.
|
|
110
|
5017 ... - ... Subtraction.
|
|
|
5018 -- Auto-decrement (NOT magical on strings). --EXPR EXPR--
|
|
|
5019 ... -= ... Subtraction assignment.
|
|
4
|
5020 -A Access time in days since script started.
|
|
|
5021 -B File is a non-text (binary) file.
|
|
|
5022 -C Inode change time in days since script started.
|
|
|
5023 -M Age in days since script started.
|
|
|
5024 -O File is owned by real uid.
|
|
|
5025 -R File is readable by real uid.
|
|
|
5026 -S File is a socket .
|
|
|
5027 -T File is a text file.
|
|
|
5028 -W File is writable by real uid.
|
|
|
5029 -X File is executable by real uid.
|
|
|
5030 -b File is a block special file.
|
|
|
5031 -c File is a character special file.
|
|
|
5032 -d File is a directory.
|
|
|
5033 -e File exists .
|
|
|
5034 -f File is a plain file.
|
|
|
5035 -g File has setgid bit set.
|
|
|
5036 -k File has sticky bit set.
|
|
|
5037 -l File is a symbolic link.
|
|
|
5038 -o File is owned by effective uid.
|
|
|
5039 -p File is a named pipe (FIFO).
|
|
|
5040 -r File is readable by effective uid.
|
|
|
5041 -s File has non-zero size.
|
|
|
5042 -t Tests if filehandle (STDIN by default) is opened to a tty.
|
|
|
5043 -u File has setuid bit set.
|
|
|
5044 -w File is writable by effective uid.
|
|
|
5045 -x File is executable by effective uid.
|
|
|
5046 -z File has zero size.
|
|
|
5047 . Concatenate strings.
|
|
|
5048 .. Alternation, also range operator.
|
|
|
5049 .= Concatenate assignment strings
|
|
110
|
5050 ... / ... Division. /PATTERN/ioxsmg Pattern match
|
|
|
5051 ... /= ... Division assignment.
|
|
4
|
5052 /PATTERN/ioxsmg Pattern match.
|
|
110
|
5053 ... < ... Numeric less than. <pattern> Glob. See <NAME>, <> as well.
|
|
4
|
5054 <NAME> Reads line from filehandle NAME. NAME must be bareword/dollar-bareword.
|
|
|
5055 <pattern> Glob. (Unless pattern is bareword/dollar-bareword - see <NAME>)
|
|
|
5056 <> Reads line from union of files in @ARGV (= command line) and STDIN.
|
|
110
|
5057 ... << ... Bitwise shift left. << start of HERE-DOCUMENT.
|
|
|
5058 ... <= ... Numeric less than or equal to.
|
|
|
5059 ... <=> ... Numeric compare.
|
|
|
5060 ... = ... Assignment.
|
|
|
5061 ... == ... Numeric equality.
|
|
|
5062 ... =~ ... Search pattern, substitution, or translation
|
|
|
5063 ... > ... Numeric greater than.
|
|
|
5064 ... >= ... Numeric greater than or equal to.
|
|
|
5065 ... >> ... Bitwise shift right.
|
|
|
5066 ... >>= ... Bitwise shift right assignment.
|
|
|
5067 ... ? ... : ... Condition=if-then-else operator. ?PAT? One-time pattern match.
|
|
|
5068 ?PATTERN? One-time pattern match.
|
|
4
|
5069 @ARGV Command line arguments (not including the command name - see $0).
|
|
|
5070 @INC List of places to look for perl scripts during do/include/use.
|
|
|
5071 @_ Parameter array for subroutines. Also used by split unless in array context.
|
|
193
|
5072 \\ Creates reference to what follows, like \$var, or quotes non-\w in strings.
|
|
4
|
5073 \\0 Octal char, e.g. \\033.
|
|
|
5074 \\E Case modification terminator. See \\Q, \\L, and \\U.
|
|
110
|
5075 \\L Lowercase until \\E . See also \l, lc.
|
|
|
5076 \\U Upcase until \\E . See also \u, uc.
|
|
|
5077 \\Q Quote metacharacters until \\E . See also quotemeta.
|
|
4
|
5078 \\a Alarm character (octal 007).
|
|
|
5079 \\b Backspace character (octal 010).
|
|
|
5080 \\c Control character, e.g. \\c[ .
|
|
|
5081 \\e Escape character (octal 033).
|
|
|
5082 \\f Formfeed character (octal 014).
|
|
193
|
5083 \\l Lowercase the next character. See also \\L and \\u, lcfirst.
|
|
|
5084 \\n Newline character (octal 012 on most systems).
|
|
|
5085 \\r Return character (octal 015 on most systems).
|
|
4
|
5086 \\t Tab character (octal 011).
|
|
193
|
5087 \\u Upcase the next character. See also \\U and \\l, ucfirst.
|
|
4
|
5088 \\x Hex character, e.g. \\x1b.
|
|
193
|
5089 ... ^ ... Bitwise exclusive or.
|
|
110
|
5090 __END__ Ends program source.
|
|
|
5091 __DATA__ Ends program source.
|
|
4
|
5092 __FILE__ Current (source) filename.
|
|
|
5093 __LINE__ Current line in current source.
|
|
193
|
5094 __PACKAGE__ Current package.
|
|
4
|
5095 ARGV Default multi-file input filehandle. <ARGV> is a synonym for <>.
|
|
|
5096 ARGVOUT Output filehandle with -i flag.
|
|
110
|
5097 BEGIN { ... } Immediately executed (during compilation) piece of code.
|
|
|
5098 END { ... } Pseudo-subroutine executed after the script finishes.
|
|
4
|
5099 DATA Input filehandle for what follows after __END__ or __DATA__.
|
|
|
5100 accept(NEWSOCKET,GENERICSOCKET)
|
|
|
5101 alarm(SECONDS)
|
|
|
5102 atan2(X,Y)
|
|
|
5103 bind(SOCKET,NAME)
|
|
|
5104 binmode(FILEHANDLE)
|
|
|
5105 caller[(LEVEL)]
|
|
|
5106 chdir(EXPR)
|
|
|
5107 chmod(LIST)
|
|
|
5108 chop[(LIST|VAR)]
|
|
|
5109 chown(LIST)
|
|
|
5110 chroot(FILENAME)
|
|
|
5111 close(FILEHANDLE)
|
|
|
5112 closedir(DIRHANDLE)
|
|
110
|
5113 ... cmp ... String compare.
|
|
4
|
5114 connect(SOCKET,NAME)
|
|
|
5115 continue of { block } continue { block }. Is executed after `next' or at end.
|
|
|
5116 cos(EXPR)
|
|
|
5117 crypt(PLAINTEXT,SALT)
|
|
110
|
5118 dbmclose(%HASH)
|
|
|
5119 dbmopen(%HASH,DBNAME,MODE)
|
|
4
|
5120 defined(EXPR)
|
|
110
|
5121 delete($HASH{KEY})
|
|
4
|
5122 die(LIST)
|
|
|
5123 do { ... }|SUBR while|until EXPR executes at least once
|
|
193
|
5124 do(EXPR|SUBR([LIST])) (with while|until executes at least once)
|
|
4
|
5125 dump LABEL
|
|
110
|
5126 each(%HASH)
|
|
4
|
5127 endgrent
|
|
|
5128 endhostent
|
|
|
5129 endnetent
|
|
|
5130 endprotoent
|
|
|
5131 endpwent
|
|
|
5132 endservent
|
|
|
5133 eof[([FILEHANDLE])]
|
|
110
|
5134 ... eq ... String equality.
|
|
4
|
5135 eval(EXPR) or eval { BLOCK }
|
|
|
5136 exec(LIST)
|
|
|
5137 exit(EXPR)
|
|
|
5138 exp(EXPR)
|
|
|
5139 fcntl(FILEHANDLE,FUNCTION,SCALAR)
|
|
|
5140 fileno(FILEHANDLE)
|
|
|
5141 flock(FILEHANDLE,OPERATION)
|
|
|
5142 for (EXPR;EXPR;EXPR) { ... }
|
|
|
5143 foreach [VAR] (@ARRAY) { ... }
|
|
|
5144 fork
|
|
110
|
5145 ... ge ... String greater than or equal.
|
|
4
|
5146 getc[(FILEHANDLE)]
|
|
|
5147 getgrent
|
|
|
5148 getgrgid(GID)
|
|
|
5149 getgrnam(NAME)
|
|
|
5150 gethostbyaddr(ADDR,ADDRTYPE)
|
|
|
5151 gethostbyname(NAME)
|
|
|
5152 gethostent
|
|
|
5153 getlogin
|
|
|
5154 getnetbyaddr(ADDR,ADDRTYPE)
|
|
|
5155 getnetbyname(NAME)
|
|
|
5156 getnetent
|
|
|
5157 getpeername(SOCKET)
|
|
|
5158 getpgrp(PID)
|
|
|
5159 getppid
|
|
|
5160 getpriority(WHICH,WHO)
|
|
|
5161 getprotobyname(NAME)
|
|
|
5162 getprotobynumber(NUMBER)
|
|
|
5163 getprotoent
|
|
|
5164 getpwent
|
|
|
5165 getpwnam(NAME)
|
|
|
5166 getpwuid(UID)
|
|
|
5167 getservbyname(NAME,PROTO)
|
|
|
5168 getservbyport(PORT,PROTO)
|
|
|
5169 getservent
|
|
|
5170 getsockname(SOCKET)
|
|
|
5171 getsockopt(SOCKET,LEVEL,OPTNAME)
|
|
|
5172 gmtime(EXPR)
|
|
|
5173 goto LABEL
|
|
|
5174 grep(EXPR,LIST)
|
|
110
|
5175 ... gt ... String greater than.
|
|
4
|
5176 hex(EXPR)
|
|
|
5177 if (EXPR) { ... } [ elsif (EXPR) { ... } ... ] [ else { ... } ] or EXPR if EXPR
|
|
|
5178 index(STR,SUBSTR[,OFFSET])
|
|
|
5179 int(EXPR)
|
|
|
5180 ioctl(FILEHANDLE,FUNCTION,SCALAR)
|
|
|
5181 join(EXPR,LIST)
|
|
110
|
5182 keys(%HASH)
|
|
4
|
5183 kill(LIST)
|
|
|
5184 last [LABEL]
|
|
110
|
5185 ... le ... String less than or equal.
|
|
4
|
5186 length(EXPR)
|
|
|
5187 link(OLDFILE,NEWFILE)
|
|
|
5188 listen(SOCKET,QUEUESIZE)
|
|
|
5189 local(LIST)
|
|
|
5190 localtime(EXPR)
|
|
|
5191 log(EXPR)
|
|
|
5192 lstat(EXPR|FILEHANDLE|VAR)
|
|
110
|
5193 ... lt ... String less than.
|
|
4
|
5194 m/PATTERN/iogsmx
|
|
|
5195 mkdir(FILENAME,MODE)
|
|
|
5196 msgctl(ID,CMD,ARG)
|
|
|
5197 msgget(KEY,FLAGS)
|
|
|
5198 msgrcv(ID,VAR,SIZE,TYPE.FLAGS)
|
|
|
5199 msgsnd(ID,MSG,FLAGS)
|
|
|
5200 my VAR or my (VAR1,...) Introduces a lexical variable ($VAR, @ARR, or %HASH).
|
|
110
|
5201 ... ne ... String inequality.
|
|
4
|
5202 next [LABEL]
|
|
|
5203 oct(EXPR)
|
|
|
5204 open(FILEHANDLE[,EXPR])
|
|
|
5205 opendir(DIRHANDLE,EXPR)
|
|
193
|
5206 ord(EXPR) ASCII value of the first char of the string.
|
|
4
|
5207 pack(TEMPLATE,LIST)
|
|
110
|
5208 package NAME Introduces package context.
|
|
193
|
5209 pipe(READHANDLE,WRITEHANDLE) Create a pair of filehandles on ends of a pipe.
|
|
4
|
5210 pop(ARRAY)
|
|
|
5211 print [FILEHANDLE] [(LIST)]
|
|
|
5212 printf [FILEHANDLE] (FORMAT,LIST)
|
|
|
5213 push(ARRAY,LIST)
|
|
|
5214 q/STRING/ Synonym for 'STRING'
|
|
|
5215 qq/STRING/ Synonym for \"STRING\"
|
|
|
5216 qx/STRING/ Synonym for `STRING`
|
|
|
5217 rand[(EXPR)]
|
|
|
5218 read(FILEHANDLE,SCALAR,LENGTH[,OFFSET])
|
|
|
5219 readdir(DIRHANDLE)
|
|
|
5220 readlink(EXPR)
|
|
|
5221 recv(SOCKET,SCALAR,LEN,FLAGS)
|
|
|
5222 redo [LABEL]
|
|
|
5223 rename(OLDNAME,NEWNAME)
|
|
|
5224 require [FILENAME | PERL_VERSION]
|
|
|
5225 reset[(EXPR)]
|
|
|
5226 return(LIST)
|
|
|
5227 reverse(LIST)
|
|
|
5228 rewinddir(DIRHANDLE)
|
|
|
5229 rindex(STR,SUBSTR[,OFFSET])
|
|
|
5230 rmdir(FILENAME)
|
|
|
5231 s/PATTERN/REPLACEMENT/gieoxsm
|
|
|
5232 scalar(EXPR)
|
|
|
5233 seek(FILEHANDLE,POSITION,WHENCE)
|
|
|
5234 seekdir(DIRHANDLE,POS)
|
|
|
5235 select(FILEHANDLE | RBITS,WBITS,EBITS,TIMEOUT)
|
|
|
5236 semctl(ID,SEMNUM,CMD,ARG)
|
|
|
5237 semget(KEY,NSEMS,SIZE,FLAGS)
|
|
|
5238 semop(KEY,...)
|
|
|
5239 send(SOCKET,MSG,FLAGS[,TO])
|
|
|
5240 setgrent
|
|
|
5241 sethostent(STAYOPEN)
|
|
|
5242 setnetent(STAYOPEN)
|
|
|
5243 setpgrp(PID,PGRP)
|
|
|
5244 setpriority(WHICH,WHO,PRIORITY)
|
|
|
5245 setprotoent(STAYOPEN)
|
|
|
5246 setpwent
|
|
|
5247 setservent(STAYOPEN)
|
|
|
5248 setsockopt(SOCKET,LEVEL,OPTNAME,OPTVAL)
|
|
|
5249 shift[(ARRAY)]
|
|
|
5250 shmctl(ID,CMD,ARG)
|
|
|
5251 shmget(KEY,SIZE,FLAGS)
|
|
|
5252 shmread(ID,VAR,POS,SIZE)
|
|
|
5253 shmwrite(ID,STRING,POS,SIZE)
|
|
|
5254 shutdown(SOCKET,HOW)
|
|
|
5255 sin(EXPR)
|
|
|
5256 sleep[(EXPR)]
|
|
|
5257 socket(SOCKET,DOMAIN,TYPE,PROTOCOL)
|
|
|
5258 socketpair(SOCKET1,SOCKET2,DOMAIN,TYPE,PROTOCOL)
|
|
|
5259 sort [SUBROUTINE] (LIST)
|
|
|
5260 splice(ARRAY,OFFSET[,LENGTH[,LIST]])
|
|
|
5261 split[(/PATTERN/[,EXPR[,LIMIT]])]
|
|
|
5262 sprintf(FORMAT,LIST)
|
|
|
5263 sqrt(EXPR)
|
|
|
5264 srand(EXPR)
|
|
|
5265 stat(EXPR|FILEHANDLE|VAR)
|
|
|
5266 study[(SCALAR)]
|
|
110
|
5267 sub [NAME [(format)]] { BODY } sub NAME [(format)]; sub [(format)] {...}
|
|
4
|
5268 substr(EXPR,OFFSET[,LEN])
|
|
|
5269 symlink(OLDFILE,NEWFILE)
|
|
|
5270 syscall(LIST)
|
|
|
5271 sysread(FILEHANDLE,SCALAR,LENGTH[,OFFSET])
|
|
|
5272 system(LIST)
|
|
|
5273 syswrite(FILEHANDLE,SCALAR,LENGTH[,OFFSET])
|
|
|
5274 tell[(FILEHANDLE)]
|
|
|
5275 telldir(DIRHANDLE)
|
|
|
5276 time
|
|
|
5277 times
|
|
|
5278 tr/SEARCHLIST/REPLACEMENTLIST/cds
|
|
|
5279 truncate(FILE|EXPR,LENGTH)
|
|
|
5280 umask[(EXPR)]
|
|
|
5281 undef[(EXPR)]
|
|
|
5282 unless (EXPR) { ... } [ else { ... } ] or EXPR unless EXPR
|
|
|
5283 unlink(LIST)
|
|
|
5284 unpack(TEMPLATE,EXPR)
|
|
|
5285 unshift(ARRAY,LIST)
|
|
110
|
5286 until (EXPR) { ... } EXPR until EXPR
|
|
4
|
5287 utime(LIST)
|
|
110
|
5288 values(%HASH)
|
|
4
|
5289 vec(EXPR,OFFSET,BITS)
|
|
|
5290 wait
|
|
|
5291 waitpid(PID,FLAGS)
|
|
193
|
5292 wantarray Returns true if the sub/eval is called in list context.
|
|
4
|
5293 warn(LIST)
|
|
110
|
5294 while (EXPR) { ... } EXPR while EXPR
|
|
4
|
5295 write[(EXPR|FILEHANDLE)]
|
|
110
|
5296 ... x ... Repeat string or array.
|
|
|
5297 x= ... Repetition assignment.
|
|
4
|
5298 y/SEARCHLIST/REPLACEMENTLIST/
|
|
110
|
5299 ... | ... Bitwise or.
|
|
|
5300 ... || ... Logical or.
|
|
|
5301 ~ ... Unary bitwise complement.
|
|
4
|
5302 #! OS interpreter indicator. If contains `perl', used for options, and -x.
|
|
110
|
5303 AUTOLOAD {...} Shorthand for `sub AUTOLOAD {...}'.
|
|
|
5304 CORE:: Prefix to access builtin function if imported sub obscures it.
|
|
|
5305 SUPER:: Prefix to lookup for a method in @ISA classes.
|
|
|
5306 DESTROY Shorthand for `sub DESTROY {...}'.
|
|
|
5307 ... EQ ... Obsolete synonym of `eq'.
|
|
|
5308 ... GE ... Obsolete synonym of `ge'.
|
|
|
5309 ... GT ... Obsolete synonym of `gt'.
|
|
|
5310 ... LE ... Obsolete synonym of `le'.
|
|
|
5311 ... LT ... Obsolete synonym of `lt'.
|
|
|
5312 ... NE ... Obsolete synonym of `ne'.
|
|
|
5313 abs [ EXPR ] absolute value
|
|
|
5314 ... and ... Low-precedence synonym for &&.
|
|
|
5315 bless REFERENCE [, PACKAGE] Makes reference into an object of a package.
|
|
193
|
5316 chomp [LIST] Strips $/ off LIST/$_. Returns count. Special if $/ eq ''!
|
|
|
5317 chr Converts a number to char with the same ordinal.
|
|
110
|
5318 else Part of if/unless {BLOCK} elsif {BLOCK} else {BLOCK}.
|
|
|
5319 elsif Part of if/unless {BLOCK} elsif {BLOCK} else {BLOCK}.
|
|
|
5320 exists $HASH{KEY} True if the key exists.
|
|
193
|
5321 format [NAME] = Start of output format. Ended by a single dot (.) on a line.
|
|
|
5322 formline PICTURE, LIST Backdoor into \"format\" processing.
|
|
110
|
5323 glob EXPR Synonym of <EXPR>.
|
|
|
5324 lc [ EXPR ] Returns lowercased EXPR.
|
|
|
5325 lcfirst [ EXPR ] Returns EXPR with lower-cased first letter.
|
|
193
|
5326 map EXPR, LIST or map {BLOCK} LIST Applies EXPR/BLOCK to elts of LIST.
|
|
110
|
5327 no PACKAGE [SYMBOL1, ...] Partial reverse for `use'. Runs `unimport' method.
|
|
193
|
5328 not ... Low-precedence synonym for ! - negation.
|
|
110
|
5329 ... or ... Low-precedence synonym for ||.
|
|
|
5330 pos STRING Set/Get end-position of the last match over this string, see \\G.
|
|
193
|
5331 quotemeta [ EXPR ] Quote regexp metacharacters.
|
|
|
5332 qw/WORD1 .../ Synonym of split('', 'WORD1 ...')
|
|
110
|
5333 readline FH Synonym of <FH>.
|
|
|
5334 readpipe CMD Synonym of `CMD`.
|
|
|
5335 ref [ EXPR ] Type of EXPR when dereferenced.
|
|
193
|
5336 sysopen FH, FILENAME, MODE [, PERM] (MODE is numeric, see Fcntl.)
|
|
|
5337 tie VAR, PACKAGE, LIST Hide an object behind a simple Perl variable.
|
|
|
5338 tied Returns internal object for a tied data.
|
|
110
|
5339 uc [ EXPR ] Returns upcased EXPR.
|
|
|
5340 ucfirst [ EXPR ] Returns EXPR with upcased first letter.
|
|
193
|
5341 untie VAR Unlink an object from a simple Perl variable.
|
|
110
|
5342 use PACKAGE [SYMBOL1, ...] Compile-time `require' with consequent `import'.
|
|
|
5343 ... xor ... Low-precedence synonym for exclusive or.
|
|
|
5344 prototype \&SUB Returns prototype of the function given a reference.
|
|
|
5345 =head1 Top-level heading.
|
|
|
5346 =head2 Second-level heading.
|
|
|
5347 =head3 Third-level heading (is there such?).
|
|
|
5348 =over [ NUMBER ] Start list.
|
|
|
5349 =item [ TITLE ] Start new item in the list.
|
|
|
5350 =back End list.
|
|
|
5351 =cut Switch from POD to Perl.
|
|
|
5352 =pod Switch from Perl to POD.
|
|
4
|
5353 ")
|
|
|
5354
|
|
|
5355 (defun cperl-switch-to-doc-buffer ()
|
|
|
5356 "Go to the perl documentation buffer and insert the documentation."
|
|
|
5357 (interactive)
|
|
|
5358 (let ((buf (get-buffer-create cperl-doc-buffer)))
|
|
|
5359 (if (interactive-p)
|
|
|
5360 (switch-to-buffer-other-window buf)
|
|
|
5361 (set-buffer buf))
|
|
|
5362 (if (= (buffer-size) 0)
|
|
|
5363 (progn
|
|
|
5364 (insert (documentation-property 'cperl-short-docs
|
|
|
5365 'variable-documentation))
|
|
|
5366 (setq buffer-read-only t)))))
|
|
|
5367
|
|
193
|
5368 (defun cperl-beautify-regexp-piece (b e embed)
|
|
|
5369 ;; b is before the starting delimiter, e before the ending
|
|
|
5370 ;; e should be a marker, may be changed, but remains "correct".
|
|
|
5371 (let (s c tmp (m (make-marker)) (m1 (make-marker)) c1 spaces inline)
|
|
|
5372 (if (not embed)
|
|
|
5373 (goto-char (1+ b))
|
|
|
5374 (goto-char b)
|
|
|
5375 (cond ((looking-at "(\\?\\\\#") ; badly commented (?#)
|
|
|
5376 (forward-char 2)
|
|
|
5377 (delete-char 1)
|
|
|
5378 (forward-char 1))
|
|
|
5379 ((looking-at "(\\?[^a-zA-Z]")
|
|
|
5380 (forward-char 3))
|
|
|
5381 ((looking-at "(\\?") ; (?i)
|
|
|
5382 (forward-char 2))
|
|
|
5383 (t
|
|
|
5384 (forward-char 1))))
|
|
|
5385 (setq c (1- (current-column))
|
|
|
5386 c1 (+ c (or cperl-regexp-indent-step cperl-indent-level)))
|
|
|
5387 (or (looking-at "[ \t]*[\n#]")
|
|
|
5388 (progn
|
|
|
5389 (insert "\n")))
|
|
|
5390 (goto-char e)
|
|
|
5391 (beginning-of-line)
|
|
|
5392 (if (re-search-forward "[^ \t]" e t)
|
|
|
5393 (progn
|
|
|
5394 (goto-char e)
|
|
|
5395 (insert "\n")
|
|
|
5396 (indent-to-column c)
|
|
|
5397 (set-marker e (point))))
|
|
|
5398 (goto-char b)
|
|
|
5399 (end-of-line 2)
|
|
|
5400 (while (< (point) (marker-position e))
|
|
|
5401 (beginning-of-line)
|
|
|
5402 (setq s (point)
|
|
|
5403 inline t)
|
|
|
5404 (skip-chars-forward " \t")
|
|
|
5405 (delete-region s (point))
|
|
|
5406 (indent-to-column c1)
|
|
|
5407 (while (and
|
|
|
5408 inline
|
|
|
5409 (looking-at
|
|
|
5410 (concat "\\([a-zA-Z0-9]+[^*+{?]\\)" ; 1
|
|
|
5411 "\\|"
|
|
|
5412 "\\$\\([a-zA-Z0-9_]+\\([[{]\\)?\\|[^\n \t)|]\\)" ; 2 3
|
|
|
5413 "\\|"
|
|
|
5414 "[$^]"
|
|
|
5415 "\\|"
|
|
|
5416 "\\(\\\\.\\|[^][()#|*+?\n]\\)\\([*+{?]\\??\\)?" ; 4 5
|
|
|
5417 "\\|"
|
|
|
5418 "\\(\\[\\)" ; 6
|
|
|
5419 "\\|"
|
|
|
5420 "\\((\\(\\?\\)?\\)" ; 7 8
|
|
|
5421 "\\|"
|
|
|
5422 "\\(|\\)" ; 9
|
|
|
5423 )))
|
|
|
5424 (goto-char (match-end 0))
|
|
|
5425 (setq spaces t)
|
|
|
5426 (cond ((match-beginning 1) ; Alphanum word + junk
|
|
|
5427 (forward-char -1))
|
|
|
5428 ((or (match-beginning 3) ; $ab[12]
|
|
|
5429 (and (match-beginning 5) ; X* X+ X{2,3}
|
|
|
5430 (eq (preceding-char) ?\{)))
|
|
|
5431 (forward-char -1)
|
|
|
5432 (forward-sexp 1))
|
|
|
5433 ((match-beginning 6) ; []
|
|
|
5434 (setq tmp (point))
|
|
|
5435 (if (looking-at "\\^?\\]")
|
|
|
5436 (goto-char (match-end 0)))
|
|
|
5437 (or (re-search-forward "\\]\\([*+{?]\\)?" e t)
|
|
|
5438 (progn
|
|
|
5439 (goto-char (1- tmp))
|
|
|
5440 (error "[]-group not terminated")))
|
|
|
5441 (if (not (eq (preceding-char) ?\{)) nil
|
|
|
5442 (forward-char -1)
|
|
|
5443 (forward-sexp 1)))
|
|
|
5444 ((match-beginning 7) ; ()
|
|
|
5445 (goto-char (match-beginning 0))
|
|
|
5446 (or (eq (current-column) c1)
|
|
|
5447 (progn
|
|
|
5448 (insert "\n")
|
|
|
5449 (indent-to-column c1)))
|
|
|
5450 (setq tmp (point))
|
|
|
5451 (forward-sexp 1)
|
|
|
5452 ;; (or (forward-sexp 1)
|
|
|
5453 ;; (progn
|
|
|
5454 ;; (goto-char tmp)
|
|
|
5455 ;; (error "()-group not terminated")))
|
|
|
5456 (set-marker m (1- (point)))
|
|
|
5457 (set-marker m1 (point))
|
|
|
5458 (cperl-beautify-regexp-piece tmp m t)
|
|
|
5459 (goto-char m1)
|
|
|
5460 (cond ((looking-at "[*+?]\\??")
|
|
|
5461 (goto-char (match-end 0)))
|
|
|
5462 ((eq (following-char) ?\{)
|
|
|
5463 (forward-sexp 1)
|
|
|
5464 (if (eq (following-char) ?\?)
|
|
|
5465 (forward-char))))
|
|
|
5466 (skip-chars-forward " \t")
|
|
|
5467 (setq spaces nil)
|
|
|
5468 (if (looking-at "[#\n]")
|
|
|
5469 (beginning-of-line 2)
|
|
|
5470 (insert "\n"))
|
|
|
5471 (end-of-line)
|
|
|
5472 (setq inline nil))
|
|
|
5473 ((match-beginning 9) ; |
|
|
|
5474 (forward-char -1)
|
|
|
5475 (setq tmp (point))
|
|
|
5476 (beginning-of-line)
|
|
|
5477 (if (re-search-forward "[^ \t]" tmp t)
|
|
|
5478 (progn
|
|
|
5479 (goto-char tmp)
|
|
|
5480 (insert "\n"))
|
|
|
5481 ;; first at line
|
|
|
5482 (delete-region (point) tmp))
|
|
|
5483 (indent-to-column c)
|
|
|
5484 (forward-char 1)
|
|
|
5485 (skip-chars-forward " \t")
|
|
|
5486 (setq spaces nil)
|
|
|
5487 (if (looking-at "[#\n]")
|
|
|
5488 (beginning-of-line 2)
|
|
|
5489 (insert "\n"))
|
|
|
5490 (end-of-line)
|
|
|
5491 (setq inline nil)))
|
|
|
5492 (or (looking-at "[ \t\n]")
|
|
|
5493 (not spaces)
|
|
|
5494 (insert " "))
|
|
|
5495 (skip-chars-forward " \t"))
|
|
|
5496 (or (looking-at "[#\n]")
|
|
|
5497 (error "unknown code in a regexp"))
|
|
|
5498 (and inline (end-of-line 2)))
|
|
|
5499 ))
|
|
|
5500
|
|
|
5501 (defun cperl-beautify-regexp ()
|
|
|
5502 "do it. (Experimental, may change semantics, recheck afterwards.)
|
|
|
5503 We suppose that the regexp is scanned already."
|
|
|
5504 (interactive)
|
|
|
5505 (or cperl-use-syntax-table-text-property
|
|
|
5506 (error "I need to have regex marked!"))
|
|
|
5507 ;; Find the start
|
|
|
5508 (re-search-backward "\\s|") ; Assume it is scanned already.
|
|
|
5509 ;;(forward-char 1)
|
|
|
5510 (let ((b (point)) (e (make-marker)) have-x delim (c (current-column))
|
|
|
5511 (sub-p (eq (preceding-char) ?s)) s)
|
|
|
5512 (forward-sexp 1)
|
|
|
5513 (set-marker e (1- (point)))
|
|
|
5514 (setq delim (preceding-char))
|
|
|
5515 (if (and sub-p (eq delim (char-after (- (point) 2))))
|
|
|
5516 (error "Possible s/blah// - do not know how to deal with"))
|
|
|
5517 (if sub-p (forward-sexp 1))
|
|
|
5518 (if (looking-at "\\sw*x")
|
|
|
5519 (setq have-x t)
|
|
|
5520 (insert "x"))
|
|
|
5521 ;; Protect fragile " ", "#"
|
|
|
5522 (if have-x nil
|
|
|
5523 (goto-char (1+ b))
|
|
|
5524 (while (re-search-forward "\\(\\=\\|[^\\\\]\\)\\(\\\\\\\\\\)*[ \t\n#]" e t) ; Need to include (?#) too?
|
|
|
5525 (forward-char -1)
|
|
|
5526 (insert "\\")
|
|
|
5527 (forward-char 1)))
|
|
|
5528 (cperl-beautify-regexp-piece b e nil)))
|
|
|
5529
|
|
|
5530
|
|
|
5531 ;; Part from the original `cperl-lazy-*', and part from `eldoc'
|
|
|
5532 ;; Karl M. Hegbloom <karlheg@inetarena.com>
|
|
|
5533
|
|
|
5534 (defun cperl-help (&optional arg)
|
|
|
5535 (interactive "p")
|
|
|
5536 (cond ((and arg (<= arg 0))
|
|
|
5537 (remove-hook 'post-command-hook 'cperl-get-help-defer)
|
|
|
5538 (remove-hook 'pre-command-hook 'cperl-refresh-echo-area)
|
|
|
5539 (setq cperl-help nil))
|
|
|
5540 (t
|
|
|
5541 (add-hook 'post-command-hook 'cperl-get-help-defer)
|
|
|
5542 (add-hook 'pre-command-hook 'cperl-refresh-echo-area)
|
|
|
5543 (setq cperl-help t))))
|
|
|
5544
|
|
|
5545 (defun cperl-toggle-help ()
|
|
|
5546 (interactive)
|
|
|
5547 (if cperl-help
|
|
|
5548 (cperl-help 0)
|
|
|
5549 (cperl-help 1)))
|
|
|
5550
|
|
|
5551 (defun cperl-get-help-defer ()
|
|
|
5552 (if (not (eq major-mode 'perl-mode)) nil
|
|
|
5553 (let ((cperl-message-on-help-error nil) (cperl-help-from-hook t))
|
|
|
5554 (cperl-get-help))))
|
|
|
5555
|
|
|
5556 ;; from `eldoc-refresh-*'
|
|
|
5557 (defun cperl-refresh-echo-area ()
|
|
|
5558 (and cperl-last-help
|
|
|
5559 (if (and cperl-mode
|
|
|
5560 (not executing-kbd-macro)
|
|
|
5561 (not cursor-in-echo-area)
|
|
|
5562 (not (eq (selected-window) (minibuffer-window))))
|
|
|
5563 (cperl-message cperl-last-help)
|
|
|
5564 (setq cperl-last-help nil))))
|
|
|
5565
|
|
|
5566 ;; see `eldoc-message'
|
|
|
5567 (defun cperl-message (&rest args)
|
|
|
5568 (let ((omessage cperl-last-help))
|
|
|
5569 (cond ((eq (car args) cperl-last-help))
|
|
|
5570 ((or (null args)
|
|
|
5571 (null (car args)))
|
|
|
5572 (setq cperl-last-help nil))
|
|
|
5573 (t
|
|
|
5574 (setq cperl-last-help (apply 'format args))))
|
|
|
5575 ;; Do not put cperl-help messages in the log
|
|
|
5576 (if cperl-last-help
|
|
|
5577 (display-message 'no-log cperl-last-help)
|
|
|
5578 (and omessage
|
|
|
5579 (clear-message 'no-log))))
|
|
|
5580 cperl-last-help)
|
|
|
5581
|
|
|
5582 (when cperl-help
|
|
|
5583 (cperl-help 1))
|
|
|
5584
|
|
|
5585 (provide 'cperl-mode)
|
