1 |
;;; cperl-mode.el --- Perl code editing commands for Emacs |
;;; cperl-mode.el --- Perl code editing commands for Emacs |
2 |
|
|
3 |
;;;; The following message is relative to GNU version of the module: |
;; Copyright (C) 1985, 86, 87, 91, 92, 93, 94, 95, 96, 97, 98, 99, 2000, 2003 |
|
|
|
|
;; Copyright (C) 1985, 86, 87, 1991--2000 |
|
4 |
;; Free Software Foundation, Inc. |
;; Free Software Foundation, Inc. |
5 |
|
|
6 |
;; Author: Ilya Zakharevich and Bob Olson |
;; Author: Ilya Zakharevich and Bob Olson |
7 |
;; Maintainer: Ilya Zakharevich <ilya@math.ohio-state.edu> |
;; Maintainer: Ilya Zakharevich <cperl@ilyaz.org> |
8 |
;; Keywords: languages, Perl |
;; Keywords: languages, Perl |
9 |
|
|
10 |
;; This file is part of GNU Emacs. |
;; This file is part of GNU Emacs. |
39 |
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, |
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, |
40 |
;; Boston, MA 02111-1307, USA. |
;; Boston, MA 02111-1307, USA. |
41 |
|
|
42 |
;;; Corrections made by Ilya Zakharevich ilya@math.mps.ohio-state.edu |
;;; Corrections made by Ilya Zakharevich cperl@ilyaz.org |
43 |
;;; XEmacs changes by Peter Arius arius@informatik.uni-erlangen.de |
;;; XEmacs changes by Peter Arius arius@informatik.uni-erlangen.de |
44 |
|
|
45 |
;;; Commentary: |
;;; Commentary: |
52 |
|
|
53 |
;; (autoload 'perl-mode "cperl-mode" "alternate mode for editing Perl programs" t) |
;; (autoload 'perl-mode "cperl-mode" "alternate mode for editing Perl programs" t) |
54 |
|
|
55 |
;;; You can either fine-tune the bells and whistles of this mode or |
;; You can either fine-tune the bells and whistles of this mode or |
56 |
;;; bulk enable them by putting |
;; bulk enable them by putting |
57 |
|
|
58 |
;; (setq cperl-hairy t) |
;; (setq cperl-hairy t) |
59 |
|
|
60 |
;;; in your .emacs file. (Emacs rulers do not consider it politically |
;; in your .emacs file. (Emacs rulers do not consider it politically |
61 |
;;; correct to make whistles enabled by default.) |
;; correct to make whistles enabled by default.) |
62 |
|
|
63 |
;;; DO NOT FORGET to read micro-docs (available from `Perl' menu) <<<<<< |
;; DO NOT FORGET to read micro-docs (available from `Perl' menu) <<<<<< |
64 |
;;; or as help on variables `cperl-tips', `cperl-problems', <<<<<< |
;; or as help on variables `cperl-tips', `cperl-problems', <<<<<< |
65 |
;;; `cperl-non-problems', `cperl-praise', `cperl-speed'. <<<<<< |
;; `cperl-non-problems', `cperl-praise', `cperl-speed'. <<<<<< |
66 |
|
|
67 |
;;; Additional useful commands to put into your .emacs file (before |
;; Additional useful commands to put into your .emacs file (before |
68 |
;;; RMS Emacs 20.3): |
;; RMS Emacs 20.3): |
69 |
|
|
70 |
;; (setq auto-mode-alist |
;; (setq auto-mode-alist |
71 |
;; (append '(("\\.\\([pP][Llm]\\|al\\)$" . perl-mode)) auto-mode-alist )) |
;; (append '(("\\.\\([pP][Llm]\\|al\\)$" . perl-mode)) auto-mode-alist )) |
72 |
;; (setq interpreter-mode-alist (append interpreter-mode-alist |
;; (setq interpreter-mode-alist (append interpreter-mode-alist |
73 |
;; '(("miniperl" . perl-mode)))) |
;; '(("miniperl" . perl-mode)))) |
74 |
|
|
75 |
;;; The mode information (on C-h m) provides some customization help. |
;; The mode information (on C-h m) provides some customization help. |
76 |
;;; If you use font-lock feature of this mode, it is advisable to use |
;; If you use font-lock feature of this mode, it is advisable to use |
77 |
;;; either lazy-lock-mode or fast-lock-mode. I prefer lazy-lock. |
;; either lazy-lock-mode or fast-lock-mode. I prefer lazy-lock. |
78 |
|
|
79 |
;;; Faces used now: three faces for first-class and second-class keywords |
;; Faces used now: three faces for first-class and second-class keywords |
80 |
;;; and control flow words, one for each: comments, string, labels, |
;; and control flow words, one for each: comments, string, labels, |
81 |
;;; functions definitions and packages, arrays, hashes, and variable |
;; functions definitions and packages, arrays, hashes, and variable |
82 |
;;; definitions. If you do not see all these faces, your font-lock does |
;; definitions. If you do not see all these faces, your font-lock does |
83 |
;;; not define them, so you need to define them manually. Maybe you have |
;; not define them, so you need to define them manually. |
84 |
;;; an obsolete font-lock from 19.28 or earlier. Upgrade. |
;; Maybe you have an obsolete font-lock from 19.28 or earlier. Upgrade. |
85 |
|
|
86 |
;;; If you have a grayscale monitor, and do not have the variable |
;; If you have a grayscale monitor, and do not have the variable |
87 |
;;; font-lock-display-type bound to 'grayscale, insert |
;; font-lock-display-type bound to 'grayscale, insert |
88 |
|
|
89 |
;;; (setq font-lock-display-type 'grayscale) |
;; (setq font-lock-display-type 'grayscale) |
90 |
|
|
91 |
;;; into your .emacs file (this is relevant before RMS Emacs 20). |
;; into your .emacs file (this is relevant before RMS Emacs 20). |
92 |
|
|
93 |
;;;; This mode supports font-lock, imenu and mode-compile. In the |
;; This mode supports font-lock, imenu and mode-compile. In the |
94 |
;;;; hairy version font-lock is on, but you should activate imenu |
;; hairy version font-lock is on, but you should activate imenu |
95 |
;;;; yourself (note that mode-compile is not standard yet). Well, you |
;; yourself (note that mode-compile is not standard yet). Well, you |
96 |
;;;; can use imenu from keyboard anyway (M-x imenu), but it is better |
;; can use imenu from keyboard anyway (M-x imenu), but it is better |
97 |
;;;; to bind it like that: |
;; to bind it like that: |
98 |
|
|
99 |
;; (define-key global-map [M-S-down-mouse-3] 'imenu) |
;; (define-key global-map [M-S-down-mouse-3] 'imenu) |
100 |
|
|
101 |
|
;;; Font lock bugs as of v4.32: |
102 |
|
|
103 |
|
;; The following kinds of Perl code erroneously start strings: |
104 |
|
;; \$` \$' \$" |
105 |
|
;; $opt::s $opt_s $opt{s} (s => ...) /\s+.../ |
106 |
|
;; likewise with m, tr, y, q, qX instead of s |
107 |
|
|
108 |
;;; In fact the version of font-lock that this version supports can be |
;;; In fact the version of font-lock that this version supports can be |
109 |
;;; much newer than the version you actually have. This means that a |
;;; much newer than the version you actually have. This means that a |
110 |
;;; lot of faces can be set up, but are not visible on your screen |
;;; lot of faces can be set up, but are not visible on your screen |
112 |
|
|
113 |
;;; Updates: ======================================== |
;;; Updates: ======================================== |
114 |
|
|
115 |
;;; Made less hairy by default: parentheses not electric, |
;;; Made less hairy by default: parentheses not electric, |
116 |
;;; linefeed not magic. Bug with abbrev-mode corrected. |
;;; linefeed not magic. Bug with abbrev-mode corrected. |
117 |
|
|
118 |
;;;; After 1.4: |
;;;; After 1.4: |
119 |
;;; Better indentation: |
;;; Better indentation: |
120 |
;;; subs inside braces should work now, |
;;; subs inside braces should work now, |
121 |
;;; Toplevel braces obey customization. |
;;; Toplevel braces obey customization. |
122 |
;;; indent-for-comment knows about bad cases, cperl-indent-for-comment |
;;; indent-for-comment knows about bad cases, cperl-indent-for-comment |
123 |
;;; moves cursor to a correct place. |
;;; moves cursor to a correct place. |
124 |
;;; cperl-indent-exp written from the scratch! Slow... (quadratic!) :-( |
;;; cperl-indent-exp written from the scratch! Slow... (quadratic!) :-( |
125 |
;;; (50 secs on DB::DB (sub of 430 lines), 486/66) |
;;; (50 secs on DB::DB (sub of 430 lines), 486/66) |
126 |
;;; Minor documentation fixes. |
;;; Minor documentation fixes. |
127 |
;;; Imenu understands packages as prefixes (including nested). |
;;; Imenu understands packages as prefixes (including nested). |
134 |
;;; `cperl-fill-paragraph' done. |
;;; `cperl-fill-paragraph' done. |
135 |
;;; Better package support for `imenu'. |
;;; Better package support for `imenu'. |
136 |
;;; Progress indicator for indentation (with `imenu' loaded). |
;;; Progress indicator for indentation (with `imenu' loaded). |
137 |
;;; `Cperl-set' was busted, now setting the individual hairy option |
;;; `Cperl-set' was busted, now setting the individual hairy option |
138 |
;;; should be better. |
;;; should be better. |
139 |
|
|
140 |
;;;; After 1.6: |
;;;; After 1.6: |
143 |
;;; Menu done. |
;;; Menu done. |
144 |
;;; New config variables `cperl-close-paren-offset' and `cperl-comment-column'. |
;;; New config variables `cperl-close-paren-offset' and `cperl-comment-column'. |
145 |
;;; Bugs with `cperl-auto-newline' corrected. |
;;; Bugs with `cperl-auto-newline' corrected. |
146 |
;;; `cperl-electric-lbrace' can work with `cperl-auto-newline' in situation |
;;; `cperl-electric-lbrace' can work with `cperl-auto-newline' in situation |
147 |
;;; like $hash{. |
;;; like $hash{. |
148 |
|
|
149 |
;;;; 1.7 XEmacs (arius@informatik.uni-erlangen.de): |
;;;; 1.7 XEmacs (arius@informatik.uni-erlangen.de): |
160 |
;;; Todo (at least): |
;;; Todo (at least): |
161 |
;;; - use emacs-vers.el (http://www.cs.utah.edu/~eeide/emacs/emacs-vers.el.gz) |
;;; - use emacs-vers.el (http://www.cs.utah.edu/~eeide/emacs/emacs-vers.el.gz) |
162 |
;;; for portable code? |
;;; for portable code? |
163 |
;;; - should `cperl-mode' do a |
;;; - should `cperl-mode' do a |
164 |
;;; (if (featurep 'easymenu) (easy-menu-add cperl-menu)) |
;;; (if (featurep 'easymenu) (easy-menu-add cperl-menu)) |
165 |
;;; or should this be left to the user's `cperl-mode-hook'? |
;;; or should this be left to the user's `cperl-mode-hook'? |
166 |
|
|
167 |
;;; Some bugs introduced by the above fix corrected (IZ ;-). |
;;; Some bugs introduced by the above fix corrected (IZ ;-). |
168 |
;;; Some bugs under XEmacs introduced by the correction corrected. |
;;; Some bugs under XEmacs introduced by the correction corrected. |
169 |
|
|
170 |
;;; Some more can remain since there are two many different variants. |
;;; Some more can remain since there are two many different variants. |
171 |
;;; Please feedback! |
;;; Please feedback! |
172 |
|
|
173 |
;;; We do not support fontification of arrays and hashes under |
;;; We do not support fontification of arrays and hashes under |
174 |
;;; obsolete font-lock any more. Upgrade. |
;;; obsolete font-lock any more. Upgrade. |
175 |
|
|
176 |
;;;; after 1.8 Minor bug with parentheses. |
;;;; after 1.8 Minor bug with parentheses. |
196 |
;;; Arglist for auto-fill-mode was incorrect. |
;;; Arglist for auto-fill-mode was incorrect. |
197 |
|
|
198 |
;;;; After 1.12: |
;;;; After 1.12: |
199 |
;;; `cperl-lineup-step' and `cperl-lineup' added: lineup constructions |
;;; `cperl-lineup-step' and `cperl-lineup' added: lineup constructions |
200 |
;;; vertically. |
;;; vertically. |
201 |
;;; `cperl-do-auto-fill' updated for 19.29 style. |
;;; `cperl-do-auto-fill' updated for 19.29 style. |
202 |
;;; `cperl-info-on-command' now has a default. |
;;; `cperl-info-on-command' now has a default. |
236 |
;;; May highlight pods and here-documents: see `cperl-pod-here-scan', |
;;; May highlight pods and here-documents: see `cperl-pod-here-scan', |
237 |
;;; `cperl-pod-here-fontify', `cperl-pod-face'. Does not use this info |
;;; `cperl-pod-here-fontify', `cperl-pod-face'. Does not use this info |
238 |
;;; for indentation so far. |
;;; for indentation so far. |
239 |
;;; Fontification updated to 19.30 style. |
;;; Fontification updated to 19.30 style. |
240 |
;;; The change 19.29->30 did not add all the required functionality, |
;;; The change 19.29->30 did not add all the required functionality, |
241 |
;;; but broke "font-lock-extra.el". Get "choose-color.el" from |
;;; but broke "font-lock-extra.el". Get "choose-color.el" from |
242 |
;;; ftp://ftp.math.ohio-state.edu/pub/users/ilya/emacs |
;;; ftp://ftp.math.ohio-state.edu/pub/users/ilya/emacs |
246 |
;;; recognized as a start of a block. |
;;; recognized as a start of a block. |
247 |
;;; Two different font-lock-levels provided. |
;;; Two different font-lock-levels provided. |
248 |
;;; `cperl-pod-head-face' introduced. Used for highlighting. |
;;; `cperl-pod-head-face' introduced. Used for highlighting. |
249 |
;;; `imenu' marks pods, +Packages moved to the head. |
;;; `imenu' marks pods, +Packages moved to the head. |
250 |
|
|
251 |
;;;; After 1.17: |
;;;; After 1.17: |
252 |
;;; Scan for pods highlights here-docs too. |
;;; Scan for pods highlights here-docs too. |
256 |
;;; POD headers were supposed to fill one line only. |
;;; POD headers were supposed to fill one line only. |
257 |
|
|
258 |
;;;; After 1.18: |
;;;; After 1.18: |
259 |
;;; `font-lock-keywords' were set in 19.30 style _always_. Current scheme |
;;; `font-lock-keywords' were set in 19.30 style _always_. Current scheme |
260 |
;;; may break under XEmacs. |
;;; may break under XEmacs. |
261 |
;;; `cperl-calculate-indent' dis suppose that `parse-start' was defined. |
;;; `cperl-calculate-indent' dis suppose that `parse-start' was defined. |
262 |
;;; `fontified' tag is added to fontified text as well as `lazy-lock' (for |
;;; `fontified' tag is added to fontified text as well as `lazy-lock' (for |
317 |
;;; Minor bugs with POD marking. |
;;; Minor bugs with POD marking. |
318 |
|
|
319 |
;;;; After 1.25 (probably not...) |
;;;; After 1.25 (probably not...) |
320 |
;;; `cperl-info-page' introduced. |
;;; `cperl-info-page' introduced. |
321 |
;;; To make `uncomment-region' working, `comment-region' would |
;;; To make `uncomment-region' working, `comment-region' would |
322 |
;;; not insert extra space. |
;;; not insert extra space. |
323 |
;;; Here documents delimiters better recognized |
;;; Here documents delimiters better recognized |
324 |
;;; (empty one, and non-alphanums in quotes handled). May be wrong with 1<<14? |
;;; (empty one, and non-alphanums in quotes handled). May be wrong with 1<<14? |
325 |
;;; `cperl-db' added, used in menu. |
;;; `cperl-db' added, used in menu. |
326 |
;;; imenu scan removes text-properties, for better debugging |
;;; imenu scan removes text-properties, for better debugging |
385 |
;;; with patched Emaxen), controlled by |
;;; with patched Emaxen), controlled by |
386 |
;;; `cperl-use-syntax-table-text-property'. Currently recognized: |
;;; `cperl-use-syntax-table-text-property'. Currently recognized: |
387 |
;;; All quote-like operators: m, s, y, tr, qq, qw, qx, q, |
;;; All quote-like operators: m, s, y, tr, qq, qw, qx, q, |
388 |
;;; // in most frequent context: |
;;; // in most frequent context: |
389 |
;;; after block or |
;;; after block or |
390 |
;;; ~ { ( = | & + - * ! , ; |
;;; ~ { ( = | & + - * ! , ; |
391 |
;;; or |
;;; or |
392 |
;;; while if unless until and or not xor split grep map |
;;; while if unless until and or not xor split grep map |
393 |
;;; Here-documents, formats, PODs, |
;;; Here-documents, formats, PODs, |
394 |
;;; ${...} |
;;; ${...} |
395 |
;;; 'abc$' |
;;; 'abc$' |
396 |
;;; sub a ($); sub a ($) {} |
;;; sub a ($); sub a ($) {} |
477 |
;;; This handles s# blah # foo #e too; |
;;; This handles s# blah # foo #e too; |
478 |
;;; s//blah/, s///, s/blah// works again, and s#blah## too, the algorithm |
;;; s//blah/, s///, s/blah// works again, and s#blah## too, the algorithm |
479 |
;;; is much simpler now; |
;;; is much simpler now; |
480 |
;;; Next round of changes: s\\\ works, s<blah>/foo/, |
;;; Next round of changes: s\\\ works, s<blah>/foo/, |
481 |
;;; comments between the first and the second part allowed |
;;; comments between the first and the second part allowed |
482 |
;;; Another problem discovered: |
;;; Another problem discovered: |
483 |
;;;;;;; s[foo] <blah>e - e part delimited by different <> (will not match) |
;;;;;;; s[foo] <blah>e - e part delimited by different <> (will not match) |
496 |
;;; `cperl-add-tags-recurse', `cperl-add-tags-recurse-noxs' |
;;; `cperl-add-tags-recurse', `cperl-add-tags-recurse-noxs' |
497 |
;;; added (for -batch mode); |
;;; added (for -batch mode); |
498 |
;;; Better handling of errors when scanning for Perl constructs; |
;;; Better handling of errors when scanning for Perl constructs; |
499 |
;;;;;;; Possible "problem" with class hierarchy in Perl distribution |
;;;;;;; Possible "problem" with class hierarchy in Perl distribution |
500 |
;;;;;;; directory: ./ext duplicates ./lib; |
;;;;;;; directory: ./ext duplicates ./lib; |
501 |
;;; Write relative paths for generated TAGS; |
;;; Write relative paths for generated TAGS; |
502 |
|
|
532 |
;;; `cperl-clobber-lisp-bindings' added. |
;;; `cperl-clobber-lisp-bindings' added. |
533 |
;;; $a->y() is not y///. |
;;; $a->y() is not y///. |
534 |
;;; `cperl-after-block-p' was missing a `save-excursion' => wrong results. |
;;; `cperl-after-block-p' was missing a `save-excursion' => wrong results. |
535 |
;;; `cperl-val' was defined too late. |
;;; `cperl-val' was defined too late. |
536 |
;;; `cperl-init-faces' was failing. |
;;; `cperl-init-faces' was failing. |
537 |
;;; Init faces when loading `ps-print'. |
;;; Init faces when loading `ps-print'. |
538 |
|
|
567 |
;;; `cperl-invert-if-unless' implemented (C-c C-t and in Menu). |
;;; `cperl-invert-if-unless' implemented (C-c C-t and in Menu). |
568 |
;;; Upgraded hints to mention 20.2's goods/bads. |
;;; Upgraded hints to mention 20.2's goods/bads. |
569 |
;;; Started to use `cperl-extra-newline-before-brace-multiline', |
;;; Started to use `cperl-extra-newline-before-brace-multiline', |
570 |
;;; `cperl-break-one-line-blocks-when-indent', |
;;; `cperl-break-one-line-blocks-when-indent', |
571 |
;;; `cperl-fix-hanging-brace-when-indent', `cperl-merge-trailing-else'. |
;;; `cperl-fix-hanging-brace-when-indent', `cperl-merge-trailing-else'. |
572 |
|
|
573 |
;;;; After 2.9: |
;;;; After 2.9: |
576 |
;;; At last, may work with `font-lock' without setting `cperl-font-lock'. |
;;; At last, may work with `font-lock' without setting `cperl-font-lock'. |
577 |
;;; (We expect that starting from 19.33, `font-lock' supports keywords |
;;; (We expect that starting from 19.33, `font-lock' supports keywords |
578 |
;;; being a function - what is a correct version?) |
;;; being a function - what is a correct version?) |
579 |
;;; Rename `cperl-indent-region-fix-else' to |
;;; Rename `cperl-indent-region-fix-else' to |
580 |
;;; `cperl-indent-region-fix-constructs'. |
;;; `cperl-indent-region-fix-constructs'. |
581 |
;;; `cperl-fix-line-spacing' could be triggered inside strings, would not |
;;; `cperl-fix-line-spacing' could be triggered inside strings, would not |
582 |
;;; know what to do with BLOCKs of map/printf/etc. |
;;; know what to do with BLOCKs of map/printf/etc. |
598 |
|
|
599 |
;;;; After 2.12: |
;;;; After 2.12: |
600 |
;;; Remove some commented out chunks. |
;;; Remove some commented out chunks. |
601 |
;;; Styles are slightly updated (a lot of work is needed, especially |
;;; Styles are slightly updated (a lot of work is needed, especially |
602 |
;;; with new `cperl-fix-line-spacing'). |
;;; with new `cperl-fix-line-spacing'). |
603 |
|
|
604 |
;;;; After 2.13: |
;;;; After 2.13: |
605 |
;;; Old value of style is memorized when choosing a new style, may be |
;;; Old value of style is memorized when choosing a new style, may be |
606 |
;;; restored from the same menu. |
;;; restored from the same menu. |
607 |
;;; Mode-documentation added to micro-docs. |
;;; Mode-documentation added to micro-docs. |
608 |
;;; `cperl-praise' updated. |
;;; `cperl-praise' updated. |
651 |
|
|
652 |
;;;; After 3.4: |
;;;; After 3.4: |
653 |
;;; (`cperl-mode'): Make lazy syntaxification possible. |
;;; (`cperl-mode'): Make lazy syntaxification possible. |
654 |
;;; (`cperl-find-pods-heres'): Safe a position in buffer where it is safe to |
;;; (`cperl-find-pods-heres'): Safe a position in buffer where it is safe to |
655 |
;;; restart syntaxification. |
;;; restart syntaxification. |
656 |
;;; (`cperl-syntaxify-by-font-lock'): Set to t, should be safe now. |
;;; (`cperl-syntaxify-by-font-lock'): Set to t, should be safe now. |
657 |
|
|
658 |
;;;; After 3.5: |
;;;; After 3.5: |
659 |
;;; (`cperl-syntaxify-by-font-lock'): Better default, customizes to |
;;; (`cperl-syntaxify-by-font-lock'): Better default, customizes to |
660 |
;;; `message' too. |
;;; `message' too. |
661 |
|
|
662 |
;;;; After 3.6: |
;;;; After 3.6: |
809 |
;;;; After 4.5: |
;;;; After 4.5: |
810 |
;;; (`cperl-init-faces-weak'): use `cperl-force-face'. |
;;; (`cperl-init-faces-weak'): use `cperl-force-face'. |
811 |
;;; (`cperl-after-block-p'): After END/BEGIN we are a block. |
;;; (`cperl-after-block-p'): After END/BEGIN we are a block. |
812 |
;;; (`cperl-mode'): `font-lock-unfontify-region-function' |
;;; (`cperl-mode'): `font-lock-unfontify-region-function' |
813 |
;;; was set to a wrong function. |
;;; was set to a wrong function. |
814 |
;;; (`cperl-comment-indent'): Commenting __END__ was not working. |
;;; (`cperl-comment-indent'): Commenting __END__ was not working. |
815 |
;;; (`cperl-indent-for-comment'): Likewise. |
;;; (`cperl-indent-for-comment'): Likewise. |
818 |
;;;; After 4.5: |
;;;; After 4.5: |
819 |
;;; (`cperl-unwind-to-safe'): Signature changed, unwinds end too. |
;;; (`cperl-unwind-to-safe'): Signature changed, unwinds end too. |
820 |
;;; (`cperl-find-pods-heres'): mark qq[]-etc sections as syntax-type=string |
;;; (`cperl-find-pods-heres'): mark qq[]-etc sections as syntax-type=string |
821 |
;;; (`cperl-fontify-syntaxically'): Unwinds start and end to go out of |
;;; (`cperl-fontify-syntaxically'): Unwinds start and end to go out of |
822 |
;;; long strings (not very successful). |
;;; long strings (not very successful). |
823 |
|
|
824 |
;;; >>>> CPerl should be usable in write mode too now <<<< |
;;; >>>> CPerl should be usable in write mode too now <<<< |
843 |
;;; (`cperl-xemacs-p') defined when compile too |
;;; (`cperl-xemacs-p') defined when compile too |
844 |
;;; (`cperl-tags-hier-init'): Another try to work around XEmacs problems |
;;; (`cperl-tags-hier-init'): Another try to work around XEmacs problems |
845 |
;;; Better progress messages. |
;;; Better progress messages. |
846 |
;;; (`cperl-find-tags'): Was writing line/pos in a wrong order, |
;;; (`cperl-find-tags'): Was writing line/pos in a wrong order, |
847 |
;;; pos off by 1 and not at beg-of-line. |
;;; pos off by 1 and not at beg-of-line. |
848 |
;;; (`cperl-etags-snarf-tag'): New macro |
;;; (`cperl-etags-snarf-tag'): New macro |
849 |
;;; (`cperl-etags-goto-tag-location'): New macro |
;;; (`cperl-etags-goto-tag-location'): New macro |
850 |
;;; (`cperl-write-tags'): When removing old TAGS info was not |
;;; (`cperl-write-tags'): When removing old TAGS info was not |
851 |
;;; relativizing filename |
;;; relativizing filename |
852 |
|
|
853 |
;;;; After 4.9: |
;;;; After 4.9: |
911 |
;;;; After 4.18: |
;;;; After 4.18: |
912 |
;;; (`cperl-find-pods-heres'): / and ? after : start a REx. |
;;; (`cperl-find-pods-heres'): / and ? after : start a REx. |
913 |
;;; (`cperl-after-expr-p'): Skip labels when checking |
;;; (`cperl-after-expr-p'): Skip labels when checking |
914 |
;;; (`cperl-calculate-indent'): Correct for labels when calculating |
;;; (`cperl-calculate-indent'): Correct for labels when calculating |
915 |
;;; indentation of continuations. |
;;; indentation of continuations. |
916 |
;;; Docstring updated. |
;;; Docstring updated. |
917 |
|
|
968 |
;;; C-x C-e the above three lines (at end-of-line). First evaluation |
;;; C-x C-e the above three lines (at end-of-line). First evaluation |
969 |
;;; of `foo' inserts (t), second one inserts (BUG) ?! |
;;; of `foo' inserts (t), second one inserts (BUG) ?! |
970 |
;;; |
;;; |
971 |
;;; In CPerl it was triggered by inserting then deleting `/' at start of |
;;; In CPerl it was triggered by inserting then deleting `/' at start of |
972 |
;;; / a (?# asdf {[(}asdf )ef,/; |
;;; / a (?# asdf {[(}asdf )ef,/; |
973 |
|
|
974 |
;;;; After 4.25: |
;;;; After 4.25: |
1050 |
;;; (`cperl-write-tags'): Use `cperl-unreadable-ok', do not fail |
;;; (`cperl-write-tags'): Use `cperl-unreadable-ok', do not fail |
1051 |
;;; on an unreadable directory |
;;; on an unreadable directory |
1052 |
|
|
1053 |
|
;;;; After 4.32: |
1054 |
|
;;; Syncronized with v1.60 from Emacs 21.3. |
1055 |
|
;;; Mostly docstring and formatting changes, and: |
1056 |
|
|
1057 |
|
;;; (`cperl-noscan-files-regexp'): Do not scan CVS subdirs |
1058 |
|
;;; (`cperl-problems'): Note that newer XEmacsen may syntaxify too |
1059 |
|
;;; (`imenu-example--create-perl-index'): |
1060 |
|
;;; Renamed to `cperl-imenu--create-perl-index' |
1061 |
|
;;; (`cperl-mode'): Replace `make-variable-buffer-local' by `make-local-variable' |
1062 |
|
;;; (`cperl-setup-tmp-buf'): Likewise |
1063 |
|
;;; (`cperl-fix-line-spacing'): Fix a misprint of "t" for "\t" |
1064 |
|
;;; (`cperl-next-bad-style'): Fix misprints in character literals |
1065 |
|
|
1066 |
|
;;;; After 4.33: |
1067 |
|
;;;; (`cperl-font-lock-keywords'): +etc: Aliased to perl-font-lock-keywords. |
1068 |
|
|
1069 |
|
;;;; After 4.34: |
1070 |
|
;;;; Further updates of whitespace and spelling w.r.t. RMS version. |
1071 |
|
;;;; (`cperl-font-lock-keywords'): +etc: Avoid warnings when aliasing. |
1072 |
|
;;;; (`cperl-mode'): Use `normal-auto-fill-function' if present. |
1073 |
|
;;;; (`cperl-use-major-mode'): New variable |
1074 |
|
;;;; (`cperl-can-font-lock'): New variable; replaces `window-system' |
1075 |
|
;;;; (`display-popup-menus-p'): use `display-popup-menus-p' (if present) |
1076 |
|
;;;; to choose `x-popup-menu' vs `tmm-prompt' |
1077 |
|
|
1078 |
;;; Code: |
;;; Code: |
1079 |
|
|
1080 |
|
|
1084 |
(require 'custom) |
(require 'custom) |
1085 |
(error nil)) |
(error nil)) |
1086 |
(defconst cperl-xemacs-p (string-match "XEmacs\\|Lucid" emacs-version)) |
(defconst cperl-xemacs-p (string-match "XEmacs\\|Lucid" emacs-version)) |
1087 |
|
(defvar cperl-can-font-lock |
1088 |
|
(or cperl-xemacs-p |
1089 |
|
(and (boundp 'emacs-major-version) |
1090 |
|
(or window-system |
1091 |
|
(> emacs-major-version 20))))) |
1092 |
|
(if cperl-can-font-lock |
1093 |
|
(require 'font-lock)) |
1094 |
|
(defvar msb-menu-cond) |
1095 |
|
(defvar gud-perldb-history) |
1096 |
|
(defvar font-lock-background-mode) ; not in Emacs |
1097 |
|
(defvar font-lock-display-type) ; ditto |
1098 |
(or (fboundp 'defgroup) |
(or (fboundp 'defgroup) |
1099 |
(defmacro defgroup (name val doc &rest arr) |
(defmacro defgroup (name val doc &rest arr) |
1100 |
nil)) |
nil)) |
1102 |
(defmacro defcustom (name val doc &rest arr) |
(defmacro defcustom (name val doc &rest arr) |
1103 |
(` (defvar (, name) (, val) (, doc))))) |
(` (defvar (, name) (, val) (, doc))))) |
1104 |
(or (and (fboundp 'custom-declare-variable) |
(or (and (fboundp 'custom-declare-variable) |
1105 |
(string< "19.31" emacs-version)) ; Checked with 19.30: defface does not work |
(string< "19.31" emacs-version)) ; Checked with 19.30: defface does not work |
1106 |
(defmacro defface (&rest arr) |
(defmacro defface (&rest arr) |
1107 |
nil)) |
nil)) |
1108 |
;; Avoid warning (tmp definitions) |
;; Avoid warning (tmp definitions) |
1109 |
(or (fboundp 'x-color-defined-p) |
(or (fboundp 'x-color-defined-p) |
1110 |
(defmacro x-color-defined-p (col) |
(defmacro x-color-defined-p (col) |
1111 |
(cond ((fboundp 'color-defined-p) (` (color-defined-p (, col)))) |
(cond ((fboundp 'color-defined-p) (` (color-defined-p (, col)))) |
1115 |
((fboundp 'x-valid-color-name-p) (` (x-valid-color-name-p (, col)))) |
((fboundp 'x-valid-color-name-p) (` (x-valid-color-name-p (, col)))) |
1116 |
(t '(error "Cannot implement color-defined-p"))))) |
(t '(error "Cannot implement color-defined-p"))))) |
1117 |
(defmacro cperl-is-face (arg) ; Takes quoted arg |
(defmacro cperl-is-face (arg) ; Takes quoted arg |
1118 |
(cond ((fboundp 'find-face) |
(cond ((fboundp 'find-face) |
1119 |
(` (find-face (, arg)))) |
(` (find-face (, arg)))) |
1120 |
(;;(and (fboundp 'face-list) |
(;;(and (fboundp 'face-list) |
1121 |
;; (face-list)) |
;; (face-list)) |
1122 |
(fboundp 'face-list) |
(fboundp 'face-list) |
1123 |
(` (member (, arg) (and (fboundp 'face-list) |
(` (member (, arg) (and (fboundp 'face-list) |
1124 |
(face-list))))) |
(face-list))))) |
1125 |
(t |
(t |
1126 |
(` (boundp (, arg)))))) |
(` (boundp (, arg)))))) |
1127 |
(defmacro cperl-make-face (arg descr) ; Takes unquoted arg |
(defmacro cperl-make-face (arg descr) ; Takes unquoted arg |
1128 |
(cond ((fboundp 'make-face) |
(cond ((fboundp 'make-face) |
1129 |
(` (make-face (quote (, arg))))) |
(` (make-face (quote (, arg))))) |
1130 |
(t |
(t |
1131 |
(` (defconst (, arg) (quote (, arg)) (, descr)))))) |
(` (defvar (, arg) (quote (, arg)) (, descr)))))) |
1132 |
(defmacro cperl-force-face (arg descr) ; Takes unquoted arg |
(defmacro cperl-force-face (arg descr) ; Takes unquoted arg |
1133 |
(` (progn |
(` (progn |
1134 |
(or (cperl-is-face (quote (, arg))) |
(or (cperl-is-face (quote (, arg))) |
1135 |
(cperl-make-face (, arg) (, descr))) |
(cperl-make-face (, arg) (, descr))) |
1136 |
(or (boundp (quote (, arg))) ; We use unquoted variants too |
(or (boundp (quote (, arg))) ; We use unquoted variants too |
1137 |
(defconst (, arg) (quote (, arg)) (, descr)))))) |
(defvar (, arg) (quote (, arg)) (, descr)))))) |
1138 |
(if cperl-xemacs-p |
(if cperl-xemacs-p |
1139 |
(defmacro cperl-etags-snarf-tag (file line) |
(defmacro cperl-etags-snarf-tag (file line) |
1140 |
(` (progn |
(` (progn |
1144 |
(` (etags-snarf-tag)))) |
(` (etags-snarf-tag)))) |
1145 |
(if cperl-xemacs-p |
(if cperl-xemacs-p |
1146 |
(defmacro cperl-etags-goto-tag-location (elt) |
(defmacro cperl-etags-goto-tag-location (elt) |
1147 |
(` ;;(progn |
(`;;(progn |
1148 |
;; (switch-to-buffer (get-file-buffer (elt (, elt) 0))) |
;; (switch-to-buffer (get-file-buffer (elt (, elt) 0))) |
1149 |
;; (set-buffer (get-file-buffer (elt (, elt) 0))) |
;; (set-buffer (get-file-buffer (elt (, elt) 0))) |
1150 |
;; Probably will not work due to some save-excursion??? |
;; Probably will not work due to some save-excursion??? |
1151 |
;; Or save-file-position? |
;; Or save-file-position? |
1152 |
;; (message "Did I get to line %s?" (elt (, elt) 1)) |
;; (message "Did I get to line %s?" (elt (, elt) 1)) |
1153 |
(goto-line (string-to-int (elt (, elt) 1))))) |
(goto-line (string-to-int (elt (, elt) 1))))) |
1154 |
;;) |
;;) |
1155 |
(defmacro cperl-etags-goto-tag-location (elt) |
(defmacro cperl-etags-goto-tag-location (elt) |
1156 |
(` (etags-goto-tag-location (, elt))))))) |
(` (etags-goto-tag-location (, elt))))))) |
1157 |
|
|
1158 |
|
(defconst cperl-xemacs-p (string-match "XEmacs\\|Lucid" emacs-version)) |
1159 |
|
|
1160 |
|
(defvar cperl-can-font-lock |
1161 |
|
(or cperl-xemacs-p |
1162 |
|
(and (boundp 'emacs-major-version) |
1163 |
|
(or window-system |
1164 |
|
(> emacs-major-version 20))))) |
1165 |
|
|
1166 |
(condition-case nil |
(condition-case nil |
1167 |
(require 'custom) |
(require 'custom) |
1168 |
(error nil)) ; Already fixed by eval-when-compile |
(error nil)) ; Already fixed by eval-when-compile |
1225 |
instead of: |
instead of: |
1226 |
|
|
1227 |
if () { |
if () { |
1228 |
} |
}" |
|
" |
|
1229 |
:type 'boolean |
:type 'boolean |
1230 |
:group 'cperl-autoinsert-details) |
:group 'cperl-autoinsert-details) |
1231 |
|
|
1232 |
(defcustom cperl-extra-newline-before-brace-multiline |
(defcustom cperl-extra-newline-before-brace-multiline |
1233 |
cperl-extra-newline-before-brace |
cperl-extra-newline-before-brace |
1234 |
"*Non-nil means the same as `cperl-extra-newline-before-brace', but |
"*Non-nil means the same as `cperl-extra-newline-before-brace', but |
1235 |
for constructs with multiline if/unless/while/until/for/foreach condition." |
for constructs with multiline if/unless/while/until/for/foreach condition." |
1243 |
|
|
1244 |
(defcustom cperl-lineup-step nil |
(defcustom cperl-lineup-step nil |
1245 |
"*`cperl-lineup' will always lineup at multiple of this number. |
"*`cperl-lineup' will always lineup at multiple of this number. |
1246 |
If `nil', the value of `cperl-indent-level' will be used." |
If nil, the value of `cperl-indent-level' will be used." |
1247 |
:type '(choice (const nil) integer) |
:type '(choice (const nil) integer) |
1248 |
:group 'cperl-indentation-details) |
:group 'cperl-indentation-details) |
1249 |
|
|
1284 |
"*Non-nil means automatically newline before and after braces, |
"*Non-nil means automatically newline before and after braces, |
1285 |
and after colons and semicolons, inserted in CPerl code. The following |
and after colons and semicolons, inserted in CPerl code. The following |
1286 |
\\[cperl-electric-backspace] will remove the inserted whitespace. |
\\[cperl-electric-backspace] will remove the inserted whitespace. |
1287 |
Insertion after colons requires both this variable and |
Insertion after colons requires both this variable and |
1288 |
`cperl-auto-newline-after-colon' set." |
`cperl-auto-newline-after-colon' set." |
1289 |
:type 'boolean |
:type 'boolean |
1290 |
:group 'cperl-autoinsert-details) |
:group 'cperl-autoinsert-details) |
1308 |
:group 'cperl-indentation-details) |
:group 'cperl-indentation-details) |
1309 |
|
|
1310 |
(defcustom cperl-font-lock nil |
(defcustom cperl-font-lock nil |
1311 |
"*Non-nil (and non-null) means CPerl buffers will use font-lock-mode. |
"*Non-nil (and non-null) means CPerl buffers will use `font-lock-mode'. |
1312 |
Can be overwritten by `cperl-hairy' if nil." |
Can be overwritten by `cperl-hairy' if nil." |
1313 |
:type '(choice (const null) boolean) |
:type '(choice (const null) boolean) |
1314 |
:group 'cperl-affected-by-hairy) |
:group 'cperl-affected-by-hairy) |
1315 |
|
|
1316 |
(defcustom cperl-electric-lbrace-space nil |
(defcustom cperl-electric-lbrace-space nil |
1317 |
"*Non-nil (and non-null) means { after $ in CPerl buffers should be preceded by ` '. |
"*Non-nil (and non-null) means { after $ should be preceded by ` '. |
1318 |
Can be overwritten by `cperl-hairy' if nil." |
Can be overwritten by `cperl-hairy' if nil." |
1319 |
:type '(choice (const null) boolean) |
:type '(choice (const null) boolean) |
1320 |
:group 'cperl-affected-by-hairy) |
:group 'cperl-affected-by-hairy) |
1333 |
|
|
1334 |
(defvar zmacs-regions) ; Avoid warning |
(defvar zmacs-regions) ; Avoid warning |
1335 |
|
|
1336 |
(defcustom cperl-electric-parens-mark |
(defcustom cperl-electric-parens-mark |
1337 |
(and window-system |
(and window-system |
1338 |
(or (and (boundp 'transient-mark-mode) ; For Emacs |
(or (and (boundp 'transient-mark-mode) ; For Emacs |
1339 |
transient-mark-mode) |
transient-mark-mode) |
1359 |
|
|
1360 |
(defcustom cperl-hairy nil |
(defcustom cperl-hairy nil |
1361 |
"*Not-nil means most of the bells and whistles are enabled in CPerl. |
"*Not-nil means most of the bells and whistles are enabled in CPerl. |
1362 |
Affects: `cperl-font-lock', `cperl-electric-lbrace-space', |
Affects: `cperl-font-lock', `cperl-electric-lbrace-space', |
1363 |
`cperl-electric-parens', `cperl-electric-linefeed', `cperl-electric-keywords', |
`cperl-electric-parens', `cperl-electric-linefeed', `cperl-electric-keywords', |
1364 |
`cperl-info-on-command-no-prompt', `cperl-clobber-lisp-bindings', |
`cperl-info-on-command-no-prompt', `cperl-clobber-lisp-bindings', |
1365 |
`cperl-lazy-help-time'." |
`cperl-lazy-help-time'." |
1377 |
:type '(repeat (list symbol string)) |
:type '(repeat (list symbol string)) |
1378 |
:group 'cperl) |
:group 'cperl) |
1379 |
|
|
1380 |
(defcustom cperl-clobber-mode-lists |
(defcustom cperl-clobber-mode-lists |
1381 |
(not |
(not |
1382 |
(and |
(and |
1383 |
(boundp 'interpreter-mode-alist) |
(boundp 'interpreter-mode-alist) |
1408 |
:group 'cperl-affected-by-hairy) |
:group 'cperl-affected-by-hairy) |
1409 |
|
|
1410 |
(defcustom cperl-pod-face 'font-lock-comment-face |
(defcustom cperl-pod-face 'font-lock-comment-face |
1411 |
"*The result of evaluation of this expression is used for pod highlighting." |
"*The result of evaluation of this expression is used for POD highlighting." |
1412 |
:type 'face |
:type 'face |
1413 |
:group 'cperl-faces) |
:group 'cperl-faces) |
1414 |
|
|
1415 |
(defcustom cperl-pod-head-face 'font-lock-variable-name-face |
(defcustom cperl-pod-head-face 'font-lock-variable-name-face |
1416 |
"*The result of evaluation of this expression is used for pod highlighting. |
"*The result of evaluation of this expression is used for POD highlighting. |
1417 |
Font for POD headers." |
Font for POD headers." |
1418 |
:type 'face |
:type 'face |
1419 |
:group 'cperl-faces) |
:group 'cperl-faces) |
1429 |
:group 'cperl-faces) |
:group 'cperl-faces) |
1430 |
|
|
1431 |
(defcustom cperl-pod-here-fontify '(featurep 'font-lock) |
(defcustom cperl-pod-here-fontify '(featurep 'font-lock) |
1432 |
"*Not-nil after evaluation means to highlight pod and here-docs sections." |
"*Not-nil after evaluation means to highlight POD and here-docs sections." |
1433 |
:type 'boolean |
:type 'boolean |
1434 |
:group 'cperl-faces) |
:group 'cperl-faces) |
1435 |
|
|
1439 |
:group 'cperl-faces) |
:group 'cperl-faces) |
1440 |
|
|
1441 |
(defcustom cperl-highlight-variables-indiscriminately nil |
(defcustom cperl-highlight-variables-indiscriminately nil |
1442 |
"*Not-nil means perform additional hightlighting on variables. |
"*Non-nil means perform additional highlighting on variables. |
1443 |
Currently only changes how scalar variables are hightlighted. |
Currently only changes how scalar variables are highlighted. |
1444 |
Note that that variable is only read at initialization time for |
Note that that variable is only read at initialization time for |
1445 |
the variable perl-font-lock-keywords-2, so changing it after you've |
the variable `perl-font-lock-keywords-2', so changing it after you've |
1446 |
entered cperl-mode the first time will have no effect." |
entered CPerl mode the first time will have no effect." |
1447 |
:type 'boolean |
:type 'boolean |
1448 |
:group 'cperl) |
:group 'cperl) |
1449 |
|
|
1450 |
(defcustom cperl-pod-here-scan t |
(defcustom cperl-pod-here-scan t |
1451 |
"*Not-nil means look for pod and here-docs sections during startup. |
"*Not-nil means look for POD and here-docs sections during startup. |
1452 |
You can always make lookup from menu or using \\[cperl-find-pods-heres]." |
You can always make lookup from menu or using \\[cperl-find-pods-heres]." |
1453 |
:type 'boolean |
:type 'boolean |
1454 |
:group 'cperl-speed) |
:group 'cperl-speed) |
1481 |
:type 'string |
:type 'string |
1482 |
:group 'cperl-help-system) |
:group 'cperl-help-system) |
1483 |
|
|
1484 |
(defcustom cperl-use-syntax-table-text-property |
(defcustom cperl-use-syntax-table-text-property |
1485 |
(boundp 'parse-sexp-lookup-properties) |
(boundp 'parse-sexp-lookup-properties) |
1486 |
"*Non-nil means CPerl sets up and uses `syntax-table' text property." |
"*Non-nil means CPerl sets up and uses `syntax-table' text property." |
1487 |
:type 'boolean |
:type 'boolean |
1488 |
:group 'cperl-speed) |
:group 'cperl-speed) |
1489 |
|
|
1490 |
(defcustom cperl-use-syntax-table-text-property-for-tags |
(defcustom cperl-use-syntax-table-text-property-for-tags |
1491 |
cperl-use-syntax-table-text-property |
cperl-use-syntax-table-text-property |
1492 |
"*Non-nil means: set up and use `syntax-table' text property generating TAGS." |
"*Non-nil means: set up and use `syntax-table' text property generating TAGS." |
1493 |
:type 'boolean |
:type 'boolean |
1498 |
:type 'regexp |
:type 'regexp |
1499 |
:group 'cperl) |
:group 'cperl) |
1500 |
|
|
1501 |
(defcustom cperl-noscan-files-regexp "/\\(\\.\\.?\\|SCCS\\|RCS\\|blib\\)$" |
(defcustom cperl-noscan-files-regexp |
1502 |
|
"/\\(\\.\\.?\\|SCCS\\|RCS\\|CVS\\|blib\\)$" |
1503 |
"*Regexp to match files/dirs to skip when generating TAGS." |
"*Regexp to match files/dirs to skip when generating TAGS." |
1504 |
:type 'regexp |
:type 'regexp |
1505 |
:group 'cperl) |
:group 'cperl) |
1506 |
|
|
1507 |
(defcustom cperl-regexp-indent-step nil |
(defcustom cperl-regexp-indent-step nil |
1508 |
"*Indentation used when beautifying regexps. |
"*Indentation used when beautifying regexps. |
1509 |
If `nil', the value of `cperl-indent-level' will be used." |
If nil, the value of `cperl-indent-level' will be used." |
1510 |
:type '(choice integer (const nil)) |
:type '(choice integer (const nil)) |
1511 |
:group 'cperl-indentation-details) |
:group 'cperl-indentation-details) |
1512 |
|
|
1540 |
|
|
1541 |
(defcustom cperl-break-one-line-blocks-when-indent t |
(defcustom cperl-break-one-line-blocks-when-indent t |
1542 |
"*Non-nil means that one-line if/unless/while/until/for/foreach BLOCKs |
"*Non-nil means that one-line if/unless/while/until/for/foreach BLOCKs |
1543 |
need to be reformated into multiline ones when indenting a region." |
need to be reformatted into multiline ones when indenting a region." |
1544 |
:type 'boolean |
:type 'boolean |
1545 |
:group 'cperl-indentation-details) |
:group 'cperl-indentation-details) |
1546 |
|
|
1547 |
(defcustom cperl-fix-hanging-brace-when-indent t |
(defcustom cperl-fix-hanging-brace-when-indent t |
1548 |
"*Non-nil means that BLOCK-end `}' may be put on a separate line |
"*Non-nil means that BLOCK-end `}' may be put on a separate line |
1549 |
when indenting a region. |
when indenting a region. |
1550 |
Braces followed by else/elsif/while/until are excepted." |
Braces followed by else/elsif/while/until are excepted." |
1551 |
:type 'boolean |
:type 'boolean |
1552 |
:group 'cperl-indentation-details) |
:group 'cperl-indentation-details) |
1553 |
|
|
1554 |
(defcustom cperl-merge-trailing-else t |
(defcustom cperl-merge-trailing-else t |
1555 |
"*Non-nil means that BLOCK-end `}' followed by else/elsif/continue |
"*Non-nil means that BLOCK-end `}' followed by else/elsif/continue |
1556 |
may be merged to be on the same line when indenting a region." |
may be merged to be on the same line when indenting a region." |
1557 |
:type 'boolean |
:type 'boolean |
1558 |
:group 'cperl-indentation-details) |
:group 'cperl-indentation-details) |
1564 |
:type 'boolean |
:type 'boolean |
1565 |
:group 'cperl-indentation-details) |
:group 'cperl-indentation-details) |
1566 |
|
|
1567 |
(defcustom cperl-syntaxify-by-font-lock |
(defcustom cperl-syntaxify-by-font-lock |
1568 |
(and window-system |
(and cperl-can-font-lock |
1569 |
(boundp 'parse-sexp-lookup-properties)) |
(boundp 'parse-sexp-lookup-properties)) |
1570 |
"*Non-nil means that CPerl uses `font-lock's routines for syntaxification." |
"*Non-nil means that CPerl uses `font-lock's routines for syntaxification." |
1571 |
:type '(choice (const message) boolean) |
:type '(choice (const message) boolean) |
1573 |
|
|
1574 |
(defcustom cperl-syntaxify-unwind |
(defcustom cperl-syntaxify-unwind |
1575 |
t |
t |
1576 |
"*Non-nil means that CPerl unwinds to a start of along construction |
"*Non-nil means that CPerl unwinds to a start of a long construction |
1577 |
when syntaxifying a chunk of buffer." |
when syntaxifying a chunk of buffer." |
1578 |
:type 'boolean |
:type 'boolean |
1579 |
:group 'cperl-speed) |
:group 'cperl-speed) |
1591 |
(font-lock-type-face nil nil underline) |
(font-lock-type-face nil nil underline) |
1592 |
(underline nil "LightGray" strikeout)) |
(underline nil "LightGray" strikeout)) |
1593 |
"List given as an argument to `ps-extend-face-list' in `cperl-ps-print'." |
"List given as an argument to `ps-extend-face-list' in `cperl-ps-print'." |
1594 |
:type '(repeat (cons symbol |
:type '(repeat (cons symbol |
1595 |
(cons (choice (const nil) string) |
(cons (choice (const nil) string) |
1596 |
(cons (choice (const nil) string) |
(cons (choice (const nil) string) |
1597 |
(repeat symbol))))) |
(repeat symbol))))) |
1598 |
:group 'cperl-faces) |
:group 'cperl-faces) |
1599 |
|
|
1600 |
(if window-system |
(if cperl-can-font-lock |
1601 |
(progn |
(progn |
1602 |
(defvar cperl-dark-background |
(defvar cperl-dark-background |
1603 |
(cperl-choose-color "navy" "os2blue" "darkgreen")) |
(cperl-choose-color "navy" "os2blue" "darkgreen")) |
1604 |
(defvar cperl-dark-foreground |
(defvar cperl-dark-foreground |
1605 |
(cperl-choose-color "orchid1" "orange")) |
(cperl-choose-color "orchid1" "orange")) |
1606 |
|
|
1607 |
(defface cperl-nonoverridable-face |
(defface cperl-nonoverridable-face |
1609 |
(:background "Gray90" :italic t :underline t)) |
(:background "Gray90" :italic t :underline t)) |
1610 |
(((class grayscale) (background dark)) |
(((class grayscale) (background dark)) |
1611 |
(:foreground "Gray80" :italic t :underline t :bold t)) |
(:foreground "Gray80" :italic t :underline t :bold t)) |
1612 |
(((class color) (background light)) |
(((class color) (background light)) |
1613 |
(:foreground "chartreuse3")) |
(:foreground "chartreuse3")) |
1614 |
(((class color) (background dark)) |
(((class color) (background dark)) |
1615 |
(:foreground (, cperl-dark-foreground))) |
(:foreground (, cperl-dark-foreground))) |
1616 |
(t (:bold t :underline t)))) |
(t (:bold t :underline t)))) |
1617 |
"Font Lock mode face used to highlight array names." |
"Font Lock mode face used to highlight array names." |
1622 |
(:background "Gray90" :bold t)) |
(:background "Gray90" :bold t)) |
1623 |
(((class grayscale) (background dark)) |
(((class grayscale) (background dark)) |
1624 |
(:foreground "Gray80" :bold t)) |
(:foreground "Gray80" :bold t)) |
1625 |
(((class color) (background light)) |
(((class color) (background light)) |
1626 |
(:foreground "Blue" :background "lightyellow2" :bold t)) |
(:foreground "Blue" :background "lightyellow2" :bold t)) |
1627 |
(((class color) (background dark)) |
(((class color) (background dark)) |
1628 |
(:foreground "yellow" :background (, cperl-dark-background) :bold t)) |
(:foreground "yellow" :background (, cperl-dark-background) :bold t)) |
1629 |
(t (:bold t)))) |
(t (:bold t)))) |
1630 |
"Font Lock mode face used to highlight array names." |
"Font Lock mode face used to highlight array names." |
1635 |
(:background "Gray90" :bold t :italic t)) |
(:background "Gray90" :bold t :italic t)) |
1636 |
(((class grayscale) (background dark)) |
(((class grayscale) (background dark)) |
1637 |
(:foreground "Gray80" :bold t :italic t)) |
(:foreground "Gray80" :bold t :italic t)) |
1638 |
(((class color) (background light)) |
(((class color) (background light)) |
1639 |
(:foreground "Red" :background "lightyellow2" :bold t :italic t)) |
(:foreground "Red" :background "lightyellow2" :bold t :italic t)) |
1640 |
(((class color) (background dark)) |
(((class color) (background dark)) |
1641 |
(:foreground "Red" :background (, cperl-dark-background) :bold t :italic t)) |
(:foreground "Red" :background (, cperl-dark-background) :bold t :italic t)) |
1642 |
(t (:bold t :italic t)))) |
(t (:bold t :italic t)))) |
1643 |
"Font Lock mode face used to highlight hash names." |
"Font Lock mode face used to highlight hash names." |
1648 |
;;; Short extra-docs. |
;;; Short extra-docs. |
1649 |
|
|
1650 |
(defvar cperl-tips 'please-ignore-this-line |
(defvar cperl-tips 'please-ignore-this-line |
1651 |
"Get newest version of this package from |
"Get maybe newer version of this package from |
1652 |
ftp://ftp.math.ohio-state.edu/pub/users/ilya/emacs |
ftp://ftp.math.ohio-state.edu/pub/users/ilya/emacs |
1653 |
and/or |
and/or |
1654 |
ftp://ftp.math.ohio-state.edu/pub/users/ilya/perl |
ftp://ftp.math.ohio-state.edu/pub/users/ilya/perl |
1659 |
ftp://ftp.math.ohio-state.edu/pub/users/ilya/cperl-mode/patches |
ftp://ftp.math.ohio-state.edu/pub/users/ilya/cperl-mode/patches |
1660 |
\(this upgrades syntax-parsing abilities of RMS Emaxen v19.34 and |
\(this upgrades syntax-parsing abilities of RMS Emaxen v19.34 and |
1661 |
v20.2 up to the level of RMS Emacs v20.3 - a must for a good Perl |
v20.2 up to the level of RMS Emacs v20.3 - a must for a good Perl |
1662 |
mode.) You will not get much from XEmacs, it's syntax abilities are |
mode.) As of beginning of 2003, XEmacs may provide a similar ability. |
|
too primitive. |
|
1663 |
|
|
1664 |
Get support packages choose-color.el (or font-lock-extra.el before |
Get support packages choose-color.el (or font-lock-extra.el before |
1665 |
19.30), imenu-go.el from the same place. \(Look for other files there |
19.30), imenu-go.el from the same place. \(Look for other files there |
1666 |
too... ;-). Get a patch for imenu.el in 19.29. Note that for 19.30 and |
too... ;-). Get a patch for imenu.el in 19.29. Note that for 19.30 and |
1667 |
later you should use choose-color.el *instead* of font-lock-extra.el |
later you should use choose-color.el *instead* of font-lock-extra.el |
1668 |
\(and you will not get smart highlighting in C :-(). |
\(and you will not get smart highlighting in C :-(). |
1669 |
|
|
1670 |
Note that to enable Compile choices in the menu you need to install |
Note that to enable Compile choices in the menu you need to install |
1673 |
If your Emacs does not default to `cperl-mode' on Perl files, and you |
If your Emacs does not default to `cperl-mode' on Perl files, and you |
1674 |
want it to: put the following into your .emacs file: |
want it to: put the following into your .emacs file: |
1675 |
|
|
1676 |
(autoload 'perl-mode \"cperl-mode\" \"alternate mode for editing Perl programs\" t) |
(autoload 'perl-mode \"cperl-mode\" \"alternate mode for editing Perl programs\" t) |
1677 |
|
|
1678 |
Get perl5-info from |
or |
1679 |
|
|
1680 |
|
(defalias 'perl-mode 'cperl-mode) |
1681 |
|
|
1682 |
|
Get perl5-info from |
1683 |
$CPAN/doc/manual/info/perl-info.tar.gz |
$CPAN/doc/manual/info/perl-info.tar.gz |
1684 |
older version was on |
older version was on |
1685 |
http://www.metronet.com:70/9/perlinfo/perl5/manual/perl5-info.tar.gz |
http://www.metronet.com:70/9/perlinfo/perl5/manual/perl5-info.tar.gz |
1689 |
Tools/Tags submenu in Perl menu. |
Tools/Tags submenu in Perl menu. |
1690 |
|
|
1691 |
If some class structure is too complicated, use Tools/Hierarchy-view |
If some class structure is too complicated, use Tools/Hierarchy-view |
1692 |
from Perl menu, or hierarchic view of imenu. The second one uses the |
from Perl menu, or hierarchic view of imenu. The second one uses the |
1693 |
current buffer only, the first one requires generation of TAGS from |
current buffer only, the first one requires generation of TAGS from |
1694 |
Perl/Tools/Tags menu beforehand. |
Perl/Tools/Tags menu beforehand. |
1695 |
|
|
1702 |
|
|
1703 |
M-x norm RET |
M-x norm RET |
1704 |
|
|
1705 |
|
or |
1706 |
|
|
1707 |
|
\\[normal-mode] |
1708 |
|
|
1709 |
In cases of more severe confusion sometimes it is helpful to do |
In cases of more severe confusion sometimes it is helpful to do |
1710 |
|
|
1711 |
M-x load-l RET cperl-mode RET |
M-x load-l RET cperl-mode RET |
1712 |
M-x norm RET |
M-x norm RET |
1713 |
|
|
1714 |
|
or |
1715 |
|
|
1716 |
|
\\[load-library] cperl-mode RET |
1717 |
|
\\[normal-mode] |
1718 |
|
|
1719 |
Before reporting (non-)problems look in the problem section of online |
Before reporting (non-)problems look in the problem section of online |
1720 |
micro-docs on what I know about CPerl problems.") |
micro-docs on what I know about CPerl problems.") |
1721 |
|
|
1722 |
(defvar cperl-problems 'please-ignore-this-line |
(defvar cperl-problems 'please-ignore-this-line |
1723 |
"Some faces will not be shown on some versions of Emacs unless you |
"Description of problems in CPerl mode. |
1724 |
|
Some faces will not be shown on some versions of Emacs unless you |
1725 |
install choose-color.el, available from |
install choose-color.el, available from |
1726 |
ftp://ftp.math.ohio-state.edu/pub/users/ilya/emacs/ |
ftp://ftp.math.ohio-state.edu/pub/users/ilya/emacs/ |
1727 |
|
|
1731 |
|
|
1732 |
Emacs had a _very_ restricted syntax parsing engine until RMS's Emacs |
Emacs had a _very_ restricted syntax parsing engine until RMS's Emacs |
1733 |
20.1. Most problems below are corrected starting from this version of |
20.1. Most problems below are corrected starting from this version of |
1734 |
Emacs, and all of them should go with RMS's version 20.3. (Or apply |
Emacs, and all of them should be fixed in RMS's version 20.3. (Or apply |
1735 |
patches to Emacs 19.33/34 - see tips.) XEmacs is very backward in |
patches to Emacs 19.33/34 - see tips.) XEmacs was very backward in |
1736 |
this respect. |
this respect (until 2003). |
1737 |
|
|
1738 |
Note that even with newer Emacsen in some very rare cases the details |
Note that even with newer Emacsen in some very rare cases the details |
1739 |
of interaction of `font-lock' and syntaxification may be not cleaned |
of interaction of `font-lock' and syntaxification may be not cleaned |
1750 |
|
|
1751 |
This may be confusing, since the regexp s#//#/#\; may be highlighted |
This may be confusing, since the regexp s#//#/#\; may be highlighted |
1752 |
as a comment, but it will be recognized as a regexp by the indentation |
as a comment, but it will be recognized as a regexp by the indentation |
1753 |
code. Or the opposite case, when a pod section is highlighted, but |
code. Or the opposite case, when a POD section is highlighted, but |
1754 |
may break the indentation of the following code (though indentation |
may break the indentation of the following code (though indentation |
1755 |
should work if the balance of delimiters is not broken by POD). |
should work if the balance of delimiters is not broken by POD). |
1756 |
|
|
1757 |
The main trick (to make $ a \"backslash\") makes constructions like |
The main trick (to make $ a \"backslash\") makes constructions like |
1758 |
${aaa} look like unbalanced braces. The only trick I can think of is |
${aaa} look like unbalanced braces. The only trick I can think of is |
1759 |
to insert it as $ {aaa} (legal in perl5, not in perl4). |
to insert it as $ {aaa} (legal in perl5, not in perl4). |
1760 |
|
|
1761 |
Similar problems arise in regexps, when /(\\s|$)/ should be rewritten |
Similar problems arise in regexps, when /(\\s|$)/ should be rewritten |
1762 |
as /($|\\s)/. Note that such a transposition is not always possible. |
as /($|\\s)/. Note that such a transposition is not always possible. |
1768 |
|
|
1769 |
If these bugs cannot be fixed on your machine (say, you have an inferior |
If these bugs cannot be fixed on your machine (say, you have an inferior |
1770 |
environment and cannot recompile), you may still disable all the fancy stuff |
environment and cannot recompile), you may still disable all the fancy stuff |
1771 |
via `cperl-use-syntax-table-text-property'." ) |
via `cperl-use-syntax-table-text-property'.") |
1772 |
|
|
1773 |
(defvar cperl-non-problems 'please-ignore-this-line |
(defvar cperl-non-problems 'please-ignore-this-line |
1774 |
"As you know from `problems' section, Perl syntax is too hard for CPerl on |
"As you know from `problems' section, Perl syntax is too hard for CPerl on |
1827 |
as far as bugs reports I see are concerned.") |
as far as bugs reports I see are concerned.") |
1828 |
|
|
1829 |
(defvar cperl-praise 'please-ignore-this-line |
(defvar cperl-praise 'please-ignore-this-line |
1830 |
"RMS asked me to list good things about CPerl. Here they go: |
"Advantages of CPerl mode. |
1831 |
|
|
1832 |
0) It uses the newest `syntax-table' property ;-); |
0) It uses the newest `syntax-table' property ;-); |
1833 |
|
|
1834 |
1) It does 99% of Perl syntax correct (as opposed to 80-90% in Perl |
1) It does 99% of Perl syntax correct (as opposed to 80-90% in Perl |
1835 |
mode - but the latter number may have improved too in last years) even |
mode - but the latter number may have improved too in last years) even |
1836 |
with old Emaxen which do not support `syntax-table' property. |
with old Emaxen which do not support `syntax-table' property. |
1837 |
|
|
1838 |
When using `syntax-table' property for syntax assist hints, it should |
When using `syntax-table' property for syntax assist hints, it should |
1896 |
not needed anymore with the support for `syntax-table' property. Has |
not needed anymore with the support for `syntax-table' property. Has |
1897 |
progress indicator for indentation (with `imenu' loaded). |
progress indicator for indentation (with `imenu' loaded). |
1898 |
|
|
1899 |
6) Indent-region improves inline-comments as well; also corrects |
6) Indent-region improves inline-comments as well; also corrects |
1900 |
whitespace *inside* the conditional/loop constructs. |
whitespace *inside* the conditional/loop constructs. |
1901 |
|
|
1902 |
7) Fill-paragraph correctly handles multi-line comments; |
7) Fill-paragraph correctly handles multi-line comments; |
1904 |
8) Can switch to different indentation styles by one command, and restore |
8) Can switch to different indentation styles by one command, and restore |
1905 |
the settings present before the switch. |
the settings present before the switch. |
1906 |
|
|
1907 |
9) When doing indentation of control constructs, may correct |
9) When doing indentation of control constructs, may correct |
1908 |
line-breaks/spacing between elements of the construct. |
line-breaks/spacing between elements of the construct. |
1909 |
|
|
1910 |
10) Uses a linear-time algorith for indentation of regions (on Emaxen with |
10) Uses a linear-time algorith for indentation of regions (on Emaxen with |
1911 |
capable syntax engines). |
capable syntax engines).") |
|
") |
|
1912 |
|
|
1913 |
(defvar cperl-speed 'please-ignore-this-line |
(defvar cperl-speed 'please-ignore-this-line |
1914 |
"This is an incomplete compendium of what is available in other parts |
"This is an incomplete compendium of what is available in other parts |
1942 |
`cperl-pod-here-scan' |
`cperl-pod-here-scan' |
1943 |
to nil. |
to nil. |
1944 |
|
|
1945 |
B) Speed of editing operations. |
B) Speed of editing operations. |
1946 |
|
|
1947 |
One can add a (minor) speedup to editing operations by setting |
One can add a (minor) speedup to editing operations by setting |
1948 |
`cperl-use-syntax-table-text-property' |
`cperl-use-syntax-table-text-property' |
1952 |
wrongly matched parentheses, wrong indentation, etc. |
wrongly matched parentheses, wrong indentation, etc. |
1953 |
|
|
1954 |
One can unset `cperl-syntaxify-unwind'. This might speed up editing |
One can unset `cperl-syntaxify-unwind'. This might speed up editing |
1955 |
of, say, long POD sections. |
of, say, long POD sections.") |
|
") |
|
1956 |
|
|
1957 |
(defvar cperl-tips-faces 'please-ignore-this-line |
(defvar cperl-tips-faces 'please-ignore-this-line |
1958 |
"CPerl mode uses following faces for highlighting: |
"CPerl mode uses following faces for highlighting: |
1959 |
|
|
1960 |
cperl-array-face Array names |
`cperl-array-face' Array names |
1961 |
cperl-hash-face Hash names |
`cperl-hash-face' Hash names |
1962 |
font-lock-comment-face Comments, PODs and whatever is considered |
`font-lock-comment-face' Comments, PODs and whatever is considered |
1963 |
syntaxically to be not code |
syntaxically to be not code |
1964 |
font-lock-constant-face HERE-doc delimiters, labels, delimiters of |
`font-lock-constant-face' HERE-doc delimiters, labels, delimiters of |
1965 |
2-arg operators s/y/tr/ or of RExen, |
2-arg operators s/y/tr/ or of RExen, |
1966 |
font-lock-function-name-face Special-cased m// and s//foo/, _ as |
`font-lock-function-name-face' Special-cased m// and s//foo/, _ as |
1967 |
a target of a file tests, file tests, |
a target of a file tests, file tests, |
1968 |
subroutine names at the moment of definition |
subroutine names at the moment of definition |
1969 |
(except those conflicting with Perl operators), |
(except those conflicting with Perl operators), |
1970 |
package names (when recognized), format names |
package names (when recognized), format names |
1971 |
font-lock-keyword-face Control flow switch constructs, declarators |
`font-lock-keyword-face' Control flow switch constructs, declarators |
1972 |
cperl-nonoverridable-face Non-overridable keywords, modifiers of RExen |
`cperl-nonoverridable-face' Non-overridable keywords, modifiers of RExen |
1973 |
font-lock-string-face Strings, qw() constructs, RExen, POD sections, |
`font-lock-string-face' Strings, qw() constructs, RExen, POD sections, |
1974 |
literal parts and the terminator of formats |
literal parts and the terminator of formats |
1975 |
and whatever is syntaxically considered |
and whatever is syntaxically considered |
1976 |
as string literals |
as string literals |
1977 |
font-lock-type-face Overridable keywords |
`font-lock-type-face' Overridable keywords |
1978 |
font-lock-variable-name-face Variable declarations, indirect array and |
`font-lock-variable-name-face' Variable declarations, indirect array and |
1979 |
hash names, POD headers/item names |
hash names, POD headers/item names |
1980 |
cperl-invalid-face Trailing whitespace |
`cperl-invalid-face' Trailing whitespace |
1981 |
|
|
1982 |
Note that in several situations the highlighting tries to inform about |
Note that in several situations the highlighting tries to inform about |
1983 |
possible confusion, such as different colors for function names in |
possible confusion, such as different colors for function names in |
1984 |
declarations depending on what they (do not) override, or special cases |
declarations depending on what they (do not) override, or special cases |
1985 |
m// and s/// which do not do what one would expect them to do. |
m// and s/// which do not do what one would expect them to do. |
1986 |
|
|
1987 |
Help with best setup of these faces for printout requested (for each of |
Help with best setup of these faces for printout requested (for each of |
1988 |
the faces: please specify bold, italic, underline, shadow and box.) |
the faces: please specify bold, italic, underline, shadow and box.) |
1989 |
|
|
1990 |
\(Not finished.)") |
\(Not finished.)") |
1993 |
|
|
1994 |
;;; Portability stuff: |
;;; Portability stuff: |
1995 |
|
|
|
(defconst cperl-xemacs-p (string-match "XEmacs\\|Lucid" emacs-version)) |
|
|
|
|
1996 |
(defmacro cperl-define-key (emacs-key definition &optional xemacs-key) |
(defmacro cperl-define-key (emacs-key definition &optional xemacs-key) |
1997 |
(` (define-key cperl-mode-map |
(` (define-key cperl-mode-map |
1998 |
(, (if xemacs-key |
(, (if xemacs-key |
2003 |
(defvar cperl-del-back-ch |
(defvar cperl-del-back-ch |
2004 |
(car (append (where-is-internal 'delete-backward-char) |
(car (append (where-is-internal 'delete-backward-char) |
2005 |
(where-is-internal 'backward-delete-char-untabify))) |
(where-is-internal 'backward-delete-char-untabify))) |
2006 |
"Character generated by key bound to delete-backward-char.") |
"Character generated by key bound to `delete-backward-char'.") |
2007 |
|
|
2008 |
(and (vectorp cperl-del-back-ch) (= (length cperl-del-back-ch) 1) |
(and (vectorp cperl-del-back-ch) (= (length cperl-del-back-ch) 1) |
2009 |
(setq cperl-del-back-ch (aref cperl-del-back-ch 0))) |
(setq cperl-del-back-ch (aref cperl-del-back-ch 0))) |
2010 |
|
|
2011 |
(defun cperl-mark-active () (mark)) ; Avoid undefined warning |
(defun cperl-mark-active () (mark)) ; Avoid undefined warning |
2020 |
(defun cperl-mark-active () mark-active)) |
(defun cperl-mark-active () mark-active)) |
2021 |
|
|
2022 |
(defsubst cperl-enable-font-lock () |
(defsubst cperl-enable-font-lock () |
2023 |
(or cperl-xemacs-p window-system)) |
cperl-can-font-lock) |
2024 |
|
|
2025 |
(defun cperl-putback-char (c) ; Emacs 19 |
(defun cperl-putback-char (c) ; Emacs 19 |
2026 |
(set 'unread-command-events (list c))) ; Avoid undefined warning |
(set 'unread-command-events (list c))) ; Avoid undefined warning |
2027 |
|
|
2028 |
(if (boundp 'unread-command-events) |
(if (boundp 'unread-command-events) |
2051 |
to cperl-do-not-fontify t))) |
to cperl-do-not-fontify t))) |
2052 |
|
|
2053 |
(defcustom cperl-mode-hook nil |
(defcustom cperl-mode-hook nil |
2054 |
"Hook run by `cperl-mode'." |
"Hook run by CPerl mode." |
2055 |
:type 'hook |
:type 'hook |
2056 |
:group 'cperl) |
:group 'cperl) |
2057 |
|
|
2058 |
(defvar cperl-syntax-state nil) |
(defvar cperl-syntax-state nil) |
2059 |
(defvar cperl-syntax-done-to nil) |
(defvar cperl-syntax-done-to nil) |
2060 |
(defvar cperl-emacs-can-parse (> (length (save-excursion |
(defvar cperl-emacs-can-parse (> (length (save-excursion |
2061 |
(parse-partial-sexp 1 1))) 9)) |
(parse-partial-sexp (point) (point)))) 9)) |
2062 |
|
|
2063 |
;; Make customization possible "in reverse" |
;; Make customization possible "in reverse" |
2064 |
(defsubst cperl-val (symbol &optional default hairy) |
(defsubst cperl-val (symbol &optional default hairy) |
2077 |
'(("miniperl" . perl-mode)))))) |
'(("miniperl" . perl-mode)))))) |
2078 |
(if (fboundp 'eval-when-compile) |
(if (fboundp 'eval-when-compile) |
2079 |
(eval-when-compile |
(eval-when-compile |
2080 |
(condition-case nil |
(mapcar (lambda (p) |
2081 |
(require 'imenu) |
(condition-case nil |
2082 |
(error nil)) |
(require p) |
2083 |
(condition-case nil |
(error nil))) |
2084 |
(require 'easymenu) |
'(imenu easymenu etags timer man info)) |
|
(error nil)) |
|
|
(condition-case nil |
|
|
(require 'etags) |
|
|
(error nil)) |
|
|
(condition-case nil |
|
|
(require 'timer) |
|
|
(error nil)) |
|
|
(condition-case nil |
|
|
(require 'man) |
|
|
(error nil)) |
|
|
(condition-case nil |
|
|
(require 'info) |
|
|
(error nil)) |
|
2085 |
(if (fboundp 'ps-extend-face-list) |
(if (fboundp 'ps-extend-face-list) |
2086 |
(defmacro cperl-ps-extend-face-list (arg) |
(defmacro cperl-ps-extend-face-list (arg) |
2087 |
(` (ps-extend-face-list (, arg)))) |
(` (ps-extend-face-list (, arg)))) |
2088 |
(defmacro cperl-ps-extend-face-list (arg) |
(defmacro cperl-ps-extend-face-list (arg) |
2089 |
(` (error "This version of Emacs has no `ps-extend-face-list'.")))) |
(` (error "This version of Emacs has no `ps-extend-face-list'")))) |
2090 |
;; Calling `cperl-enable-font-lock' below doesn't compile on XEmacs, |
;; Calling `cperl-enable-font-lock' below doesn't compile on XEmacs, |
2091 |
;; macros instead of defsubsts don't work on Emacs, so we do the |
;; macros instead of defsubsts don't work on Emacs, so we do the |
2092 |
;; expansion manually. Any other suggestions? |
;; expansion manually. Any other suggestions? |
2093 |
(if (or (string-match "XEmacs\\|Lucid" emacs-version) |
(if cperl-can-font-lock |
|
window-system) |
|
2094 |
(require 'font-lock)) |
(require 'font-lock)) |
2095 |
(require 'cl))) |
(require 'cl))) |
2096 |
|
|
2097 |
(defvar cperl-mode-abbrev-table nil |
(defvar cperl-mode-abbrev-table nil |
2098 |
"Abbrev table in use in Cperl-mode buffers.") |
"Abbrev table in use in CPerl mode buffers.") |
2099 |
|
|
2100 |
(add-hook 'edit-var-mode-alist '(perl-mode (regexp . "^cperl-"))) |
(add-hook 'edit-var-mode-alist '(perl-mode (regexp . "^cperl-"))) |
2101 |
|
|
2155 |
;;(concat (char-to-string help-char) "v") ; does not work |
;;(concat (char-to-string help-char) "v") ; does not work |
2156 |
'cperl-get-help |
'cperl-get-help |
2157 |
[(control c) (control h) v])) |
[(control c) (control h) v])) |
2158 |
(if (and cperl-xemacs-p |
(if (and cperl-xemacs-p |
2159 |
(<= emacs-minor-version 11) (<= emacs-major-version 19)) |
(<= emacs-minor-version 11) (<= emacs-major-version 19)) |
2160 |
(progn |
(progn |
2161 |
;; substitute-key-definition is usefulness-deenhanced... |
;; substitute-key-definition is usefulness-deenhanced... |
2181 |
(condition-case nil |
(condition-case nil |
2182 |
(progn |
(progn |
2183 |
(require 'easymenu) |
(require 'easymenu) |
2184 |
(easy-menu-define cperl-menu cperl-mode-map "Menu for CPerl mode" |
(easy-menu-define |
2185 |
'("Perl" |
cperl-menu cperl-mode-map "Menu for CPerl mode" |
2186 |
["Beginning of function" beginning-of-defun t] |
'("Perl" |
2187 |
["End of function" end-of-defun t] |
["Beginning of function" beginning-of-defun t] |
2188 |
["Mark function" mark-defun t] |
["End of function" end-of-defun t] |
2189 |
["Indent expression" cperl-indent-exp t] |
["Mark function" mark-defun t] |
2190 |
["Fill paragraph/comment" cperl-fill-paragraph t] |
["Indent expression" cperl-indent-exp t] |
2191 |
"----" |
["Fill paragraph/comment" cperl-fill-paragraph t] |
2192 |
["Line up a construction" cperl-lineup (cperl-use-region-p)] |
"----" |
2193 |
["Invert if/unless/while etc" cperl-invert-if-unless t] |
["Line up a construction" cperl-lineup (cperl-use-region-p)] |
2194 |
("Regexp" |
["Invert if/unless/while etc" cperl-invert-if-unless t] |
2195 |
["Beautify" cperl-beautify-regexp |
("Regexp" |
2196 |
cperl-use-syntax-table-text-property] |
["Beautify" cperl-beautify-regexp |
2197 |
["Beautify one level deep" (cperl-beautify-regexp 1) |
cperl-use-syntax-table-text-property] |
2198 |
cperl-use-syntax-table-text-property] |
["Beautify one level deep" (cperl-beautify-regexp 1) |
2199 |
["Beautify a group" cperl-beautify-level |
cperl-use-syntax-table-text-property] |
2200 |
cperl-use-syntax-table-text-property] |
["Beautify a group" cperl-beautify-level |
2201 |
["Beautify a group one level deep" (cperl-beautify-level 1) |
cperl-use-syntax-table-text-property] |
2202 |
cperl-use-syntax-table-text-property] |
["Beautify a group one level deep" (cperl-beautify-level 1) |
2203 |
["Contract a group" cperl-contract-level |
cperl-use-syntax-table-text-property] |
2204 |
cperl-use-syntax-table-text-property] |
["Contract a group" cperl-contract-level |
2205 |
["Contract groups" cperl-contract-levels |
cperl-use-syntax-table-text-property] |
2206 |
cperl-use-syntax-table-text-property]) |
["Contract groups" cperl-contract-levels |
2207 |
["Refresh \"hard\" constructions" cperl-find-pods-heres t] |
cperl-use-syntax-table-text-property]) |
2208 |
"----" |
["Refresh \"hard\" constructions" cperl-find-pods-heres t] |
2209 |
["Indent region" cperl-indent-region (cperl-use-region-p)] |
"----" |
2210 |
["Comment region" cperl-comment-region (cperl-use-region-p)] |
["Indent region" cperl-indent-region (cperl-use-region-p)] |
2211 |
["Uncomment region" cperl-uncomment-region (cperl-use-region-p)] |
["Comment region" cperl-comment-region (cperl-use-region-p)] |
2212 |
"----" |
["Uncomment region" cperl-uncomment-region (cperl-use-region-p)] |
2213 |
["Run" mode-compile (fboundp 'mode-compile)] |
"----" |
2214 |
["Kill" mode-compile-kill (and (fboundp 'mode-compile-kill) |
["Run" mode-compile (fboundp 'mode-compile)] |
2215 |
(get-buffer "*compilation*"))] |
["Kill" mode-compile-kill (and (fboundp 'mode-compile-kill) |
2216 |
["Next error" next-error (get-buffer "*compilation*")] |
(get-buffer "*compilation*"))] |
2217 |
["Check syntax" cperl-check-syntax (fboundp 'mode-compile)] |
["Next error" next-error (get-buffer "*compilation*")] |
2218 |
"----" |
["Check syntax" cperl-check-syntax (fboundp 'mode-compile)] |
2219 |
["Debugger" cperl-db t] |
"----" |
2220 |
"----" |
["Debugger" cperl-db t] |
2221 |
("Tools" |
"----" |
2222 |
["Imenu" imenu (fboundp 'imenu)] |
("Tools" |
2223 |
["Insert spaces if needed" cperl-find-bad-style t] |
["Imenu" imenu (fboundp 'imenu)] |
2224 |
["Class Hierarchy from TAGS" cperl-tags-hier-init t] |
["Insert spaces if needed" cperl-find-bad-style t] |
2225 |
;;["Update classes" (cperl-tags-hier-init t) tags-table-list] |
["Class Hierarchy from TAGS" cperl-tags-hier-init t] |
2226 |
["CPerl pretty print (exprmntl)" cperl-ps-print |
;;["Update classes" (cperl-tags-hier-init t) tags-table-list] |
2227 |
(fboundp 'ps-extend-face-list)] |
["CPerl pretty print (exprmntl)" cperl-ps-print |
2228 |
["Imenu on info" cperl-imenu-on-info (featurep 'imenu)] |
(fboundp 'ps-extend-face-list)] |
2229 |
("Tags" |
["Imenu on info" cperl-imenu-on-info (featurep 'imenu)] |
2230 |
|
("Tags" |
2231 |
;;; ["Create tags for current file" cperl-etags t] |
;;; ["Create tags for current file" cperl-etags t] |
2232 |
;;; ["Add tags for current file" (cperl-etags t) t] |
;;; ["Add tags for current file" (cperl-etags t) t] |
2233 |
;;; ["Create tags for Perl files in directory" (cperl-etags nil t) t] |
;;; ["Create tags for Perl files in directory" (cperl-etags nil t) t] |
2234 |
;;; ["Add tags for Perl files in directory" (cperl-etags t t) t] |
;;; ["Add tags for Perl files in directory" (cperl-etags t t) t] |
2235 |
;;; ["Create tags for Perl files in (sub)directories" |
;;; ["Create tags for Perl files in (sub)directories" |
2236 |
;;; (cperl-etags nil 'recursive) t] |
;;; (cperl-etags nil 'recursive) t] |
2237 |
;;; ["Add tags for Perl files in (sub)directories" |
;;; ["Add tags for Perl files in (sub)directories" |
2238 |
;;; (cperl-etags t 'recursive) t]) |
;;; (cperl-etags t 'recursive) t]) |
2239 |
;;;; cperl-write-tags (&optional file erase recurse dir inbuffer) |
;;;; cperl-write-tags (&optional file erase recurse dir inbuffer) |
2240 |
["Create tags for current file" (cperl-write-tags nil t) t] |
["Create tags for current file" (cperl-write-tags nil t) t] |
2241 |
["Add tags for current file" (cperl-write-tags) t] |
["Add tags for current file" (cperl-write-tags) t] |
2242 |
["Create tags for Perl files in directory" |
["Create tags for Perl files in directory" |
2243 |
(cperl-write-tags nil t nil t) t] |
(cperl-write-tags nil t nil t) t] |
2244 |
["Add tags for Perl files in directory" |
["Add tags for Perl files in directory" |
2245 |
(cperl-write-tags nil nil nil t) t] |
(cperl-write-tags nil nil nil t) t] |
2246 |
["Create tags for Perl files in (sub)directories" |
["Create tags for Perl files in (sub)directories" |
2247 |
(cperl-write-tags nil t t t) t] |
(cperl-write-tags nil t t t) t] |
2248 |
["Add tags for Perl files in (sub)directories" |
["Add tags for Perl files in (sub)directories" |
2249 |
(cperl-write-tags nil nil t t) t])) |
(cperl-write-tags nil nil t t) t])) |
2250 |
("Perl docs" |
("Perl docs" |
2251 |
["Define word at point" imenu-go-find-at-position |
["Define word at point" imenu-go-find-at-position |
2252 |
(fboundp 'imenu-go-find-at-position)] |
(fboundp 'imenu-go-find-at-position)] |
2253 |
["Help on function" cperl-info-on-command t] |
["Help on function" cperl-info-on-command t] |
2254 |
["Help on function at point" cperl-info-on-current-command t] |
["Help on function at point" cperl-info-on-current-command t] |
2255 |
["Help on symbol at point" cperl-get-help t] |
["Help on symbol at point" cperl-get-help t] |
2256 |
["Perldoc" cperl-perldoc t] |
["Perldoc" cperl-perldoc t] |
2257 |
["Perldoc on word at point" cperl-perldoc-at-point t] |
["Perldoc on word at point" cperl-perldoc-at-point t] |
2258 |
["View manpage of POD in this file" cperl-pod-to-manpage t] |
["View manpage of POD in this file" cperl-pod-to-manpage t] |
2259 |
["Auto-help on" cperl-lazy-install |
["Auto-help on" cperl-lazy-install |
2260 |
(and (fboundp 'run-with-idle-timer) |
(and (fboundp 'run-with-idle-timer) |
2261 |
(not cperl-lazy-installed))] |
(not cperl-lazy-installed))] |
2262 |
["Auto-help off" (eval '(cperl-lazy-unstall)) |
["Auto-help off" (eval '(cperl-lazy-unstall)) |
2263 |
(and (fboundp 'run-with-idle-timer) |
(and (fboundp 'run-with-idle-timer) |
2264 |
cperl-lazy-installed)]) |
cperl-lazy-installed)]) |
2265 |
("Toggle..." |
("Toggle..." |
2266 |
["Auto newline" cperl-toggle-auto-newline t] |
["Auto newline" cperl-toggle-auto-newline t] |
2267 |
["Electric parens" cperl-toggle-electric t] |
["Electric parens" cperl-toggle-electric t] |
2268 |
["Electric keywords" cperl-toggle-abbrev t] |
["Electric keywords" cperl-toggle-abbrev t] |
2269 |
["Fix whitespace on indent" cperl-toggle-construct-fix t] |
["Fix whitespace on indent" cperl-toggle-construct-fix t] |
2270 |
["Auto fill" auto-fill-mode t]) |
["Auto fill" auto-fill-mode t]) |
2271 |
("Indent styles..." |
("Indent styles..." |
2272 |
["CPerl" (cperl-set-style "CPerl") t] |
["CPerl" (cperl-set-style "CPerl") t] |
2273 |
["PerlStyle" (cperl-set-style "PerlStyle") t] |
["PerlStyle" (cperl-set-style "PerlStyle") t] |
2274 |
["GNU" (cperl-set-style "GNU") t] |
["GNU" (cperl-set-style "GNU") t] |
2275 |
["C++" (cperl-set-style "C++") t] |
["C++" (cperl-set-style "C++") t] |
2276 |
["FSF" (cperl-set-style "FSF") t] |
["FSF" (cperl-set-style "FSF") t] |
2277 |
["BSD" (cperl-set-style "BSD") t] |
["BSD" (cperl-set-style "BSD") t] |
2278 |
["Whitesmith" (cperl-set-style "Whitesmith") t] |
["Whitesmith" (cperl-set-style "Whitesmith") t] |
2279 |
["Current" (cperl-set-style "Current") t] |
["Current" (cperl-set-style "Current") t] |
2280 |
["Memorized" (cperl-set-style-back) cperl-old-style]) |
["Memorized" (cperl-set-style-back) cperl-old-style]) |
2281 |
("Micro-docs" |
("Micro-docs" |
2282 |
["Tips" (describe-variable 'cperl-tips) t] |
["Tips" (describe-variable 'cperl-tips) t] |
2283 |
["Problems" (describe-variable 'cperl-problems) t] |
["Problems" (describe-variable 'cperl-problems) t] |
2284 |
["Non-problems" (describe-variable 'cperl-non-problems) t] |
["Non-problems" (describe-variable 'cperl-non-problems) t] |
2285 |
["Speed" (describe-variable 'cperl-speed) t] |
["Speed" (describe-variable 'cperl-speed) t] |
2286 |
["Praise" (describe-variable 'cperl-praise) t] |
["Praise" (describe-variable 'cperl-praise) t] |
2287 |
["Faces" (describe-variable 'cperl-tips-faces) t] |
["Faces" (describe-variable 'cperl-tips-faces) t] |
2288 |
["CPerl mode" (describe-function 'cperl-mode) t] |
["CPerl mode" (describe-function 'cperl-mode) t] |
2289 |
["CPerl version" |
["CPerl version" |
2290 |
(message "The version of master-file for this CPerl is %s" |
(message "The version of master-file for this CPerl is %s" |
2291 |
cperl-version) t])))) |
cperl-version) t])))) |
2292 |
(error nil)) |
(error nil)) |
2293 |
|
|
2294 |
(autoload 'c-macro-expand "cmacexp" |
(autoload 'c-macro-expand "cmacexp" |
2296 |
The expansion is entirely correct because it uses the C preprocessor." |
The expansion is entirely correct because it uses the C preprocessor." |
2297 |
t) |
t) |
2298 |
|
|
2299 |
|
(defvar cperl-imenu--function-name-regexp-perl |
2300 |
|
(concat |
2301 |
|
"^\\(" |
2302 |
|
"[ \t]*\\(sub\\|package\\)[ \t\n]+\\([a-zA-Z_0-9:']+\\)[ \t]*\\(([^()]*)[ \t]*\\)?" |
2303 |
|
"\\|" |
2304 |
|
"=head\\([12]\\)[ \t]+\\([^\n]+\\)$" |
2305 |
|
"\\)")) |
2306 |
|
|
2307 |
|
(defvar cperl-outline-regexp |
2308 |
|
(concat cperl-imenu--function-name-regexp-perl "\\|" "\\`")) |
2309 |
|
|
2310 |
(defvar cperl-mode-syntax-table nil |
(defvar cperl-mode-syntax-table nil |
2311 |
"Syntax table in use in Cperl-mode buffers.") |
"Syntax table in use in CPerl mode buffers.") |
2312 |
|
|
2313 |
(defvar cperl-string-syntax-table nil |
(defvar cperl-string-syntax-table nil |
2314 |
"Syntax table in use in Cperl-mode string-like chunks.") |
"Syntax table in use in CPerl mode string-like chunks.") |
2315 |
|
|
2316 |
(if cperl-mode-syntax-table |
(if cperl-mode-syntax-table |
2317 |
() |
() |
2337 |
(modify-syntax-entry ?| "." cperl-mode-syntax-table) |
(modify-syntax-entry ?| "." cperl-mode-syntax-table) |
2338 |
(setq cperl-string-syntax-table (copy-syntax-table cperl-mode-syntax-table)) |
(setq cperl-string-syntax-table (copy-syntax-table cperl-mode-syntax-table)) |
2339 |
(modify-syntax-entry ?$ "." cperl-string-syntax-table) |
(modify-syntax-entry ?$ "." cperl-string-syntax-table) |
2340 |
(modify-syntax-entry ?# "." cperl-string-syntax-table) ; (?# comment ) |
(modify-syntax-entry ?# "." cperl-string-syntax-table)) ; (?# comment ) |
|
) |
|
2341 |
|
|
2342 |
|
|
2343 |
|
|
2353 |
(defvar perl-font-lock-keywords-1) |
(defvar perl-font-lock-keywords-1) |
2354 |
(defvar perl-font-lock-keywords-2) |
(defvar perl-font-lock-keywords-2) |
2355 |
(defvar outline-level) |
(defvar outline-level) |
2356 |
(defvar cperl-outline-regexp) |
(if (fboundp 'defvaralias) |
2357 |
|
(let ((f 'defvaralias)) ; Some functions deduce stuff from the mode name... |
2358 |
|
(funcall f 'cperl-font-lock-keywords 'perl-font-lock-keywords) |
2359 |
|
(funcall f 'cperl-font-lock-keywords-1 'perl-font-lock-keywords-1) |
2360 |
|
(funcall f 'cperl-font-lock-keywords-2 'perl-font-lock-keywords-2))) |
2361 |
|
|
2362 |
|
(defvar cperl-use-major-mode 'perl-mode) |
2363 |
|
|
2364 |
;;;###autoload |
;;;###autoload |
2365 |
(defun cperl-mode () |
(defun cperl-mode () |
2374 |
well, with optional special formatting done on {}. (Disabled by |
well, with optional special formatting done on {}. (Disabled by |
2375 |
default.) You can always quote (with \\[quoted-insert]) the left |
default.) You can always quote (with \\[quoted-insert]) the left |
2376 |
\"paren\" to avoid the expansion. The processing of < is special, |
\"paren\" to avoid the expansion. The processing of < is special, |
2377 |
since most the time you mean \"less\". Cperl mode tries to guess |
since most the time you mean \"less\". CPerl mode tries to guess |
2378 |
whether you want to type pair <>, and inserts is if it |
whether you want to type pair <>, and inserts is if it |
2379 |
appropriate. You can set `cperl-electric-parens-string' to the string that |
appropriate. You can set `cperl-electric-parens-string' to the string that |
2380 |
contains the parenths from the above list you want to be electrical. |
contains the parenths from the above list you want to be electrical. |
2384 |
|
|
2385 |
CPerl mode provides expansion of the Perl control constructs: |
CPerl mode provides expansion of the Perl control constructs: |
2386 |
|
|
2387 |
if, else, elsif, unless, while, until, continue, do, |
if, else, elsif, unless, while, until, continue, do, |
2388 |
for, foreach, formy and foreachmy. |
for, foreach, formy and foreachmy. |
2389 |
|
|
2390 |
and POD directives (Disabled by default, see `cperl-electric-keywords'.) |
and POD directives (Disabled by default, see `cperl-electric-keywords'.) |
2397 |
type some boolean expression within the parens. Having done that, |
type some boolean expression within the parens. Having done that, |
2398 |
typing \\[cperl-linefeed] places you - appropriately indented - on a |
typing \\[cperl-linefeed] places you - appropriately indented - on a |
2399 |
new line between the braces (if you typed \\[cperl-linefeed] in a POD |
new line between the braces (if you typed \\[cperl-linefeed] in a POD |
2400 |
directive line, then appropriate number of new lines is inserted). |
directive line, then appropriate number of new lines is inserted). |
2401 |
|
|
2402 |
If CPerl decides that you want to insert \"English\" style construct like |
If CPerl decides that you want to insert \"English\" style construct like |
2403 |
|
|
2416 |
|
|
2417 |
and you are on a boundary of a statement inside braces, it will |
and you are on a boundary of a statement inside braces, it will |
2418 |
transform the construct into a multiline and will place you into an |
transform the construct into a multiline and will place you into an |
2419 |
appropriately indented blank line. If you need a usual |
appropriately indented blank line. If you need a usual |
2420 |
`newline-and-indent' behaviour, it is on \\[newline-and-indent], |
`newline-and-indent' behaviour, it is on \\[newline-and-indent], |
2421 |
see documentation on `cperl-electric-linefeed'. |
see documentation on `cperl-electric-linefeed'. |
2422 |
|
|
2423 |
Use \\[cperl-invert-if-unless] to change a construction of the form |
Use \\[cperl-invert-if-unless] to change a construction of the form |
2448 |
\\[cperl-info-on-current-command] and \\[cperl-info-on-command] to access it. |
\\[cperl-info-on-current-command] and \\[cperl-info-on-command] to access it. |
2449 |
These keys run commands `cperl-info-on-current-command' and |
These keys run commands `cperl-info-on-current-command' and |
2450 |
`cperl-info-on-command', which one is which is controlled by variable |
`cperl-info-on-command', which one is which is controlled by variable |
2451 |
`cperl-info-on-command-no-prompt' and `cperl-clobber-lisp-bindings' |
`cperl-info-on-command-no-prompt' and `cperl-clobber-lisp-bindings' |
2452 |
\(in turn affected by `cperl-hairy'). |
\(in turn affected by `cperl-hairy'). |
2453 |
|
|
2454 |
Even if you have no info-format documentation, short one-liner-style |
Even if you have no info-format documentation, short one-liner-style |
2466 |
span the needed amount of lines. |
span the needed amount of lines. |
2467 |
|
|
2468 |
Variables `cperl-pod-here-scan', `cperl-pod-here-fontify', |
Variables `cperl-pod-here-scan', `cperl-pod-here-fontify', |
2469 |
`cperl-pod-face', `cperl-pod-head-face' control processing of pod and |
`cperl-pod-face', `cperl-pod-head-face' control processing of POD and |
2470 |
here-docs sections. With capable Emaxen results of scan are used |
here-docs sections. With capable Emaxen results of scan are used |
2471 |
for indentation too, otherwise they are used for highlighting only. |
for indentation too, otherwise they are used for highlighting only. |
2472 |
|
|
2480 |
Non-nil means automatically newline before and after braces, |
Non-nil means automatically newline before and after braces, |
2481 |
and after colons and semicolons, inserted in Perl code. The following |
and after colons and semicolons, inserted in Perl code. The following |
2482 |
\\[cperl-electric-backspace] will remove the inserted whitespace. |
\\[cperl-electric-backspace] will remove the inserted whitespace. |
2483 |
Insertion after colons requires both this variable and |
Insertion after colons requires both this variable and |
2484 |
`cperl-auto-newline-after-colon' set. |
`cperl-auto-newline-after-colon' set. |
2485 |
`cperl-auto-newline-after-colon' |
`cperl-auto-newline-after-colon' |
2486 |
Non-nil means automatically newline even after colons. |
Non-nil means automatically newline even after colons. |
2487 |
Subject to `cperl-auto-newline' setting. |
Subject to `cperl-auto-newline' setting. |
2517 |
\(both available from menu). |
\(both available from menu). |
2518 |
|
|
2519 |
If `cperl-indent-level' is 0, the statement after opening brace in |
If `cperl-indent-level' is 0, the statement after opening brace in |
2520 |
column 0 is indented on |
column 0 is indented on |
2521 |
`cperl-brace-offset'+`cperl-continued-statement-offset'. |
`cperl-brace-offset'+`cperl-continued-statement-offset'. |
2522 |
|
|
2523 |
Turning on CPerl mode calls the hooks in the variable `cperl-mode-hook' |
Turning on CPerl mode calls the hooks in the variable `cperl-mode-hook' |
2541 |
(cperl-define-key "\C-hf" 'cperl-info-on-current-command [(control h) f]) |
(cperl-define-key "\C-hf" 'cperl-info-on-current-command [(control h) f]) |
2542 |
(cperl-define-key "\C-c\C-hf" 'cperl-info-on-command |
(cperl-define-key "\C-c\C-hf" 'cperl-info-on-command |
2543 |
[(control c) (control h) f]))) |
[(control c) (control h) f]))) |
2544 |
(setq major-mode 'perl-mode) |
(setq major-mode cperl-use-major-mode) |
2545 |
(setq mode-name "CPerl") |
(setq mode-name "CPerl") |
2546 |
(if (not cperl-mode-abbrev-table) |
(if (not cperl-mode-abbrev-table) |
2547 |
(let ((prev-a-c abbrevs-changed)) |
(let ((prev-a-c abbrevs-changed)) |
2604 |
;;(setq auto-fill-function 'cperl-do-auto-fill) ; Need to switch on and off! |
;;(setq auto-fill-function 'cperl-do-auto-fill) ; Need to switch on and off! |
2605 |
(make-local-variable 'imenu-create-index-function) |
(make-local-variable 'imenu-create-index-function) |
2606 |
(setq imenu-create-index-function |
(setq imenu-create-index-function |
2607 |
(function imenu-example--create-perl-index)) |
(function cperl-imenu--create-perl-index)) |
2608 |
(make-local-variable 'imenu-sort-function) |
(make-local-variable 'imenu-sort-function) |
2609 |
(setq imenu-sort-function nil) |
(setq imenu-sort-function nil) |
2610 |
(make-local-variable 'vc-header-alist) |
(make-local-variable 'vc-header-alist) |
2625 |
(make-local-variable 'cperl-syntax-state) |
(make-local-variable 'cperl-syntax-state) |
2626 |
(if cperl-use-syntax-table-text-property |
(if cperl-use-syntax-table-text-property |
2627 |
(progn |
(progn |
2628 |
(make-variable-buffer-local 'parse-sexp-lookup-properties) |
(make-local-variable 'parse-sexp-lookup-properties) |
2629 |
;; Do not introduce variable if not needed, we check it! |
;; Do not introduce variable if not needed, we check it! |
2630 |
(set 'parse-sexp-lookup-properties t) |
(set 'parse-sexp-lookup-properties t) |
2631 |
;; Fix broken font-lock: |
;; Fix broken font-lock: |
2632 |
(or (boundp 'font-lock-unfontify-region-function) |
(or (boundp 'font-lock-unfontify-region-function) |
2633 |
(set 'font-lock-unfontify-region-function |
(set 'font-lock-unfontify-region-function |
2634 |
'font-lock-default-unfontify-region)) |
'font-lock-default-unfontify-region)) |
2635 |
(make-variable-buffer-local 'font-lock-unfontify-region-function) |
(make-local-variable 'font-lock-unfontify-region-function) |
2636 |
(set 'font-lock-unfontify-region-function |
(set 'font-lock-unfontify-region-function ; not present with old Emacs |
2637 |
'cperl-font-lock-unfontify-region-function) |
'cperl-font-lock-unfontify-region-function) |
2638 |
(make-variable-buffer-local 'cperl-syntax-done-to) |
(make-local-variable 'cperl-syntax-done-to) |
2639 |
;; Another bug: unless font-lock-syntactic-keywords, font-lock |
;; Another bug: unless font-lock-syntactic-keywords, font-lock |
2640 |
;; ignores syntax-table text-property. (t) is a hack |
;; ignores syntax-table text-property. (t) is a hack |
2641 |
;; to make font-lock think that font-lock-syntactic-keywords |
;; to make font-lock think that font-lock-syntactic-keywords |
2642 |
;; are defined |
;; are defined |
2643 |
(make-variable-buffer-local 'font-lock-syntactic-keywords) |
(make-local-variable 'font-lock-syntactic-keywords) |
2644 |
(setq font-lock-syntactic-keywords |
(setq font-lock-syntactic-keywords |
2645 |
(if cperl-syntaxify-by-font-lock |
(if cperl-syntaxify-by-font-lock |
2646 |
'(t (cperl-fontify-syntaxically)) |
'(t (cperl-fontify-syntaxically)) |
2647 |
'(t))))) |
'(t))))) |
2648 |
(make-local-variable 'cperl-old-style) |
(make-local-variable 'cperl-old-style) |
2649 |
(or (fboundp 'cperl-old-auto-fill-mode) |
(if (boundp 'normal-auto-fill-function) ; 19.33 and later |
2650 |
(progn |
(set (make-local-variable 'normal-auto-fill-function) |
2651 |
(fset 'cperl-old-auto-fill-mode (symbol-function 'auto-fill-mode)) |
'cperl-do-auto-fill) ; RMS has it as #'cperl-do-auto-fill ??? |
2652 |
(defun auto-fill-mode (&optional arg) |
(or (fboundp 'cperl-old-auto-fill-mode) |
2653 |
(interactive "P") |
(progn |
2654 |
(eval '(cperl-old-auto-fill-mode arg)) ; Avoid a warning |
(fset 'cperl-old-auto-fill-mode (symbol-function 'auto-fill-mode)) |
2655 |
(and auto-fill-function (eq major-mode 'perl-mode) |
(defun auto-fill-mode (&optional arg) |
2656 |
(setq auto-fill-function 'cperl-do-auto-fill))))) |
(interactive "P") |
2657 |
|
(eval '(cperl-old-auto-fill-mode arg)) ; Avoid a warning |
2658 |
|
(and auto-fill-function (memq major-mode '(perl-mode cperl-mode)) |
2659 |
|
(setq auto-fill-function 'cperl-do-auto-fill)))))) |
2660 |
(if (cperl-enable-font-lock) |
(if (cperl-enable-font-lock) |
2661 |
(if (cperl-val 'cperl-font-lock) |
(if (cperl-val 'cperl-font-lock) |
2662 |
(progn (or cperl-faces-init (cperl-init-faces)) |
(progn (or cperl-faces-init (cperl-init-faces)) |
2663 |
(font-lock-mode 1)))) |
(font-lock-mode 1)))) |
2664 |
(and (boundp 'msb-menu-cond) |
(and (boundp 'msb-menu-cond) |
2668 |
(easy-menu-add cperl-menu)) ; A NOP in RMS Emacs. |
(easy-menu-add cperl-menu)) ; A NOP in RMS Emacs. |
2669 |
(run-hooks 'cperl-mode-hook) |
(run-hooks 'cperl-mode-hook) |
2670 |
;; After hooks since fontification will break this |
;; After hooks since fontification will break this |
2671 |
(if cperl-pod-here-scan |
(if cperl-pod-here-scan |
2672 |
(or ;;(and (boundp 'font-lock-mode) |
(or cperl-syntaxify-by-font-lock |
|
;; (eval 'font-lock-mode) ; Avoid warning |
|
|
;; (boundp 'font-lock-hot-pass) ; Newer font-lock |
|
|
cperl-syntaxify-by-font-lock ;;) |
|
2673 |
(progn (or cperl-faces-init (cperl-init-faces-weak)) |
(progn (or cperl-faces-init (cperl-init-faces-weak)) |
2674 |
(cperl-find-pods-heres))))) |
(cperl-find-pods-heres))))) |
2675 |
|
|
2676 |
;; Fix for perldb - make default reasonable |
;; Fix for perldb - make default reasonable |
|
(defvar gud-perldb-history) |
|
2677 |
(defun cperl-db () |
(defun cperl-db () |
2678 |
(interactive) |
(interactive) |
2679 |
(require 'gud) |
(require 'gud) |
2681 |
(if (consp gud-perldb-history) |
(if (consp gud-perldb-history) |
2682 |
(car gud-perldb-history) |
(car gud-perldb-history) |
2683 |
(concat "perl " ;;(file-name-nondirectory |
(concat "perl " ;;(file-name-nondirectory |
2684 |
;; I have problems |
;; I have problems |
2685 |
;; in OS/2 |
;; in OS/2 |
2686 |
;; otherwise |
;; otherwise |
2687 |
(buffer-file-name))) |
(buffer-file-name))) |
2688 |
nil nil |
nil nil |
2689 |
'(gud-perldb-history . 1)))) |
'(gud-perldb-history . 1)))) |
2690 |
|
|
|
(defvar msb-menu-cond) |
|
2691 |
(defun cperl-msb-fix () |
(defun cperl-msb-fix () |
2692 |
;; Adds perl files to msb menu, supposes that msb is already loaded |
;; Adds perl files to msb menu, supposes that msb is already loaded |
2693 |
(setq cperl-msb-fixed t) |
(setq cperl-msb-fixed t) |
2697 |
(handle (1- (nth 1 last)))) |
(handle (1- (nth 1 last)))) |
2698 |
(setcdr precdr (list |
(setcdr precdr (list |
2699 |
(list |
(list |
2700 |
'(eq major-mode 'perl-mode) |
'(memq major-mode '(cperl-mode perl-mode)) |
2701 |
handle |
handle |
2702 |
"Perl Files (%d)") |
"Perl Files (%d)") |
2703 |
last)))) |
last)))) |
2747 |
;;; (let ((c (current-column)) target cnt prevc) |
;;; (let ((c (current-column)) target cnt prevc) |
2748 |
;;; (if (= c comment-column) nil |
;;; (if (= c comment-column) nil |
2749 |
;;; (setq cnt (skip-chars-backward "[ \t]")) |
;;; (setq cnt (skip-chars-backward "[ \t]")) |
2750 |
;;; (setq target (max (1+ (setq prevc |
;;; (setq target (max (1+ (setq prevc |
2751 |
;;; (current-column))) ; Else indent at comment column |
;;; (current-column))) ; Else indent at comment column |
2752 |
;;; comment-column)) |
;;; comment-column)) |
2753 |
;;; (if (= c comment-column) nil |
;;; (if (= c comment-column) nil |
2789 |
"Insert character and correct line's indentation. |
"Insert character and correct line's indentation. |
2790 |
If ONLY-BEFORE and `cperl-auto-newline', will insert newline before the |
If ONLY-BEFORE and `cperl-auto-newline', will insert newline before the |
2791 |
place (even in empty line), but not after. If after \")\" and the inserted |
place (even in empty line), but not after. If after \")\" and the inserted |
2792 |
char is \"{\", insert extra newline before only if |
char is \"{\", insert extra newline before only if |
2793 |
`cperl-extra-newline-before-brace'." |
`cperl-extra-newline-before-brace'." |
2794 |
(interactive "P") |
(interactive "P") |
2795 |
(let (insertpos |
(let (insertpos |
2796 |
(other-end (if (and cperl-electric-parens-mark |
(other-end (if (and cperl-electric-parens-mark |
2797 |
(cperl-mark-active) |
(cperl-mark-active) |
2798 |
(< (mark) (point))) |
(< (mark) (point))) |
2799 |
(mark) |
(mark) |
2800 |
nil))) |
nil))) |
2801 |
(if (and other-end |
(if (and other-end |
2802 |
(not cperl-brace-recursing) |
(not cperl-brace-recursing) |
2810 |
(setq last-command-char ?\{) |
(setq last-command-char ?\{) |
2811 |
(cperl-electric-lbrace arg insertpos)) |
(cperl-electric-lbrace arg insertpos)) |
2812 |
(forward-char 1)) |
(forward-char 1)) |
2813 |
;: Check whether we close something "usual" with `}' |
;; Check whether we close something "usual" with `}' |
2814 |
(if (and (eq last-command-char ?\}) |
(if (and (eq last-command-char ?\}) |
2815 |
(not |
(not |
2816 |
(condition-case nil |
(condition-case nil |
2817 |
(save-excursion |
(save-excursion |
2818 |
(up-list (- (prefix-numeric-value arg))) |
(up-list (- (prefix-numeric-value arg))) |
2834 |
(save-excursion |
(save-excursion |
2835 |
(skip-chars-backward " \t") |
(skip-chars-backward " \t") |
2836 |
(eq (preceding-char) ?\)))) |
(eq (preceding-char) ?\)))) |
2837 |
(if cperl-auto-newline |
(if cperl-auto-newline |
2838 |
(progn (cperl-indent-line) (newline) t) nil))) |
(progn (cperl-indent-line) (newline) t) nil))) |
2839 |
(progn |
(progn |
2840 |
(self-insert-command (prefix-numeric-value arg)) |
(self-insert-command (prefix-numeric-value arg)) |
2847 |
(cperl-indent-line))) |
(cperl-indent-line))) |
2848 |
(save-excursion |
(save-excursion |
2849 |
(if insertpos (progn (goto-char insertpos) |
(if insertpos (progn (goto-char insertpos) |
2850 |
(search-forward (make-string |
(search-forward (make-string |
2851 |
1 last-command-char)) |
1 last-command-char)) |
2852 |
(setq insertpos (1- (point))))) |
(setq insertpos (1- (point))))) |
2853 |
(delete-char -1)))) |
(delete-char -1)))) |
2860 |
(defun cperl-electric-lbrace (arg &optional end) |
(defun cperl-electric-lbrace (arg &optional end) |
2861 |
"Insert character, correct line's indentation, correct quoting by space." |
"Insert character, correct line's indentation, correct quoting by space." |
2862 |
(interactive "P") |
(interactive "P") |
2863 |
(let (pos after |
(let ((cperl-brace-recursing t) |
2864 |
(cperl-brace-recursing t) |
(cperl-auto-newline cperl-auto-newline) |
2865 |
(cperl-auto-newline cperl-auto-newline) |
(other-end (or end |
2866 |
(other-end (or end |
(if (and cperl-electric-parens-mark |
2867 |
(if (and cperl-electric-parens-mark |
(cperl-mark-active) |
2868 |
(cperl-mark-active) |
(> (mark) (point))) |
2869 |
(> (mark) (point))) |
(save-excursion |
2870 |
(save-excursion |
(goto-char (mark)) |
2871 |
(goto-char (mark)) |
(point-marker)) |
2872 |
(point-marker)) |
nil))) |
2873 |
nil)))) |
pos after) |
2874 |
(and (cperl-val 'cperl-electric-lbrace-space) |
(and (cperl-val 'cperl-electric-lbrace-space) |
2875 |
(eq (preceding-char) ?$) |
(eq (preceding-char) ?$) |
2876 |
(save-excursion |
(save-excursion |
2878 |
(looking-at "\\(\\$\\$\\)*\\$\\([^\\$]\\|$\\)")) |
(looking-at "\\(\\$\\$\\)*\\$\\([^\\$]\\|$\\)")) |
2879 |
(insert ?\ )) |
(insert ?\ )) |
2880 |
;; Check whether we are in comment |
;; Check whether we are in comment |
2881 |
(if (and |
(if (and |
2882 |
(save-excursion |
(save-excursion |
2883 |
(beginning-of-line) |
(beginning-of-line) |
2884 |
(not (looking-at "[ \t]*#"))) |
(not (looking-at "[ \t]*#"))) |
2888 |
(cperl-electric-brace arg) |
(cperl-electric-brace arg) |
2889 |
(and (cperl-val 'cperl-electric-parens) |
(and (cperl-val 'cperl-electric-parens) |
2890 |
(eq last-command-char ?{) |
(eq last-command-char ?{) |
2891 |
(memq last-command-char |
(memq last-command-char |
2892 |
(append cperl-electric-parens-string nil)) |
(append cperl-electric-parens-string nil)) |
2893 |
(or (if other-end (goto-char (marker-position other-end))) |
(or (if other-end (goto-char (marker-position other-end))) |
2894 |
t) |
t) |
2901 |
(interactive "P") |
(interactive "P") |
2902 |
(let ((beg (save-excursion (beginning-of-line) (point))) |
(let ((beg (save-excursion (beginning-of-line) (point))) |
2903 |
(other-end (if (and cperl-electric-parens-mark |
(other-end (if (and cperl-electric-parens-mark |
2904 |
(cperl-mark-active) |
(cperl-mark-active) |
2905 |
(> (mark) (point))) |
(> (mark) (point))) |
2906 |
(save-excursion |
(save-excursion |
2907 |
(goto-char (mark)) |
(goto-char (mark)) |
2908 |
(point-marker)) |
(point-marker)) |
2909 |
nil))) |
nil))) |
2910 |
(if (and (cperl-val 'cperl-electric-parens) |
(if (and (cperl-val 'cperl-electric-parens) |
2911 |
(memq last-command-char |
(memq last-command-char |
2921 |
(progn |
(progn |
2922 |
(self-insert-command (prefix-numeric-value arg)) |
(self-insert-command (prefix-numeric-value arg)) |
2923 |
(if other-end (goto-char (marker-position other-end))) |
(if other-end (goto-char (marker-position other-end))) |
2924 |
(insert (make-string |
(insert (make-string |
2925 |
(prefix-numeric-value arg) |
(prefix-numeric-value arg) |
2926 |
(cdr (assoc last-command-char '((?{ .?}) |
(cdr (assoc last-command-char '((?{ .?}) |
2927 |
(?[ . ?]) |
(?[ . ?]) |
2939 |
(cperl-val 'cperl-electric-parens) |
(cperl-val 'cperl-electric-parens) |
2940 |
(memq last-command-char |
(memq last-command-char |
2941 |
(append cperl-electric-parens-string nil)) |
(append cperl-electric-parens-string nil)) |
2942 |
(cperl-mark-active) |
(cperl-mark-active) |
2943 |
(< (mark) (point))) |
(< (mark) (point))) |
2944 |
(mark) |
(mark) |
2945 |
nil)) |
nil)) |
2946 |
p) |
p) |
2947 |
(if (and other-end |
(if (and other-end |
2957 |
(insert (make-string |
(insert (make-string |
2958 |
(prefix-numeric-value arg) |
(prefix-numeric-value arg) |
2959 |
(cdr (assoc last-command-char '((?\} . ?\{) |
(cdr (assoc last-command-char '((?\} . ?\{) |
2960 |
(?\] . ?\[) |
(?\] . ?\[) |
2961 |
(?\) . ?\() |
(?\) . ?\() |
2962 |
(?\> . ?\<)))))) |
(?\> . ?\<)))))) |
2963 |
(goto-char (1+ p))) |
(goto-char (1+ p))) |
2964 |
(self-insert-command (prefix-numeric-value arg))))) |
(self-insert-command (prefix-numeric-value arg))))) |
2965 |
|
|
2967 |
"Insert a construction appropriate after a keyword. |
"Insert a construction appropriate after a keyword. |
2968 |
Help message may be switched off by setting `cperl-message-electric-keyword' |
Help message may be switched off by setting `cperl-message-electric-keyword' |
2969 |
to nil." |
to nil." |
2970 |
(let ((beg (save-excursion (beginning-of-line) (point))) |
(let ((beg (save-excursion (beginning-of-line) (point))) |
2971 |
(dollar (and (eq last-command-char ?$) |
(dollar (and (eq last-command-char ?$) |
2972 |
(eq this-command 'self-insert-command))) |
(eq this-command 'self-insert-command))) |
2973 |
(delete (and (memq last-command-char '(?\ ?\n ?\t ?\f)) |
(delete (and (memq last-command-char '(?\ ?\n ?\t ?\f)) |
2980 |
(setq do (looking-at "do\\>"))) |
(setq do (looking-at "do\\>"))) |
2981 |
(error nil)) |
(error nil)) |
2982 |
(cperl-after-expr-p nil "{;:")) |
(cperl-after-expr-p nil "{;:")) |
2983 |
(save-excursion |
(save-excursion |
2984 |
(not |
(not |
2985 |
(re-search-backward |
(re-search-backward |
2986 |
"[#\"'`]\\|\\<q\\(\\|[wqxr]\\)\\>" |
"[#\"'`]\\|\\<q\\(\\|[wqxr]\\)\\>" |
2987 |
beg t))) |
beg t))) |
2998 |
(forward-char -2) |
(forward-char -2) |
2999 |
(insert " ") |
(insert " ") |
3000 |
(forward-char 2) |
(forward-char 2) |
3001 |
(setq my t dollar t |
(setq my t dollar t |
3002 |
delete |
delete |
3003 |
(memq this-command '(self-insert-command newline))))) |
(memq this-command '(self-insert-command newline))))) |
3004 |
(and dollar (insert " $")) |
(and dollar (insert " $")) |
3005 |
(cperl-indent-line) |
(cperl-indent-line) |
3014 |
(insert "\n}") |
(insert "\n}") |
3015 |
(and do (insert " while ();"))) |
(and do (insert " while ();"))) |
3016 |
(t |
(t |
3017 |
(insert (if do " {\n} while ();" " () {\n}"))) |
(insert (if do " {\n} while ();" " () {\n}")))) |
|
) |
|
3018 |
(or (looking-at "[ \t]\\|$") (insert " ")) |
(or (looking-at "[ \t]\\|$") (insert " ")) |
3019 |
(cperl-indent-line) |
(cperl-indent-line) |
3020 |
(if dollar (progn (search-backward "$") |
(if dollar (progn (search-backward "$") |
3021 |
(if my |
(if my |
3022 |
(forward-char 1) |
(forward-char 1) |
3023 |
(delete-char 1))) |
(delete-char 1))) |
3024 |
(search-backward ")")) |
(search-backward ")")) |
3044 |
head1 notlast name p really-delete over) |
head1 notlast name p really-delete over) |
3045 |
(and (save-excursion |
(and (save-excursion |
3046 |
(forward-word -1) |
(forward-word -1) |
3047 |
(and |
(and |
3048 |
(eq (preceding-char) ?=) |
(eq (preceding-char) ?=) |
3049 |
(progn |
(progn |
3050 |
(setq head1 (looking-at "head1\\>[ \t]*$")) |
(setq head1 (looking-at "head1\\>[ \t]*$")) |
3052 |
(not (looking-at "over[ \t]*\n\n\n*=item\\>")))) |
(not (looking-at "over[ \t]*\n\n\n*=item\\>")))) |
3053 |
(forward-char -1) |
(forward-char -1) |
3054 |
(bolp)) |
(bolp)) |
3055 |
(or |
(or |
3056 |
(get-text-property (point) 'in-pod) |
(get-text-property (point) 'in-pod) |
3057 |
(cperl-after-expr-p nil "{;:") |
(cperl-after-expr-p nil "{;:") |
3058 |
(and (re-search-backward |
(and (re-search-backward |
3059 |
;; "\\(\\`\n?\\|\n\n\\)=\\sw+" |
;; "\\(\\`\n?\\|\n\n\\)=\\sw+" |
3060 |
"\\(\\`\n?\\|^\n\\)=\\sw+" |
"\\(\\`\n?\\|^\n\\)=\\sw+" |
3061 |
(point-min) t) |
(point-min) t) |
3062 |
(not (or |
(not (or |
3063 |
(looking-at "=cut") |
(looking-at "=cut") |
3072 |
(insert "\n\n=cut") |
(insert "\n\n=cut") |
3073 |
(cperl-ensure-newlines 2) |
(cperl-ensure-newlines 2) |
3074 |
(forward-word -2) |
(forward-word -2) |
3075 |
(if (and head1 |
(if (and head1 |
3076 |
(not |
(not |
3077 |
(save-excursion |
(save-excursion |
3078 |
(forward-char -1) |
(forward-char -1) |
3079 |
(re-search-backward "\\(\\`\n?\\|\n\n\\)=head1\\>" |
(re-search-backward "\\(\\`\n?\\|\n\n\\)=head1\\>" |
3080 |
nil t)))) ; Only one |
nil t)))) ; Only one |
3081 |
(progn |
(progn |
3082 |
(forward-word 1) |
(forward-word 1) |
3083 |
(setq name (file-name-sans-extension |
(setq name (file-name-sans-extension |
3084 |
(file-name-nondirectory (buffer-file-name))) |
(file-name-nondirectory (buffer-file-name))) |
3085 |
p (point)) |
p (point)) |
3086 |
(insert " NAME\n\n" name |
(insert " NAME\n\n" name |
3087 |
" - \n\n=head1 SYNOPSIS\n\n\n\n" |
" - \n\n=head1 SYNOPSIS\n\n\n\n" |
3088 |
"=head1 DESCRIPTION") |
"=head1 DESCRIPTION") |
3089 |
(cperl-ensure-newlines 4) |
(cperl-ensure-newlines 4) |
3113 |
(and (save-excursion |
(and (save-excursion |
3114 |
(backward-sexp 1) |
(backward-sexp 1) |
3115 |
(cperl-after-expr-p nil "{;:")) |
(cperl-after-expr-p nil "{;:")) |
3116 |
(save-excursion |
(save-excursion |
3117 |
(not |
(not |
3118 |
(re-search-backward |
(re-search-backward |
3119 |
"[#\"'`]\\|\\<q\\(\\|[wqxr]\\)\\>" |
"[#\"'`]\\|\\<q\\(\\|[wqxr]\\)\\>" |
3120 |
beg t))) |
beg t))) |
3134 |
(cperl-indent-line) |
(cperl-indent-line) |
3135 |
(insert "\n\n}")) |
(insert "\n\n}")) |
3136 |
(t |
(t |
3137 |
(insert " {\n\n}")) |
(insert " {\n\n}"))) |
|
) |
|
3138 |
(or (looking-at "[ \t]\\|$") (insert " ")) |
(or (looking-at "[ \t]\\|$") (insert " ")) |
3139 |
(cperl-indent-line) |
(cperl-indent-line) |
3140 |
(forward-line -1) |
(forward-line -1) |
3152 |
(end (save-excursion (end-of-line) (point))) |
(end (save-excursion (end-of-line) (point))) |
3153 |
(pos (point)) start over cut res) |
(pos (point)) start over cut res) |
3154 |
(if (and ; Check if we need to split: |
(if (and ; Check if we need to split: |
3155 |
; i.e., on a boundary and inside "{...}" |
; i.e., on a boundary and inside "{...}" |
3156 |
(save-excursion (cperl-to-comment-or-eol) |
(save-excursion (cperl-to-comment-or-eol) |
3157 |
(>= (point) pos)) ; Not in a comment |
(>= (point) pos)) ; Not in a comment |
3158 |
(or (save-excursion |
(or (save-excursion |
3159 |
(skip-chars-backward " \t" beg) |
(skip-chars-backward " \t" beg) |
3160 |
(forward-char -1) |
(forward-char -1) |
3163 |
(re-search-forward "\\=[ \t]*;" end t)) ; Before spaces + ; |
(re-search-forward "\\=[ \t]*;" end t)) ; Before spaces + ; |
3164 |
(save-excursion |
(save-excursion |
3165 |
(and |
(and |
3166 |
(eq (car (parse-partial-sexp pos end -1)) -1) |
(eq (car (parse-partial-sexp pos end -1)) -1) |
3167 |
; Leave the level of parens |
; Leave the level of parens |
3168 |
(looking-at "[,; \t]*\\($\\|#\\)") ; Comma to allow anon subr |
(looking-at "[,; \t]*\\($\\|#\\)") ; Comma to allow anon subr |
3169 |
; Are at end |
; Are at end |
3191 |
(cperl-indent-line) |
(cperl-indent-line) |
3192 |
(beginning-of-line) |
(beginning-of-line) |
3193 |
(or (looking-at "[ \t]*}[,; \t]*$") ; If there is a statement |
(or (looking-at "[ \t]*}[,; \t]*$") ; If there is a statement |
3194 |
; after, move it to separate line |
; after, move it to separate line |
3195 |
(progn |
(progn |
3196 |
(end-of-line) |
(end-of-line) |
3197 |
(search-backward "}" beg) |
(search-backward "}" beg) |
3201 |
(insert "\n") |
(insert "\n") |
3202 |
(cperl-indent-line) |
(cperl-indent-line) |
3203 |
(forward-line -1))) |
(forward-line -1))) |
3204 |
(forward-line -1) ; We are on the line before target |
(forward-line -1) ; We are on the line before target |
3205 |
(end-of-line) |
(end-of-line) |
3206 |
(newline-and-indent)) |
(newline-and-indent)) |
3207 |
(end-of-line) ; else - no splitting |
(end-of-line) ; else - no splitting |
3210 |
(save-excursion |
(save-excursion |
3211 |
(skip-chars-backward " \t") |
(skip-chars-backward " \t") |
3212 |
(eq (preceding-char) ?\)))) ; Probably if () {} group |
(eq (preceding-char) ?\)))) ; Probably if () {} group |
3213 |
; with an extra newline. |
; with an extra newline. |
3214 |
(forward-line 2) |
(forward-line 2) |
3215 |
(cperl-indent-line)) |
(cperl-indent-line)) |
3216 |
((save-excursion ; In POD header |
((save-excursion ; In POD header |
3218 |
;; (re-search-backward "\\(\\`\n?\\|\n\n\\)=head1\\b") |
;; (re-search-backward "\\(\\`\n?\\|\n\n\\)=head1\\b") |
3219 |
;; We are after \n now, so look for the rest |
;; We are after \n now, so look for the rest |
3220 |
(if (looking-at "\\(\\`\n?\\|\n\\)=\\sw+") |
(if (looking-at "\\(\\`\n?\\|\n\\)=\\sw+") |
3221 |
(progn |
(progn |
3222 |
(setq cut (looking-at "\\(\\`\n?\\|\n\\)=cut\\>")) |
(setq cut (looking-at "\\(\\`\n?\\|\n\\)=cut\\>")) |
3223 |
(setq over (looking-at "\\(\\`\n?\\|\n\\)=over\\>")) |
(setq over (looking-at "\\(\\`\n?\\|\n\\)=over\\>")) |
3224 |
t))) |
t))) |
3262 |
(defun cperl-electric-terminator (arg) |
(defun cperl-electric-terminator (arg) |
3263 |
"Insert character and correct line's indentation." |
"Insert character and correct line's indentation." |
3264 |
(interactive "P") |
(interactive "P") |
3265 |
(let (insertpos (end (point)) |
(let ((end (point)) |
3266 |
(auto (and cperl-auto-newline |
(auto (and cperl-auto-newline |
3267 |
(or (not (eq last-command-char ?:)) |
(or (not (eq last-command-char ?:)) |
3268 |
cperl-auto-newline-after-colon)))) |
cperl-auto-newline-after-colon))) |
3269 |
(if (and ;;(not arg) |
insertpos) |
3270 |
|
(if (and ;;(not arg) |
3271 |
(eolp) |
(eolp) |
3272 |
(not (save-excursion |
(not (save-excursion |
3273 |
(beginning-of-line) |
(beginning-of-line) |
3310 |
(self-insert-command (prefix-numeric-value arg))))) |
(self-insert-command (prefix-numeric-value arg))))) |
3311 |
|
|
3312 |
(defun cperl-electric-backspace (arg) |
(defun cperl-electric-backspace (arg) |
3313 |
"Backspace-untabify, or remove the whitespace around the point inserted |
"Backspace-untabify, or remove the whitespace around the point inserted |
3314 |
by an electric key." |
by an electric key." |
3315 |
(interactive "p") |
(interactive "p") |
3316 |
(if (and cperl-auto-newline |
(if (and cperl-auto-newline |
3317 |
(memq last-command '(cperl-electric-semi |
(memq last-command '(cperl-electric-semi |
3318 |
cperl-electric-terminator |
cperl-electric-terminator |
3319 |
cperl-electric-lbrace)) |
cperl-electric-lbrace)) |
3320 |
(memq (preceding-char) '(?\ ?\t ?\n))) |
(memq (preceding-char) '(?\ ?\t ?\n))) |
3321 |
(let (p) |
(let (p) |
3322 |
(if (eq last-command 'cperl-electric-lbrace) |
(if (eq last-command 'cperl-electric-lbrace) |
3323 |
(skip-chars-forward " \t\n")) |
(skip-chars-forward " \t\n")) |
3324 |
(setq p (point)) |
(setq p (point)) |
3325 |
(skip-chars-backward " \t\n") |
(skip-chars-backward " \t\n") |
3327 |
(and (eq last-command 'cperl-electric-else) |
(and (eq last-command 'cperl-electric-else) |
3328 |
;; We are removing the whitespace *inside* cperl-electric-else |
;; We are removing the whitespace *inside* cperl-electric-else |
3329 |
(setq this-command 'cperl-electric-else-really)) |
(setq this-command 'cperl-electric-else-really)) |
3330 |
(if (and cperl-auto-newline |
(if (and cperl-auto-newline |
3331 |
(eq last-command 'cperl-electric-else-really) |
(eq last-command 'cperl-electric-else-really) |
3332 |
(memq (preceding-char) '(?\ ?\t ?\n))) |
(memq (preceding-char) '(?\ ?\t ?\n))) |
3333 |
(let (p) |
(let (p) |
3349 |
|
|
3350 |
(defun cperl-indent-command (&optional whole-exp) |
(defun cperl-indent-command (&optional whole-exp) |
3351 |
"Indent current line as Perl code, or in some cases insert a tab character. |
"Indent current line as Perl code, or in some cases insert a tab character. |
3352 |
If `cperl-tab-always-indent' is non-nil (the default), always indent current |
If `cperl-tab-always-indent' is non-nil (the default), always indent current |
3353 |
line. Otherwise, indent the current line only if point is at the left margin |
line. Otherwise, indent the current line only if point is at the left margin |
3354 |
or in the line's indentation; otherwise insert a tab. |
or in the line's indentation; otherwise insert a tab. |
3355 |
|
|
3385 |
(defun cperl-indent-line (&optional parse-data) |
(defun cperl-indent-line (&optional parse-data) |
3386 |
"Indent current line as Perl code. |
"Indent current line as Perl code. |
3387 |
Return the amount the indentation changed by." |
Return the amount the indentation changed by." |
3388 |
(let (indent i beg shift-amt |
(let ((case-fold-search nil) |
3389 |
(case-fold-search nil) |
(pos (- (point-max) (point))) |
3390 |
(pos (- (point-max) (point)))) |
indent i beg shift-amt) |
3391 |
(setq indent (cperl-calculate-indent parse-data) |
(setq indent (cperl-calculate-indent parse-data) |
3392 |
i indent) |
i indent) |
3393 |
(beginning-of-line) |
(beginning-of-line) |
3437 |
(defun cperl-get-state (&optional parse-start start-state) |
(defun cperl-get-state (&optional parse-start start-state) |
3438 |
;; returns list (START STATE DEPTH PRESTART), |
;; returns list (START STATE DEPTH PRESTART), |
3439 |
;; START is a good place to start parsing, or equal to |
;; START is a good place to start parsing, or equal to |
3440 |
;; PARSE-START if preset, |
;; PARSE-START if preset, |
3441 |
;; STATE is what is returned by `parse-partial-sexp'. |
;; STATE is what is returned by `parse-partial-sexp'. |
3442 |
;; DEPTH is true is we are immediately after end of block |
;; DEPTH is true is we are immediately after end of block |
3443 |
;; which contains START. |
;; which contains START. |
3465 |
(or state (setq state (parse-partial-sexp start start-point -1 nil start-state))) |
(or state (setq state (parse-partial-sexp start start-point -1 nil start-state))) |
3466 |
(list start state depth prestart)))) |
(list start state depth prestart)))) |
3467 |
|
|
3468 |
(defun cperl-block-p () ; Do not C-M-q ! One string contains ";" ! |
(defun cperl-block-p () ; Do not C-M-q ! One string contains ";" ! |
3469 |
;; Positions is before ?\{. Checks whether it starts a block. |
;; Positions is before ?\{. Checks whether it starts a block. |
3470 |
;; No save-excursion! |
;; No save-excursion! |
3471 |
(cperl-backward-to-noncomment (point-min)) |
(cperl-backward-to-noncomment (point-min)) |
3483 |
(and (memq (char-syntax (preceding-char)) '(?w ?_)) |
(and (memq (char-syntax (preceding-char)) '(?w ?_)) |
3484 |
(progn |
(progn |
3485 |
(backward-sexp) |
(backward-sexp) |
3486 |
(looking-at |
(looking-at |
3487 |
"sub[ \t]+[a-zA-Z0-9_:]+[ \t\n\f]*\\(([^()]*)[ \t\n\f]*\\)?[#{]"))))))))) |
"sub[ \t]+[a-zA-Z0-9_:]+[ \t\n\f]*\\(([^()]*)[ \t\n\f]*\\)?[#{]"))))))))) |
3488 |
|
|
3489 |
(defvar cperl-look-for-prop '((pod in-pod) (here-doc-delim here-doc-group))) |
(defvar cperl-look-for-prop '((pod in-pod) (here-doc-delim here-doc-group))) |
3494 |
Returns nil if line starts inside a string, t if in a comment. |
Returns nil if line starts inside a string, t if in a comment. |
3495 |
|
|
3496 |
Will not correct the indentation for labels, but will correct it for braces |
Will not correct the indentation for labels, but will correct it for braces |
3497 |
and closing parentheses and brackets.." |
and closing parentheses and brackets." |
3498 |
(save-excursion |
(save-excursion |
3499 |
(if (or |
(if (or |
3500 |
(and (memq (get-text-property (point) 'syntax-type) |
(and (memq (get-text-property (point) 'syntax-type) |
3502 |
(not (get-text-property (point) 'indentable))) |
(not (get-text-property (point) 'indentable))) |
3503 |
;; before start of POD - whitespace found since do not have 'pod! |
;; before start of POD - whitespace found since do not have 'pod! |
3504 |
(and (looking-at "[ \t]*\n=") |
(and (looking-at "[ \t]*\n=") |
3505 |
(error "Spaces before pod section!")) |
(error "Spaces before POD section!")) |
3506 |
(and (not cperl-indent-left-aligned-comments) |
(and (not cperl-indent-left-aligned-comments) |
3507 |
(looking-at "^#"))) |
(looking-at "^#"))) |
3508 |
nil |
nil |
3509 |
(beginning-of-line) |
(beginning-of-line) |
3510 |
(let ((indent-point (point)) |
(let ((indent-point (point)) |
3511 |
(char-after (save-excursion |
(char-after (save-excursion |
3512 |
(skip-chars-forward " \t") |
(skip-chars-forward " \t") |
3513 |
(following-char))) |
(following-char))) |
3514 |
(in-pod (get-text-property (point) 'in-pod)) |
(in-pod (get-text-property (point) 'in-pod)) |
3515 |
(pre-indent-point (point)) |
(pre-indent-point (point)) |
3516 |
p prop look-prop is-block delim) |
p prop look-prop is-block delim) |
3517 |
(cond |
(cond |
3518 |
(in-pod |
(in-pod |
3519 |
;; In the verbatim part, probably code example. What to do??? |
;; In the verbatim part, probably code example. What to do??? |
3520 |
) |
) |
3521 |
(t |
(t |
3522 |
(save-excursion |
(save-excursion |
3523 |
;; Not in pod |
;; Not in POD |
3524 |
(cperl-backward-to-noncomment nil) |
(cperl-backward-to-noncomment nil) |
3525 |
(setq p (max (point-min) (1- (point))) |
(setq p (max (point-min) (1- (point))) |
3526 |
prop (get-text-property p 'syntax-type) |
prop (get-text-property p 'syntax-type) |
3527 |
look-prop (or (nth 1 (assoc prop cperl-look-for-prop)) |
look-prop (or (nth 1 (assoc prop cperl-look-for-prop)) |
3528 |
'syntax-type)) |
'syntax-type)) |
3529 |
(if (memq prop '(pod here-doc format here-doc-delim)) |
(if (memq prop '(pod here-doc format here-doc-delim)) |
3530 |
|
(progn |
3531 |
|
(goto-char (or (previous-single-property-change p look-prop) |
3532 |
|
(point-min))) |
3533 |
|
(beginning-of-line) |
3534 |
|
(setq pre-indent-point (point))))))) |
3535 |
|
(goto-char pre-indent-point) |
3536 |
|
(let* ((case-fold-search nil) |
3537 |
|
(s-s (cperl-get-state (car parse-data) (nth 1 parse-data))) |
3538 |
|
(start (or (nth 2 parse-data) |
3539 |
|
(nth 0 s-s))) |
3540 |
|
(state (nth 1 s-s)) |
3541 |
|
(containing-sexp (car (cdr state))) |
3542 |
|
old-indent) |
3543 |
|
(if (and |
3544 |
|
;;containing-sexp ;; We are buggy at toplevel :-( |
3545 |
|
parse-data) |
3546 |
(progn |
(progn |
3547 |
(goto-char (or (previous-single-property-change p look-prop) |
(setcar parse-data pre-indent-point) |
3548 |
(point-min))) |
(setcar (cdr parse-data) state) |
3549 |
(beginning-of-line) |
(or (nth 2 parse-data) |
3550 |
(setq pre-indent-point (point))))))) |
(setcar (cddr parse-data) start)) |
3551 |
(goto-char pre-indent-point) |
;; Before this point: end of statement |
3552 |
(let* ((case-fold-search nil) |
(setq old-indent (nth 3 parse-data)))) |
3553 |
(s-s (cperl-get-state (car parse-data) (nth 1 parse-data))) |
(cond ((get-text-property (point) 'indentable) |
3554 |
(start (or (nth 2 parse-data) |
;; indent to just after the surrounding open, |
3555 |
(nth 0 s-s))) |
;; skip blanks if we do not close the expression. |
3556 |
(state (nth 1 s-s)) |
(goto-char (1+ (previous-single-property-change (point) 'indentable))) |
3557 |
(containing-sexp (car (cdr state))) |
(or (memq char-after (append ")]}" nil)) |
3558 |
old-indent) |
(looking-at "[ \t]*\\(#\\|$\\)") |
3559 |
(if (and |
(skip-chars-forward " \t")) |
3560 |
;;containing-sexp ;; We are buggy at toplevel :-( |
(current-column)) |
3561 |
parse-data) |
((or (nth 3 state) (nth 4 state)) |
3562 |
(progn |
;; return nil or t if should not change this line |
3563 |
(setcar parse-data pre-indent-point) |
(nth 4 state)) |
3564 |
(setcar (cdr parse-data) state) |
;; XXXX Do we need to special-case this? |
3565 |
(or (nth 2 parse-data) |
((null containing-sexp) |
3566 |
(setcar (cddr parse-data) start)) |
;; Line is at top level. May be data or function definition, |
3567 |
;; Before this point: end of statement |
;; or may be function argument declaration. |
3568 |
(setq old-indent (nth 3 parse-data)))) |
;; Indent like the previous top level line |
3569 |
(cond ((get-text-property (point) 'indentable) |
;; unless that ends in a closeparen without semicolon, |
3570 |
;; indent to just after the surrounding open, |
;; in which case this line is the first argument decl. |
3571 |
;; skip blanks if we do not close the expression. |
(skip-chars-forward " \t") |
3572 |
(goto-char (1+ (previous-single-property-change (point) 'indentable))) |
(+ (save-excursion |
3573 |
(or (memq char-after (append ")]}" nil)) |
(goto-char start) |
3574 |
(looking-at "[ \t]*\\(#\\|$\\)") |
(- (current-indentation) |
3575 |
(skip-chars-forward " \t")) |
(if (nth 2 s-s) cperl-indent-level 0))) |
3576 |
(current-column)) |
(if (= char-after ?{) cperl-continued-brace-offset 0) |
3577 |
((or (nth 3 state) (nth 4 state)) |
(progn |
3578 |
;; return nil or t if should not change this line |
(cperl-backward-to-noncomment (or old-indent (point-min))) |
3579 |
(nth 4 state)) |
;; Look at previous line that's at column 0 |
3580 |
;; XXXX Do we need to special-case this? |
;; to determine whether we are in top-level decls |
3581 |
((null containing-sexp) |
;; or function's arg decls. Set basic-indent accordingly. |
3582 |
;; Line is at top level. May be data or function definition, |
;; Now add a little if this is a continuation line. |
3583 |
;; or may be function argument declaration. |
(if (or (bobp) |
3584 |
;; Indent like the previous top level line |
(eq (point) old-indent) ; old-indent was at comment |
3585 |
;; unless that ends in a closeparen without semicolon, |
(eq (preceding-char) ?\;) |
3586 |
;; in which case this line is the first argument decl. |
;; Had ?\) too |
3587 |
(skip-chars-forward " \t") |
(and (eq (preceding-char) ?\}) |
3588 |
(+ (save-excursion |
(cperl-after-block-and-statement-beg |
3589 |
(goto-char start) |
(point-min))) ; Was start - too close |
3590 |
(- (current-indentation) |
(memq char-after (append ")]}" nil)) |
3591 |
(if (nth 2 s-s) cperl-indent-level 0))) |
(and (eq (preceding-char) ?\:) ; label |
3592 |
(if (= char-after ?{) cperl-continued-brace-offset 0) |
(progn |
3593 |
(progn |
(forward-sexp -1) |
3594 |
(cperl-backward-to-noncomment (or old-indent (point-min))) |
(skip-chars-backward " \t") |
3595 |
;; Look at previous line that's at column 0 |
(looking-at "[ \t]*[a-zA-Z_][a-zA-Z_0-9]*[ \t]*:")))) |
3596 |
;; to determine whether we are in top-level decls |
(progn |
3597 |
;; or function's arg decls. Set basic-indent accordingly. |
(if (and parse-data |
3598 |
;; Now add a little if this is a continuation line. |
(not (eq char-after ?\C-j))) |
3599 |
(if (or (bobp) |
(setcdr (cddr parse-data) |
3600 |
(eq (point) old-indent) ; old-indent was at comment |
(list pre-indent-point))) |
3601 |
(eq (preceding-char) ?\;) |
0) |
3602 |
;; Had ?\) too |
cperl-continued-statement-offset)))) |
3603 |
(and (eq (preceding-char) ?\}) |
((not |
3604 |
(cperl-after-block-and-statement-beg |
(or (setq is-block |
3605 |
(point-min))) ; Was start - too close |
(and (setq delim (= (char-after containing-sexp) ?{)) |
3606 |
(memq char-after (append ")]}" nil)) |
(save-excursion ; Is it a hash? |
3607 |
(and (eq (preceding-char) ?\:) ; label |
(goto-char containing-sexp) |
3608 |
(progn |
(cperl-block-p)))) |
3609 |
(forward-sexp -1) |
cperl-indent-parens-as-block)) |
3610 |
(skip-chars-backward " \t") |
;; group is an expression, not a block: |
3611 |
(looking-at "[ \t]*[a-zA-Z_][a-zA-Z_0-9]*[ \t]*:")))) |
;; indent to just after the surrounding open parens, |
3612 |
(progn |
;; skip blanks if we do not close the expression. |
3613 |
(if (and parse-data |
(goto-char (1+ containing-sexp)) |
3614 |
(not (eq char-after ?\C-j))) |
(or (memq char-after |
3615 |
(setcdr (cddr parse-data) |
(append (if delim "}" ")]}") nil)) |
3616 |
(list pre-indent-point))) |
(looking-at "[ \t]*\\(#\\|$\\)") |
3617 |
0) |
(skip-chars-forward " \t")) |
3618 |
cperl-continued-statement-offset)))) |
(+ (current-column) |
3619 |
((not |
(if (and delim |
3620 |
(or (setq is-block |
(eq char-after ?\})) |
3621 |
(and (setq delim (= (char-after containing-sexp) ?{)) |
;; Correct indentation of trailing ?\} |
3622 |
(save-excursion ; Is it a hash? |
(+ cperl-indent-level cperl-close-paren-offset) |
3623 |
(goto-char containing-sexp) |
0))) |
|
(cperl-block-p)))) |
|
|
cperl-indent-parens-as-block)) |
|
|
;; group is an expression, not a block: |
|
|
;; indent to just after the surrounding open parens, |
|
|
;; skip blanks if we do not close the expression. |
|
|
(goto-char (1+ containing-sexp)) |
|
|
(or (memq char-after |
|
|
(append (if delim "}" ")]}") nil)) |
|
|
(looking-at "[ \t]*\\(#\\|$\\)") |
|
|
(skip-chars-forward " \t")) |
|
|
(+ (current-column) |
|
|
(if (and delim |
|
|
(eq char-after ?\})) |
|
|
;; Correct indentation of trailing ?\} |
|
|
(+ cperl-indent-level cperl-close-paren-offset) |
|
|
0))) |
|
3624 |
;;; ((and (/= (char-after containing-sexp) ?{) |
;;; ((and (/= (char-after containing-sexp) ?{) |
3625 |
;;; (not cperl-indent-parens-as-block)) |
;;; (not cperl-indent-parens-as-block)) |
3626 |
;;; ;; line is expression, not statement: |
;;; ;; line is expression, not statement: |
3642 |
;;; (skip-chars-forward " \t")) |
;;; (skip-chars-forward " \t")) |
3643 |
;;; (+ (current-column) ; Correct indentation of trailing ?\} |
;;; (+ (current-column) ; Correct indentation of trailing ?\} |
3644 |
;;; (if (eq char-after ?\}) (+ cperl-indent-level |
;;; (if (eq char-after ?\}) (+ cperl-indent-level |
3645 |
;;; cperl-close-paren-offset) |
;;; cperl-close-paren-offset) |
3646 |
;;; 0))) |
;;; 0))) |
3647 |
(t |
(t |
3648 |
;; Statement level. Is it a continuation or a new statement? |
;; Statement level. Is it a continuation or a new statement? |
3649 |
;; Find previous non-comment character. |
;; Find previous non-comment character. |
3650 |
(goto-char pre-indent-point) |
(goto-char pre-indent-point) |
3651 |
(cperl-backward-to-noncomment containing-sexp) |
(cperl-backward-to-noncomment containing-sexp) |
3652 |
;; Back up over label lines, since they don't |
;; Back up over label lines, since they don't |
3653 |
;; affect whether our line is a continuation. |
;; affect whether our line is a continuation. |
3654 |
;; (Had \, too) |
;; (Had \, too) |
3655 |
(while ;;(or (eq (preceding-char) ?\,) |
(while ;;(or (eq (preceding-char) ?\,) |
3656 |
(and (eq (preceding-char) ?:) |
(and (eq (preceding-char) ?:) |
3657 |
(or;;(eq (char-after (- (point) 2)) ?\') ; ???? |
(or ;;(eq (char-after (- (point) 2)) ?\') ; ???? |
3658 |
(memq (char-syntax (char-after (- (point) 2))) |
(memq (char-syntax (char-after (- (point) 2))) |
3659 |
'(?w ?_)))) |
'(?w ?_)))) |
3660 |
;;) |
;;) |
3661 |
(if (eq (preceding-char) ?\,) |
(if (eq (preceding-char) ?\,) |
3662 |
;; Will go to beginning of line, essentially. |
;; Will go to beginning of line, essentially. |
3663 |
;; Will ignore embedded sexpr XXXX. |
;; Will ignore embedded sexpr XXXX. |
3664 |
(cperl-backward-to-start-of-continued-exp containing-sexp)) |
(cperl-backward-to-start-of-continued-exp containing-sexp)) |
3665 |
(beginning-of-line) |
(beginning-of-line) |
3666 |
(cperl-backward-to-noncomment containing-sexp)) |
(cperl-backward-to-noncomment containing-sexp)) |
3667 |
;; Now we get the answer. |
;; Now we get the answer. |
3668 |
(if (not (or (eq (1- (point)) containing-sexp) |
(if (not (or (eq (1- (point)) containing-sexp) |
3669 |
(memq (preceding-char) |
(memq (preceding-char) |
3670 |
(append (if is-block " ;{" " ,;{") '(nil))) |
(append (if is-block " ;{" " ,;{") '(nil))) |
3671 |
(and (eq (preceding-char) ?\}) |
(and (eq (preceding-char) ?\}) |
3672 |
(cperl-after-block-and-statement-beg |
(cperl-after-block-and-statement-beg |
3673 |
containing-sexp)))) |
containing-sexp)))) |
3674 |
;; This line is continuation of preceding line's statement; |
;; This line is continuation of preceding line's statement; |
3675 |
;; indent `cperl-continued-statement-offset' more than the |
;; indent `cperl-continued-statement-offset' more than the |
3676 |
;; previous line of the statement. |
;; previous line of the statement. |
3677 |
;; |
;; |
3678 |
;; There might be a label on this line, just |
;; There might be a label on this line, just |
3679 |
;; consider it bad style and ignore it. |
;; consider it bad style and ignore it. |
|
(progn |
|
|
(cperl-backward-to-start-of-continued-exp containing-sexp) |
|
|
(+ (if (memq char-after (append "}])" nil)) |
|
|
0 ; Closing parenth |
|
|
cperl-continued-statement-offset) |
|
|
(if (or is-block |
|
|
(not delim) |
|
|
(not (eq char-after ?\}))) |
|
|
0 |
|
|
;; Now it is a hash reference |
|
|
(+ cperl-indent-level cperl-close-paren-offset)) |
|
|
(if (looking-at "\\w+[ \t]*:") |
|
|
(if (> (current-indentation) cperl-min-label-indent) |
|
|
(- (current-indentation) cperl-label-offset) |
|
|
;; Do not move `parse-data', this should |
|
|
;; be quick anyway (this comment comes |
|
|
;;from different location): |
|
|
(cperl-calculate-indent)) |
|
|
(current-column)) |
|
|
(if (eq char-after ?\{) |
|
|
cperl-continued-brace-offset 0))) |
|
|
;; This line starts a new statement. |
|
|
;; Position following last unclosed open. |
|
|
(goto-char containing-sexp) |
|
|
;; Is line first statement after an open-brace? |
|
|
(or |
|
|
;; If no, find that first statement and indent like |
|
|
;; it. If the first statement begins with label, do |
|
|
;; not believe when the indentation of the label is too |
|
|
;; small. |
|
|
(save-excursion |
|
|
(forward-char 1) |
|
|
(setq old-indent (current-indentation)) |
|
|
(let ((colon-line-end 0)) |
|
|
(while (progn (skip-chars-forward " \t\n") |
|
|
(looking-at "#\\|[a-zA-Z0-9_$]*:[^:]")) |
|
|
;; Skip over comments and labels following openbrace. |
|
|
(cond ((= (following-char) ?\#) |
|
|
(forward-line 1)) |
|
|
;; label: |
|
|
(t |
|
|
(save-excursion (end-of-line) |
|
|
(setq colon-line-end (point))) |
|
|
(search-forward ":")))) |
|
|
;; The first following code counts |
|
|
;; if it is before the line we want to indent. |
|
|
(and (< (point) indent-point) |
|
|
(if (> colon-line-end (point)) ; After label |
|
|
(if (> (current-indentation) |
|
|
cperl-min-label-indent) |
|
|
(- (current-indentation) cperl-label-offset) |
|
|
;; Do not believe: `max' is involved |
|
|
(+ old-indent cperl-indent-level)) |
|
|
(current-column))))) |
|
|
;; If no previous statement, |
|
|
;; indent it relative to line brace is on. |
|
|
;; For open brace in column zero, don't let statement |
|
|
;; start there too. If cperl-indent-level is zero, |
|
|
;; use cperl-brace-offset + cperl-continued-statement-offset instead. |
|
|
;; For open-braces not the first thing in a line, |
|
|
;; add in cperl-brace-imaginary-offset. |
|
|
|
|
|
;; If first thing on a line: ????? |
|
|
(+ (if (and (bolp) (zerop cperl-indent-level)) |
|
|
(+ cperl-brace-offset cperl-continued-statement-offset) |
|
|
cperl-indent-level) |
|
|
(if (or is-block |
|
|
(not delim) |
|
|
(not (eq char-after ?\}))) |
|
|
0 |
|
|
;; Now it is a hash reference |
|
|
(+ cperl-indent-level cperl-close-paren-offset)) |
|
|
;; Move back over whitespace before the openbrace. |
|
|
;; If openbrace is not first nonwhite thing on the line, |
|
|
;; add the cperl-brace-imaginary-offset. |
|
|
(progn (skip-chars-backward " \t") |
|
|
(if (bolp) 0 cperl-brace-imaginary-offset)) |
|
|
;; If the openbrace is preceded by a parenthesized exp, |
|
|
;; move to the beginning of that; |
|
|
;; possibly a different line |
|
3680 |
(progn |
(progn |
3681 |
(if (eq (preceding-char) ?\)) |
(cperl-backward-to-start-of-continued-exp containing-sexp) |
3682 |
(forward-sexp -1)) |
(+ (if (memq char-after (append "}])" nil)) |
3683 |
;; In the case it starts a subroutine, indent with |
0 ; Closing parenth |
3684 |
;; respect to `sub', not with respect to the the |
cperl-continued-statement-offset) |
3685 |
;; first thing on the line, say in the case of |
(if (or is-block |
3686 |
;; anonymous sub in a hash. |
(not delim) |
3687 |
;; |
(not (eq char-after ?\}))) |
3688 |
(skip-chars-backward " \t") |
0 |
3689 |
(if (and (eq (preceding-char) ?b) |
;; Now it is a hash reference |
3690 |
(progn |
(+ cperl-indent-level cperl-close-paren-offset)) |
3691 |
(forward-sexp -1) |
(if (looking-at "\\w+[ \t]*:") |
3692 |
(looking-at "sub\\>")) |
(if (> (current-indentation) cperl-min-label-indent) |
3693 |
(setq old-indent |
(- (current-indentation) cperl-label-offset) |
3694 |
(nth 1 |
;; Do not move `parse-data', this should |
3695 |
(parse-partial-sexp |
;; be quick anyway (this comment comes |
3696 |
(save-excursion (beginning-of-line) (point)) |
;; from different location): |
3697 |
(point))))) |
(cperl-calculate-indent)) |
3698 |
(progn (goto-char (1+ old-indent)) |
(current-column)) |
3699 |
(skip-chars-forward " \t") |
(if (eq char-after ?\{) |
3700 |
(current-column)) |
cperl-continued-brace-offset 0))) |
3701 |
;; Get initial indentation of the line we are on. |
;; This line starts a new statement. |
3702 |
;; If line starts with label, calculate label indentation |
;; Position following last unclosed open. |
3703 |
(if (save-excursion |
(goto-char containing-sexp) |
3704 |
(beginning-of-line) |
;; Is line first statement after an open-brace? |
3705 |
(looking-at "[ \t]*[a-zA-Z_][a-zA-Z_0-9]*:[^:]")) |
(or |
3706 |
(if (> (current-indentation) cperl-min-label-indent) |
;; If no, find that first statement and indent like |
3707 |
(- (current-indentation) cperl-label-offset) |
;; it. If the first statement begins with label, do |
3708 |
;; Do not move `parse-data', this should |
;; not believe when the indentation of the label is too |
3709 |
;; be quick anyway: |
;; small. |
3710 |
(cperl-calculate-indent)) |
(save-excursion |
3711 |
(current-indentation)))))))))))))) |
(forward-char 1) |
3712 |
|
(setq old-indent (current-indentation)) |
3713 |
|
(let ((colon-line-end 0)) |
3714 |
|
(while (progn (skip-chars-forward " \t\n") |
3715 |
|
(looking-at "#\\|[a-zA-Z0-9_$]*:[^:]")) |
3716 |
|
;; Skip over comments and labels following openbrace. |
3717 |
|
(cond ((= (following-char) ?\#) |
3718 |
|
(forward-line 1)) |
3719 |
|
;; label: |
3720 |
|
(t |
3721 |
|
(save-excursion (end-of-line) |
3722 |
|
(setq colon-line-end (point))) |
3723 |
|
(search-forward ":")))) |
3724 |
|
;; The first following code counts |
3725 |
|
;; if it is before the line we want to indent. |
3726 |
|
(and (< (point) indent-point) |
3727 |
|
(if (> colon-line-end (point)) ; After label |
3728 |
|
(if (> (current-indentation) |
3729 |
|
cperl-min-label-indent) |
3730 |
|
(- (current-indentation) cperl-label-offset) |
3731 |
|
;; Do not believe: `max' is involved |
3732 |
|
(+ old-indent cperl-indent-level)) |
3733 |
|
(current-column))))) |
3734 |
|
;; If no previous statement, |
3735 |
|
;; indent it relative to line brace is on. |
3736 |
|
;; For open brace in column zero, don't let statement |
3737 |
|
;; start there too. If cperl-indent-level is zero, |
3738 |
|
;; use cperl-brace-offset + cperl-continued-statement-offset instead. |
3739 |
|
;; For open-braces not the first thing in a line, |
3740 |
|
;; add in cperl-brace-imaginary-offset. |
3741 |
|
|
3742 |
|
;; If first thing on a line: ????? |
3743 |
|
(+ (if (and (bolp) (zerop cperl-indent-level)) |
3744 |
|
(+ cperl-brace-offset cperl-continued-statement-offset) |
3745 |
|
cperl-indent-level) |
3746 |
|
(if (or is-block |
3747 |
|
(not delim) |
3748 |
|
(not (eq char-after ?\}))) |
3749 |
|
0 |
3750 |
|
;; Now it is a hash reference |
3751 |
|
(+ cperl-indent-level cperl-close-paren-offset)) |
3752 |
|
;; Move back over whitespace before the openbrace. |
3753 |
|
;; If openbrace is not first nonwhite thing on the line, |
3754 |
|
;; add the cperl-brace-imaginary-offset. |
3755 |
|
(progn (skip-chars-backward " \t") |
3756 |
|
(if (bolp) 0 cperl-brace-imaginary-offset)) |
3757 |
|
;; If the openbrace is preceded by a parenthesized exp, |
3758 |
|
;; move to the beginning of that; |
3759 |
|
;; possibly a different line |
3760 |
|
(progn |
3761 |
|
(if (eq (preceding-char) ?\)) |
3762 |
|
(forward-sexp -1)) |
3763 |
|
;; In the case it starts a subroutine, indent with |
3764 |
|
;; respect to `sub', not with respect to the |
3765 |
|
;; first thing on the line, say in the case of |
3766 |
|
;; anonymous sub in a hash. |
3767 |
|
;; |
3768 |
|
(skip-chars-backward " \t") |
3769 |
|
(if (and (eq (preceding-char) ?b) |
3770 |
|
(progn |
3771 |
|
(forward-sexp -1) |
3772 |
|
(looking-at "sub\\>")) |
3773 |
|
(setq old-indent |
3774 |
|
(nth 1 |
3775 |
|
(parse-partial-sexp |
3776 |
|
(save-excursion (beginning-of-line) (point)) |
3777 |
|
(point))))) |
3778 |
|
(progn (goto-char (1+ old-indent)) |
3779 |
|
(skip-chars-forward " \t") |
3780 |
|
(current-column)) |
3781 |
|
;; Get initial indentation of the line we are on. |
3782 |
|
;; If line starts with label, calculate label indentation |
3783 |
|
(if (save-excursion |
3784 |
|
(beginning-of-line) |
3785 |
|
(looking-at "[ \t]*[a-zA-Z_][a-zA-Z_0-9]*:[^:]")) |
3786 |
|
(if (> (current-indentation) cperl-min-label-indent) |
3787 |
|
(- (current-indentation) cperl-label-offset) |
3788 |
|
;; Do not move `parse-data', this should |
3789 |
|
;; be quick anyway: |
3790 |
|
(cperl-calculate-indent)) |
3791 |
|
(current-indentation)))))))))))))) |
3792 |
|
|
3793 |
(defvar cperl-indent-alist |
(defvar cperl-indent-alist |
3794 |
'((string nil) |
'((string nil) |
3824 |
((nth 4 state) ; In comment |
((nth 4 state) ; In comment |
3825 |
(setq res (cons '(comment) res))) |
(setq res (cons '(comment) res))) |
3826 |
((null containing-sexp) |
((null containing-sexp) |
3827 |
;; Line is at top level. |
;; Line is at top level. |
3828 |
;; Indent like the previous top level line |
;; Indent like the previous top level line |
3829 |
;; unless that ends in a closeparen without semicolon, |
;; unless that ends in a closeparen without semicolon, |
3830 |
;; in which case this line is the first argument decl. |
;; in which case this line is the first argument decl. |
3836 |
(setq res (cons (list 'toplevel start) res))) |
(setq res (cons (list 'toplevel start) res))) |
3837 |
((eq (preceding-char) ?\) ) |
((eq (preceding-char) ?\) ) |
3838 |
(setq res (cons (list 'toplevel-after-parenth start) res))) |
(setq res (cons (list 'toplevel-after-parenth start) res))) |
3839 |
(t |
(t |
3840 |
(setq res (cons (list 'toplevel-continued start) res))))) |
(setq res (cons (list 'toplevel-continued start) res))))) |
3841 |
((/= (char-after containing-sexp) ?{) |
((/= (char-after containing-sexp) ?{) |
3842 |
;; line is expression, not statement: |
;; line is expression, not statement: |
3850 |
(point))) |
(point))) |
3851 |
(cons (list 'expression containing-sexp) res)))) |
(cons (list 'expression containing-sexp) res)))) |
3852 |
((progn |
((progn |
3853 |
;; Containing-expr starts with \{. Check whether it is a hash. |
;; Containing-expr starts with \{. Check whether it is a hash. |
3854 |
(goto-char containing-sexp) |
(goto-char containing-sexp) |
3855 |
(not (cperl-block-p))) |
(not (cperl-block-p))) |
3856 |
(setq res (cons (list 'expression-blanks |
(setq res (cons (list 'expression-blanks |
3857 |
(progn |
(progn |
3858 |
(goto-char (1+ containing-sexp)) |
(goto-char (1+ containing-sexp)) |
3873 |
(save-excursion (cperl-after-label))) |
(save-excursion (cperl-after-label))) |
3874 |
(if (eq (preceding-char) ?\,) |
(if (eq (preceding-char) ?\,) |
3875 |
;; Will go to beginning of line, essentially |
;; Will go to beginning of line, essentially |
3876 |
;; Will ignore embedded sexpr XXXX. |
;; Will ignore embedded sexpr XXXX. |
3877 |
(cperl-backward-to-start-of-continued-exp containing-sexp)) |
(cperl-backward-to-start-of-continued-exp containing-sexp)) |
3878 |
(beginning-of-line) |
(beginning-of-line) |
3879 |
(cperl-backward-to-noncomment containing-sexp)) |
(cperl-backward-to-noncomment containing-sexp)) |
3906 |
(save-excursion (end-of-line) |
(save-excursion (end-of-line) |
3907 |
(setq colon-line-end (point))) |
(setq colon-line-end (point))) |
3908 |
(search-forward ":")))) |
(search-forward ":")))) |
3909 |
;; Now at the point, after label, or at start |
;; Now at the point, after label, or at start |
3910 |
;; of first statement in the block. |
;; of first statement in the block. |
3911 |
(and (< (point) start-point) |
(and (< (point) start-point) |
3912 |
(if (> colon-line-end (point)) |
(if (> colon-line-end (point)) |
3913 |
;; Before statement after label |
;; Before statement after label |
3914 |
(if (> (current-indentation) |
(if (> (current-indentation) |
3915 |
cperl-min-label-indent) |
cperl-min-label-indent) |
3916 |
(list (list 'label-in-block (point))) |
(list (list 'label-in-block (point))) |
3917 |
;; Do not believe: `max' is involved |
;; Do not believe: `max' is involved |
3970 |
|
|
3971 |
|
|
3972 |
(defun cperl-to-comment-or-eol () |
(defun cperl-to-comment-or-eol () |
3973 |
"Goes to position before comment on the current line, or to end of line. |
"Go to position before comment on the current line, or to end of line. |
3974 |
Returns true if comment is found." |
Returns true if comment is found." |
3975 |
(let (state stop-in cpoint (lim (progn (end-of-line) (point)))) |
(let (state stop-in cpoint (lim (progn (end-of-line) (point)))) |
3976 |
(beginning-of-line) |
(beginning-of-line) |
3977 |
(if (or |
(if (or |
3978 |
(eq (get-text-property (point) 'syntax-type) 'pod) |
(eq (get-text-property (point) 'syntax-type) 'pod) |
3979 |
(re-search-forward "\\=[ \t]*\\(#\\|$\\)" lim t)) |
(re-search-forward "\\=[ \t]*\\(#\\|$\\)" lim t)) |
3980 |
(if (eq (preceding-char) ?\#) (progn (backward-char 1) t)) |
(if (eq (preceding-char) ?\#) (progn (backward-char 1) t)) |
3981 |
;; Else |
;; Else |
3982 |
(while (not stop-in) |
(while (not stop-in) |
3983 |
(setq state (parse-partial-sexp (point) lim nil nil nil t)) |
(setq state (parse-partial-sexp (point) lim nil nil nil t)) |
3984 |
; stop at comment |
; stop at comment |
3985 |
;; If fails (beginning-of-line inside sexp), then contains not-comment |
;; If fails (beginning-of-line inside sexp), then contains not-comment |
3986 |
(if (nth 4 state) ; After `#'; |
(if (nth 4 state) ; After `#'; |
3987 |
; (nth 2 state) can be |
; (nth 2 state) can be |
3988 |
; beginning of m,s,qq and so |
; beginning of m,s,qq and so |
3989 |
; on |
; on |
3990 |
(if (nth 2 state) |
(if (nth 2 state) |
3991 |
(progn |
(progn |
3992 |
(setq cpoint (point)) |
(setq cpoint (point)) |
3993 |
(goto-char (nth 2 state)) |
(goto-char (nth 2 state)) |
3994 |
(cond |
(cond |
3995 |
((looking-at "\\(s\\|tr\\)\\>") |
((looking-at "\\(s\\|tr\\)\\>") |
3996 |
(or (re-search-forward |
(or (re-search-forward |
3997 |
"\\=\\w+[ \t]*#\\([^\n\\\\#]\\|\\\\[\\\\#]\\)*#\\([^\n\\\\#]\\|\\\\[\\\\#]\\)*" |
"\\=\\w+[ \t]*#\\([^\n\\\\#]\\|\\\\[\\\\#]\\)*#\\([^\n\\\\#]\\|\\\\[\\\\#]\\)*" |
3998 |
lim 'move) |
lim 'move) |
3999 |
(setq stop-in t))) |
(setq stop-in t))) |
4000 |
((looking-at "\\(m\\|q\\([qxwr]\\)?\\)\\>") |
((looking-at "\\(m\\|q\\([qxwr]\\)?\\)\\>") |
4001 |
(or (re-search-forward |
(or (re-search-forward |
4002 |
"\\=\\w+[ \t]*#\\([^\n\\\\#]\\|\\\\[\\\\#]\\)*#" |
"\\=\\w+[ \t]*#\\([^\n\\\\#]\\|\\\\[\\\\#]\\)*#" |
4003 |
lim 'move) |
lim 'move) |
4004 |
(setq stop-in t))) |
(setq stop-in t))) |
4005 |
(t ; It was fair comment |
(t ; It was fair comment |
4006 |
(setq stop-in t) ; Finish |
(setq stop-in t) ; Finish |
4007 |
(goto-char (1- cpoint))))) |
(goto-char (1- cpoint))))) |
4008 |
(setq stop-in t) ; Finish |
(setq stop-in t) ; Finish |
4009 |
(forward-char -1)) |
(forward-char -1)) |
4010 |
(setq stop-in t)) ; Finish |
(setq stop-in t))) ; Finish |
4011 |
) |
(nth 4 state)))) |
|
(nth 4 state)))) |
|
4012 |
|
|
4013 |
(defsubst cperl-1- (p) |
(defsubst cperl-1- (p) |
4014 |
(max (point-min) (1- p))) |
(max (point-min) (1- p))) |
4030 |
(put-text-property (1- (point)) (point) 'syntax-table cperl-st-punct)))) |
(put-text-property (1- (point)) (point) 'syntax-table cperl-st-punct)))) |
4031 |
|
|
4032 |
(defun cperl-commentify (bb e string &optional noface) |
(defun cperl-commentify (bb e string &optional noface) |
4033 |
(if cperl-use-syntax-table-text-property |
(if cperl-use-syntax-table-text-property |
4034 |
(if (eq noface 'n) ; Only immediate |
(if (eq noface 'n) ; Only immediate |
4035 |
nil |
nil |
4036 |
;; We suppose that e is _after_ the end of construction, as after eol. |
;; We suppose that e is _after_ the end of construction, as after eol. |
4041 |
(cperl-modify-syntax-type bb string) |
(cperl-modify-syntax-type bb string) |
4042 |
(cperl-modify-syntax-type (1- e) string)) |
(cperl-modify-syntax-type (1- e) string)) |
4043 |
(if (and (eq string cperl-st-sfence) (> (- e 2) bb)) |
(if (and (eq string cperl-st-sfence) (> (- e 2) bb)) |
4044 |
(put-text-property (1+ bb) (1- e) |
(put-text-property (1+ bb) (1- e) |
4045 |
'syntax-table cperl-string-syntax-table)) |
'syntax-table cperl-string-syntax-table)) |
4046 |
(cperl-protect-defun-start bb e)) |
(cperl-protect-defun-start bb e)) |
4047 |
;; Fontify |
;; Fontify |
4062 |
(let (b starter ender st i i2 go-forward reset-st) |
(let (b starter ender st i i2 go-forward reset-st) |
4063 |
(skip-chars-forward " \t") |
(skip-chars-forward " \t") |
4064 |
;; ender means matching-char matcher. |
;; ender means matching-char matcher. |
4065 |
(setq b (point) |
(setq b (point) |
4066 |
starter (if (eobp) 0 (char-after b)) |
starter (if (eobp) 0 (char-after b)) |
4067 |
ender (cdr (assoc starter cperl-starters))) |
ender (cdr (assoc starter cperl-starters))) |
4068 |
;; What if starter == ?\\ ???? |
;; What if starter == ?\\ ???? |
4128 |
(setq i2 (point)))) |
(setq i2 (point)))) |
4129 |
(forward-char -1)) |
(forward-char -1)) |
4130 |
(modify-syntax-entry starter (if (eq starter ?\\) "\\" ".") st) |
(modify-syntax-entry starter (if (eq starter ?\\) "\\" ".") st) |
4131 |
(if ender (modify-syntax-entry ender "." st)) |
(if ender (modify-syntax-entry ender "." st)) |
4132 |
(setq set-st nil) |
(setq set-st nil) |
4133 |
(setq ender (cperl-forward-re lim end nil t st-l err-l |
(setq ender (cperl-forward-re lim end nil t st-l err-l |
4134 |
argument starter ender) |
argument starter ender) |
4158 |
(defvar font-lock-string-face) |
(defvar font-lock-string-face) |
4159 |
;;(defvar font-lock-reference-face) |
;;(defvar font-lock-reference-face) |
4160 |
(defvar font-lock-constant-face) |
(defvar font-lock-constant-face) |
4161 |
(defsubst cperl-postpone-fontification (b e type val &optional now) |
(defsubst cperl-postpone-fontification (b e type val &optional now) |
4162 |
;; Do after syntactic fontification? |
;; Do after syntactic fontification? |
4163 |
(if cperl-syntaxify-by-font-lock |
(if cperl-syntaxify-by-font-lock |
4164 |
(or now (put-text-property b e 'cperl-postpone (cons type val))) |
(or now (put-text-property b e 'cperl-postpone (cons type val))) |
4165 |
(put-text-property b e type val))) |
(put-text-property b e type val))) |
4166 |
|
|
4167 |
;;; Here is how the global structures (those which cannot be |
;;; Here is how the global structures (those which cannot be |
4168 |
;;; recognized locally) are marked: |
;;; recognized locally) are marked: |
4169 |
;; a) PODs: |
;; a) PODs: |
4170 |
;; Start-to-end is marked `in-pod' ==> t |
;; Start-to-end is marked `in-pod' ==> t |
4171 |
;; Each non-literal part is marked `syntax-type' ==> `pod' |
;; Each non-literal part is marked `syntax-type' ==> `pod' |
4172 |
;; Each literal part is marked `syntax-type' ==> `in-pod' |
;; Each literal part is marked `syntax-type' ==> `in-pod' |
4173 |
;; b) HEREs: |
;; b) HEREs: |
4174 |
;; Start-to-end is marked `here-doc-group' ==> t |
;; Start-to-end is marked `here-doc-group' ==> t |
4175 |
;; The body is marked `syntax-type' ==> `here-doc' |
;; The body is marked `syntax-type' ==> `here-doc' |
4176 |
;; The delimiter is marked `syntax-type' ==> `here-doc-delim' |
;; The delimiter is marked `syntax-type' ==> `here-doc-delim' |
4177 |
;; c) FORMATs: |
;; c) FORMATs: |
4178 |
;; After-initial-line--to-end is marked `syntax-type' ==> `format' |
;; After-initial-line--to-end is marked `syntax-type' ==> `format' |
4179 |
;; d) 'Q'uoted string: |
;; d) 'Q'uoted string: |
4180 |
;; part between markers inclusive is marked `syntax-type' ==> `string' |
;; part between markers inclusive is marked `syntax-type' ==> `string' |
4181 |
;; part between `q' and the first marker is marked `syntax-type' ==> `prestring' |
;; part between `q' and the first marker is marked `syntax-type' ==> `prestring' |
4182 |
|
|
4214 |
|
|
4215 |
(defun cperl-find-pods-heres (&optional min max non-inter end ignore-max) |
(defun cperl-find-pods-heres (&optional min max non-inter end ignore-max) |
4216 |
"Scans the buffer for hard-to-parse Perl constructions. |
"Scans the buffer for hard-to-parse Perl constructions. |
4217 |
If `cperl-pod-here-fontify' is not-nil after evaluation, will fontify |
If `cperl-pod-here-fontify' is not-nil after evaluation, will fontify |
4218 |
the sections using `cperl-pod-head-face', `cperl-pod-face', |
the sections using `cperl-pod-head-face', `cperl-pod-face', |
4219 |
`cperl-here-face'." |
`cperl-here-face'." |
4220 |
(interactive) |
(interactive) |
4221 |
(or min (setq min (point-min) |
(or min (setq min (point-min) |
4222 |
cperl-syntax-state nil |
cperl-syntax-state nil |
4223 |
cperl-syntax-done-to min)) |
cperl-syntax-done-to min)) |
4224 |
(or max (setq max (point-max))) |
(or max (setq max (point-max))) |
4225 |
(let* (face head-face here-face b e bb tag qtag b1 e1 argument i c tail tb |
(let* ((cperl-pod-here-fontify (eval cperl-pod-here-fontify)) go tmpend |
4226 |
is-REx is-x-REx REx-comment-start REx-comment-end was-comment i2 |
face head-face here-face b e bb tag qtag b1 e1 argument i c tail tb |
4227 |
(cperl-pod-here-fontify (eval cperl-pod-here-fontify)) go tmpend |
is-REx is-x-REx REx-comment-start REx-comment-end was-comment i2 |
4228 |
(case-fold-search nil) (inhibit-read-only t) (buffer-undo-list t) |
(case-fold-search nil) (inhibit-read-only t) (buffer-undo-list t) |
4229 |
(modified (buffer-modified-p)) |
(modified (buffer-modified-p)) |
4230 |
(after-change-functions nil) |
(after-change-functions nil) |
4231 |
(use-syntax-state (and cperl-syntax-state |
(use-syntax-state (and cperl-syntax-state |
4232 |
(>= min (car cperl-syntax-state)))) |
(>= min (car cperl-syntax-state)))) |
4233 |
(state-point (if use-syntax-state |
(state-point (if use-syntax-state |
4234 |
(car cperl-syntax-state) |
(car cperl-syntax-state) |
4235 |
(point-min))) |
(point-min))) |
4236 |
(state (if use-syntax-state |
(state (if use-syntax-state |
4237 |
(cdr cperl-syntax-state))) |
(cdr cperl-syntax-state))) |
4238 |
;; (st-l '(nil)) (err-l '(nil)) ; Would overwrite - propagates from a function call to a function call! |
;; (st-l '(nil)) (err-l '(nil)) ; Would overwrite - propagates from a function call to a function call! |
4239 |
(st-l (list nil)) (err-l (list nil)) |
(st-l (list nil)) (err-l (list nil)) |
4240 |
;; Somehow font-lock may be not loaded yet... |
;; Somehow font-lock may be not loaded yet... |
4241 |
(font-lock-string-face (if (boundp 'font-lock-string-face) |
(font-lock-string-face (if (boundp 'font-lock-string-face) |
4242 |
font-lock-string-face |
font-lock-string-face |
4243 |
'font-lock-string-face)) |
'font-lock-string-face)) |
4244 |
(font-lock-constant-face (if (boundp 'font-lock-constant-face) |
(font-lock-constant-face (if (boundp 'font-lock-constant-face) |
4245 |
font-lock-constant-face |
font-lock-constant-face |
4246 |
'font-lock-constant-face)) |
'font-lock-constant-face)) |
4247 |
(font-lock-function-name-face |
(font-lock-function-name-face |
4248 |
(if (boundp 'font-lock-function-name-face) |
(if (boundp 'font-lock-function-name-face) |
4249 |
font-lock-function-name-face |
font-lock-function-name-face |
4250 |
'font-lock-function-name-face)) |
'font-lock-function-name-face)) |
4251 |
(font-lock-comment-face |
(font-lock-comment-face |
4252 |
(if (boundp 'font-lock-comment-face) |
(if (boundp 'font-lock-comment-face) |
4253 |
font-lock-comment-face |
font-lock-comment-face |
4254 |
'font-lock-comment-face)) |
'font-lock-comment-face)) |
4255 |
(cperl-nonoverridable-face |
(cperl-nonoverridable-face |
4256 |
(if (boundp 'cperl-nonoverridable-face) |
(if (boundp 'cperl-nonoverridable-face) |
4257 |
cperl-nonoverridable-face |
cperl-nonoverridable-face |
4258 |
'cperl-nonoverridable-face)) |
'cperl-nonoverridable-face)) |
4259 |
(stop-point (if ignore-max |
(stop-point (if ignore-max |
4260 |
(point-max) |
(point-max) |
4261 |
max)) |
max)) |
4262 |
(search |
(search |
4263 |
|
(concat |
4264 |
|
"\\(\\`\n?\\|^\n\\)=" |
4265 |
|
"\\|" |
4266 |
|
;; One extra () before this: |
4267 |
|
"<<" |
4268 |
|
"\\(" ; 1 + 1 |
4269 |
|
;; First variant "BLAH" or just ``. |
4270 |
|
"[ \t]*" ; Yes, whitespace is allowed! |
4271 |
|
"\\([\"'`]\\)" ; 2 + 1 = 3 |
4272 |
|
"\\([^\"'`\n]*\\)" ; 3 + 1 |
4273 |
|
"\\3" |
4274 |
|
"\\|" |
4275 |
|
;; Second variant: Identifier or \ID or empty |
4276 |
|
"\\\\?\\(\\([a-zA-Z_][a-zA-Z_0-9]*\\)?\\)" ; 4 + 1, 5 + 1 |
4277 |
|
;; Do not have <<= or << 30 or <<30 or << $blah. |
4278 |
|
;; "\\([^= \t0-9$@%&]\\|[ \t]+[^ \t\n0-9$@%&]\\)" ; 6 + 1 |
4279 |
|
"\\(\\)" ; To preserve count of pars :-( 6 + 1 |
4280 |
|
"\\)" |
4281 |
|
"\\|" |
4282 |
|
;; 1+6 extra () before this: |
4283 |
|
"^[ \t]*\\(format\\)[ \t]*\\([a-zA-Z0-9_]+\\)?[ \t]*=[ \t]*$" |
4284 |
|
(if cperl-use-syntax-table-text-property |
4285 |
(concat |
(concat |
|
"\\(\\`\n?\\|^\n\\)=" |
|
4286 |
"\\|" |
"\\|" |
4287 |
;; One extra () before this: |
;; 1+6+2=9 extra () before this: |
4288 |
"<<" |
"\\<\\(q[wxqr]?\\|[msy]\\|tr\\)\\>" |
4289 |
"\\(" ; 1 + 1 |
"\\|" |
4290 |
;; First variant "BLAH" or just ``. |
;; 1+6+2+1=10 extra () before this: |
4291 |
"[ \t]*" ; Yes, whitespace is allowed! |
"\\([?/<]\\)" ; /blah/ or ?blah? or <file*glob> |
4292 |
"\\([\"'`]\\)" ; 2 + 1 = 3 |
"\\|" |
4293 |
"\\([^\"'`\n]*\\)" ; 3 + 1 |
;; 1+6+2+1+1=11 extra () before this: |
4294 |
"\\3" |
"\\<sub\\>[ \t]*\\([a-zA-Z_:'0-9]+[ \t]*\\)?\\(([^()]*)\\)" |
4295 |
"\\|" |
"\\|" |
4296 |
;; Second variant: Identifier or \ID or empty |
;; 1+6+2+1+1+2=13 extra () before this: |
4297 |
"\\\\?\\(\\([a-zA-Z_][a-zA-Z_0-9]*\\)?\\)" ; 4 + 1, 5 + 1 |
"\\$\\(['{]\\)" |
|
;; Do not have <<= or << 30 or <<30 or << $blah. |
|
|
;; "\\([^= \t0-9$@%&]\\|[ \t]+[^ \t\n0-9$@%&]\\)" ; 6 + 1 |
|
|
"\\(\\)" ; To preserve count of pars :-( 6 + 1 |
|
|
"\\)" |
|
4298 |
"\\|" |
"\\|" |
4299 |
;; 1+6 extra () before this: |
;; 1+6+2+1+1+2+1=14 extra () before this: |
4300 |
"^[ \t]*\\(format\\)[ \t]*\\([a-zA-Z0-9_]+\\)?[ \t]*=[ \t]*$" |
"\\(\\<sub[ \t\n\f]+\\|[&*$@%]\\)[a-zA-Z0-9_]*'" |
4301 |
(if cperl-use-syntax-table-text-property |
;; 1+6+2+1+1+2+1+1=15 extra () before this: |
4302 |
(concat |
"\\|" |
4303 |
"\\|" |
"__\\(END\\|DATA\\)__" |
4304 |
;; 1+6+2=9 extra () before this: |
;; 1+6+2+1+1+2+1+1+1=16 extra () before this: |
4305 |
"\\<\\(q[wxqr]?\\|[msy]\\|tr\\)\\>" |
"\\|" |
4306 |
"\\|" |
"\\\\\\(['`\"]\\)") |
4307 |
;; 1+6+2+1=10 extra () before this: |
"")))) |
|
"\\([?/<]\\)" ; /blah/ or ?blah? or <file*glob> |
|
|
"\\|" |
|
|
;; 1+6+2+1+1=11 extra () before this: |
|
|
"\\<sub\\>[ \t]*\\([a-zA-Z_:'0-9]+[ \t]*\\)?\\(([^()]*)\\)" |
|
|
"\\|" |
|
|
;; 1+6+2+1+1+2=13 extra () before this: |
|
|
"\\$\\(['{]\\)" |
|
|
"\\|" |
|
|
;; 1+6+2+1+1+2+1=14 extra () before this: |
|
|
"\\(\\<sub[ \t\n\f]+\\|[&*$@%]\\)[a-zA-Z0-9_]*'" |
|
|
;; 1+6+2+1+1+2+1+1=15 extra () before this: |
|
|
"\\|" |
|
|
"__\\(END\\|DATA\\)__" |
|
|
;; 1+6+2+1+1+2+1+1+1=16 extra () before this: |
|
|
"\\|" |
|
|
"\\\\\\(['`\"]\\)" |
|
|
) |
|
|
"")))) |
|
4308 |
(unwind-protect |
(unwind-protect |
4309 |
(progn |
(progn |
4310 |
(save-excursion |
(save-excursion |
4311 |
(or non-inter |
(or non-inter |
4312 |
(message "Scanning for \"hard\" Perl constructions...")) |
(message "Scanning for \"hard\" Perl constructions...")) |
4313 |
(and cperl-pod-here-fontify |
(and cperl-pod-here-fontify |
4314 |
;; We had evals here, do not know why... |
;; We had evals here, do not know why... |
4315 |
(setq face cperl-pod-face |
(setq face cperl-pod-face |
4316 |
head-face cperl-pod-head-face |
head-face cperl-pod-head-face |
4317 |
here-face cperl-here-face)) |
here-face cperl-here-face)) |
4318 |
(remove-text-properties min max |
(remove-text-properties min max |
4319 |
'(syntax-type t in-pod t syntax-table t |
'(syntax-type t in-pod t syntax-table t |
4320 |
cperl-postpone t |
cperl-postpone t |
4321 |
syntax-subtype t |
syntax-subtype t |
4325 |
(goto-char min) |
(goto-char min) |
4326 |
(and (eq system-type 'emx) |
(and (eq system-type 'emx) |
4327 |
(looking-at "extproc[ \t]") ; Analogue of #! |
(looking-at "extproc[ \t]") ; Analogue of #! |
4328 |
(cperl-commentify min |
(cperl-commentify min |
4329 |
(save-excursion (end-of-line) (point)) |
(save-excursion (end-of-line) (point)) |
4330 |
nil)) |
nil)) |
4331 |
(while (and |
(while (and |
4332 |
(< (point) max) |
(< (point) max) |
4333 |
(re-search-forward search max t)) |
(re-search-forward search max t)) |
4334 |
(setq tmpend nil) ; Valid for most cases |
(setq tmpend nil) ; Valid for most cases |
4335 |
(cond |
(cond |
4336 |
((match-beginning 1) ; POD section |
((match-beginning 1) ; POD section |
4337 |
;; "\\(\\`\n?\\|^\n\\)=" |
;; "\\(\\`\n?\\|^\n\\)=" |
4338 |
(if (looking-at "cut\\>") |
(if (looking-at "cut\\>") |
4339 |
(if ignore-max |
(if ignore-max |
4340 |
nil ; Doing a chunk only |
nil ; Doing a chunk only |
4341 |
(message "=cut is not preceded by a POD section") |
(message "=cut is not preceded by a POD section") |
4342 |
(or (car err-l) (setcar err-l (point)))) |
(or (car err-l) (setcar err-l (point)))) |
4343 |
(beginning-of-line) |
(beginning-of-line) |
4344 |
|
|
4345 |
(setq b (point) |
(setq b (point) |
4346 |
bb b |
bb b |
4347 |
tb (match-beginning 0) |
tb (match-beginning 0) |
4348 |
b1 nil) ; error condition |
b1 nil) ; error condition |
4360 |
(setq e (point)) |
(setq e (point)) |
4361 |
(and (> e max) |
(and (> e max) |
4362 |
(progn |
(progn |
4363 |
(remove-text-properties |
(remove-text-properties |
4364 |
max e '(syntax-type t in-pod t syntax-table t |
max e '(syntax-type t in-pod t syntax-table t |
4365 |
cperl-postpone t |
cperl-postpone t |
4366 |
syntax-subtype t |
syntax-subtype t |
4376 |
(put-text-property (cperl-1- b) (point) 'syntax-type 'pod) |
(put-text-property (cperl-1- b) (point) 'syntax-type 'pod) |
4377 |
(cperl-put-do-not-fontify b (point) t) |
(cperl-put-do-not-fontify b (point) t) |
4378 |
;; mark the non-literal parts as PODs |
;; mark the non-literal parts as PODs |
4379 |
(if cperl-pod-here-fontify |
(if cperl-pod-here-fontify |
4380 |
(cperl-postpone-fontification b (point) 'face face t)) |
(cperl-postpone-fontification b (point) 'face face t)) |
4381 |
(re-search-forward "\n\n[^ \t\f\n]" e 'toend) |
(re-search-forward "\n\n[^ \t\f\n]" e 'toend) |
4382 |
(beginning-of-line) |
(beginning-of-line) |
4383 |
(setq b (point))) |
(setq b (point))) |
4384 |
(put-text-property (cperl-1- (point)) e 'syntax-type 'pod) |
(put-text-property (cperl-1- (point)) e 'syntax-type 'pod) |
4385 |
(cperl-put-do-not-fontify (point) e t) |
(cperl-put-do-not-fontify (point) e t) |
4386 |
(if cperl-pod-here-fontify |
(if cperl-pod-here-fontify |
4387 |
(progn |
(progn |
4388 |
;; mark the non-literal parts as PODs |
;; mark the non-literal parts as PODs |
4389 |
(cperl-postpone-fontification (point) e 'face face t) |
(cperl-postpone-fontification (point) e 'face face t) |
4390 |
(goto-char bb) |
(goto-char bb) |
4391 |
(if (looking-at |
(if (looking-at |
4392 |
"=[a-zA-Z0-9_]+\\>[ \t]*\\(\\(\n?[^\n]\\)+\\)$") |
"=[a-zA-Z0-9_]+\\>[ \t]*\\(\\(\n?[^\n]\\)+\\)$") |
4393 |
;; mark the headers |
;; mark the headers |
4394 |
(cperl-postpone-fontification |
(cperl-postpone-fontification |
4395 |
(match-beginning 1) (match-end 1) |
(match-beginning 1) (match-end 1) |
4396 |
'face head-face)) |
'face head-face)) |
4397 |
(while (re-search-forward |
(while (re-search-forward |
4399 |
"^\n=[a-zA-Z0-9_]+\\>[ \t]*\\(\\(\n?[^\n]\\)+\\)$" |
"^\n=[a-zA-Z0-9_]+\\>[ \t]*\\(\\(\n?[^\n]\\)+\\)$" |
4400 |
e 'toend) |
e 'toend) |
4401 |
;; mark the headers |
;; mark the headers |
4402 |
(cperl-postpone-fontification |
(cperl-postpone-fontification |
4403 |
(match-beginning 1) (match-end 1) |
(match-beginning 1) (match-end 1) |
4404 |
'face head-face)))) |
'face head-face)))) |
4405 |
(cperl-commentify bb e nil) |
(cperl-commentify bb e nil) |
4406 |
(goto-char e) |
(goto-char e) |
4407 |
(or (eq e (point-max)) |
(or (eq e (point-max)) |
4408 |
(forward-char -1)))) ; Prepare for immediate pod start. |
(forward-char -1)))) ; Prepare for immediate POD start. |
4409 |
;; Here document |
;; Here document |
4410 |
;; We do only one here-per-line |
;; We do only one here-per-line |
4411 |
;; ;; One extra () before this: |
;; ;; One extra () before this: |
4412 |
;;"<<" |
;;"<<" |
4413 |
;; "\\(" ; 1 + 1 |
;; "\\(" ; 1 + 1 |
4414 |
;; ;; First variant "BLAH" or just ``. |
;; ;; First variant "BLAH" or just ``. |
4415 |
;; "\\([\"'`]\\)" ; 2 + 1 |
;; "\\([\"'`]\\)" ; 2 + 1 |
4429 |
state-point b |
state-point b |
4430 |
tb (match-beginning 0) |
tb (match-beginning 0) |
4431 |
i (or (nth 3 state) (nth 4 state))) |
i (or (nth 3 state) (nth 4 state))) |
4432 |
(if i |
(if i |
4433 |
(setq c t) |
(setq c t) |
4434 |
(setq c (and |
(setq c (and |
4435 |
(match-beginning 5) |
(match-beginning 5) |
4445 |
e1 (match-end 4))) ; 3 + 1 |
e1 (match-end 4))) ; 3 + 1 |
4446 |
(setq tag (buffer-substring b1 e1) |
(setq tag (buffer-substring b1 e1) |
4447 |
qtag (regexp-quote tag)) |
qtag (regexp-quote tag)) |
4448 |
(cond (cperl-pod-here-fontify |
(cond (cperl-pod-here-fontify |
4449 |
;; Highlight the starting delimiter |
;; Highlight the starting delimiter |
4450 |
(cperl-postpone-fontification b1 e1 'face font-lock-constant-face) |
(cperl-postpone-fontification b1 e1 'face font-lock-constant-face) |
4451 |
(cperl-put-do-not-fontify b1 e1 t))) |
(cperl-put-do-not-fontify b1 e1 t))) |
4453 |
(setq b (point)) |
(setq b (point)) |
4454 |
;; We do not search to max, since we may be called from |
;; We do not search to max, since we may be called from |
4455 |
;; some hook of fontification, and max is random |
;; some hook of fontification, and max is random |
4456 |
(cond ((re-search-forward (concat "^" qtag "$") |
(cond ((re-search-forward (concat "^" qtag "$") |
4457 |
stop-point 'toend) |
stop-point 'toend) |
4458 |
(if cperl-pod-here-fontify |
(if cperl-pod-here-fontify |
4459 |
(progn |
(progn |
4460 |
;; Highlight the ending delimiter |
;; Highlight the ending delimiter |
4461 |
(cperl-postpone-fontification (match-beginning 0) (match-end 0) |
(cperl-postpone-fontification (match-beginning 0) (match-end 0) |
4462 |
'face font-lock-constant-face) |
'face font-lock-constant-face) |
4463 |
(cperl-put-do-not-fontify b (match-end 0) t) |
(cperl-put-do-not-fontify b (match-end 0) t) |
4464 |
;; Highlight the HERE-DOC |
;; Highlight the HERE-DOC |
4465 |
(cperl-postpone-fontification b (match-beginning 0) |
(cperl-postpone-fontification b (match-beginning 0) |
4466 |
'face here-face))) |
'face here-face))) |
4467 |
(setq e1 (cperl-1+ (match-end 0))) |
(setq e1 (cperl-1+ (match-end 0))) |
4468 |
(put-text-property b (match-beginning 0) |
(put-text-property b (match-beginning 0) |
4469 |
'syntax-type 'here-doc) |
'syntax-type 'here-doc) |
4470 |
(put-text-property (match-beginning 0) e1 |
(put-text-property (match-beginning 0) e1 |
4471 |
'syntax-type 'here-doc-delim) |
'syntax-type 'here-doc-delim) |
4488 |
"") |
"") |
4489 |
tb (match-beginning 0)) |
tb (match-beginning 0)) |
4490 |
(setq argument nil) |
(setq argument nil) |
4491 |
(if cperl-pod-here-fontify |
(if cperl-pod-here-fontify |
4492 |
(while (and (eq (forward-line) 0) |
(while (and (eq (forward-line) 0) |
4493 |
(not (looking-at "^[.;]$"))) |
(not (looking-at "^[.;]$"))) |
4494 |
(cond |
(cond |
4495 |
((looking-at "^#")) ; Skip comments |
((looking-at "^#")) ; Skip comments |
4496 |
((and argument ; Skip argument multi-lines |
((and argument ; Skip argument multi-lines |
4497 |
(looking-at "^[ \t]*{")) |
(looking-at "^[ \t]*{")) |
4498 |
(forward-sexp 1) |
(forward-sexp 1) |
4499 |
(setq argument nil)) |
(setq argument nil)) |
4500 |
(argument ; Skip argument lines |
(argument ; Skip argument lines |
4504 |
(setq argument (looking-at "^[^\n]*[@^]")) |
(setq argument (looking-at "^[^\n]*[@^]")) |
4505 |
(end-of-line) |
(end-of-line) |
4506 |
;; Highlight the format line |
;; Highlight the format line |
4507 |
(cperl-postpone-fontification b1 (point) |
(cperl-postpone-fontification b1 (point) |
4508 |
'face font-lock-string-face) |
'face font-lock-string-face) |
4509 |
(cperl-commentify b1 (point) nil) |
(cperl-commentify b1 (point) nil) |
4510 |
(cperl-put-do-not-fontify b1 (point) t)))) |
(cperl-put-do-not-fontify b1 (point) t)))) |
4511 |
;; We do not search to max, since we may be called from |
;; We do not search to max, since we may be called from |
4512 |
;; some hook of fontification, and max is random |
;; some hook of fontification, and max is random |
4513 |
(re-search-forward "^[.;]$" stop-point 'toend)) |
(re-search-forward "^[.;]$" stop-point 'toend)) |
4514 |
(beginning-of-line) |
(beginning-of-line) |
4515 |
(if (looking-at "^\\.$") ; ";" is not supported yet |
(if (looking-at "^\\.$") ; ";" is not supported yet |
4516 |
(progn |
(progn |
4517 |
;; Highlight the ending delimiter |
;; Highlight the ending delimiter |
4518 |
(cperl-postpone-fontification (point) (+ (point) 2) |
(cperl-postpone-fontification (point) (+ (point) 2) |
4519 |
'face font-lock-string-face) |
'face font-lock-string-face) |
4520 |
(cperl-commentify (point) (+ (point) 2) nil) |
(cperl-commentify (point) (+ (point) 2) nil) |
4521 |
(cperl-put-do-not-fontify (point) (+ (point) 2) t)) |
(cperl-put-do-not-fontify (point) (+ (point) 2) t)) |
4522 |
(message "End of format `%s' not found." name) |
(message "End of format `%s' not found." name) |
4544 |
(memq bb '(?\$ ?\@ ?\% ?\* ?\#)) ; $#y |
(memq bb '(?\$ ?\@ ?\% ?\* ?\#)) ; $#y |
4545 |
(and (eq bb ?-) (eq c ?s)) ; -s file test |
(and (eq bb ?-) (eq c ?s)) ; -s file test |
4546 |
(and (eq bb ?\&) |
(and (eq bb ?\&) |
4547 |
(not (eq (char-after ; &&m/blah/ |
(not (eq (char-after ; &&m/blah/ |
4548 |
(- (match-beginning b1) 2)) |
(- (match-beginning b1) 2)) |
4549 |
?\&)))) |
?\&)))) |
4550 |
;; <file> or <$file> |
;; <file> or <$file> |
4551 |
(and (eq c ?\<) |
(and (eq c ?\<) |
4552 |
;; Do not stringify <FH>, <$fh> : |
;; Do not stringify <FH>, <$fh> : |
4553 |
(save-match-data |
(save-match-data |
4554 |
(looking-at |
(looking-at |
4555 |
"\\$?\\([_a-zA-Z:][_a-zA-Z0-9:]*\\)?>")))) |
"\\$?\\([_a-zA-Z:][_a-zA-Z0-9:]*\\)?>")))) |
4556 |
tb (match-beginning 0)) |
tb (match-beginning 0)) |
4557 |
(goto-char (match-beginning b1)) |
(goto-char (match-beginning b1)) |
4561 |
(setq argument "" |
(setq argument "" |
4562 |
bb ; Not a regexp? |
bb ; Not a regexp? |
4563 |
(progn |
(progn |
4564 |
(not |
(not |
4565 |
;; What is below: regexp-p? |
;; What is below: regexp-p? |
4566 |
(and |
(and |
4567 |
(or (memq (preceding-char) |
(or (memq (preceding-char) |
4582 |
(and |
(and |
4583 |
(not (memq (preceding-char) |
(not (memq (preceding-char) |
4584 |
'(?$ ?@ ?& ?%))) |
'(?$ ?@ ?& ?%))) |
4585 |
(looking-at |
(looking-at |
4586 |
"\\(while\\|if\\|unless\\|until\\|and\\|or\\|not\\|xor\\|split\\|grep\\|map\\|print\\)\\>"))))) |
"\\(while\\|if\\|unless\\|until\\|and\\|or\\|not\\|xor\\|split\\|grep\\|map\\|print\\)\\>"))))) |
4587 |
(and (eq (preceding-char) ?.) |
(and (eq (preceding-char) ?.) |
4588 |
(eq (char-after (- (point) 2)) ?.)) |
(eq (char-after (- (point) 2)) ?.)) |
4589 |
(bobp)) |
(bobp)) |
4590 |
;; m|blah| ? foo : bar; |
;; m|blah| ? foo : bar; |
4591 |
(not |
(not |
4592 |
(and (eq c ?\?) |
(and (eq c ?\?) |
4593 |
cperl-use-syntax-table-text-property |
cperl-use-syntax-table-text-property |
4594 |
(not (bobp)) |
(not (bobp)) |
4595 |
(progn |
(progn |
4596 |
(forward-char -1) |
(forward-char -1) |
4602 |
(eq (char-after (- (point) 2)) ?-)) |
(eq (char-after (- (point) 2)) ?-)) |
4603 |
;; Not a regexp |
;; Not a regexp |
4604 |
(setq bb t)))) |
(setq bb t)))) |
4605 |
(or bb (setq state (parse-partial-sexp |
(or bb (setq state (parse-partial-sexp |
4606 |
state-point b nil nil state) |
state-point b nil nil state) |
4607 |
state-point b)) |
state-point b)) |
4608 |
(goto-char b) |
(goto-char b) |
4627 |
t st-l err-l argument) |
t st-l err-l argument) |
4628 |
;; Note that if `go', then it is considered as 1-arg |
;; Note that if `go', then it is considered as 1-arg |
4629 |
b1 (nth 1 i) ; start of the second part |
b1 (nth 1 i) ; start of the second part |
4630 |
tag (nth 2 i) ; ender-char, true if second part |
tag (nth 2 i) ; ender-char, true if second part |
4631 |
; is with matching chars [] |
; is with matching chars [] |
4632 |
go (nth 4 i) ; There is a 1-char part after the end |
go (nth 4 i) ; There is a 1-char part after the end |
4633 |
i (car i) ; intermediate point |
i (car i) ; intermediate point |
4634 |
e1 (point) ; end |
e1 (point) ; end |
4635 |
;; Before end of the second part if non-matching: /// |
;; Before end of the second part if non-matching: /// |
4636 |
tail (if (and i (not tag)) |
tail (if (and i (not tag)) |
4637 |
(1- e1)) |
(1- e1)) |
4638 |
e (if i i e1) ; end of the first part |
e (if i i e1) ; end of the first part |
4639 |
qtag nil ; need to preserve backslashitis |
qtag nil ; need to preserve backslashitis |
4684 |
(progn |
(progn |
4685 |
(forward-word 1) ; skip modifiers s///s |
(forward-word 1) ; skip modifiers s///s |
4686 |
(if tail (cperl-commentify tail (point) t)) |
(if tail (cperl-commentify tail (point) t)) |
4687 |
(cperl-postpone-fontification |
(cperl-postpone-fontification |
4688 |
e1 (point) 'face 'cperl-nonoverridable-face))) |
e1 (point) 'face 'cperl-nonoverridable-face))) |
4689 |
;; Check whether it is m// which means "previous match" |
;; Check whether it is m// which means "previous match" |
4690 |
;; and highlight differently |
;; and highlight differently |
4691 |
(setq is-REx |
(setq is-REx |
4692 |
(and (string-match "^\\([sm]?\\|qr\\)$" argument) |
(and (string-match "^\\([sm]?\\|qr\\)$" argument) |
4693 |
(or (not (= (length argument) 0)) |
(or (not (= (length argument) 0)) |
4694 |
(not (eq c ?\<))))) |
(not (eq c ?\<))))) |
4695 |
(if (and is-REx |
(if (and is-REx |
4696 |
(eq e (+ 2 b)) |
(eq e (+ 2 b)) |
4697 |
;; split // *is* using zero-pattern |
;; split // *is* using zero-pattern |
4698 |
(save-excursion |
(save-excursion |
4702 |
(forward-sexp -1) |
(forward-sexp -1) |
4703 |
(not (looking-at "split\\>"))) |
(not (looking-at "split\\>"))) |
4704 |
(error t)))) |
(error t)))) |
4705 |
(cperl-postpone-fontification |
(cperl-postpone-fontification |
4706 |
b e 'face font-lock-function-name-face) |
b e 'face font-lock-function-name-face) |
4707 |
(if (or i2 ; Has 2 args |
(if (or i2 ; Has 2 args |
4708 |
(and cperl-fontify-m-as-s |
(and cperl-fontify-m-as-s |
4711 |
(and (eq 0 (length argument)) |
(and (eq 0 (length argument)) |
4712 |
(not (eq ?\< (char-after b))))))) |
(not (eq ?\< (char-after b))))))) |
4713 |
(progn |
(progn |
4714 |
(cperl-postpone-fontification |
(cperl-postpone-fontification |
4715 |
b (cperl-1+ b) 'face font-lock-constant-face) |
b (cperl-1+ b) 'face font-lock-constant-face) |
4716 |
(cperl-postpone-fontification |
(cperl-postpone-fontification |
4717 |
(1- e) e 'face font-lock-constant-face))) |
(1- e) e 'face font-lock-constant-face))) |
4718 |
(if (and is-REx cperl-regexp-scan) |
(if (and is-REx cperl-regexp-scan) |
4719 |
;; Process RExen better |
;; Process RExen better |
4725 |
(if is-x-REx |
(if is-x-REx |
4726 |
(if (eq (char-after b) ?\#) |
(if (eq (char-after b) ?\#) |
4727 |
"\\((\\?\\\\#\\)\\|\\(\\\\#\\)" |
"\\((\\?\\\\#\\)\\|\\(\\\\#\\)" |
4728 |
"\\((\\?#\\)\\|\\(#\\)") |
"\\((\\?#\\)\\|\\(#\\)") |
4729 |
(if (eq (char-after b) ?\#) |
(if (eq (char-after b) ?\#) |
4730 |
"\\((\\?\\\\#\\)" |
"\\((\\?\\\\#\\)" |
4731 |
"\\((\\?#\\)")) |
"\\((\\?#\\)")) |
4732 |
(1- e) 'to-end)) |
(1- e) 'to-end)) |
4733 |
(goto-char (match-beginning 0)) |
(goto-char (match-beginning 0)) |
4734 |
(setq REx-comment-start (point) |
(setq REx-comment-start (point) |
4742 |
(progn (setq was-comment nil) |
(progn (setq was-comment nil) |
4743 |
(forward-char 1)) |
(forward-char 1)) |
4744 |
(if (match-beginning 2) |
(if (match-beginning 2) |
4745 |
(progn |
(progn |
4746 |
(beginning-of-line 2) |
(beginning-of-line 2) |
4747 |
(if (> (point) e) |
(if (> (point) e) |
4748 |
(goto-char (1- e)))) |
(goto-char (1- e)))) |
4758 |
(setq REx-comment-end (point)) |
(setq REx-comment-end (point)) |
4759 |
(cperl-commentify |
(cperl-commentify |
4760 |
REx-comment-start REx-comment-end nil) |
REx-comment-start REx-comment-end nil) |
4761 |
(cperl-postpone-fontification |
(cperl-postpone-fontification |
4762 |
REx-comment-start REx-comment-end |
REx-comment-start REx-comment-end |
4763 |
'face font-lock-comment-face)))))) |
'face font-lock-comment-face)))))) |
4764 |
(if (and is-REx is-x-REx) |
(if (and is-REx is-x-REx) |
4765 |
(put-text-property (1+ b) (1- e) |
(put-text-property (1+ b) (1- e) |
4766 |
'syntax-subtype 'x-REx))) |
'syntax-subtype 'x-REx))) |
4767 |
(if i2 |
(if i2 |
4768 |
(progn |
(progn |
4769 |
(cperl-postpone-fontification |
(cperl-postpone-fontification |
4770 |
(1- e1) e1 'face font-lock-constant-face) |
(1- e1) e1 'face font-lock-constant-face) |
4771 |
(if (assoc (char-after b) cperl-starters) |
(if (assoc (char-after b) cperl-starters) |
4772 |
(cperl-postpone-fontification |
(cperl-postpone-fontification |
4773 |
b1 (1+ b1) 'face font-lock-constant-face)))) |
b1 (1+ b1) 'face font-lock-constant-face)))) |
4774 |
(if (> (point) max) |
(if (> (point) max) |
4775 |
(setq tmpend tb)))) |
(setq tmpend tb)))) |
4778 |
(if (memq (char-after (1- b)) |
(if (memq (char-after (1- b)) |
4779 |
'(?\$ ?\@ ?\% ?\& ?\*)) |
'(?\$ ?\@ ?\% ?\& ?\*)) |
4780 |
nil |
nil |
4781 |
(setq state (parse-partial-sexp |
(setq state (parse-partial-sexp |
4782 |
state-point b nil nil state) |
state-point b nil nil state) |
4783 |
state-point b) |
state-point b) |
4784 |
(if (or (nth 3 state) (nth 4 state)) |
(if (or (nth 3 state) (nth 4 state)) |
4791 |
((and (match-beginning 14) |
((and (match-beginning 14) |
4792 |
(eq (preceding-char) ?\')) ; $' |
(eq (preceding-char) ?\')) ; $' |
4793 |
(setq b (1- (point)) |
(setq b (1- (point)) |
4794 |
state (parse-partial-sexp |
state (parse-partial-sexp |
4795 |
state-point (1- b) nil nil state) |
state-point (1- b) nil nil state) |
4796 |
state-point (1- b)) |
state-point (1- b)) |
4797 |
(if (nth 3 state) ; in string |
(if (nth 3 state) ; in string |
4807 |
((match-beginning 15) ; old $abc'efg syntax |
((match-beginning 15) ; old $abc'efg syntax |
4808 |
(setq bb (match-end 0) |
(setq bb (match-end 0) |
4809 |
b (match-beginning 0) |
b (match-beginning 0) |
4810 |
state (parse-partial-sexp |
state (parse-partial-sexp |
4811 |
state-point b nil nil state) |
state-point b nil nil state) |
4812 |
state-point b) |
state-point b) |
4813 |
(if (nth 3 state) ; in string |
(if (nth 3 state) ; in string |
4819 |
((match-beginning 16) ; __END__, __DATA__ |
((match-beginning 16) ; __END__, __DATA__ |
4820 |
(setq bb (match-end 0) |
(setq bb (match-end 0) |
4821 |
b (match-beginning 0) |
b (match-beginning 0) |
4822 |
state (parse-partial-sexp |
state (parse-partial-sexp |
4823 |
state-point b nil nil state) |
state-point b nil nil state) |
4824 |
state-point b) |
state-point b) |
4825 |
(if (or (nth 3 state) (nth 4 state)) |
(if (or (nth 3 state) (nth 4 state)) |
4834 |
(goto-char b) |
(goto-char b) |
4835 |
(skip-chars-backward "\\\\") |
(skip-chars-backward "\\\\") |
4836 |
;;;(setq i2 (= (% (skip-chars-backward "\\\\") 2) -1)) |
;;;(setq i2 (= (% (skip-chars-backward "\\\\") 2) -1)) |
4837 |
(setq state (parse-partial-sexp |
(setq state (parse-partial-sexp |
4838 |
state-point b nil nil state) |
state-point b nil nil state) |
4839 |
state-point b) |
state-point b) |
4840 |
(if (or (nth 3 state) (nth 4 state) ) |
(if (or (nth 3 state) (nth 4 state) ) |
4844 |
(t (error "Error in regexp of the sniffer"))) |
(t (error "Error in regexp of the sniffer"))) |
4845 |
(if (> (point) stop-point) |
(if (> (point) stop-point) |
4846 |
(progn |
(progn |
4847 |
(if end |
(if end |
4848 |
(message "Garbage after __END__/__DATA__ ignored") |
(message "Garbage after __END__/__DATA__ ignored") |
4849 |
(message "Unbalanced syntax found while scanning") |
(message "Unbalanced syntax found while scanning") |
4850 |
(or (car err-l) (setcar err-l b))) |
(or (car err-l) (setcar err-l b))) |
4870 |
(if (memq (setq pr (get-text-property (point) 'syntax-type)) |
(if (memq (setq pr (get-text-property (point) 'syntax-type)) |
4871 |
'(pod here-doc here-doc-delim)) |
'(pod here-doc here-doc-delim)) |
4872 |
(cperl-unwind-to-safe nil) |
(cperl-unwind-to-safe nil) |
4873 |
(if (or (looking-at "^[ \t]*\\(#\\|$\\)") |
(or (looking-at "^[ \t]*\\(#\\|$\\)") |
4874 |
(progn (cperl-to-comment-or-eol) (bolp))) |
(progn (cperl-to-comment-or-eol) (bolp)) |
4875 |
nil ; Only comment, skip |
(progn |
4876 |
;; Else |
(skip-chars-backward " \t") |
4877 |
(skip-chars-backward " \t") |
(if (< p (point)) (goto-char p)) |
4878 |
(if (< p (point)) (goto-char p)) |
(setq stop t))))))) |
|
(setq stop t)))))) |
|
4879 |
|
|
4880 |
(defun cperl-after-block-p (lim) |
(defun cperl-after-block-p (lim) |
4881 |
;; We suppose that the preceding char is }. |
;; We suppose that the preceding char is }. |
4901 |
(error nil)))) |
(error nil)))) |
4902 |
|
|
4903 |
(defun cperl-after-expr-p (&optional lim chars test) |
(defun cperl-after-expr-p (&optional lim chars test) |
4904 |
"Returns true if the position is good for start of expression. |
"Return true if the position is good for start of expression. |
4905 |
TEST is the expression to evaluate at the found position. If absent, |
TEST is the expression to evaluate at the found position. If absent, |
4906 |
CHARS is a string that contains good characters to have before us (however, |
CHARS is a string that contains good characters to have before us (however, |
4907 |
`}' is treated \"smartly\" if it is not in the list)." |
`}' is treated \"smartly\" if it is not in the list)." |
4908 |
(let (stop p |
(let ((lim (or lim (point-min))) |
4909 |
(lim (or lim (point-min)))) |
stop p) |
4910 |
(save-excursion |
(save-excursion |
4911 |
(while (and (not stop) (> (point) lim)) |
(while (and (not stop) (> (point) lim)) |
4912 |
(skip-chars-backward " \t\n\f" lim) |
(skip-chars-backward " \t\n\f" lim) |
4914 |
(beginning-of-line) |
(beginning-of-line) |
4915 |
(if (looking-at "^[ \t]*\\(#\\|$\\)") nil ; Only comment, skip |
(if (looking-at "^[ \t]*\\(#\\|$\\)") nil ; Only comment, skip |
4916 |
;; Else: last iteration, or a label |
;; Else: last iteration, or a label |
4917 |
(cperl-to-comment-or-eol) |
(cperl-to-comment-or-eol) |
4918 |
(skip-chars-backward " \t") |
(skip-chars-backward " \t") |
4919 |
(if (< p (point)) (goto-char p)) |
(if (< p (point)) (goto-char p)) |
4920 |
(setq p (point)) |
(setq p (point)) |
4945 |
|
|
4946 |
(defun cperl-after-block-and-statement-beg (lim) |
(defun cperl-after-block-and-statement-beg (lim) |
4947 |
;; We assume that we are after ?\} |
;; We assume that we are after ?\} |
4948 |
(and |
(and |
4949 |
(cperl-after-block-p lim) |
(cperl-after-block-p lim) |
4950 |
(save-excursion |
(save-excursion |
4951 |
(forward-sexp -1) |
(forward-sexp -1) |
4955 |
(not (= (char-syntax (preceding-char)) ?w)) |
(not (= (char-syntax (preceding-char)) ?w)) |
4956 |
(progn |
(progn |
4957 |
(forward-sexp -1) |
(forward-sexp -1) |
4958 |
(not |
(not |
4959 |
(looking-at |
(looking-at |
4960 |
"\\(map\\|grep\\|printf?\\|system\\|exec\\|tr\\|s\\)\\>"))))))) |
"\\(map\\|grep\\|printf?\\|system\\|exec\\|tr\\|s\\)\\>"))))))) |
4961 |
|
|
4969 |
Will not indent comment if it starts at `comment-indent' or looks like |
Will not indent comment if it starts at `comment-indent' or looks like |
4970 |
continuation of the comment on the previous line. |
continuation of the comment on the previous line. |
4971 |
|
|
4972 |
If `cperl-indent-region-fix-constructs', will improve spacing on |
If `cperl-indent-region-fix-constructs', will improve spacing on |
4973 |
conditional/loop constructs." |
conditional/loop constructs." |
4974 |
(interactive) |
(interactive) |
4975 |
(save-excursion |
(save-excursion |
5002 |
(interactive) |
(interactive) |
5003 |
(or end |
(or end |
5004 |
(setq end (point-max))) |
(setq end (point-max))) |
5005 |
(let (p pp ml have-brace ret |
(let ((ee (save-excursion (end-of-line) (point))) |
5006 |
(ee (save-excursion (end-of-line) (point))) |
(cperl-indent-region-fix-constructs |
5007 |
(cperl-indent-region-fix-constructs |
(or cperl-indent-region-fix-constructs 1)) |
5008 |
(or cperl-indent-region-fix-constructs 1))) |
p pp ml have-brace ret) |
5009 |
(save-excursion |
(save-excursion |
5010 |
(beginning-of-line) |
(beginning-of-line) |
5011 |
(setq ret (point)) |
(setq ret (point)) |
5012 |
;; }? continue |
;; }? continue |
5013 |
;; blah; } |
;; blah; } |
5014 |
(if (not |
(if (not |
5015 |
(or (looking-at "[ \t]*\\(els\\(e\\|if\\)\\|continue\\|if\\|while\\|for\\(each\\)?\\|until\\)") |
(or (looking-at "[ \t]*\\(els\\(e\\|if\\)\\|continue\\|if\\|while\\|for\\(each\\)?\\|until\\)") |
5016 |
(setq have-brace (save-excursion (search-forward "}" ee t))))) |
(setq have-brace (save-excursion (search-forward "}" ee t))))) |
5017 |
nil ; Do not need to do anything |
nil ; Do not need to do anything |
5018 |
;; Looking at: |
;; Looking at: |
5019 |
;; } |
;; } |
5020 |
;; else |
;; else |
5021 |
(if (and cperl-merge-trailing-else |
(if (and cperl-merge-trailing-else |
5022 |
(looking-at |
(looking-at |
5023 |
"[ \t]*}[ \t]*\n[ \t\n]*\\(els\\(e\\|if\\)\\|continue\\)\\>")) |
"[ \t]*}[ \t]*\n[ \t\n]*\\(els\\(e\\|if\\)\\|continue\\)\\>")) |
5024 |
(progn |
(progn |
5025 |
(search-forward "}") |
(search-forward "}") |
5026 |
(setq p (point)) |
(setq p (point)) |
5027 |
(skip-chars-forward " \t\n") |
(skip-chars-forward " \t\n") |
5028 |
(delete-region p (point)) |
(delete-region p (point)) |
5029 |
(insert (make-string cperl-indent-region-fix-constructs ?\ )) |
(insert (make-string cperl-indent-region-fix-constructs ?\ )) |
5030 |
(beginning-of-line))) |
(beginning-of-line))) |
5031 |
;; Looking at: |
;; Looking at: |
5032 |
;; } else |
;; } else |
5033 |
(if (looking-at "[ \t]*}\\(\t*\\|[ \t][ \t]+\\)\\<\\(els\\(e\\|if\\)\\|continue\\)\\>") |
(if (looking-at "[ \t]*}\\(\t*\\|[ \t][ \t]+\\)\\<\\(els\\(e\\|if\\)\\|continue\\)\\>") |
5034 |
(progn |
(progn |
5035 |
(search-forward "}") |
(search-forward "}") |
5036 |
(delete-horizontal-space) |
(delete-horizontal-space) |
5037 |
(insert (make-string cperl-indent-region-fix-constructs ?\ )) |
(insert (make-string cperl-indent-region-fix-constructs ?\ )) |
5038 |
(beginning-of-line))) |
(beginning-of-line))) |
5039 |
;; Looking at: |
;; Looking at: |
5040 |
;; else { |
;; else { |
5041 |
(if (looking-at |
(if (looking-at |
5042 |
"[ \t]*}?[ \t]*\\<\\(\\els\\(e\\|if\\)\\|continue\\|unless\\|if\\|while\\|for\\(each\\)?\\|until\\)\\>\\(\t*\\|[ \t][ \t]+\\)[^ \t\n#]") |
"[ \t]*}?[ \t]*\\<\\(\\els\\(e\\|if\\)\\|continue\\|unless\\|if\\|while\\|for\\(each\\)?\\|until\\)\\>\\(\t*\\|[ \t][ \t]+\\)[^ \t\n#]") |
5043 |
(progn |
(progn |
5044 |
(forward-word 1) |
(forward-word 1) |
5045 |
(delete-horizontal-space) |
(delete-horizontal-space) |
5046 |
(insert (make-string cperl-indent-region-fix-constructs ?\ )) |
(insert (make-string cperl-indent-region-fix-constructs ?\ )) |
5047 |
(beginning-of-line))) |
(beginning-of-line))) |
5048 |
;; Looking at: |
;; Looking at: |
5049 |
;; foreach my $var |
;; foreach my $var |
5050 |
(if (looking-at |
(if (looking-at |
5051 |
"[ \t]*\\<for\\(each\\)?[ \t]+\\(my\\|local\\|our\\)\\(\t*\\|[ \t][ \t]+\\)[^ \t\n]") |
"[ \t]*\\<for\\(each\\)?[ \t]+\\(my\\|local\\|our\\)\\(\t*\\|[ \t][ \t]+\\)[^ \t\n]") |
5052 |
(progn |
(progn |
5053 |
(forward-word 2) |
(forward-word 2) |
5054 |
(delete-horizontal-space) |
(delete-horizontal-space) |
5055 |
(insert (make-string cperl-indent-region-fix-constructs ?\ )) |
(insert (make-string cperl-indent-region-fix-constructs ?\ )) |
5056 |
(beginning-of-line))) |
(beginning-of-line))) |
5057 |
;; Looking at: |
;; Looking at: |
5058 |
;; foreach my $var ( |
;; foreach my $var ( |
5059 |
(if (looking-at |
(if (looking-at |
5060 |
"[ \t]*\\<for\\(each\\)?[ \t]+\\(my\\|local\\|our\\)[ \t]*\\$[_a-zA-Z0-9]+\\(\t*\\|[ \t][ \t]+\\)[^ \t\n#]") |
"[ \t]*\\<for\\(each\\)?[ \t]+\\(my\\|local\\|our\\)[ \t]*\\$[_a-zA-Z0-9]+\\(\t*\\|[ \t][ \t]+\\)[^ \t\n#]") |
5061 |
(progn |
(progn |
5062 |
(forward-word 3) |
(forward-word 3) |
5063 |
(delete-horizontal-space) |
(delete-horizontal-space) |
5064 |
(insert |
(insert |
5065 |
(make-string cperl-indent-region-fix-constructs ?\ )) |
(make-string cperl-indent-region-fix-constructs ?\ )) |
5066 |
(beginning-of-line))) |
(beginning-of-line))) |
5067 |
;; Looking at: |
;; Looking at: |
5068 |
;; } foreach my $var () { |
;; } foreach my $var () { |
5069 |
(if (looking-at |
(if (looking-at |
5070 |
"[ \t]*\\(}[ \t]*\\)?\\<\\(\\els\\(e\\|if\\)\\|continue\\|if\\|unless\\|while\\|for\\(each\\)?\\(\\([ t]+\\(my\\|local\\|our\\)\\)?[ \t]*\\$[_a-zA-Z0-9]+\\)?\\|until\\)\\>\\([ \t]*(\\|[ \t\n]*{\\)\\|[ \t]*{") |
"[ \t]*\\(}[ \t]*\\)?\\<\\(\\els\\(e\\|if\\)\\|continue\\|if\\|unless\\|while\\|for\\(each\\)?\\(\\([ \t]+\\(my\\|local\\|our\\)\\)?[ \t]*\\$[_a-zA-Z0-9]+\\)?\\|until\\)\\>\\([ \t]*(\\|[ \t\n]*{\\)\\|[ \t]*{") |
5071 |
(progn |
(progn |
5072 |
(setq ml (match-beginning 8)) |
(setq ml (match-beginning 8)) |
5073 |
(re-search-forward "[({]") |
(re-search-forward "[({]") |
5074 |
(forward-char -1) |
(forward-char -1) |
5075 |
(setq p (point)) |
(setq p (point)) |
5076 |
(if (eq (following-char) ?\( ) |
(if (eq (following-char) ?\( ) |
5077 |
(progn |
(progn |
5078 |
(forward-sexp 1) |
(forward-sexp 1) |
5079 |
(setq pp (point))) |
(setq pp (point))) |
5080 |
;; after `else' or nothing |
;; after `else' or nothing |
5081 |
(if ml ; after `else' |
(if ml ; after `else' |
5082 |
(skip-chars-backward " \t\n") |
(skip-chars-backward " \t\n") |
5083 |
(beginning-of-line)) |
(beginning-of-line)) |
5084 |
(setq pp nil)) |
(setq pp nil)) |
5085 |
;; Now after the sexp before the brace |
;; Now after the sexp before the brace |
5086 |
;; Multiline expr should be special |
;; Multiline expr should be special |
5087 |
(setq ml (and pp (save-excursion (goto-char p) |
(setq ml (and pp (save-excursion (goto-char p) |
5088 |
(search-forward "\n" pp t)))) |
(search-forward "\n" pp t)))) |
5089 |
(if (and (or (not pp) (< pp end)) |
(if (and (or (not pp) (< pp end)) |
5090 |
(looking-at "[ \t\n]*{")) |
(looking-at "[ \t\n]*{")) |
5091 |
(progn |
(progn |
5092 |
(cond |
(cond |
5093 |
((bolp) ; Were before `{', no if/else/etc |
((bolp) ; Were before `{', no if/else/etc |
5094 |
nil) |
nil) |
5095 |
((looking-at "\\(\t*\\| [ \t]+\\){") |
((looking-at "\\(\t*\\| [ \t]+\\){") |
5096 |
(delete-horizontal-space) |
(delete-horizontal-space) |
5097 |
(if (if ml |
(if (if ml |
5098 |
cperl-extra-newline-before-brace-multiline |
cperl-extra-newline-before-brace-multiline |
5099 |
cperl-extra-newline-before-brace) |
cperl-extra-newline-before-brace) |
5100 |
(progn |
(progn |
5101 |
(delete-horizontal-space) |
(delete-horizontal-space) |
5102 |
(insert "\n") |
(insert "\n") |
5103 |
(setq ret (point)) |
(setq ret (point)) |
5104 |
(if (cperl-indent-line parse-data) |
(if (cperl-indent-line parse-data) |
5105 |
(progn |
(progn |
5106 |
(cperl-fix-line-spacing end parse-data) |
(cperl-fix-line-spacing end parse-data) |
5107 |
(setq ret (point))))) |
(setq ret (point))))) |
5108 |
|
(insert |
5109 |
|
(make-string cperl-indent-region-fix-constructs ?\ )))) |
5110 |
|
((and (looking-at "[ \t]*\n") |
5111 |
|
(not (if ml |
5112 |
|
cperl-extra-newline-before-brace-multiline |
5113 |
|
cperl-extra-newline-before-brace))) |
5114 |
|
(setq pp (point)) |
5115 |
|
(skip-chars-forward " \t\n") |
5116 |
|
(delete-region pp (point)) |
5117 |
(insert |
(insert |
5118 |
(make-string cperl-indent-region-fix-constructs ?\ )))) |
(make-string cperl-indent-region-fix-constructs ?\ )))) |
5119 |
((and (looking-at "[ \t]*\n") |
;; Now we are before `{' |
5120 |
(not (if ml |
(if (looking-at "[ \t\n]*{[ \t]*[^ \t\n#]") |
5121 |
cperl-extra-newline-before-brace-multiline |
(progn |
5122 |
cperl-extra-newline-before-brace))) |
(skip-chars-forward " \t\n") |
5123 |
(setq pp (point)) |
(setq pp (point)) |
5124 |
(skip-chars-forward " \t\n") |
(forward-sexp 1) |
5125 |
(delete-region pp (point)) |
(setq p (point)) |
5126 |
(insert |
(goto-char pp) |
5127 |
(make-string cperl-indent-region-fix-constructs ?\ )))) |
(setq ml (search-forward "\n" p t)) |
5128 |
;; Now we are before `{' |
(if (or cperl-break-one-line-blocks-when-indent ml) |
5129 |
(if (looking-at "[ \t\n]*{[ \t]*[^ \t\n#]") |
;; not good: multi-line BLOCK |
5130 |
(progn |
(progn |
5131 |
(skip-chars-forward " \t\n") |
(goto-char (1+ pp)) |
5132 |
(setq pp (point)) |
(delete-horizontal-space) |
5133 |
(forward-sexp 1) |
(insert "\n") |
5134 |
(setq p (point)) |
(setq ret (point)) |
5135 |
(goto-char pp) |
(if (cperl-indent-line parse-data) |
5136 |
(setq ml (search-forward "\n" p t)) |
(setq ret (cperl-fix-line-spacing end parse-data))))))))))) |
5137 |
(if (or cperl-break-one-line-blocks-when-indent ml) |
(beginning-of-line) |
5138 |
;; not good: multi-line BLOCK |
(setq p (point) pp (save-excursion (end-of-line) (point))) ; May be different from ee. |
5139 |
(progn |
;; Now check whether there is a hanging `}' |
5140 |
(goto-char (1+ pp)) |
;; Looking at: |
5141 |
(delete-horizontal-space) |
;; } blah |
5142 |
(insert "\n") |
(if (and |
5143 |
(setq ret (point)) |
cperl-fix-hanging-brace-when-indent |
5144 |
(if (cperl-indent-line parse-data) |
have-brace |
5145 |
(setq ret (cperl-fix-line-spacing end parse-data))))))))))) |
(not (looking-at "[ \t]*}[ \t]*\\(\\<\\(els\\(if\\|e\\)\\|continue\\|while\\|until\\)\\>\\|$\\|#\\)")) |
5146 |
(beginning-of-line) |
(condition-case nil |
5147 |
(setq p (point) pp (save-excursion (end-of-line) (point))) ; May be different from ee. |
(progn |
5148 |
;; Now check whether there is a hanging `}' |
(up-list 1) |
5149 |
;; Looking at: |
(if (and (<= (point) pp) |
5150 |
;; } blah |
(eq (preceding-char) ?\} ) |
5151 |
(if (and |
(cperl-after-block-and-statement-beg (point-min))) |
5152 |
cperl-fix-hanging-brace-when-indent |
t |
5153 |
have-brace |
(goto-char p) |
5154 |
(not (looking-at "[ \t]*}[ \t]*\\(\\<\\(els\\(if\\|e\\)\\|continue\\|while\\|until\\)\\>\\|$\\|#\\)")) |
nil)) |
5155 |
(condition-case nil |
(error nil))) |
5156 |
(progn |
(progn |
5157 |
(up-list 1) |
(forward-char -1) |
5158 |
(if (and (<= (point) pp) |
(skip-chars-backward " \t") |
5159 |
(eq (preceding-char) ?\} ) |
(if (bolp) |
5160 |
(cperl-after-block-and-statement-beg (point-min))) |
;; `}' was the first thing on the line, insert NL *after* it. |
5161 |
t |
(progn |
5162 |
(goto-char p) |
(cperl-indent-line parse-data) |
5163 |
nil)) |
(search-forward "}") |
5164 |
(error nil))) |
(delete-horizontal-space) |
5165 |
(progn |
(insert "\n")) |
5166 |
(forward-char -1) |
(delete-horizontal-space) |
5167 |
(skip-chars-backward " \t") |
(or (eq (preceding-char) ?\;) |
5168 |
(if (bolp) |
(bolp) |
5169 |
;; `}' was the first thing on the line, insert NL *after* it. |
(and (eq (preceding-char) ?\} ) |
5170 |
(progn |
(cperl-after-block-p (point-min))) |
5171 |
(cperl-indent-line parse-data) |
(insert ";")) |
5172 |
(search-forward "}") |
(insert "\n") |
5173 |
(delete-horizontal-space) |
(setq ret (point))) |
5174 |
(insert "\n")) |
(if (cperl-indent-line parse-data) |
5175 |
(delete-horizontal-space) |
(setq ret (cperl-fix-line-spacing end parse-data))) |
5176 |
(or (eq (preceding-char) ?\;) |
(beginning-of-line))))) |
|
(bolp) |
|
|
(and (eq (preceding-char) ?\} ) |
|
|
(cperl-after-block-p (point-min))) |
|
|
(insert ";")) |
|
|
(insert "\n") |
|
|
(setq ret (point))) |
|
|
(if (cperl-indent-line parse-data) |
|
|
(setq ret (cperl-fix-line-spacing end parse-data))) |
|
|
(beginning-of-line))))) |
|
5177 |
ret)) |
ret)) |
5178 |
|
|
5179 |
(defvar cperl-update-start) ; Do not need to make them local |
(defvar cperl-update-start) ; Do not need to make them local |
5184 |
|
|
5185 |
(defun cperl-indent-region (start end) |
(defun cperl-indent-region (start end) |
5186 |
"Simple variant of indentation of region in CPerl mode. |
"Simple variant of indentation of region in CPerl mode. |
5187 |
Should be slow. Will not indent comment if it starts at `comment-indent' |
Should be slow. Will not indent comment if it starts at `comment-indent' |
5188 |
or looks like continuation of the comment on the previous line. |
or looks like continuation of the comment on the previous line. |
5189 |
Indents all the lines whose first character is between START and END |
Indents all the lines whose first character is between START and END |
5190 |
inclusive. |
inclusive. |
5191 |
|
|
5192 |
If `cperl-indent-region-fix-constructs', will improve spacing on |
If `cperl-indent-region-fix-constructs', will improve spacing on |
5193 |
conditional/loop constructs." |
conditional/loop constructs." |
5194 |
(interactive "r") |
(interactive "r") |
5195 |
(cperl-update-syntaxification end end) |
(cperl-update-syntaxification end end) |
5196 |
(save-excursion |
(save-excursion |
5197 |
(let (cperl-update-start cperl-update-end (h-a-c after-change-functions)) |
(let (cperl-update-start cperl-update-end (h-a-c after-change-functions)) |
5198 |
(let (st comm old-comm-indent new-comm-indent p pp i empty |
(let ((indent-info (if cperl-emacs-can-parse |
5199 |
(indent-info (if cperl-emacs-can-parse |
(list nil nil nil) ; Cannot use '(), since will modify |
5200 |
(list nil nil nil) ; Cannot use '(), since will modify |
nil)) |
5201 |
nil)) |
(pm 0) (imenu-scanning-message "Indenting... (%3d%%)") |
5202 |
after-change-functions ; Speed it up! |
after-change-functions ; Speed it up! |
5203 |
(pm 0) (imenu-scanning-message "Indenting... (%3d%%)")) |
st comm old-comm-indent new-comm-indent p pp i empty) |
5204 |
(if h-a-c (add-hook 'after-change-functions 'cperl-delay-update-hook)) |
(if h-a-c (add-hook 'after-change-functions 'cperl-delay-update-hook)) |
5205 |
(goto-char start) |
(goto-char start) |
5206 |
(setq old-comm-indent (and (cperl-to-comment-or-eol) |
(setq old-comm-indent (and (cperl-to-comment-or-eol) |
5213 |
(message "Indenting... For feedback load `imenu'...")) |
(message "Indenting... For feedback load `imenu'...")) |
5214 |
(while (and (<= (point) end) (not (eobp))) ; bol to check start |
(while (and (<= (point) end) (not (eobp))) ; bol to check start |
5215 |
(and (fboundp 'imenu-progress-message) |
(and (fboundp 'imenu-progress-message) |
5216 |
(imenu-progress-message |
(imenu-progress-message |
5217 |
pm (/ (* 100 (- (point) start)) (- end start -1)))) |
pm (/ (* 100 (- (point) start)) (- end start -1)))) |
5218 |
(setq st (point)) |
(setq st (point)) |
5219 |
(if (or |
(if (or |
5220 |
(setq empty (looking-at "[ \t]*\n")) |
(setq empty (looking-at "[ \t]*\n")) |
5221 |
(and (setq comm (looking-at "[ \t]*#")) |
(and (setq comm (looking-at "[ \t]*#")) |
5222 |
(or (eq (current-indentation) (or old-comm-indent |
(or (eq (current-indentation) (or old-comm-indent |
5223 |
comment-column)) |
comment-column)) |
5224 |
(setq old-comm-indent nil)))) |
(setq old-comm-indent nil)))) |
5225 |
(if (and old-comm-indent |
(if (and old-comm-indent |
5230 |
cperl-st-cfence))) |
cperl-st-cfence))) |
5231 |
(let ((comment-column new-comm-indent)) |
(let ((comment-column new-comm-indent)) |
5232 |
(indent-for-comment))) |
(indent-for-comment))) |
5233 |
(progn |
(progn |
5234 |
(setq i (cperl-indent-line indent-info)) |
(setq i (cperl-indent-line indent-info)) |
5235 |
(or comm |
(or comm |
5236 |
(not i) |
(not i) |
5237 |
(progn |
(progn |
5238 |
(if cperl-indent-region-fix-constructs |
(if cperl-indent-region-fix-constructs |
5239 |
(goto-char (cperl-fix-line-spacing end indent-info))) |
(goto-char (cperl-fix-line-spacing end indent-info))) |
5240 |
(if (setq old-comm-indent |
(if (setq old-comm-indent |
5241 |
(and (cperl-to-comment-or-eol) |
(and (cperl-to-comment-or-eol) |
5242 |
(not (memq (get-text-property (point) |
(not (memq (get-text-property (point) |
5243 |
'syntax-type) |
'syntax-type) |
5244 |
'(pod here-doc))) |
'(pod here-doc))) |
5245 |
(not (eq (get-text-property (point) |
(not (eq (get-text-property (point) |
5246 |
'syntax-table) |
'syntax-table) |
5247 |
cperl-st-cfence)) |
cperl-st-cfence)) |
5248 |
(current-column))) |
(current-column))) |
5255 |
(imenu-progress-message pm 100) |
(imenu-progress-message pm 100) |
5256 |
(message nil))) |
(message nil))) |
5257 |
;; Now run the update hooks |
;; Now run the update hooks |
5258 |
(if after-change-functions |
(and after-change-functions |
5259 |
(save-excursion |
cperl-update-end |
5260 |
(if cperl-update-end |
(save-excursion |
5261 |
(progn |
(goto-char cperl-update-end) |
5262 |
(goto-char cperl-update-end) |
(insert " ") |
5263 |
(insert " ") |
(delete-char -1) |
5264 |
(delete-char -1) |
(goto-char cperl-update-start) |
5265 |
(goto-char cperl-update-start) |
(insert " ") |
5266 |
(insert " ") |
(delete-char -1)))))) |
|
(delete-char -1)))))))) |
|
5267 |
|
|
5268 |
;; Stolen from lisp-mode with a lot of improvements |
;; Stolen from lisp-mode with a lot of improvements |
5269 |
|
|
5273 |
block of it that point is in, preserving the comment's initial |
block of it that point is in, preserving the comment's initial |
5274 |
indentation and initial hashes. Behaves usually outside of comment." |
indentation and initial hashes. Behaves usually outside of comment." |
5275 |
(interactive "P") |
(interactive "P") |
5276 |
(let ( |
(let (;; Non-nil if the current line contains a comment. |
|
;; Non-nil if the current line contains a comment. |
|
5277 |
has-comment |
has-comment |
5278 |
|
|
5279 |
;; If has-comment, the appropriate fill-prefix for the comment. |
;; If has-comment, the appropriate fill-prefix for the comment. |
5298 |
((cperl-to-comment-or-eol) |
((cperl-to-comment-or-eol) |
5299 |
(setq has-comment t) |
(setq has-comment t) |
5300 |
(looking-at "#+[ \t]*") |
(looking-at "#+[ \t]*") |
5301 |
(setq start (point) c (current-column) |
(setq start (point) c (current-column) |
5302 |
comment-fill-prefix |
comment-fill-prefix |
5303 |
(concat (make-string (current-column) ?\ ) |
(concat (make-string (current-column) ?\ ) |
5304 |
(buffer-substring (match-beginning 0) (match-end 0))) |
(buffer-substring (match-beginning 0) (match-end 0))) |
5305 |
spaces (progn (skip-chars-backward " \t") |
spaces (progn (skip-chars-backward " \t") |
5306 |
(buffer-substring (point) start)) |
(buffer-substring (point) start)) |
5307 |
dc (- c (current-column)) len (- start (point)) |
dc (- c (current-column)) len (- start (point)) |
5308 |
start (point-marker)) |
start (point-marker)) |
5309 |
(delete-char len) |
(delete-char len) |
5310 |
(insert (make-string dc ?-))))) |
(insert (make-string dc ?-))))) |
5311 |
(if (not has-comment) |
(if (not has-comment) |
5312 |
(fill-paragraph justify) ; Do the usual thing outside of comment |
(fill-paragraph justify) ; Do the usual thing outside of comment |
5313 |
;; Narrow to include only the comment, and then fill the region. |
;; Narrow to include only the comment, and then fill the region. |
5314 |
(save-restriction |
(save-restriction |
5315 |
(narrow-to-region |
(narrow-to-region |
5331 |
(goto-char (point-min)) |
(goto-char (point-min)) |
5332 |
(while (progn (forward-line 1) (< (point) (point-max))) |
(while (progn (forward-line 1) (< (point) (point-max))) |
5333 |
(skip-chars-forward " \t") |
(skip-chars-forward " \t") |
5334 |
(and (looking-at "#+") |
(and (looking-at "#+") |
5335 |
(delete-char (- (match-end 0) (match-beginning 0))))) |
(delete-char (- (match-end 0) (match-beginning 0))))) |
5336 |
|
|
5337 |
;; Lines with only hashes on them can be paragraph boundaries. |
;; Lines with only hashes on them can be paragraph boundaries. |
5340 |
(fill-prefix comment-fill-prefix)) |
(fill-prefix comment-fill-prefix)) |
5341 |
(fill-paragraph justify))) |
(fill-paragraph justify))) |
5342 |
(if (and start) |
(if (and start) |
5343 |
(progn |
(progn |
5344 |
(goto-char start) |
(goto-char start) |
5345 |
(if (> dc 0) |
(if (> dc 0) |
5346 |
(progn (delete-char dc) (insert spaces))) |
(progn (delete-char dc) (insert spaces))) |
5347 |
(if (or (= (current-column) c) iteration) nil |
(if (or (= (current-column) c) iteration) nil |
5348 |
(setq comment-column c) |
(setq comment-column c) |
5349 |
(indent-for-comment) |
(indent-for-comment) |
5356 |
(end-of-line) |
(end-of-line) |
5357 |
(current-column)) |
(current-column)) |
5358 |
fill-column) |
fill-column) |
5359 |
(let ((c (save-excursion (beginning-of-line) |
(let ((c (save-excursion (beginning-of-line) |
5360 |
(cperl-to-comment-or-eol) (point))) |
(cperl-to-comment-or-eol) (point))) |
5361 |
(s (memq (following-char) '(?\ ?\t))) marker) |
(s (memq (following-char) '(?\ ?\t))) marker) |
5362 |
(if (>= c (point)) nil |
(if (>= c (point)) nil |
5363 |
(setq marker (point-marker)) |
(setq marker (point-marker)) |
5364 |
(cperl-fill-paragraph) |
(cperl-fill-paragraph) |
5365 |
(goto-char marker) |
(goto-char marker) |
5366 |
;; Is not enough, sometimes marker is a start of line |
;; Is not enough, sometimes marker is a start of line |
5367 |
(if (bolp) (progn (re-search-forward "#+[ \t]*") |
(if (bolp) (progn (re-search-forward "#+[ \t]*") |
5368 |
(goto-char (match-end 0)))) |
(goto-char (match-end 0)))) |
5369 |
;; Following space could have gone: |
;; Following space could have gone: |
5370 |
(if (or (not s) (memq (following-char) '(?\ ?\t))) nil |
(if (or (not s) (memq (following-char) '(?\ ?\t))) nil |
5371 |
(insert " ") |
(insert " ") |
5372 |
(backward-char 1)) |
(backward-char 1)) |
5373 |
;; Previous space could have gone: |
;; Previous space could have gone: |
5374 |
(or (memq (preceding-char) '(?\ ?\t)) (insert " ")))))) |
(or (memq (preceding-char) '(?\ ?\t)) (insert " ")))))) |
|
|
|
|
(defvar imenu-example--function-name-regexp-perl |
|
|
(concat |
|
|
"^\\(" |
|
|
"[ \t]*\\(sub\\|package\\)[ \t\n]+\\([a-zA-Z_0-9:']+\\)[ \t]*\\(([^()]*)[ \t]*\\)?" |
|
|
"\\|" |
|
|
"=head\\([12]\\)[ \t]+\\([^\n]+\\)$" |
|
|
"\\)")) |
|
5375 |
|
|
5376 |
(defun cperl-imenu-addback (lst &optional isback name) |
(defun cperl-imenu-addback (lst &optional isback name) |
5377 |
;; We suppose that the lst is a DAG, unless the first element only |
;; We suppose that the lst is a DAG, unless the first element only |
5379 |
;; applied twice without ISBACK set. |
;; applied twice without ISBACK set. |
5380 |
(cond ((not cperl-imenu-addback) lst) |
(cond ((not cperl-imenu-addback) lst) |
5381 |
(t |
(t |
5382 |
(or name |
(or name |
5383 |
(setq name "+++BACK+++")) |
(setq name "+++BACK+++")) |
5384 |
(mapcar (function (lambda (elt) |
(mapcar (lambda (elt) |
5385 |
(if (and (listp elt) (listp (cdr elt))) |
(if (and (listp elt) (listp (cdr elt))) |
5386 |
(progn |
(progn |
5387 |
;; In the other order it goes up |
;; In the other order it goes up |
5388 |
;; one level only ;-( |
;; one level only ;-( |
5389 |
(setcdr elt (cons (cons name lst) |
(setcdr elt (cons (cons name lst) |
5390 |
(cdr elt))) |
(cdr elt))) |
5391 |
(cperl-imenu-addback (cdr elt) t name) |
(cperl-imenu-addback (cdr elt) t name)))) |
|
)))) |
|
5392 |
(if isback (cdr lst) lst)) |
(if isback (cdr lst) lst)) |
5393 |
lst))) |
lst))) |
5394 |
|
|
5395 |
(defun imenu-example--create-perl-index (&optional regexp) |
(defun cperl-imenu--create-perl-index (&optional regexp) |
5396 |
(require 'cl) |
(require 'cl) |
5397 |
(require 'imenu) ; May be called from TAGS creator |
(require 'imenu) ; May be called from TAGS creator |
5398 |
(let ((index-alist '()) (index-pack-alist '()) (index-pod-alist '()) |
(let ((index-alist '()) (index-pack-alist '()) (index-pod-alist '()) |
5399 |
(index-unsorted-alist '()) (i-s-f (default-value 'imenu-sort-function)) |
(index-unsorted-alist '()) (i-s-f (default-value 'imenu-sort-function)) |
5400 |
(index-meth-alist '()) meth |
(index-meth-alist '()) meth |
5401 |
packages ends-ranges p marker |
packages ends-ranges p marker |
5408 |
;; Search for the function |
;; Search for the function |
5409 |
(progn ;;save-match-data |
(progn ;;save-match-data |
5410 |
(while (re-search-forward |
(while (re-search-forward |
5411 |
(or regexp imenu-example--function-name-regexp-perl) |
(or regexp cperl-imenu--function-name-regexp-perl) |
5412 |
nil t) |
nil t) |
5413 |
(or noninteractive |
(or noninteractive |
5414 |
(imenu-progress-message prev-pos)) |
(imenu-progress-message prev-pos)) |
5417 |
(match-beginning 2) ; package or sub |
(match-beginning 2) ; package or sub |
5418 |
(eq (char-after (match-beginning 2)) ?p) ; package |
(eq (char-after (match-beginning 2)) ?p) ; package |
5419 |
(not (save-match-data |
(not (save-match-data |
5420 |
(looking-at "[ \t\n]*;")))) ; Plain text word 'package' |
(looking-at "[ \t\n]*;")))) ; Plain text word 'package' |
5421 |
nil) |
nil) |
5422 |
((and |
((and |
5423 |
(match-beginning 2) ; package or sub |
(match-beginning 2) ; package or sub |
5427 |
(null (get-text-property (match-beginning 1) 'in-pod))) |
(null (get-text-property (match-beginning 1) 'in-pod))) |
5428 |
(save-excursion |
(save-excursion |
5429 |
(goto-char (match-beginning 2)) |
(goto-char (match-beginning 2)) |
5430 |
(setq fchar (following-char)) |
(setq fchar (following-char))) |
|
) |
|
5431 |
;; (if (looking-at "([^()]*)[ \t\n\f]*") |
;; (if (looking-at "([^()]*)[ \t\n\f]*") |
5432 |
;; (goto-char (match-end 0))) ; Messes what follows |
;; (goto-char (match-end 0))) ; Messes what follows |
5433 |
(setq char (following-char) ; ?\; for "sub foo () ;" |
(setq char (following-char) ; ?\; for "sub foo () ;" |
5443 |
name (progn |
name (progn |
5444 |
(set-text-properties 0 (length name) nil name) |
(set-text-properties 0 (length name) nil name) |
5445 |
name) |
name) |
5446 |
package (concat name "::") |
package (concat name "::") |
5447 |
name (concat "package " name) |
name (concat "package " name) |
5448 |
end-range |
end-range |
5449 |
(save-excursion |
(save-excursion |
5450 |
(parse-partial-sexp (point) (point-max) -1) (point)) |
(parse-partial-sexp (point) (point-max) -1) (point)) |
5451 |
ends-ranges (cons end-range ends-ranges) |
ends-ranges (cons end-range ends-ranges) |
5457 |
marker (make-marker)) |
marker (make-marker)) |
5458 |
(set-text-properties 0 (length name) nil name) |
(set-text-properties 0 (length name) nil name) |
5459 |
(set-marker marker (match-end 3)) |
(set-marker marker (match-end 3)) |
5460 |
(if (eq fchar ?p) |
(if (eq fchar ?p) |
5461 |
(setq name (concat "package " name)) |
(setq name (concat "package " name)) |
5462 |
(cond ((string-match "[:']" name) |
(cond ((string-match "[:']" name) |
5463 |
(setq meth t)) |
(setq meth t)) |
5464 |
((> p end-range) nil) |
((> p end-range) nil) |
5465 |
(t |
(t |
5466 |
(setq name (concat package name) meth t)))) |
(setq name (concat package name) meth t)))) |
5467 |
(setq index (cons name marker)) |
(setq index (cons name marker)) |
5468 |
(if (eq fchar ?p) |
(if (eq fchar ?p) |
5469 |
(push index index-pack-alist) |
(push index index-pack-alist) |
5470 |
(push index index-alist)) |
(push index index-alist)) |
5471 |
(if meth (push index index-meth-alist)) |
(if meth (push index index-meth-alist)) |
5472 |
(push index index-unsorted-alist))) |
(push index index-unsorted-alist))) |
5473 |
((match-beginning 5) ; Pod section |
((match-beginning 5) ; POD section |
5474 |
;; (beginning-of-line) |
;; (beginning-of-line) |
5475 |
(setq index (imenu-example--name-and-position) |
(setq index (imenu-example--name-and-position) |
5476 |
name (buffer-substring (match-beginning 6) (match-end 6))) |
name (buffer-substring (match-beginning 6) (match-end 6))) |
5483 |
(push index1 index-unsorted-alist))))) |
(push index1 index-unsorted-alist))))) |
5484 |
(or noninteractive |
(or noninteractive |
5485 |
(imenu-progress-message prev-pos 100)) |
(imenu-progress-message prev-pos 100)) |
5486 |
(setq index-alist |
(setq index-alist |
5487 |
(if (default-value 'imenu-sort-function) |
(if (default-value 'imenu-sort-function) |
5488 |
(sort index-alist (default-value 'imenu-sort-function)) |
(sort index-alist (default-value 'imenu-sort-function)) |
5489 |
(nreverse index-alist))) |
(nreverse index-alist))) |
5490 |
(and index-pod-alist |
(and index-pod-alist |
5491 |
(push (cons "+POD headers+..." |
(push (cons "+POD headers+..." |
5492 |
(nreverse index-pod-alist)) |
(nreverse index-pod-alist)) |
5503 |
(setq elt (car lst) lst (cdr lst)) |
(setq elt (car lst) lst (cdr lst)) |
5504 |
(cond ((string-match "\\(::\\|'\\)[_a-zA-Z0-9]+$" (car elt)) |
(cond ((string-match "\\(::\\|'\\)[_a-zA-Z0-9]+$" (car elt)) |
5505 |
(setq pack (substring (car elt) 0 (match-beginning 0))) |
(setq pack (substring (car elt) 0 (match-beginning 0))) |
5506 |
(if (setq group (assoc pack hier-list)) |
(if (setq group (assoc pack hier-list)) |
5507 |
(if (listp (cdr group)) |
(if (listp (cdr group)) |
5508 |
;; Have some functions already |
;; Have some functions already |
5509 |
(setcdr group |
(setcdr group |
5510 |
(cons (cons (substring |
(cons (cons (substring |
5511 |
(car elt) |
(car elt) |
5512 |
(+ 2 (match-beginning 0))) |
(+ 2 (match-beginning 0))) |
5513 |
(cdr elt)) |
(cdr elt)) |
5514 |
(cdr group))) |
(cdr group))) |
5515 |
(setcdr group (list (cons (substring |
(setcdr group (list (cons (substring |
5516 |
(car elt) |
(car elt) |
5517 |
(+ 2 (match-beginning 0))) |
(+ 2 (match-beginning 0))) |
5518 |
(cdr elt))))) |
(cdr elt))))) |
5519 |
(setq hier-list |
(setq hier-list |
5520 |
(cons (cons pack |
(cons (cons pack |
5521 |
(list (cons (substring |
(list (cons (substring |
5522 |
(car elt) |
(car elt) |
5523 |
(+ 2 (match-beginning 0))) |
(+ 2 (match-beginning 0))) |
5524 |
(cdr elt)))) |
(cdr elt)))) |
5530 |
(push (cons "+Packages+..." |
(push (cons "+Packages+..." |
5531 |
(nreverse index-pack-alist)) |
(nreverse index-pack-alist)) |
5532 |
index-alist)) |
index-alist)) |
5533 |
(and (or index-pack-alist index-pod-alist |
(and (or index-pack-alist index-pod-alist |
5534 |
(default-value 'imenu-sort-function)) |
(default-value 'imenu-sort-function)) |
5535 |
index-unsorted-alist |
index-unsorted-alist |
5536 |
(push (cons "+Unsorted List+..." |
(push (cons "+Unsorted List+..." |
5539 |
(cperl-imenu-addback index-alist))) |
(cperl-imenu-addback index-alist))) |
5540 |
|
|
5541 |
|
|
|
(defvar cperl-outline-regexp |
|
|
(concat imenu-example--function-name-regexp-perl "\\|" "\\`")) |
|
|
|
|
5542 |
;; Suggested by Mark A. Hershberger |
;; Suggested by Mark A. Hershberger |
5543 |
(defun cperl-outline-level () |
(defun cperl-outline-level () |
5544 |
(looking-at outline-regexp) |
(looking-at outline-regexp) |
5554 |
(t 3))) ; should not happen |
(t 3))) ; should not happen |
5555 |
|
|
5556 |
|
|
5557 |
(defvar cperl-compilation-error-regexp-alist |
(defvar cperl-compilation-error-regexp-alist |
5558 |
;; This look like a paranoiac regexp: could anybody find a better one? (which WORK). |
;; This look like a paranoiac regexp: could anybody find a better one? (which WORK). |
5559 |
'(("^[^\n]* \\(file\\|at\\) \\([^ \t\n]+\\) [^\n]*line \\([0-9]+\\)[\\., \n]" |
'(("^[^\n]* \\(file\\|at\\) \\([^ \t\n]+\\) [^\n]*line \\([0-9]+\\)[\\., \n]" |
5560 |
2 3)) |
2 3)) |
5562 |
|
|
5563 |
(if (fboundp 'eval-after-load) |
(if (fboundp 'eval-after-load) |
5564 |
(eval-after-load |
(eval-after-load |
5565 |
"mode-compile" |
"mode-compile" |
5566 |
'(setq perl-compilation-error-regexp-alist |
'(setq perl-compilation-error-regexp-alist |
5567 |
cperl-compilation-error-regexp-alist))) |
cperl-compilation-error-regexp-alist))) |
5568 |
|
|
5569 |
|
|
5570 |
(defun cperl-windowed-init () |
(defun cperl-windowed-init () |
5575 |
(add-hook 'font-lock-mode-hook |
(add-hook 'font-lock-mode-hook |
5576 |
(function |
(function |
5577 |
(lambda () |
(lambda () |
5578 |
(if (or |
(if (memq major-mode '(perl-mode cperl-mode)) |
|
(eq major-mode 'perl-mode) |
|
|
(eq major-mode 'cperl-mode)) |
|
5579 |
(progn |
(progn |
5580 |
(or cperl-faces-init (cperl-init-faces))))))) |
(or cperl-faces-init (cperl-init-faces))))))) |
5581 |
(if (fboundp 'eval-after-load) |
(if (fboundp 'eval-after-load) |
5582 |
(eval-after-load |
(eval-after-load |
5583 |
"ps-print" |
"ps-print" |
5584 |
'(or cperl-faces-init (cperl-init-faces)))))) |
'(or cperl-faces-init (cperl-init-faces)))))) |
5585 |
|
|
5586 |
(defun cperl-load-font-lock-keywords () |
(defun cperl-load-font-lock-keywords () |
5587 |
(or cperl-faces-init (cperl-init-faces)) |
(or cperl-faces-init (cperl-init-faces)) |
5622 |
(let (t-font-lock-keywords t-font-lock-keywords-1 font-lock-anchored) |
(let (t-font-lock-keywords t-font-lock-keywords-1 font-lock-anchored) |
5623 |
(if (fboundp 'font-lock-fontify-anchored-keywords) |
(if (fboundp 'font-lock-fontify-anchored-keywords) |
5624 |
(setq font-lock-anchored t)) |
(setq font-lock-anchored t)) |
5625 |
(setq |
(setq |
5626 |
t-font-lock-keywords |
t-font-lock-keywords |
5627 |
(list |
(list |
5628 |
(list "[ \t]+$" 0 cperl-invalid-face t) |
(list "[ \t]+$" 0 cperl-invalid-face t) |
5675 |
;; "telldir" "time" "times" "truncate" "uc" "ucfirst" |
;; "telldir" "time" "times" "truncate" "uc" "ucfirst" |
5676 |
;; "umask" "unlink" "unpack" "utime" "values" "vec" |
;; "umask" "unlink" "unpack" "utime" "values" "vec" |
5677 |
;; "wait" "waitpid" "wantarray" "warn" "write" "x" "xor" |
;; "wait" "waitpid" "wantarray" "warn" "write" "x" "xor" |
5678 |
"a\\(bs\\|ccept\\|tan2\\|larm\\|nd\\)\\|" |
"a\\(bs\\|ccept\\|tan2\\|larm\\|nd\\)\\|" |
5679 |
"b\\(in\\(d\\|mode\\)\\|less\\)\\|" |
"b\\(in\\(d\\|mode\\)\\|less\\)\\|" |
5680 |
"c\\(h\\(r\\(\\|oot\\)\\|dir\\|mod\\|own\\)\\|aller\\|rypt\\|" |
"c\\(h\\(r\\(\\|oot\\)\\|dir\\|mod\\|own\\)\\|aller\\|rypt\\|" |
5681 |
"lose\\(\\|dir\\)\\|mp\\|o\\(s\\|n\\(tinue\\|nect\\)\\)\\)\\|" |
"lose\\(\\|dir\\)\\|mp\\|o\\(s\\|n\\(tinue\\|nect\\)\\)\\)\\|" |
5746 |
'("^[ \t]*format[ \t]+\\([a-zA-z_][a-zA-z_0-9:]*\\)[ \t]*=[ \t]*$" |
'("^[ \t]*format[ \t]+\\([a-zA-z_][a-zA-z_0-9:]*\\)[ \t]*=[ \t]*$" |
5747 |
1 font-lock-function-name-face) |
1 font-lock-function-name-face) |
5748 |
(cond ((featurep 'font-lock-extra) |
(cond ((featurep 'font-lock-extra) |
5749 |
'("\\([]}\\\\%@>*&]\\|\\$[a-zA-Z0-9_:]*\\)[ \t]*{[ \t]*\\(-?[a-zA-Z0-9_:]+\\)[ \t]*}" |
'("\\([]}\\\\%@>*&]\\|\\$[a-zA-Z0-9_:]*\\)[ \t]*{[ \t]*\\(-?[a-zA-Z0-9_:]+\\)[ \t]*}" |
5750 |
(2 font-lock-string-face t) |
(2 font-lock-string-face t) |
5751 |
(0 '(restart 2 t)))) ; To highlight $a{bc}{ef} |
(0 '(restart 2 t)))) ; To highlight $a{bc}{ef} |
5752 |
(font-lock-anchored |
(font-lock-anchored |
5759 |
2 font-lock-string-face t))) |
2 font-lock-string-face t))) |
5760 |
'("[\[ \t{,(]\\(-?[a-zA-Z0-9_:]+\\)[ \t]*=>" 1 |
'("[\[ \t{,(]\\(-?[a-zA-Z0-9_:]+\\)[ \t]*=>" 1 |
5761 |
font-lock-string-face t) |
font-lock-string-face t) |
5762 |
'("^[ \t]*\\([a-zA-Z0-9_]+[ \t]*:\\)[ \t]*\\($\\|{\\|\\<\\(until\\|while\\|for\\(each\\)?\\|do\\)\\>\\)" 1 |
'("^[ \t]*\\([a-zA-Z0-9_]+[ \t]*:\\)[ \t]*\\($\\|{\\|\\<\\(until\\|while\\|for\\(each\\)?\\|do\\)\\>\\)" 1 |
5763 |
font-lock-constant-face) ; labels |
font-lock-constant-face) ; labels |
5764 |
'("\\<\\(continue\\|next\\|last\\|redo\\|goto\\)\\>[ \t]+\\([a-zA-Z0-9_:]+\\)" ; labels as targets |
'("\\<\\(continue\\|next\\|last\\|redo\\|goto\\)\\>[ \t]+\\([a-zA-Z0-9_:]+\\)" ; labels as targets |
5765 |
2 font-lock-constant-face) |
2 font-lock-constant-face) |
5766 |
;; Uncomment to get perl-mode-like vars |
;; Uncomment to get perl-mode-like vars |
5773 |
(4 '(another 4 nil |
(4 '(another 4 nil |
5774 |
("\\=[ \t]*,[ \t]*\\([$@%*][a-zA-Z0-9_:]+\\)\\([ \t]*,\\)?" |
("\\=[ \t]*,[ \t]*\\([$@%*][a-zA-Z0-9_:]+\\)\\([ \t]*,\\)?" |
5775 |
(1 font-lock-variable-name-face) |
(1 font-lock-variable-name-face) |
5776 |
(2 '(restart 2 nil) nil t))) |
(2 '(restart 2 nil) nil t))) |
5777 |
nil t))) ; local variables, multiple |
nil t))) ; local variables, multiple |
5778 |
(font-lock-anchored |
(font-lock-anchored |
5779 |
'("^[ \t{}]*\\(my\\|local\\|our\\)[ \t]*\\(([ \t]*\\)?\\([$@%*][a-zA-Z0-9_:]+\\)" |
'("^[ \t{}]*\\(my\\|local\\|our\\)[ \t]*\\(([ \t]*\\)?\\([$@%*][a-zA-Z0-9_:]+\\)" |
5785 |
3 font-lock-variable-name-face))) |
3 font-lock-variable-name-face))) |
5786 |
'("\\<for\\(each\\)?\\([ \t]+\\(my\\|local\\|our\\)\\)?[ \t]*\\(\\$[a-zA-Z_][a-zA-Z_0-9]*\\)[ \t]*(" |
'("\\<for\\(each\\)?\\([ \t]+\\(my\\|local\\|our\\)\\)?[ \t]*\\(\\$[a-zA-Z_][a-zA-Z_0-9]*\\)[ \t]*(" |
5787 |
4 font-lock-variable-name-face))) |
4 font-lock-variable-name-face))) |
5788 |
(setq |
(setq |
5789 |
t-font-lock-keywords-1 |
t-font-lock-keywords-1 |
5790 |
(and (fboundp 'turn-on-font-lock) ; Check for newer font-lock |
(and (fboundp 'turn-on-font-lock) ; Check for newer font-lock |
5791 |
(not cperl-xemacs-p) ; not yet as of XEmacs 19.12 |
(not cperl-xemacs-p) ; not yet as of XEmacs 19.12 |
5792 |
'( |
'( |
5793 |
("\\(\\([@%]\\|\$#\\)[a-zA-Z_:][a-zA-Z0-9_:]*\\)" 1 |
("\\(\\([@%]\\|\$#\\)[a-zA-Z_:][a-zA-Z0-9_:]*\\)" 1 |
5794 |
(if (eq (char-after (match-beginning 2)) ?%) |
(if (eq (char-after (match-beginning 2)) ?%) |
5797 |
t) ; arrays and hashes |
t) ; arrays and hashes |
5798 |
("\\(\\([$@]+\\)[a-zA-Z_:][a-zA-Z0-9_:]*\\)[ \t]*\\([[{]\\)" |
("\\(\\([$@]+\\)[a-zA-Z_:][a-zA-Z0-9_:]*\\)[ \t]*\\([[{]\\)" |
5799 |
1 |
1 |
5800 |
(if (= (- (match-end 2) (match-beginning 2)) 1) |
(if (= (- (match-end 2) (match-beginning 2)) 1) |
5801 |
(if (eq (char-after (match-beginning 3)) ?{) |
(if (eq (char-after (match-beginning 3)) ?{) |
5802 |
cperl-hash-face |
cperl-hash-face |
5803 |
cperl-array-face) ; arrays and hashes |
cperl-array-face) ; arrays and hashes |
5805 |
t) |
t) |
5806 |
;;("\\([smy]\\|tr\\)\\([^a-z_A-Z0-9]\\)\\(\\([^\n\\]*||\\)\\)\\2") |
;;("\\([smy]\\|tr\\)\\([^a-z_A-Z0-9]\\)\\(\\([^\n\\]*||\\)\\)\\2") |
5807 |
;;; Too much noise from \s* @s[ and friends |
;;; Too much noise from \s* @s[ and friends |
5808 |
;;("\\(\\<\\([msy]\\|tr\\)[ \t]*\\([^ \t\na-zA-Z0-9_]\\)\\|\\(/\\)\\)" |
;;("\\(\\<\\([msy]\\|tr\\)[ \t]*\\([^ \t\na-zA-Z0-9_]\\)\\|\\(/\\)\\)" |
5809 |
;;(3 font-lock-function-name-face t t) |
;;(3 font-lock-function-name-face t t) |
5810 |
;;(4 |
;;(4 |
5811 |
;; (if (cperl-slash-is-regexp) |
;; (if (cperl-slash-is-regexp) |
5828 |
(if (fboundp 'ps-print-buffer) (cperl-ps-print-init)) |
(if (fboundp 'ps-print-buffer) (cperl-ps-print-init)) |
5829 |
(if (or (featurep 'choose-color) (featurep 'font-lock-extra)) |
(if (or (featurep 'choose-color) (featurep 'font-lock-extra)) |
5830 |
(eval ; Avoid a warning |
(eval ; Avoid a warning |
5831 |
'(font-lock-require-faces |
'(font-lock-require-faces |
5832 |
(list |
(list |
5833 |
;; Color-light Color-dark Gray-light Gray-dark Mono |
;; Color-light Color-dark Gray-light Gray-dark Mono |
5834 |
(list 'font-lock-comment-face |
(list 'font-lock-comment-face |
5835 |
["Firebrick" "OrangeRed" "DimGray" "Gray80"] |
["Firebrick" "OrangeRed" "DimGray" "Gray80"] |
5836 |
nil |
nil |
5837 |
[nil nil t t t] |
[nil nil t t t] |
5838 |
[nil nil t t t] |
[nil nil t t t] |
5839 |
nil) |
nil) |
5840 |
(list 'font-lock-string-face |
(list 'font-lock-string-face |
5841 |
["RosyBrown" "LightSalmon" "Gray50" "LightGray"] |
["RosyBrown" "LightSalmon" "Gray50" "LightGray"] |
5842 |
nil |
nil |
5843 |
nil |
nil |
5844 |
[nil nil t t t] |
[nil nil t t t] |
5845 |
nil) |
nil) |
5846 |
(list 'font-lock-function-name-face |
(list 'font-lock-function-name-face |
5847 |
(vector |
(vector |
5848 |
"Blue" "LightSkyBlue" "Gray50" "LightGray" |
"Blue" "LightSkyBlue" "Gray50" "LightGray" |
5849 |
(cdr (assq 'background-color ; if mono |
(cdr (assq 'background-color ; if mono |
5850 |
(frame-parameters)))) |
(frame-parameters)))) |
5851 |
(vector |
(vector |
5852 |
nil nil nil nil |
nil nil nil nil |
5853 |
(cdr (assq 'foreground-color ; if mono |
(cdr (assq 'foreground-color ; if mono |
5854 |
(frame-parameters)))) |
(frame-parameters)))) |
5855 |
[nil nil t t t] |
[nil nil t t t] |
5856 |
nil |
nil |
5857 |
nil) |
nil) |
5858 |
(list 'font-lock-variable-name-face |
(list 'font-lock-variable-name-face |
5859 |
["DarkGoldenrod" "LightGoldenrod" "DimGray" "Gray90"] |
["DarkGoldenrod" "LightGoldenrod" "DimGray" "Gray90"] |
5860 |
nil |
nil |
5861 |
[nil nil t t t] |
[nil nil t t t] |
5862 |
[nil nil t t t] |
[nil nil t t t] |
5863 |
nil) |
nil) |
5864 |
(list 'font-lock-type-face |
(list 'font-lock-type-face |
5865 |
["DarkOliveGreen" "PaleGreen" "DimGray" "Gray80"] |
["DarkOliveGreen" "PaleGreen" "DimGray" "Gray80"] |
5866 |
nil |
nil |
5867 |
[nil nil t t t] |
[nil nil t t t] |
5868 |
nil |
nil |
5869 |
[nil nil t t t] |
[nil nil t t t]) |
5870 |
) |
(list 'font-lock-constant-face |
5871 |
(list 'font-lock-constant-face |
["CadetBlue" "Aquamarine" "Gray50" "LightGray"] |
5872 |
["CadetBlue" "Aquamarine" "Gray50" "LightGray"] |
nil |
5873 |
nil |
[nil nil t t t] |
5874 |
[nil nil t t t] |
nil |
5875 |
nil |
[nil nil t t t]) |
5876 |
[nil nil t t t] |
(list 'cperl-nonoverridable-face |
5877 |
) |
["chartreuse3" ("orchid1" "orange") |
5878 |
(list 'cperl-nonoverridable-face |
nil "Gray80"] |
5879 |
["chartreuse3" ("orchid1" "orange") |
[nil nil "gray90"] |
5880 |
nil "Gray80"] |
[nil nil nil t t] |
5881 |
[nil nil "gray90"] |
[nil nil t t] |
5882 |
[nil nil nil t t] |
[nil nil t t t]) |
5883 |
[nil nil t t] |
(list 'cperl-array-face |
5884 |
[nil nil t t t] |
["blue" "yellow" nil "Gray80"] |
5885 |
) |
["lightyellow2" ("navy" "os2blue" "darkgreen") |
5886 |
(list 'cperl-array-face |
"gray90"] |
5887 |
["blue" "yellow" nil "Gray80"] |
t |
5888 |
["lightyellow2" ("navy" "os2blue" "darkgreen") |
nil |
5889 |
"gray90"] |
nil) |
5890 |
t |
(list 'cperl-hash-face |
5891 |
nil |
["red" "red" nil "Gray80"] |
5892 |
nil) |
["lightyellow2" ("navy" "os2blue" "darkgreen") |
5893 |
(list 'cperl-hash-face |
"gray90"] |
5894 |
["red" "red" nil "Gray80"] |
t |
5895 |
["lightyellow2" ("navy" "os2blue" "darkgreen") |
t |
5896 |
"gray90"] |
nil)))) |
|
t |
|
|
t |
|
|
nil)))) |
|
5897 |
;; Do it the dull way, without choose-color |
;; Do it the dull way, without choose-color |
5898 |
(defvar cperl-guessed-background nil |
(defvar cperl-guessed-background nil |
5899 |
"Display characteristics as guessed by cperl.") |
"Display characteristics as guessed by cperl.") |
5900 |
;; (or (fboundp 'x-color-defined-p) |
;; (or (fboundp 'x-color-defined-p) |
5901 |
;; (defalias 'x-color-defined-p |
;; (defalias 'x-color-defined-p |
5902 |
;; (cond ((fboundp 'color-defined-p) 'color-defined-p) |
;; (cond ((fboundp 'color-defined-p) 'color-defined-p) |
5903 |
;; ;; XEmacs >= 19.12 |
;; ;; XEmacs >= 19.12 |
5904 |
;; ((fboundp 'valid-color-name-p) 'valid-color-name-p) |
;; ((fboundp 'valid-color-name-p) 'valid-color-name-p) |
5905 |
;; ;; XEmacs 19.11 |
;; ;; XEmacs 19.11 |
5906 |
;; (t 'x-valid-color-name-p)))) |
;; (t 'x-valid-color-name-p)))) |
5907 |
(cperl-force-face font-lock-constant-face |
(cperl-force-face font-lock-constant-face |
5908 |
"Face for constant and label names") |
"Face for constant and label names") |
5909 |
(cperl-force-face font-lock-variable-name-face |
(cperl-force-face font-lock-variable-name-face |
5910 |
"Face for variable names") |
"Face for variable names") |
5944 |
;; 'font-lock-function-name-face |
;; 'font-lock-function-name-face |
5945 |
;; "Face to use for function names."))) |
;; "Face to use for function names."))) |
5946 |
(if (and |
(if (and |
5947 |
(not (cperl-is-face 'cperl-array-face)) |
(not (cperl-is-face 'cperl-array-face)) |
5948 |
(cperl-is-face 'font-lock-emphasized-face)) |
(cperl-is-face 'font-lock-emphasized-face)) |
5949 |
(copy-face 'font-lock-emphasized-face 'cperl-array-face)) |
(copy-face 'font-lock-emphasized-face 'cperl-array-face)) |
5950 |
(if (and |
(if (and |
5951 |
(not (cperl-is-face 'cperl-hash-face)) |
(not (cperl-is-face 'cperl-hash-face)) |
5952 |
(cperl-is-face 'font-lock-other-emphasized-face)) |
(cperl-is-face 'font-lock-other-emphasized-face)) |
5953 |
(copy-face 'font-lock-other-emphasized-face |
(copy-face 'font-lock-other-emphasized-face |
5954 |
'cperl-hash-face)) |
'cperl-hash-face)) |
5955 |
(if (and |
(if (and |
5956 |
(not (cperl-is-face 'cperl-nonoverridable-face)) |
(not (cperl-is-face 'cperl-nonoverridable-face)) |
5957 |
(cperl-is-face 'font-lock-other-type-face)) |
(cperl-is-face 'font-lock-other-type-face)) |
5958 |
(copy-face 'font-lock-other-type-face |
(copy-face 'font-lock-other-type-face |
5959 |
'cperl-nonoverridable-face)) |
'cperl-nonoverridable-face)) |
5960 |
;;(or (boundp 'cperl-hash-face) |
;;(or (boundp 'cperl-hash-face) |
5961 |
;; (defconst cperl-hash-face |
;; (defconst cperl-hash-face |
5969 |
(let ((background |
(let ((background |
5970 |
(if (boundp 'font-lock-background-mode) |
(if (boundp 'font-lock-background-mode) |
5971 |
font-lock-background-mode |
font-lock-background-mode |
5972 |
'light)) |
'light)) |
5973 |
(face-list (and (fboundp 'face-list) (face-list))) |
(face-list (and (fboundp 'face-list) (face-list)))) |
|
;; cperl-is-face |
|
|
) |
|
5974 |
;;;; (fset 'cperl-is-face |
;;;; (fset 'cperl-is-face |
5975 |
;;;; (cond ((fboundp 'find-face) |
;;;; (cond ((fboundp 'find-face) |
5976 |
;;;; (symbol-function 'find-face)) |
;;;; (symbol-function 'find-face)) |
5984 |
'gray |
'gray |
5985 |
background) |
background) |
5986 |
"Background as guessed by CPerl mode") |
"Background as guessed by CPerl mode") |
5987 |
(if (and |
(and (not (cperl-is-face 'font-lock-constant-face)) |
5988 |
(not (cperl-is-face 'font-lock-constant-face)) |
(cperl-is-face 'font-lock-reference-face) |
5989 |
(cperl-is-face 'font-lock-reference-face)) |
(copy-face 'font-lock-reference-face 'font-lock-constant-face)) |
|
(copy-face 'font-lock-reference-face 'font-lock-constant-face)) |
|
5990 |
(if (cperl-is-face 'font-lock-type-face) nil |
(if (cperl-is-face 'font-lock-type-face) nil |
5991 |
(copy-face 'default 'font-lock-type-face) |
(copy-face 'default 'font-lock-type-face) |
5992 |
(cond |
(cond |
6062 |
"Initialization of `ps-print' components for faces used in CPerl." |
"Initialization of `ps-print' components for faces used in CPerl." |
6063 |
(eval-after-load "ps-print" |
(eval-after-load "ps-print" |
6064 |
'(setq ps-bold-faces |
'(setq ps-bold-faces |
6065 |
;; font-lock-variable-name-face |
;; font-lock-variable-name-face |
6066 |
;; font-lock-constant-face |
;; font-lock-constant-face |
6067 |
(append '(cperl-array-face |
(append '(cperl-array-face |
6068 |
cperl-hash-face) |
cperl-hash-face) |
6069 |
ps-bold-faces) |
ps-bold-faces) |
6070 |
ps-italic-faces |
ps-italic-faces |
6071 |
;; font-lock-constant-face |
;; font-lock-constant-face |
6089 |
|
|
6090 |
Style of printout regulated by the variable `cperl-ps-print-face-properties'." |
Style of printout regulated by the variable `cperl-ps-print-face-properties'." |
6091 |
(interactive) |
(interactive) |
6092 |
(or file |
(or file |
6093 |
(setq file (read-from-minibuffer |
(setq file (read-from-minibuffer |
6094 |
"Print to file (if empty - to printer): " |
"Print to file (if empty - to printer): " |
6095 |
(concat (buffer-file-name) ".ps") |
(concat (buffer-file-name) ".ps") |
6096 |
nil nil 'file-name-history))) |
nil nil 'file-name-history))) |
6111 |
;;; (setq ps-bold-faces |
;;; (setq ps-bold-faces |
6112 |
;;; (append '(font-lock-emphasized-face |
;;; (append '(font-lock-emphasized-face |
6113 |
;;; cperl-array-face |
;;; cperl-array-face |
6114 |
;;; font-lock-keyword-face |
;;; font-lock-keyword-face |
6115 |
;;; font-lock-variable-name-face |
;;; font-lock-variable-name-face |
6116 |
;;; font-lock-constant-face |
;;; font-lock-constant-face |
6117 |
;;; font-lock-reference-face |
;;; font-lock-reference-face |
6118 |
;;; font-lock-other-emphasized-face |
;;; font-lock-other-emphasized-face |
6119 |
;;; cperl-hash-face) |
;;; cperl-hash-face) |
6120 |
;;; ps-bold-faces)) |
;;; ps-bold-faces)) |
6121 |
;;; (setq ps-italic-faces |
;;; (setq ps-italic-faces |
6122 |
;;; (append '(cperl-nonoverridable-face |
;;; (append '(cperl-nonoverridable-face |
6123 |
;;; font-lock-constant-face |
;;; font-lock-constant-face |
6124 |
;;; font-lock-reference-face |
;;; font-lock-reference-face |
6125 |
;;; font-lock-other-emphasized-face |
;;; font-lock-other-emphasized-face |
6126 |
;;; cperl-hash-face) |
;;; cperl-hash-face) |
6127 |
;;; ps-italic-faces)) |
;;; ps-italic-faces)) |
6138 |
(if (cperl-enable-font-lock) (cperl-windowed-init)) |
(if (cperl-enable-font-lock) (cperl-windowed-init)) |
6139 |
|
|
6140 |
(defconst cperl-styles-entries |
(defconst cperl-styles-entries |
6141 |
'(cperl-indent-level cperl-brace-offset cperl-continued-brace-offset |
'(cperl-indent-level cperl-brace-offset cperl-continued-brace-offset |
6142 |
cperl-label-offset cperl-extra-newline-before-brace |
cperl-label-offset cperl-extra-newline-before-brace |
6143 |
cperl-merge-trailing-else |
cperl-merge-trailing-else |
6144 |
cperl-continued-statement-offset)) |
cperl-continued-statement-offset)) |
6145 |
|
|
6146 |
(defconst cperl-style-alist |
(defconst cperl-style-alist |
6147 |
'(("CPerl" ; =GNU without extra-newline-before-brace |
'(("CPerl" ; =GNU without extra-newline-before-brace |
6148 |
(cperl-indent-level . 2) |
(cperl-indent-level . 2) |
6149 |
(cperl-brace-offset . 0) |
(cperl-brace-offset . 0) |
6150 |
(cperl-continued-brace-offset . 0) |
(cperl-continued-brace-offset . 0) |
6152 |
(cperl-extra-newline-before-brace . nil) |
(cperl-extra-newline-before-brace . nil) |
6153 |
(cperl-merge-trailing-else . t) |
(cperl-merge-trailing-else . t) |
6154 |
(cperl-continued-statement-offset . 2)) |
(cperl-continued-statement-offset . 2)) |
6155 |
("PerlStyle" ; CPerl with 4 as indent |
("PerlStyle" ; CPerl with 4 as indent |
6156 |
(cperl-indent-level . 4) |
(cperl-indent-level . 4) |
6157 |
(cperl-brace-offset . 0) |
(cperl-brace-offset . 0) |
6158 |
(cperl-continued-brace-offset . 0) |
(cperl-continued-brace-offset . 0) |
6203 |
Should be used via `cperl-set-style' or via Perl menu.") |
Should be used via `cperl-set-style' or via Perl menu.") |
6204 |
|
|
6205 |
(defun cperl-set-style (style) |
(defun cperl-set-style (style) |
6206 |
"Set CPerl-mode variables to use one of several different indentation styles. |
"Set CPerl mode variables to use one of several different indentation styles. |
6207 |
The arguments are a string representing the desired style. |
The arguments are a string representing the desired style. |
6208 |
The list of styles is in `cperl-style-alist', available styles |
The list of styles is in `cperl-style-alist', available styles |
6209 |
are GNU, K&R, BSD, C++ and Whitesmith. |
are GNU, K&R, BSD, C++ and Whitesmith. |
6210 |
|
|
6211 |
The current value of style is memorized (unless there is a memorized |
The current value of style is memorized (unless there is a memorized |
6213 |
|
|
6214 |
Chosing \"Current\" style will not change style, so this may be used for |
Chosing \"Current\" style will not change style, so this may be used for |
6215 |
side-effect of memorizing only." |
side-effect of memorizing only." |
6216 |
(interactive |
(interactive |
6217 |
(let ((list (mapcar (function (lambda (elt) (list (car elt)))) |
(let ((list (mapcar (function (lambda (elt) (list (car elt)))) |
6218 |
cperl-style-alist))) |
cperl-style-alist))) |
6219 |
(list (completing-read "Enter style: " list nil 'insist)))) |
(list (completing-read "Enter style: " list nil 'insist)))) |
6234 |
(or cperl-old-style (error "The style was not changed")) |
(or cperl-old-style (error "The style was not changed")) |
6235 |
(let (setting) |
(let (setting) |
6236 |
(while cperl-old-style |
(while cperl-old-style |
6237 |
(setq setting (car cperl-old-style) |
(setq setting (car cperl-old-style) |
6238 |
cperl-old-style (cdr cperl-old-style)) |
cperl-old-style (cdr cperl-old-style)) |
6239 |
(set (car setting) (cdr setting))))) |
(set (car setting) (cdr setting))))) |
6240 |
|
|
6267 |
(set-buffer "*info-perl-tmp*") |
(set-buffer "*info-perl-tmp*") |
6268 |
(rename-buffer "*info*") |
(rename-buffer "*info*") |
6269 |
(set-buffer bname))) |
(set-buffer bname))) |
6270 |
(make-variable-buffer-local 'window-min-height) |
(make-local-variable 'window-min-height) |
6271 |
(setq window-min-height 2) |
(setq window-min-height 2) |
6272 |
(current-buffer))))) |
(current-buffer))))) |
6273 |
|
|
6274 |
(defun cperl-word-at-point (&optional p) |
(defun cperl-word-at-point (&optional p) |
6275 |
;; Returns the word at point or at P. |
"Return the word at point or at P." |
6276 |
(save-excursion |
(save-excursion |
6277 |
(if p (goto-char p)) |
(if p (goto-char p)) |
6278 |
(or (cperl-word-at-point-hard) |
(or (cperl-word-at-point-hard) |
6286 |
'find-tag-default)))))) |
'find-tag-default)))))) |
6287 |
|
|
6288 |
(defun cperl-info-on-command (command) |
(defun cperl-info-on-command (command) |
6289 |
"Shows documentation for Perl command in other window. |
"Show documentation for Perl command COMMAND in other window. |
6290 |
If perl-info buffer is shown in some frame, uses this frame. |
If perl-info buffer is shown in some frame, uses this frame. |
6291 |
Customized by setting variables `cperl-shrink-wrap-info-frame', |
Customized by setting variables `cperl-shrink-wrap-info-frame', |
6292 |
`cperl-max-help-size'." |
`cperl-max-help-size'." |
6293 |
(interactive |
(interactive |
6294 |
(let* ((default (cperl-word-at-point)) |
(let* ((default (cperl-word-at-point)) |
6295 |
(read (read-string |
(read (read-string |
6296 |
(format "Find doc for Perl function (default %s): " |
(format "Find doc for Perl function (default %s): " |
6297 |
default)))) |
default)))) |
6298 |
(list (if (equal read "") |
(list (if (equal read "") |
6299 |
default |
default |
6300 |
read)))) |
read)))) |
6301 |
|
|
6302 |
(let ((buffer (current-buffer)) |
(let ((buffer (current-buffer)) |
6303 |
(cmd-desc (concat "^" (regexp-quote command) "[^a-zA-Z_0-9]")) ; "tr///" |
(cmd-desc (concat "^" (regexp-quote command) "[^a-zA-Z_0-9]")) ; "tr///" |
6311 |
fr1 (window-frame iniwin)) |
fr1 (window-frame iniwin)) |
6312 |
(set-buffer buf) |
(set-buffer buf) |
6313 |
(beginning-of-buffer) |
(beginning-of-buffer) |
6314 |
(or isvar |
(or isvar |
6315 |
(progn (re-search-forward "^-X[ \t\n]") |
(progn (re-search-forward "^-X[ \t\n]") |
6316 |
(forward-line -1))) |
(forward-line -1))) |
6317 |
(if (re-search-forward cmd-desc nil t) |
(if (re-search-forward cmd-desc nil t) |
6320 |
(if (re-search-backward "^[ \t\n\f]") |
(if (re-search-backward "^[ \t\n\f]") |
6321 |
(forward-line 1)) |
(forward-line 1)) |
6322 |
(beginning-of-line) |
(beginning-of-line) |
6323 |
;; Get some of |
;; Get some of |
6324 |
(setq pos (point) |
(setq pos (point) |
6325 |
buf-list (list buf "*info-perl-var*" "*info-perl*")) |
buf-list (list buf "*info-perl-var*" "*info-perl*")) |
6326 |
(while (and (not win) buf-list) |
(while (and (not win) buf-list) |
6339 |
(setq iniheight (window-height) |
(setq iniheight (window-height) |
6340 |
frheight (frame-height) |
frheight (frame-height) |
6341 |
not-loner (< iniheight (1- frheight))) ; Are not alone |
not-loner (< iniheight (1- frheight))) ; Are not alone |
6342 |
(cond ((if not-loner cperl-max-help-size |
(cond ((if not-loner cperl-max-help-size |
6343 |
cperl-shrink-wrap-info-frame) |
cperl-shrink-wrap-info-frame) |
6344 |
(setq height |
(setq height |
6345 |
(+ 2 |
(+ 2 |
6346 |
(count-lines |
(count-lines |
6347 |
pos |
pos |
6348 |
(save-excursion |
(save-excursion |
6349 |
(if (re-search-forward |
(if (re-search-forward |
6350 |
"^[ \t][^\n]*\n+\\([^ \t\n\f]\\|\\'\\)" nil t) |
"^[ \t][^\n]*\n+\\([^ \t\n\f]\\|\\'\\)" nil t) |
6351 |
(match-beginning 0) (point-max))))) |
(match-beginning 0) (point-max))))) |
6352 |
max-height |
max-height |
6353 |
(if not-loner |
(if not-loner |
6354 |
(/ (* (- frheight 3) cperl-max-help-size) 100) |
(/ (* (- frheight 3) cperl-max-help-size) 100) |
6355 |
(setq char-height (frame-char-height)) |
(setq char-height (frame-char-height)) |
6356 |
;; Non-functioning under OS/2: |
;; Non-functioning under OS/2: |
6357 |
(if (eq char-height 1) (setq char-height 18)) |
(if (eq char-height 1) (setq char-height 18)) |
6358 |
;; Title, menubar, + 2 for slack |
;; Title, menubar, + 2 for slack |
6359 |
(- (/ (x-display-pixel-height) char-height) 4) |
(- (/ (x-display-pixel-height) char-height) 4))) |
|
)) |
|
6360 |
(if (> height max-height) (setq height max-height)) |
(if (> height max-height) (setq height max-height)) |
6361 |
;;(message "was %s doing %s" iniheight height) |
;;(message "was %s doing %s" iniheight height) |
6362 |
(if not-loner |
(if not-loner |
6368 |
(select-window iniwin))) |
(select-window iniwin))) |
6369 |
|
|
6370 |
(defun cperl-info-on-current-command () |
(defun cperl-info-on-current-command () |
6371 |
"Shows documentation for Perl command at point in other window." |
"Show documentation for Perl command at point in other window." |
6372 |
(interactive) |
(interactive) |
6373 |
(cperl-info-on-command (cperl-word-at-point))) |
(cperl-info-on-command (cperl-word-at-point))) |
6374 |
|
|
6378 |
"^\n\\([-a-zA-Z_]+\\)[ \t\n]") |
"^\n\\([-a-zA-Z_]+\\)[ \t\n]") |
6379 |
(forward-line 1))) |
(forward-line 1))) |
6380 |
|
|
6381 |
(defun cperl-imenu-info-imenu-name () |
(defun cperl-imenu-info-imenu-name () |
6382 |
(buffer-substring |
(buffer-substring |
6383 |
(match-beginning 1) (match-end 1))) |
(match-beginning 1) (match-end 1))) |
6384 |
|
|
6386 |
(interactive) |
(interactive) |
6387 |
(let* ((buffer (current-buffer)) |
(let* ((buffer (current-buffer)) |
6388 |
imenu-create-index-function |
imenu-create-index-function |
6389 |
imenu-prev-index-position-function |
imenu-prev-index-position-function |
6390 |
imenu-extract-index-name-function |
imenu-extract-index-name-function |
6391 |
(index-item (save-restriction |
(index-item (save-restriction |
6392 |
(save-window-excursion |
(save-window-excursion |
6393 |
(set-buffer (cperl-info-buffer nil)) |
(set-buffer (cperl-info-buffer nil)) |
6394 |
(setq imenu-create-index-function |
(setq imenu-create-index-function |
6395 |
'imenu-default-create-index-function |
'imenu-default-create-index-function |
6396 |
imenu-prev-index-position-function |
imenu-prev-index-position-function |
6397 |
'cperl-imenu-info-imenu-search |
'cperl-imenu-info-imenu-search |
6418 |
|
|
6419 |
MINSHIFT is the minimal amount of space to insert before the construction. |
MINSHIFT is the minimal amount of space to insert before the construction. |
6420 |
STEP is the tabwidth to position constructions. |
STEP is the tabwidth to position constructions. |
6421 |
If STEP is `nil', `cperl-lineup-step' will be used |
If STEP is nil, `cperl-lineup-step' will be used |
6422 |
\(or `cperl-indent-level', if `cperl-lineup-step' is `nil'). |
\(or `cperl-indent-level', if `cperl-lineup-step' is `nil'). |
6423 |
Will not move the position at the start to the left." |
Will not move the position at the start to the left." |
6424 |
(interactive "r") |
(interactive "r") |
6436 |
(if (looking-at "[a-zA-Z0-9_]") |
(if (looking-at "[a-zA-Z0-9_]") |
6437 |
(if (looking-at "\\<[a-zA-Z0-9_]+\\>") |
(if (looking-at "\\<[a-zA-Z0-9_]+\\>") |
6438 |
(setq search |
(setq search |
6439 |
(concat "\\<" |
(concat "\\<" |
6440 |
(regexp-quote |
(regexp-quote |
6441 |
(buffer-substring (match-beginning 0) |
(buffer-substring (match-beginning 0) |
6442 |
(match-end 0))) "\\>")) |
(match-end 0))) "\\>")) |
6443 |
(error "Cannot line up in a middle of the word")) |
(error "Cannot line up in a middle of the word")) |
6448 |
(or minshift (setq minshift 1)) |
(or minshift (setq minshift 1)) |
6449 |
(while (progn |
(while (progn |
6450 |
(beginning-of-line 2) |
(beginning-of-line 2) |
6451 |
(and (< (point) end) |
(and (< (point) end) |
6452 |
(re-search-forward search end t) |
(re-search-forward search end t) |
6453 |
(goto-char (match-beginning 0)))) |
(goto-char (match-beginning 0)))) |
6454 |
(setq tcol (current-column) seen t) |
(setq tcol (current-column) seen t) |
6458 |
(goto-char beg) |
(goto-char beg) |
6459 |
(setq col (+ col minshift)) |
(setq col (+ col minshift)) |
6460 |
(if (/= (% col step) 0) (setq step (* step (1+ (/ col step))))) |
(if (/= (% col step) 0) (setq step (* step (1+ (/ col step))))) |
6461 |
(while |
(while |
6462 |
(progn |
(progn |
6463 |
(setq e (point)) |
(setq e (point)) |
6464 |
(skip-chars-backward " \t") |
(skip-chars-backward " \t") |
6465 |
(delete-region (point) e) |
(delete-region (point) e) |
6466 |
(indent-to-column col); (make-string (- col (current-column)) ?\ )) |
(indent-to-column col) ;(make-string (- col (current-column)) ?\ )) |
6467 |
(beginning-of-line 2) |
(beginning-of-line 2) |
6468 |
(and (< (point) end) |
(and (< (point) end) |
6469 |
(re-search-forward search end t) |
(re-search-forward search end t) |
6470 |
(goto-char (match-beginning 0)))))))) ; No body |
(goto-char (match-beginning 0)))))))) ; No body |
6471 |
|
|
6482 |
(cond |
(cond |
6483 |
((eq all 'recursive) |
((eq all 'recursive) |
6484 |
;;(error "Not implemented: recursive") |
;;(error "Not implemented: recursive") |
6485 |
(setq args (append (list "-e" |
(setq args (append (list "-e" |
6486 |
"sub wanted {push @ARGV, $File::Find::name if /\\.[pP][Llm]$/} |
"sub wanted {push @ARGV, $File::Find::name if /\\.[pP][Llm]$/} |
6487 |
use File::Find; |
use File::Find; |
6488 |
find(\\&wanted, '.'); |
find(\\&wanted, '.'); |
6489 |
exec @ARGV;" |
exec @ARGV;" |
6490 |
cmd) args) |
cmd) args) |
6491 |
cmd "perl")) |
cmd "perl")) |
6492 |
(all |
(all |
6493 |
;;(error "Not implemented: all") |
;;(error "Not implemented: all") |
6494 |
(setq args (append (list "-e" |
(setq args (append (list "-e" |
6495 |
"push @ARGV, <*.PL *.pl *.pm>; |
"push @ARGV, <*.PL *.pl *.pm>; |
6496 |
exec @ARGV;" |
exec @ARGV;" |
6497 |
cmd) args) |
cmd) args) |
6498 |
cmd "perl")) |
cmd "perl")) |
6499 |
(t |
(t |
6506 |
"Toggle the state of `cperl-auto-newline'." |
"Toggle the state of `cperl-auto-newline'." |
6507 |
(interactive) |
(interactive) |
6508 |
(setq cperl-auto-newline (not cperl-auto-newline)) |
(setq cperl-auto-newline (not cperl-auto-newline)) |
6509 |
(message "Newlines will %sbe auto-inserted now." |
(message "Newlines will %sbe auto-inserted now." |
6510 |
(if cperl-auto-newline "" "not "))) |
(if cperl-auto-newline "" "not "))) |
6511 |
|
|
6512 |
(defun cperl-toggle-abbrev () |
(defun cperl-toggle-abbrev () |
6513 |
"Toggle the state of automatic keyword expansion in CPerl mode." |
"Toggle the state of automatic keyword expansion in CPerl mode." |
6514 |
(interactive) |
(interactive) |
6515 |
(abbrev-mode (if abbrev-mode 0 1)) |
(abbrev-mode (if abbrev-mode 0 1)) |
6516 |
(message "Perl control structure will %sbe auto-inserted now." |
(message "Perl control structure will %sbe auto-inserted now." |
6517 |
(if abbrev-mode "" "not "))) |
(if abbrev-mode "" "not "))) |
6518 |
|
|
6519 |
|
|
6521 |
"Toggle the state of parentheses doubling in CPerl mode." |
"Toggle the state of parentheses doubling in CPerl mode." |
6522 |
(interactive) |
(interactive) |
6523 |
(setq cperl-electric-parens (if (cperl-val 'cperl-electric-parens) 'null t)) |
(setq cperl-electric-parens (if (cperl-val 'cperl-electric-parens) 'null t)) |
6524 |
(message "Parentheses will %sbe auto-doubled now." |
(message "Parentheses will %sbe auto-doubled now." |
6525 |
(if (cperl-val 'cperl-electric-parens) "" "not "))) |
(if (cperl-val 'cperl-electric-parens) "" "not "))) |
6526 |
|
|
6527 |
(defun cperl-toggle-autohelp () |
(defun cperl-toggle-autohelp () |
6533 |
(if cperl-lazy-installed |
(if cperl-lazy-installed |
6534 |
(eval '(cperl-lazy-unstall)) |
(eval '(cperl-lazy-unstall)) |
6535 |
(cperl-lazy-install)) |
(cperl-lazy-install)) |
6536 |
(message "Perl help messages will %sbe automatically shown now." |
(message "Perl help messages will %sbe automatically shown now." |
6537 |
(if cperl-lazy-installed "" "not "))) |
(if cperl-lazy-installed "" "not "))) |
6538 |
(message "Cannot automatically show Perl help messages - run-with-idle-timer missing."))) |
(message "Cannot automatically show Perl help messages - run-with-idle-timer missing."))) |
6539 |
|
|
6540 |
(defun cperl-toggle-construct-fix () |
(defun cperl-toggle-construct-fix () |
6541 |
"Toggle whether `indent-region'/`indent-sexp' fix whitespace too." |
"Toggle whether `indent-region'/`indent-sexp' fix whitespace too." |
6542 |
(interactive) |
(interactive) |
6543 |
(setq cperl-indent-region-fix-constructs |
(setq cperl-indent-region-fix-constructs |
6544 |
(if cperl-indent-region-fix-constructs |
(if cperl-indent-region-fix-constructs |
6545 |
nil |
nil |
6546 |
1)) |
1)) |
6547 |
(message "indent-region/indent-sexp will %sbe automatically fix whitespace." |
(message "indent-region/indent-sexp will %sbe automatically fix whitespace." |
6548 |
(if cperl-indent-region-fix-constructs "" "not "))) |
(if cperl-indent-region-fix-constructs "" "not "))) |
6549 |
|
|
6550 |
;;;; Tags file creation. |
;;;; Tags file creation. |
6558 |
(auto-fill-mode 0) |
(auto-fill-mode 0) |
6559 |
(if cperl-use-syntax-table-text-property-for-tags |
(if cperl-use-syntax-table-text-property-for-tags |
6560 |
(progn |
(progn |
6561 |
(make-variable-buffer-local 'parse-sexp-lookup-properties) |
(make-local-variable 'parse-sexp-lookup-properties) |
6562 |
;; Do not introduce variable if not needed, we check it! |
;; Do not introduce variable if not needed, we check it! |
6563 |
(set 'parse-sexp-lookup-properties t)))) |
(set 'parse-sexp-lookup-properties t)))) |
6564 |
|
|
6565 |
(defun cperl-xsub-scan () |
(defun cperl-xsub-scan () |
6566 |
(require 'cl) |
(require 'cl) |
6567 |
(require 'imenu) |
(require 'imenu) |
6568 |
(let ((index-alist '()) |
(let ((index-alist '()) |
6569 |
(prev-pos 0) index index1 name package prefix) |
(prev-pos 0) index index1 name package prefix) |
6570 |
(goto-char (point-min)) |
(goto-char (point-min)) |
6571 |
(if noninteractive |
(if noninteractive |
6579 |
(or noninteractive |
(or noninteractive |
6580 |
(imenu-progress-message prev-pos)) |
(imenu-progress-message prev-pos)) |
6581 |
(cond |
(cond |
6582 |
((match-beginning 2) ; SECTION |
((match-beginning 2) ; SECTION |
6583 |
(setq package (buffer-substring (match-beginning 2) (match-end 2))) |
(setq package (buffer-substring (match-beginning 2) (match-end 2))) |
6584 |
(goto-char (match-beginning 0)) |
(goto-char (match-beginning 0)) |
6585 |
(skip-chars-forward " \t") |
(skip-chars-forward " \t") |
6612 |
(defvar cperl-unreadable-ok nil) |
(defvar cperl-unreadable-ok nil) |
6613 |
|
|
6614 |
(defun cperl-find-tags (ifile xs topdir) |
(defun cperl-find-tags (ifile xs topdir) |
6615 |
(let (ind (b (get-buffer cperl-tmp-buffer)) lst elt pos ret rel |
(let ((b (get-buffer cperl-tmp-buffer)) ind lst elt pos ret rel |
6616 |
(cperl-pod-here-fontify nil) f file) |
(cperl-pod-here-fontify nil) f file) |
6617 |
(save-excursion |
(save-excursion |
6618 |
(if b (set-buffer b) |
(if b (set-buffer b) |
6619 |
(cperl-setup-tmp-buf)) |
(cperl-setup-tmp-buf)) |
6620 |
(erase-buffer) |
(erase-buffer) |
6621 |
(condition-case err |
(condition-case err |
6622 |
(setq file (car (insert-file-contents ifile))) |
(setq file (car (insert-file-contents ifile))) |
6625 |
(format "File %s unreadable. Continue? " ifile)) |
(format "File %s unreadable. Continue? " ifile)) |
6626 |
(setq cperl-unreadable-ok t) |
(setq cperl-unreadable-ok t) |
6627 |
(error "Aborting: unreadable file %s" ifile))))) |
(error "Aborting: unreadable file %s" ifile))))) |
6628 |
(if (not file) |
(if (not file) |
6629 |
(message "Unreadable file %s" ifile) |
(message "Unreadable file %s" ifile) |
6630 |
(message "Scanning file %s ..." file) |
(message "Scanning file %s ..." file) |
6631 |
(if (and cperl-use-syntax-table-text-property-for-tags |
(if (and cperl-use-syntax-table-text-property-for-tags |
6632 |
(not xs)) |
(not xs)) |
6633 |
(condition-case err ; after __END__ may have garbage |
(condition-case err ; after __END__ may have garbage |
6634 |
(cperl-find-pods-heres nil nil noninteractive) |
(cperl-find-pods-heres nil nil noninteractive) |
6635 |
(error (message "While scanning for syntax: %s" err)))) |
(error (message "While scanning for syntax: %s" err)))) |
6636 |
(if xs |
(if xs |
6637 |
(setq lst (cperl-xsub-scan)) |
(setq lst (cperl-xsub-scan)) |
6638 |
(setq ind (imenu-example--create-perl-index)) |
(setq ind (cperl-imenu--create-perl-index)) |
6639 |
(setq lst (cdr (assoc "+Unsorted List+..." ind)))) |
(setq lst (cdr (assoc "+Unsorted List+..." ind)))) |
6640 |
(setq lst |
(setq lst |
6641 |
(mapcar |
(mapcar |
6642 |
(function |
(function |
6643 |
(lambda (elt) |
(lambda (elt) |
6644 |
(cond ((string-match "^[_a-zA-Z]" (car elt)) |
(cond ((string-match "^[_a-zA-Z]" (car elt)) |
6645 |
(goto-char (cdr elt)) |
(goto-char (cdr elt)) |
6646 |
(beginning-of-line) ; pos should be of the start of the line |
(beginning-of-line) ; pos should be of the start of the line |
6647 |
(list (car elt) |
(list (car elt) |
6648 |
(point) |
(point) |
6649 |
(1+ (count-lines 1 (point))) ; 1+ since at beg-o-l |
(1+ (count-lines 1 (point))) ; 1+ since at beg-o-l |
6650 |
(buffer-substring (progn |
(buffer-substring (progn |
6651 |
(goto-char (cdr elt)) |
(goto-char (cdr elt)) |
6652 |
;; After name now... |
;; After name now... |
6653 |
(or (eolp) (forward-char 1)) |
(or (eolp) (forward-char 1)) |
6654 |
(point)) |
(point)) |
6655 |
(progn |
(progn |
6656 |
(beginning-of-line) |
(beginning-of-line) |
6657 |
(point)))))))) |
(point)))))))) |
6658 |
lst)) |
lst)) |
6659 |
(erase-buffer) |
(erase-buffer) |
6660 |
(while lst |
(while lst |
6661 |
(setq elt (car lst) lst (cdr lst)) |
(setq elt (car lst) lst (cdr lst)) |
6662 |
(if elt |
(if elt |
6663 |
(progn |
(progn |
6664 |
(insert (elt elt 3) |
(insert (elt elt 3) |
6665 |
127 |
127 |
6666 |
(if (string-match "^package " (car elt)) |
(if (string-match "^package " (car elt)) |
6667 |
(substring (car elt) 8) |
(substring (car elt) 8) |
6668 |
(car elt) ) |
(car elt) ) |
6669 |
1 |
1 |
6670 |
(number-to-string (elt elt 2)) ; Line |
(number-to-string (elt elt 2)) ; Line |
6671 |
"," |
"," |
6672 |
(number-to-string (1- (elt elt 1))) ; Char pos 0-based |
(number-to-string (1- (elt elt 1))) ; Char pos 0-based |
6673 |
"\n") |
"\n") |
6674 |
(if (and (string-match "^[_a-zA-Z]+::" (car elt)) |
(if (and (string-match "^[_a-zA-Z]+::" (car elt)) |
6675 |
(string-match "^sub[ \t]+\\([_a-zA-Z]+\\)[^:_a-zA-Z]" |
(string-match "^sub[ \t]+\\([_a-zA-Z]+\\)[^:_a-zA-Z]" |
6676 |
(elt elt 3))) |
(elt elt 3))) |
6677 |
;; Need to insert the name without package as well |
;; Need to insert the name without package as well |
6678 |
(setq lst (cons (cons (substring (elt elt 3) |
(setq lst (cons (cons (substring (elt elt 3) |
6679 |
(match-beginning 1) |
(match-beginning 1) |
6680 |
(match-end 1)) |
(match-end 1)) |
6681 |
(cdr elt)) |
(cdr elt)) |
6682 |
lst)))))) |
lst)))))) |
6683 |
(setq pos (point)) |
(setq pos (point)) |
6684 |
(goto-char 1) |
(goto-char 1) |
6685 |
(setq rel file) |
(setq rel file) |
6686 |
;; On case-preserving filesystems (EMX on OS/2) case might be encoded in properties |
;; On case-preserving filesystems (EMX on OS/2) case might be encoded in properties |
6687 |
(set-text-properties 0 (length rel) nil rel) |
(set-text-properties 0 (length rel) nil rel) |
6688 |
(and (equal topdir (substring rel 0 (length topdir))) |
(and (equal topdir (substring rel 0 (length topdir))) |
6689 |
(setq rel (substring file (length topdir)))) |
(setq rel (substring file (length topdir)))) |
6690 |
(insert "\f\n" rel "," (number-to-string (1- pos)) "\n") |
(insert "\f\n" rel "," (number-to-string (1- pos)) "\n") |
6691 |
(setq ret (buffer-substring 1 (point-max))) |
(setq ret (buffer-substring 1 (point-max))) |
6692 |
(erase-buffer) |
(erase-buffer) |
6693 |
(or noninteractive |
(or noninteractive |
6694 |
(message "Scanning file %s finished" file)) |
(message "Scanning file %s finished" file)) |
6695 |
ret)))) |
ret)))) |
6696 |
|
|
6697 |
(defun cperl-add-tags-recurse-noxs () |
(defun cperl-add-tags-recurse-noxs () |
6698 |
"Add to TAGS data for Perl and XSUB files in the current directory and kids. |
"Add to TAGS data for Perl and XSUB files in the current directory and kids. |
6699 |
Use as |
Use as |
6700 |
emacs -batch -q -no-site-file -l emacs/cperl-mode.el \ |
emacs -batch -q -no-site-file -l emacs/cperl-mode.el \ |
6701 |
-f cperl-add-tags-recurse |
-f cperl-add-tags-recurse |
6702 |
" |
" |
6703 |
(cperl-write-tags nil nil t t nil t)) |
(cperl-write-tags nil nil t t nil t)) |
6704 |
|
|
6706 |
"Add to TAGS file data for Perl files in the current directory and kids. |
"Add to TAGS file data for Perl files in the current directory and kids. |
6707 |
Use as |
Use as |
6708 |
emacs -batch -q -no-site-file -l emacs/cperl-mode.el \ |
emacs -batch -q -no-site-file -l emacs/cperl-mode.el \ |
6709 |
-f cperl-add-tags-recurse |
-f cperl-add-tags-recurse |
6710 |
" |
" |
6711 |
(cperl-write-tags nil nil t t)) |
(cperl-write-tags nil nil t t)) |
6712 |
|
|
6727 |
((file-exists-p tags-file-name) |
((file-exists-p tags-file-name) |
6728 |
(if cperl-xemacs-p |
(if cperl-xemacs-p |
6729 |
(visit-tags-table-buffer) |
(visit-tags-table-buffer) |
6730 |
(visit-tags-table-buffer tags-file-name))) |
(visit-tags-table-buffer tags-file-name))) |
6731 |
(t (set-buffer (find-file-noselect tags-file-name)))) |
(t (set-buffer (find-file-noselect tags-file-name)))) |
6732 |
(cond |
(cond |
6733 |
(dir |
(dir |
6735 |
(erase |
(erase |
6736 |
(erase-buffer) |
(erase-buffer) |
6737 |
(setq erase 'ignore))) |
(setq erase 'ignore))) |
6738 |
(let ((files |
(let ((files |
6739 |
(condition-case err |
(condition-case err |
6740 |
(directory-files file t |
(directory-files file t |
6741 |
(if recurse nil cperl-scan-files-regexp) |
(if recurse nil cperl-scan-files-regexp) |
6742 |
t) |
t) |
6743 |
(error |
(error |
6744 |
(if cperl-unreadable-ok nil |
(if cperl-unreadable-ok nil |
6745 |
(if (y-or-n-p |
(if (y-or-n-p |
6746 |
(format "Directory %s unreadable. Continue? " file)) |
(format "Directory %s unreadable. Continue? " file)) |
6747 |
(setq cperl-unreadable-ok t |
(setq cperl-unreadable-ok t |
6748 |
tm nil) ; Return empty list |
tm nil) ; Return empty list |
6749 |
(error "Aborting: unreadable directory %s" file))))))) |
(error "Aborting: unreadable directory %s" file))))))) |
6750 |
(mapcar (function (lambda (file) |
(mapcar (function |
6751 |
(cond |
(lambda (file) |
6752 |
((string-match cperl-noscan-files-regexp file) |
(cond |
6753 |
nil) |
((string-match cperl-noscan-files-regexp file) |
6754 |
((not (file-directory-p file)) |
nil) |
6755 |
(if (string-match cperl-scan-files-regexp file) |
((not (file-directory-p file)) |
6756 |
(cperl-write-tags file erase recurse nil t noxs topdir))) |
(if (string-match cperl-scan-files-regexp file) |
6757 |
((not recurse) nil) |
(cperl-write-tags file erase recurse nil t noxs topdir))) |
6758 |
(t (cperl-write-tags file erase recurse t t noxs topdir))))) |
((not recurse) nil) |
6759 |
files)) |
(t (cperl-write-tags file erase recurse t t noxs topdir))))) |
6760 |
) |
files))) |
6761 |
(t |
(t |
6762 |
(setq xs (string-match "\\.xs$" file)) |
(setq xs (string-match "\\.xs$" file)) |
6763 |
(if (not (and xs noxs)) |
(if (not (and xs noxs)) |
6764 |
(progn |
(progn |
6765 |
(cond ((eq erase 'ignore) (goto-char (point-max))) |
(cond ((eq erase 'ignore) (goto-char (point-max))) |
6766 |
(erase (erase-buffer)) |
(erase (erase-buffer)) |
6767 |
(t |
(t |
6768 |
(goto-char 1) |
(goto-char 1) |
6769 |
(setq rel file) |
(setq rel file) |
6770 |
;; On case-preserving filesystems (EMX on OS/2) case might be encoded in properties |
;; On case-preserving filesystems (EMX on OS/2) case might be encoded in properties |
6771 |
(set-text-properties 0 (length rel) nil rel) |
(set-text-properties 0 (length rel) nil rel) |
6772 |
(and (equal topdir (substring rel 0 (length topdir))) |
(and (equal topdir (substring rel 0 (length topdir))) |
6773 |
(setq rel (substring file (length topdir)))) |
(setq rel (substring file (length topdir)))) |
6774 |
(if (search-forward (concat "\f\n" rel ",") nil t) |
(if (search-forward (concat "\f\n" rel ",") nil t) |
6775 |
(progn |
(progn |
6776 |
(search-backward "\f\n") |
(search-backward "\f\n") |
6777 |
(delete-region (point) |
(delete-region (point) |
6778 |
(save-excursion |
(save-excursion |
6779 |
(forward-char 1) |
(forward-char 1) |
6780 |
(if (search-forward "\f\n" |
(if (search-forward "\f\n" |
6781 |
nil 'toend) |
nil 'toend) |
6782 |
(- (point) 2) |
(- (point) 2) |
6783 |
(point-max))))) |
(point-max))))) |
6784 |
(goto-char (point-max))))) |
(goto-char (point-max))))) |
6785 |
(insert (cperl-find-tags file xs topdir)))))) |
(insert (cperl-find-tags file xs topdir)))))) |
6786 |
(if inbuffer nil ; Delegate to the caller |
(if inbuffer nil ; Delegate to the caller |
6787 |
(save-buffer 0) ; No backup |
(save-buffer 0) ; No backup |
6788 |
(if (fboundp 'initialize-new-tags-table) ; Do we need something special in XEmacs? |
(if (fboundp 'initialize-new-tags-table) ; Do we need something special in XEmacs? |
6789 |
(initialize-new-tags-table)))))) |
(initialize-new-tags-table)))))) |
6790 |
|
|
6791 |
(defvar cperl-tags-hier-regexp-list |
(defvar cperl-tags-hier-regexp-list |
6792 |
(concat |
(concat |
6793 |
"^\\(" |
"^\\(" |
6794 |
"\\(package\\)\\>" |
"\\(package\\)\\>" |
6795 |
"\\|" |
"\\|" |
6801 |
"\\)")) |
"\\)")) |
6802 |
|
|
6803 |
(defvar cperl-hierarchy '(() ()) |
(defvar cperl-hierarchy '(() ()) |
6804 |
"Global hierarchy of classes") |
"Global hierarchy of classes.") |
6805 |
|
|
6806 |
(defun cperl-tags-hier-fill () |
(defun cperl-tags-hier-fill () |
6807 |
;; Suppose we are in a tag table cooked by cperl. |
;; Suppose we are in a tag table cooked by cperl. |
6808 |
(goto-char 1) |
(goto-char 1) |
6809 |
(let (type pack name pos line chunk ord cons1 file str info fileind) |
(let (type pack name pos line chunk ord cons1 file str info fileind) |
6810 |
(while (re-search-forward cperl-tags-hier-regexp-list nil t) |
(while (re-search-forward cperl-tags-hier-regexp-list nil t) |
6811 |
(setq pos (match-beginning 0) |
(setq pos (match-beginning 0) |
6812 |
pack (match-beginning 2)) |
pack (match-beginning 2)) |
6813 |
(beginning-of-line) |
(beginning-of-line) |
6814 |
(if (looking-at (concat |
(if (looking-at (concat |
6838 |
(cdr cons1))) |
(cdr cons1))) |
6839 |
;; First occurrence of the name, start alist |
;; First occurrence of the name, start alist |
6840 |
(setq cons1 (cons name (list (cons fileind (vector file info))))) |
(setq cons1 (cons name (list (cons fileind (vector file info))))) |
6841 |
(if pack |
(if pack |
6842 |
(setcar (cdr cperl-hierarchy) |
(setcar (cdr cperl-hierarchy) |
6843 |
(cons cons1 (nth 1 cperl-hierarchy))) |
(cons cons1 (nth 1 cperl-hierarchy))) |
6844 |
(setcar cperl-hierarchy |
(setcar cperl-hierarchy |
6854 |
(require 'etags) |
(require 'etags) |
6855 |
(require 'imenu) |
(require 'imenu) |
6856 |
(if (or update (null (nth 2 cperl-hierarchy))) |
(if (or update (null (nth 2 cperl-hierarchy))) |
6857 |
(let (pack name cons1 to l1 l2 l3 l4 b |
(let ((remover (function (lambda (elt) ; (name (file1...) (file2..)) |
6858 |
(remover (function (lambda (elt) ; (name (file1...) (file2..)) |
(or (nthcdr 2 elt) |
6859 |
(or (nthcdr 2 elt) |
;; Only in one file |
6860 |
;; Only in one file |
(setcdr elt (cdr (nth 1 elt))))))) |
6861 |
(setcdr elt (cdr (nth 1 elt)))))))) |
pack name cons1 to l1 l2 l3 l4 b) |
6862 |
;; (setq cperl-hierarchy '(() () ())) ; Would write into '() later! |
;; (setq cperl-hierarchy '(() () ())) ; Would write into '() later! |
6863 |
(setq cperl-hierarchy (list l1 l2 l3)) |
(setq cperl-hierarchy (list l1 l2 l3)) |
6864 |
(if cperl-xemacs-p ; Not checked |
(if cperl-xemacs-p ; Not checked |
6893 |
(error "No items found")) |
(error "No items found")) |
6894 |
(setq update |
(setq update |
6895 |
;;; (imenu-choose-buffer-index "Packages: " (nth 2 cperl-hierarchy)) |
;;; (imenu-choose-buffer-index "Packages: " (nth 2 cperl-hierarchy)) |
6896 |
(if window-system |
(if (if (boundp 'display-popup-menus-p) |
6897 |
|
(let ((f 'display-popup-menus-p)) |
6898 |
|
(funcall f)) |
6899 |
|
window-system) |
6900 |
(x-popup-menu t (nth 2 cperl-hierarchy)) |
(x-popup-menu t (nth 2 cperl-hierarchy)) |
6901 |
(require 'tmm) |
(require 'tmm) |
6902 |
(tmm-prompt (nth 2 cperl-hierarchy)))) |
(tmm-prompt (nth 2 cperl-hierarchy)))) |
6903 |
(if (and update (listp update)) |
(if (and update (listp update)) |
6904 |
(progn (while (cdr update) (setq update (cdr update))) |
(progn (while (cdr update) (setq update (cdr update))) |
6905 |
(setq update (car update)))) ; Get the last from the list |
(setq update (car update)))) ; Get the last from the list |
6906 |
(if (vectorp update) |
(if (vectorp update) |
6907 |
(progn |
(progn |
6908 |
(find-file (elt update 0)) |
(find-file (elt update 0)) |
6909 |
(cperl-etags-goto-tag-location (elt update 1)))) |
(cperl-etags-goto-tag-location (elt update 1)))) |
6911 |
|
|
6912 |
(defun cperl-tags-treeify (to level) |
(defun cperl-tags-treeify (to level) |
6913 |
;; cadr of `to' is read-write. On start it is a cons |
;; cadr of `to' is read-write. On start it is a cons |
6914 |
(let* ((regexp (concat "^\\(" (mapconcat |
(let* ((regexp (concat "^\\(" (mapconcat |
6915 |
'identity |
'identity |
6916 |
(make-list level "[_a-zA-Z0-9]+") |
(make-list level "[_a-zA-Z0-9]+") |
6917 |
"::") |
"::") |
6975 |
(cdr elt)) |
(cdr elt)) |
6976 |
(cdr to))))) |
(cdr to))))) |
6977 |
(if (default-value 'imenu-sort-function) |
(if (default-value 'imenu-sort-function) |
6978 |
(nreverse |
(nreverse |
6979 |
(sort root-packages (default-value 'imenu-sort-function))) |
(sort root-packages (default-value 'imenu-sort-function))) |
6980 |
root-packages)) |
root-packages)))) |
|
)) |
|
6981 |
|
|
6982 |
;;;(x-popup-menu t |
;;;(x-popup-menu t |
6983 |
;;; '(keymap "Name1" |
;;; '(keymap "Name1" |
6984 |
;;; ("Ret1" "aa") |
;;; ("Ret1" "aa") |
6985 |
;;; ("Head1" "ab" |
;;; ("Head1" "ab" |
6986 |
;;; keymap "Name2" |
;;; keymap "Name2" |
6987 |
;;; ("Tail1" "x") ("Tail2" "y")))) |
;;; ("Tail1" "x") ("Tail2" "y")))) |
6988 |
|
|
6989 |
(defun cperl-list-fold (list name limit) |
(defun cperl-list-fold (list name limit) |
6991 |
(if (<= (length list) limit) list |
(if (<= (length list) limit) list |
6992 |
(setq list1 nil list2 nil) |
(setq list1 nil list2 nil) |
6993 |
(while list |
(while list |
6994 |
(setq num (1+ num) |
(setq num (1+ num) |
6995 |
elt1 (car list) |
elt1 (car list) |
6996 |
list (cdr list)) |
list (cdr list)) |
6997 |
(if (<= num imenu-max-items) |
(if (<= num imenu-max-items) |
7007 |
|
|
7008 |
(defun cperl-menu-to-keymap (menu &optional name) |
(defun cperl-menu-to-keymap (menu &optional name) |
7009 |
(let (list) |
(let (list) |
7010 |
(cons 'keymap |
(cons 'keymap |
7011 |
(mapcar |
(mapcar |
7012 |
(function |
(function |
7013 |
(lambda (elt) |
(lambda (elt) |
7014 |
(cond ((listp (cdr elt)) |
(cond ((listp (cdr elt)) |
7015 |
(setq list (cperl-list-fold |
(setq list (cperl-list-fold |
7024 |
|
|
7025 |
(defvar cperl-bad-style-regexp |
(defvar cperl-bad-style-regexp |
7026 |
(mapconcat 'identity |
(mapconcat 'identity |
7027 |
'("[^-\n\t <>=+!.&|(*/'`\"#^][-=+<>!|&^]" ; char sign |
'("[^-\n\t <>=+!.&|(*/'`\"#^][-=+<>!|&^]" ; char sign |
7028 |
"[-<>=+^&|]+[^- \t\n=+<>~]" ; sign+ char |
"[-<>=+^&|]+[^- \t\n=+<>~]") ; sign+ char |
7029 |
) |
"\\|") |
|
"\\|") |
|
7030 |
"Finds places such that insertion of a whitespace may help a lot.") |
"Finds places such that insertion of a whitespace may help a lot.") |
7031 |
|
|
7032 |
(defvar cperl-not-bad-style-regexp |
(defvar cperl-not-bad-style-regexp |
7033 |
(mapconcat 'identity |
(mapconcat |
7034 |
|
'identity |
7035 |
'("[^-\t <>=+]\\(--\\|\\+\\+\\)" ; var-- var++ |
'("[^-\t <>=+]\\(--\\|\\+\\+\\)" ; var-- var++ |
7036 |
"[a-zA-Z0-9_][|&][a-zA-Z0-9_$]" ; abc|def abc&def are often used. |
"[a-zA-Z0-9_][|&][a-zA-Z0-9_$]" ; abc|def abc&def are often used. |
7037 |
"&[(a-zA-Z0-9_$]" ; &subroutine &(var->field) |
"&[(a-zA-Z0-9_$]" ; &subroutine &(var->field) |
7050 |
"||" |
"||" |
7051 |
"&&" |
"&&" |
7052 |
"[CBIXSLFZ]<\\(\\sw\\|\\s \\|\\s_\\|[\n]\\)*>" ; C<code like text> |
"[CBIXSLFZ]<\\(\\sw\\|\\s \\|\\s_\\|[\n]\\)*>" ; C<code like text> |
7053 |
"-[a-zA-Z_0-9]+[ \t]*=>" ; -option => value |
"-[a-zA-Z_0-9]+[ \t]*=>" ; -option => value |
7054 |
;; Unaddressed trouble spots: = -abc, f(56, -abc) --- specialcased below |
;; Unaddressed trouble spots: = -abc, f(56, -abc) --- specialcased below |
7055 |
;;"[*/+-|&<.]+=" |
;;"[*/+-|&<.]+=" |
7056 |
) |
) |
7069 |
(setq last-nonmenu-event 13) ; To disable popup |
(setq last-nonmenu-event 13) ; To disable popup |
7070 |
(beginning-of-buffer) |
(beginning-of-buffer) |
7071 |
(map-y-or-n-p "Insert space here? " |
(map-y-or-n-p "Insert space here? " |
7072 |
(function (lambda (arg) (insert " "))) |
(lambda (arg) (insert " ")) |
7073 |
'cperl-next-bad-style |
'cperl-next-bad-style |
7074 |
'("location" "locations" "insert a space into") |
'("location" "locations" "insert a space into") |
7075 |
'((?\C-r (lambda (arg) |
'((?\C-r (lambda (arg) |
7076 |
(let ((buffer-quit-function |
(let ((buffer-quit-function |
7077 |
'exit-recursive-edit)) |
'exit-recursive-edit)) |
7078 |
(message "Exit with Esc Esc") |
(message "Exit with Esc Esc") |
7079 |
(recursive-edit) |
(recursive-edit) |
7080 |
t)) ; Consider acted upon |
t)) ; Consider acted upon |
7081 |
"edit, exit with Esc Esc") |
"edit, exit with Esc Esc") |
7082 |
(?e (lambda (arg) |
(?e (lambda (arg) |
7083 |
(let ((buffer-quit-function |
(let ((buffer-quit-function |
7084 |
'exit-recursive-edit)) |
'exit-recursive-edit)) |
7103 |
(and (eq (following-char) ?\-) |
(and (eq (following-char) ?\-) |
7104 |
(save-excursion |
(save-excursion |
7105 |
(skip-chars-backward " \t\n") |
(skip-chars-backward " \t\n") |
7106 |
(memq (preceding-char) '(?\= ?\> ?\< ?\, ?\(, ?\[, ?\{)))) |
(memq (preceding-char) '(?\= ?\> ?\< ?\, ?\( ?\[ ?\{)))) |
7107 |
;; Now check for syntax type |
;; Now check for syntax type |
7108 |
(save-match-data |
(save-match-data |
7109 |
(setq found (point)) |
(setq found (point)) |
7116 |
found-bad found))) |
found-bad found))) |
7117 |
(not not-found))) |
(not not-found))) |
7118 |
|
|
7119 |
|
|
7120 |
;;; Getting help |
;;; Getting help |
7121 |
(defvar cperl-have-help-regexp |
(defvar cperl-have-help-regexp |
7122 |
;;(concat "\\(" |
;;(concat "\\(" |
7123 |
(mapconcat |
(mapconcat |
7124 |
'identity |
'identity |
7125 |
'("[$@%*&][0-9a-zA-Z_:]+\\([ \t]*[[{]\\)?" ; Usual variable |
'("[$@%*&][0-9a-zA-Z_:]+\\([ \t]*[[{]\\)?" ; Usual variable |
7126 |
"[$@]\\^[a-zA-Z]" ; Special variable |
"[$@]\\^[a-zA-Z]" ; Special variable |
7127 |
"[$@][^ \n\t]" ; Special variable |
"[$@][^ \n\t]" ; Special variable |
7128 |
"-[a-zA-Z]" ; File test |
"-[a-zA-Z]" ; File test |
7129 |
"\\\\[a-zA-Z0]" ; Special chars |
"\\\\[a-zA-Z0]" ; Special chars |
7130 |
"^=[a-z][a-zA-Z0-9_]*" ; Pod sections |
"^=[a-z][a-zA-Z0-9_]*" ; POD sections |
7131 |
"[-!&*+,-./<=>?\\\\^|~]+" ; Operator |
"[-!&*+,-./<=>?\\\\^|~]+" ; Operator |
7132 |
"[a-zA-Z_0-9:]+" ; symbol or number |
"[a-zA-Z_0-9:]+" ; symbol or number |
7133 |
"x=" |
"x=" |
7134 |
"#!" |
"#!") |
|
) |
|
7135 |
;;"\\)\\|\\(" |
;;"\\)\\|\\(" |
7136 |
"\\|" |
"\\|") |
7137 |
) |
;;"\\)" |
7138 |
;;"\\)" |
;;) |
|
;;) |
|
7139 |
"Matches places in the buffer we can find help for.") |
"Matches places in the buffer we can find help for.") |
7140 |
|
|
7141 |
(defvar cperl-message-on-help-error t) |
(defvar cperl-message-on-help-error t) |
7145 |
;; Does not save-excursion |
;; Does not save-excursion |
7146 |
;; Get to the something meaningful |
;; Get to the something meaningful |
7147 |
(or (eobp) (eolp) (forward-char 1)) |
(or (eobp) (eolp) (forward-char 1)) |
7148 |
(re-search-backward "[-a-zA-Z0-9_:!&*+,-./<=>?\\\\^|~$%@]" |
(re-search-backward "[-a-zA-Z0-9_:!&*+,-./<=>?\\\\^|~$%@]" |
7149 |
(save-excursion (beginning-of-line) (point)) |
(save-excursion (beginning-of-line) (point)) |
7150 |
'to-beg) |
'to-beg) |
7151 |
;; (cond |
;; (cond |
7156 |
(cond |
(cond |
7157 |
((looking-at "[a-zA-Z0-9_:]") ; symbol |
((looking-at "[a-zA-Z0-9_:]") ; symbol |
7158 |
(skip-chars-backward "a-zA-Z0-9_:") |
(skip-chars-backward "a-zA-Z0-9_:") |
7159 |
(cond |
(cond |
7160 |
((and (eq (preceding-char) ?^) ; $^I |
((and (eq (preceding-char) ?^) ; $^I |
7161 |
(eq (char-after (- (point) 2)) ?\$)) |
(eq (char-after (- (point) 2)) ?\$)) |
7162 |
(forward-char -2)) |
(forward-char -2)) |
7210 |
nil |
nil |
7211 |
(cperl-describe-perl-symbol word)) |
(cperl-describe-perl-symbol word)) |
7212 |
(if cperl-message-on-help-error |
(if cperl-message-on-help-error |
7213 |
(message "Nothing found for %s..." |
(message "Nothing found for %s..." |
7214 |
(buffer-substring (point) (min (+ 5 (point)) (point-max)))))))))) |
(buffer-substring (point) (min (+ 5 (point)) (point-max)))))))))) |
7215 |
|
|
7216 |
;;; Stolen from perl-descr.el by Johan Vromans: |
;;; Stolen from perl-descr.el by Johan Vromans: |
7223 |
(let ((enable-recursive-minibuffers t) |
(let ((enable-recursive-minibuffers t) |
7224 |
args-file regexp) |
args-file regexp) |
7225 |
(cond |
(cond |
7226 |
((string-match "^[&*][a-zA-Z_]" val) |
((string-match "^[&*][a-zA-Z_]" val) |
7227 |
(setq val (concat (substring val 0 1) "NAME"))) |
(setq val (concat (substring val 0 1) "NAME"))) |
7228 |
((string-match "^[$@]\\([a-zA-Z_:0-9]+\\)[ \t]*\\[" val) |
((string-match "^[$@]\\([a-zA-Z_:0-9]+\\)[ \t]*\\[" val) |
7229 |
(setq val (concat "@" (substring val 1 (match-end 1))))) |
(setq val (concat "@" (substring val 1 (match-end 1))))) |
7230 |
((string-match "^[$@]\\([a-zA-Z_:0-9]+\\)[ \t]*{" val) |
((string-match "^[$@]\\([a-zA-Z_:0-9]+\\)[ \t]*{" val) |
7231 |
(setq val (concat "%" (substring val 1 (match-end 1))))) |
(setq val (concat "%" (substring val 1 (match-end 1))))) |
7232 |
((and (string= val "x") (string-match "^x=" val)) |
((and (string= val "x") (string-match "^x=" val)) |
7233 |
(setq val "x=")) |
(setq val "x=")) |
7234 |
((string-match "^\\$[\C-a-\C-z]" val) |
((string-match "^\\$[\C-a-\C-z]" val) |
7235 |
(setq val (concat "$^" (char-to-string (+ ?A -1 (aref val 1)))))) |
(setq val (concat "$^" (char-to-string (+ ?A -1 (aref val 1)))))) |
7236 |
((string-match "^CORE::" val) |
((string-match "^CORE::" val) |
7237 |
(setq val "CORE::")) |
(setq val "CORE::")) |
7238 |
((string-match "^SUPER::" val) |
((string-match "^SUPER::" val) |
7239 |
(setq val "SUPER::")) |
(setq val "SUPER::")) |
7240 |
((and (string= "<" val) (string-match "^<\\$?[a-zA-Z0-9_:]+>" val)) |
((and (string= "<" val) (string-match "^<\\$?[a-zA-Z0-9_:]+>" val)) |
7241 |
(setq val "<NAME>"))) |
(setq val "<NAME>"))) |
7242 |
(setq regexp (concat "^" |
(setq regexp (concat "^" |
7243 |
"\\([^a-zA-Z0-9_:]+[ \t]+\\)?" |
"\\([^a-zA-Z0-9_:]+[ \t]+\\)?" |
7244 |
(regexp-quote val) |
(regexp-quote val) |
7245 |
"\\([ \t([/]\\|$\\)")) |
"\\([ \t([/]\\|$\\)")) |
7246 |
|
|
7247 |
;; get the buffer with the documentation text |
;; get the buffer with the documentation text |
7250 |
;; lookup in the doc |
;; lookup in the doc |
7251 |
(goto-char (point-min)) |
(goto-char (point-min)) |
7252 |
(let ((case-fold-search nil)) |
(let ((case-fold-search nil)) |
7253 |
(list |
(list |
7254 |
(if (re-search-forward regexp (point-max) t) |
(if (re-search-forward regexp (point-max) t) |
7255 |
(save-excursion |
(save-excursion |
7256 |
(beginning-of-line 1) |
(beginning-of-line 1) |
7260 |
(if cperl-message-on-help-error |
(if cperl-message-on-help-error |
7261 |
(message "No definition for %s" val))))))) |
(message "No definition for %s" val))))))) |
7262 |
|
|
7263 |
(defvar cperl-short-docs "Ignore my value" |
(defvar cperl-short-docs 'please-ignore-this-line |
7264 |
;; Perl4 version was written by Johan Vromans (jvromans@squirrel.nl) |
;; Perl4 version was written by Johan Vromans (jvromans@squirrel.nl) |
7265 |
"# based on '@(#)@ perl-descr.el 1.9 - describe-perl-symbol' [Perl 5] |
"# based on '@(#)@ perl-descr.el 1.9 - describe-perl-symbol' [Perl 5] |
7266 |
! ... Logical negation. |
! ... Logical negation. |
7267 |
... != ... Numeric inequality. |
... != ... Numeric inequality. |
7268 |
... !~ ... Search pattern, substitution, or translation (negated). |
... !~ ... Search pattern, substitution, or translation (negated). |
7269 |
$! In numeric context: errno. In a string context: error string. |
$! In numeric context: errno. In a string context: error string. |
7322 |
$^W True if warnings are requested (perl -w flag). |
$^W True if warnings are requested (perl -w flag). |
7323 |
$^X The name under which perl was invoked (argv[0] in C-speech). |
$^X The name under which perl was invoked (argv[0] in C-speech). |
7324 |
$_ The default input and pattern-searching space. |
$_ The default input and pattern-searching space. |
7325 |
$| Auto-flush after write/print on current output channel? Default 0. |
$| Auto-flush after write/print on current output channel? Default 0. |
7326 |
$~ The name of the current report format. |
$~ The name of the current report format. |
7327 |
... % ... Modulo division. |
... % ... Modulo division. |
7328 |
... %= ... Modulo division assignment. |
... %= ... Modulo division assignment. |
7646 |
chr Converts a number to char with the same ordinal. |
chr Converts a number to char with the same ordinal. |
7647 |
else Part of if/unless {BLOCK} elsif {BLOCK} else {BLOCK}. |
else Part of if/unless {BLOCK} elsif {BLOCK} else {BLOCK}. |
7648 |
elsif Part of if/unless {BLOCK} elsif {BLOCK} else {BLOCK}. |
elsif Part of if/unless {BLOCK} elsif {BLOCK} else {BLOCK}. |
7649 |
exists $HASH{KEY} True if the key exists. |
exists $HASH{KEY} True if the key exists. |
7650 |
format [NAME] = Start of output format. Ended by a single dot (.) on a line. |
format [NAME] = Start of output format. Ended by a single dot (.) on a line. |
7651 |
formline PICTURE, LIST Backdoor into \"format\" processing. |
formline PICTURE, LIST Backdoor into \"format\" processing. |
7652 |
glob EXPR Synonym of <EXPR>. |
glob EXPR Synonym of <EXPR>. |
7724 |
(goto-char e) |
(goto-char e) |
7725 |
(beginning-of-line) |
(beginning-of-line) |
7726 |
(if (re-search-forward "[^ \t]" e t) |
(if (re-search-forward "[^ \t]" e t) |
7727 |
(progn ; Something before the ending delimiter |
(progn ; Something before the ending delimiter |
7728 |
(goto-char e) |
(goto-char e) |
7729 |
(delete-horizontal-space) |
(delete-horizontal-space) |
7730 |
(insert "\n") |
(insert "\n") |
7741 |
(indent-to-column c1) |
(indent-to-column c1) |
7742 |
(while (and |
(while (and |
7743 |
inline |
inline |
7744 |
(looking-at |
(looking-at |
7745 |
(concat "\\([a-zA-Z0-9]+[^*+{?]\\)" ; 1 word |
(concat "\\([a-zA-Z0-9]+[^*+{?]\\)" ; 1 word |
7746 |
"\\|" ; Embedded variable |
"\\|" ; Embedded variable |
7747 |
"\\$\\([a-zA-Z0-9_]+\\([[{]\\)?\\|[^\n \t)|]\\)" ; 2 3 |
"\\$\\([a-zA-Z0-9_]+\\([[{]\\)?\\|[^\n \t)|]\\)" ; 2 3 |
7754 |
"\\|" ; Grouping |
"\\|" ; Grouping |
7755 |
"\\((\\(\\?\\)?\\)" ; 7 8 |
"\\((\\(\\?\\)?\\)" ; 7 8 |
7756 |
"\\|" ; | |
"\\|" ; | |
7757 |
"\\(|\\)" ; 9 |
"\\(|\\)"))) ; 9 |
|
))) |
|
7758 |
(goto-char (match-end 0)) |
(goto-char (match-end 0)) |
7759 |
(setq spaces t) |
(setq spaces t) |
7760 |
(cond ((match-beginning 1) ; Alphanum word + junk |
(cond ((match-beginning 1) ; Alphanum word + junk |
7801 |
(set-marker m1 (point)) |
(set-marker m1 (point)) |
7802 |
(if (= level 1) |
(if (= level 1) |
7803 |
(if (progn ; indent rigidly if multiline |
(if (progn ; indent rigidly if multiline |
7804 |
;; In fact does not make a lot of sense, since |
;; In fact does not make a lot of sense, since |
7805 |
;; the starting position can be already lost due |
;; the starting position can be already lost due |
7806 |
;; to insertion of "\n" and " " |
;; to insertion of "\n" and " " |
7807 |
(goto-char tmp) |
(goto-char tmp) |
7864 |
(not spaces) |
(not spaces) |
7865 |
(insert " ")) |
(insert " ")) |
7866 |
(skip-chars-forward " \t")) |
(skip-chars-forward " \t")) |
7867 |
(or (looking-at "[#\n]") |
(or (looking-at "[#\n]") |
7868 |
(error "unknown code \"%s\" in a regexp" |
(error "Unknown code `%s' in a regexp" |
7869 |
(buffer-substring (point) (1+ (point))))) |
(buffer-substring (point) (1+ (point))))) |
7870 |
(and inline (end-of-line 2))) |
(and inline (end-of-line 2))) |
7871 |
;; Special-case the last line of group |
;; Special-case the last line of group |
7872 |
(if (and (>= (point) (marker-position e)) |
(if (and (>= (point) (marker-position e)) |
7873 |
(/= (current-indentation) c)) |
(/= (current-indentation) c)) |
7874 |
(progn |
(progn |
7875 |
(beginning-of-line) |
(beginning-of-line) |
7876 |
(setq s (point)) |
(setq s (point)) |
7877 |
(skip-chars-forward " \t") |
(skip-chars-forward " \t") |
7878 |
(delete-region s (point)) |
(delete-region s (point)) |
7879 |
(indent-to-column c))) |
(indent-to-column c))))) |
|
)) |
|
7880 |
|
|
7881 |
(defun cperl-make-regexp-x () |
(defun cperl-make-regexp-x () |
7882 |
;; Returns position of the start |
;; Returns position of the start |
7889 |
nil ; good already |
nil ; good already |
7890 |
(if (looking-at "\\([smy]\\|qr\\)\\s|") |
(if (looking-at "\\([smy]\\|qr\\)\\s|") |
7891 |
(forward-char 1) |
(forward-char 1) |
7892 |
(re-search-backward "\\s|"))) ; Assume it is scanned already. |
(re-search-backward "\\s|"))) ; Assume it is scanned already. |
7893 |
;;(forward-char 1) |
;;(forward-char 1) |
7894 |
(let ((b (point)) (e (make-marker)) have-x delim (c (current-column)) |
(let ((b (point)) (e (make-marker)) have-x delim (c (current-column)) |
7895 |
(sub-p (eq (preceding-char) ?s)) s) |
(sub-p (eq (preceding-char) ?s)) s) |
7899 |
(if (and sub-p (eq delim (char-after (- (point) 2)))) |
(if (and sub-p (eq delim (char-after (- (point) 2)))) |
7900 |
(error "Possible s/blah// - do not know how to deal with")) |
(error "Possible s/blah// - do not know how to deal with")) |
7901 |
(if sub-p (forward-sexp 1)) |
(if sub-p (forward-sexp 1)) |
7902 |
(if (looking-at "\\sw*x") |
(if (looking-at "\\sw*x") |
7903 |
(setq have-x t) |
(setq have-x t) |
7904 |
(insert "x")) |
(insert "x")) |
7905 |
;; Protect fragile " ", "#" |
;; Protect fragile " ", "#" |
7912 |
b))) |
b))) |
7913 |
|
|
7914 |
(defun cperl-beautify-regexp (&optional deep) |
(defun cperl-beautify-regexp (&optional deep) |
7915 |
"do it. (Experimental, may change semantics, recheck the result.) |
"Do it. (Experimental, may change semantics, recheck the result.) |
7916 |
We suppose that the regexp is scanned already." |
We suppose that the regexp is scanned already." |
7917 |
(interactive "P") |
(interactive "P") |
7918 |
(if deep |
(setq deep (if deep (prefix-numeric-value deep) -1)) |
|
(prefix-numeric-value deep) |
|
|
(setq deep -1)) |
|
7919 |
(save-excursion |
(save-excursion |
7920 |
(goto-char (cperl-make-regexp-x)) |
(goto-char (cperl-make-regexp-x)) |
7921 |
(let ((b (point)) (e (make-marker))) |
(let ((b (point)) (e (make-marker))) |
7944 |
We suppose that the regexp is scanned already." |
We suppose that the regexp is scanned already." |
7945 |
(interactive) |
(interactive) |
7946 |
;; (save-excursion ; Can't, breaks `cperl-contract-levels' |
;; (save-excursion ; Can't, breaks `cperl-contract-levels' |
7947 |
(cperl-regext-to-level-start) |
(cperl-regext-to-level-start) |
7948 |
(let ((b (point)) (e (make-marker)) s c) |
(let ((b (point)) (e (make-marker)) s c) |
7949 |
(forward-sexp 1) |
(forward-sexp 1) |
7950 |
(set-marker e (1- (point))) |
(set-marker e (1- (point))) |
7951 |
(goto-char b) |
(goto-char b) |
7952 |
(while (re-search-forward "\\(#\\)\\|\n" e 'to-end) |
(while (re-search-forward "\\(#\\)\\|\n" e 'to-end) |
7953 |
(cond |
(cond |
7954 |
((match-beginning 1) ; #-comment |
((match-beginning 1) ; #-comment |
7955 |
(or c (setq c (current-indentation))) |
(or c (setq c (current-indentation))) |
7956 |
(beginning-of-line 2) ; Skip |
(beginning-of-line 2) ; Skip |
7957 |
(setq s (point)) |
(setq s (point)) |
7958 |
(skip-chars-forward " \t") |
(skip-chars-forward " \t") |
7959 |
(delete-region s (point)) |
(delete-region s (point)) |
7960 |
(indent-to-column c)) |
(indent-to-column c)) |
7961 |
(t |
(t |
7962 |
(delete-char -1) |
(delete-char -1) |
7963 |
(just-one-space)))))) |
(just-one-space)))))) |
7964 |
|
|
7965 |
(defun cperl-contract-levels () |
(defun cperl-contract-levels () |
7966 |
"Find an enclosing group in regexp and contract all the kids. |
"Find an enclosing group in regexp and contract all the kids. |
7977 |
(set-marker e (1- (point))) |
(set-marker e (1- (point))) |
7978 |
(goto-char (1+ b)) |
(goto-char (1+ b)) |
7979 |
(while (re-search-forward "\\(\\\\\\\\\\)\\|(" e t) |
(while (re-search-forward "\\(\\\\\\\\\\)\\|(" e t) |
7980 |
(cond |
(cond |
7981 |
((match-beginning 1) ; Skip |
((match-beginning 1) ; Skip |
7982 |
nil) |
nil) |
7983 |
(t ; Group |
(t ; Group |
7988 |
\(Experimental, may change semantics, recheck the result.) |
\(Experimental, may change semantics, recheck the result.) |
7989 |
We suppose that the regexp is scanned already." |
We suppose that the regexp is scanned already." |
7990 |
(interactive "P") |
(interactive "P") |
7991 |
(if deep |
(setq deep (if deep (prefix-numeric-value deep) -1)) |
|
(prefix-numeric-value deep) |
|
|
(setq deep -1)) |
|
7992 |
(save-excursion |
(save-excursion |
7993 |
(cperl-regext-to-level-start) |
(cperl-regext-to-level-start) |
7994 |
(let ((b (point)) (e (make-marker))) |
(let ((b (point)) (e (make-marker))) |
8000 |
"Change `if (A) {B}' into `B if A;' etc if possible." |
"Change `if (A) {B}' into `B if A;' etc if possible." |
8001 |
(interactive) |
(interactive) |
8002 |
(or (looking-at "\\<") |
(or (looking-at "\\<") |
8003 |
(forward-sexp -1)) |
(forward-sexp -1)) |
8004 |
(if (looking-at "\\<\\(if\\|unless\\|while\\|until\\|for\\|foreach\\)\\>") |
(if (looking-at "\\<\\(if\\|unless\\|while\\|until\\|for\\|foreach\\)\\>") |
8005 |
(let ((pos1 (point)) |
(let ((pos1 (point)) |
8006 |
pos2 pos3 pos4 pos5 s1 s2 state p pos45 |
pos2 pos3 pos4 pos5 s1 s2 state p pos45 |
8040 |
(setq p (match-beginning 0) |
(setq p (match-beginning 0) |
8041 |
s1 (buffer-substring p (match-end 0)) |
s1 (buffer-substring p (match-end 0)) |
8042 |
state (parse-partial-sexp pos4 p)) |
state (parse-partial-sexp pos4 p)) |
8043 |
(or (nth 3 state) |
(or (nth 3 state) |
8044 |
(nth 4 state) |
(nth 4 state) |
8045 |
(nth 5 state) |
(nth 5 state) |
8046 |
(error "`%s' inside `%s' BLOCK" s1 s0)) |
(error "`%s' inside `%s' BLOCK" s1 s0)) |
8080 |
(cperl-indent-line)) |
(cperl-indent-line)) |
8081 |
(error "`%s' (EXPR) not with an {BLOCK}" s0))) |
(error "`%s' (EXPR) not with an {BLOCK}" s0))) |
8082 |
(error "`%s' not with an (EXPR)" s0))) |
(error "`%s' not with an (EXPR)" s0))) |
8083 |
(error "Not at `if', `unless', `while', `unless', `for' or `foreach'"))) |
(error "Not at `if', `unless', `while', `until', `for' or `foreach'"))) |
8084 |
|
|
8085 |
;;; By Anthony Foiani <afoiani@uswest.com> |
;;; By Anthony Foiani <afoiani@uswest.com> |
8086 |
;;; Getting help on modules in C-h f ? |
;;; Getting help on modules in C-h f ? |
8100 |
(error "No perldoc args given") |
(error "No perldoc args given") |
8101 |
default-entry) |
default-entry) |
8102 |
input)))) |
input)))) |
8103 |
(let* ((is-func (and |
(require 'man) |
8104 |
|
(let* ((is-func (and |
8105 |
(string-match "^[a-z]+$" word) |
(string-match "^[a-z]+$" word) |
8106 |
(string-match (concat "^" word "\\>") |
(string-match (concat "^" word "\\>") |
8107 |
(documentation-property |
(documentation-property |
8108 |
'cperl-short-docs |
'cperl-short-docs |
8109 |
'variable-documentation)))) |
'variable-documentation)))) |
8110 |
(manual-program (if is-func "perldoc -f" "perldoc"))) |
(manual-program (if is-func "perldoc -f" "perldoc"))) |
|
(require 'man) |
|
8111 |
(Man-getpage-in-background word))) |
(Man-getpage-in-background word))) |
8112 |
|
|
8113 |
(defun cperl-perldoc-at-point () |
(defun cperl-perldoc-at-point () |
8172 |
(not cperl-lazy-installed)) |
(not cperl-lazy-installed)) |
8173 |
(progn |
(progn |
8174 |
(add-hook 'post-command-hook 'cperl-lazy-hook) |
(add-hook 'post-command-hook 'cperl-lazy-hook) |
8175 |
(run-with-idle-timer |
(run-with-idle-timer |
8176 |
(cperl-val 'cperl-lazy-help-time 1000000 5) |
(cperl-val 'cperl-lazy-help-time 1000000 5) |
8177 |
t |
t |
8178 |
'cperl-get-help-defer) |
'cperl-get-help-defer) |
8179 |
(setq cperl-lazy-installed t)))) |
(setq cperl-lazy-installed t)))) |
8180 |
|
|
8188 |
(setq cperl-help-shown nil)) |
(setq cperl-help-shown nil)) |
8189 |
|
|
8190 |
(defun cperl-get-help-defer () |
(defun cperl-get-help-defer () |
8191 |
(if (not (eq major-mode 'perl-mode)) nil |
(if (not (memq major-mode '(perl-mode cperl-mode))) nil |
8192 |
(let ((cperl-message-on-help-error nil) (cperl-help-from-timer t)) |
(let ((cperl-message-on-help-error nil) (cperl-help-from-timer t)) |
8193 |
(cperl-get-help) |
(cperl-get-help) |
8194 |
(setq cperl-help-shown t)))) |
(setq cperl-help-shown t)))) |
8210 |
(defun cperl-fontify-syntaxically (end) |
(defun cperl-fontify-syntaxically (end) |
8211 |
;; Some vars for debugging only |
;; Some vars for debugging only |
8212 |
;; (message "Syntaxifying...") |
;; (message "Syntaxifying...") |
8213 |
(let (start (dbg (point)) (iend end) |
(let ((dbg (point)) (iend end) |
8214 |
(istate (car cperl-syntax-state))) |
(istate (car cperl-syntax-state)) |
8215 |
|
start) |
8216 |
(and cperl-syntaxify-unwind |
(and cperl-syntaxify-unwind |
8217 |
(setq end (cperl-unwind-to-safe t end))) |
(setq end (cperl-unwind-to-safe t end))) |
8218 |
(setq start (point)) |
(setq start (point)) |
8229 |
(setq cperl-syntax-done-to start) ; In case what follows fails |
(setq cperl-syntax-done-to start) ; In case what follows fails |
8230 |
(cperl-find-pods-heres start end t nil t)) |
(cperl-find-pods-heres start end t nil t)) |
8231 |
(if (eq cperl-syntaxify-by-font-lock 'message) |
(if (eq cperl-syntaxify-by-font-lock 'message) |
8232 |
(message "Syntaxified %s..%s from %s to %s(%s), state %s-->%s" |
(message "Syntaxified %s..%s from %s to %s(%s), state %s-->%s" |
8233 |
dbg iend |
dbg iend |
8234 |
start end cperl-syntax-done-to |
start end cperl-syntax-done-to |
8235 |
istate (car cperl-syntax-state))) ; For debugging |
istate (car cperl-syntax-state))) ; For debugging |
8236 |
nil)) ; Do not iterate |
nil)) ; Do not iterate |
8237 |
|
|
8238 |
(defun cperl-fontify-update (end) |
(defun cperl-fontify-update (end) |
8242 |
(setq posend (next-single-property-change pos 'cperl-postpone nil end)) |
(setq posend (next-single-property-change pos 'cperl-postpone nil end)) |
8243 |
(and prop (put-text-property pos posend (car prop) (cdr prop))) |
(and prop (put-text-property pos posend (car prop) (cdr prop))) |
8244 |
(setq pos posend))) |
(setq pos posend))) |
8245 |
nil) ; Do not iterate |
nil) ; Do not iterate |
8246 |
|
|
8247 |
(defun cperl-update-syntaxification (from to) |
(defun cperl-update-syntaxification (from to) |
8248 |
(if (and cperl-use-syntax-table-text-property |
(if (and cperl-use-syntax-table-text-property |
8254 |
(goto-char from) |
(goto-char from) |
8255 |
(cperl-fontify-syntaxically to))))) |
(cperl-fontify-syntaxically to))))) |
8256 |
|
|
8257 |
(defvar cperl-version |
(defvar cperl-version |
8258 |
(let ((v "$Revision$")) |
(let ((v "$Revision$")) |
8259 |
(string-match ":\\s *\\([0-9.]+\\)" v) |
(string-match ":\\s *\\([0-9.]+\\)" v) |
8260 |
(substring v (match-beginning 1) (match-end 1))) |
(substring v (match-beginning 1) (match-end 1))) |