Mercurial > hg > xemacs-beta
comparison lisp/modes/cperl-mode.el @ 0:376386a54a3c r19-14
Import from CVS: tag r19-14
| author | cvs |
|---|---|
| date | Mon, 13 Aug 2007 08:45:50 +0200 |
| parents | |
| children | ac2d302a0011 |
comparison
equal
deleted
inserted
replaced
| -1:000000000000 | 0:376386a54a3c |
|---|---|
| 1 ;;; This code started from the following message of long time ago (IZ): | |
| 2 | |
| 3 ;;; From: olson@mcs.anl.gov (Bob Olson) | |
| 4 ;;; Newsgroups: comp.lang.perl | |
| 5 ;;; Subject: cperl-mode: Another perl mode for Gnuemacs | |
| 6 ;;; Date: 14 Aug 91 15:20:01 GMT | |
| 7 | |
| 8 ;; Perl code editing commands for Emacs | |
| 9 ;; Copyright (C) 1985, 1986, 1987 Free Software Foundation, Inc. | |
| 10 | |
| 11 ;; This file is not (yet) part of GNU Emacs. | |
| 12 | |
| 13 ;; GNU Emacs is free software; you can redistribute it and/or modify | |
| 14 ;; it under the terms of the GNU General Public License as published by | |
| 15 ;; the Free Software Foundation; either version 2, or (at your option) | |
| 16 ;; any later version. | |
| 17 | |
| 18 ;; GNU Emacs is distributed in the hope that it will be useful, | |
| 19 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
| 20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
| 21 ;; GNU General Public License for more details. | |
| 22 | |
| 23 ;; You should have received a copy of the GNU General Public License | |
| 24 ;; along with GNU Emacs; see the file COPYING. If not, write to | |
| 25 ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. | |
| 26 | |
| 27 ;;; Synched up with: Not in FSF. | |
| 28 | |
| 29 ;;; Corrections made by Ilya Zakharevich ilya@math.mps.ohio-state.edu | |
| 30 ;;; XEmacs changes by Peter Arius arius@informatik.uni-erlangen.de | |
| 31 | |
| 32 ;; $Id: cperl-mode.el,v 1.1.1.1 1996/12/18 03:31:06 steve Exp $ | |
| 33 | |
| 34 ;;; To use this mode put the following into your .emacs file: | |
| 35 | |
| 36 ;; (autoload 'perl-mode "cperl-mode" "alternate mode for editing Perl programs" t) | |
| 37 | |
| 38 ;;; You can either fine-tune the bells and whistles of this mode or | |
| 39 ;;; bulk enable them by putting | |
| 40 | |
| 41 ;; (setq cperl-hairy t) | |
| 42 | |
| 43 ;;; in your .emacs file. (Emacs rulers do not consider it politically | |
| 44 ;;; correct to make whistles enabled by default.) | |
| 45 | |
| 46 ;;; Additional useful commands to put into your .emacs file: | |
| 47 | |
| 48 ;; (setq auto-mode-alist | |
| 49 ;; (append '(("\\.[pP][Llm]$" . perl-mode)) auto-mode-alist )) | |
| 50 ;; (setq interpreter-mode-alist (append interpreter-mode-alist | |
| 51 ;; '(("miniperl" . perl-mode)))) | |
| 52 | |
| 53 ;;; The mode information (on C-h m) provides customization help. | |
| 54 ;;; If you use font-lock feature of this mode, it is advisable to use | |
| 55 ;;; eather lazy-lock-mode or fast-lock-mode (available on ELisp | |
| 56 ;;; archive in files lazy-lock.el and fast-lock.el). I prefer lazy-lock. | |
| 57 | |
| 58 ;;; Faces used now: three faces for first-class and second-class keywords | |
| 59 ;;; and control flow words, one for each: comments, string, labels, | |
| 60 ;;; functions definitions and packages, arrays, hashes, and variable | |
| 61 ;;; definitions. If you do not see all these faces, your font-lock does | |
| 62 ;;; not define them, so you need to define them manually. Maybe you have | |
| 63 ;;; an obsolete font-lock from 19.28 or earlier. Upgrade. | |
| 64 | |
| 65 ;;; If you have grayscale monitor, and do not have the variable | |
| 66 ;;; font-lock-display-type bound to 'grayscale, insert | |
| 67 | |
| 68 ;;; (setq font-lock-display-type 'grayscale) | |
| 69 | |
| 70 ;;; to your .emacs file. | |
| 71 | |
| 72 ;;;; This mode supports font-lock, imenu and mode-compile. In the | |
| 73 ;;;; hairy version font-lock is on, but you should activate imenu | |
| 74 ;;;; yourself (note that mode-compile is not standard yet). Well, you | |
| 75 ;;;; can use imenu from keyboard anyway (M-x imenu), but it is better | |
| 76 ;;;; to bind it like that: | |
| 77 | |
| 78 ;; (define-key global-map [M-S-down-mouse-3] 'imenu) | |
| 79 | |
| 80 ;;; In fact the version of font-lock that this version supports can be | |
| 81 ;;; much newer than the version you actually have. This means that a | |
| 82 ;;; lot of faces can be set up, but are not visible on your screen | |
| 83 ;;; since the coloring rules for this faces are not defined. | |
| 84 | |
| 85 ;;; Updates: ======================================== | |
| 86 | |
| 87 ;;; Made less hairy by default: parentheses not electric, | |
| 88 ;;; linefeed not magic. Bug with abbrev-mode corrected. | |
| 89 | |
| 90 ;;;; After 1.4: | |
| 91 ;;; Better indentation: | |
| 92 ;;; subs inside braces should work now, | |
| 93 ;;; Toplevel braces obey customization. | |
| 94 ;;; indent-for-comment knows about bad cases, cperl-indent-for-comment | |
| 95 ;;; moves cursor to a correct place. | |
| 96 ;;; cperl-indent-exp written from the scratch! Slow... (quadratic!) :-( | |
| 97 ;;; (50 secs on DB::DB (sub of 430 lines), 486/66) | |
| 98 ;;; Minor documentation fixes. | |
| 99 ;;; Imenu understands packages as prefixes (including nested). | |
| 100 ;;; Hairy options can be switched off one-by-one by setting to null. | |
| 101 ;;; Names of functions and variables changed to conform to `cperl-' style. | |
| 102 | |
| 103 ;;;; After 1.5: | |
| 104 ;;; Some bugs with indentation of labels (and embedded subs) corrected. | |
| 105 ;;; `cperl-indent-region' done (slow :-()). | |
| 106 ;;; `cperl-fill-paragraph' done. | |
| 107 ;;; Better package support for `imenu'. | |
| 108 ;;; Progress indicator for indentation (with `imenu' loaded). | |
| 109 ;;; `Cperl-set' was busted, now setting the individual hairy option | |
| 110 ;;; should be better. | |
| 111 | |
| 112 ;;;; After 1.6: | |
| 113 ;;; `cperl-set-style' done. | |
| 114 ;;; `cperl-check-syntax' done. | |
| 115 ;;; Menu done. | |
| 116 ;;; New config variables `cperl-close-paren-offset' and `cperl-comment-column'. | |
| 117 ;;; Bugs with `cperl-auto-newline' corrected. | |
| 118 ;;; `cperl-electric-lbrace' can work with `cperl-auto-newline' in situation | |
| 119 ;;; like $hash{. | |
| 120 | |
| 121 ;;;; 1.7 XEmacs (arius@informatik.uni-erlangen.de): | |
| 122 ;;; - use `next-command-event', if `next-command-events' does not exist | |
| 123 ;;; - use `find-face' as def. of `is-face' | |
| 124 ;;; - corrected def. of `x-color-defined-p' | |
| 125 ;;; - added const defs for font-lock-comment-face, | |
| 126 ;;; font-lock-keyword-face and font-lock-function-name-face | |
| 127 ;;; - added def. of font-lock-variable-name-face | |
| 128 ;;; - added (require 'easymenu) inside an `eval-when-compile' | |
| 129 ;;; - replaced 4-argument `substitute-key-definition' with ordinary | |
| 130 ;;; `define-key's | |
| 131 ;;; - replaced `mark-active' in menu definition by `cperl-use-region-p'. | |
| 132 ;;; Todo (at least): | |
| 133 ;;; - use emacs-vers.el (http://www.cs.utah.edu/~eeide/emacs/emacs-vers.el.gz) | |
| 134 ;;; for portable code? | |
| 135 ;;; - should `cperl-mode' do a | |
| 136 ;;; (if (featurep 'easymenu) (easy-menu-add cperl-menu)) | |
| 137 ;;; or should this be left to the user's `cperl-mode-hook'? | |
| 138 | |
| 139 ;;; Some bugs introduced by the above fix corrected (IZ ;-). | |
| 140 ;;; Some bugs under XEmacs introduced by the correction corrected. | |
| 141 | |
| 142 ;;; Some more can remain since there are two many different variants. | |
| 143 ;;; Please feedback! | |
| 144 | |
| 145 ;;; We do not support fontification of arrays and hashes under | |
| 146 ;;; obsolete font-lock any more. Upgrade. | |
| 147 | |
| 148 ;;;; after 1.8 Minor bug with parentheses. | |
| 149 ;;;; after 1.9 Improvements from Joe Marzot. | |
| 150 ;;;; after 1.10 | |
| 151 ;;; Does not need easymenu to compile under XEmacs. | |
| 152 ;;; `vc-insert-headers' should work better. | |
| 153 ;;; Should work with 19.29 and 19.12. | |
| 154 ;;; Small improvements to fontification. | |
| 155 ;;; Expansion of keywords does not depend on C-? being backspace. | |
| 156 | |
| 157 ;;; after 1.10+ | |
| 158 ;;; 19.29 and 19.12 supported. | |
| 159 ;;; `cperl-font-lock-enhanced' deprecated. Use font-lock-extra.el. | |
| 160 ;;; Support for font-lock-extra.el. | |
| 161 | |
| 162 ;;;; After 1.11: | |
| 163 ;;; Tools submenu. | |
| 164 ;;; Support for perl5-info. | |
| 165 ;;; `imenu-go-find-at-position' in Tools requires imenu-go.el (see hints above) | |
| 166 ;;; Imenu entries do not work with stock imenu.el. Patch sent to maintainers. | |
| 167 ;;; Fontifies `require a if b;', __DATA__. | |
| 168 ;;; Arglist for auto-fill-mode was incorrect. | |
| 169 | |
| 170 ;;;; After 1.12: | |
| 171 ;;; `cperl-lineup-step' and `cperl-lineup' added: lineup constructions | |
| 172 ;;; vertically. | |
| 173 ;;; `cperl-do-auto-fill' updated for 19.29 style. | |
| 174 ;;; `cperl-info-on-command' now has a default. | |
| 175 ;;; Workaround for broken C-h on XEmacs. | |
| 176 ;;; VC strings escaped. | |
| 177 ;;; C-h f now may prompt for function name instead of going on, | |
| 178 ;;; controlled by `cperl-info-on-command-no-prompt'. | |
| 179 | |
| 180 ;;;; After 1.13: | |
| 181 ;;; Msb buffer list includes perl files | |
| 182 ;;; Indent-for-comment uses indent-to | |
| 183 ;;; Can write tag files using etags. | |
| 184 | |
| 185 ;;;; After 1.14: | |
| 186 ;;; Recognizes (tries to ;-) {...} which are not blocks during indentation. | |
| 187 ;;; `cperl-close-paren-offset' affects ?\] too (and ?\} if not block) | |
| 188 ;;; Bug with auto-filling comments started with "##" corrected. | |
| 189 | |
| 190 ;;;; Very slow now: on DB::DB 0.91, 486/66: | |
| 191 | |
| 192 ;;;Function Name Call Count Elapsed Time Average Time | |
| 193 ;;;======================================== ========== ============ ============ | |
| 194 ;;;cperl-block-p 469 3.7799999999 0.0080597014 | |
| 195 ;;;cperl-get-state 505 163.39000000 0.3235445544 | |
| 196 ;;;cperl-comment-indent 12 0.0299999999 0.0024999999 | |
| 197 ;;;cperl-backward-to-noncomment 939 4.4599999999 0.0047497337 | |
| 198 ;;;cperl-calculate-indent 505 172.22000000 0.3410297029 | |
| 199 ;;;cperl-indent-line 505 172.88000000 0.3423366336 | |
| 200 ;;;cperl-use-region-p 40 0.0299999999 0.0007499999 | |
| 201 ;;;cperl-indent-exp 1 177.97000000 177.97000000 | |
| 202 ;;;cperl-to-comment-or-eol 1453 3.9800000000 0.0027391603 | |
| 203 ;;;cperl-backward-to-start-of-continued-exp 9 0.0300000000 0.0033333333 | |
| 204 ;;;cperl-indent-region 1 177.94000000 177.94000000 | |
| 205 | |
| 206 ;;;; After 1.15: | |
| 207 ;;; Takes into account white space after opening parentheses during indent. | |
| 208 ;;; May highlight pods and here-documents: see `cperl-pod-here-scan', | |
| 209 ;;; `cperl-pod-here-fontify', `cperl-pod-face'. Does not use this info | |
| 210 ;;; for indentation so far. | |
| 211 ;;; Fontification updated to 19.30 style. | |
| 212 ;;; The change 19.29->30 did not add all the required functionality, | |
| 213 ;;; but broke "font-lock-extra.el". Get "choose-color.el" from | |
| 214 ;;; ftp://ftp.math.ohio-state.edu/pub/users/ilya/emacs | |
| 215 | |
| 216 ;;;; After 1.16: | |
| 217 ;;; else # comment | |
| 218 ;;; recognized as a start of a block. | |
| 219 ;;; Two different font-lock-levels provided. | |
| 220 ;;; `cperl-pod-head-face' introduced. Used for highlighting. | |
| 221 ;;; `imenu' marks pods, +Packages moved to the head. | |
| 222 | |
| 223 ;;;; After 1.17: | |
| 224 ;;; Scan for pods highlights here-docs too. | |
| 225 ;;; Note that the tag of here-doc may be rehighlighted later by lazy-lock. | |
| 226 ;;; Only one here-doc-tag per line is supported, and one in comment | |
| 227 ;;; or a string may break fontification. | |
| 228 ;;; POD headers were supposed to fill one line only. | |
| 229 | |
| 230 ;;;; After 1.18: | |
| 231 ;;; `font-lock-keywords' were set in 19.30 style _always_. Current scheme | |
| 232 ;;; may break under XEmacs. | |
| 233 ;;; `cperl-calculate-indent' dis suppose that `parse-start' was defined. | |
| 234 ;;; `fontified' tag is added to fontified text as well as `lazy-lock' (for | |
| 235 ;;; compatibility with older lazy-lock.el) (older one overfontifies | |
| 236 ;;; something nevertheless :-(). | |
| 237 ;;; Will not indent something inside pod and here-documents. | |
| 238 ;;; Fontifies the package name after import/no/bootstrap. | |
| 239 ;;; Added new entry to menu with meta-info about the mode. | |
| 240 | |
| 241 ;;;; After 1.19: | |
| 242 ;;; Prefontification works much better with 19.29. Should be checked | |
| 243 ;;; with 19.30 as well. | |
| 244 ;;; Some misprints in docs corrected. | |
| 245 ;;; Now $a{-text} and -text => "blah" are fontified as strings too. | |
| 246 ;;; Now the pod search is much stricter, so it can help you to find | |
| 247 ;;; pod sections which are broken because of whitespace before =blah | |
| 248 ;;; - just observe the fontification. | |
| 249 | |
| 250 ;;;; After 1.20 | |
| 251 ;;; Anonymous subs are indented with respect to the level of | |
| 252 ;;; indentation of `sub' now. | |
| 253 ;;; {} is recognized as hash after `bless' and `return'. | |
| 254 ;;; Anonymous subs are split by `cperl-linefeed' as well. | |
| 255 ;;; Electric parens embrace a region if present. | |
| 256 ;;; To make `cperl-auto-newline' useful, | |
| 257 ;;; `cperl-auto-newline-after-colon' is introduced. | |
| 258 ;;; `cperl-electric-parens' is now t or nul. The old meaning is moved to | |
| 259 ;;; `cperl-electric-parens-string'. | |
| 260 ;;; `cperl-toggle-auto-newline' introduced, put on C-c C-a. | |
| 261 ;;; `cperl-toggle-abbrev' introduced, put on C-c C-k. | |
| 262 ;;; `cperl-toggle-electric' introduced, put on C-c C-e. | |
| 263 ;;; Beginning-of-defun-regexp was not anchored. | |
| 264 | |
| 265 ;;;; After 1.21 | |
| 266 ;;; Auto-newline grants `cperl-extra-newline-before-brace' if "{" is typed | |
| 267 ;;; after ")". | |
| 268 ;;; {} is recognized as expression after `tr' and friends. | |
| 269 ;;; Works with XEmacs again. | |
| 270 | |
| 271 (defvar cperl-extra-newline-before-brace nil | |
| 272 "*Non-nil means that if, elsif, while, until, else, for, foreach | |
| 273 and do constructs look like: | |
| 274 | |
| 275 if () | |
| 276 { | |
| 277 } | |
| 278 | |
| 279 instead of: | |
| 280 | |
| 281 if () { | |
| 282 } | |
| 283 ") | |
| 284 | |
| 285 (defvar cperl-indent-level 2 | |
| 286 "*Indentation of CPerl statements with respect to containing block.") | |
| 287 (defvar cperl-lineup-step nil | |
| 288 "*`cperl-lineup' will always lineup at multiple of this number. | |
| 289 If `nil', the value of `cperl-indent-level' will be used.") | |
| 290 (defvar cperl-brace-imaginary-offset 0 | |
| 291 "*Imagined indentation of a Perl open brace that actually follows a statement. | |
| 292 An open brace following other text is treated as if it were this far | |
| 293 to the right of the start of its line.") | |
| 294 (defvar cperl-brace-offset 0 | |
| 295 "*Extra indentation for braces, compared with other text in same context.") | |
| 296 (defvar cperl-label-offset -2 | |
| 297 "*Offset of CPerl label lines relative to usual indentation.") | |
| 298 (defvar cperl-min-label-indent 1 | |
| 299 "*Minimal offset of CPerl label lines.") | |
| 300 (defvar cperl-continued-statement-offset 2 | |
| 301 "*Extra indent for lines not starting new statements.") | |
| 302 (defvar cperl-continued-brace-offset 0 | |
| 303 "*Extra indent for substatements that start with open-braces. | |
| 304 This is in addition to cperl-continued-statement-offset.") | |
| 305 (defvar cperl-close-paren-offset -1 | |
| 306 "*Extra indent for substatements that start with close-parenthesis.") | |
| 307 | |
| 308 (defvar cperl-auto-newline nil | |
| 309 "*Non-nil means automatically newline before and after braces, | |
| 310 and after colons and semicolons, inserted in CPerl code. The following | |
| 311 \\[cperl-electric-backspace] will remove the inserted whitespace. | |
| 312 Insertion after colons requires both this variable and | |
| 313 `cperl-auto-newline-after-colon' set.") | |
| 314 | |
| 315 (defvar cperl-auto-newline-after-colon nil | |
| 316 "*Non-nil means automatically newline even after colons. | |
| 317 Subject to `cperl-auto-newline' setting.") | |
| 318 | |
| 319 (defvar cperl-tab-always-indent t | |
| 320 "*Non-nil means TAB in CPerl mode should always reindent the current line, | |
| 321 regardless of where in the line point is when the TAB command is used.") | |
| 322 | |
| 323 (defvar cperl-font-lock nil | |
| 324 "*Non-nil (and non-null) means CPerl buffers will use font-lock-mode. | |
| 325 Can be overwritten by `cperl-hairy' if nil.") | |
| 326 | |
| 327 (defvar cperl-electric-lbrace-space nil | |
| 328 "*Non-nil (and non-null) means { after $ in CPerl buffers should be preceeded by ` '. | |
| 329 Can be overwritten by `cperl-hairy' if nil.") | |
| 330 | |
| 331 (defvar cperl-electric-parens-string "({[<" | |
| 332 "*String of parentheses that should be electric in CPerl.") | |
| 333 | |
| 334 (defvar cperl-electric-parens nil | |
| 335 "*Non-nil (and non-null) means parentheses should be electric in CPerl. | |
| 336 Can be overwritten by `cperl-hairy' if nil.") | |
| 337 | |
| 338 (defvar cperl-electric-parens-mark (and window-system | |
| 339 (or (and ; Emacs | |
| 340 (boundp 'transient-mark-mode) | |
| 341 transient-mark-mode) | |
| 342 (and ; XEmacs | |
| 343 (boundp 'zmacs-regions) | |
| 344 zmacs-regions))) | |
| 345 "*Not-nil means that electric parens look for active mark. | |
| 346 Default is yes if there is visual feedback on mark.") | |
| 347 | |
| 348 (defvar cperl-electric-linefeed nil | |
| 349 "*If true, LFD should be hairy in CPerl, otherwise C-c LFD is hairy. | |
| 350 In any case these two mean plain and hairy linefeeds together. | |
| 351 Can be overwritten by `cperl-hairy' if nil.") | |
| 352 | |
| 353 (defvar cperl-electric-keywords nil | |
| 354 "*Not-nil (and non-null) means keywords are electric in CPerl. | |
| 355 Can be overwritten by `cperl-hairy' if nil.") | |
| 356 | |
| 357 (defvar cperl-hairy nil | |
| 358 "*Not-nil means all the bells and whistles are enabled in CPerl.") | |
| 359 | |
| 360 (defvar cperl-comment-column 32 | |
| 361 "*Column to put comments in CPerl (use \\[cperl-indent]' to lineup with code).") | |
| 362 | |
| 363 (defvar cperl-vc-header-alist '((SCCS "$sccs = '%W\%' ;") | |
| 364 (RCS "$rcs = ' $Id\$ ' ;")) | |
| 365 "*What to use as `vc-header-alist' in CPerl.") | |
| 366 | |
| 367 (defvar cperl-info-on-command-no-prompt nil | |
| 368 "*Not-nil (and non-null) means not to prompt on C-h f. | |
| 369 The opposite behaviour is always available if prefixed with C-c. | |
| 370 Can be overwritten by `cperl-hairy' if nil.") | |
| 371 | |
| 372 (defvar cperl-pod-face 'font-lock-comment-face | |
| 373 "*The result of evaluation of this expression is used for pod highlighting.") | |
| 374 | |
| 375 (defvar cperl-pod-head-face 'font-lock-variable-name-face | |
| 376 "*The result of evaluation of this expression is used for pod highlighting. | |
| 377 Font for POD headers.") | |
| 378 | |
| 379 (defvar cperl-here-face 'font-lock-string-face | |
| 380 "*The result of evaluation of this expression is used for here-docs highlighting.") | |
| 381 | |
| 382 (defvar cperl-pod-here-fontify '(featurep 'font-lock) | |
| 383 "*Not-nil after evaluation means to highlight pod and here-docs sections.") | |
| 384 | |
| 385 (defvar cperl-pod-here-scan t | |
| 386 "*Not-nil means look for pod and here-docs sections during startup. | |
| 387 You can always make lookup from menu or using \\[cperl-find-pods-heres].") | |
| 388 | |
| 389 | |
| 390 | |
| 391 ;;; Short extra-docs. | |
| 392 | |
| 393 (defvar cperl-tips 'please-ignore-this-line | |
| 394 "Get newest version of this package from | |
| 395 ftp://ftp.math.ohio-state.edu/pub/users/ilya/emacs | |
| 396 and/or | |
| 397 ftp://ftp.math.ohio-state.edu/pub/users/ilya/perl | |
| 398 | |
| 399 Get support packages font-lock-extra.el, imenu-go.el from the same place. | |
| 400 \(Look for other files there too... ;-) Get a patch for imenu.el in 19.29. | |
| 401 Note that for 19.30 you should use choose-color.el *instead* of | |
| 402 font-lock-extra.el (and you will not get smart highlighting in C :-(). | |
| 403 | |
| 404 Note that to enable Compile choices in the menu you need to install | |
| 405 mode-compile.el. | |
| 406 | |
| 407 Get perl5-info from | |
| 408 http://www.metronet.com:70/9/perlinfo/perl5/manual/perl5-info.tar.gz | |
| 409 \(may be quite obsolete, but still useful). | |
| 410 | |
| 411 If you use imenu-go, run imenu on perl5-info buffer (you can do it from | |
| 412 CPerl menu). | |
| 413 | |
| 414 Before reporting (non-)problems look in the problem section on what I | |
| 415 know about them.") | |
| 416 | |
| 417 (defvar cperl-problems 'please-ignore-this-line | |
| 418 "Emacs has a _very_ restricted syntax parsing engine. | |
| 419 | |
| 420 It may be corrected on the level of C code, please look in the | |
| 421 `non-problems' section if you want to volunteer. | |
| 422 | |
| 423 CPerl mode tries to corrects some Emacs misunderstandings, however, | |
| 424 for effeciency reasons the degree of correction is different for | |
| 425 different operations. The partially corrected problems are: POD | |
| 426 sections, here-documents, regexps. The operations are: highlighting, | |
| 427 indentation, electric keywords, electric braces. | |
| 428 | |
| 429 This may be confusing, since the regexp s#//#/#\; may be highlighted | |
| 430 as a comment, but it will recognized as a regexp by the indentation | |
| 431 code. Or the opposite case, when a pod section is highlighted, but | |
| 432 breaks the indentation of the following code. | |
| 433 | |
| 434 The main trick (to make $ a \"backslash\") makes constructions like | |
| 435 ${aaa} look like unbalanced braces. The only trick I can think out is | |
| 436 to insert it as $ {aaa} (legal in perl5, not in perl4). | |
| 437 | |
| 438 Similar problems arise in regexps, when /(\\s|$)/ should be rewritten | |
| 439 as /($|\\s)/. Note that such a transpositinon is not always possible | |
| 440 :-(. " ) | |
| 441 | |
| 442 (defvar cperl-non-problems 'please-ignore-this-line | |
| 443 "As you know from `problems' section, Perl syntax too hard for CPerl. | |
| 444 | |
| 445 Most the time, if you write your own code, you may find an equivalent | |
| 446 \(and almost as readable) expression. | |
| 447 | |
| 448 Try to help it: add comments with embedded quotes to fix CPerl | |
| 449 misunderstandings about the end of quotation: | |
| 450 | |
| 451 $a='500$'; # '; | |
| 452 | |
| 453 You won't need it too often. The reason: $ \"quotes\" the following | |
| 454 character (this saves a life a lot of times in CPerl), thus due to | |
| 455 Emacs parsing rules it does not consider tick after the dollar as a | |
| 456 closing one, but as a usual character. | |
| 457 | |
| 458 Now the indentation code is pretty wise. The only drawback is that it | |
| 459 relies on Emacs parsing to find matching parentheses. And Emacs | |
| 460 *cannot* match parentheses in Perl 100% correctly. So | |
| 461 1 if s#//#/#; | |
| 462 will not break indentation, but | |
| 463 1 if ( s#//#/# ); | |
| 464 will. | |
| 465 | |
| 466 If you still get wrong indentation in situation that you think the | |
| 467 code should be able to parse, try: | |
| 468 | |
| 469 a) Check what Emacs thinks about balance of your parentheses. | |
| 470 b) Supply the code to me (IZ). | |
| 471 | |
| 472 Pods are treated _very_ rudimentally. Here-documents are not treated | |
| 473 at all (except highlighting and inhibiting indentation). (This may | |
| 474 change some time. RMS approved making syntax lookup recognize text | |
| 475 attributes, but volonteers are needed to change Emacs C code.) | |
| 476 | |
| 477 To speed up coloring the following compromises exist: | |
| 478 a) sub in $mypackage::sub may be highlighted. | |
| 479 b) -z in [a-z] may be highlighted. | |
| 480 c) if your regexp contains a keyword (like \"s\"), it may be highlighted. | |
| 481 ") | |
| 482 | |
| 483 | |
| 484 | |
| 485 ;;; Portability stuff: | |
| 486 | |
| 487 (defsubst cperl-xemacs-p () | |
| 488 (string-match "XEmacs\\|Lucid" emacs-version)) | |
| 489 | |
| 490 (defvar del-back-ch (car (append (where-is-internal 'delete-backward-char) | |
| 491 (where-is-internal 'backward-delete-char-untabify))) | |
| 492 "Character generated by key bound to delete-backward-char.") | |
| 493 | |
| 494 (and (vectorp del-back-ch) (= (length del-back-ch) 1) | |
| 495 (setq del-back-ch (aref del-back-ch 0))) | |
| 496 | |
| 497 (if (cperl-xemacs-p) | |
| 498 (progn | |
| 499 ;; "Active regions" are on: use region only if active | |
| 500 ;; "Active regions" are off: use region unconditionally | |
| 501 (defun cperl-use-region-p () | |
| 502 (if zmacs-regions (mark) t)) | |
| 503 (defun cperl-mark-active () (mark))) | |
| 504 (defun cperl-use-region-p () | |
| 505 (if transient-mark-mode mark-active t)) | |
| 506 (defun cperl-mark-active () mark-active)) | |
| 507 | |
| 508 (defsubst cperl-enable-font-lock () | |
| 509 (or (cperl-xemacs-p) window-system)) | |
| 510 | |
| 511 (if (boundp 'unread-command-events) | |
| 512 (if (cperl-xemacs-p) | |
| 513 (defun cperl-putback-char (c) ; XEmacs >= 19.12 | |
| 514 (setq unread-command-events (list (character-to-event c)))) | |
| 515 (defun cperl-putback-char (c) ; Emacs 19 | |
| 516 (setq unread-command-events (list c)))) | |
| 517 (defun cperl-putback-char (c) ; XEmacs <= 19.11 | |
| 518 (setq unread-command-event (character-to-event c)))) | |
| 519 | |
| 520 (or (fboundp 'uncomment-region) | |
| 521 (defun uncomment-region (beg end) | |
| 522 (interactive "r") | |
| 523 (comment-region beg end -1))) | |
| 524 | |
| 525 (defvar cperl-do-not-fontify | |
| 526 (if (string< emacs-version "19.30") | |
| 527 'fontified | |
| 528 'lazy-lock) | |
| 529 "Text property which inhibits refontification.") | |
| 530 | |
| 531 | |
| 532 ;;; Probably it is too late to set these guys already, but it can help later: | |
| 533 | |
| 534 (setq auto-mode-alist | |
| 535 (append '(("\\.[pP][Llm]$" . perl-mode)) auto-mode-alist )) | |
| 536 (and (boundp 'interpreter-mode-alist) | |
| 537 (setq interpreter-mode-alist (append interpreter-mode-alist | |
| 538 '(("miniperl" . perl-mode))))) | |
| 539 (if (fboundp 'eval-when-compile) | |
| 540 (eval-when-compile | |
| 541 (condition-case nil | |
| 542 (require 'imenu) | |
| 543 (error nil)) | |
| 544 (condition-case nil | |
| 545 (require 'easymenu) | |
| 546 (error nil)) | |
| 547 ;; Calling `cperl-enable-font-lock' below doesn't compile on XEmacs, | |
| 548 ;; macros instead of defsubsts don't work on Emacs, so we do the | |
| 549 ;; expansion manually. Any other suggestions? | |
| 550 (if (or (string-match "XEmacs\\|Lucid" emacs-version) | |
| 551 window-system) | |
| 552 (require 'font-lock)) | |
| 553 (require 'cl) | |
| 554 )) | |
| 555 | |
| 556 (defvar cperl-mode-abbrev-table nil | |
| 557 "Abbrev table in use in Cperl-mode buffers.") | |
| 558 | |
| 559 (add-hook 'edit-var-mode-alist '(perl-mode (regexp . "^cperl-"))) | |
| 560 | |
| 561 (defvar cperl-mode-map () "Keymap used in CPerl mode.") | |
| 562 | |
| 563 (if cperl-mode-map nil | |
| 564 (setq cperl-mode-map (make-sparse-keymap)) | |
| 565 (define-key cperl-mode-map "{" 'cperl-electric-lbrace) | |
| 566 (define-key cperl-mode-map "[" 'cperl-electric-paren) | |
| 567 (define-key cperl-mode-map "(" 'cperl-electric-paren) | |
| 568 (define-key cperl-mode-map "<" 'cperl-electric-paren) | |
| 569 (define-key cperl-mode-map "}" 'cperl-electric-brace) | |
| 570 (define-key cperl-mode-map ";" 'cperl-electric-semi) | |
| 571 (define-key cperl-mode-map ":" 'cperl-electric-terminator) | |
| 572 (define-key cperl-mode-map "\C-j" 'newline-and-indent) | |
| 573 (define-key cperl-mode-map "\C-c\C-j" 'cperl-linefeed) | |
| 574 (define-key cperl-mode-map "\C-c\C-a" 'cperl-toggle-auto-newline) | |
| 575 (define-key cperl-mode-map "\C-c\C-k" 'cperl-toggle-abbrev) | |
| 576 (define-key cperl-mode-map "\C-c\C-e" 'cperl-toggle-electric) | |
| 577 (define-key cperl-mode-map "\e\C-q" 'cperl-indent-exp) ; Usually not bound | |
| 578 ;;(define-key cperl-mode-map "\M-q" 'cperl-fill-paragraph) | |
| 579 ;;(define-key cperl-mode-map "\e;" 'cperl-indent-for-comment) | |
| 580 (define-key cperl-mode-map "\177" 'cperl-electric-backspace) | |
| 581 (define-key cperl-mode-map "\t" 'cperl-indent-command) | |
| 582 (if (cperl-xemacs-p) | |
| 583 ;; don't clobber the backspace binding: | |
| 584 (define-key cperl-mode-map [(control h) f] 'cperl-info-on-command) | |
| 585 (define-key cperl-mode-map "\C-hf" 'cperl-info-on-command)) | |
| 586 (if (cperl-xemacs-p) | |
| 587 ;; don't clobber the backspace binding: | |
| 588 (define-key cperl-mode-map [(control c) (control h) f] | |
| 589 'cperl-info-on-current-command) | |
| 590 (define-key cperl-mode-map "\C-c\C-hf" 'cperl-info-on-current-command)) | |
| 591 (if (and (cperl-xemacs-p) | |
| 592 (<= emacs-minor-version 11) (<= emacs-major-version 19)) | |
| 593 (progn | |
| 594 ;; substitute-key-definition is usefulness-deenhanced... | |
| 595 (define-key cperl-mode-map "\M-q" 'cperl-fill-paragraph) | |
| 596 (define-key cperl-mode-map "\e;" 'cperl-indent-for-comment) | |
| 597 (define-key cperl-mode-map "\e\C-\\" 'cperl-indent-region)) | |
| 598 (substitute-key-definition | |
| 599 'indent-sexp 'cperl-indent-exp | |
| 600 cperl-mode-map global-map) | |
| 601 (substitute-key-definition | |
| 602 'fill-paragraph 'cperl-fill-paragraph | |
| 603 cperl-mode-map global-map) | |
| 604 (substitute-key-definition | |
| 605 'indent-region 'cperl-indent-region | |
| 606 cperl-mode-map global-map) | |
| 607 (substitute-key-definition | |
| 608 'indent-for-comment 'cperl-indent-for-comment | |
| 609 cperl-mode-map global-map))) | |
| 610 | |
| 611 (condition-case nil | |
| 612 (progn | |
| 613 (require 'easymenu) | |
| 614 (easy-menu-define cperl-menu cperl-mode-map "Menu for CPerl mode" | |
| 615 '("Perl" | |
| 616 ["Beginning of function" beginning-of-defun t] | |
| 617 ["End of function" end-of-defun t] | |
| 618 ["Mark function" mark-defun t] | |
| 619 ["Indent expression" cperl-indent-exp t] | |
| 620 ["Fill paragraph/comment" cperl-fill-paragraph t] | |
| 621 ["Line up a construction" cperl-lineup (cperl-use-region-p)] | |
| 622 "----" | |
| 623 ["Indent region" cperl-indent-region (cperl-use-region-p)] | |
| 624 ["Comment region" comment-region (cperl-use-region-p)] | |
| 625 ["Uncomment region" uncomment-region (cperl-use-region-p)] | |
| 626 "----" | |
| 627 ["Run" mode-compile (fboundp 'mode-compile)] | |
| 628 ["Kill" mode-compile-kill (and (fboundp 'mode-compile-kill) | |
| 629 (get-buffer "*compilation*"))] | |
| 630 ["Next error" next-error (get-buffer "*compilation*")] | |
| 631 ["Check syntax" cperl-check-syntax (fboundp 'mode-compile)] | |
| 632 "----" | |
| 633 ["Debugger" perldb t] | |
| 634 "----" | |
| 635 ("Tools" | |
| 636 ["Imenu" imenu (fboundp 'imenu)] | |
| 637 ["Imenu on info" cperl-imenu-on-info (featurep 'imenu)] | |
| 638 ("Tags" | |
| 639 ["Create tags for current file" cperl-etags t] | |
| 640 ["Add tags for current file" (cperl-etags t) t] | |
| 641 ["Create tags for Perl files in directory" (cperl-etags nil t) t] | |
| 642 ["Add tags for Perl files in directory" (cperl-etags t t) t] | |
| 643 ["Create tags for Perl files in (sub)directories" | |
| 644 (cperl-etags nil 'recursive) t] | |
| 645 ["Add tags for Perl files in (sub)directories" | |
| 646 (cperl-etags t 'recursive) t]) | |
| 647 ["Recalculate PODs" cperl-find-pods-heres t] | |
| 648 ["Define word at point" imenu-go-find-at-position | |
| 649 (fboundp 'imenu-go-find-at-position)] | |
| 650 ["Help on function" cperl-info-on-command t] | |
| 651 ["Help on function at point" cperl-info-on-current-command t]) | |
| 652 ("Toggle..." | |
| 653 ["Auto newline" cperl-toggle-auto-newline t] | |
| 654 ["Electric parens" cperl-toggle-electric t] | |
| 655 ["Electric keywords" cperl-toggle-abbrev t] | |
| 656 ) | |
| 657 ("Indent styles..." | |
| 658 ["GNU" (cperl-set-style "GNU") t] | |
| 659 ["C++" (cperl-set-style "C++") t] | |
| 660 ["FSF" (cperl-set-style "FSF") t] | |
| 661 ["BSD" (cperl-set-style "BSD") t] | |
| 662 ["Whitesmith" (cperl-set-style "Whitesmith") t]) | |
| 663 ("Micro-docs" | |
| 664 ["Tips" (describe-variable 'cperl-tips) t] | |
| 665 ["Problems" (describe-variable 'cperl-problems) t] | |
| 666 ["Non-problems" (describe-variable 'cperl-non-problems) t])))) | |
| 667 (error nil)) | |
| 668 | |
| 669 (autoload 'c-macro-expand "cmacexp" | |
| 670 "Display the result of expanding all C macros occurring in the region. | |
| 671 The expansion is entirely correct because it uses the C preprocessor." | |
| 672 t) | |
| 673 | |
| 674 (defvar cperl-mode-syntax-table nil | |
| 675 "Syntax table in use in Cperl-mode buffers.") | |
| 676 | |
| 677 (if cperl-mode-syntax-table | |
| 678 () | |
| 679 (setq cperl-mode-syntax-table (make-syntax-table)) | |
| 680 (modify-syntax-entry ?\\ "\\" cperl-mode-syntax-table) | |
| 681 (modify-syntax-entry ?/ "." cperl-mode-syntax-table) | |
| 682 (modify-syntax-entry ?* "." cperl-mode-syntax-table) | |
| 683 (modify-syntax-entry ?+ "." cperl-mode-syntax-table) | |
| 684 (modify-syntax-entry ?- "." cperl-mode-syntax-table) | |
| 685 (modify-syntax-entry ?= "." cperl-mode-syntax-table) | |
| 686 (modify-syntax-entry ?% "." cperl-mode-syntax-table) | |
| 687 (modify-syntax-entry ?< "." cperl-mode-syntax-table) | |
| 688 (modify-syntax-entry ?> "." cperl-mode-syntax-table) | |
| 689 (modify-syntax-entry ?& "." cperl-mode-syntax-table) | |
| 690 (modify-syntax-entry ?$ "\\" cperl-mode-syntax-table) | |
| 691 (modify-syntax-entry ?\n ">" cperl-mode-syntax-table) | |
| 692 (modify-syntax-entry ?# "<" cperl-mode-syntax-table) | |
| 693 (modify-syntax-entry ?' "\"" cperl-mode-syntax-table) | |
| 694 (modify-syntax-entry ?` "\"" cperl-mode-syntax-table) | |
| 695 (modify-syntax-entry ?_ "w" cperl-mode-syntax-table) | |
| 696 (modify-syntax-entry ?| "." cperl-mode-syntax-table)) | |
| 697 | |
| 698 | |
| 699 | |
| 700 ;; Make customization possible "in reverse" | |
| 701 ;;(defun cperl-set (symbol to) | |
| 702 ;; (or (eq (symbol-value symbol) 'null) (set symbol to))) | |
| 703 (defsubst cperl-val (symbol &optional default hairy) | |
| 704 (cond | |
| 705 ((eq (symbol-value symbol) 'null) default) | |
| 706 (cperl-hairy (or hairy t)) | |
| 707 (t (symbol-value symbol)))) | |
| 708 | |
| 709 ;; provide an alias for working with emacs 19. the perl-mode that comes | |
| 710 ;; with it is really bad, and this lets us seamlessly replace it. | |
| 711 (fset 'perl-mode 'cperl-mode) | |
| 712 (defun cperl-mode () | |
| 713 "Major mode for editing Perl code. | |
| 714 Expression and list commands understand all C brackets. | |
| 715 Tab indents for Perl code. | |
| 716 Paragraphs are separated by blank lines only. | |
| 717 Delete converts tabs to spaces as it moves back. | |
| 718 | |
| 719 Various characters in Perl almost always come in pairs: {}, (), [], | |
| 720 sometimes <>. When the user types the first, she gets the second as | |
| 721 well, with optional special formatting done on {}. (Disabled by | |
| 722 default.) You can always quote (with \\[quoted-insert]) the left | |
| 723 \"paren\" to avoid the expansion. The processing of < is special, | |
| 724 since most the time you mean \"less\". Cperl mode tries to guess | |
| 725 whether you want to type pair <>, and inserts is if it | |
| 726 appropriate. You can set `cperl-electric-parens-string' to the string that | |
| 727 contains the parenths from the above list you want to be electrical. | |
| 728 Electricity of parenths is controlled by `cperl-electric-parens'. | |
| 729 You may also set `cperl-electric-parens-mark' to have electric parens | |
| 730 look for active mark and \"embrace\" a region if possible.' | |
| 731 | |
| 732 CPerl mode provides expansion of the Perl control constructs: | |
| 733 if, else, elsif, unless, while, until, for, and foreach. | |
| 734 =========(Disabled by default, see `cperl-electric-keywords'.) | |
| 735 The user types the keyword immediately followed by a space, which causes | |
| 736 the construct to be expanded, and the user is positioned where she is most | |
| 737 likely to want to be. | |
| 738 eg. when the user types a space following \"if\" the following appears in | |
| 739 the buffer: | |
| 740 if () { or if () | |
| 741 } { | |
| 742 } | |
| 743 and the cursor is between the parentheses. The user can then type some | |
| 744 boolean expression within the parens. Having done that, typing | |
| 745 \\[cperl-linefeed] places you, appropriately indented on a new line | |
| 746 between the braces. If CPerl decides that you want to insert | |
| 747 \"English\" style construct like | |
| 748 bite if angry; | |
| 749 it will not do any expansion. See also help on variable | |
| 750 `cperl-extra-newline-before-brace'. | |
| 751 | |
| 752 \\[cperl-linefeed] is a convinience replacement for typing carriage | |
| 753 return. It places you in the next line with proper indentation, or if | |
| 754 you type it inside the inline block of control construct, like | |
| 755 foreach (@lines) {print; print} | |
| 756 and you are on a boundary of a statement inside braces, it will | |
| 757 transform the construct into a multiline and will place you into an | |
| 758 apporpriately indented blank line. If you need a usual | |
| 759 `newline-and-indent' behaviour, it is on \\[newline-and-indent], | |
| 760 see documentation on `cperl-electric-linefeed'. | |
| 761 | |
| 762 \\{cperl-mode-map} | |
| 763 | |
| 764 Setting the variable `cperl-font-lock' to t switches on | |
| 765 font-lock-mode, `cperl-electric-lbrace-space' to t switches on | |
| 766 electric space between $ and {, `cperl-electric-parens-string' is the | |
| 767 string that contains parentheses that should be electric in CPerl (see | |
| 768 also `cperl-electric-parens-mark' and `cperl-electric-parens'), | |
| 769 setting `cperl-electric-keywords' enables electric expansion of | |
| 770 control structures in CPerl. `cperl-electric-linefeed' governs which | |
| 771 one of two linefeed behavior is preferable. You can enable all these | |
| 772 options simultaneously (recommended mode of use) by setting | |
| 773 `cperl-hairy' to t. In this case you can switch separate options off | |
| 774 by setting them to `null'. Note that one may undo the extra whitespace | |
| 775 inserted by semis and braces in `auto-newline'-mode by consequent | |
| 776 \\[cperl-electric-backspace]. | |
| 777 | |
| 778 If your site has perl5 documentation in info format, you can use commands | |
| 779 \\[cperl-info-on-current-command] and \\[cperl-info-on-command] to access it. | |
| 780 These keys run commands `cperl-info-on-current-command' and | |
| 781 `cperl-info-on-command', which one is which is controlled by variable | |
| 782 `cperl-info-on-command-no-prompt' (in turn affected by `cperl-hairy'). | |
| 783 | |
| 784 Variables `cperl-pod-here-scan', `cperl-pod-here-fontify', | |
| 785 `cperl-pod-face', `cperl-pod-head-face' control processing of pod and | |
| 786 here-docs sections. In a future version results of scan may be used | |
| 787 for indentation too, currently they are used for highlighting only. | |
| 788 | |
| 789 Variables controlling indentation style: | |
| 790 `cperl-tab-always-indent' | |
| 791 Non-nil means TAB in CPerl mode should always reindent the current line, | |
| 792 regardless of where in the line point is when the TAB command is used. | |
| 793 `cperl-auto-newline' | |
| 794 Non-nil means automatically newline before and after braces, | |
| 795 and after colons and semicolons, inserted in Perl code. The following | |
| 796 \\[cperl-electric-backspace] will remove the inserted whitespace. | |
| 797 Insertion after colons requires both this variable and | |
| 798 `cperl-auto-newline-after-colon' set. | |
| 799 `cperl-auto-newline-after-colon' | |
| 800 Non-nil means automatically newline even after colons. | |
| 801 Subject to `cperl-auto-newline' setting. | |
| 802 `cperl-indent-level' | |
| 803 Indentation of Perl statements within surrounding block. | |
| 804 The surrounding block's indentation is the indentation | |
| 805 of the line on which the open-brace appears. | |
| 806 `cperl-continued-statement-offset' | |
| 807 Extra indentation given to a substatement, such as the | |
| 808 then-clause of an if, or body of a while, or just a statement continuation. | |
| 809 `cperl-continued-brace-offset' | |
| 810 Extra indentation given to a brace that starts a substatement. | |
| 811 This is in addition to `cperl-continued-statement-offset'. | |
| 812 `cperl-brace-offset' | |
| 813 Extra indentation for line if it starts with an open brace. | |
| 814 `cperl-brace-imaginary-offset' | |
| 815 An open brace following other text is treated as if it the line started | |
| 816 this far to the right of the actual line indentation. | |
| 817 `cperl-label-offset' | |
| 818 Extra indentation for line that is a label. | |
| 819 `cperl-min-label-indent' | |
| 820 Minimal indentation for line that is a label. | |
| 821 | |
| 822 Settings for K&R and BSD indentation styles are | |
| 823 `cperl-indent-level' 5 8 | |
| 824 `cperl-continued-statement-offset' 5 8 | |
| 825 `cperl-brace-offset' -5 -8 | |
| 826 `cperl-label-offset' -5 -8 | |
| 827 | |
| 828 If `cperl-indent-level' is 0, the statement after opening brace in column 0 is indented on `cperl-brace-offset'+`cperl-continued-statement-offset'. | |
| 829 | |
| 830 Turning on CPerl mode calls the hooks in the variable `cperl-mode-hook' | |
| 831 with no args." | |
| 832 (interactive) | |
| 833 (kill-all-local-variables) | |
| 834 ;;(if cperl-hairy | |
| 835 ;; (progn | |
| 836 ;; (cperl-set 'cperl-font-lock cperl-hairy) | |
| 837 ;; (cperl-set 'cperl-electric-lbrace-space cperl-hairy) | |
| 838 ;; (cperl-set 'cperl-electric-parens "{[(<") | |
| 839 ;; (cperl-set 'cperl-electric-keywords cperl-hairy) | |
| 840 ;; (cperl-set 'cperl-electric-linefeed cperl-hairy))) | |
| 841 (use-local-map cperl-mode-map) | |
| 842 (if (cperl-val 'cperl-electric-linefeed) | |
| 843 (progn | |
| 844 (local-set-key "\C-J" 'cperl-linefeed) | |
| 845 (local-set-key "\C-C\C-J" 'newline-and-indent))) | |
| 846 (if (cperl-val 'cperl-info-on-command-no-prompt) | |
| 847 (progn | |
| 848 (if (cperl-xemacs-p) | |
| 849 ;; don't clobber the backspace binding: | |
| 850 (local-set-key [(control h) f] 'cperl-info-on-current-command) | |
| 851 (local-set-key "\C-hf" 'cperl-info-on-current-command)) | |
| 852 (if (cperl-xemacs-p) | |
| 853 ;; don't clobber the backspace binding: | |
| 854 (local-set-key [(control c) (control h) f] | |
| 855 'cperl-info-on-command) | |
| 856 (local-set-key "\C-c\C-hf" 'cperl-info-on-command)))) | |
| 857 (setq major-mode 'perl-mode) | |
| 858 (setq mode-name "CPerl") | |
| 859 (if (not cperl-mode-abbrev-table) | |
| 860 (let ((prev-a-c abbrevs-changed)) | |
| 861 (define-abbrev-table 'cperl-mode-abbrev-table '( | |
| 862 ("if" "if" cperl-electric-keyword 0) | |
| 863 ("elsif" "elsif" cperl-electric-keyword 0) | |
| 864 ("while" "while" cperl-electric-keyword 0) | |
| 865 ("until" "until" cperl-electric-keyword 0) | |
| 866 ("unless" "unless" cperl-electric-keyword 0) | |
| 867 ("else" "else" cperl-electric-else 0) | |
| 868 ("for" "for" cperl-electric-keyword 0) | |
| 869 ("foreach" "foreach" cperl-electric-keyword 0) | |
| 870 ("do" "do" cperl-electric-keyword 0))) | |
| 871 (setq abbrevs-changed prev-a-c))) | |
| 872 (setq local-abbrev-table cperl-mode-abbrev-table) | |
| 873 (abbrev-mode (if (cperl-val 'cperl-electric-keywords) 1 0)) | |
| 874 (set-syntax-table cperl-mode-syntax-table) | |
| 875 (make-local-variable 'paragraph-start) | |
| 876 (setq paragraph-start (concat "^$\\|" page-delimiter)) | |
| 877 (make-local-variable 'paragraph-separate) | |
| 878 (setq paragraph-separate paragraph-start) | |
| 879 (make-local-variable 'paragraph-ignore-fill-prefix) | |
| 880 (setq paragraph-ignore-fill-prefix t) | |
| 881 (make-local-variable 'indent-line-function) | |
| 882 (setq indent-line-function 'cperl-indent-line) | |
| 883 (make-local-variable 'require-final-newline) | |
| 884 (setq require-final-newline t) | |
| 885 (make-local-variable 'comment-start) | |
| 886 (setq comment-start "# ") | |
| 887 (make-local-variable 'comment-end) | |
| 888 (setq comment-end "") | |
| 889 (make-local-variable 'comment-column) | |
| 890 (setq comment-column cperl-comment-column) | |
| 891 (make-local-variable 'comment-start-skip) | |
| 892 (setq comment-start-skip "#+ *") | |
| 893 (make-local-variable 'defun-prompt-regexp) | |
| 894 (setq defun-prompt-regexp "^[ \t]*sub\\s +\\([^ \t\n{;]+\\)\\s *") | |
| 895 (make-local-variable 'comment-indent-function) | |
| 896 (setq comment-indent-function 'cperl-comment-indent) | |
| 897 (make-local-variable 'parse-sexp-ignore-comments) | |
| 898 (setq parse-sexp-ignore-comments t) | |
| 899 (make-local-variable 'indent-region-function) | |
| 900 (setq indent-region-function 'cperl-indent-region) | |
| 901 ;;(setq auto-fill-function 'cperl-do-auto-fill) ; Need to switch on and off! | |
| 902 (make-local-variable 'imenu-create-index-function) | |
| 903 (setq imenu-create-index-function | |
| 904 (function imenu-example--create-perl-index)) | |
| 905 (make-local-variable 'imenu-sort-function) | |
| 906 (setq imenu-sort-function nil) | |
| 907 (make-local-variable 'vc-header-alist) | |
| 908 (setq vc-header-alist cperl-vc-header-alist) | |
| 909 (make-local-variable 'font-lock-defaults) | |
| 910 (setq font-lock-defaults | |
| 911 (if (string< emacs-version "19.30") | |
| 912 '(perl-font-lock-keywords-2) | |
| 913 '((perl-font-lock-keywords | |
| 914 perl-font-lock-keywords-1 | |
| 915 perl-font-lock-keywords-2)))) | |
| 916 (or (fboundp 'cperl-old-auto-fill-mode) | |
| 917 (progn | |
| 918 (fset 'cperl-old-auto-fill-mode (symbol-function 'auto-fill-mode)) | |
| 919 (defun auto-fill-mode (&optional arg) | |
| 920 (interactive "P") | |
| 921 (cperl-old-auto-fill-mode arg) | |
| 922 (and auto-fill-function (eq major-mode 'perl-mode) | |
| 923 (setq auto-fill-function 'cperl-do-auto-fill))))) | |
| 924 (if (cperl-enable-font-lock) | |
| 925 (if (cperl-val 'cperl-font-lock) | |
| 926 (progn (or cperl-faces-init (cperl-init-faces)) | |
| 927 (font-lock-mode 1)))) | |
| 928 (and (boundp 'msb-menu-cond) | |
| 929 (not cperl-msb-fixed) | |
| 930 (cperl-msb-fix)) | |
| 931 (run-hooks 'cperl-mode-hook) | |
| 932 ;; After hooks since fontification will break this | |
| 933 (if cperl-pod-here-scan (cperl-find-pods-heres))) | |
| 934 | |
| 935 ;; Fix for msb.el | |
| 936 (defvar cperl-msb-fixed nil) | |
| 937 | |
| 938 (defun cperl-msb-fix () | |
| 939 ;; Adds perl files to msb menu, supposes that msb is already loaded | |
| 940 (setq cperl-msb-fixed t) | |
| 941 (let* ((l (length msb-menu-cond)) | |
| 942 (last (nth (1- l) msb-menu-cond)) | |
| 943 (precdr (nthcdr (- l 2) msb-menu-cond)) ; cdr of this is last | |
| 944 (handle (1- (nth 1 last)))) | |
| 945 (setcdr precdr (list | |
| 946 (list | |
| 947 '(eq major-mode 'perl-mode) | |
| 948 handle | |
| 949 "Perl Files (%d)") | |
| 950 last)))) | |
| 951 | |
| 952 ;; This is used by indent-for-comment | |
| 953 ;; to decide how much to indent a comment in CPerl code | |
| 954 ;; based on its context. Do fallback if comment is found wrong. | |
| 955 | |
| 956 (defvar cperl-wrong-comment) | |
| 957 | |
| 958 (defun cperl-comment-indent () | |
| 959 (let ((p (point)) (c (current-column)) was) | |
| 960 (if (looking-at "^#") 0 ; Existing comment at bol stays there. | |
| 961 ;; Wrong comment found | |
| 962 (save-excursion | |
| 963 (setq was (cperl-to-comment-or-eol)) | |
| 964 (if (= (point) p) | |
| 965 (progn | |
| 966 (skip-chars-backward " \t") | |
| 967 (max (1+ (current-column)) ; Else indent at comment column | |
| 968 comment-column)) | |
| 969 (if was nil | |
| 970 (insert comment-start) | |
| 971 (backward-char (length comment-start))) | |
| 972 (setq cperl-wrong-comment t) | |
| 973 (indent-to comment-column 1) ; Indent minimum 1 | |
| 974 c))))) ; except leave at least one space. | |
| 975 | |
| 976 ;;;(defun cperl-comment-indent-fallback () | |
| 977 ;;; "Is called if the standard comment-search procedure fails. | |
| 978 ;;;Point is at start of real comment." | |
| 979 ;;; (let ((c (current-column)) target cnt prevc) | |
| 980 ;;; (if (= c comment-column) nil | |
| 981 ;;; (setq cnt (skip-chars-backward "[ \t]")) | |
| 982 ;;; (setq target (max (1+ (setq prevc | |
| 983 ;;; (current-column))) ; Else indent at comment column | |
| 984 ;;; comment-column)) | |
| 985 ;;; (if (= c comment-column) nil | |
| 986 ;;; (delete-backward-char cnt) | |
| 987 ;;; (while (< prevc target) | |
| 988 ;;; (insert "\t") | |
| 989 ;;; (setq prevc (current-column))) | |
| 990 ;;; (if (> prevc target) (progn (delete-char -1) (setq prevc (current-column)))) | |
| 991 ;;; (while (< prevc target) | |
| 992 ;;; (insert " ") | |
| 993 ;;; (setq prevc (current-column))))))) | |
| 994 | |
| 995 (defun cperl-indent-for-comment () | |
| 996 "Substite for `indent-for-comment' in CPerl." | |
| 997 (interactive) | |
| 998 (let (cperl-wrong-comment) | |
| 999 (indent-for-comment) | |
| 1000 (if cperl-wrong-comment | |
| 1001 (progn (cperl-to-comment-or-eol) | |
| 1002 (forward-char (length comment-start)))))) | |
| 1003 | |
| 1004 (defun cperl-electric-brace (arg &optional only-before) | |
| 1005 "Insert character and correct line's indentation. | |
| 1006 If ONLY-BEFORE and `cperl-auto-newline', will insert newline before the | |
| 1007 place (even in empty line), but not after. If after \")\" and the inserted | |
| 1008 char is \"{\", insert extra newline before only if | |
| 1009 `cperl-extra-newline-before-brace'." | |
| 1010 (interactive "P") | |
| 1011 (let (insertpos) | |
| 1012 (if (and (not arg) ; No args, end (of empty line or auto) | |
| 1013 (eolp) | |
| 1014 (or (and (null only-before) | |
| 1015 (save-excursion | |
| 1016 (skip-chars-backward " \t") | |
| 1017 (bolp))) | |
| 1018 (and (eq last-command-char ?\{) ; Do not insert newline | |
| 1019 ;; if after ")" and `cperl-extra-newline-before-brace' | |
| 1020 ;; is nil, do not insert extra newline. | |
| 1021 (not cperl-extra-newline-before-brace) | |
| 1022 (save-excursion | |
| 1023 (skip-chars-backward " \t") | |
| 1024 (eq (preceding-char) ?\)))) | |
| 1025 (if cperl-auto-newline | |
| 1026 (progn (cperl-indent-line) (newline) t) nil))) | |
| 1027 (progn | |
| 1028 (if cperl-auto-newline | |
| 1029 (setq insertpos (point))) | |
| 1030 (insert last-command-char) | |
| 1031 (cperl-indent-line) | |
| 1032 (if (and cperl-auto-newline (null only-before)) | |
| 1033 (progn | |
| 1034 (newline) | |
| 1035 (cperl-indent-line))) | |
| 1036 (save-excursion | |
| 1037 (if insertpos (progn (goto-char insertpos) | |
| 1038 (search-forward (make-string | |
| 1039 1 last-command-char)) | |
| 1040 (setq insertpos (1- (point))))) | |
| 1041 (delete-char -1)))) | |
| 1042 (if insertpos | |
| 1043 (save-excursion | |
| 1044 (goto-char insertpos) | |
| 1045 (self-insert-command (prefix-numeric-value arg))) | |
| 1046 (self-insert-command (prefix-numeric-value arg))))) | |
| 1047 | |
| 1048 (defun cperl-electric-lbrace (arg) | |
| 1049 "Insert character, correct line's indentation, correct quoting by space." | |
| 1050 (interactive "P") | |
| 1051 (let (pos after | |
| 1052 (cperl-auto-newline cperl-auto-newline) | |
| 1053 (other-end (if (and cperl-electric-parens-mark | |
| 1054 (cperl-mark-active) | |
| 1055 (> (mark) (point))) | |
| 1056 (save-excursion | |
| 1057 (goto-char (mark)) | |
| 1058 (point-marker)) | |
| 1059 nil))) | |
| 1060 (and (cperl-val 'cperl-electric-lbrace-space) | |
| 1061 (eq (preceding-char) ?$) | |
| 1062 (save-excursion | |
| 1063 (skip-chars-backward "$") | |
| 1064 (looking-at "\\(\\$\\$\\)*\\$\\([^\\$]\\|$\\)")) | |
| 1065 (insert ? )) | |
| 1066 (if (cperl-after-expr-p nil "{};)") nil (setq cperl-auto-newline nil)) | |
| 1067 (cperl-electric-brace arg) | |
| 1068 (and (cperl-val 'cperl-electric-parens) | |
| 1069 (eq last-command-char ?{) | |
| 1070 (memq last-command-char | |
| 1071 (append cperl-electric-parens-string nil)) | |
| 1072 (or (if other-end (goto-char (marker-position other-end))) | |
| 1073 t) | |
| 1074 (setq last-command-char ?} pos (point)) | |
| 1075 (progn (cperl-electric-brace arg t) | |
| 1076 (goto-char pos))))) | |
| 1077 | |
| 1078 (defun cperl-electric-paren (arg) | |
| 1079 "Insert a matching pair of parentheses." | |
| 1080 (interactive "P") | |
| 1081 (let ((beg (save-excursion (beginning-of-line) (point))) | |
| 1082 (other-end (if (and cperl-electric-parens-mark | |
| 1083 (cperl-mark-active) | |
| 1084 (> (mark) (point))) | |
| 1085 (save-excursion | |
| 1086 (goto-char (mark)) | |
| 1087 (point-marker)) | |
| 1088 nil))) | |
| 1089 (if (and (cperl-val 'cperl-electric-parens) | |
| 1090 (memq last-command-char | |
| 1091 (append cperl-electric-parens-string nil)) | |
| 1092 (>= (save-excursion (cperl-to-comment-or-eol) (point)) (point)) | |
| 1093 ;;(not (save-excursion (search-backward "#" beg t))) | |
| 1094 (if (eq last-command-char ?<) | |
| 1095 (cperl-after-expr-p nil "{};(,:=") | |
| 1096 1)) | |
| 1097 (progn | |
| 1098 (insert last-command-char) | |
| 1099 (if other-end (goto-char (marker-position other-end))) | |
| 1100 (insert (cdr (assoc last-command-char '((?{ .?}) | |
| 1101 (?[ . ?]) | |
| 1102 (?( . ?)) | |
| 1103 (?< . ?>))))) | |
| 1104 (forward-char -1)) | |
| 1105 (insert last-command-char) | |
| 1106 ))) | |
| 1107 | |
| 1108 (defun cperl-electric-keyword () | |
| 1109 "Insert a construction appropriate after a keyword." | |
| 1110 (let ((beg (save-excursion (beginning-of-line) (point))) | |
| 1111 (dollar (eq (preceding-char) ?$))) | |
| 1112 (and (save-excursion | |
| 1113 (backward-sexp 1) | |
| 1114 (cperl-after-expr-p nil "{};:")) | |
| 1115 (save-excursion | |
| 1116 (not | |
| 1117 (re-search-backward | |
| 1118 "[#\"'`]\\|\\<q\\(\\|[wqx]\\)\\>" | |
| 1119 beg t))) | |
| 1120 (save-excursion (or (not (re-search-backward "^=" nil t)) | |
| 1121 (looking-at "=cut"))) | |
| 1122 (progn | |
| 1123 (and dollar (insert " $")) | |
| 1124 (cperl-indent-line) | |
| 1125 ;;(insert " () {\n}") | |
| 1126 (cond | |
| 1127 (cperl-extra-newline-before-brace | |
| 1128 (insert " ()\n") | |
| 1129 (insert "{") | |
| 1130 (cperl-indent-line) | |
| 1131 (insert "\n") | |
| 1132 (cperl-indent-line) | |
| 1133 (insert "\n}")) | |
| 1134 (t | |
| 1135 (insert " () {\n}")) | |
| 1136 ) | |
| 1137 (or (looking-at "[ \t]\\|$") (insert " ")) | |
| 1138 (cperl-indent-line) | |
| 1139 (if dollar (progn (search-backward "$") | |
| 1140 (forward-char 1)) | |
| 1141 (search-backward ")")) | |
| 1142 (cperl-putback-char del-back-ch))))) | |
| 1143 | |
| 1144 (defun cperl-electric-else () | |
| 1145 "Insert a construction appropriate after a keyword." | |
| 1146 (let ((beg (save-excursion (beginning-of-line) (point)))) | |
| 1147 (and (save-excursion | |
| 1148 (backward-sexp 1) | |
| 1149 (cperl-after-expr-p nil "{};:")) | |
| 1150 (save-excursion | |
| 1151 (not | |
| 1152 (re-search-backward | |
| 1153 "[#\"'`]\\|\\<q\\(\\|[wqx]\\)\\>" | |
| 1154 beg t))) | |
| 1155 (save-excursion (or (not (re-search-backward "^=" nil t)) | |
| 1156 (looking-at "=cut"))) | |
| 1157 (progn | |
| 1158 (cperl-indent-line) | |
| 1159 ;;(insert " {\n\n}") | |
| 1160 (cond | |
| 1161 (cperl-extra-newline-before-brace | |
| 1162 (insert "\n") | |
| 1163 (insert "{") | |
| 1164 (cperl-indent-line) | |
| 1165 (insert "\n\n}")) | |
| 1166 (t | |
| 1167 (insert " {\n\n}")) | |
| 1168 ) | |
| 1169 (or (looking-at "[ \t]\\|$") (insert " ")) | |
| 1170 (cperl-indent-line) | |
| 1171 (forward-line -1) | |
| 1172 (cperl-indent-line) | |
| 1173 (cperl-putback-char del-back-ch))))) | |
| 1174 | |
| 1175 (defun cperl-linefeed () | |
| 1176 "Go to end of line, open a new line and indent appropriately." | |
| 1177 (interactive) | |
| 1178 (let ((beg (save-excursion (beginning-of-line) (point))) | |
| 1179 (end (save-excursion (end-of-line) (point))) | |
| 1180 (pos (point)) start) | |
| 1181 (if (and ; Check if we need to split: | |
| 1182 ; i.e., on a boundary and inside "{...}" | |
| 1183 (save-excursion (cperl-to-comment-or-eol) | |
| 1184 (>= (point) pos)) | |
| 1185 (or (save-excursion | |
| 1186 (skip-chars-backward " \t" beg) | |
| 1187 (forward-char -1) | |
| 1188 (looking-at "[;{]")) | |
| 1189 (looking-at "[ \t]*}") | |
| 1190 (re-search-forward "\\=[ \t]*;" end t)) | |
| 1191 (save-excursion | |
| 1192 (and | |
| 1193 (eq (car (parse-partial-sexp pos end -1)) -1) | |
| 1194 (looking-at "[,; \t]*\\($\\|#\\)") ; Comma to allow anon subr | |
| 1195 (progn | |
| 1196 (backward-sexp 1) | |
| 1197 (setq start (point-marker)) | |
| 1198 (<= start pos))))) | |
| 1199 (progn | |
| 1200 (skip-chars-backward " \t") | |
| 1201 (or (memq (preceding-char) (append ";{" nil)) | |
| 1202 (insert ";")) | |
| 1203 (insert "\n") | |
| 1204 (forward-line -1) | |
| 1205 (cperl-indent-line) | |
| 1206 (goto-char start) | |
| 1207 (or (looking-at "{[ \t]*$") ; If there is a statement | |
| 1208 ; before, move it to separate line | |
| 1209 (progn | |
| 1210 (forward-char 1) | |
| 1211 (insert "\n") | |
| 1212 (cperl-indent-line))) | |
| 1213 (forward-line 1) ; We are on the target line | |
| 1214 (cperl-indent-line) | |
| 1215 (beginning-of-line) | |
| 1216 (or (looking-at "[ \t]*}[,; \t]*$") ; If there is a statement | |
| 1217 ; after, move it to separate line | |
| 1218 (progn | |
| 1219 (end-of-line) | |
| 1220 (search-backward "}" beg) | |
| 1221 (skip-chars-backward " \t") | |
| 1222 (or (memq (preceding-char) (append ";{" nil)) | |
| 1223 (insert ";")) | |
| 1224 (insert "\n") | |
| 1225 (cperl-indent-line) | |
| 1226 (forward-line -1))) | |
| 1227 (forward-line -1) ; We are on the line before target | |
| 1228 (end-of-line) | |
| 1229 (newline-and-indent)) | |
| 1230 (end-of-line) ; else | |
| 1231 (if (not (looking-at "\n[ \t]*$")) | |
| 1232 (newline-and-indent) | |
| 1233 (forward-line 1) | |
| 1234 (cperl-indent-line))))) | |
| 1235 | |
| 1236 (defun cperl-electric-semi (arg) | |
| 1237 "Insert character and correct line's indentation." | |
| 1238 (interactive "P") | |
| 1239 (if cperl-auto-newline | |
| 1240 (cperl-electric-terminator arg) | |
| 1241 (self-insert-command (prefix-numeric-value arg)))) | |
| 1242 | |
| 1243 (defun cperl-electric-terminator (arg) | |
| 1244 "Insert character and correct line's indentation." | |
| 1245 (interactive "P") | |
| 1246 (let (insertpos (end (point)) | |
| 1247 (auto (and cperl-auto-newline | |
| 1248 (or (not (eq last-command-char ?:)) | |
| 1249 cperl-auto-newline-after-colon)))) | |
| 1250 (if (and (not arg) (eolp) | |
| 1251 (not (save-excursion | |
| 1252 (beginning-of-line) | |
| 1253 (skip-chars-forward " \t") | |
| 1254 (or | |
| 1255 ;; Ignore in comment lines | |
| 1256 (= (following-char) ?#) | |
| 1257 ;; Colon is special only after a label | |
| 1258 ;; So quickly rule out most other uses of colon | |
| 1259 ;; and do no indentation for them. | |
| 1260 (and (eq last-command-char ?:) | |
| 1261 (save-excursion | |
| 1262 (forward-word 1) | |
| 1263 (skip-chars-forward " \t") | |
| 1264 (and (< (point) end) | |
| 1265 (progn (goto-char (- end 1)) | |
| 1266 (not (looking-at ":")))))) | |
| 1267 (progn | |
| 1268 (beginning-of-defun) | |
| 1269 (let ((pps (parse-partial-sexp (point) end))) | |
| 1270 (or (nth 3 pps) (nth 4 pps) (nth 5 pps)))))))) | |
| 1271 (progn | |
| 1272 (insert last-command-char) | |
| 1273 (forward-char -1) | |
| 1274 (if auto (setq insertpos (point-marker))) | |
| 1275 (forward-char 1) | |
| 1276 (cperl-indent-line) | |
| 1277 (if auto | |
| 1278 (progn | |
| 1279 (newline) | |
| 1280 (cperl-indent-line))) | |
| 1281 ;; (save-excursion | |
| 1282 ;; (if insertpos (progn (goto-char (marker-position insertpos)) | |
| 1283 ;; (search-forward (make-string | |
| 1284 ;; 1 last-command-char)) | |
| 1285 ;; (setq insertpos (1- (point))))) | |
| 1286 ;; (delete-char -1)))) | |
| 1287 (save-excursion | |
| 1288 (if insertpos (goto-char (marker-position insertpos)) | |
| 1289 (forward-char -1)) | |
| 1290 (delete-char 1)))) | |
| 1291 (if insertpos | |
| 1292 (save-excursion | |
| 1293 (goto-char insertpos) | |
| 1294 (self-insert-command (prefix-numeric-value arg))) | |
| 1295 (self-insert-command (prefix-numeric-value arg))))) | |
| 1296 | |
| 1297 (defun cperl-electric-backspace (arg) | |
| 1298 "Backspace-untabify, or remove the whitespace inserted by an electric key." | |
| 1299 (interactive "p") | |
| 1300 (if (and cperl-auto-newline | |
| 1301 (memq last-command '(cperl-electric-semi | |
| 1302 cperl-electric-terminator | |
| 1303 cperl-electric-lbrace)) | |
| 1304 (memq (preceding-char) '(? ?\t ?\n))) | |
| 1305 (let (p) | |
| 1306 (if (eq last-command 'cperl-electric-lbrace) | |
| 1307 (skip-chars-forward " \t\n")) | |
| 1308 (setq p (point)) | |
| 1309 (skip-chars-backward " \t\n") | |
| 1310 (delete-region (point) p)) | |
| 1311 (backward-delete-char-untabify arg))) | |
| 1312 | |
| 1313 (defun cperl-inside-parens-p () | |
| 1314 (condition-case () | |
| 1315 (save-excursion | |
| 1316 (save-restriction | |
| 1317 (narrow-to-region (point) | |
| 1318 (progn (beginning-of-defun) (point))) | |
| 1319 (goto-char (point-max)) | |
| 1320 (= (char-after (or (scan-lists (point) -1 1) (point-min))) ?\())) | |
| 1321 (error nil))) | |
| 1322 | |
| 1323 (defun cperl-indent-command (&optional whole-exp) | |
| 1324 (interactive "P") | |
| 1325 "Indent current line as Perl code, or in some cases insert a tab character. | |
| 1326 If `cperl-tab-always-indent' is non-nil (the default), always indent current line. | |
| 1327 Otherwise, indent the current line only if point is at the left margin | |
| 1328 or in the line's indentation; otherwise insert a tab. | |
| 1329 | |
| 1330 A numeric argument, regardless of its value, | |
| 1331 means indent rigidly all the lines of the expression starting after point | |
| 1332 so that this line becomes properly indented. | |
| 1333 The relative indentation among the lines of the expression are preserved." | |
| 1334 (if whole-exp | |
| 1335 ;; If arg, always indent this line as Perl | |
| 1336 ;; and shift remaining lines of expression the same amount. | |
| 1337 (let ((shift-amt (cperl-indent-line)) | |
| 1338 beg end) | |
| 1339 (save-excursion | |
| 1340 (if cperl-tab-always-indent | |
| 1341 (beginning-of-line)) | |
| 1342 (setq beg (point)) | |
| 1343 (forward-sexp 1) | |
| 1344 (setq end (point)) | |
| 1345 (goto-char beg) | |
| 1346 (forward-line 1) | |
| 1347 (setq beg (point))) | |
| 1348 (if (> end beg) | |
| 1349 (indent-code-rigidly beg end shift-amt "#"))) | |
| 1350 (if (and (not cperl-tab-always-indent) | |
| 1351 (save-excursion | |
| 1352 (skip-chars-backward " \t") | |
| 1353 (not (bolp)))) | |
| 1354 (insert-tab) | |
| 1355 (cperl-indent-line)))) | |
| 1356 | |
| 1357 (defun cperl-indent-line (&optional symbol) | |
| 1358 "Indent current line as Perl code. | |
| 1359 Return the amount the indentation changed by." | |
| 1360 (let (indent | |
| 1361 beg shift-amt | |
| 1362 (case-fold-search nil) | |
| 1363 (pos (- (point-max) (point)))) | |
| 1364 (setq indent (cperl-calculate-indent nil symbol)) | |
| 1365 (beginning-of-line) | |
| 1366 (setq beg (point)) | |
| 1367 (cond ((eq indent nil) | |
| 1368 (setq indent (current-indentation))) | |
| 1369 ;;((eq indent t) ; Never? | |
| 1370 ;; (setq indent (cperl-calculate-indent-within-comment))) | |
| 1371 ;;((looking-at "[ \t]*#") | |
| 1372 ;; (setq indent 0)) | |
| 1373 (t | |
| 1374 (skip-chars-forward " \t") | |
| 1375 (if (listp indent) (setq indent (car indent))) | |
| 1376 (cond ((looking-at "[A-Za-z]+:[^:]") | |
| 1377 (and (> indent 0) | |
| 1378 (setq indent (max cperl-min-label-indent | |
| 1379 (+ indent cperl-label-offset))))) | |
| 1380 ((= (following-char) ?}) | |
| 1381 (setq indent (- indent cperl-indent-level))) | |
| 1382 ((memq (following-char) '(?\) ?\])) ; To line up with opening paren. | |
| 1383 (setq indent (+ indent cperl-close-paren-offset))) | |
| 1384 ((= (following-char) ?{) | |
| 1385 (setq indent (+ indent cperl-brace-offset)))))) | |
| 1386 (skip-chars-forward " \t") | |
| 1387 (setq shift-amt (- indent (current-column))) | |
| 1388 (if (zerop shift-amt) | |
| 1389 (if (> (- (point-max) pos) (point)) | |
| 1390 (goto-char (- (point-max) pos))) | |
| 1391 (delete-region beg (point)) | |
| 1392 (indent-to indent) | |
| 1393 ;; If initial point was within line's indentation, | |
| 1394 ;; position after the indentation. Else stay at same point in text. | |
| 1395 (if (> (- (point-max) pos) (point)) | |
| 1396 (goto-char (- (point-max) pos)))) | |
| 1397 shift-amt)) | |
| 1398 | |
| 1399 (defun cperl-after-label () | |
| 1400 ;; Returns true if the point is after label. Does not do save-excursion. | |
| 1401 (and (eq (preceding-char) ?:) | |
| 1402 (memq (char-syntax (char-after (- (point) 2))) | |
| 1403 '(?w ?_)) | |
| 1404 (progn | |
| 1405 (backward-sexp) | |
| 1406 (looking-at "[a-zA-Z_][a-zA-Z0-9_]*:")))) | |
| 1407 | |
| 1408 (defun cperl-get-state (&optional parse-start start-state) | |
| 1409 ;; returns list (START STATE DEPTH PRESTART), START is a good place | |
| 1410 ;; to start parsing, STATE is what is returned by | |
| 1411 ;; `parse-partial-sexp'. DEPTH is true is we are immediately after | |
| 1412 ;; end of block which contains START. PRESTART is the position | |
| 1413 ;; basing on which START was found. | |
| 1414 (save-excursion | |
| 1415 (let ((start-point (point)) depth state start prestart) | |
| 1416 (if parse-start | |
| 1417 (goto-char parse-start) | |
| 1418 (beginning-of-defun)) | |
| 1419 (setq prestart (point)) | |
| 1420 (if start-state nil | |
| 1421 ;; Try to go out, if sub is not on the outermost level | |
| 1422 (while (< (point) start-point) | |
| 1423 (setq start (point) parse-start start depth nil | |
| 1424 state (parse-partial-sexp start start-point -1)) | |
| 1425 (if (> (car state) -1) nil | |
| 1426 ;; The current line could start like }}}, so the indentation | |
| 1427 ;; corresponds to a different level than what we reached | |
| 1428 (setq depth t) | |
| 1429 (beginning-of-line 2))) ; Go to the next line. | |
| 1430 (if start (goto-char start))) ; Not at the start of file | |
| 1431 (setq start (point)) | |
| 1432 (if (< start start-point) (setq parse-start start)) | |
| 1433 (or state (setq state (parse-partial-sexp start start-point -1 nil start-state))) | |
| 1434 (list start state depth prestart)))) | |
| 1435 | |
| 1436 (defun cperl-block-p () ; Do not C-M-q ! One string contains ";" ! | |
| 1437 ;; Positions is before ?\{. Checks whether it starts a block. | |
| 1438 ;; No save-excursion! | |
| 1439 (cperl-backward-to-noncomment (point-min)) | |
| 1440 ;;(skip-chars-backward " \t\n\f") | |
| 1441 (or (memq (preceding-char) (append ";){}$@&%\C-@" nil)) ; Or label! \C-@ at bobp | |
| 1442 ; Label may be mixed up with `$blah :' | |
| 1443 (save-excursion (cperl-after-label)) | |
| 1444 (and (eq (char-syntax (preceding-char)) ?w) | |
| 1445 (progn | |
| 1446 (backward-sexp) | |
| 1447 ;; Need take into account `bless', `return', `tr',... | |
| 1448 (or (and (looking-at "\\sw+[ \t\n\f]*[{#]") ; Method call syntax | |
| 1449 (not (looking-at "\\(bless\\|return\\|qw\\|tr\\|[smy]\\)\\>"))) | |
| 1450 (progn | |
| 1451 (skip-chars-backward " \t\n\f") | |
| 1452 (and (eq (char-syntax (preceding-char)) ?w) | |
| 1453 (progn | |
| 1454 (backward-sexp) | |
| 1455 (looking-at | |
| 1456 "sub[ \t]+\\sw+[ \t\n\f]*[#{]"))))))))) | |
| 1457 | |
| 1458 (defun cperl-calculate-indent (&optional parse-start symbol) | |
| 1459 "Return appropriate indentation for current line as Perl code. | |
| 1460 In usual case returns an integer: the column to indent to. | |
| 1461 Returns nil if line starts inside a string, t if in a comment." | |
| 1462 (save-excursion | |
| 1463 (if (memq (get-text-property (point) 'syntax-type) '(pod here-doc)) nil | |
| 1464 (beginning-of-line) | |
| 1465 (let* ((indent-point (point)) | |
| 1466 (case-fold-search nil) | |
| 1467 (s-s (cperl-get-state)) | |
| 1468 (start (nth 0 s-s)) | |
| 1469 (state (nth 1 s-s)) | |
| 1470 (containing-sexp (car (cdr state))) | |
| 1471 (char-after (save-excursion | |
| 1472 (skip-chars-forward " \t") | |
| 1473 (following-char))) | |
| 1474 (start-indent (save-excursion | |
| 1475 (goto-char start) | |
| 1476 (- (current-indentation) | |
| 1477 (if (nth 2 s-s) cperl-indent-level 0)))) | |
| 1478 old-indent) | |
| 1479 ;; (or parse-start (null symbol) | |
| 1480 ;; (setq parse-start (symbol-value symbol) | |
| 1481 ;; start-indent (nth 2 parse-start) | |
| 1482 ;; parse-start (car parse-start))) | |
| 1483 ;; (if parse-start | |
| 1484 ;; (goto-char parse-start) | |
| 1485 ;; (beginning-of-defun)) | |
| 1486 ;; ;; Try to go out | |
| 1487 ;; (while (< (point) indent-point) | |
| 1488 ;; (setq start (point) parse-start start moved nil | |
| 1489 ;; state (parse-partial-sexp start indent-point -1)) | |
| 1490 ;; (if (> (car state) -1) nil | |
| 1491 ;; ;; The current line could start like }}}, so the indentation | |
| 1492 ;; ;; corresponds to a different level than what we reached | |
| 1493 ;; (setq moved t) | |
| 1494 ;; (beginning-of-line 2))) ; Go to the next line. | |
| 1495 ;; (if start ; Not at the start of file | |
| 1496 ;; (progn | |
| 1497 ;; (goto-char start) | |
| 1498 ;; (setq start-indent (current-indentation)) | |
| 1499 ;; (if moved ; Should correct... | |
| 1500 ;; (setq start-indent (- start-indent cperl-indent-level)))) | |
| 1501 ;; (setq start-indent 0)) | |
| 1502 ;; (if (< (point) indent-point) (setq parse-start (point))) | |
| 1503 ;; (or state (setq state (parse-partial-sexp | |
| 1504 ;; (point) indent-point -1 nil start-state))) | |
| 1505 ;; (setq containing-sexp | |
| 1506 ;; (or (car (cdr state)) | |
| 1507 ;; (and (>= (nth 6 state) 0) old-containing-sexp)) | |
| 1508 ;; old-containing-sexp nil start-state nil) | |
| 1509 ;;;; (while (< (point) indent-point) | |
| 1510 ;;;; (setq parse-start (point)) | |
| 1511 ;;;; (setq state (parse-partial-sexp (point) indent-point -1 nil start-state)) | |
| 1512 ;;;; (setq containing-sexp | |
| 1513 ;;;; (or (car (cdr state)) | |
| 1514 ;;;; (and (>= (nth 6 state) 0) old-containing-sexp)) | |
| 1515 ;;;; old-containing-sexp nil start-state nil)) | |
| 1516 ;; (if symbol (set symbol (list indent-point state start-indent))) | |
| 1517 ;; (goto-char indent-point) | |
| 1518 (cond ((or (nth 3 state) (nth 4 state)) | |
| 1519 ;; return nil or t if should not change this line | |
| 1520 (nth 4 state)) | |
| 1521 ((null containing-sexp) | |
| 1522 ;; Line is at top level. May be data or function definition, | |
| 1523 ;; or may be function argument declaration. | |
| 1524 ;; Indent like the previous top level line | |
| 1525 ;; unless that ends in a closeparen without semicolon, | |
| 1526 ;; in which case this line is the first argument decl. | |
| 1527 (skip-chars-forward " \t") | |
| 1528 (+ start-indent | |
| 1529 (if (= (following-char) ?{) cperl-continued-brace-offset 0) | |
| 1530 (progn | |
| 1531 (cperl-backward-to-noncomment (or parse-start (point-min))) | |
| 1532 ;;(skip-chars-backward " \t\f\n") | |
| 1533 ;; Look at previous line that's at column 0 | |
| 1534 ;; to determine whether we are in top-level decls | |
| 1535 ;; or function's arg decls. Set basic-indent accordingly. | |
| 1536 ;; Now add a little if this is a continuation line. | |
| 1537 (if (or (bobp) | |
| 1538 (memq (preceding-char) (append " ;}" nil)) ; Was ?\) | |
| 1539 (memq char-after (append ")]}" nil))) | |
| 1540 0 | |
| 1541 cperl-continued-statement-offset)))) | |
| 1542 ((/= (char-after containing-sexp) ?{) | |
| 1543 ;; line is expression, not statement: | |
| 1544 ;; indent to just after the surrounding open, | |
| 1545 ;; skip blanks if we do not close the expression. | |
| 1546 (goto-char (1+ containing-sexp)) | |
| 1547 (or (memq char-after (append ")]}" nil)) | |
| 1548 (looking-at "[ \t]*\\(#\\|$\\)") | |
| 1549 (skip-chars-forward " \t")) | |
| 1550 (current-column)) | |
| 1551 ((progn | |
| 1552 ;; Containing-expr starts with \{. Check whether it is a hash. | |
| 1553 (goto-char containing-sexp) | |
| 1554 (not (cperl-block-p))) | |
| 1555 (goto-char (1+ containing-sexp)) | |
| 1556 (or (eq char-after ?\}) | |
| 1557 (looking-at "[ \t]*\\(#\\|$\\)") | |
| 1558 (skip-chars-forward " \t")) | |
| 1559 (+ (current-column) ; Correct indentation of trailing ?\} | |
| 1560 (if (eq char-after ?\}) (+ cperl-indent-level | |
| 1561 cperl-close-paren-offset) | |
| 1562 0))) | |
| 1563 (t | |
| 1564 ;; Statement level. Is it a continuation or a new statement? | |
| 1565 ;; Find previous non-comment character. | |
| 1566 (goto-char indent-point) | |
| 1567 (cperl-backward-to-noncomment containing-sexp) | |
| 1568 ;; Back up over label lines, since they don't | |
| 1569 ;; affect whether our line is a continuation. | |
| 1570 (while (or (eq (preceding-char) ?\,) | |
| 1571 (and (eq (preceding-char) ?:) | |
| 1572 (or;;(eq (char-after (- (point) 2)) ?\') ; ???? | |
| 1573 (memq (char-syntax (char-after (- (point) 2))) | |
| 1574 '(?w ?_))))) | |
| 1575 (if (eq (preceding-char) ?\,) | |
| 1576 ;; Will go to beginning of line, essentially. | |
| 1577 ;; Will ignore embedded sexpr XXXX. | |
| 1578 (cperl-backward-to-start-of-continued-exp containing-sexp)) | |
| 1579 (beginning-of-line) | |
| 1580 (cperl-backward-to-noncomment containing-sexp)) | |
| 1581 ;; Now we get the answer. | |
| 1582 (if (not (memq (preceding-char) (append ", ;}{" '(nil)))) ; Was ?\, | |
| 1583 ;; This line is continuation of preceding line's statement; | |
| 1584 ;; indent `cperl-continued-statement-offset' more than the | |
| 1585 ;; previous line of the statement. | |
| 1586 (progn | |
| 1587 (cperl-backward-to-start-of-continued-exp containing-sexp) | |
| 1588 (+ (if (memq char-after (append "}])" nil)) | |
| 1589 0 ; Closing parenth | |
| 1590 cperl-continued-statement-offset) | |
| 1591 (current-column) | |
| 1592 (if (eq char-after ?\{) | |
| 1593 cperl-continued-brace-offset 0))) | |
| 1594 ;; This line starts a new statement. | |
| 1595 ;; Position following last unclosed open. | |
| 1596 (goto-char containing-sexp) | |
| 1597 ;; Is line first statement after an open-brace? | |
| 1598 (or | |
| 1599 ;; If no, find that first statement and indent like | |
| 1600 ;; it. If the first statement begins with label, do | |
| 1601 ;; not belive when the indentation of the label is too | |
| 1602 ;; small. | |
| 1603 (save-excursion | |
| 1604 (forward-char 1) | |
| 1605 (setq old-indent (current-indentation)) | |
| 1606 (let ((colon-line-end 0)) | |
| 1607 (while (progn (skip-chars-forward " \t\n") | |
| 1608 (looking-at "#\\|[a-zA-Z0-9_$]*:[^:]")) | |
| 1609 ;; Skip over comments and labels following openbrace. | |
| 1610 (cond ((= (following-char) ?\#) | |
| 1611 (forward-line 1)) | |
| 1612 ;; label: | |
| 1613 (t | |
| 1614 (save-excursion (end-of-line) | |
| 1615 (setq colon-line-end (point))) | |
| 1616 (search-forward ":")))) | |
| 1617 ;; The first following code counts | |
| 1618 ;; if it is before the line we want to indent. | |
| 1619 (and (< (point) indent-point) | |
| 1620 (if (> colon-line-end (point)) ; After label | |
| 1621 (if (> (current-indentation) | |
| 1622 cperl-min-label-indent) | |
| 1623 (- (current-indentation) cperl-label-offset) | |
| 1624 ;; Do not belive: `max' is involved | |
| 1625 (+ old-indent cperl-indent-level)) | |
| 1626 (current-column))))) | |
| 1627 ;; If no previous statement, | |
| 1628 ;; indent it relative to line brace is on. | |
| 1629 ;; For open brace in column zero, don't let statement | |
| 1630 ;; start there too. If cperl-indent-level is zero, | |
| 1631 ;; use cperl-brace-offset + cperl-continued-statement-offset instead. | |
| 1632 ;; For open-braces not the first thing in a line, | |
| 1633 ;; add in cperl-brace-imaginary-offset. | |
| 1634 | |
| 1635 ;; If first thing on a line: ????? | |
| 1636 (+ (if (and (bolp) (zerop cperl-indent-level)) | |
| 1637 (+ cperl-brace-offset cperl-continued-statement-offset) | |
| 1638 cperl-indent-level) | |
| 1639 ;; Move back over whitespace before the openbrace. | |
| 1640 ;; If openbrace is not first nonwhite thing on the line, | |
| 1641 ;; add the cperl-brace-imaginary-offset. | |
| 1642 (progn (skip-chars-backward " \t") | |
| 1643 (if (bolp) 0 cperl-brace-imaginary-offset)) | |
| 1644 ;; If the openbrace is preceded by a parenthesized exp, | |
| 1645 ;; move to the beginning of that; | |
| 1646 ;; possibly a different line | |
| 1647 (progn | |
| 1648 (if (eq (preceding-char) ?\)) | |
| 1649 (forward-sexp -1)) | |
| 1650 ;; In the case it starts a subroutine, indent with | |
| 1651 ;; respect to `sub', not with respect to the the | |
| 1652 ;; first thing on the line, say in the case of | |
| 1653 ;; anonymous sub in a hash. | |
| 1654 ;; | |
| 1655 (skip-chars-backward " \t") | |
| 1656 (if (and (eq (preceding-char) ?b) | |
| 1657 (progn | |
| 1658 (forward-word -1) | |
| 1659 (looking-at "sub\\>")) | |
| 1660 (setq old-indent | |
| 1661 (nth 1 | |
| 1662 (parse-partial-sexp | |
| 1663 (save-excursion (beginning-of-line) (point)) | |
| 1664 (point))))) | |
| 1665 (progn (goto-char (1+ old-indent)) | |
| 1666 (skip-chars-forward " \t") | |
| 1667 (current-column)) | |
| 1668 ;; Get initial indentation of the line we are on. | |
| 1669 ;; If line starts with label, calculate label indentation | |
| 1670 (if (save-excursion | |
| 1671 (beginning-of-line) | |
| 1672 (looking-at "[ \t]*[a-zA-Z_][a-zA-Z_]*:[^:]")) | |
| 1673 (if (> (current-indentation) cperl-min-label-indent) | |
| 1674 (- (current-indentation) cperl-label-offset) | |
| 1675 (cperl-calculate-indent | |
| 1676 (if (and parse-start (<= parse-start (point))) | |
| 1677 parse-start))) | |
| 1678 (current-indentation))))))))))))) | |
| 1679 | |
| 1680 (defvar cperl-indent-alist | |
| 1681 '((string nil) | |
| 1682 (comment nil) | |
| 1683 (toplevel 0) | |
| 1684 (toplevel-after-parenth 2) | |
| 1685 (toplevel-continued 2) | |
| 1686 (expression 1)) | |
| 1687 "Alist of indentation rules for CPerl mode. | |
| 1688 The values mean: | |
| 1689 nil: do not indent; | |
| 1690 number: add this amount of indentation.") | |
| 1691 | |
| 1692 (defun cperl-where-am-i (&optional parse-start start-state) | |
| 1693 ;; Unfinished | |
| 1694 "Return a list of lists ((TYPE POS)...) of good points before the point. | |
| 1695 POS may be nil if it is hard to find, say, when TYPE is `string' or `comment'." | |
| 1696 (save-excursion | |
| 1697 (let* ((start-point (point)) | |
| 1698 (s-s (cperl-get-state)) | |
| 1699 (start (nth 0 s-s)) | |
| 1700 (state (nth 1 s-s)) | |
| 1701 (prestart (nth 3 s-s)) | |
| 1702 (containing-sexp (car (cdr state))) | |
| 1703 (case-fold-search nil) | |
| 1704 (res (list (list 'parse-start start) (list 'parse-prestart prestart)))) | |
| 1705 (cond ((nth 3 state) ; In string | |
| 1706 (setq res (cons (list 'string nil (nth 3 state)) res))) ; What started string | |
| 1707 ((nth 4 state) ; In comment | |
| 1708 (setq res (cons '(comment) res))) | |
| 1709 ((null containing-sexp) | |
| 1710 ;; Line is at top level. | |
| 1711 ;; Indent like the previous top level line | |
| 1712 ;; unless that ends in a closeparen without semicolon, | |
| 1713 ;; in which case this line is the first argument decl. | |
| 1714 (cperl-backward-to-noncomment (or parse-start (point-min))) | |
| 1715 ;;(skip-chars-backward " \t\f\n") | |
| 1716 (cond | |
| 1717 ((or (bobp) | |
| 1718 (memq (preceding-char) (append ";}" nil))) | |
| 1719 (setq res (cons (list 'toplevel start) res))) | |
| 1720 ((eq (preceding-char) ?\) ) | |
| 1721 (setq res (cons (list 'toplevel-after-parenth start) res))) | |
| 1722 (t | |
| 1723 (setq res (cons (list 'toplevel-continued start) res))))) | |
| 1724 ((/= (char-after containing-sexp) ?{) | |
| 1725 ;; line is expression, not statement: | |
| 1726 ;; indent to just after the surrounding open. | |
| 1727 ;; skip blanks if we do not close the expression. | |
| 1728 (setq res (cons (list 'expression-blanks | |
| 1729 (progn | |
| 1730 (goto-char (1+ containing-sexp)) | |
| 1731 (or (looking-at "[ \t]*\\(#\\|$\\)") | |
| 1732 (skip-chars-forward " \t")) | |
| 1733 (point))) | |
| 1734 (cons (list 'expression containing-sexp) res)))) | |
| 1735 ((progn | |
| 1736 ;; Containing-expr starts with \{. Check whether it is a hash. | |
| 1737 (goto-char containing-sexp) | |
| 1738 (not (cperl-block-p))) | |
| 1739 (setq res (cons (list 'expression-blanks | |
| 1740 (progn | |
| 1741 (goto-char (1+ containing-sexp)) | |
| 1742 (or (looking-at "[ \t]*\\(#\\|$\\)") | |
| 1743 (skip-chars-forward " \t")) | |
| 1744 (point))) | |
| 1745 (cons (list 'expression containing-sexp) res)))) | |
| 1746 (t | |
| 1747 ;; Statement level. | |
| 1748 (setq res (cons (list 'in-block containing-sexp) res)) | |
| 1749 ;; Is it a continuation or a new statement? | |
| 1750 ;; Find previous non-comment character. | |
| 1751 (cperl-backward-to-noncomment containing-sexp) | |
| 1752 ;; Back up over label lines, since they don't | |
| 1753 ;; affect whether our line is a continuation. | |
| 1754 ;; Back up comma-delimited lines too ????? | |
| 1755 (while (or (eq (preceding-char) ?\,) | |
| 1756 (save-excursion (cperl-after-label))) | |
| 1757 (if (eq (preceding-char) ?\,) | |
| 1758 ;; Will go to beginning of line, essentially | |
| 1759 ;; Will ignore embedded sexpr XXXX. | |
| 1760 (cperl-backward-to-start-of-continued-exp containing-sexp)) | |
| 1761 (beginning-of-line) | |
| 1762 (cperl-backward-to-noncomment containing-sexp)) | |
| 1763 ;; Now we get the answer. | |
| 1764 (if (not (memq (preceding-char) (append ";}{" '(nil)))) ; Was ?\, | |
| 1765 ;; This line is continuation of preceding line's statement. | |
| 1766 (list (list 'statement-continued containing-sexp)) | |
| 1767 ;; This line starts a new statement. | |
| 1768 ;; Position following last unclosed open. | |
| 1769 (goto-char containing-sexp) | |
| 1770 ;; Is line first statement after an open-brace? | |
| 1771 (or | |
| 1772 ;; If no, find that first statement and indent like | |
| 1773 ;; it. If the first statement begins with label, do | |
| 1774 ;; not belive when the indentation of the label is too | |
| 1775 ;; small. | |
| 1776 (save-excursion | |
| 1777 (forward-char 1) | |
| 1778 (let ((colon-line-end 0)) | |
| 1779 (while (progn (skip-chars-forward " \t\n" start-point) | |
| 1780 (and (< (point) start-point) | |
| 1781 (looking-at | |
| 1782 "#\\|[a-zA-Z_][a-zA-Z0-9_]*:[^:]"))) | |
| 1783 ;; Skip over comments and labels following openbrace. | |
| 1784 (cond ((= (following-char) ?\#) | |
| 1785 ;;(forward-line 1) | |
| 1786 (end-of-line)) | |
| 1787 ;; label: | |
| 1788 (t | |
| 1789 (save-excursion (end-of-line) | |
| 1790 (setq colon-line-end (point))) | |
| 1791 (search-forward ":")))) | |
| 1792 ;; Now at the point, after label, or at start | |
| 1793 ;; of first statement in the block. | |
| 1794 (and (< (point) start-point) | |
| 1795 (if (> colon-line-end (point)) | |
| 1796 ;; Before statement after label | |
| 1797 (if (> (current-indentation) | |
| 1798 cperl-min-label-indent) | |
| 1799 (list (list 'label-in-block (point))) | |
| 1800 ;; Do not belive: `max' is involved | |
| 1801 (list | |
| 1802 (list 'label-in-block-min-indent (point)))) | |
| 1803 ;; Before statement | |
| 1804 (list 'statement-in-block (point)))))) | |
| 1805 ;; If no previous statement, | |
| 1806 ;; indent it relative to line brace is on. | |
| 1807 ;; For open brace in column zero, don't let statement | |
| 1808 ;; start there too. If cperl-indent-level is zero, | |
| 1809 ;; use cperl-brace-offset + cperl-continued-statement-offset instead. | |
| 1810 ;; For open-braces not the first thing in a line, | |
| 1811 ;; add in cperl-brace-imaginary-offset. | |
| 1812 | |
| 1813 ;; If first thing on a line: ????? | |
| 1814 (+ (if (and (bolp) (zerop cperl-indent-level)) | |
| 1815 (+ cperl-brace-offset cperl-continued-statement-offset) | |
| 1816 cperl-indent-level) | |
| 1817 ;; Move back over whitespace before the openbrace. | |
| 1818 ;; If openbrace is not first nonwhite thing on the line, | |
| 1819 ;; add the cperl-brace-imaginary-offset. | |
| 1820 (progn (skip-chars-backward " \t") | |
| 1821 (if (bolp) 0 cperl-brace-imaginary-offset)) | |
| 1822 ;; If the openbrace is preceded by a parenthesized exp, | |
| 1823 ;; move to the beginning of that; | |
| 1824 ;; possibly a different line | |
| 1825 (progn | |
| 1826 (if (eq (preceding-char) ?\)) | |
| 1827 (forward-sexp -1)) | |
| 1828 ;; Get initial indentation of the line we are on. | |
| 1829 ;; If line starts with label, calculate label indentation | |
| 1830 (if (save-excursion | |
| 1831 (beginning-of-line) | |
| 1832 (looking-at "[ \t]*[a-zA-Z_][a-zA-Z_]*:[^:]")) | |
| 1833 (if (> (current-indentation) cperl-min-label-indent) | |
| 1834 (- (current-indentation) cperl-label-offset) | |
| 1835 (cperl-calculate-indent | |
| 1836 (if (and parse-start (<= parse-start (point))) | |
| 1837 parse-start))) | |
| 1838 (current-indentation)))))))) | |
| 1839 res))) | |
| 1840 | |
| 1841 (defun cperl-calculate-indent-within-comment () | |
| 1842 "Return the indentation amount for line, assuming that | |
| 1843 the current line is to be regarded as part of a block comment." | |
| 1844 (let (end star-start) | |
| 1845 (save-excursion | |
| 1846 (beginning-of-line) | |
| 1847 (skip-chars-forward " \t") | |
| 1848 (setq end (point)) | |
| 1849 (and (= (following-char) ?#) | |
| 1850 (forward-line -1) | |
| 1851 (cperl-to-comment-or-eol) | |
| 1852 (setq end (point))) | |
| 1853 (goto-char end) | |
| 1854 (current-column)))) | |
| 1855 | |
| 1856 | |
| 1857 (defun cperl-to-comment-or-eol () | |
| 1858 "Goes to position before comment on the current line, or to end of line. | |
| 1859 Returns true if comment is found." | |
| 1860 (let (state stop-in cpoint (lim (progn (end-of-line) (point)))) | |
| 1861 (beginning-of-line) | |
| 1862 (if (re-search-forward "\\=[ \t]*\\(#\\|$\\)" lim t) | |
| 1863 (if (eq (preceding-char) ?\#) (progn (backward-char 1) t)) | |
| 1864 ;; Else | |
| 1865 (while (not stop-in) | |
| 1866 (setq state (parse-partial-sexp (point) lim nil nil nil t)) | |
| 1867 ; stop at comment | |
| 1868 ;; If fails (beginning-of-line inside sexp), then contains not-comment | |
| 1869 ;; Do simplified processing | |
| 1870 ;;(if (re-search-forward "[^$]#" lim 1) | |
| 1871 ;; (progn | |
| 1872 ;; (forward-char -1) | |
| 1873 ;; (skip-chars-backward " \t\n\f" lim)) | |
| 1874 ;; (goto-char lim)) ; No `#' at all | |
| 1875 ;;) | |
| 1876 (if (nth 4 state) ; After `#'; | |
| 1877 ; (nth 2 state) can be | |
| 1878 ; beginning of m,s,qq and so | |
| 1879 ; on | |
| 1880 (if (nth 2 state) | |
| 1881 (progn | |
| 1882 (setq cpoint (point)) | |
| 1883 (goto-char (nth 2 state)) | |
| 1884 (cond | |
| 1885 ((looking-at "\\(s\\|tr\\)\\>") | |
| 1886 (or (re-search-forward | |
| 1887 "\\=\\w+[ \t]*#\\([^\n\\\\#]\\|\\\\[\\\\#]\\)*#\\([^\n\\\\#]\\|\\\\[\\\\#]\\)*" | |
| 1888 lim 'move) | |
| 1889 (setq stop-in t))) | |
| 1890 ((looking-at "\\(m\\|q\\([qxw]\\)?\\)\\>") | |
| 1891 (or (re-search-forward | |
| 1892 "\\=\\w+[ \t]*#\\([^\n\\\\#]\\|\\\\[\\\\#]\\)*#" | |
| 1893 lim 'move) | |
| 1894 (setq stop-in t))) | |
| 1895 (t ; It was fair comment | |
| 1896 (setq stop-in t) ; Finish | |
| 1897 (goto-char (1- cpoint))))) | |
| 1898 (setq stop-in t) ; Finish | |
| 1899 (forward-char -1)) | |
| 1900 (setq stop-in t)) ; Finish | |
| 1901 ) | |
| 1902 (nth 4 state)))) | |
| 1903 | |
| 1904 (defun cperl-find-pods-heres (&optional min max) | |
| 1905 "Scans the buffer for POD sections and here-documents. | |
| 1906 If `cperl-pod-here-fontify' is not-nil after evaluation, will fontify | |
| 1907 the sections using `cperl-pod-head-face', `cperl-pod-face', | |
| 1908 `cperl-here-face'." | |
| 1909 (interactive) | |
| 1910 (or min (setq min (point-min))) | |
| 1911 (or max (setq max (point-max))) | |
| 1912 (let (face head-face here-face b e bb tag err | |
| 1913 (cperl-pod-here-fontify (eval cperl-pod-here-fontify)) | |
| 1914 (case-fold-search nil) (inhibit-read-only t) (buffer-undo-list t) | |
| 1915 (modified (buffer-modified-p))) | |
| 1916 (unwind-protect | |
| 1917 (progn | |
| 1918 (save-excursion | |
| 1919 (message "Scanning for pods and here-docs...") | |
| 1920 (if cperl-pod-here-fontify | |
| 1921 (setq face (eval cperl-pod-face) | |
| 1922 head-face (eval cperl-pod-head-face) | |
| 1923 here-face (eval cperl-here-face))) | |
| 1924 (remove-text-properties min max '(syntax-type t)) | |
| 1925 ;; Need to remove face as well... | |
| 1926 (goto-char min) | |
| 1927 (while (re-search-forward "\\(\\`\n?\\|\n\n\\)=" max t) | |
| 1928 (if (looking-at "\n*cut\\>") | |
| 1929 (progn | |
| 1930 (message "=cut is not preceeded by a pod section") | |
| 1931 (setq err (point))) | |
| 1932 (beginning-of-line) | |
| 1933 (setq b (point) bb b) | |
| 1934 (or (re-search-forward "\n\n=cut\\>" max 'toend) | |
| 1935 (message "Cannot find the end of a pod section")) | |
| 1936 (beginning-of-line 4) | |
| 1937 (setq e (point)) | |
| 1938 (put-text-property b e 'in-pod t) | |
| 1939 (goto-char b) | |
| 1940 (while (re-search-forward "\n\n[ \t]" e t) | |
| 1941 (beginning-of-line) | |
| 1942 (put-text-property b (point) 'syntax-type 'pod) | |
| 1943 (put-text-property (max (point-min) (1- b)) | |
| 1944 (point) cperl-do-not-fontify t) | |
| 1945 (if cperl-pod-here-fontify (put-text-property b (point) 'face face)) | |
| 1946 (re-search-forward "\n\n[^ \t\f]" e 'toend) | |
| 1947 (beginning-of-line) | |
| 1948 (setq b (point))) | |
| 1949 (put-text-property (point) e 'syntax-type 'pod) | |
| 1950 (put-text-property (max (point-min) (1- (point))) | |
| 1951 e cperl-do-not-fontify t) | |
| 1952 (if cperl-pod-here-fontify | |
| 1953 (progn (put-text-property (point) e 'face face) | |
| 1954 (goto-char bb) | |
| 1955 (while (re-search-forward | |
| 1956 ;; One paragraph | |
| 1957 "\n\n=[a-zA-Z0-9]+\\>[ \t]*\\(\\(\n?[^\n]\\)+\\)$" | |
| 1958 e 'toend) | |
| 1959 (put-text-property | |
| 1960 (match-beginning 1) (match-end 1) | |
| 1961 'face head-face)))) | |
| 1962 (goto-char e))) | |
| 1963 (goto-char min) | |
| 1964 (while (re-search-forward | |
| 1965 "<<\\(\\([\"'`]\\)?\\)\\([a-zA-Z_][a-zA-Z_0-9]*\\)\\1" | |
| 1966 max t) | |
| 1967 (setq tag (buffer-substring (match-beginning 3) | |
| 1968 (match-end 3))) | |
| 1969 (if cperl-pod-here-fontify | |
| 1970 (put-text-property (match-beginning 3) (match-end 3) | |
| 1971 'face font-lock-reference-face)) | |
| 1972 (forward-line) | |
| 1973 (setq b (point)) | |
| 1974 (and (re-search-forward (concat "^" tag "$") max 'toend) | |
| 1975 (progn | |
| 1976 (if cperl-pod-here-fontify | |
| 1977 (progn | |
| 1978 (put-text-property (match-beginning 0) (match-end 0) | |
| 1979 'face font-lock-reference-face) | |
| 1980 (put-text-property (max (point-min) (1- b)) | |
| 1981 (min (point-max) | |
| 1982 (1+ (match-end 0))) | |
| 1983 cperl-do-not-fontify t) | |
| 1984 (put-text-property b (match-beginning 0) | |
| 1985 'face here-face))) | |
| 1986 (put-text-property b (match-beginning 0) | |
| 1987 'syntax-type 'here-doc))))) | |
| 1988 (if err (goto-char err) | |
| 1989 (message "Scan for pods and here-docs completed."))) | |
| 1990 (and (buffer-modified-p) | |
| 1991 (not modified) | |
| 1992 (set-buffer-modified-p nil))))) | |
| 1993 | |
| 1994 (defun cperl-backward-to-noncomment (lim) | |
| 1995 ;; Stops at lim or after non-whitespace that is not in comment | |
| 1996 (let (stop p) | |
| 1997 (while (and (not stop) (> (point) (or lim 1))) | |
| 1998 (skip-chars-backward " \t\n\f" lim) | |
| 1999 (setq p (point)) | |
| 2000 (beginning-of-line) | |
| 2001 (if (looking-at "^[ \t]*\\(#\\|$\\)") nil ; Only comment, skip | |
| 2002 ;; Else | |
| 2003 (cperl-to-comment-or-eol) | |
| 2004 (skip-chars-backward " \t") | |
| 2005 (if (< p (point)) (goto-char p)) | |
| 2006 (setq stop t))))) | |
| 2007 | |
| 2008 (defun cperl-after-expr-p (&optional lim chars test) | |
| 2009 "Returns true if the position is good for start of expression. | |
| 2010 TEST is the expression to evaluate at the found position. If absent, | |
| 2011 CHARS is a string that contains good characters to have before us." | |
| 2012 (let (stop p) | |
| 2013 (save-excursion | |
| 2014 (while (and (not stop) (> (point) (or lim 1))) | |
| 2015 (skip-chars-backward " \t\n\f" lim) | |
| 2016 (setq p (point)) | |
| 2017 (beginning-of-line) | |
| 2018 (if (looking-at "^[ \t]*\\(#\\|$\\)") nil ; Only comment, skip | |
| 2019 ;; Else: last iteration (What to do with labels?) | |
| 2020 (cperl-to-comment-or-eol) | |
| 2021 (skip-chars-backward " \t") | |
| 2022 (if (< p (point)) (goto-char p)) | |
| 2023 (setq stop t))) | |
| 2024 (or (bobp) | |
| 2025 (progn | |
| 2026 (backward-char 1) | |
| 2027 (if test (eval test) | |
| 2028 (memq (following-char) (append (or chars "{};") nil)))))))) | |
| 2029 | |
| 2030 (defun cperl-backward-to-start-of-continued-exp (lim) | |
| 2031 (if (memq (preceding-char) (append ")]}\"'`" nil)) | |
| 2032 (forward-sexp -1)) | |
| 2033 (beginning-of-line) | |
| 2034 (if (<= (point) lim) | |
| 2035 (goto-char (1+ lim))) | |
| 2036 (skip-chars-forward " \t")) | |
| 2037 | |
| 2038 | |
| 2039 (defvar innerloop-done nil) | |
| 2040 (defvar last-depth nil) | |
| 2041 | |
| 2042 (defun cperl-indent-exp () | |
| 2043 "Simple variant of indentation of continued-sexp. | |
| 2044 Should be slow. Will not indent comment if it starts at `comment-indent' | |
| 2045 or looks like continuation of the comment on the previous line." | |
| 2046 (interactive) | |
| 2047 (save-excursion | |
| 2048 (let ((tmp-end (progn (end-of-line) (point))) top done) | |
| 2049 (save-excursion | |
| 2050 (while (null done) | |
| 2051 (beginning-of-line) | |
| 2052 (setq top (point)) | |
| 2053 (while (= (nth 0 (parse-partial-sexp (point) tmp-end | |
| 2054 -1)) -1) | |
| 2055 (setq top (point))) ; Get the outermost parenths in line | |
| 2056 (goto-char top) | |
| 2057 (while (< (point) tmp-end) | |
| 2058 (parse-partial-sexp (point) tmp-end nil t) ; To start-sexp or eol | |
| 2059 (or (eolp) (forward-sexp 1))) | |
| 2060 (if (> (point) tmp-end) (progn (end-of-line) (setq tmp-end (point))) | |
| 2061 (setq done t))) | |
| 2062 (goto-char tmp-end) | |
| 2063 (setq tmp-end (point-marker))) | |
| 2064 (cperl-indent-region (point) tmp-end)))) | |
| 2065 | |
| 2066 (defun cperl-indent-region (start end) | |
| 2067 "Simple variant of indentation of region in CPerl mode. | |
| 2068 Should be slow. Will not indent comment if it starts at `comment-indent' | |
| 2069 or looks like continuation of the comment on the previous line. | |
| 2070 Indents all the lines whose first character is between START and END | |
| 2071 inclusive." | |
| 2072 (interactive "r") | |
| 2073 (save-excursion | |
| 2074 (let (st comm indent-info old-comm-indent new-comm-indent | |
| 2075 (pm 0) (imenu-scanning-message "Indenting... (%3d%%)")) | |
| 2076 (goto-char start) | |
| 2077 (setq old-comm-indent (and (cperl-to-comment-or-eol) | |
| 2078 (current-column)) | |
| 2079 new-comm-indent old-comm-indent) | |
| 2080 (goto-char start) | |
| 2081 (or (bolp) (beginning-of-line 2)) | |
| 2082 (or (fboundp 'imenu-progress-message) | |
| 2083 (message "Indenting... For feedback load `imenu'...")) | |
| 2084 (while (and (<= (point) end) (not (eobp))) ; bol to check start | |
| 2085 (and (fboundp 'imenu-progress-message) | |
| 2086 (imenu-progress-message | |
| 2087 pm (/ (* 100 (- (point) start)) (- end start -1)))) | |
| 2088 (setq st (point) | |
| 2089 indent-info nil | |
| 2090 ) ; Believe indentation of the current | |
| 2091 (if (and (setq comm (looking-at "[ \t]*#")) | |
| 2092 (or (eq (current-indentation) (or old-comm-indent | |
| 2093 comment-column)) | |
| 2094 (setq old-comm-indent nil))) | |
| 2095 (if (and old-comm-indent | |
| 2096 (= (current-indentation) old-comm-indent)) | |
| 2097 (let ((comment-column new-comm-indent)) | |
| 2098 (indent-for-comment))) | |
| 2099 (progn | |
| 2100 (cperl-indent-line 'indent-info) | |
| 2101 (or comm | |
| 2102 (progn | |
| 2103 (if (setq old-comm-indent (and (cperl-to-comment-or-eol) | |
| 2104 (current-column))) | |
| 2105 (progn (indent-for-comment) | |
| 2106 (skip-chars-backward " \t") | |
| 2107 (skip-chars-backward "#") | |
| 2108 (setq new-comm-indent (current-column)))))))) | |
| 2109 (beginning-of-line 2)) | |
| 2110 (if (fboundp 'imenu-progress-message) | |
| 2111 (imenu-progress-message pm 100) | |
| 2112 (message nil))))) | |
| 2113 | |
| 2114 (defun cperl-slash-is-regexp (&optional pos) | |
| 2115 (save-excursion | |
| 2116 (goto-char (if pos pos (1- (point)))) | |
| 2117 (and | |
| 2118 (not (memq (get-text-property (point) 'face) | |
| 2119 '(font-lock-string-face font-lock-comment-face))) | |
| 2120 (cperl-after-expr-p nil nil ' | |
| 2121 (or (looking-at "[^]a-zA-Z0-9_)}]") | |
| 2122 (eq (get-text-property (point) 'face) | |
| 2123 'font-lock-keyword-face)))))) | |
| 2124 | |
| 2125 ;; Stolen from lisp-mode with a lot of improvements | |
| 2126 | |
| 2127 (defun cperl-fill-paragraph (&optional justify iteration) | |
| 2128 "Like \\[fill-paragraph], but handle CPerl comments. | |
| 2129 If any of the current line is a comment, fill the comment or the | |
| 2130 block of it that point is in, preserving the comment's initial | |
| 2131 indentation and initial hashes. Behaves usually outside of comment." | |
| 2132 (interactive "P") | |
| 2133 (let ( | |
| 2134 ;; Non-nil if the current line contains a comment. | |
| 2135 has-comment | |
| 2136 | |
| 2137 ;; If has-comment, the appropriate fill-prefix for the comment. | |
| 2138 comment-fill-prefix | |
| 2139 ;; Line that contains code and comment (or nil) | |
| 2140 start | |
| 2141 c spaces len dc (comment-column comment-column)) | |
| 2142 ;; Figure out what kind of comment we are looking at. | |
| 2143 (save-excursion | |
| 2144 (beginning-of-line) | |
| 2145 (cond | |
| 2146 | |
| 2147 ;; A line with nothing but a comment on it? | |
| 2148 ((looking-at "[ \t]*#[# \t]*") | |
| 2149 (setq has-comment t | |
| 2150 comment-fill-prefix (buffer-substring (match-beginning 0) | |
| 2151 (match-end 0)))) | |
| 2152 | |
| 2153 ;; A line with some code, followed by a comment? Remember that the | |
| 2154 ;; semi which starts the comment shouldn't be part of a string or | |
| 2155 ;; character. | |
| 2156 ((cperl-to-comment-or-eol) | |
| 2157 (setq has-comment t) | |
| 2158 (looking-at "#+[ \t]*") | |
| 2159 (setq start (point) c (current-column) | |
| 2160 comment-fill-prefix | |
| 2161 (concat (make-string (current-column) ?\ ) | |
| 2162 (buffer-substring (match-beginning 0) (match-end 0))) | |
| 2163 spaces (progn (skip-chars-backward " \t") | |
| 2164 (buffer-substring (point) start)) | |
| 2165 dc (- c (current-column)) len (- start (point)) | |
| 2166 start (point-marker)) | |
| 2167 (delete-char len) | |
| 2168 (insert (make-string dc ?-))))) | |
| 2169 (if (not has-comment) | |
| 2170 (fill-paragraph justify) ; Do the usual thing outside of comment | |
| 2171 ;; Narrow to include only the comment, and then fill the region. | |
| 2172 (save-restriction | |
| 2173 (narrow-to-region | |
| 2174 ;; Find the first line we should include in the region to fill. | |
| 2175 (if start (progn (beginning-of-line) (point)) | |
| 2176 (save-excursion | |
| 2177 (while (and (zerop (forward-line -1)) | |
| 2178 (looking-at "^[ \t]*#+[ \t]*[^ \t\n#]"))) | |
| 2179 ;; We may have gone to far. Go forward again. | |
| 2180 (or (looking-at "^[ \t]*#+[ \t]*[^ \t\n#]") | |
| 2181 (forward-line 1)) | |
| 2182 (point))) | |
| 2183 ;; Find the beginning of the first line past the region to fill. | |
| 2184 (save-excursion | |
| 2185 (while (progn (forward-line 1) | |
| 2186 (looking-at "^[ \t]*#+[ \t]*[^ \t\n#]"))) | |
| 2187 (point))) | |
| 2188 ;; Remove existing hashes | |
| 2189 (goto-char (point-min)) | |
| 2190 (while (progn (forward-line 1) (< (point) (point-max))) | |
| 2191 (skip-chars-forward " \t") | |
| 2192 (and (looking-at "#+") | |
| 2193 (delete-char (- (match-end 0) (match-beginning 0))))) | |
| 2194 | |
| 2195 ;; Lines with only hashes on them can be paragraph boundaries. | |
| 2196 (let ((paragraph-start (concat paragraph-start "\\|^[ \t#]*$")) | |
| 2197 (paragraph-separate (concat paragraph-start "\\|^[ \t#]*$")) | |
| 2198 (fill-prefix comment-fill-prefix)) | |
| 2199 (fill-paragraph justify))) | |
| 2200 (if (and start) | |
| 2201 (progn | |
| 2202 (goto-char start) | |
| 2203 (if (> dc 0) | |
| 2204 (progn (delete-char dc) (insert spaces))) | |
| 2205 (if (or (= (current-column) c) iteration) nil | |
| 2206 (setq comment-column c) | |
| 2207 (indent-for-comment) | |
| 2208 ;; Repeat once more, flagging as iteration | |
| 2209 (cperl-fill-paragraph justify t))))))) | |
| 2210 | |
| 2211 (defun cperl-do-auto-fill () | |
| 2212 ;; Break out if the line is short enough | |
| 2213 (if (> (save-excursion | |
| 2214 (end-of-line) | |
| 2215 (current-column)) | |
| 2216 fill-column) | |
| 2217 (let ((c (save-excursion (beginning-of-line) | |
| 2218 (cperl-to-comment-or-eol) (point))) | |
| 2219 (s (memq (following-char) '(?\ ?\t))) marker) | |
| 2220 (if (>= c (point)) nil | |
| 2221 (setq marker (point-marker)) | |
| 2222 (cperl-fill-paragraph) | |
| 2223 (goto-char marker) | |
| 2224 ;; Is not enough, sometimes marker is a start of line | |
| 2225 (if (bolp) (progn (re-search-forward "#+[ \t]*") | |
| 2226 (goto-char (match-end 0)))) | |
| 2227 ;; Following space could have gone: | |
| 2228 (if (or (not s) (memq (following-char) '(?\ ?\t))) nil | |
| 2229 (insert " ") | |
| 2230 (backward-char 1)) | |
| 2231 ;; Previous space could have gone: | |
| 2232 (or (memq (preceding-char) '(?\ ?\t)) (insert " ")))))) | |
| 2233 | |
| 2234 (defvar imenu-example--function-name-regexp-perl | |
| 2235 "^\\([ \t]*\\(sub\\|package\\)[ \t\n]+\\([a-zA-Z_0-9:']+\\)[ \t]*\\|=head\\([12]\\)[ \t]+\\([^\n]+\\)$\\)") | |
| 2236 | |
| 2237 (defun imenu-example--create-perl-index (&optional regexp) | |
| 2238 (require 'cl) | |
| 2239 (let ((index-alist '()) (index-pack-alist '()) (index-pod-alist '()) | |
| 2240 (index-unsorted-alist '()) (i-s-f (default-value 'imenu-sort-function)) | |
| 2241 packages ends-ranges p | |
| 2242 (prev-pos 0) char fchar index index1 name (end-range 0) package) | |
| 2243 (goto-char (point-min)) | |
| 2244 (imenu-progress-message prev-pos 0) | |
| 2245 ;; Search for the function | |
| 2246 (save-match-data | |
| 2247 (while (re-search-forward | |
| 2248 (or regexp imenu-example--function-name-regexp-perl) | |
| 2249 nil t) | |
| 2250 (imenu-progress-message prev-pos) | |
| 2251 ;;(backward-up-list 1) | |
| 2252 (cond | |
| 2253 ((match-beginning 2) ; package or sub | |
| 2254 (save-excursion | |
| 2255 (goto-char (match-beginning 2)) | |
| 2256 (setq fchar (following-char)) | |
| 2257 ) | |
| 2258 (setq char (following-char)) | |
| 2259 (setq p (point)) | |
| 2260 (while (and ends-ranges (>= p (car ends-ranges))) | |
| 2261 ;; delete obsolete entries | |
| 2262 (setq ends-ranges (cdr ends-ranges) packages (cdr packages))) | |
| 2263 (setq package (or (car packages) "") | |
| 2264 end-range (or (car ends-ranges) 0)) | |
| 2265 (if (eq fchar ?p) | |
| 2266 (progn | |
| 2267 (setq name (buffer-substring (match-beginning 3) (match-end 3)) | |
| 2268 package (concat name "::") | |
| 2269 name (concat "package " name) | |
| 2270 end-range | |
| 2271 (save-excursion | |
| 2272 (parse-partial-sexp (point) (point-max) -1) (point)) | |
| 2273 ends-ranges (cons end-range ends-ranges) | |
| 2274 packages (cons package packages)))) | |
| 2275 ;; ) | |
| 2276 ;; Skip this function name if it is a prototype declaration. | |
| 2277 (if (and (eq fchar ?s) (eq char ?\;)) nil | |
| 2278 (if (eq fchar ?p) nil | |
| 2279 (setq name (buffer-substring (match-beginning 3) (match-end 3))) | |
| 2280 (if (or (> p end-range) (string-match "[:']" name)) nil | |
| 2281 (setq name (concat package name)))) | |
| 2282 (setq index (imenu-example--name-and-position)) | |
| 2283 (setcar index name) | |
| 2284 (if (eq fchar ?p) | |
| 2285 (push index index-pack-alist) | |
| 2286 (push index index-alist)) | |
| 2287 (push index index-unsorted-alist))) | |
| 2288 (t ; Pod section | |
| 2289 ;; (beginning-of-line) | |
| 2290 (setq index (imenu-example--name-and-position) | |
| 2291 name (buffer-substring (match-beginning 5) (match-end 5))) | |
| 2292 (if (eq (char-after (match-beginning 4)) ?2) | |
| 2293 (setq name (concat " " name))) | |
| 2294 (setcar index name) | |
| 2295 (setq index1 (cons (concat "=" name) (cdr index))) | |
| 2296 (push index index-pod-alist) | |
| 2297 (push index1 index-unsorted-alist))))) | |
| 2298 (imenu-progress-message prev-pos 100) | |
| 2299 (setq index-alist | |
| 2300 (if (default-value 'imenu-sort-function) | |
| 2301 (sort index-alist (default-value 'imenu-sort-function)) | |
| 2302 (nreverse index-alist))) | |
| 2303 (and index-pod-alist | |
| 2304 (push (cons (imenu-create-submenu-name "+POD headers+") | |
| 2305 (nreverse index-pod-alist)) | |
| 2306 index-alist)) | |
| 2307 (and index-pack-alist | |
| 2308 (push (cons (imenu-create-submenu-name "+Packages+") | |
| 2309 (nreverse index-pack-alist)) | |
| 2310 index-alist)) | |
| 2311 (and (or index-pack-alist index-pod-alist | |
| 2312 (default-value 'imenu-sort-function)) | |
| 2313 index-unsorted-alist | |
| 2314 (push (cons (imenu-create-submenu-name "+Unsorted List+") | |
| 2315 (nreverse index-unsorted-alist)) | |
| 2316 index-alist)) | |
| 2317 index-alist)) | |
| 2318 | |
| 2319 (defvar cperl-compilation-error-regexp-alist | |
| 2320 ;; This look like a paranoiac regexp: could anybody find a better one? (which WORK). | |
| 2321 '(("^[^\n]* \\(file\\|at\\) \\([^ \t\n]+\\) [^\n]*line \\([0-9]+\\)[\\., \n]" | |
| 2322 2 3)) | |
| 2323 "Alist that specifies how to match errors in perl output.") | |
| 2324 | |
| 2325 (if (fboundp 'eval-after-load) | |
| 2326 (eval-after-load | |
| 2327 "mode-compile" | |
| 2328 '(setq perl-compilation-error-regexp-alist | |
| 2329 cperl-compilation-error-regexp-alist))) | |
| 2330 | |
| 2331 | |
| 2332 (defvar cperl-faces-init nil) | |
| 2333 | |
| 2334 (defun cperl-windowed-init () | |
| 2335 "Initialization under windowed version." | |
| 2336 (add-hook 'font-lock-mode-hook | |
| 2337 (function | |
| 2338 (lambda () | |
| 2339 (if (or | |
| 2340 (eq major-mode 'perl-mode) | |
| 2341 (eq major-mode 'cperl-mode)) | |
| 2342 (progn | |
| 2343 (or cperl-faces-init (cperl-init-faces)))))))) | |
| 2344 | |
| 2345 (defvar perl-font-lock-keywords-1 nil | |
| 2346 "Additional expressions to highlight in Perl mode. Minimal set.") | |
| 2347 (defvar perl-font-lock-keywords nil | |
| 2348 "Additional expressions to highlight in Perl mode. Default set.") | |
| 2349 (defvar perl-font-lock-keywords-2 nil | |
| 2350 "Additional expressions to highlight in Perl mode. Maximal set") | |
| 2351 | |
| 2352 (defun cperl-init-faces () | |
| 2353 (condition-case nil | |
| 2354 (progn | |
| 2355 (require 'font-lock) | |
| 2356 (and (fboundp 'font-lock-fontify-anchored-keywords) | |
| 2357 (featurep 'font-lock-extra) | |
| 2358 (message "You have an obsolete package `font-lock-extra'. Install `choose-color'.")) | |
| 2359 (let (t-font-lock-keywords t-font-lock-keywords-1 font-lock-anchored) | |
| 2360 ;;(defvar cperl-font-lock-enhanced nil | |
| 2361 ;; "Set to be non-nil if font-lock allows active highlights.") | |
| 2362 (if (fboundp 'font-lock-fontify-anchored-keywords) | |
| 2363 (setq font-lock-anchored t)) | |
| 2364 (setq | |
| 2365 t-font-lock-keywords | |
| 2366 (list | |
| 2367 (cons | |
| 2368 (concat | |
| 2369 "\\(^\\|[^$@%&\\]\\)\\<\\(" | |
| 2370 (mapconcat | |
| 2371 'identity | |
| 2372 '("if" "until" "while" "elsif" "else" "unless" "for" | |
| 2373 "foreach" "continue" "exit" "die" "last" "goto" "next" | |
| 2374 "redo" "return" "local" "exec" "sub" "do" "dump" "use" | |
| 2375 "require" "package" "eval" "my" "BEGIN" "END") | |
| 2376 "\\|") ; Flow control | |
| 2377 "\\)\\>") 2) ; was "\\)[ \n\t;():,\|&]" | |
| 2378 ; In what follows we use `type' style | |
| 2379 ; for overwritable buildins | |
| 2380 (list | |
| 2381 (concat | |
| 2382 "\\(^\\|[^$@%&\\]\\)\\<\\(" | |
| 2383 ;; "CORE" "__FILE__" "__LINE__" "abs" "accept" "alarm" "and" "atan2" | |
| 2384 ;; "bind" "binmode" "bless" "caller" "chdir" "chmod" "chown" "chr" | |
| 2385 ;; "chroot" "close" "closedir" "cmp" "connect" "continue" "cos" | |
| 2386 ;; "crypt" "dbmclose" "dbmopen" "die" "dump" "endgrent" "endhostent" | |
| 2387 ;; "endnetent" "endprotoent" "endpwent" "endservent" "eof" "eq" "exec" | |
| 2388 ;; "exit" "exp" "fcntl" "fileno" "flock" "fork" "formline" "ge" "getc" | |
| 2389 ;; "getgrent" "getgrgid" "getgrnam" "gethostbyaddr" "gethostbyname" | |
| 2390 ;; "gethostent" "getlogin" "getnetbyaddr" "getnetbyname" "getnetent" | |
| 2391 ;; "getpeername" "getpgrp" "getppid" "getpriority" "getprotobyname" | |
| 2392 ;; "getprotobynumber" "getprotoent" "getpwent" "getpwnam" "getpwuid" | |
| 2393 ;; "getservbyname" "getservbyport" "getservent" "getsockname" | |
| 2394 ;; "getsockopt" "glob" "gmtime" "gt" "hex" "index" "int" "ioctl" | |
| 2395 ;; "join" "kill" "lc" "lcfirst" "le" "length" "link" "listen" | |
| 2396 ;; "localtime" "log" "lstat" "lt" "mkdir" "msgctl" "msgget" "msgrcv" | |
| 2397 ;; "msgsnd" "ne" "not" "oct" "open" "opendir" "or" "ord" "pack" "pipe" | |
| 2398 ;; "quotemeta" "rand" "read" "readdir" "readline" "readlink" | |
| 2399 ;; "readpipe" "recv" "ref" "rename" "require" "reset" "reverse" | |
| 2400 ;; "rewinddir" "rindex" "rmdir" "seek" "seekdir" "select" "semctl" | |
| 2401 ;; "semget" "semop" "send" "setgrent" "sethostent" "setnetent" | |
| 2402 ;; "setpgrp" "setpriority" "setprotoent" "setpwent" "setservent" | |
| 2403 ;; "setsockopt" "shmctl" "shmget" "shmread" "shmwrite" "shutdown" | |
| 2404 ;; "sin" "sleep" "socket" "socketpair" "sprintf" "sqrt" "srand" "stat" | |
| 2405 ;; "substr" "symlink" "syscall" "sysread" "system" "syswrite" "tell" | |
| 2406 ;; "telldir" "time" "times" "truncate" "uc" "ucfirst" "umask" "unlink" | |
| 2407 ;; "unpack" "utime" "values" "vec" "wait" "waitpid" "wantarray" "warn" | |
| 2408 ;; "write" "x" "xor" | |
| 2409 "a\\(bs\\|ccept\\|tan2\\|larm\\|nd\\)\\|" | |
| 2410 "b\\(in\\(d\\|mode\\)\\|less\\)\\|" | |
| 2411 "c\\(h\\(r\\(\\|oot\\)\\|dir\\|mod\\|own\\)\\|aller\\|rypt\\|" | |
| 2412 "lose\\(\\|dir\\)\\|mp\\|o\\(s\\|n\\(tinue\\|nect\\)\\)\\)\\|" | |
| 2413 "CORE\\|d\\(ie\\|bm\\(close\\|open\\)\\|ump\\)\\|" | |
| 2414 "e\\(x\\(p\\|it\\|ec\\)\\|q\\|nd\\(p\\(rotoent\\|went\\)\\|" | |
| 2415 "hostent\\|servent\\|netent\\|grent\\)\\|of\\)\\|" | |
| 2416 "f\\(ileno\\|cntl\\|lock\\|or\\(k\\|mline\\)\\)\\|" | |
| 2417 "g\\(t\\|lob\\|mtime\\|e\\(\\|t\\(p\\(pid\\|r\\(iority\\|" | |
| 2418 "oto\\(byn\\(ame\\|umber\\)\\|ent\\)\\)\\|eername\\|w" | |
| 2419 "\\(uid\\|ent\\|nam\\)\\|grp\\)\\|host\\(by\\(addr\\|name\\)\\|" | |
| 2420 "ent\\)\\|s\\(erv\\(by\\(port\\|name\\)\\|ent\\)\\|" | |
| 2421 "ock\\(name\\|opt\\)\\)\\|c\\|login\\|net\\(by\\(addr\\|name\\)\\|" | |
| 2422 "ent\\)\\|gr\\(ent\\|nam\\|gid\\)\\)\\)\\)\\|" | |
| 2423 "hex\\|i\\(n\\(t\\|dex\\)\\|octl\\)\\|join\\|kill\\|" | |
| 2424 "l\\(i\\(sten\\|nk\\)\\|stat\\|c\\(\\|first\\)\\|t\\|e" | |
| 2425 "\\(\\|ngth\\)\\|o\\(caltime\\|g\\)\\)\\|m\\(sg\\(rcv\\|snd\\|" | |
| 2426 "ctl\\|get\\)\\|kdir\\)\\|n\\(e\\|ot\\)\\|o\\(pen\\(\\|dir\\)\\|" | |
| 2427 "r\\(\\|d\\)\\|ct\\)\\|p\\(ipe\\|ack\\)\\|quotemeta\\|" | |
| 2428 "r\\(index\\|and\\|mdir\\|e\\(quire\\|ad\\(pipe\\|\\|lin" | |
| 2429 "\\(k\\|e\\)\\|dir\\)\\|set\\|cv\\|verse\\|f\\|winddir\\|name" | |
| 2430 "\\)\\)\\|s\\(printf\\|qrt\\|rand\\|tat\\|ubstr\\|e\\(t\\(p\\(r" | |
| 2431 "\\(iority\\|otoent\\)\\|went\\|grp\\)\\|hostent\\|s\\(ervent\\|" | |
| 2432 "ockopt\\)\\|netent\\|grent\\)\\|ek\\(\\|dir\\)\\|lect\\|" | |
| 2433 "m\\(ctl\\|op\\|get\\)\\|nd\\)\\|h\\(utdown\\|m\\(read\\|ctl\\|" | |
| 2434 "write\\|get\\)\\)\\|y\\(s\\(read\\|call\\|tem\\|write\\)\\|" | |
| 2435 "mlink\\)\\|in\\|leep\\|ocket\\(pair\\|\\)\\)\\|t\\(runcate\\|" | |
| 2436 "ell\\(\\|dir\\)\\|ime\\(\\|s\\)\\)\\|u\\(c\\(\\|first\\)\\|" | |
| 2437 "time\\|mask\\|n\\(pack\\|link\\)\\)\\|v\\(alues\\|ec\\)\\|" | |
| 2438 "w\\(a\\(rn\\|it\\(pid\\|\\)\\|ntarray\\)\\|rite\\)\\|" | |
| 2439 "x\\(\\|or\\)\\|__\\(FILE__\\|LINE__\\)" | |
| 2440 "\\)\\>") 2 'font-lock-type-face) | |
| 2441 ;; In what follows we use `other' style | |
| 2442 ;; for nonoverwritable buildins | |
| 2443 ;; Somehow 's', 'm' are not autogenerated??? | |
| 2444 (list | |
| 2445 (concat | |
| 2446 "\\(^\\|[^$@%&\\]\\)\\<\\(" | |
| 2447 ;; "AUTOLOAD" "BEGIN" "DESTROY" "END" "__END__" "chomp" "chop" | |
| 2448 ;; "defined" "delete" "do" "each" "else" "elsif" "eval" "exists" "for" | |
| 2449 ;; "foreach" "format" "goto" "grep" "if" "keys" "last" "local" "map" | |
| 2450 ;; "my" "next" "no" "package" "pop" "pos" "print" "printf" "push" "q" | |
| 2451 ;; "qq" "qw" "qx" "redo" "return" "scalar" "shift" "sort" "splice" | |
| 2452 ;; "split" "study" "sub" "tie" "tr" "undef" "unless" "unshift" "untie" | |
| 2453 ;; "until" "use" "while" "y" | |
| 2454 "AUTOLOAD\\|BEGIN\\|cho\\(p\\|mp\\)\\|d\\(e\\(fined\\|lete\\)\\|" | |
| 2455 "o\\)\\|DESTROY\\|e\\(ach\\|val\\|xists\\|ls\\(e\\|if\\)\\)\\|" | |
| 2456 "END\\|for\\(\\|each\\|mat\\)\\|g\\(rep\\|oto\\)\\|if\\|keys\\|" | |
| 2457 "l\\(ast\\|ocal\\)\\|m\\(ap\\|y\\)\\|n\\(ext\\|o\\)\\|" | |
| 2458 "p\\(ackage\\|rint\\(\\|f\\)\\|ush\\|o\\(p\\|s\\)\\)\\|" | |
| 2459 "q\\(\\|q\\|w\\|x\\)\\|re\\(turn\\|do\\)\\|s\\(pli\\(ce\\|t\\)\\|" | |
| 2460 "calar\\|tudy\\|ub\\|hift\\|ort\\)\\|t\\(r\\|ie\\)\\|" | |
| 2461 "u\\(se\\|n\\(shift\\|ti\\(l\\|e\\)\\|def\\|less\\)\\)\\|" | |
| 2462 "while\\|y\\|__\\(END\\|DATA\\)__" ;__DATA__ added manually | |
| 2463 "\\|[sm]" ; Added manually | |
| 2464 "\\)\\>") 2 'font-lock-other-type-face) | |
| 2465 ;; (mapconcat 'identity | |
| 2466 ;; '("#endif" "#else" "#ifdef" "#ifndef" "#if" | |
| 2467 ;; "#include" "#define" "#undef") | |
| 2468 ;; "\\|") | |
| 2469 '("-[rwxoRWXOezsfdlpSbctugkTBMAC]\\>\\([ \t]+_\\>\\)?" 0 | |
| 2470 font-lock-function-name-face) ; Not very good, triggers at "[a-z]" | |
| 2471 '("\\<sub[ \t]+\\([^ \t{;]+\\)[ \t]*[{\n]" 1 | |
| 2472 font-lock-function-name-face) | |
| 2473 '("\\<\\(package\\|require\\|use\\|import\\|no\\|bootstrap\\)[ \t]+\\([a-zA-z_][a-zA-z_0-9:]*\\)[ \t;]" ; require A if B; | |
| 2474 2 font-lock-function-name-face) | |
| 2475 (cond ((featurep 'font-lock-extra) | |
| 2476 '("\\([]}\\\\%@>*&]\\|\\$[a-zA-Z0-9_:]*\\)[ \t]*{[ \t]*\\(-?[a-zA-Z0-9_:]+\\)[ \t]*}" | |
| 2477 (2 font-lock-string-face t) | |
| 2478 (0 '(restart 2 t)))) ; To highlight $a{bc}{ef} | |
| 2479 (font-lock-anchored | |
| 2480 '("\\([]}\\\\%@>*&]\\|\\$[a-zA-Z0-9_:]*\\)[ \t]*{[ \t]*\\(-?[a-zA-Z0-9_:]+\\)[ \t]*}" | |
| 2481 (2 font-lock-string-face t) | |
| 2482 ("\\=[ \t]*{[ \t]*\\(-?[a-zA-Z0-9_:]+\\)[ \t]*}" | |
| 2483 nil nil | |
| 2484 (1 font-lock-string-face t)))) | |
| 2485 (t '("\\([]}\\\\%@>*&]\\|\\$[a-zA-Z0-9_:]*\\)[ \t]*{[ \t]*\\(-?[a-zA-Z0-9_:]+\\)[ \t]*}" | |
| 2486 2 font-lock-string-face t))) | |
| 2487 '("[ \t{,(]\\(-?[a-zA-Z0-9_:]+\\)[ \t]*=>" 1 | |
| 2488 font-lock-string-face t) | |
| 2489 '("^[ \t]*\\([a-zA-Z0-9_]+[ \t]*:\\)[ \t]*\\($\\|{\\|\\<\\(until\\|while\\|for\\(each\\)?\\|do\\)\\>\\)" 1 | |
| 2490 font-lock-reference-face) ; labels | |
| 2491 '("\\<\\(continue\\|next\\|last\\|redo\\|goto\\)\\>[ \t]+\\([a-zA-Z0-9_:]+\\)" ; labels as targets | |
| 2492 2 font-lock-reference-face) | |
| 2493 (cond ((featurep 'font-lock-extra) | |
| 2494 '("^[ \t]*\\(my\\|local\\)[ \t]*\\(([ \t]*\\)?\\([$@%*][a-zA-Z0-9_:]+\\)\\([ \t]*,\\)?" | |
| 2495 (3 font-lock-variable-name-face) | |
| 2496 (4 '(another 4 nil | |
| 2497 ("\\=[ \t]*,[ \t]*\\([$@%*][a-zA-Z0-9_:]+\\)\\([ \t]*,\\)?" | |
| 2498 (1 font-lock-variable-name-face) | |
| 2499 (2 '(restart 2 nil) nil t))) | |
| 2500 nil t))) ; local variables, multiple | |
| 2501 (font-lock-anchored | |
| 2502 '("^[ \t]*\\(my\\|local\\)[ \t]*\\(([ \t]*\\)?\\([$@%*][a-zA-Z0-9_:]+\\)" | |
| 2503 (3 font-lock-variable-name-face) | |
| 2504 ("\\=[ \t]*,[ \t]*\\([$@%*][a-zA-Z0-9_:]+\\)" | |
| 2505 nil nil | |
| 2506 (1 font-lock-variable-name-face)))) | |
| 2507 (t '("^[ \t]*\\(my\\|local\\)[ \t]*\\(([ \t]*\\)?\\([$@%*][a-zA-Z0-9_:]+\\)" | |
| 2508 3 font-lock-variable-name-face))) | |
| 2509 '("\\<for\\(each\\)?[ \t]*\\(\\$[a-zA-Z_][a-zA-Z_0-9]*\\)[ \t]*(" | |
| 2510 2 font-lock-variable-name-face))) | |
| 2511 (setq | |
| 2512 t-font-lock-keywords-1 | |
| 2513 (and (fboundp 'turn-on-font-lock) ; Check for newer font-lock | |
| 2514 (not (cperl-xemacs-p)) ; not yet as of XEmacs 19.12 | |
| 2515 '(("\\(\\([$@]+\\)[a-zA-Z_:][a-zA-Z0-9_:]*\\)[ \t]*\\([[{]\\)" | |
| 2516 1 | |
| 2517 (if (= (- (match-end 2) (match-beginning 2)) 1) | |
| 2518 (if (eq (char-after (match-beginning 3)) ?{) | |
| 2519 font-lock-other-emphasized-face | |
| 2520 font-lock-emphasized-face) ; arrays and hashes | |
| 2521 font-lock-variable-name-face) ; Just to put something | |
| 2522 t) | |
| 2523 ("\\(\\([@%]\\|\$#\\)[a-zA-Z_:][a-zA-Z0-9_:]*\\)" 1 | |
| 2524 (if (eq (char-after (match-beginning 2)) ?%) | |
| 2525 font-lock-other-emphasized-face | |
| 2526 font-lock-emphasized-face) | |
| 2527 t) ; arrays and hashes | |
| 2528 ;;("\\([smy]\\|tr\\)\\([^a-z_A-Z0-9]\\)\\(\\([^\n\\]*||\\)\\)\\2") | |
| 2529 ;;; Too much noise from \s* @s[ and friends | |
| 2530 ;;("\\(\\<\\([msy]\\|tr\\)[ \t]*\\([^ \t\na-zA-Z0-9_]\\)\\|\\(/\\)\\)" | |
| 2531 ;;(3 font-lock-function-name-face t t) | |
| 2532 ;;(4 | |
| 2533 ;; (if (cperl-slash-is-regexp) | |
| 2534 ;; font-lock-function-name-face 'default) nil t)) | |
| 2535 ))) | |
| 2536 (setq perl-font-lock-keywords-1 t-font-lock-keywords | |
| 2537 perl-font-lock-keywords perl-font-lock-keywords-1 | |
| 2538 perl-font-lock-keywords-2 (append | |
| 2539 t-font-lock-keywords | |
| 2540 t-font-lock-keywords-1))) | |
| 2541 (if (fboundp 'ps-print-buffer) (cperl-ps-print-init)) | |
| 2542 (if (or (featurep 'choose-color) (featurep 'font-lock-extra)) | |
| 2543 (font-lock-require-faces | |
| 2544 (list | |
| 2545 ;; Color-light Color-dark Gray-light Gray-dark Mono | |
| 2546 (list 'font-lock-comment-face | |
| 2547 ["Firebrick" "OrangeRed" "DimGray" "Gray80"] | |
| 2548 nil | |
| 2549 [nil nil t t t] | |
| 2550 [nil nil t t t] | |
| 2551 nil) | |
| 2552 (list 'font-lock-string-face | |
| 2553 ["RosyBrown" "LightSalmon" "Gray50" "LightGray"] | |
| 2554 nil | |
| 2555 nil | |
| 2556 [nil nil t t t] | |
| 2557 nil) | |
| 2558 (list 'font-lock-keyword-face | |
| 2559 ["Purple" "LightSteelBlue" "DimGray" "Gray90"] | |
| 2560 nil | |
| 2561 [nil nil t t t] | |
| 2562 nil | |
| 2563 nil) | |
| 2564 (list 'font-lock-function-name-face | |
| 2565 (vector | |
| 2566 "Blue" "LightSkyBlue" "Gray50" "LightGray" | |
| 2567 (cdr (assq 'background-color ; if mono | |
| 2568 (frame-parameters)))) | |
| 2569 (vector | |
| 2570 nil nil nil nil | |
| 2571 (cdr (assq 'foreground-color ; if mono | |
| 2572 (frame-parameters)))) | |
| 2573 [nil nil t t t] | |
| 2574 nil | |
| 2575 nil) | |
| 2576 (list 'font-lock-variable-name-face | |
| 2577 ["DarkGoldenrod" "LightGoldenrod" "DimGray" "Gray90"] | |
| 2578 nil | |
| 2579 [nil nil t t t] | |
| 2580 [nil nil t t t] | |
| 2581 nil) | |
| 2582 (list 'font-lock-type-face | |
| 2583 ["DarkOliveGreen" "PaleGreen" "DimGray" "Gray80"] | |
| 2584 nil | |
| 2585 [nil nil t t t] | |
| 2586 nil | |
| 2587 [nil nil t t t] | |
| 2588 ) | |
| 2589 (list 'font-lock-reference-face | |
| 2590 ["CadetBlue" "Aquamarine" "Gray50" "LightGray"] | |
| 2591 nil | |
| 2592 [nil nil t t t] | |
| 2593 nil | |
| 2594 [nil nil t t t] | |
| 2595 ) | |
| 2596 (list 'font-lock-other-type-face | |
| 2597 ["chartreuse3" ("orchid1" "orange") | |
| 2598 nil "Gray80"] | |
| 2599 [nil nil "gray90"] | |
| 2600 [nil nil nil t t] | |
| 2601 [nil nil t t] | |
| 2602 [nil nil t t t] | |
| 2603 ) | |
| 2604 (list 'font-lock-emphasized-face | |
| 2605 ["blue" "yellow" nil "Gray80"] | |
| 2606 ["lightyellow2" ("navy" "os2blue" "darkgreen") | |
| 2607 "gray90"] | |
| 2608 t | |
| 2609 nil | |
| 2610 nil) | |
| 2611 (list 'font-lock-other-emphasized-face | |
| 2612 ["red" "red" nil "Gray80"] | |
| 2613 ["lightyellow2" ("navy" "os2blue" "darkgreen") | |
| 2614 "gray90"] | |
| 2615 t | |
| 2616 t | |
| 2617 nil))) | |
| 2618 (defvar cperl-guessed-background nil | |
| 2619 "Display characteristics as guessed by cperl.") | |
| 2620 (or (fboundp 'x-color-defined-p) | |
| 2621 (defalias 'x-color-defined-p | |
| 2622 (cond ((fboundp 'color-defined-p) 'color-defined-p) | |
| 2623 ;; XEmacs >= 19.12 | |
| 2624 ((fboundp 'valid-color-name-p) 'valid-color-name-p) | |
| 2625 ;; XEmacs 19.11 | |
| 2626 (t 'x-valid-color-name-p)))) | |
| 2627 (defvar font-lock-reference-face 'font-lock-reference-face) | |
| 2628 (defvar font-lock-variable-name-face 'font-lock-variable-name-face) | |
| 2629 (or (boundp 'font-lock-type-face) | |
| 2630 (defconst font-lock-type-face | |
| 2631 'font-lock-type-face | |
| 2632 "Face to use for data types.") | |
| 2633 ) | |
| 2634 (or (boundp 'font-lock-other-type-face) | |
| 2635 (defconst font-lock-other-type-face | |
| 2636 'font-lock-other-type-face | |
| 2637 "Face to use for data types from another group.") | |
| 2638 ) | |
| 2639 (if (not (cperl-xemacs-p)) nil | |
| 2640 (or (boundp 'font-lock-comment-face) | |
| 2641 (defconst font-lock-comment-face | |
| 2642 'font-lock-comment-face | |
| 2643 "Face to use for comments.") | |
| 2644 ) | |
| 2645 (or (boundp 'font-lock-keyword-face) | |
| 2646 (defconst font-lock-keyword-face | |
| 2647 'font-lock-keyword-face | |
| 2648 "Face to use for keywords.") | |
| 2649 ) | |
| 2650 (or (boundp 'font-lock-function-name-face) | |
| 2651 (defconst font-lock-function-name-face | |
| 2652 'font-lock-function-name-face | |
| 2653 "Face to use for function names.") | |
| 2654 ) | |
| 2655 ) | |
| 2656 ;;(if (featurep 'font-lock) | |
| 2657 (if (face-equal font-lock-type-face font-lock-comment-face) | |
| 2658 (defconst font-lock-type-face | |
| 2659 'font-lock-type-face | |
| 2660 "Face to use for basic data types.") | |
| 2661 ) | |
| 2662 ;;; (if (fboundp 'eval-after-load) | |
| 2663 ;;; (eval-after-load "font-lock" | |
| 2664 ;;; '(if (face-equal font-lock-type-face | |
| 2665 ;;; font-lock-comment-face) | |
| 2666 ;;; (defconst font-lock-type-face | |
| 2667 ;;; 'font-lock-type-face | |
| 2668 ;;; "Face to use for basic data types.") | |
| 2669 ;;; ))) ; This does not work :-( Why?! | |
| 2670 ;;; ; Workaround: added to font-lock-m-h | |
| 2671 ;;; ) | |
| 2672 (or (boundp 'font-lock-other-emphasized-face) | |
| 2673 (defconst font-lock-other-emphasized-face | |
| 2674 'font-lock-other-emphasized-face | |
| 2675 "Face to use for another type of emphasizing.") | |
| 2676 ) | |
| 2677 (or (boundp 'font-lock-emphasized-face) | |
| 2678 (defconst font-lock-emphasized-face | |
| 2679 'font-lock-emphasized-face | |
| 2680 "Face to use for emphasizing.") | |
| 2681 ) | |
| 2682 ;; Here we try to guess background | |
| 2683 (let ((background | |
| 2684 (if (boundp 'font-lock-background-mode) | |
| 2685 font-lock-background-mode | |
| 2686 'light)) | |
| 2687 (face-list (and (fboundp 'face-list) (face-list))) | |
| 2688 is-face) | |
| 2689 (fset 'is-face | |
| 2690 (cond ((fboundp 'find-face) | |
| 2691 (symbol-function 'find-face)) | |
| 2692 (face-list | |
| 2693 (function (lambda (face) (member face face-list)))) | |
| 2694 (t | |
| 2695 (function (lambda (face) (boundp face)))))) | |
| 2696 (defvar cperl-guessed-background | |
| 2697 (if (and (boundp 'font-lock-display-type) | |
| 2698 (eq font-lock-display-type 'grayscale)) | |
| 2699 'gray | |
| 2700 background) | |
| 2701 "Background as guessed by CPerl mode") | |
| 2702 (if (is-face 'font-lock-type-face) nil | |
| 2703 (copy-face 'default 'font-lock-type-face) | |
| 2704 (cond | |
| 2705 ((eq background 'light) | |
| 2706 (set-face-foreground 'font-lock-type-face | |
| 2707 (if (x-color-defined-p "seagreen") | |
| 2708 "seagreen" | |
| 2709 "sea green"))) | |
| 2710 ((eq background 'dark) | |
| 2711 (set-face-foreground 'font-lock-type-face | |
| 2712 (if (x-color-defined-p "os2pink") | |
| 2713 "os2pink" | |
| 2714 "pink"))) | |
| 2715 (t | |
| 2716 (set-face-background 'font-lock-type-face "gray90")))) | |
| 2717 (if (is-face 'font-lock-other-type-face) | |
| 2718 nil | |
| 2719 (copy-face 'font-lock-type-face 'font-lock-other-type-face) | |
| 2720 (cond | |
| 2721 ((eq background 'light) | |
| 2722 (set-face-foreground 'font-lock-other-type-face | |
| 2723 (if (x-color-defined-p "chartreuse3") | |
| 2724 "chartreuse3" | |
| 2725 "chartreuse"))) | |
| 2726 ((eq background 'dark) | |
| 2727 (set-face-foreground 'font-lock-other-type-face | |
| 2728 (if (x-color-defined-p "orchid1") | |
| 2729 "orchid1" | |
| 2730 "orange"))))) | |
| 2731 (if (is-face 'font-lock-other-emphasized-face) nil | |
| 2732 (copy-face 'bold-italic 'font-lock-other-emphasized-face) | |
| 2733 (cond | |
| 2734 ((eq background 'light) | |
| 2735 (set-face-background 'font-lock-other-emphasized-face | |
| 2736 (if (x-color-defined-p "lightyellow2") | |
| 2737 "lightyellow2" | |
| 2738 (if (x-color-defined-p "lightyellow") | |
| 2739 "lightyellow" | |
| 2740 "light yellow")))) | |
| 2741 ((eq background 'dark) | |
| 2742 (set-face-background 'font-lock-other-emphasized-face | |
| 2743 (if (x-color-defined-p "navy") | |
| 2744 "navy" | |
| 2745 (if (x-color-defined-p "darkgreen") | |
| 2746 "darkgreen" | |
| 2747 "dark green")))) | |
| 2748 (t (set-face-background 'font-lock-other-emphasized-face "gray90")))) | |
| 2749 (if (is-face 'font-lock-emphasized-face) nil | |
| 2750 (copy-face 'bold 'font-lock-emphasized-face) | |
| 2751 (cond | |
| 2752 ((eq background 'light) | |
| 2753 (set-face-background 'font-lock-emphasized-face | |
| 2754 (if (x-color-defined-p "lightyellow2") | |
| 2755 "lightyellow2" | |
| 2756 "lightyellow"))) | |
| 2757 ((eq background 'dark) | |
| 2758 (set-face-background 'font-lock-emphasized-face | |
| 2759 (if (x-color-defined-p "navy") | |
| 2760 "navy" | |
| 2761 (if (x-color-defined-p "darkgreen") | |
| 2762 "darkgreen" | |
| 2763 "dark green")))) | |
| 2764 (t (set-face-background 'font-lock-emphasized-face "gray90")))) | |
| 2765 (if (is-face 'font-lock-variable-name-face) nil | |
| 2766 (copy-face 'italic 'font-lock-variable-name-face)) | |
| 2767 (if (is-face 'font-lock-reference-face) nil | |
| 2768 (copy-face 'italic 'font-lock-reference-face)))) | |
| 2769 (setq cperl-faces-init t)) | |
| 2770 (error nil))) | |
| 2771 | |
| 2772 | |
| 2773 (defun cperl-ps-print-init () | |
| 2774 "Initialization of `ps-print' components for faces used in CPerl." | |
| 2775 ;; Guard against old versions | |
| 2776 (defvar ps-underlined-faces nil) | |
| 2777 (defvar ps-bold-faces nil) | |
| 2778 (defvar ps-italic-faces nil) | |
| 2779 (setq ps-bold-faces | |
| 2780 (append '(font-lock-emphasized-face | |
| 2781 font-lock-keyword-face | |
| 2782 font-lock-variable-name-face | |
| 2783 font-lock-reference-face | |
| 2784 font-lock-other-emphasized-face) | |
| 2785 ps-bold-faces)) | |
| 2786 (setq ps-italic-faces | |
| 2787 (append '(font-lock-other-type-face | |
| 2788 font-lock-reference-face | |
| 2789 font-lock-other-emphasized-face) | |
| 2790 ps-italic-faces)) | |
| 2791 (setq ps-underlined-faces | |
| 2792 (append '(font-lock-emphasized-face | |
| 2793 font-lock-other-emphasized-face | |
| 2794 font-lock-other-type-face font-lock-type-face) | |
| 2795 ps-underlined-faces)) | |
| 2796 (cons 'font-lock-type-face ps-underlined-faces)) | |
| 2797 | |
| 2798 | |
| 2799 (if (cperl-enable-font-lock) (cperl-windowed-init)) | |
| 2800 | |
| 2801 (defun cperl-set-style (style) | |
| 2802 "Set CPerl-mode variables to use one of several different indentation styles. | |
| 2803 The arguments are a string representing the desired style. | |
| 2804 Available styles are GNU, K&R, BSD and Whitesmith." | |
| 2805 (interactive | |
| 2806 (let ((list (mapcar (function (lambda (elt) (list (car elt)))) | |
| 2807 c-style-alist))) | |
| 2808 (list (completing-read "Enter style: " list nil 'insist)))) | |
| 2809 (let ((style (cdr (assoc style c-style-alist))) setting str sym) | |
| 2810 (while style | |
| 2811 (setq setting (car style) style (cdr style)) | |
| 2812 (setq str (symbol-name (car setting))) | |
| 2813 (and (string-match "^c-" str) | |
| 2814 (setq str (concat "cperl-" (substring str 2))) | |
| 2815 (setq sym (intern-soft str)) | |
| 2816 (boundp sym) | |
| 2817 (set sym (cdr setting)))))) | |
| 2818 | |
| 2819 (defun cperl-check-syntax () | |
| 2820 (interactive) | |
| 2821 (require 'mode-compile) | |
| 2822 (let ((perl-dbg-flags "-wc")) | |
| 2823 (mode-compile))) | |
| 2824 | |
| 2825 (defun cperl-info-buffer () | |
| 2826 ;; Returns buffer with documentation. Creats if missing | |
| 2827 (let ((info (get-buffer "*info-perl*"))) | |
| 2828 (if info info | |
| 2829 (save-window-excursion | |
| 2830 ;; Get Info running | |
| 2831 (require 'info) | |
| 2832 (save-window-excursion | |
| 2833 (info)) | |
| 2834 (Info-find-node "perl5" "perlfunc") | |
| 2835 (set-buffer "*info*") | |
| 2836 (rename-buffer "*info-perl*") | |
| 2837 (current-buffer))))) | |
| 2838 | |
| 2839 (defun cperl-word-at-point (&optional p) | |
| 2840 ;; Returns the word at point or at P. | |
| 2841 (save-excursion | |
| 2842 (if p (goto-char p)) | |
| 2843 (require 'etags) | |
| 2844 (funcall (or (and (boundp 'find-tag-default-function) | |
| 2845 find-tag-default-function) | |
| 2846 (get major-mode 'find-tag-default-function) | |
| 2847 ;; XEmacs 19.12 has `find-tag-default-hook'; it is | |
| 2848 ;; automatically used within `find-tag-default': | |
| 2849 'find-tag-default)))) | |
| 2850 | |
| 2851 (defun cperl-info-on-command (command) | |
| 2852 "Shows documentation for Perl command in other window." | |
| 2853 (interactive | |
| 2854 (let* ((default (cperl-word-at-point)) | |
| 2855 (read (read-string | |
| 2856 (format "Find doc for Perl function (default %s): " | |
| 2857 default)))) | |
| 2858 (list (if (equal read "") | |
| 2859 default | |
| 2860 read)))) | |
| 2861 | |
| 2862 (let ((buffer (current-buffer)) | |
| 2863 (cmd-desc (concat "^" (regexp-quote command) "[^a-zA-Z_0-9]")) ; "tr///" | |
| 2864 pos) | |
| 2865 (if (string-match "^-[a-zA-Z]$" command) | |
| 2866 (setq cmd-desc "^-X[ \t\n]")) | |
| 2867 (set-buffer (cperl-info-buffer)) | |
| 2868 (beginning-of-buffer) | |
| 2869 (re-search-forward "^-X[ \t\n]") | |
| 2870 (forward-line -1) | |
| 2871 (if (re-search-forward cmd-desc nil t) | |
| 2872 (progn | |
| 2873 (setq pos (progn (beginning-of-line) | |
| 2874 (point))) | |
| 2875 (pop-to-buffer (cperl-info-buffer)) | |
| 2876 (set-window-start (selected-window) pos)) | |
| 2877 (message "No entry for %s found." command)) | |
| 2878 (pop-to-buffer buffer))) | |
| 2879 | |
| 2880 (defun cperl-info-on-current-command () | |
| 2881 "Shows documentation for Perl command at point in other window." | |
| 2882 (interactive) | |
| 2883 (cperl-info-on-command (cperl-word-at-point))) | |
| 2884 | |
| 2885 (defun cperl-imenu-info-imenu-search () | |
| 2886 (if (looking-at "^-X[ \t\n]") nil | |
| 2887 (re-search-backward | |
| 2888 "^\n\\([-a-zA-Z]+\\)[ \t\n]") | |
| 2889 (forward-line 1))) | |
| 2890 | |
| 2891 (defun cperl-imenu-info-imenu-name () | |
| 2892 (buffer-substring | |
| 2893 (match-beginning 1) (match-end 1))) | |
| 2894 | |
| 2895 (defun cperl-imenu-on-info () | |
| 2896 (interactive) | |
| 2897 (let* ((buffer (current-buffer)) | |
| 2898 imenu-create-index-function | |
| 2899 imenu-prev-index-position-function | |
| 2900 imenu-extract-index-name-function | |
| 2901 (index-item (save-restriction | |
| 2902 (save-window-excursion | |
| 2903 (set-buffer (cperl-info-buffer)) | |
| 2904 (setq imenu-create-index-function | |
| 2905 'imenu-default-create-index-function | |
| 2906 imenu-prev-index-position-function | |
| 2907 'cperl-imenu-info-imenu-search | |
| 2908 imenu-extract-index-name-function | |
| 2909 'cperl-imenu-info-imenu-name) | |
| 2910 (imenu-choose-buffer-index))))) | |
| 2911 (and index-item | |
| 2912 (progn | |
| 2913 (push-mark) | |
| 2914 (pop-to-buffer "*info-perl*") | |
| 2915 (cond | |
| 2916 ((markerp (cdr index-item)) | |
| 2917 (goto-char (marker-position (cdr index-item)))) | |
| 2918 (t | |
| 2919 (goto-char (cdr index-item)))) | |
| 2920 (set-window-start (selected-window) (point)) | |
| 2921 (pop-to-buffer buffer))))) | |
| 2922 | |
| 2923 (defun cperl-lineup (beg end &optional step minshift) | |
| 2924 "Lineup construction in a region. | |
| 2925 Beginning of region should be at the start of a construction. | |
| 2926 All first occurences of this construction in the lines that are | |
| 2927 partially contained in the region are lined up at the same column. | |
| 2928 | |
| 2929 MINSHIFT is the minimal amount of space to insert before the construction. | |
| 2930 STEP is the tabwidth to position constructions. | |
| 2931 If STEP is `nil', `cperl-lineup-step' will be used | |
| 2932 \(or `cperl-indent-level', if `cperl-lineup-step' is `nil'). | |
| 2933 Will not move the position at the start to the left." | |
| 2934 (interactive "r") | |
| 2935 (let (search col tcol seen b e) | |
| 2936 (save-excursion | |
| 2937 (goto-char end) | |
| 2938 (end-of-line) | |
| 2939 (setq end (point-marker)) | |
| 2940 (goto-char beg) | |
| 2941 (skip-chars-forward " \t\f") | |
| 2942 (setq beg (point-marker)) | |
| 2943 (indent-region beg end nil) | |
| 2944 (goto-char beg) | |
| 2945 (setq col (current-column)) | |
| 2946 (if (looking-at "\\sw") | |
| 2947 (if (looking-at "\\<\\sw+\\>") | |
| 2948 (setq search | |
| 2949 (concat "\\<" | |
| 2950 (regexp-quote | |
| 2951 (buffer-substring (match-beginning 0) | |
| 2952 (match-end 0))) "\\>")) | |
| 2953 (error "Cannot line up in a middle of the word")) | |
| 2954 (if (looking-at "$") | |
| 2955 (error "Cannot line up end of line")) | |
| 2956 (setq search (regexp-quote (char-to-string (following-char))))) | |
| 2957 (setq step (or step cperl-lineup-step cperl-indent-level)) | |
| 2958 (or minshift (setq minshift 1)) | |
| 2959 (while (progn | |
| 2960 (beginning-of-line 2) | |
| 2961 (and (< (point) end) | |
| 2962 (re-search-forward search end t) | |
| 2963 (goto-char (match-beginning 0)))) | |
| 2964 (setq tcol (current-column) seen t) | |
| 2965 (if (> tcol col) (setq col tcol))) | |
| 2966 (or seen | |
| 2967 (error "The construction to line up occured only once")) | |
| 2968 (goto-char beg) | |
| 2969 (setq col (+ col minshift)) | |
| 2970 (if (/= (% col step) 0) (setq step (* step (1+ (/ col step))))) | |
| 2971 (while | |
| 2972 (progn | |
| 2973 (setq e (point)) | |
| 2974 (skip-chars-backward " \t") | |
| 2975 (delete-region (point) e) | |
| 2976 (indent-to-column col); (make-string (- col (current-column)) ?\ )) | |
| 2977 (beginning-of-line 2) | |
| 2978 (and (< (point) end) | |
| 2979 (re-search-forward search end t) | |
| 2980 (goto-char (match-beginning 0)))))))) ; No body | |
| 2981 | |
| 2982 (defun cperl-etags (&optional add all files) | |
| 2983 "Run etags with appropriate options for Perl files. | |
| 2984 If optional argument ALL is `recursive', will process Perl files | |
| 2985 in subdirectories too." | |
| 2986 (interactive) | |
| 2987 (let ((cmd "etags") | |
| 2988 (args '("-l" "none" "-r" "/\\<\\(package\\|sub\\)[ \\t]+\\(\\([a-zA-Z0-9:_]*::\\)?\\([a-zA-Z0-9_]+\\)[ \\t]*\\([{#]\\|$\\)\\)/\\4/")) | |
| 2989 res) | |
| 2990 (if add (setq args (cons "-a" args))) | |
| 2991 (or files (setq files (list buffer-file-name))) | |
| 2992 (cond | |
| 2993 ((eq all 'recursive) | |
| 2994 ;;(error "Not implemented: recursive") | |
| 2995 (setq args (append (list "-e" | |
| 2996 "sub wanted {push @ARGV, $File::Find::name if /\\.[Pp][Llm]$/} | |
| 2997 use File::Find; | |
| 2998 find(\\&wanted, '.'); | |
| 2999 exec @ARGV;" | |
| 3000 cmd) args) | |
| 3001 cmd "perl")) | |
| 3002 (all | |
| 3003 ;;(error "Not implemented: all") | |
| 3004 (setq args (append (list "-e" | |
| 3005 "push @ARGV, <*.PL *.pl *.pm>; | |
| 3006 exec @ARGV;" | |
| 3007 cmd) args) | |
| 3008 cmd "perl")) | |
| 3009 (t | |
| 3010 (setq args (append args files)))) | |
| 3011 (setq res (apply 'call-process cmd nil nil nil args)) | |
| 3012 (or (eq res 0) | |
| 3013 (message "etags returned \"%s\"" res)))) | |
| 3014 | |
| 3015 (defun cperl-toggle-auto-newline () | |
| 3016 "Toggle the state of `cperl-auto-newline'." | |
| 3017 (interactive) | |
| 3018 (setq cperl-auto-newline (not cperl-auto-newline)) | |
| 3019 (message "Newlines will %sbe auto-inserted now." | |
| 3020 (if cperl-auto-newline "" "not "))) | |
| 3021 | |
| 3022 (defun cperl-toggle-abbrev () | |
| 3023 "Toggle the state of automatic keyword expansion in CPerl mode." | |
| 3024 (interactive) | |
| 3025 (abbrev-mode (if abbrev-mode 0 1)) | |
| 3026 (message "Perl control structure will %sbe auto-inserted now." | |
| 3027 (if abbrev-mode "" "not "))) | |
| 3028 | |
| 3029 | |
| 3030 (defun cperl-toggle-electric () | |
| 3031 "Toggle the state of parentheses doubling in CPerl mode." | |
| 3032 (interactive) | |
| 3033 (setq cperl-electric-parens (if (cperl-val 'cperl-electric-parens) 'null t)) | |
| 3034 (message "Parentheses will %sbe auto-doubled now." | |
| 3035 (if (cperl-val 'cperl-electric-parens) "" "not "))) | |
| 3036 |