/[emacs]/emacs/lisp/progmodes/cperl-mode.el
ViewVC logotype

Diff of /emacs/lisp/progmodes/cperl-mode.el

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.1.1.2 by monnier, Tue Mar 6 22:06:44 2001 UTC revision 1.1.1.3 by monnier, Wed Feb 19 21:12:47 2003 UTC
# Line 1  Line 1 
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.
# Line 41  Line 39 
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:
# Line 54  Line 52 
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
# Line 107  Line 112 
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).
# Line 129  Line 134 
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:
# Line 138  Line 143 
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):
# Line 155  Line 160 
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.
# Line 191  Line 196 
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.
# Line 231  Line 236 
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
# Line 241  Line 246 
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.
# Line 251  Line 256 
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
# Line 312  Line 317 
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
# Line 380  Line 385 
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 ($) {}
# Line 472  Line 477 
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)
# Line 491  Line 496 
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    
# Line 527  Line 532 
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    
# Line 562  Line 567 
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:
# Line 571  Line 576 
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.
# Line 593  Line 598 
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.
# Line 646  Line 651 
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:
# Line 804  Line 809 
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.
# Line 813  Line 818 
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 <<<<
# Line 838  Line 843 
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:
# Line 906  Line 911 
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    
# Line 963  Line 968 
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:
# Line 1045  Line 1050 
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    
# Line 1054  Line 1084 
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))
# Line 1061  Line 1102 
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))))
# Line 1074  Line 1115 
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
# Line 1103  Line 1144 
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
# Line 1176  and do constructs look like: Line 1225  and do constructs look like:
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."
# Line 1195  for constructs with multiline if/unless/ Line 1243  for constructs with multiline if/unless/
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    
# Line 1236  This is in addition to cperl-continued-s Line 1284  This is in addition to cperl-continued-s
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)
# Line 1260  regardless of where in the line point is Line 1308  regardless of where in the line point is
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)
# Line 1285  Can be overwritten by `cperl-hairy' if n Line 1333  Can be overwritten by `cperl-hairy' if n
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)
# Line 1311  Can be overwritten by `cperl-hairy' if n Line 1359  Can be overwritten by `cperl-hairy' if n
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'."
# Line 1329  Affects: `cperl-font-lock', `cperl-elect Line 1377  Affects: `cperl-font-lock', `cperl-elect
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)
# Line 1360  Can be overwritten by `cperl-hairy' to b Line 1408  Can be overwritten by `cperl-hairy' to b
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)
# Line 1381  Font for POD headers." Line 1429  Font for POD headers."
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    
# Line 1391  Font for POD headers." Line 1439  Font for POD headers."
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)
# Line 1433  Older version of this page was called `p Line 1481  Older version of this page was called `p
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
# Line 1450  Older version of this page was called `p Line 1498  Older version of this page was called `p
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    
# Line 1491  than 1 and nil will probably not work." Line 1540  than 1 and nil will probably not work."
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)
# Line 1515  One should tune up `cperl-close-paren-of Line 1564  One should tune up `cperl-close-paren-of
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)
# Line 1524  One should tune up `cperl-close-paren-of Line 1573  One should tune up `cperl-close-paren-of
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)
# Line 1542  when syntaxifying a chunk of buffer." Line 1591  when syntaxifying a chunk of buffer."
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
# Line 1560  when syntaxifying a chunk of buffer." Line 1609  when syntaxifying a chunk of buffer."
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."
# Line 1573  when syntaxifying a chunk of buffer." Line 1622  when syntaxifying a chunk of buffer."
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."
# Line 1586  when syntaxifying a chunk of buffer." Line 1635  when syntaxifying a chunk of buffer."
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."
# Line 1599  when syntaxifying a chunk of buffer." Line 1648  when syntaxifying a chunk of buffer."
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
# Line 1610  For best results apply to an older Emacs Line 1659  For best results apply to an older Emacs
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
# Line 1625  mode-compile.el. Line 1673  mode-compile.el.
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
# Line 1637  from Perl menu).  If many files are rela Line 1689  from Perl menu).  If many files are rela
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    
# Line 1650  parsing of Perl even when editing, somet Line 1702  parsing of Perl even when editing, somet
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    
# Line 1669  yet. Line 1731  yet.
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
# Line 1688  braces. Line 1750  braces.
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.
# Line 1706  and on CPAN. Line 1768  and on CPAN.
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
# Line 1765  receive.  Note that some releases of XEm Line 1827  receive.  Note that some releases of XEm
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
# Line 1834  voice); Line 1896  voice);
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;
# Line 1842  whitespace *inside* the conditional/loop Line 1904  whitespace *inside* the conditional/loop
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
# Line 1881  syntax-parsing routines, and marks them Line 1942  syntax-parsing routines, and marks them
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'
# Line 1891  B) Speed of editing operations. Line 1952  B) Speed of editing operations.
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.)")
# Line 1933  the faces: please specify bold, italic, Line 1993  the faces: please specify bold, italic,
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
# Line 1945  the faces: please specify bold, italic, Line 2003  the faces: please specify bold, italic,
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
# Line 1962  the faces: please specify bold, italic, Line 2020  the faces: please specify bold, italic,
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)
# Line 1993  the faces: please specify bold, italic, Line 2051  the faces: please specify bold, italic,
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)
# Line 2019  the faces: please specify bold, italic, Line 2077  the faces: please specify bold, italic,
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    
# Line 2111  the faces: please specify bold, italic, Line 2155  the faces: please specify bold, italic,
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...
# Line 2137  the faces: please specify bold, italic, Line 2181  the faces: please specify bold, italic,
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"
# Line 2251  the faces: please specify bold, italic, Line 2296  the faces: please specify bold, italic,
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      ()      ()
# Line 2281  The expansion is entirely correct becaus Line 2337  The expansion is entirely correct becaus
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    
# Line 2298  The expansion is entirely correct becaus Line 2353  The expansion is entirely correct becaus
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 ()
# Line 2313  sometimes <>.  When the user types the f Line 2374  sometimes <>.  When the user types the f
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.
# Line 2323  look for active mark and \"embrace\" a r Line 2384  look for active mark and \"embrace\" a r
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'.)
# Line 2336  following \"if\" the following appears i Line 2397  following \"if\" the following appears i
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    
# Line 2355  you type it inside the inline block of c Line 2416  you type it inside the inline block of c
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
# Line 2387  If your site has perl5 documentation in Line 2448  If your site has perl5 documentation in
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
# Line 2405  beginning of the region at the start of Line 2466  beginning of the region at the start of
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    
# Line 2419  Variables controlling indentation style: Line 2480  Variables controlling indentation style:
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.
# Line 2456  corresponding variables.  Use \\[cperl-s Line 2517  corresponding variables.  Use \\[cperl-s
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'
# Line 2480  or as help on variables `cperl-tips', `c Line 2541  or as help on variables `cperl-tips', `c
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))
# Line 2543  or as help on variables `cperl-tips', `c Line 2604  or as help on variables `cperl-tips', `c
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)
# Line 2564  or as help on variables `cperl-tips', `c Line 2625  or as help on variables `cperl-tips', `c
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)
# Line 2604  or as help on variables `cperl-tips', `c Line 2668  or as help on variables `cperl-tips', `c
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)
# Line 2621  or as help on variables `cperl-tips', `c Line 2681  or as help on variables `cperl-tips', `c
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)
# Line 2638  or as help on variables `cperl-tips', `c Line 2697  or as help on variables `cperl-tips', `c
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))))
# Line 2688  or as help on variables `cperl-tips', `c Line 2747  or as help on variables `cperl-tips', `c
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
# Line 2730  See `comment-region'." Line 2789  See `comment-region'."
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)
# Line 2751  char is \"{\", insert extra newline befo Line 2810  char is \"{\", insert extra newline befo
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)))
# Line 2775  char is \"{\", insert extra newline befo Line 2834  char is \"{\", insert extra newline befo
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))
# Line 2788  char is \"{\", insert extra newline befo Line 2847  char is \"{\", insert extra newline befo
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))))
# Line 2801  char is \"{\", insert extra newline befo Line 2860  char is \"{\", insert extra newline befo
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
# Line 2819  char is \"{\", insert extra newline befo Line 2878  char is \"{\", insert extra newline befo
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]*#")))
# Line 2829  char is \"{\", insert extra newline befo Line 2888  char is \"{\", insert extra newline befo
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)
# Line 2842  char is \"{\", insert extra newline befo Line 2901  char is \"{\", insert extra newline befo
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
# Line 2862  char is \"{\", insert extra newline befo Line 2921  char is \"{\", insert extra newline befo
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                                                     (?[ . ?])                                                     (?[ . ?])
# Line 2880  If not, or if we are not at the end of m Line 2939  If not, or if we are not at the end of m
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
# Line 2898  If not, or if we are not at the end of m Line 2957  If not, or if we are not at the end of m
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    
# Line 2908  If not, or if we are not at the end of m Line 2967  If not, or if we are not at the end of m
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))
# Line 2921  to nil." Line 2980  to nil."
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)))
# Line 2939  to nil." Line 2998  to nil."
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)
# Line 2955  to nil." Line 3014  to nil."
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 ")"))
# Line 2986  to nil." Line 3044  to nil."
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]*$"))
# Line 2994  to nil." Line 3052  to nil."
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")
# Line 3014  to nil." Line 3072  to nil."
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)
# Line 3055  to nil." Line 3113  to nil."
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)))
# Line 3076  to nil." Line 3134  to nil."
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)
# Line 3095  If in POD, insert appropriate lines." Line 3152  If in POD, insert appropriate lines."
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)
# Line 3106  If in POD, insert appropriate lines." Line 3163  If in POD, insert appropriate lines."
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
# Line 3134  If in POD, insert appropriate lines." Line 3191  If in POD, insert appropriate lines."
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)
# Line 3144  If in POD, insert appropriate lines." Line 3201  If in POD, insert appropriate lines."
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
# Line 3153  If in POD, insert appropriate lines." Line 3210  If in POD, insert appropriate lines."
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
# Line 3161  If in POD, insert appropriate lines." Line 3218  If in POD, insert appropriate lines."
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)))
# Line 3205  If in POD, insert appropriate lines." Line 3262  If in POD, insert appropriate lines."
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)
# Line 3252  If in POD, insert appropriate lines." Line 3310  If in POD, insert appropriate lines."
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")
# Line 3269  by an electric key." Line 3327  by an electric key."
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)
# Line 3291  by an electric key." Line 3349  by an electric key."
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    
# Line 3327  The relative indentation among the lines Line 3385  The relative indentation among the lines
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)
# Line 3379  Return the amount the indentation change Line 3437  Return the amount the indentation change
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.
# Line 3407  Return the amount the indentation change Line 3465  Return the amount the indentation change
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))
# Line 3425  Return the amount the indentation change Line 3483  Return the amount the indentation change
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)))
# Line 3436  In usual case returns an integer: the co Line 3494  In usual case returns an integer: the co
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)
# Line 3444  and closing parentheses and brackets.." Line 3502  and closing parentheses and brackets.."
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:
# Line 3584  and closing parentheses and brackets.." Line 3642  and closing parentheses and brackets.."
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)
# Line 3766  Not finished, not used." Line 3824  Not finished, not used."
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.
# Line 3778  Not finished, not used." Line 3836  Not finished, not used."
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:
# Line 3792  Not finished, not used." Line 3850  Not finished, not used."
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))
# Line 3815  Not finished, not used." Line 3873  Not finished, not used."
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))
# Line 3848  Not finished, not used." Line 3906  Not finished, not used."
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
# Line 3912  the current line is to be regarded as pa Line 3970  the current line is to be regarded as pa
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)))
# Line 3973  Returns true if comment is found." Line 4030  Returns true if comment is found."
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.
# Line 3984  Returns true if comment is found." Line 4041  Returns true if comment is found."
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
# Line 4005  Returns true if comment is found." Line 4062  Returns true if comment is found."
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 == ?\\  ????
# Line 4071  Returns true if comment is found." Line 4128  Returns true if comment is found."
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)
# Line 4101  Returns true if comment is found." Line 4158  Returns true if comment is found."
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    
# Line 4157  Returns true if comment is found." Line 4214  Returns true if comment is found."
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
# Line 4269  the sections using `cperl-pod-head-face' Line 4325  the sections using `cperl-pod-head-face'
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
# Line 4304  the sections using `cperl-pod-head-face' Line 4360  the sections using `cperl-pod-head-face'
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
# Line 4320  the sections using `cperl-pod-head-face' Line 4376  the sections using `cperl-pod-head-face'
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
# Line 4343  the sections using `cperl-pod-head-face' Line 4399  the sections using `cperl-pod-head-face'
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
# Line 4373  the sections using `cperl-pod-head-face' Line 4429  the sections using `cperl-pod-head-face'
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)
# Line 4389  the sections using `cperl-pod-head-face' Line 4445  the sections using `cperl-pod-head-face'
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)))
# Line 4397  the sections using `cperl-pod-head-face' Line 4453  the sections using `cperl-pod-head-face'
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)
# Line 4432  the sections using `cperl-pod-head-face' Line 4488  the sections using `cperl-pod-head-face'
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
# Line 4448  the sections using `cperl-pod-head-face' Line 4504  the sections using `cperl-pod-head-face'
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)
# Line 4488  the sections using `cperl-pod-head-face' Line 4544  the sections using `cperl-pod-head-face'
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))
# Line 4505  the sections using `cperl-pod-head-face' Line 4561  the sections using `cperl-pod-head-face'
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)
# Line 4526  the sections using `cperl-pod-head-face' Line 4582  the sections using `cperl-pod-head-face'
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)
# Line 4546  the sections using `cperl-pod-head-face' Line 4602  the sections using `cperl-pod-head-face'
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)
# Line 4571  the sections using `cperl-pod-head-face' Line 4627  the sections using `cperl-pod-head-face'
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
# Line 4628  the sections using `cperl-pod-head-face' Line 4684  the sections using `cperl-pod-head-face'
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
# Line 4646  the sections using `cperl-pod-head-face' Line 4702  the sections using `cperl-pod-head-face'
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
# Line 4655  the sections using `cperl-pod-head-face' Line 4711  the sections using `cperl-pod-head-face'
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
# Line 4669  the sections using `cperl-pod-head-face' Line 4725  the sections using `cperl-pod-head-face'
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)
# Line 4686  the sections using `cperl-pod-head-face' Line 4742  the sections using `cperl-pod-head-face'
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))))
# Line 4702  the sections using `cperl-pod-head-face' Line 4758  the sections using `cperl-pod-head-face'
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))))
# Line 4722  the sections using `cperl-pod-head-face' Line 4778  the sections using `cperl-pod-head-face'
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))
# Line 4735  the sections using `cperl-pod-head-face' Line 4791  the sections using `cperl-pod-head-face'
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
# Line 4751  the sections using `cperl-pod-head-face' Line 4807  the sections using `cperl-pod-head-face'
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
# Line 4763  the sections using `cperl-pod-head-face' Line 4819  the sections using `cperl-pod-head-face'
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))
# Line 4778  the sections using `cperl-pod-head-face' Line 4834  the sections using `cperl-pod-head-face'
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) )
# Line 4788  the sections using `cperl-pod-head-face' Line 4844  the sections using `cperl-pod-head-face'
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)))
# Line 4814  the sections using `cperl-pod-head-face' Line 4870  the sections using `cperl-pod-head-face'
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 }.
# Line 4846  the sections using `cperl-pod-head-face' Line 4901  the sections using `cperl-pod-head-face'
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)
# Line 4859  CHARS is a string that contains good cha Line 4914  CHARS is a string that contains good cha
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))
# Line 4890  CHARS is a string that contains good cha Line 4945  CHARS is a string that contains good cha
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)
# Line 4900  CHARS is a string that contains good cha Line 4955  CHARS is a string that contains good cha
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    
# Line 4914  CHARS is a string that contains good cha Line 4969  CHARS is a string that contains good cha
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
# Line 4947  Returns some position at the last line." Line 5002  Returns some position at the last line."
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
# Line 5129  Returns some position at the last line." Line 5184  Returns some position at the last line."
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)
# Line 5158  conditional/loop constructs." Line 5213  conditional/loop constructs."
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
# Line 5175  conditional/loop constructs." Line 5230  conditional/loop constructs."
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)))
# Line 5200  conditional/loop constructs." Line 5255  conditional/loop constructs."
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    
# Line 5219  If any of the current line is a comment, Line 5273  If any of the current line is a comment,
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.
# Line 5245  indentation and initial hashes.  Behaves Line 5298  indentation and initial hashes.  Behaves
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
# Line 5278  indentation and initial hashes.  Behaves Line 5331  indentation and initial hashes.  Behaves
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.
# Line 5287  indentation and initial hashes.  Behaves Line 5340  indentation and initial hashes.  Behaves
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)
# Line 5303  indentation and initial hashes.  Behaves Line 5356  indentation and initial hashes.  Behaves
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
# Line 5334  indentation and initial hashes.  Behaves Line 5379  indentation and initial hashes.  Behaves
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
# Line 5364  indentation and initial hashes.  Behaves Line 5408  indentation and initial hashes.  Behaves
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))
# Line 5373  indentation and initial hashes.  Behaves Line 5417  indentation and initial hashes.  Behaves
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
# Line 5383  indentation and initial hashes.  Behaves Line 5427  indentation and initial hashes.  Behaves
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 () ;"
# Line 5400  indentation and initial hashes.  Behaves Line 5443  indentation and initial hashes.  Behaves
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)
# Line 5414  indentation and initial hashes.  Behaves Line 5457  indentation and initial hashes.  Behaves
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)))
# Line 5440  indentation and initial hashes.  Behaves Line 5483  indentation and initial hashes.  Behaves
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))
# Line 5460  indentation and initial hashes.  Behaves Line 5503  indentation and initial hashes.  Behaves
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))))
# Line 5487  indentation and initial hashes.  Behaves Line 5530  indentation and initial hashes.  Behaves
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+..."
# Line 5496  indentation and initial hashes.  Behaves Line 5539  indentation and initial hashes.  Behaves
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)
# Line 5514  indentation and initial hashes.  Behaves Line 5554  indentation and initial hashes.  Behaves
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))
# Line 5522  indentation and initial hashes.  Behaves Line 5562  indentation and initial hashes.  Behaves
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 ()
# Line 5535  indentation and initial hashes.  Behaves Line 5575  indentation and initial hashes.  Behaves
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))
# Line 5584  indentation and initial hashes.  Behaves Line 5622  indentation and initial hashes.  Behaves
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)
# Line 5637  indentation and initial hashes.  Behaves Line 5675  indentation and initial hashes.  Behaves
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\\)\\)\\)\\|"
# Line 5708  indentation and initial hashes.  Behaves Line 5746  indentation and initial hashes.  Behaves
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
# Line 5721  indentation and initial hashes.  Behaves Line 5759  indentation and initial hashes.  Behaves
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
# Line 5735  indentation and initial hashes.  Behaves Line 5773  indentation and initial hashes.  Behaves
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_:]+\\)"
# Line 5747  indentation and initial hashes.  Behaves Line 5785  indentation and initial hashes.  Behaves
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)) ?%)
# Line 5759  indentation and initial hashes.  Behaves Line 5797  indentation and initial hashes.  Behaves
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
# Line 5767  indentation and initial hashes.  Behaves Line 5805  indentation and initial hashes.  Behaves
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)
# Line 5790  indentation and initial hashes.  Behaves Line 5828  indentation and initial hashes.  Behaves
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")
# Line 5909  indentation and initial hashes.  Behaves Line 5944  indentation and initial hashes.  Behaves
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
# Line 5934  indentation and initial hashes.  Behaves Line 5969  indentation and initial hashes.  Behaves
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))
# Line 5951  indentation and initial hashes.  Behaves Line 5984  indentation and initial hashes.  Behaves
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
# Line 6030  indentation and initial hashes.  Behaves Line 6062  indentation and initial hashes.  Behaves
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
# Line 6057  to the file FILE.  If FILE is nil, promp Line 6089  to the file FILE.  If FILE is nil, promp
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)))
# Line 6079  Style of printout regulated by the varia Line 6111  Style of printout regulated by the varia
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))
# Line 6106  Style of printout regulated by the varia Line 6138  Style of printout regulated by the varia
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)
# Line 6120  Style of printout regulated by the varia Line 6152  Style of printout regulated by the varia
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)
# Line 6171  Style of printout regulated by the varia Line 6203  Style of printout regulated by the varia
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
# Line 6181  data already), may be restored by `cperl Line 6213  data already), may be restored by `cperl
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))))
# Line 6202  side-effect of memorizing only." Line 6234  side-effect of memorizing only."
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    
# Line 6235  side-effect of memorizing only." Line 6267  side-effect of memorizing only."
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)
# Line 6254  side-effect of memorizing only." Line 6286  side-effect of memorizing only."
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///"
# Line 6279  Customized by setting variables `cperl-s Line 6311  Customized by setting variables `cperl-s
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)
# Line 6288  Customized by setting variables `cperl-s Line 6320  Customized by setting variables `cperl-s
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)
# Line 6307  Customized by setting variables `cperl-s Line 6339  Customized by setting variables `cperl-s
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
# Line 6337  Customized by setting variables `cperl-s Line 6368  Customized by setting variables `cperl-s
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    
# Line 6347  Customized by setting variables `cperl-s Line 6378  Customized by setting variables `cperl-s
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    
# Line 6355  Customized by setting variables `cperl-s Line 6386  Customized by setting variables `cperl-s
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
# Line 6387  partially contained in the region are li Line 6418  partially contained in the region are li
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")
# Line 6405  Will not move the position at the start Line 6436  Will not move the position at the start
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"))
# Line 6417  Will not move the position at the start Line 6448  Will not move the position at the start
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)
# Line 6427  Will not move the position at the start Line 6458  Will not move the position at the start
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    
# Line 6451  in subdirectories too." Line 6482  in subdirectories too."
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
# Line 6475  in subdirectories too." Line 6506  in subdirectories too."
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    
# Line 6490  in subdirectories too." Line 6521  in subdirectories too."
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 ()
# Line 6502  See `cperl-lazy-help-time' too." Line 6533  See `cperl-lazy-help-time' too."
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.
# Line 6527  See `cperl-lazy-help-time' too." Line 6558  See `cperl-lazy-help-time' too."
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
# Line 6548  See `cperl-lazy-help-time' too." Line 6579  See `cperl-lazy-help-time' too."
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")
# Line 6581  See `cperl-lazy-help-time' too." Line 6612  See `cperl-lazy-help-time' too."
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)))
# Line 6594  See `cperl-lazy-help-time' too." Line 6625  See `cperl-lazy-help-time' too."
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    
# Line 6675  Use as Line 6706  Use as
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    
# Line 6696  Use as Line 6727  Use as
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
# Line 6704  Use as Line 6735  Use as
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       "\\|"       "\\|"
# Line 6770  Use as Line 6801  Use as
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
# Line 6807  Use as Line 6838  Use as
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
# Line 6823  One may build such TAGS files from CPerl Line 6854  One may build such TAGS files from CPerl
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
# Line 6862  One may build such TAGS files from CPerl Line 6893  One may build such TAGS files from CPerl
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))))
# Line 6877  One may build such TAGS files from CPerl Line 6911  One may build such TAGS files from CPerl
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                                   "::")                                   "::")
# Line 6941  One may build such TAGS files from CPerl Line 6975  One may build such TAGS files from CPerl
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)
# Line 6958  One may build such TAGS files from CPerl Line 6991  One may build such TAGS files from CPerl
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)
# Line 6974  One may build such TAGS files from CPerl Line 7007  One may build such TAGS files from CPerl
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
# Line 6991  One may build such TAGS files from CPerl Line 7024  One may build such TAGS files from CPerl
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)
# Line 7017  One may build such TAGS files from CPerl Line 7050  One may build such TAGS files from CPerl
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       )       )
# Line 7036  Currently it is tuned to C and Perl synt Line 7069  Currently it is tuned to C and Perl synt
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))
# Line 7070  Currently it is tuned to C and Perl synt Line 7103  Currently it is tuned to C and Perl synt
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))
# Line 7083  Currently it is tuned to C and Perl synt Line 7116  Currently it is tuned to C and Perl synt
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)
# Line 7114  Currently it is tuned to C and Perl synt Line 7145  Currently it is tuned to C and Perl synt
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
# Line 7125  Currently it is tuned to C and Perl synt Line 7156  Currently it is tuned to C and Perl synt
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))
# Line 7179  than a line.  Your contribution to updat Line 7210  than a line.  Your contribution to updat
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:
# Line 7192  than a line.  Your contribution to updat Line 7223  than a line.  Your contribution to updat
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
# Line 7219  than a line.  Your contribution to updat Line 7250  than a line.  Your contribution to updat
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)
# Line 7229  than a line.  Your contribution to updat Line 7260  than a line.  Your contribution to updat
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.
# Line 7291  $^T    The time the script was started.  Us Line 7322  $^T    The time the script was started.  Us
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.
# Line 7615  chomp [LIST]   Strips $/ off LIST/$_.  Ret Line 7646  chomp [LIST]   Strips $/ off LIST/$_.  Ret
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>.
# Line 7693  prototype \&SUB        Returns prototype of the Line 7724  prototype \&SUB        Returns prototype of the
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")
# Line 7710  prototype \&SUB        Returns prototype of the Line 7741  prototype \&SUB        Returns prototype of the
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
# Line 7723  prototype \&SUB        Returns prototype of the Line 7754  prototype \&SUB        Returns prototype of the
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
# Line 7771  prototype \&SUB        Returns prototype of the Line 7801  prototype \&SUB        Returns prototype of the
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)
# Line 7834  prototype \&SUB        Returns prototype of the Line 7864  prototype \&SUB        Returns prototype of the
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
# Line 7860  prototype \&SUB        Returns prototype of the Line 7889  prototype \&SUB        Returns prototype of the
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)
# Line 7870  prototype \&SUB        Returns prototype of the Line 7899  prototype \&SUB        Returns prototype of the
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 " ", "#"
# Line 7883  prototype \&SUB        Returns prototype of the Line 7912  prototype \&SUB        Returns prototype of the
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)))
# Line 7917  We suppose that the regexp is scanned al Line 7944  We suppose that the regexp is scanned al
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.
# Line 7950  We suppose that the regexp is scanned al Line 7977  We suppose that the regexp is scanned al
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
# Line 7961  We suppose that the regexp is scanned al Line 7988  We suppose that the regexp is scanned al
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)))
# Line 7975  We suppose that the regexp is scanned al Line 8000  We suppose that the regexp is scanned al
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
# Line 8015  We suppose that the regexp is scanned al Line 8040  We suppose that the regexp is scanned al
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))
# Line 8055  We suppose that the regexp is scanned al Line 8080  We suppose that the regexp is scanned al
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 ?
# Line 8075  We suppose that the regexp is scanned al Line 8100  We suppose that the regexp is scanned al
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 ()
# Line 8147  We suppose that the regexp is scanned al Line 8172  We suppose that the regexp is scanned al
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    
# Line 8163  We suppose that the regexp is scanned al Line 8188  We suppose that the regexp is scanned al
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))))
# Line 8185  We suppose that the regexp is scanned al Line 8210  We suppose that the regexp is scanned al
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))
# Line 8203  We suppose that the regexp is scanned al Line 8229  We suppose that the regexp is scanned al
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)
# Line 8216  We suppose that the regexp is scanned al Line 8242  We suppose that the regexp is scanned al
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
# Line 8228  We suppose that the regexp is scanned al Line 8254  We suppose that the regexp is scanned al
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)))

Legend:
Removed from v.1.1.1.2  
changed lines
  Added in v.1.1.1.3

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26