aboutsummaryrefslogtreecommitdiffstats
path: root/lisp
diff options
context:
space:
mode:
authorStefan Monnier2003-02-23 01:42:24 +0000
committerStefan Monnier2003-02-23 01:42:24 +0000
commit83261a2f134a3fbb8c5d4977b8e96e9fb136b744 (patch)
tree4345e60d3438c86fac0fdc3c3d482d0b6c9cdaf3 /lisp
parent7114be0e0ac73b752ab70a7159cdab2a32bf6f4c (diff)
downloademacs-83261a2f134a3fbb8c5d4977b8e96e9fb136b744.tar.gz
emacs-83261a2f134a3fbb8c5d4977b8e96e9fb136b744.zip
Merge changes from CPerl-4.35.
(cperl-xemacs-p): Move. (cperl-can-font-lock): New var to replace window-system. (cperl-enable-font-lock): Use it. (cperl-use-major-mode): New var. (cperl-mode): Use it. (cperl-calculate-indent): Remove code whose removal was missed in some earlier merge. (cperl-tags-hier-init): Use display-popup-menus-p.
Diffstat (limited to 'lisp')
-rw-r--r--lisp/progmodes/cperl-mode.el2266
1 files changed, 1127 insertions, 1139 deletions
diff --git a/lisp/progmodes/cperl-mode.el b/lisp/progmodes/cperl-mode.el
index a593d94ab98..4084f824eaa 100644
--- a/lisp/progmodes/cperl-mode.el
+++ b/lisp/progmodes/cperl-mode.el
@@ -1,10 +1,10 @@
1;;; cperl-mode.el --- Perl code editing commands for Emacs 1;;; cperl-mode.el --- Perl code editing commands for Emacs
2 2
3;; Copyright (C) 1985, 86, 87, 91, 92, 93, 94, 95, 96, 1997 3;; Copyright (C) 1985, 86, 87, 91, 92, 93, 94, 95, 96, 97, 98, 99, 2000, 2003
4;; Free Software Foundation, Inc. 4;; Free Software Foundation, Inc.
5 5
6;; Author: Ilya Zakharevich and Bob Olson 6;; Author: Ilya Zakharevich and Bob Olson
7;; Maintainer: Ilya Zakharevich <ilya@math.ohio-state.edu> 7;; Maintainer: Ilya Zakharevich <cperl@ilyaz.org>
8;; Keywords: languages, Perl 8;; Keywords: languages, Perl
9 9
10;; This file is part of GNU Emacs. 10;; This file is part of GNU Emacs.
@@ -24,52 +24,63 @@
24;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, 24;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
25;; Boston, MA 02111-1307, USA. 25;; Boston, MA 02111-1307, USA.
26 26
27;;; Corrections made by Ilya Zakharevich ilya@math.mps.ohio-state.edu 27;;; Corrections made by Ilya Zakharevich cperl@ilyaz.org
28 28
29;;; Commentary: 29;;; Commentary:
30 30
31;;; You can either fine-tune the bells and whistles of this mode or 31;; You can either fine-tune the bells and whistles of this mode or
32;;; bulk enable them by putting 32;; bulk enable them by putting
33 33
34;; (setq cperl-hairy t) 34;; (setq cperl-hairy t)
35 35
36;;; in your .emacs file. (Emacs rulers do not consider it politically 36;; in your .emacs file. (Emacs rulers do not consider it politically
37;;; correct to make whistles enabled by default.) 37;; correct to make whistles enabled by default.)
38 38
39;;; DO NOT FORGET to read micro-docs (available from `Perl' menu) <<<<<< 39;; DO NOT FORGET to read micro-docs (available from `Perl' menu) <<<<<<
40;;; or as help on variables `cperl-tips', `cperl-problems', <<<<<< 40;; or as help on variables `cperl-tips', `cperl-problems', <<<<<<
41;;; `cperl-praise', `cperl-speed'. <<<<<< 41;; `cperl-praise', `cperl-speed'. <<<<<<
42 42
43;;; The mode information (on C-h m) provides some customization help. 43;; The mode information (on C-h m) provides some customization help.
44;;; If you use font-lock feature of this mode, it is advisable to use 44;; If you use font-lock feature of this mode, it is advisable to use
45;;; either lazy-lock-mode or fast-lock-mode. I prefer lazy-lock. 45;; either lazy-lock-mode or fast-lock-mode. I prefer lazy-lock.
46 46
47;;; Faces used now: three faces for first-class and second-class keywords 47;; Faces used now: three faces for first-class and second-class keywords
48;;; and control flow words, one for each: comments, string, labels, 48;; and control flow words, one for each: comments, string, labels,
49;;; functions definitions and packages, arrays, hashes, and variable 49;; functions definitions and packages, arrays, hashes, and variable
50;;; definitions. If you do not see all these faces, your font-lock does 50;; definitions. If you do not see all these faces, your font-lock does
51;;; not define them, so you need to define them manually. 51;; not define them, so you need to define them manually.
52 52
53;;; into your .emacs file. 53;; This mode supports font-lock, imenu and mode-compile. In the
54 54;; hairy version font-lock is on, but you should activate imenu
55;;;; This mode supports font-lock, imenu and mode-compile. In the 55;; yourself (note that mode-compile is not standard yet). Well, you
56;;;; hairy version font-lock is on, but you should activate imenu 56;; can use imenu from keyboard anyway (M-x imenu), but it is better
57;;;; yourself (note that mode-compile is not standard yet). Well, you 57;; to bind it like that:
58;;;; can use imenu from keyboard anyway (M-x imenu), but it is better
59;;;; to bind it like that:
60 58
61;; (define-key global-map [M-S-down-mouse-3] 'imenu) 59;; (define-key global-map [M-S-down-mouse-3] 'imenu)
62 60
61;;; Font lock bugs as of v4.32:
62
63;; The following kinds of Perl code erroneously start strings:
64;; \$` \$' \$"
65;; $opt::s $opt_s $opt{s} (s => ...) /\s+.../
66;; likewise with m, tr, y, q, qX instead of s
67
63;;; Code: 68;;; Code:
64 69
65;; Some macros are needed for `defcustom' 70;; Some macros are needed for `defcustom'
66(eval-when-compile 71(eval-when-compile
67 (require 'font-lock) 72 (defconst cperl-xemacs-p (string-match "XEmacs\\|Lucid" emacs-version))
73 (defvar cperl-can-font-lock
74 (or cperl-xemacs-p
75 (and (boundp 'emacs-major-version)
76 (or window-system
77 (> emacs-major-version 20)))))
78 (if cperl-can-font-lock
79 (require 'font-lock))
68 (defvar msb-menu-cond) 80 (defvar msb-menu-cond)
69 (defvar gud-perldb-history) 81 (defvar gud-perldb-history)
70 (defvar font-lock-background-mode) ; not in Emacs 82 (defvar font-lock-background-mode) ; not in Emacs
71 (defvar font-lock-display-type) ; ditto 83 (defvar font-lock-display-type) ; ditto
72 (defconst cperl-xemacs-p (string-match "XEmacs\\|Lucid" emacs-version))
73 (defmacro cperl-is-face (arg) ; Takes quoted arg 84 (defmacro cperl-is-face (arg) ; Takes quoted arg
74 (cond ((fboundp 'find-face) 85 (cond ((fboundp 'find-face)
75 `(find-face ,arg)) 86 `(find-face ,arg))
@@ -112,6 +123,14 @@
112 `(etags-goto-tag-location ,elt))) 123 `(etags-goto-tag-location ,elt)))
113 (autoload 'tmm-prompt "tmm")) 124 (autoload 'tmm-prompt "tmm"))
114 125
126(defconst cperl-xemacs-p (string-match "XEmacs\\|Lucid" emacs-version))
127
128(defvar cperl-can-font-lock
129 (or cperl-xemacs-p
130 (and (boundp 'emacs-major-version)
131 (or window-system
132 (> emacs-major-version 20)))))
133
115(defun cperl-choose-color (&rest list) 134(defun cperl-choose-color (&rest list)
116 (let (answer) 135 (let (answer)
117 (while list 136 (while list
@@ -170,8 +189,7 @@ and do constructs look like:
170instead of: 189instead of:
171 190
172 if () { 191 if () {
173 } 192 }"
174"
175 :type 'boolean 193 :type 'boolean
176 :group 'cperl-autoinsert-details) 194 :group 'cperl-autoinsert-details)
177 195
@@ -354,12 +372,12 @@ Can be overwritten by `cperl-hairy' to be 5 sec if nil."
354 :group 'cperl-affected-by-hairy) 372 :group 'cperl-affected-by-hairy)
355 373
356(defcustom cperl-pod-face 'font-lock-comment-face 374(defcustom cperl-pod-face 'font-lock-comment-face
357 "*Face for pod highlighting." 375 "*Face for POD highlighting."
358 :type 'face 376 :type 'face
359 :group 'cperl-faces) 377 :group 'cperl-faces)
360 378
361(defcustom cperl-pod-head-face 'font-lock-variable-name-face 379(defcustom cperl-pod-head-face 'font-lock-variable-name-face
362 "*Face for pod highlighting. 380 "*Face for POD highlighting.
363Font for POD headers." 381Font for POD headers."
364 :type 'face 382 :type 'face
365 :group 'cperl-faces) 383 :group 'cperl-faces)
@@ -376,7 +394,7 @@ Font for POD headers."
376 :group 'cperl-faces) 394 :group 'cperl-faces)
377 395
378(defcustom cperl-pod-here-fontify '(featurep 'font-lock) 396(defcustom cperl-pod-here-fontify '(featurep 'font-lock)
379 "*Not-nil after evaluation means to highlight pod and here-docs sections." 397 "*Not-nil after evaluation means to highlight POD and here-docs sections."
380 :type 'boolean 398 :type 'boolean
381 :group 'cperl-faces) 399 :group 'cperl-faces)
382 400
@@ -395,7 +413,7 @@ entered CPerl mode the first time will have no effect."
395 :group 'cperl) 413 :group 'cperl)
396 414
397(defcustom cperl-pod-here-scan t 415(defcustom cperl-pod-here-scan t
398 "*Not-nil means look for pod and here-docs sections during startup. 416 "*Not-nil means look for POD and here-docs sections during startup.
399You can always make lookup from menu or using \\[cperl-find-pods-heres]." 417You can always make lookup from menu or using \\[cperl-find-pods-heres]."
400 :type 'boolean 418 :type 'boolean
401 :group 'cperl-speed) 419 :group 'cperl-speed)
@@ -512,7 +530,7 @@ One should tune up `cperl-close-paren-offset' as well."
512 :group 'cperl-indentation-details) 530 :group 'cperl-indentation-details)
513 531
514(defcustom cperl-syntaxify-by-font-lock 532(defcustom cperl-syntaxify-by-font-lock
515 (and window-system 533 (and cperl-can-font-lock
516 (boundp 'parse-sexp-lookup-properties)) 534 (boundp 'parse-sexp-lookup-properties))
517 "*Non-nil means that CPerl uses `font-lock's routines for syntaxification." 535 "*Non-nil means that CPerl uses `font-lock's routines for syntaxification."
518 :type '(choice (const message) boolean) 536 :type '(choice (const message) boolean)
@@ -593,7 +611,7 @@ when syntaxifying a chunk of buffer."
593;;; Short extra-docs. 611;;; Short extra-docs.
594 612
595(defvar cperl-tips 'please-ignore-this-line 613(defvar cperl-tips 'please-ignore-this-line
596 "Get newest version of this package from 614 "Get maybe newer version of this package from
597 ftp://ftp.math.ohio-state.edu/pub/users/ilya/emacs 615 ftp://ftp.math.ohio-state.edu/pub/users/ilya/emacs
598and/or 616and/or
599 ftp://ftp.math.ohio-state.edu/pub/users/ilya/perl 617 ftp://ftp.math.ohio-state.edu/pub/users/ilya/perl
@@ -602,9 +620,9 @@ patches to related files.
602 620
603For best results apply to an older Emacs the patches from 621For best results apply to an older Emacs the patches from
604 ftp://ftp.math.ohio-state.edu/pub/users/ilya/cperl-mode/patches 622 ftp://ftp.math.ohio-state.edu/pub/users/ilya/cperl-mode/patches
605\(this upgrades syntax-parsing abilities of Emaxen v19.34 and 623\(this upgrades syntax-parsing abilities of Emacsen v19.34 and
606v20.2 up to the level of Emacs v20.3 - a must for a good Perl 624v20.2 up to the level of Emacs v20.3 - a must for a good Perl
607mode.) 625mode.) As of beginning of 2003, XEmacs may provide a similar ability.
608 626
609Get support packages choose-color.el (or font-lock-extra.el before 627Get support packages choose-color.el (or font-lock-extra.el before
61019.30), imenu-go.el from the same place. \(Look for other files there 62819.30), imenu-go.el from the same place. \(Look for other files there
@@ -664,7 +682,8 @@ yet.
664Emacs had a _very_ restricted syntax parsing engine until version 682Emacs had a _very_ restricted syntax parsing engine until version
66520.1. Most problems below are corrected starting from this version of 68320.1. Most problems below are corrected starting from this version of
666Emacs, and all of them should be fixed in version 20.3. (Or apply 684Emacs, and all of them should be fixed in version 20.3. (Or apply
667patches to Emacs 19.33/34 - see tips.) 685patches to Emacs 19.33/34 - see tips.) XEmacs was very backward in
686this respect (until 2003).
668 687
669Note that even with newer Emacsen in some very rare cases the details 688Note that even with newer Emacsen in some very rare cases the details
670of interaction of `font-lock' and syntaxification may be not cleaned 689of interaction of `font-lock' and syntaxification may be not cleaned
@@ -681,7 +700,7 @@ braces.
681 700
682This may be confusing, since the regexp s#//#/#\; may be highlighted 701This may be confusing, since the regexp s#//#/#\; may be highlighted
683as a comment, but it will be recognized as a regexp by the indentation 702as a comment, but it will be recognized as a regexp by the indentation
684code. Or the opposite case, when a pod section is highlighted, but 703code. Or the opposite case, when a POD section is highlighted, but
685may break the indentation of the following code (though indentation 704may break the indentation of the following code (though indentation
686should work if the balance of delimiters is not broken by POD). 705should work if the balance of delimiters is not broken by POD).
687 706
@@ -699,7 +718,7 @@ and on CPAN.
699 718
700If these bugs cannot be fixed on your machine (say, you have an inferior 719If these bugs cannot be fixed on your machine (say, you have an inferior
701environment and cannot recompile), you may still disable all the fancy stuff 720environment and cannot recompile), you may still disable all the fancy stuff
702via `cperl-use-syntax-table-text-property'." ) 721via `cperl-use-syntax-table-text-property'.")
703 722
704(defvar cperl-praise 'please-ignore-this-line 723(defvar cperl-praise 'please-ignore-this-line
705 "Advantages of CPerl mode. 724 "Advantages of CPerl mode.
@@ -783,8 +802,7 @@ the settings present before the switch.
783line-breaks/spacing between elements of the construct. 802line-breaks/spacing between elements of the construct.
784 803
78510) Uses a linear-time algorith for indentation of regions (on Emaxen with 80410) Uses a linear-time algorith for indentation of regions (on Emaxen with
786capable syntax engines). 805capable syntax engines).")
787")
788 806
789(defvar cperl-speed 'please-ignore-this-line 807(defvar cperl-speed 'please-ignore-this-line
790 "This is an incomplete compendium of what is available in other parts 808 "This is an incomplete compendium of what is available in other parts
@@ -828,8 +846,7 @@ B) Speed of editing operations.
828 wrongly matched parentheses, wrong indentation, etc. 846 wrongly matched parentheses, wrong indentation, etc.
829 847
830 One can unset `cperl-syntaxify-unwind'. This might speed up editing 848 One can unset `cperl-syntaxify-unwind'. This might speed up editing
831 of, say, long POD sections. 849 of, say, long POD sections.")
832")
833 850
834(defvar cperl-tips-faces 'please-ignore-this-line 851(defvar cperl-tips-faces 'please-ignore-this-line
835 "CPerl mode uses following faces for highlighting: 852 "CPerl mode uses following faces for highlighting:
@@ -870,8 +887,6 @@ the faces: please specify bold, italic, underline, shadow and box.)
870 887
871;;; Portability stuff: 888;;; Portability stuff:
872 889
873(defconst cperl-xemacs-p (string-match "XEmacs\\|Lucid" emacs-version))
874
875(defmacro cperl-define-key (emacs-key definition &optional xemacs-key) 890(defmacro cperl-define-key (emacs-key definition &optional xemacs-key)
876 `(define-key cperl-mode-map 891 `(define-key cperl-mode-map
877 ,(if xemacs-key 892 ,(if xemacs-key
@@ -899,9 +914,9 @@ the faces: please specify bold, italic, underline, shadow and box.)
899 (defun cperl-mark-active () mark-active)) 914 (defun cperl-mark-active () mark-active))
900 915
901(defsubst cperl-enable-font-lock () 916(defsubst cperl-enable-font-lock ()
902 (or cperl-xemacs-p window-system)) 917 cperl-can-font-lock)
903 918
904(defun cperl-putback-char (c) ; Emacs 19 919(defun cperl-putback-char (c) ; Emacs 19
905 (set 'unread-command-events (list c))) ; Avoid undefined warning 920 (set 'unread-command-events (list c))) ; Avoid undefined warning
906 921
907(if (boundp 'unread-command-events) 922(if (boundp 'unread-command-events)
@@ -955,24 +970,11 @@ the faces: please specify bold, italic, underline, shadow and box.)
955;;; (setq interpreter-mode-alist (append interpreter-mode-alist 970;;; (setq interpreter-mode-alist (append interpreter-mode-alist
956;;; '(("miniperl" . perl-mode)))))) 971;;; '(("miniperl" . perl-mode))))))
957(eval-when-compile 972(eval-when-compile
958 (condition-case nil 973 (mapcar (lambda (p)
959 (require 'imenu) 974 (condition-case nil
960 (error nil)) 975 (require p)
961 (condition-case nil 976 (error nil)))
962 (require 'easymenu) 977 '(imenu easymenu etags timer man info))
963 (error nil))
964 (condition-case nil
965 (require 'etags)
966 (error nil))
967 (condition-case nil
968 (require 'timer)
969 (error nil))
970 (condition-case nil
971 (require 'man)
972 (error nil))
973 (condition-case nil
974 (require 'info)
975 (error nil))
976 (if (fboundp 'ps-extend-face-list) 978 (if (fboundp 'ps-extend-face-list)
977 (defmacro cperl-ps-extend-face-list (arg) 979 (defmacro cperl-ps-extend-face-list (arg)
978 `(ps-extend-face-list ,arg)) 980 `(ps-extend-face-list ,arg))
@@ -1070,52 +1072,53 @@ the faces: please specify bold, italic, underline, shadow and box.)
1070(condition-case nil 1072(condition-case nil
1071 (progn 1073 (progn
1072 (require 'easymenu) 1074 (require 'easymenu)
1073 (easy-menu-define cperl-menu cperl-mode-map "Menu for CPerl mode" 1075 (easy-menu-define
1074 '("Perl" 1076 cperl-menu cperl-mode-map "Menu for CPerl mode"
1075 ["Beginning of function" beginning-of-defun t] 1077 '("Perl"
1076 ["End of function" end-of-defun t] 1078 ["Beginning of function" beginning-of-defun t]
1077 ["Mark function" mark-defun t] 1079 ["End of function" end-of-defun t]
1078 ["Indent expression" cperl-indent-exp t] 1080 ["Mark function" mark-defun t]
1079 ["Fill paragraph/comment" cperl-fill-paragraph t] 1081 ["Indent expression" cperl-indent-exp t]
1080 "----" 1082 ["Fill paragraph/comment" cperl-fill-paragraph t]
1081 ["Line up a construction" cperl-lineup (cperl-use-region-p)] 1083 "----"
1082 ["Invert if/unless/while etc" cperl-invert-if-unless t] 1084 ["Line up a construction" cperl-lineup (cperl-use-region-p)]
1083 ("Regexp" 1085 ["Invert if/unless/while etc" cperl-invert-if-unless t]
1084 ["Beautify" cperl-beautify-regexp 1086 ("Regexp"
1085 cperl-use-syntax-table-text-property] 1087 ["Beautify" cperl-beautify-regexp
1086 ["Beautify one level deep" (cperl-beautify-regexp 1) 1088 cperl-use-syntax-table-text-property]
1087 cperl-use-syntax-table-text-property] 1089 ["Beautify one level deep" (cperl-beautify-regexp 1)
1088 ["Beautify a group" cperl-beautify-level 1090 cperl-use-syntax-table-text-property]
1089 cperl-use-syntax-table-text-property] 1091 ["Beautify a group" cperl-beautify-level
1090 ["Beautify a group one level deep" (cperl-beautify-level 1) 1092 cperl-use-syntax-table-text-property]
1091 cperl-use-syntax-table-text-property] 1093 ["Beautify a group one level deep" (cperl-beautify-level 1)
1092 ["Contract a group" cperl-contract-level 1094 cperl-use-syntax-table-text-property]
1093 cperl-use-syntax-table-text-property] 1095 ["Contract a group" cperl-contract-level
1094 ["Contract groups" cperl-contract-levels 1096 cperl-use-syntax-table-text-property]
1095 cperl-use-syntax-table-text-property]) 1097 ["Contract groups" cperl-contract-levels
1096 ["Refresh \"hard\" constructions" cperl-find-pods-heres t] 1098 cperl-use-syntax-table-text-property])
1097 "----" 1099 ["Refresh \"hard\" constructions" cperl-find-pods-heres t]
1098 ["Indent region" cperl-indent-region (cperl-use-region-p)] 1100 "----"
1099 ["Comment region" cperl-comment-region (cperl-use-region-p)] 1101 ["Indent region" cperl-indent-region (cperl-use-region-p)]
1100 ["Uncomment region" cperl-uncomment-region (cperl-use-region-p)] 1102 ["Comment region" cperl-comment-region (cperl-use-region-p)]
1101 "----" 1103 ["Uncomment region" cperl-uncomment-region (cperl-use-region-p)]
1102 ["Run" mode-compile (fboundp 'mode-compile)] 1104 "----"
1103 ["Kill" mode-compile-kill (and (fboundp 'mode-compile-kill) 1105 ["Run" mode-compile (fboundp 'mode-compile)]
1104 (get-buffer "*compilation*"))] 1106 ["Kill" mode-compile-kill (and (fboundp 'mode-compile-kill)
1105 ["Next error" next-error (get-buffer "*compilation*")] 1107 (get-buffer "*compilation*"))]
1106 ["Check syntax" cperl-check-syntax (fboundp 'mode-compile)] 1108 ["Next error" next-error (get-buffer "*compilation*")]
1107 "----" 1109 ["Check syntax" cperl-check-syntax (fboundp 'mode-compile)]
1108 ["Debugger" cperl-db t] 1110 "----"
1109 "----" 1111 ["Debugger" cperl-db t]
1110 ("Tools" 1112 "----"
1111 ["Imenu" imenu (fboundp 'imenu)] 1113 ("Tools"
1112 ["Insert spaces if needed" cperl-find-bad-style t] 1114 ["Imenu" imenu (fboundp 'imenu)]
1113 ["Class Hierarchy from TAGS" cperl-tags-hier-init t] 1115 ["Insert spaces if needed" cperl-find-bad-style t]
1114 ;;["Update classes" (cperl-tags-hier-init t) tags-table-list] 1116 ["Class Hierarchy from TAGS" cperl-tags-hier-init t]
1115 ["CPerl pretty print (exprmntl)" cperl-ps-print 1117 ;;["Update classes" (cperl-tags-hier-init t) tags-table-list]
1116 (fboundp 'ps-extend-face-list)] 1118 ["CPerl pretty print (exprmntl)" cperl-ps-print
1117 ["Imenu on info" cperl-imenu-on-info (featurep 'imenu)] 1119 (fboundp 'ps-extend-face-list)]
1118 ("Tags" 1120 ["Imenu on info" cperl-imenu-on-info (featurep 'imenu)]
1121 ("Tags"
1119;;; ["Create tags for current file" cperl-etags t] 1122;;; ["Create tags for current file" cperl-etags t]
1120;;; ["Add tags for current file" (cperl-etags t) t] 1123;;; ["Add tags for current file" (cperl-etags t) t]
1121;;; ["Create tags for Perl files in directory" (cperl-etags nil t) t] 1124;;; ["Create tags for Perl files in directory" (cperl-etags nil t) t]
@@ -1125,57 +1128,57 @@ the faces: please specify bold, italic, underline, shadow and box.)
1125;;; ["Add tags for Perl files in (sub)directories" 1128;;; ["Add tags for Perl files in (sub)directories"
1126;;; (cperl-etags t 'recursive) t]) 1129;;; (cperl-etags t 'recursive) t])
1127;;;; cperl-write-tags (&optional file erase recurse dir inbuffer) 1130;;;; cperl-write-tags (&optional file erase recurse dir inbuffer)
1128 ["Create tags for current file" (cperl-write-tags nil t) t] 1131 ["Create tags for current file" (cperl-write-tags nil t) t]
1129 ["Add tags for current file" (cperl-write-tags) t] 1132 ["Add tags for current file" (cperl-write-tags) t]
1130 ["Create tags for Perl files in directory" 1133 ["Create tags for Perl files in directory"
1131 (cperl-write-tags nil t nil t) t] 1134 (cperl-write-tags nil t nil t) t]
1132 ["Add tags for Perl files in directory" 1135 ["Add tags for Perl files in directory"
1133 (cperl-write-tags nil nil nil t) t] 1136 (cperl-write-tags nil nil nil t) t]
1134 ["Create tags for Perl files in (sub)directories" 1137 ["Create tags for Perl files in (sub)directories"
1135 (cperl-write-tags nil t t t) t] 1138 (cperl-write-tags nil t t t) t]
1136 ["Add tags for Perl files in (sub)directories" 1139 ["Add tags for Perl files in (sub)directories"
1137 (cperl-write-tags nil nil t t) t])) 1140 (cperl-write-tags nil nil t t) t]))
1138 ("Perl docs" 1141 ("Perl docs"
1139 ["Define word at point" imenu-go-find-at-position 1142 ["Define word at point" imenu-go-find-at-position
1140 (fboundp 'imenu-go-find-at-position)] 1143 (fboundp 'imenu-go-find-at-position)]
1141 ["Help on function" cperl-info-on-command t] 1144 ["Help on function" cperl-info-on-command t]
1142 ["Help on function at point" cperl-info-on-current-command t] 1145 ["Help on function at point" cperl-info-on-current-command t]
1143 ["Help on symbol at point" cperl-get-help t] 1146 ["Help on symbol at point" cperl-get-help t]
1144 ["Perldoc" cperl-perldoc t] 1147 ["Perldoc" cperl-perldoc t]
1145 ["Perldoc on word at point" cperl-perldoc-at-point t] 1148 ["Perldoc on word at point" cperl-perldoc-at-point t]
1146 ["View manpage of POD in this file" cperl-pod-to-manpage t] 1149 ["View manpage of POD in this file" cperl-pod-to-manpage t]
1147 ["Auto-help on" cperl-lazy-install 1150 ["Auto-help on" cperl-lazy-install
1148 (and (fboundp 'run-with-idle-timer) 1151 (and (fboundp 'run-with-idle-timer)
1149 (not cperl-lazy-installed))] 1152 (not cperl-lazy-installed))]
1150 ["Auto-help off" (eval '(cperl-lazy-unstall)) 1153 ["Auto-help off" (eval '(cperl-lazy-unstall))
1151 (and (fboundp 'run-with-idle-timer) 1154 (and (fboundp 'run-with-idle-timer)
1152 cperl-lazy-installed)]) 1155 cperl-lazy-installed)])
1153 ("Toggle..." 1156 ("Toggle..."
1154 ["Auto newline" cperl-toggle-auto-newline t] 1157 ["Auto newline" cperl-toggle-auto-newline t]
1155 ["Electric parens" cperl-toggle-electric t] 1158 ["Electric parens" cperl-toggle-electric t]
1156 ["Electric keywords" cperl-toggle-abbrev t] 1159 ["Electric keywords" cperl-toggle-abbrev t]
1157 ["Fix whitespace on indent" cperl-toggle-construct-fix t] 1160 ["Fix whitespace on indent" cperl-toggle-construct-fix t]
1158 ["Auto fill" auto-fill-mode t]) 1161 ["Auto fill" auto-fill-mode t])
1159 ("Indent styles..." 1162 ("Indent styles..."
1160 ["CPerl" (cperl-set-style "CPerl") t] 1163 ["CPerl" (cperl-set-style "CPerl") t]
1161 ["PerlStyle" (cperl-set-style "PerlStyle") t] 1164 ["PerlStyle" (cperl-set-style "PerlStyle") t]
1162 ["GNU" (cperl-set-style "GNU") t] 1165 ["GNU" (cperl-set-style "GNU") t]
1163 ["C++" (cperl-set-style "C++") t] 1166 ["C++" (cperl-set-style "C++") t]
1164 ["FSF" (cperl-set-style "FSF") t] 1167 ["FSF" (cperl-set-style "FSF") t]
1165 ["BSD" (cperl-set-style "BSD") t] 1168 ["BSD" (cperl-set-style "BSD") t]
1166 ["Whitesmith" (cperl-set-style "Whitesmith") t] 1169 ["Whitesmith" (cperl-set-style "Whitesmith") t]
1167 ["Current" (cperl-set-style "Current") t] 1170 ["Current" (cperl-set-style "Current") t]
1168 ["Memorized" (cperl-set-style-back) cperl-old-style]) 1171 ["Memorized" (cperl-set-style-back) cperl-old-style])
1169 ("Micro-docs" 1172 ("Micro-docs"
1170 ["Tips" (describe-variable 'cperl-tips) t] 1173 ["Tips" (describe-variable 'cperl-tips) t]
1171 ["Problems" (describe-variable 'cperl-problems) t] 1174 ["Problems" (describe-variable 'cperl-problems) t]
1172 ["Speed" (describe-variable 'cperl-speed) t] 1175 ["Speed" (describe-variable 'cperl-speed) t]
1173 ["Praise" (describe-variable 'cperl-praise) t] 1176 ["Praise" (describe-variable 'cperl-praise) t]
1174 ["Faces" (describe-variable 'cperl-tips-faces) t] 1177 ["Faces" (describe-variable 'cperl-tips-faces) t]
1175 ["CPerl mode" (describe-function 'cperl-mode) t] 1178 ["CPerl mode" (describe-function 'cperl-mode) t]
1176 ["CPerl version" 1179 ["CPerl version"
1177 (message "The version of master-file for this CPerl is %s-emacs" 1180 (message "The version of master-file for this CPerl is %s-emacs"
1178 cperl-version) t])))) 1181 cperl-version) t]))))
1179 (error nil)) 1182 (error nil))
1180 1183
1181(autoload 'c-macro-expand "cmacexp" 1184(autoload 'c-macro-expand "cmacexp"
@@ -1224,14 +1227,15 @@ The expansion is entirely correct because it uses the C preprocessor."
1224 (modify-syntax-entry ?| "." cperl-mode-syntax-table) 1227 (modify-syntax-entry ?| "." cperl-mode-syntax-table)
1225 (setq cperl-string-syntax-table (copy-syntax-table cperl-mode-syntax-table)) 1228 (setq cperl-string-syntax-table (copy-syntax-table cperl-mode-syntax-table))
1226 (modify-syntax-entry ?$ "." cperl-string-syntax-table) 1229 (modify-syntax-entry ?$ "." cperl-string-syntax-table)
1227 (modify-syntax-entry ?# "." cperl-string-syntax-table) ; (?# comment ) 1230 (modify-syntax-entry ?# "." cperl-string-syntax-table)) ; (?# comment )
1228)
1229 1231
1230 1232
1231 1233
1232(defvar cperl-faces-init nil) 1234(defvar cperl-faces-init nil)
1233;; Fix for msb.el 1235;; Fix for msb.el
1234(defvar cperl-msb-fixed nil) 1236(defvar cperl-msb-fixed nil)
1237(defvar cperl-use-major-mode 'cperl-mode)
1238
1235;;;###autoload 1239;;;###autoload
1236(defun cperl-mode () 1240(defun cperl-mode ()
1237 "Major mode for editing Perl code. 1241 "Major mode for editing Perl code.
@@ -1337,7 +1341,7 @@ beginning of the region at the start of construction, and make region
1337span the needed amount of lines. 1341span the needed amount of lines.
1338 1342
1339Variables `cperl-pod-here-scan', `cperl-pod-here-fontify', 1343Variables `cperl-pod-here-scan', `cperl-pod-here-fontify',
1340`cperl-pod-face', `cperl-pod-head-face' control processing of pod and 1344`cperl-pod-face', `cperl-pod-head-face' control processing of POD and
1341here-docs sections. With capable Emaxen results of scan are used 1345here-docs sections. With capable Emaxen results of scan are used
1342for indentation too, otherwise they are used for highlighting only. 1346for indentation too, otherwise they are used for highlighting only.
1343 1347
@@ -1412,7 +1416,7 @@ or as help on variables `cperl-tips', `cperl-problems',
1412 (cperl-define-key "\C-hf" 'cperl-info-on-current-command [(control h) f]) 1416 (cperl-define-key "\C-hf" 'cperl-info-on-current-command [(control h) f])
1413 (cperl-define-key "\C-c\C-hf" 'cperl-info-on-command 1417 (cperl-define-key "\C-c\C-hf" 'cperl-info-on-command
1414 [(control c) (control h) f]))) 1418 [(control c) (control h) f])))
1415 (setq major-mode 'cperl-mode) 1419 (setq major-mode cperl-use-major-mode)
1416 (setq mode-name "CPerl") 1420 (setq mode-name "CPerl")
1417 (if (not cperl-mode-abbrev-table) 1421 (if (not cperl-mode-abbrev-table)
1418 (let ((prev-a-c abbrevs-changed)) 1422 (let ((prev-a-c abbrevs-changed))
@@ -1502,9 +1506,9 @@ or as help on variables `cperl-tips', `cperl-problems',
1502 ;; Fix broken font-lock: 1506 ;; Fix broken font-lock:
1503 (or (boundp 'font-lock-unfontify-region-function) 1507 (or (boundp 'font-lock-unfontify-region-function)
1504 (set 'font-lock-unfontify-region-function 1508 (set 'font-lock-unfontify-region-function
1505 'font-lock-default-unfontify-region)) 1509 'font-lock-default-unfontify-region))
1506 (make-local-variable 'font-lock-unfontify-region-function) 1510 (make-local-variable 'font-lock-unfontify-region-function)
1507 (set 'font-lock-unfontify-region-function 1511 (set 'font-lock-unfontify-region-function ; not present with old Emacs
1508 'cperl-font-lock-unfontify-region-function) 1512 'cperl-font-lock-unfontify-region-function)
1509 (make-local-variable 'cperl-syntax-done-to) 1513 (make-local-variable 'cperl-syntax-done-to)
1510 ;; Another bug: unless font-lock-syntactic-keywords, font-lock 1514 ;; Another bug: unless font-lock-syntactic-keywords, font-lock
@@ -1517,8 +1521,17 @@ or as help on variables `cperl-tips', `cperl-problems',
1517 '(t (cperl-fontify-syntaxically)) 1521 '(t (cperl-fontify-syntaxically))
1518 '(t))))) 1522 '(t)))))
1519 (make-local-variable 'cperl-old-style) 1523 (make-local-variable 'cperl-old-style)
1520 (set (make-local-variable 'normal-auto-fill-function) 1524 (if (boundp 'normal-auto-fill-function) ; 19.33 and later
1521 #'cperl-do-auto-fill) 1525 (set (make-local-variable 'normal-auto-fill-function)
1526 'cperl-do-auto-fill) ; RMS has it as #'cperl-do-auto-fill ???
1527 (or (fboundp 'cperl-old-auto-fill-mode)
1528 (progn
1529 (fset 'cperl-old-auto-fill-mode (symbol-function 'auto-fill-mode))
1530 (defun auto-fill-mode (&optional arg)
1531 (interactive "P")
1532 (eval '(cperl-old-auto-fill-mode arg)) ; Avoid a warning
1533 (and auto-fill-function (memq major-mode '(perl-mode cperl-mode))
1534 (setq auto-fill-function 'cperl-do-auto-fill))))))
1522 (if (cperl-enable-font-lock) 1535 (if (cperl-enable-font-lock)
1523 (if (cperl-val 'cperl-font-lock) 1536 (if (cperl-val 'cperl-font-lock)
1524 (progn (or cperl-faces-init (cperl-init-faces)) 1537 (progn (or cperl-faces-init (cperl-init-faces))
@@ -1531,10 +1544,7 @@ or as help on variables `cperl-tips', `cperl-problems',
1531 (run-hooks 'cperl-mode-hook) 1544 (run-hooks 'cperl-mode-hook)
1532 ;; After hooks since fontification will break this 1545 ;; After hooks since fontification will break this
1533 (if cperl-pod-here-scan 1546 (if cperl-pod-here-scan
1534 (or ;;(and (boundp 'font-lock-mode) 1547 (or cperl-syntaxify-by-font-lock
1535 ;; (eval 'font-lock-mode) ; Avoid warning
1536 ;; (boundp 'font-lock-hot-pass) ; Newer font-lock
1537 cperl-syntaxify-by-font-lock ;;)
1538 (progn (or cperl-faces-init (cperl-init-faces-weak)) 1548 (progn (or cperl-faces-init (cperl-init-faces-weak))
1539 (cperl-find-pods-heres))))) 1549 (cperl-find-pods-heres)))))
1540 1550
@@ -1546,10 +1556,10 @@ or as help on variables `cperl-tips', `cperl-problems',
1546 (if (consp gud-perldb-history) 1556 (if (consp gud-perldb-history)
1547 (car gud-perldb-history) 1557 (car gud-perldb-history)
1548 (concat "perl " ;;(file-name-nondirectory 1558 (concat "perl " ;;(file-name-nondirectory
1549 ;; I have problems 1559 ;; I have problems
1550 ;; in OS/2 1560 ;; in OS/2
1551 ;; otherwise 1561 ;; otherwise
1552 (buffer-file-name))) 1562 (buffer-file-name)))
1553 nil nil 1563 nil nil
1554 '(gud-perldb-history . 1)))) 1564 '(gud-perldb-history . 1))))
1555 1565
@@ -1675,7 +1685,7 @@ char is \"{\", insert extra newline before only if
1675 (setq last-command-char ?\{) 1685 (setq last-command-char ?\{)
1676 (cperl-electric-lbrace arg insertpos)) 1686 (cperl-electric-lbrace arg insertpos))
1677 (forward-char 1)) 1687 (forward-char 1))
1678 ;: Check whether we close something "usual" with `}' 1688 ;; Check whether we close something "usual" with `}'
1679 (if (and (eq last-command-char ?\}) 1689 (if (and (eq last-command-char ?\})
1680 (not 1690 (not
1681 (condition-case nil 1691 (condition-case nil
@@ -1725,17 +1735,17 @@ char is \"{\", insert extra newline before only if
1725(defun cperl-electric-lbrace (arg &optional end) 1735(defun cperl-electric-lbrace (arg &optional end)
1726 "Insert character, correct line's indentation, correct quoting by space." 1736 "Insert character, correct line's indentation, correct quoting by space."
1727 (interactive "P") 1737 (interactive "P")
1728 (let (pos after 1738 (let ((cperl-brace-recursing t)
1729 (cperl-brace-recursing t) 1739 (cperl-auto-newline cperl-auto-newline)
1730 (cperl-auto-newline cperl-auto-newline) 1740 (other-end (or end
1731 (other-end (or end 1741 (if (and cperl-electric-parens-mark
1732 (if (and cperl-electric-parens-mark 1742 (cperl-mark-active)
1733 (cperl-mark-active) 1743 (> (mark) (point)))
1734 (> (mark) (point))) 1744 (save-excursion
1735 (save-excursion 1745 (goto-char (mark))
1736 (goto-char (mark)) 1746 (point-marker))
1737 (point-marker)) 1747 nil)))
1738 nil)))) 1748 pos after)
1739 (and (cperl-val 'cperl-electric-lbrace-space) 1749 (and (cperl-val 'cperl-electric-lbrace-space)
1740 (eq (preceding-char) ?$) 1750 (eq (preceding-char) ?$)
1741 (save-excursion 1751 (save-excursion
@@ -1768,9 +1778,9 @@ char is \"{\", insert extra newline before only if
1768 (other-end (if (and cperl-electric-parens-mark 1778 (other-end (if (and cperl-electric-parens-mark
1769 (cperl-mark-active) 1779 (cperl-mark-active)
1770 (> (mark) (point))) 1780 (> (mark) (point)))
1771 (save-excursion 1781 (save-excursion
1772 (goto-char (mark)) 1782 (goto-char (mark))
1773 (point-marker)) 1783 (point-marker))
1774 nil))) 1784 nil)))
1775 (if (and (cperl-val 'cperl-electric-parens) 1785 (if (and (cperl-val 'cperl-electric-parens)
1776 (memq last-command-char 1786 (memq last-command-char
@@ -1822,9 +1832,9 @@ If not, or if we are not at the end of marking range, would self-insert."
1822 (insert (make-string 1832 (insert (make-string
1823 (prefix-numeric-value arg) 1833 (prefix-numeric-value arg)
1824 (cdr (assoc last-command-char '((?\} . ?\{) 1834 (cdr (assoc last-command-char '((?\} . ?\{)
1825 (?\] . ?\[) 1835 (?\] . ?\[)
1826 (?\) . ?\() 1836 (?\) . ?\()
1827 (?\> . ?\<)))))) 1837 (?\> . ?\<))))))
1828 (goto-char (1+ p))) 1838 (goto-char (1+ p)))
1829 (self-insert-command (prefix-numeric-value arg))))) 1839 (self-insert-command (prefix-numeric-value arg)))))
1830 1840
@@ -1879,8 +1889,7 @@ to nil."
1879 (insert "\n}") 1889 (insert "\n}")
1880 (and do (insert " while ();"))) 1890 (and do (insert " while ();")))
1881 (t 1891 (t
1882 (insert (if do " {\n} while ();" " () {\n}"))) 1892 (insert (if do " {\n} while ();" " () {\n}"))))
1883 )
1884 (or (looking-at "[ \t]\\|$") (insert " ")) 1893 (or (looking-at "[ \t]\\|$") (insert " "))
1885 (cperl-indent-line) 1894 (cperl-indent-line)
1886 (if dollar (progn (search-backward "$") 1895 (if dollar (progn (search-backward "$")
@@ -1943,7 +1952,7 @@ to nil."
1943 (save-excursion 1952 (save-excursion
1944 (forward-char -1) 1953 (forward-char -1)
1945 (re-search-backward "\\(\\`\n?\\|\n\n\\)=head1\\>" 1954 (re-search-backward "\\(\\`\n?\\|\n\n\\)=head1\\>"
1946 nil t)))) ; Only one 1955 nil t)))) ; Only one
1947 (progn 1956 (progn
1948 (forward-word 1) 1957 (forward-word 1)
1949 (setq name (file-name-sans-extension 1958 (setq name (file-name-sans-extension
@@ -2000,8 +2009,7 @@ to nil."
2000 (cperl-indent-line) 2009 (cperl-indent-line)
2001 (insert "\n\n}")) 2010 (insert "\n\n}"))
2002 (t 2011 (t
2003 (insert " {\n\n}")) 2012 (insert " {\n\n}")))
2004 )
2005 (or (looking-at "[ \t]\\|$") (insert " ")) 2013 (or (looking-at "[ \t]\\|$") (insert " "))
2006 (cperl-indent-line) 2014 (cperl-indent-line)
2007 (forward-line -1) 2015 (forward-line -1)
@@ -2021,7 +2029,7 @@ If in POD, insert appropriate lines."
2021 (if (and ; Check if we need to split: 2029 (if (and ; Check if we need to split:
2022 ; i.e., on a boundary and inside "{...}" 2030 ; i.e., on a boundary and inside "{...}"
2023 (save-excursion (cperl-to-comment-or-eol) 2031 (save-excursion (cperl-to-comment-or-eol)
2024 (>= (point) pos)) ; Not in a comment 2032 (>= (point) pos)) ; Not in a comment
2025 (or (save-excursion 2033 (or (save-excursion
2026 (skip-chars-backward " \t" beg) 2034 (skip-chars-backward " \t" beg)
2027 (forward-char -1) 2035 (forward-char -1)
@@ -2058,7 +2066,7 @@ If in POD, insert appropriate lines."
2058 (cperl-indent-line) 2066 (cperl-indent-line)
2059 (beginning-of-line) 2067 (beginning-of-line)
2060 (or (looking-at "[ \t]*}[,; \t]*$") ; If there is a statement 2068 (or (looking-at "[ \t]*}[,; \t]*$") ; If there is a statement
2061 ; after, move it to separate line 2069 ; after, move it to separate line
2062 (progn 2070 (progn
2063 (end-of-line) 2071 (end-of-line)
2064 (search-backward "}" beg) 2072 (search-backward "}" beg)
@@ -2077,7 +2085,7 @@ If in POD, insert appropriate lines."
2077 (save-excursion 2085 (save-excursion
2078 (skip-chars-backward " \t") 2086 (skip-chars-backward " \t")
2079 (eq (preceding-char) ?\)))) ; Probably if () {} group 2087 (eq (preceding-char) ?\)))) ; Probably if () {} group
2080 ; with an extra newline. 2088 ; with an extra newline.
2081 (forward-line 2) 2089 (forward-line 2)
2082 (cperl-indent-line)) 2090 (cperl-indent-line))
2083 ((save-excursion ; In POD header 2091 ((save-excursion ; In POD header
@@ -2129,10 +2137,11 @@ If in POD, insert appropriate lines."
2129(defun cperl-electric-terminator (arg) 2137(defun cperl-electric-terminator (arg)
2130 "Insert character and correct line's indentation." 2138 "Insert character and correct line's indentation."
2131 (interactive "P") 2139 (interactive "P")
2132 (let (insertpos (end (point)) 2140 (let ((end (point))
2133 (auto (and cperl-auto-newline 2141 (auto (and cperl-auto-newline
2134 (or (not (eq last-command-char ?:)) 2142 (or (not (eq last-command-char ?:))
2135 cperl-auto-newline-after-colon)))) 2143 cperl-auto-newline-after-colon)))
2144 insertpos)
2136 (if (and ;;(not arg) 2145 (if (and ;;(not arg)
2137 (eolp) 2146 (eolp)
2138 (not (save-excursion 2147 (not (save-excursion
@@ -2251,9 +2260,9 @@ The relative indentation among the lines of the expression are preserved."
2251(defun cperl-indent-line (&optional parse-data) 2260(defun cperl-indent-line (&optional parse-data)
2252 "Indent current line as Perl code. 2261 "Indent current line as Perl code.
2253Return the amount the indentation changed by." 2262Return the amount the indentation changed by."
2254 (let (indent i beg shift-amt 2263 (let ((case-fold-search nil)
2255 (case-fold-search nil) 2264 (pos (- (point-max) (point)))
2256 (pos (- (point-max) (point)))) 2265 indent i beg shift-amt)
2257 (setq indent (cperl-calculate-indent parse-data) 2266 (setq indent (cperl-calculate-indent parse-data)
2258 i indent) 2267 i indent)
2259 (beginning-of-line) 2268 (beginning-of-line)
@@ -2331,7 +2340,7 @@ Return the amount the indentation changed by."
2331 (or state (setq state (parse-partial-sexp start start-point -1 nil start-state))) 2340 (or state (setq state (parse-partial-sexp start start-point -1 nil start-state)))
2332 (list start state depth prestart)))) 2341 (list start state depth prestart))))
2333 2342
2334(defun cperl-block-p () ; Do not C-M-q ! One string contains ";" ! 2343(defun cperl-block-p () ; Do not C-M-q ! One string contains ";" !
2335 ;; Positions is before ?\{. Checks whether it starts a block. 2344 ;; Positions is before ?\{. Checks whether it starts a block.
2336 ;; No save-excursion! 2345 ;; No save-excursion!
2337 (cperl-backward-to-noncomment (point-min)) 2346 (cperl-backward-to-noncomment (point-min))
@@ -2368,134 +2377,125 @@ and closing parentheses and brackets."
2368 (not (get-text-property (point) 'indentable))) 2377 (not (get-text-property (point) 'indentable)))
2369 ;; before start of POD - whitespace found since do not have 'pod! 2378 ;; before start of POD - whitespace found since do not have 'pod!
2370 (and (looking-at "[ \t]*\n=") 2379 (and (looking-at "[ \t]*\n=")
2371 (error "Spaces before pod section!")) 2380 (error "Spaces before POD section!"))
2372 (and (not cperl-indent-left-aligned-comments) 2381 (and (not cperl-indent-left-aligned-comments)
2373 (looking-at "^#"))) 2382 (looking-at "^#")))
2374 nil 2383 nil
2375 (beginning-of-line) 2384 (beginning-of-line)
2376 (let ((indent-point (point)) 2385 (let ((indent-point (point))
2377 (char-after (save-excursion 2386 (char-after (save-excursion
2378 (skip-chars-forward " \t") 2387 (skip-chars-forward " \t")
2379 (following-char))) 2388 (following-char)))
2380 (in-pod (get-text-property (point) 'in-pod)) 2389 (in-pod (get-text-property (point) 'in-pod))
2381 (pre-indent-point (point)) 2390 (pre-indent-point (point))
2382 p prop look-prop is-block delim) 2391 p prop look-prop is-block delim)
2383 (cond 2392 (cond
2384 (in-pod 2393 (in-pod
2385 ;; In the verbatim part, probably code example. What to do??? 2394 ;; In the verbatim part, probably code example. What to do???
2386 ) 2395 )
2387 (t 2396 (t
2388 (save-excursion 2397 (save-excursion
2389 ;; Not in pod 2398 ;; Not in POD
2390 (cperl-backward-to-noncomment nil) 2399 (cperl-backward-to-noncomment nil)
2391 (setq p (max (point-min) (1- (point))) 2400 (setq p (max (point-min) (1- (point)))
2392 prop (get-text-property p 'syntax-type) 2401 prop (get-text-property p 'syntax-type)
2393 look-prop (or (nth 1 (assoc prop cperl-look-for-prop)) 2402 look-prop (or (nth 1 (assoc prop cperl-look-for-prop))
2394 'syntax-type)) 2403 'syntax-type))
2395 (if (memq prop '(pod here-doc format here-doc-delim)) 2404 (if (memq prop '(pod here-doc format here-doc-delim))
2405 (progn
2406 (goto-char (or (previous-single-property-change p look-prop)
2407 (point-min)))
2408 (beginning-of-line)
2409 (setq pre-indent-point (point)))))))
2410 (goto-char pre-indent-point)
2411 (let* ((case-fold-search nil)
2412 (s-s (cperl-get-state (car parse-data) (nth 1 parse-data)))
2413 (start (or (nth 2 parse-data)
2414 (nth 0 s-s)))
2415 (state (nth 1 s-s))
2416 (containing-sexp (car (cdr state)))
2417 old-indent)
2418 (if (and
2419 ;;containing-sexp ;; We are buggy at toplevel :-(
2420 parse-data)
2396 (progn 2421 (progn
2397 (goto-char (or (previous-single-property-change p look-prop) 2422 (setcar parse-data pre-indent-point)
2398 (point-min))) 2423 (setcar (cdr parse-data) state)
2399 (beginning-of-line) 2424 (or (nth 2 parse-data)
2400 (setq pre-indent-point (point))))))) 2425 (setcar (cddr parse-data) start))
2401 (goto-char pre-indent-point) 2426 ;; Before this point: end of statement
2402 (let* ((case-fold-search nil) 2427 (setq old-indent (nth 3 parse-data))))
2403 (s-s (cperl-get-state (car parse-data) (nth 1 parse-data))) 2428 (cond ((get-text-property (point) 'indentable)
2404 (start (or (nth 2 parse-data) 2429 ;; indent to just after the surrounding open,
2405 (nth 0 s-s))) 2430 ;; skip blanks if we do not close the expression.
2406 (state (nth 1 s-s)) 2431 (goto-char (1+ (previous-single-property-change (point) 'indentable)))
2407 (containing-sexp (car (cdr state))) 2432 (or (memq char-after (append ")]}" nil))
2408 old-indent) 2433 (looking-at "[ \t]*\\(#\\|$\\)")
2409 (if (and 2434 (skip-chars-forward " \t"))
2410 ;;containing-sexp ;; We are buggy at toplevel :-( 2435 (current-column))
2411 parse-data) 2436 ((or (nth 3 state) (nth 4 state))
2412 (progn 2437 ;; return nil or t if should not change this line
2413 (setcar parse-data pre-indent-point) 2438 (nth 4 state))
2414 (setcar (cdr parse-data) state) 2439 ;; XXXX Do we need to special-case this?
2415 (or (nth 2 parse-data) 2440 ((null containing-sexp)
2416 (setcar (cddr parse-data) start)) 2441 ;; Line is at top level. May be data or function definition,
2417 ;; Before this point: end of statement 2442 ;; or may be function argument declaration.
2418 (setq old-indent (nth 3 parse-data)))) 2443 ;; Indent like the previous top level line
2419 (cond ((get-text-property (point) 'indentable) 2444 ;; unless that ends in a closeparen without semicolon,
2420 ;; indent to just after the surrounding open, 2445 ;; in which case this line is the first argument decl.
2421 ;; skip blanks if we do not close the expression. 2446 (skip-chars-forward " \t")
2422 (goto-char (1+ (previous-single-property-change (point) 'indentable))) 2447 (+ (save-excursion
2423 (or (memq char-after (append ")]}" nil)) 2448 (goto-char start)
2424 (looking-at "[ \t]*\\(#\\|$\\)") 2449 (- (current-indentation)
2425 (skip-chars-forward " \t")) 2450 (if (nth 2 s-s) cperl-indent-level 0)))
2426 (current-column)) 2451 (if (= char-after ?{) cperl-continued-brace-offset 0)
2427 ((or (nth 3 state) (nth 4 state)) 2452 (progn
2428 ;; return nil or t if should not change this line 2453 (cperl-backward-to-noncomment (or old-indent (point-min)))
2429 (nth 4 state)) 2454 ;; Look at previous line that's at column 0
2430 ;; XXXX Do we need to special-case this? 2455 ;; to determine whether we are in top-level decls
2431 ((null containing-sexp) 2456 ;; or function's arg decls. Set basic-indent accordingly.
2432 ;; Line is at top level. May be data or function definition, 2457 ;; Now add a little if this is a continuation line.
2433 ;; or may be function argument declaration. 2458 (if (or (bobp)
2434 ;; Indent like the previous top level line 2459 (eq (point) old-indent) ; old-indent was at comment
2435 ;; unless that ends in a closeparen without semicolon, 2460 (eq (preceding-char) ?\;)
2436 ;; in which case this line is the first argument decl. 2461 ;; Had ?\) too
2437 (skip-chars-forward " \t") 2462 (and (eq (preceding-char) ?\})
2438 (+ (save-excursion 2463 (cperl-after-block-and-statement-beg
2439 (goto-char start) 2464 (point-min))) ; Was start - too close
2440 (- (current-indentation) 2465 (memq char-after (append ")]}" nil))
2441 (if (nth 2 s-s) cperl-indent-level 0))) 2466 (and (eq (preceding-char) ?\:) ; label
2442 (if (= char-after ?{) cperl-continued-brace-offset 0) 2467 (progn
2443 (progn 2468 (forward-sexp -1)
2444 (cperl-backward-to-noncomment (or old-indent (point-min))) 2469 (skip-chars-backward " \t")
2445 ;; Look at previous line that's at column 0 2470 (looking-at "[ \t]*[a-zA-Z_][a-zA-Z_0-9]*[ \t]*:"))))
2446 ;; to determine whether we are in top-level decls 2471 (progn
2447 ;; or function's arg decls. Set basic-indent accordingly. 2472 (if (and parse-data
2448 ;; Now add a little if this is a continuation line. 2473 (not (eq char-after ?\C-j)))
2449 (if (or (bobp) 2474 (setcdr (cddr parse-data)
2450 (eq (point) old-indent) ; old-indent was at comment 2475 (list pre-indent-point)))
2451 (eq (preceding-char) ?\;) 2476 0)
2452 ;; Had ?\) too 2477 cperl-continued-statement-offset))))
2453 (and (eq (preceding-char) ?\}) 2478 ((not
2454 (cperl-after-block-and-statement-beg 2479 (or (setq is-block
2455 (point-min))) ; Was start - too close 2480 (and (setq delim (= (char-after containing-sexp) ?{))
2456 (memq char-after (append ")]}" nil)) 2481 (save-excursion ; Is it a hash?
2457 (and (eq (preceding-char) ?\:) ; label 2482 (goto-char containing-sexp)
2458 (progn 2483 (cperl-block-p))))
2459 (forward-sexp -1) 2484 cperl-indent-parens-as-block))
2460 (skip-chars-backward " \t") 2485 ;; group is an expression, not a block:
2461 (looking-at "[ \t]*[a-zA-Z_][a-zA-Z_0-9]*[ \t]*:")))) 2486 ;; indent to just after the surrounding open parens,
2462 (progn 2487 ;; skip blanks if we do not close the expression.
2463 (if (and parse-data 2488 (goto-char (1+ containing-sexp))
2464 (not (eq char-after ?\C-j))) 2489 (or (memq char-after
2465 (setcdr (cddr parse-data) 2490 (append (if delim "}" ")]}") nil))
2466 (list pre-indent-point))) 2491 (looking-at "[ \t]*\\(#\\|$\\)")
2467 0) 2492 (skip-chars-forward " \t"))
2468 cperl-continued-statement-offset)))) 2493 (+ (current-column)
2469 ((not 2494 (if (and delim
2470 (or (setq is-block 2495 (eq char-after ?\}))
2471 (and (setq delim (= (char-after containing-sexp) ?{)) 2496 ;; Correct indentation of trailing ?\}
2472 (save-excursion ; Is it a hash? 2497 (+ cperl-indent-level cperl-close-paren-offset)
2473 (goto-char containing-sexp) 2498 0)))
2474 (cperl-block-p))))
2475 cperl-indent-parens-as-block))
2476 ;; group is an expression, not a block:
2477 ;; indent to just after the surrounding open parens,
2478 ;; skip blanks if we do not close the expression.
2479 (goto-char (1+ containing-sexp))
2480 (or (memq char-after (append ")]}" nil))
2481 (looking-at "[ \t]*\\(#\\|$\\)")
2482 (skip-chars-forward " \t"))
2483 (current-column))
2484 ((progn
2485 ;; Containing-expr starts with \{. Check whether it is a hash.
2486 (goto-char containing-sexp)
2487 (not (cperl-block-p)))
2488 (goto-char (1+ containing-sexp))
2489 (or (memq char-after
2490 (append (if delim "}" ")]}") nil))
2491 (looking-at "[ \t]*\\(#\\|$\\)")
2492 (skip-chars-forward " \t"))
2493 (+ (current-column)
2494 (if (and delim
2495 (eq char-after ?\}))
2496 ;; Correct indentation of trailing ?\}
2497 (+ cperl-indent-level cperl-close-paren-offset)
2498 0)))
2499;;; ((and (/= (char-after containing-sexp) ?{) 2499;;; ((and (/= (char-after containing-sexp) ?{)
2500;;; (not cperl-indent-parens-as-block)) 2500;;; (not cperl-indent-parens-as-block))
2501;;; ;; line is expression, not statement: 2501;;; ;; line is expression, not statement:
@@ -2519,151 +2519,151 @@ and closing parentheses and brackets."
2519;;; (if (eq char-after ?\}) (+ cperl-indent-level 2519;;; (if (eq char-after ?\}) (+ cperl-indent-level
2520;;; cperl-close-paren-offset) 2520;;; cperl-close-paren-offset)
2521;;; 0))) 2521;;; 0)))
2522 (t 2522 (t
2523 ;; Statement level. Is it a continuation or a new statement? 2523 ;; Statement level. Is it a continuation or a new statement?
2524 ;; Find previous non-comment character. 2524 ;; Find previous non-comment character.
2525 (goto-char pre-indent-point) 2525 (goto-char pre-indent-point)
2526 (cperl-backward-to-noncomment containing-sexp) 2526 (cperl-backward-to-noncomment containing-sexp)
2527 ;; Back up over label lines, since they don't 2527 ;; Back up over label lines, since they don't
2528 ;; affect whether our line is a continuation. 2528 ;; affect whether our line is a continuation.
2529 ;; (Had \, too) 2529 ;; (Had \, too)
2530 (while ;;(or (eq (preceding-char) ?\,) 2530 (while ;;(or (eq (preceding-char) ?\,)
2531 (and (eq (preceding-char) ?:) 2531 (and (eq (preceding-char) ?:)
2532 (or;;(eq (char-after (- (point) 2)) ?\') ; ???? 2532 (or ;;(eq (char-after (- (point) 2)) ?\') ; ????
2533 (memq (char-syntax (char-after (- (point) 2))) 2533 (memq (char-syntax (char-after (- (point) 2)))
2534 '(?w ?_)))) 2534 '(?w ?_))))
2535 ;;) 2535 ;;)
2536 (if (eq (preceding-char) ?\,) 2536 (if (eq (preceding-char) ?\,)
2537 ;; Will go to beginning of line, essentially. 2537 ;; Will go to beginning of line, essentially.
2538 ;; Will ignore embedded sexpr XXXX. 2538 ;; Will ignore embedded sexpr XXXX.
2539 (cperl-backward-to-start-of-continued-exp containing-sexp)) 2539 (cperl-backward-to-start-of-continued-exp containing-sexp))
2540 (beginning-of-line) 2540 (beginning-of-line)
2541 (cperl-backward-to-noncomment containing-sexp)) 2541 (cperl-backward-to-noncomment containing-sexp))
2542 ;; Now we get the answer. 2542 ;; Now we get the answer.
2543 (if (not (or (eq (1- (point)) containing-sexp) 2543 (if (not (or (eq (1- (point)) containing-sexp)
2544 (memq (preceding-char) 2544 (memq (preceding-char)
2545 (append (if is-block " ;{" " ,;{") '(nil))) 2545 (append (if is-block " ;{" " ,;{") '(nil)))
2546 (and (eq (preceding-char) ?\}) 2546 (and (eq (preceding-char) ?\})
2547 (cperl-after-block-and-statement-beg 2547 (cperl-after-block-and-statement-beg
2548 containing-sexp)))) 2548 containing-sexp))))
2549 ;; This line is continuation of preceding line's statement; 2549 ;; This line is continuation of preceding line's statement;
2550 ;; indent `cperl-continued-statement-offset' more than the 2550 ;; indent `cperl-continued-statement-offset' more than the
2551 ;; previous line of the statement. 2551 ;; previous line of the statement.
2552 ;; 2552 ;;
2553 ;; There might be a label on this line, just 2553 ;; There might be a label on this line, just
2554 ;; consider it bad style and ignore it. 2554 ;; consider it bad style and ignore it.
2555 (progn
2556 (cperl-backward-to-start-of-continued-exp containing-sexp)
2557 (+ (if (memq char-after (append "}])" nil))
2558 0 ; Closing parenth
2559 cperl-continued-statement-offset)
2560 (if (or is-block
2561 (not delim)
2562 (not (eq char-after ?\})))
2563 0
2564 ;; Now it is a hash reference
2565 (+ cperl-indent-level cperl-close-paren-offset))
2566 (if (looking-at "\\w+[ \t]*:")
2567 (if (> (current-indentation) cperl-min-label-indent)
2568 (- (current-indentation) cperl-label-offset)
2569 ;; Do not move `parse-data', this should
2570 ;; be quick anyway (this comment comes
2571 ;; from different location):
2572 (cperl-calculate-indent))
2573 (current-column))
2574 (if (eq char-after ?\{)
2575 cperl-continued-brace-offset 0)))
2576 ;; This line starts a new statement.
2577 ;; Position following last unclosed open.
2578 (goto-char containing-sexp)
2579 ;; Is line first statement after an open-brace?
2580 (or
2581 ;; If no, find that first statement and indent like
2582 ;; it. If the first statement begins with label, do
2583 ;; not believe when the indentation of the label is too
2584 ;; small.
2585 (save-excursion
2586 (forward-char 1)
2587 (setq old-indent (current-indentation))
2588 (let ((colon-line-end 0))
2589 (while (progn (skip-chars-forward " \t\n")
2590 (looking-at "#\\|[a-zA-Z0-9_$]*:[^:]"))
2591 ;; Skip over comments and labels following openbrace.
2592 (cond ((= (following-char) ?\#)
2593 (forward-line 1))
2594 ;; label:
2595 (t
2596 (save-excursion (end-of-line)
2597 (setq colon-line-end (point)))
2598 (search-forward ":"))))
2599 ;; The first following code counts
2600 ;; if it is before the line we want to indent.
2601 (and (< (point) indent-point)
2602 (if (> colon-line-end (point)) ; After label
2603 (if (> (current-indentation)
2604 cperl-min-label-indent)
2605 (- (current-indentation) cperl-label-offset)
2606 ;; Do not believe: `max' is involved
2607 (+ old-indent cperl-indent-level))
2608 (current-column)))))
2609 ;; If no previous statement,
2610 ;; indent it relative to line brace is on.
2611 ;; For open brace in column zero, don't let statement
2612 ;; start there too. If cperl-indent-level is zero,
2613 ;; use cperl-brace-offset + cperl-continued-statement-offset instead.
2614 ;; For open-braces not the first thing in a line,
2615 ;; add in cperl-brace-imaginary-offset.
2616
2617 ;; If first thing on a line: ?????
2618 (+ (if (and (bolp) (zerop cperl-indent-level))
2619 (+ cperl-brace-offset cperl-continued-statement-offset)
2620 cperl-indent-level)
2621 (if (or is-block
2622 (not delim)
2623 (not (eq char-after ?\})))
2624 0
2625 ;; Now it is a hash reference
2626 (+ cperl-indent-level cperl-close-paren-offset))
2627 ;; Move back over whitespace before the openbrace.
2628 ;; If openbrace is not first nonwhite thing on the line,
2629 ;; add the cperl-brace-imaginary-offset.
2630 (progn (skip-chars-backward " \t")
2631 (if (bolp) 0 cperl-brace-imaginary-offset))
2632 ;; If the openbrace is preceded by a parenthesized exp,
2633 ;; move to the beginning of that;
2634 ;; possibly a different line
2635 (progn 2555 (progn
2636 (if (eq (preceding-char) ?\)) 2556 (cperl-backward-to-start-of-continued-exp containing-sexp)
2637 (forward-sexp -1)) 2557 (+ (if (memq char-after (append "}])" nil))
2638 ;; In the case it starts a subroutine, indent with 2558 0 ; Closing parenth
2639 ;; respect to `sub', not with respect to the 2559 cperl-continued-statement-offset)
2640 ;; first thing on the line, say in the case of 2560 (if (or is-block
2641 ;; anonymous sub in a hash. 2561 (not delim)
2642 ;; 2562 (not (eq char-after ?\})))
2643 (skip-chars-backward " \t") 2563 0
2644 (if (and (eq (preceding-char) ?b) 2564 ;; Now it is a hash reference
2645 (progn 2565 (+ cperl-indent-level cperl-close-paren-offset))
2646 (forward-sexp -1) 2566 (if (looking-at "\\w+[ \t]*:")
2647 (looking-at "sub\\>")) 2567 (if (> (current-indentation) cperl-min-label-indent)
2648 (setq old-indent 2568 (- (current-indentation) cperl-label-offset)
2649 (nth 1 2569 ;; Do not move `parse-data', this should
2650 (parse-partial-sexp 2570 ;; be quick anyway (this comment comes
2651 (save-excursion (beginning-of-line) (point)) 2571 ;; from different location):
2652 (point))))) 2572 (cperl-calculate-indent))
2653 (progn (goto-char (1+ old-indent)) 2573 (current-column))
2654 (skip-chars-forward " \t") 2574 (if (eq char-after ?\{)
2655 (current-column)) 2575 cperl-continued-brace-offset 0)))
2656 ;; Get initial indentation of the line we are on. 2576 ;; This line starts a new statement.
2657 ;; If line starts with label, calculate label indentation 2577 ;; Position following last unclosed open.
2658 (if (save-excursion 2578 (goto-char containing-sexp)
2659 (beginning-of-line) 2579 ;; Is line first statement after an open-brace?
2660 (looking-at "[ \t]*[a-zA-Z_][a-zA-Z_0-9]*:[^:]")) 2580 (or
2661 (if (> (current-indentation) cperl-min-label-indent) 2581 ;; If no, find that first statement and indent like
2662 (- (current-indentation) cperl-label-offset) 2582 ;; it. If the first statement begins with label, do
2663 ;; Do not move `parse-data', this should 2583 ;; not believe when the indentation of the label is too
2664 ;; be quick anyway: 2584 ;; small.
2665 (cperl-calculate-indent)) 2585 (save-excursion
2666 (current-indentation)))))))))))))) 2586 (forward-char 1)
2587 (setq old-indent (current-indentation))
2588 (let ((colon-line-end 0))
2589 (while (progn (skip-chars-forward " \t\n")
2590 (looking-at "#\\|[a-zA-Z0-9_$]*:[^:]"))
2591 ;; Skip over comments and labels following openbrace.
2592 (cond ((= (following-char) ?\#)
2593 (forward-line 1))
2594 ;; label:
2595 (t
2596 (save-excursion (end-of-line)
2597 (setq colon-line-end (point)))
2598 (search-forward ":"))))
2599 ;; The first following code counts
2600 ;; if it is before the line we want to indent.
2601 (and (< (point) indent-point)
2602 (if (> colon-line-end (point)) ; After label
2603 (if (> (current-indentation)
2604 cperl-min-label-indent)
2605 (- (current-indentation) cperl-label-offset)
2606 ;; Do not believe: `max' is involved
2607 (+ old-indent cperl-indent-level))
2608 (current-column)))))
2609 ;; If no previous statement,
2610 ;; indent it relative to line brace is on.
2611 ;; For open brace in column zero, don't let statement
2612 ;; start there too. If cperl-indent-level is zero,
2613 ;; use cperl-brace-offset + cperl-continued-statement-offset instead.
2614 ;; For open-braces not the first thing in a line,
2615 ;; add in cperl-brace-imaginary-offset.
2616
2617 ;; If first thing on a line: ?????
2618 (+ (if (and (bolp) (zerop cperl-indent-level))
2619 (+ cperl-brace-offset cperl-continued-statement-offset)
2620 cperl-indent-level)
2621 (if (or is-block
2622 (not delim)
2623 (not (eq char-after ?\})))
2624 0
2625 ;; Now it is a hash reference
2626 (+ cperl-indent-level cperl-close-paren-offset))
2627 ;; Move back over whitespace before the openbrace.
2628 ;; If openbrace is not first nonwhite thing on the line,
2629 ;; add the cperl-brace-imaginary-offset.
2630 (progn (skip-chars-backward " \t")
2631 (if (bolp) 0 cperl-brace-imaginary-offset))
2632 ;; If the openbrace is preceded by a parenthesized exp,
2633 ;; move to the beginning of that;
2634 ;; possibly a different line
2635 (progn
2636 (if (eq (preceding-char) ?\))
2637 (forward-sexp -1))
2638 ;; In the case it starts a subroutine, indent with
2639 ;; respect to `sub', not with respect to the
2640 ;; first thing on the line, say in the case of
2641 ;; anonymous sub in a hash.
2642 ;;
2643 (skip-chars-backward " \t")
2644 (if (and (eq (preceding-char) ?b)
2645 (progn
2646 (forward-sexp -1)
2647 (looking-at "sub\\>"))
2648 (setq old-indent
2649 (nth 1
2650 (parse-partial-sexp
2651 (save-excursion (beginning-of-line) (point))
2652 (point)))))
2653 (progn (goto-char (1+ old-indent))
2654 (skip-chars-forward " \t")
2655 (current-column))
2656 ;; Get initial indentation of the line we are on.
2657 ;; If line starts with label, calculate label indentation
2658 (if (save-excursion
2659 (beginning-of-line)
2660 (looking-at "[ \t]*[a-zA-Z_][a-zA-Z_0-9]*:[^:]"))
2661 (if (> (current-indentation) cperl-min-label-indent)
2662 (- (current-indentation) cperl-label-offset)
2663 ;; Do not move `parse-data', this should
2664 ;; be quick anyway:
2665 (cperl-calculate-indent))
2666 (current-indentation))))))))))))))
2667 2667
2668(defvar cperl-indent-alist 2668(defvar cperl-indent-alist
2669 '((string nil) 2669 '((string nil)
@@ -2725,9 +2725,9 @@ Not finished, not used."
2725 (point))) 2725 (point)))
2726 (cons (list 'expression containing-sexp) res)))) 2726 (cons (list 'expression containing-sexp) res))))
2727 ((progn 2727 ((progn
2728 ;; Containing-expr starts with \{. Check whether it is a hash. 2728 ;; Containing-expr starts with \{. Check whether it is a hash.
2729 (goto-char containing-sexp) 2729 (goto-char containing-sexp)
2730 (not (cperl-block-p))) 2730 (not (cperl-block-p)))
2731 (setq res (cons (list 'expression-blanks 2731 (setq res (cons (list 'expression-blanks
2732 (progn 2732 (progn
2733 (goto-char (1+ containing-sexp)) 2733 (goto-char (1+ containing-sexp))
@@ -2748,7 +2748,7 @@ Not finished, not used."
2748 (save-excursion (cperl-after-label))) 2748 (save-excursion (cperl-after-label)))
2749 (if (eq (preceding-char) ?\,) 2749 (if (eq (preceding-char) ?\,)
2750 ;; Will go to beginning of line, essentially 2750 ;; Will go to beginning of line, essentially
2751 ;; Will ignore embedded sexpr XXXX. 2751 ;; Will ignore embedded sexpr XXXX.
2752 (cperl-backward-to-start-of-continued-exp containing-sexp)) 2752 (cperl-backward-to-start-of-continued-exp containing-sexp))
2753 (beginning-of-line) 2753 (beginning-of-line)
2754 (cperl-backward-to-noncomment containing-sexp)) 2754 (cperl-backward-to-noncomment containing-sexp))
@@ -2848,43 +2848,42 @@ the current line is to be regarded as part of a block comment."
2848 "Go to position before comment on the current line, or to end of line. 2848 "Go to position before comment on the current line, or to end of line.
2849Returns true if comment is found." 2849Returns true if comment is found."
2850 (let (state stop-in cpoint (lim (progn (end-of-line) (point)))) 2850 (let (state stop-in cpoint (lim (progn (end-of-line) (point))))
2851 (beginning-of-line) 2851 (beginning-of-line)
2852 (if (or 2852 (if (or
2853 (eq (get-text-property (point) 'syntax-type) 'pod) 2853 (eq (get-text-property (point) 'syntax-type) 'pod)
2854 (re-search-forward "\\=[ \t]*\\(#\\|$\\)" lim t)) 2854 (re-search-forward "\\=[ \t]*\\(#\\|$\\)" lim t))
2855 (if (eq (preceding-char) ?\#) (progn (backward-char 1) t)) 2855 (if (eq (preceding-char) ?\#) (progn (backward-char 1) t))
2856 ;; Else 2856 ;; Else
2857 (while (not stop-in) 2857 (while (not stop-in)
2858 (setq state (parse-partial-sexp (point) lim nil nil nil t)) 2858 (setq state (parse-partial-sexp (point) lim nil nil nil t))
2859 ; stop at comment 2859 ; stop at comment
2860 ;; If fails (beginning-of-line inside sexp), then contains not-comment 2860 ;; If fails (beginning-of-line inside sexp), then contains not-comment
2861 (if (nth 4 state) ; After `#'; 2861 (if (nth 4 state) ; After `#';
2862 ; (nth 2 state) can be 2862 ; (nth 2 state) can be
2863 ; beginning of m,s,qq and so 2863 ; beginning of m,s,qq and so
2864 ; on 2864 ; on
2865 (if (nth 2 state) 2865 (if (nth 2 state)
2866 (progn 2866 (progn
2867 (setq cpoint (point)) 2867 (setq cpoint (point))
2868 (goto-char (nth 2 state)) 2868 (goto-char (nth 2 state))
2869 (cond 2869 (cond
2870 ((looking-at "\\(s\\|tr\\)\\>") 2870 ((looking-at "\\(s\\|tr\\)\\>")
2871 (or (re-search-forward 2871 (or (re-search-forward
2872 "\\=\\w+[ \t]*#\\([^\n\\\\#]\\|\\\\[\\\\#]\\)*#\\([^\n\\\\#]\\|\\\\[\\\\#]\\)*" 2872 "\\=\\w+[ \t]*#\\([^\n\\\\#]\\|\\\\[\\\\#]\\)*#\\([^\n\\\\#]\\|\\\\[\\\\#]\\)*"
2873 lim 'move) 2873 lim 'move)
2874 (setq stop-in t))) 2874 (setq stop-in t)))
2875 ((looking-at "\\(m\\|q\\([qxwr]\\)?\\)\\>") 2875 ((looking-at "\\(m\\|q\\([qxwr]\\)?\\)\\>")
2876 (or (re-search-forward 2876 (or (re-search-forward
2877 "\\=\\w+[ \t]*#\\([^\n\\\\#]\\|\\\\[\\\\#]\\)*#" 2877 "\\=\\w+[ \t]*#\\([^\n\\\\#]\\|\\\\[\\\\#]\\)*#"
2878 lim 'move) 2878 lim 'move)
2879 (setq stop-in t))) 2879 (setq stop-in t)))
2880 (t ; It was fair comment 2880 (t ; It was fair comment
2881 (setq stop-in t) ; Finish 2881 (setq stop-in t) ; Finish
2882 (goto-char (1- cpoint))))) 2882 (goto-char (1- cpoint)))))
2883 (setq stop-in t) ; Finish 2883 (setq stop-in t) ; Finish
2884 (forward-char -1)) 2884 (forward-char -1))
2885 (setq stop-in t)) ; Finish 2885 (setq stop-in t))) ; Finish
2886 ) 2886 (nth 4 state))))
2887 (nth 4 state))))
2888 2887
2889(defsubst cperl-1- (p) 2888(defsubst cperl-1- (p)
2890 (max (point-min) (1- p))) 2889 (max (point-min) (1- p)))
@@ -3031,11 +3030,14 @@ Returns true if comment is found."
3031 ;; go-forward: has 2 args, and the second part is empty 3030 ;; go-forward: has 2 args, and the second part is empty
3032 (list i i2 ender starter go-forward))) 3031 (list i i2 ender starter go-forward)))
3033 3032
3033(defvar font-lock-string-face)
3034;;(defvar font-lock-reference-face)
3035(defvar font-lock-constant-face)
3034(defsubst cperl-postpone-fontification (b e type val &optional now) 3036(defsubst cperl-postpone-fontification (b e type val &optional now)
3035 ;; Do after syntactic fontification? 3037 ;; Do after syntactic fontification?
3036 (if cperl-syntaxify-by-font-lock 3038 (if cperl-syntaxify-by-font-lock
3037 (or now (put-text-property b e 'cperl-postpone (cons type val))) 3039 (or now (put-text-property b e 'cperl-postpone (cons type val)))
3038 (put-text-property b e type val))) 3040 (put-text-property b e type val)))
3039 3041
3040;;; Here is how the global structures (those which cannot be 3042;;; Here is how the global structures (those which cannot be
3041;;; recognized locally) are marked: 3043;;; recognized locally) are marked:
@@ -3095,100 +3097,99 @@ the sections using `cperl-pod-head-face', `cperl-pod-face',
3095 cperl-syntax-state nil 3097 cperl-syntax-state nil
3096 cperl-syntax-done-to min)) 3098 cperl-syntax-done-to min))
3097 (or max (setq max (point-max))) 3099 (or max (setq max (point-max)))
3098 (let* (face head-face here-face b e bb tag qtag b1 e1 argument i c tail tb 3100 (let* ((cperl-pod-here-fontify (eval cperl-pod-here-fontify)) go tmpend
3099 is-REx is-x-REx REx-comment-start REx-comment-end was-comment i2 3101 face head-face here-face b e bb tag qtag b1 e1 argument i c tail tb
3100 (cperl-pod-here-fontify (eval cperl-pod-here-fontify)) go tmpend 3102 is-REx is-x-REx REx-comment-start REx-comment-end was-comment i2
3101 (case-fold-search nil) (inhibit-read-only t) (buffer-undo-list t) 3103 (case-fold-search nil) (inhibit-read-only t) (buffer-undo-list t)
3102 (modified (buffer-modified-p)) 3104 (modified (buffer-modified-p))
3103 (after-change-functions nil) 3105 (after-change-functions nil)
3104 (use-syntax-state (and cperl-syntax-state 3106 (use-syntax-state (and cperl-syntax-state
3105 (>= min (car cperl-syntax-state)))) 3107 (>= min (car cperl-syntax-state))))
3106 (state-point (if use-syntax-state 3108 (state-point (if use-syntax-state
3107 (car cperl-syntax-state) 3109 (car cperl-syntax-state)
3108 (point-min))) 3110 (point-min)))
3109 (state (if use-syntax-state 3111 (state (if use-syntax-state
3110 (cdr cperl-syntax-state))) 3112 (cdr cperl-syntax-state)))
3111 ;; (st-l '(nil)) (err-l '(nil)) ; Would overwrite - propagates from a function call to a function call! 3113 ;; (st-l '(nil)) (err-l '(nil)) ; Would overwrite - propagates from a function call to a function call!
3112 (st-l (list nil)) (err-l (list nil)) 3114 (st-l (list nil)) (err-l (list nil))
3113 ;; Somehow font-lock may be not loaded yet... 3115 ;; Somehow font-lock may be not loaded yet...
3114 (font-lock-string-face (if (boundp 'font-lock-string-face) 3116 (font-lock-string-face (if (boundp 'font-lock-string-face)
3115 font-lock-string-face 3117 font-lock-string-face
3116 'font-lock-string-face)) 3118 'font-lock-string-face))
3117 (font-lock-constant-face (if (boundp 'font-lock-constant-face) 3119 (font-lock-constant-face (if (boundp 'font-lock-constant-face)
3118 font-lock-constant-face 3120 font-lock-constant-face
3119 'font-lock-constant-face)) 3121 'font-lock-constant-face))
3120 (font-lock-function-name-face 3122 (font-lock-function-name-face
3121 (if (boundp 'font-lock-function-name-face) 3123 (if (boundp 'font-lock-function-name-face)
3122 font-lock-function-name-face 3124 font-lock-function-name-face
3123 'font-lock-function-name-face)) 3125 'font-lock-function-name-face))
3124 (font-lock-comment-face 3126 (font-lock-comment-face
3125 (if (boundp 'font-lock-comment-face) 3127 (if (boundp 'font-lock-comment-face)
3126 font-lock-comment-face 3128 font-lock-comment-face
3127 'font-lock-comment-face)) 3129 'font-lock-comment-face))
3128 (cperl-nonoverridable-face 3130 (cperl-nonoverridable-face
3129 (if (boundp 'cperl-nonoverridable-face) 3131 (if (boundp 'cperl-nonoverridable-face)
3130 cperl-nonoverridable-face 3132 cperl-nonoverridable-face
3131 'cperl-nonoverridable-face)) 3133 'cperl-nonoverridable-face))
3132 (stop-point (if ignore-max 3134 (stop-point (if ignore-max
3133 (point-max) 3135 (point-max)
3134 max)) 3136 max))
3135 (search 3137 (search
3138 (concat
3139 "\\(\\`\n?\\|^\n\\)="
3140 "\\|"
3141 ;; One extra () before this:
3142 "<<"
3143 "\\(" ; 1 + 1
3144 ;; First variant "BLAH" or just ``.
3145 "[ \t]*" ; Yes, whitespace is allowed!
3146 "\\([\"'`]\\)" ; 2 + 1 = 3
3147 "\\([^\"'`\n]*\\)" ; 3 + 1
3148 "\\3"
3149 "\\|"
3150 ;; Second variant: Identifier or \ID or empty
3151 "\\\\?\\(\\([a-zA-Z_][a-zA-Z_0-9]*\\)?\\)" ; 4 + 1, 5 + 1
3152 ;; Do not have <<= or << 30 or <<30 or << $blah.
3153 ;; "\\([^= \t0-9$@%&]\\|[ \t]+[^ \t\n0-9$@%&]\\)" ; 6 + 1
3154 "\\(\\)" ; To preserve count of pars :-( 6 + 1
3155 "\\)"
3156 "\\|"
3157 ;; 1+6 extra () before this:
3158 "^[ \t]*\\(format\\)[ \t]*\\([a-zA-Z0-9_]+\\)?[ \t]*=[ \t]*$"
3159 (if cperl-use-syntax-table-text-property
3136 (concat 3160 (concat
3137 "\\(\\`\n?\\|^\n\\)="
3138 "\\|" 3161 "\\|"
3139 ;; One extra () before this: 3162 ;; 1+6+2=9 extra () before this:
3140 "<<" 3163 "\\<\\(q[wxqr]?\\|[msy]\\|tr\\)\\>"
3141 "\\(" ; 1 + 1 3164 "\\|"
3142 ;; First variant "BLAH" or just ``. 3165 ;; 1+6+2+1=10 extra () before this:
3143 "[ \t]*" ; Yes, whitespace is allowed! 3166 "\\([?/<]\\)" ; /blah/ or ?blah? or <file*glob>
3144 "\\([\"'`]\\)" ; 2 + 1 = 3 3167 "\\|"
3145 "\\([^\"'`\n]*\\)" ; 3 + 1 3168 ;; 1+6+2+1+1=11 extra () before this:
3146 "\\3" 3169 "\\<sub\\>[ \t]*\\([a-zA-Z_:'0-9]+[ \t]*\\)?\\(([^()]*)\\)"
3147 "\\|" 3170 "\\|"
3148 ;; Second variant: Identifier or \ID or empty 3171 ;; 1+6+2+1+1+2=13 extra () before this:
3149 "\\\\?\\(\\([a-zA-Z_][a-zA-Z_0-9]*\\)?\\)" ; 4 + 1, 5 + 1 3172 "\\$\\(['{]\\)"
3150 ;; Do not have <<= or << 30 or <<30 or << $blah. 3173 "\\|"
3151 ;; "\\([^= \t0-9$@%&]\\|[ \t]+[^ \t\n0-9$@%&]\\)" ; 6 + 1 3174 ;; 1+6+2+1+1+2+1=14 extra () before this:
3152 "\\(\\)" ; To preserve count of pars :-( 6 + 1 3175 "\\(\\<sub[ \t\n\f]+\\|[&*$@%]\\)[a-zA-Z0-9_]*'"
3153 "\\)" 3176 ;; 1+6+2+1+1+2+1+1=15 extra () before this:
3177 "\\|"
3178 "__\\(END\\|DATA\\)__"
3179 ;; 1+6+2+1+1+2+1+1+1=16 extra () before this:
3154 "\\|" 3180 "\\|"
3155 ;; 1+6 extra () before this: 3181 "\\\\\\(['`\"]\\)")
3156 "^[ \t]*\\(format\\)[ \t]*\\([a-zA-Z0-9_]+\\)?[ \t]*=[ \t]*$" 3182 ""))))
3157 (if cperl-use-syntax-table-text-property
3158 (concat
3159 "\\|"
3160 ;; 1+6+2=9 extra () before this:
3161 "\\<\\(q[wxqr]?\\|[msy]\\|tr\\)\\>"
3162 "\\|"
3163 ;; 1+6+2+1=10 extra () before this:
3164 "\\([?/<]\\)" ; /blah/ or ?blah? or <file*glob>
3165 "\\|"
3166 ;; 1+6+2+1+1=11 extra () before this:
3167 "\\<sub\\>[ \t]*\\([a-zA-Z_:'0-9]+[ \t]*\\)?\\(([^()]*)\\)"
3168 "\\|"
3169 ;; 1+6+2+1+1+2=13 extra () before this:
3170 "\\$\\(['{]\\)"
3171 "\\|"
3172 ;; 1+6+2+1+1+2+1=14 extra () before this:
3173 "\\(\\<sub[ \t\n\f]+\\|[&*$@%]\\)[a-zA-Z0-9_]*'"
3174 ;; 1+6+2+1+1+2+1+1=15 extra () before this:
3175 "\\|"
3176 "__\\(END\\|DATA\\)__"
3177 ;; 1+6+2+1+1+2+1+1+1=16 extra () before this:
3178 "\\|"
3179 "\\\\\\(['`\"]\\)"
3180 )
3181 ""))))
3182 (unwind-protect 3183 (unwind-protect
3183 (progn 3184 (progn
3184 (save-excursion 3185 (save-excursion
3185 (or non-inter 3186 (or non-inter
3186 (message "Scanning for \"hard\" Perl constructions...")) 3187 (message "Scanning for \"hard\" Perl constructions..."))
3187 (and cperl-pod-here-fontify 3188 (and cperl-pod-here-fontify
3188 ;; We had evals here, do not know why... 3189 ;; We had evals here, do not know why...
3189 (setq face cperl-pod-face 3190 (setq face cperl-pod-face
3190 head-face cperl-pod-head-face 3191 head-face cperl-pod-head-face
3191 here-face cperl-here-face)) 3192 here-face cperl-here-face))
3192 (remove-text-properties min max 3193 (remove-text-properties min max
3193 '(syntax-type t in-pod t syntax-table t 3194 '(syntax-type t in-pod t syntax-table t
3194 cperl-postpone t 3195 cperl-postpone t
@@ -3279,7 +3280,7 @@ the sections using `cperl-pod-head-face', `cperl-pod-face',
3279 (cperl-commentify bb e nil) 3280 (cperl-commentify bb e nil)
3280 (goto-char e) 3281 (goto-char e)
3281 (or (eq e (point-max)) 3282 (or (eq e (point-max))
3282 (forward-char -1)))) ; Prepare for immediate pod start. 3283 (forward-char -1)))) ; Prepare for immediate POD start.
3283 ;; Here document 3284 ;; Here document
3284 ;; We do only one here-per-line 3285 ;; We do only one here-per-line
3285 ;; ;; One extra () before this: 3286 ;; ;; One extra () before this:
@@ -3333,11 +3334,11 @@ the sections using `cperl-pod-head-face', `cperl-pod-face',
3333 (progn 3334 (progn
3334 ;; Highlight the ending delimiter 3335 ;; Highlight the ending delimiter
3335 (cperl-postpone-fontification (match-beginning 0) (match-end 0) 3336 (cperl-postpone-fontification (match-beginning 0) (match-end 0)
3336 'face font-lock-constant-face) 3337 'face font-lock-constant-face)
3337 (cperl-put-do-not-fontify b (match-end 0) t) 3338 (cperl-put-do-not-fontify b (match-end 0) t)
3338 ;; Highlight the HERE-DOC 3339 ;; Highlight the HERE-DOC
3339 (cperl-postpone-fontification b (match-beginning 0) 3340 (cperl-postpone-fontification b (match-beginning 0)
3340 'face here-face))) 3341 'face here-face)))
3341 (setq e1 (cperl-1+ (match-end 0))) 3342 (setq e1 (cperl-1+ (match-end 0)))
3342 (put-text-property b (match-beginning 0) 3343 (put-text-property b (match-beginning 0)
3343 'syntax-type 'here-doc) 3344 'syntax-type 'here-doc)
@@ -3379,18 +3380,18 @@ the sections using `cperl-pod-head-face', `cperl-pod-face',
3379 (end-of-line) 3380 (end-of-line)
3380 ;; Highlight the format line 3381 ;; Highlight the format line
3381 (cperl-postpone-fontification b1 (point) 3382 (cperl-postpone-fontification b1 (point)
3382 'face font-lock-string-face) 3383 'face font-lock-string-face)
3383 (cperl-commentify b1 (point) nil) 3384 (cperl-commentify b1 (point) nil)
3384 (cperl-put-do-not-fontify b1 (point) t)))) 3385 (cperl-put-do-not-fontify b1 (point) t))))
3385 ;; We do not search to max, since we may be called from 3386 ;; We do not search to max, since we may be called from
3386 ;; some hook of fontification, and max is random 3387 ;; some hook of fontification, and max is random
3387 (re-search-forward "^[.;]$" stop-point 'toend)) 3388 (re-search-forward "^[.;]$" stop-point 'toend))
3388 (beginning-of-line) 3389 (beginning-of-line)
3389 (if (looking-at "^\\.$") ; ";" is not supported yet 3390 (if (looking-at "^\\.$") ; ";" is not supported yet
3390 (progn 3391 (progn
3391 ;; Highlight the ending delimiter 3392 ;; Highlight the ending delimiter
3392 (cperl-postpone-fontification (point) (+ (point) 2) 3393 (cperl-postpone-fontification (point) (+ (point) 2)
3393 'face font-lock-string-face) 3394 'face font-lock-string-face)
3394 (cperl-commentify (point) (+ (point) 2) nil) 3395 (cperl-commentify (point) (+ (point) 2) nil)
3395 (cperl-put-do-not-fontify (point) (+ (point) 2) t)) 3396 (cperl-put-do-not-fontify (point) (+ (point) 2) t))
3396 (message "End of format `%s' not found." name) 3397 (message "End of format `%s' not found." name)
@@ -3418,7 +3419,7 @@ the sections using `cperl-pod-head-face', `cperl-pod-face',
3418 (memq bb '(?\$ ?\@ ?\% ?\* ?\#)) ; $#y 3419 (memq bb '(?\$ ?\@ ?\% ?\* ?\#)) ; $#y
3419 (and (eq bb ?-) (eq c ?s)) ; -s file test 3420 (and (eq bb ?-) (eq c ?s)) ; -s file test
3420 (and (eq bb ?\&) 3421 (and (eq bb ?\&)
3421 (not (eq (char-after ; &&m/blah/ 3422 (not (eq (char-after ; &&m/blah/
3422 (- (match-beginning b1) 2)) 3423 (- (match-beginning b1) 2))
3423 ?\&)))) 3424 ?\&))))
3424 ;; <file> or <$file> 3425 ;; <file> or <$file>
@@ -3599,10 +3600,10 @@ the sections using `cperl-pod-head-face', `cperl-pod-face',
3599 (if is-x-REx 3600 (if is-x-REx
3600 (if (eq (char-after b) ?\#) 3601 (if (eq (char-after b) ?\#)
3601 "\\((\\?\\\\#\\)\\|\\(\\\\#\\)" 3602 "\\((\\?\\\\#\\)\\|\\(\\\\#\\)"
3602 "\\((\\?#\\)\\|\\(#\\)") 3603 "\\((\\?#\\)\\|\\(#\\)")
3603 (if (eq (char-after b) ?\#) 3604 (if (eq (char-after b) ?\#)
3604 "\\((\\?\\\\#\\)" 3605 "\\((\\?\\\\#\\)"
3605 "\\((\\?#\\)")) 3606 "\\((\\?#\\)"))
3606 (1- e) 'to-end)) 3607 (1- e) 'to-end))
3607 (goto-char (match-beginning 0)) 3608 (goto-char (match-beginning 0))
3608 (setq REx-comment-start (point) 3609 (setq REx-comment-start (point)
@@ -3744,13 +3745,12 @@ the sections using `cperl-pod-head-face', `cperl-pod-face',
3744 (if (memq (setq pr (get-text-property (point) 'syntax-type)) 3745 (if (memq (setq pr (get-text-property (point) 'syntax-type))
3745 '(pod here-doc here-doc-delim)) 3746 '(pod here-doc here-doc-delim))
3746 (cperl-unwind-to-safe nil) 3747 (cperl-unwind-to-safe nil)
3747 (if (or (looking-at "^[ \t]*\\(#\\|$\\)") 3748 (or (looking-at "^[ \t]*\\(#\\|$\\)")
3748 (progn (cperl-to-comment-or-eol) (bolp))) 3749 (progn (cperl-to-comment-or-eol) (bolp))
3749 nil ; Only comment, skip 3750 (progn
3750 ;; Else 3751 (skip-chars-backward " \t")
3751 (skip-chars-backward " \t") 3752 (if (< p (point)) (goto-char p))
3752 (if (< p (point)) (goto-char p)) 3753 (setq stop t)))))))
3753 (setq stop t))))))
3754 3754
3755(defun cperl-after-block-p (lim) 3755(defun cperl-after-block-p (lim)
3756 ;; We suppose that the preceding char is }. 3756 ;; We suppose that the preceding char is }.
@@ -3780,8 +3780,8 @@ the sections using `cperl-pod-head-face', `cperl-pod-face',
3780TEST is the expression to evaluate at the found position. If absent, 3780TEST is the expression to evaluate at the found position. If absent,
3781CHARS is a string that contains good characters to have before us (however, 3781CHARS is a string that contains good characters to have before us (however,
3782`}' is treated \"smartly\" if it is not in the list)." 3782`}' is treated \"smartly\" if it is not in the list)."
3783 (let (stop p 3783 (let ((lim (or lim (point-min)))
3784 (lim (or lim (point-min)))) 3784 stop p)
3785 (save-excursion 3785 (save-excursion
3786 (while (and (not stop) (> (point) lim)) 3786 (while (and (not stop) (> (point) lim))
3787 (skip-chars-backward " \t\n\f" lim) 3787 (skip-chars-backward " \t\n\f" lim)
@@ -3874,10 +3874,10 @@ Returns some position at the last line."
3874 (interactive) 3874 (interactive)
3875 (or end 3875 (or end
3876 (setq end (point-max))) 3876 (setq end (point-max)))
3877 (let (p pp ml have-brace ret 3877 (let ((ee (save-excursion (end-of-line) (point)))
3878 (ee (save-excursion (end-of-line) (point))) 3878 (cperl-indent-region-fix-constructs
3879 (cperl-indent-region-fix-constructs 3879 (or cperl-indent-region-fix-constructs 1))
3880 (or cperl-indent-region-fix-constructs 1))) 3880 p pp ml have-brace ret)
3881 (save-excursion 3881 (save-excursion
3882 (beginning-of-line) 3882 (beginning-of-line)
3883 (setq ret (point)) 3883 (setq ret (point))
@@ -3887,165 +3887,165 @@ Returns some position at the last line."
3887 (or (looking-at "[ \t]*\\(els\\(e\\|if\\)\\|continue\\|if\\|while\\|for\\(each\\)?\\|until\\)") 3887 (or (looking-at "[ \t]*\\(els\\(e\\|if\\)\\|continue\\|if\\|while\\|for\\(each\\)?\\|until\\)")
3888 (setq have-brace (save-excursion (search-forward "}" ee t))))) 3888 (setq have-brace (save-excursion (search-forward "}" ee t)))))
3889 nil ; Do not need to do anything 3889 nil ; Do not need to do anything
3890 ;; Looking at: 3890 ;; Looking at:
3891 ;; } 3891 ;; }
3892 ;; else 3892 ;; else
3893 (if (and cperl-merge-trailing-else 3893 (if (and cperl-merge-trailing-else
3894 (looking-at 3894 (looking-at
3895 "[ \t]*}[ \t]*\n[ \t\n]*\\(els\\(e\\|if\\)\\|continue\\)\\>")) 3895 "[ \t]*}[ \t]*\n[ \t\n]*\\(els\\(e\\|if\\)\\|continue\\)\\>"))
3896 (progn 3896 (progn
3897 (search-forward "}") 3897 (search-forward "}")
3898 (setq p (point)) 3898 (setq p (point))
3899 (skip-chars-forward " \t\n") 3899 (skip-chars-forward " \t\n")
3900 (delete-region p (point)) 3900 (delete-region p (point))
3901 (insert (make-string cperl-indent-region-fix-constructs ?\ )) 3901 (insert (make-string cperl-indent-region-fix-constructs ?\ ))
3902 (beginning-of-line))) 3902 (beginning-of-line)))
3903 ;; Looking at: 3903 ;; Looking at:
3904 ;; } else 3904 ;; } else
3905 (if (looking-at "[ \t]*}\\(\t*\\|[ \t][ \t]+\\)\\<\\(els\\(e\\|if\\)\\|continue\\)\\>") 3905 (if (looking-at "[ \t]*}\\(\t*\\|[ \t][ \t]+\\)\\<\\(els\\(e\\|if\\)\\|continue\\)\\>")
3906 (progn 3906 (progn
3907 (search-forward "}") 3907 (search-forward "}")
3908 (delete-horizontal-space) 3908 (delete-horizontal-space)
3909 (insert (make-string cperl-indent-region-fix-constructs ?\ )) 3909 (insert (make-string cperl-indent-region-fix-constructs ?\ ))
3910 (beginning-of-line))) 3910 (beginning-of-line)))
3911 ;; Looking at: 3911 ;; Looking at:
3912 ;; else { 3912 ;; else {
3913 (if (looking-at 3913 (if (looking-at
3914 "[ \t]*}?[ \t]*\\<\\(\\els\\(e\\|if\\)\\|continue\\|unless\\|if\\|while\\|for\\(each\\)?\\|until\\)\\>\\(\t*\\|[ \t][ \t]+\\)[^ \t\n#]") 3914 "[ \t]*}?[ \t]*\\<\\(\\els\\(e\\|if\\)\\|continue\\|unless\\|if\\|while\\|for\\(each\\)?\\|until\\)\\>\\(\t*\\|[ \t][ \t]+\\)[^ \t\n#]")
3915 (progn 3915 (progn
3916 (forward-word 1) 3916 (forward-word 1)
3917 (delete-horizontal-space) 3917 (delete-horizontal-space)
3918 (insert (make-string cperl-indent-region-fix-constructs ?\ )) 3918 (insert (make-string cperl-indent-region-fix-constructs ?\ ))
3919 (beginning-of-line))) 3919 (beginning-of-line)))
3920 ;; Looking at: 3920 ;; Looking at:
3921 ;; foreach my $var 3921 ;; foreach my $var
3922 (if (looking-at 3922 (if (looking-at
3923 "[ \t]*\\<for\\(each\\)?[ \t]+\\(my\\|local\\|our\\)\\(\t*\\|[ \t][ \t]+\\)[^ \t\n]") 3923 "[ \t]*\\<for\\(each\\)?[ \t]+\\(my\\|local\\|our\\)\\(\t*\\|[ \t][ \t]+\\)[^ \t\n]")
3924 (progn 3924 (progn
3925 (forward-word 2) 3925 (forward-word 2)
3926 (delete-horizontal-space) 3926 (delete-horizontal-space)
3927 (insert (make-string cperl-indent-region-fix-constructs ?\ )) 3927 (insert (make-string cperl-indent-region-fix-constructs ?\ ))
3928 (beginning-of-line))) 3928 (beginning-of-line)))
3929 ;; Looking at: 3929 ;; Looking at:
3930 ;; foreach my $var ( 3930 ;; foreach my $var (
3931 (if (looking-at 3931 (if (looking-at
3932 "[ \t]*\\<for\\(each\\)?[ \t]+\\(my\\|local\\|our\\)[ \t]*\\$[_a-zA-Z0-9]+\\(\t*\\|[ \t][ \t]+\\)[^ \t\n#]") 3932 "[ \t]*\\<for\\(each\\)?[ \t]+\\(my\\|local\\|our\\)[ \t]*\\$[_a-zA-Z0-9]+\\(\t*\\|[ \t][ \t]+\\)[^ \t\n#]")
3933 (progn 3933 (progn
3934 (forward-word 3) 3934 (forward-word 3)
3935 (delete-horizontal-space) 3935 (delete-horizontal-space)
3936 (insert 3936 (insert
3937 (make-string cperl-indent-region-fix-constructs ?\ )) 3937 (make-string cperl-indent-region-fix-constructs ?\ ))
3938 (beginning-of-line))) 3938 (beginning-of-line)))
3939 ;; Looking at: 3939 ;; Looking at:
3940 ;; } foreach my $var () { 3940 ;; } foreach my $var () {
3941 (if (looking-at 3941 (if (looking-at
3942 "[ \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]*{") 3942 "[ \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]*{")
3943 (progn 3943 (progn
3944 (setq ml (match-beginning 8)) 3944 (setq ml (match-beginning 8))
3945 (re-search-forward "[({]") 3945 (re-search-forward "[({]")
3946 (forward-char -1) 3946 (forward-char -1)
3947 (setq p (point)) 3947 (setq p (point))
3948 (if (eq (following-char) ?\( ) 3948 (if (eq (following-char) ?\( )
3949 (progn 3949 (progn
3950 (forward-sexp 1) 3950 (forward-sexp 1)
3951 (setq pp (point))) 3951 (setq pp (point)))
3952 ;; after `else' or nothing 3952 ;; after `else' or nothing
3953 (if ml ; after `else' 3953 (if ml ; after `else'
3954 (skip-chars-backward " \t\n") 3954 (skip-chars-backward " \t\n")
3955 (beginning-of-line)) 3955 (beginning-of-line))
3956 (setq pp nil)) 3956 (setq pp nil))
3957 ;; Now after the sexp before the brace 3957 ;; Now after the sexp before the brace
3958 ;; Multiline expr should be special 3958 ;; Multiline expr should be special
3959 (setq ml (and pp (save-excursion (goto-char p) 3959 (setq ml (and pp (save-excursion (goto-char p)
3960 (search-forward "\n" pp t)))) 3960 (search-forward "\n" pp t))))
3961 (if (and (or (not pp) (< pp end)) 3961 (if (and (or (not pp) (< pp end))
3962 (looking-at "[ \t\n]*{")) 3962 (looking-at "[ \t\n]*{"))
3963 (progn 3963 (progn
3964 (cond 3964 (cond
3965 ((bolp) ; Were before `{', no if/else/etc 3965 ((bolp) ; Were before `{', no if/else/etc
3966 nil) 3966 nil)
3967 ((looking-at "\\(\t*\\| [ \t]+\\){") 3967 ((looking-at "\\(\t*\\| [ \t]+\\){")
3968 (delete-horizontal-space) 3968 (delete-horizontal-space)
3969 (if (if ml 3969 (if (if ml
3970 cperl-extra-newline-before-brace-multiline 3970 cperl-extra-newline-before-brace-multiline
3971 cperl-extra-newline-before-brace) 3971 cperl-extra-newline-before-brace)
3972 (progn 3972 (progn
3973 (delete-horizontal-space) 3973 (delete-horizontal-space)
3974 (insert "\n") 3974 (insert "\n")
3975 (setq ret (point)) 3975 (setq ret (point))
3976 (if (cperl-indent-line parse-data) 3976 (if (cperl-indent-line parse-data)
3977 (progn 3977 (progn
3978 (cperl-fix-line-spacing end parse-data) 3978 (cperl-fix-line-spacing end parse-data)
3979 (setq ret (point))))) 3979 (setq ret (point)))))
3980 (insert
3981 (make-string cperl-indent-region-fix-constructs ?\ ))))
3982 ((and (looking-at "[ \t]*\n")
3983 (not (if ml
3984 cperl-extra-newline-before-brace-multiline
3985 cperl-extra-newline-before-brace)))
3986 (setq pp (point))
3987 (skip-chars-forward " \t\n")
3988 (delete-region pp (point))
3980 (insert 3989 (insert
3981 (make-string cperl-indent-region-fix-constructs ?\ )))) 3990 (make-string cperl-indent-region-fix-constructs ?\ ))))
3982 ((and (looking-at "[ \t]*\n") 3991 ;; Now we are before `{'
3983 (not (if ml 3992 (if (looking-at "[ \t\n]*{[ \t]*[^ \t\n#]")
3984 cperl-extra-newline-before-brace-multiline 3993 (progn
3985 cperl-extra-newline-before-brace))) 3994 (skip-chars-forward " \t\n")
3986 (setq pp (point)) 3995 (setq pp (point))
3987 (skip-chars-forward " \t\n") 3996 (forward-sexp 1)
3988 (delete-region pp (point)) 3997 (setq p (point))
3989 (insert 3998 (goto-char pp)
3990 (make-string cperl-indent-region-fix-constructs ?\ )))) 3999 (setq ml (search-forward "\n" p t))
3991 ;; Now we are before `{' 4000 (if (or cperl-break-one-line-blocks-when-indent ml)
3992 (if (looking-at "[ \t\n]*{[ \t]*[^ \t\n#]") 4001 ;; not good: multi-line BLOCK
3993 (progn 4002 (progn
3994 (skip-chars-forward " \t\n") 4003 (goto-char (1+ pp))
3995 (setq pp (point)) 4004 (delete-horizontal-space)
3996 (forward-sexp 1) 4005 (insert "\n")
3997 (setq p (point)) 4006 (setq ret (point))
3998 (goto-char pp) 4007 (if (cperl-indent-line parse-data)
3999 (setq ml (search-forward "\n" p t)) 4008 (setq ret (cperl-fix-line-spacing end parse-data)))))))))))
4000 (if (or cperl-break-one-line-blocks-when-indent ml) 4009 (beginning-of-line)
4001 ;; not good: multi-line BLOCK 4010 (setq p (point) pp (save-excursion (end-of-line) (point))) ; May be different from ee.
4002 (progn 4011 ;; Now check whether there is a hanging `}'
4003 (goto-char (1+ pp)) 4012 ;; Looking at:
4004 (delete-horizontal-space) 4013 ;; } blah
4005 (insert "\n") 4014 (if (and
4006 (setq ret (point)) 4015 cperl-fix-hanging-brace-when-indent
4007 (if (cperl-indent-line parse-data) 4016 have-brace
4008 (setq ret (cperl-fix-line-spacing end parse-data))))))))))) 4017 (not (looking-at "[ \t]*}[ \t]*\\(\\<\\(els\\(if\\|e\\)\\|continue\\|while\\|until\\)\\>\\|$\\|#\\)"))
4009 (beginning-of-line) 4018 (condition-case nil
4010 (setq p (point) pp (save-excursion (end-of-line) (point))) ; May be different from ee. 4019 (progn
4011 ;; Now check whether there is a hanging `}' 4020 (up-list 1)
4012 ;; Looking at: 4021 (if (and (<= (point) pp)
4013 ;; } blah 4022 (eq (preceding-char) ?\} )
4014 (if (and 4023 (cperl-after-block-and-statement-beg (point-min)))
4015 cperl-fix-hanging-brace-when-indent 4024 t
4016 have-brace 4025 (goto-char p)
4017 (not (looking-at "[ \t]*}[ \t]*\\(\\<\\(els\\(if\\|e\\)\\|continue\\|while\\|until\\)\\>\\|$\\|#\\)")) 4026 nil))
4018 (condition-case nil 4027 (error nil)))
4019 (progn 4028 (progn
4020 (up-list 1) 4029 (forward-char -1)
4021 (if (and (<= (point) pp) 4030 (skip-chars-backward " \t")
4022 (eq (preceding-char) ?\} ) 4031 (if (bolp)
4023 (cperl-after-block-and-statement-beg (point-min))) 4032 ;; `}' was the first thing on the line, insert NL *after* it.
4024 t 4033 (progn
4025 (goto-char p) 4034 (cperl-indent-line parse-data)
4026 nil)) 4035 (search-forward "}")
4027 (error nil))) 4036 (delete-horizontal-space)
4028 (progn 4037 (insert "\n"))
4029 (forward-char -1) 4038 (delete-horizontal-space)
4030 (skip-chars-backward " \t") 4039 (or (eq (preceding-char) ?\;)
4031 (if (bolp) 4040 (bolp)
4032 ;; `}' was the first thing on the line, insert NL *after* it. 4041 (and (eq (preceding-char) ?\} )
4033 (progn 4042 (cperl-after-block-p (point-min)))
4034 (cperl-indent-line parse-data) 4043 (insert ";"))
4035 (search-forward "}") 4044 (insert "\n")
4036 (delete-horizontal-space) 4045 (setq ret (point)))
4037 (insert "\n")) 4046 (if (cperl-indent-line parse-data)
4038 (delete-horizontal-space) 4047 (setq ret (cperl-fix-line-spacing end parse-data)))
4039 (or (eq (preceding-char) ?\;) 4048 (beginning-of-line)))))
4040 (bolp)
4041 (and (eq (preceding-char) ?\} )
4042 (cperl-after-block-p (point-min)))
4043 (insert ";"))
4044 (insert "\n")
4045 (setq ret (point)))
4046 (if (cperl-indent-line parse-data)
4047 (setq ret (cperl-fix-line-spacing end parse-data)))
4048 (beginning-of-line)))))
4049 ret)) 4049 ret))
4050 4050
4051(defvar cperl-update-start) ; Do not need to make them local 4051(defvar cperl-update-start) ; Do not need to make them local
@@ -4067,32 +4067,32 @@ conditional/loop constructs."
4067 (cperl-update-syntaxification end end) 4067 (cperl-update-syntaxification end end)
4068 (save-excursion 4068 (save-excursion
4069 (let (cperl-update-start cperl-update-end (h-a-c after-change-functions)) 4069 (let (cperl-update-start cperl-update-end (h-a-c after-change-functions))
4070 (let (st comm old-comm-indent new-comm-indent p pp i empty 4070 (let ((indent-info (if cperl-emacs-can-parse
4071 (indent-info (if cperl-emacs-can-parse 4071 (list nil nil nil) ; Cannot use '(), since will modify
4072 (list nil nil nil) ; Cannot use '(), since will modify 4072 nil))
4073 nil)) 4073 (pm 0) (imenu-scanning-message "Indenting... (%3d%%)")
4074 after-change-functions ; Speed it up! 4074 after-change-functions ; Speed it up!
4075 (pm 0) (imenu-scanning-message "Indenting... (%3d%%)")) 4075 st comm old-comm-indent new-comm-indent p pp i empty)
4076 (if h-a-c (add-hook 'after-change-functions 'cperl-delay-update-hook)) 4076 (if h-a-c (add-hook 'after-change-functions 'cperl-delay-update-hook))
4077 (goto-char start) 4077 (goto-char start)
4078 (setq old-comm-indent (and (cperl-to-comment-or-eol) 4078 (setq old-comm-indent (and (cperl-to-comment-or-eol)
4079 (current-column)) 4079 (current-column))
4080 new-comm-indent old-comm-indent) 4080 new-comm-indent old-comm-indent)
4081 (goto-char start) 4081 (goto-char start)
4082 (setq end (set-marker (make-marker) end)) ; indentation changes pos 4082 (setq end (set-marker (make-marker) end)) ; indentation changes pos
4083 (or (bolp) (beginning-of-line 2)) 4083 (or (bolp) (beginning-of-line 2))
4084 (or (fboundp 'imenu-progress-message) 4084 (or (fboundp 'imenu-progress-message)
4085 (message "Indenting... For feedback load `imenu'...")) 4085 (message "Indenting... For feedback load `imenu'..."))
4086 (while (and (<= (point) end) (not (eobp))) ; bol to check start 4086 (while (and (<= (point) end) (not (eobp))) ; bol to check start
4087 (and (fboundp 'imenu-progress-message) 4087 (and (fboundp 'imenu-progress-message)
4088 (imenu-progress-message 4088 (imenu-progress-message
4089 pm (/ (* 100 (- (point) start)) (- end start -1)))) 4089 pm (/ (* 100 (- (point) start)) (- end start -1))))
4090 (setq st (point)) 4090 (setq st (point))
4091 (if (or 4091 (if (or
4092 (setq empty (looking-at "[ \t]*\n")) 4092 (setq empty (looking-at "[ \t]*\n"))
4093 (and (setq comm (looking-at "[ \t]*#")) 4093 (and (setq comm (looking-at "[ \t]*#"))
4094 (or (eq (current-indentation) (or old-comm-indent 4094 (or (eq (current-indentation) (or old-comm-indent
4095 comment-column)) 4095 comment-column))
4096 (setq old-comm-indent nil)))) 4096 (setq old-comm-indent nil))))
4097 (if (and old-comm-indent 4097 (if (and old-comm-indent
4098 (not empty) 4098 (not empty)
@@ -4100,20 +4100,20 @@ conditional/loop constructs."
4100 (not (eq (get-text-property (point) 'syntax-type) 'pod)) 4100 (not (eq (get-text-property (point) 'syntax-type) 'pod))
4101 (not (eq (get-text-property (point) 'syntax-table) 4101 (not (eq (get-text-property (point) 'syntax-table)
4102 cperl-st-cfence))) 4102 cperl-st-cfence)))
4103 (let ((comment-column new-comm-indent)) 4103 (let ((comment-column new-comm-indent))
4104 (indent-for-comment))) 4104 (indent-for-comment)))
4105 (progn 4105 (progn
4106 (setq i (cperl-indent-line indent-info)) 4106 (setq i (cperl-indent-line indent-info))
4107 (or comm 4107 (or comm
4108 (not i) 4108 (not i)
4109 (progn 4109 (progn
4110 (if cperl-indent-region-fix-constructs 4110 (if cperl-indent-region-fix-constructs
4111 (goto-char (cperl-fix-line-spacing end indent-info))) 4111 (goto-char (cperl-fix-line-spacing end indent-info)))
4112 (if (setq old-comm-indent 4112 (if (setq old-comm-indent
4113 (and (cperl-to-comment-or-eol) 4113 (and (cperl-to-comment-or-eol)
4114 (not (memq (get-text-property (point) 4114 (not (memq (get-text-property (point)
4115 'syntax-type) 4115 'syntax-type)
4116 '(pod here-doc))) 4116 '(pod here-doc)))
4117 (not (eq (get-text-property (point) 4117 (not (eq (get-text-property (point)
4118 'syntax-table) 4118 'syntax-table)
4119 cperl-st-cfence)) 4119 cperl-st-cfence))
@@ -4127,16 +4127,15 @@ conditional/loop constructs."
4127 (imenu-progress-message pm 100) 4127 (imenu-progress-message pm 100)
4128 (message nil))) 4128 (message nil)))
4129 ;; Now run the update hooks 4129 ;; Now run the update hooks
4130 (if after-change-functions 4130 (and after-change-functions
4131 (save-excursion 4131 cperl-update-end
4132 (if cperl-update-end 4132 (save-excursion
4133 (progn 4133 (goto-char cperl-update-end)
4134 (goto-char cperl-update-end) 4134 (insert " ")
4135 (insert " ") 4135 (delete-char -1)
4136 (delete-char -1) 4136 (goto-char cperl-update-start)
4137 (goto-char cperl-update-start) 4137 (insert " ")
4138 (insert " ") 4138 (delete-char -1))))))
4139 (delete-char -1))))))))
4140 4139
4141;; Stolen from lisp-mode with a lot of improvements 4140;; Stolen from lisp-mode with a lot of improvements
4142 4141
@@ -4146,8 +4145,7 @@ If any of the current line is a comment, fill the comment or the
4146block of it that point is in, preserving the comment's initial 4145block of it that point is in, preserving the comment's initial
4147indentation and initial hashes. Behaves usually outside of comment." 4146indentation and initial hashes. Behaves usually outside of comment."
4148 (interactive "P") 4147 (interactive "P")
4149 (let ( 4148 (let (;; Non-nil if the current line contains a comment.
4150 ;; Non-nil if the current line contains a comment.
4151 has-comment 4149 has-comment
4152 4150
4153 ;; If has-comment, the appropriate fill-prefix for the comment. 4151 ;; If has-comment, the appropriate fill-prefix for the comment.
@@ -4183,7 +4181,7 @@ indentation and initial hashes. Behaves usually outside of comment."
4183 (delete-char len) 4181 (delete-char len)
4184 (insert (make-string dc ?-))))) 4182 (insert (make-string dc ?-)))))
4185 (if (not has-comment) 4183 (if (not has-comment)
4186 (fill-paragraph justify) ; Do the usual thing outside of comment 4184 (fill-paragraph justify) ; Do the usual thing outside of comment
4187 ;; Narrow to include only the comment, and then fill the region. 4185 ;; Narrow to include only the comment, and then fill the region.
4188 (save-restriction 4186 (save-restriction
4189 (narrow-to-region 4187 (narrow-to-region
@@ -4217,7 +4215,7 @@ indentation and initial hashes. Behaves usually outside of comment."
4217 (progn 4215 (progn
4218 (goto-char start) 4216 (goto-char start)
4219 (if (> dc 0) 4217 (if (> dc 0)
4220 (progn (delete-char dc) (insert spaces))) 4218 (progn (delete-char dc) (insert spaces)))
4221 (if (or (= (current-column) c) iteration) nil 4219 (if (or (= (current-column) c) iteration) nil
4222 (setq comment-column c) 4220 (setq comment-column c)
4223 (indent-for-comment) 4221 (indent-for-comment)
@@ -4230,22 +4228,22 @@ indentation and initial hashes. Behaves usually outside of comment."
4230 (end-of-line) 4228 (end-of-line)
4231 (current-column)) 4229 (current-column))
4232 fill-column) 4230 fill-column)
4233 (let ((c (save-excursion (beginning-of-line) 4231 (let ((c (save-excursion (beginning-of-line)
4234 (cperl-to-comment-or-eol) (point))) 4232 (cperl-to-comment-or-eol) (point)))
4235 (s (memq (following-char) '(?\ ?\t))) marker) 4233 (s (memq (following-char) '(?\ ?\t))) marker)
4236 (if (>= c (point)) nil 4234 (if (>= c (point)) nil
4237 (setq marker (point-marker)) 4235 (setq marker (point-marker))
4238 (cperl-fill-paragraph) 4236 (cperl-fill-paragraph)
4239 (goto-char marker) 4237 (goto-char marker)
4240 ;; Is not enough, sometimes marker is a start of line 4238 ;; Is not enough, sometimes marker is a start of line
4241 (if (bolp) (progn (re-search-forward "#+[ \t]*") 4239 (if (bolp) (progn (re-search-forward "#+[ \t]*")
4242 (goto-char (match-end 0)))) 4240 (goto-char (match-end 0))))
4243 ;; Following space could have gone: 4241 ;; Following space could have gone:
4244 (if (or (not s) (memq (following-char) '(?\ ?\t))) nil 4242 (if (or (not s) (memq (following-char) '(?\ ?\t))) nil
4245 (insert " ") 4243 (insert " ")
4246 (backward-char 1)) 4244 (backward-char 1))
4247 ;; Previous space could have gone: 4245 ;; Previous space could have gone:
4248 (or (memq (preceding-char) '(?\ ?\t)) (insert " ")))))) 4246 (or (memq (preceding-char) '(?\ ?\t)) (insert " "))))))
4249 4247
4250(defun cperl-imenu-addback (lst &optional isback name) 4248(defun cperl-imenu-addback (lst &optional isback name)
4251 ;; We suppose that the lst is a DAG, unless the first element only 4249 ;; We suppose that the lst is a DAG, unless the first element only
@@ -4255,15 +4253,14 @@ indentation and initial hashes. Behaves usually outside of comment."
4255 (t 4253 (t
4256 (or name 4254 (or name
4257 (setq name "+++BACK+++")) 4255 (setq name "+++BACK+++"))
4258 (mapcar (function (lambda (elt) 4256 (mapcar (lambda (elt)
4259 (if (and (listp elt) (listp (cdr elt))) 4257 (if (and (listp elt) (listp (cdr elt)))
4260 (progn 4258 (progn
4261 ;; In the other order it goes up 4259 ;; In the other order it goes up
4262 ;; one level only ;-( 4260 ;; one level only ;-(
4263 (setcdr elt (cons (cons name lst) 4261 (setcdr elt (cons (cons name lst)
4264 (cdr elt))) 4262 (cdr elt)))
4265 (cperl-imenu-addback (cdr elt) t name) 4263 (cperl-imenu-addback (cdr elt) t name))))
4266 ))))
4267 (if isback (cdr lst) lst)) 4264 (if isback (cdr lst) lst))
4268 lst))) 4265 lst)))
4269 4266
@@ -4291,7 +4288,7 @@ indentation and initial hashes. Behaves usually outside of comment."
4291 (match-beginning 2) ; package or sub 4288 (match-beginning 2) ; package or sub
4292 (eq (char-after (match-beginning 2)) ?p) ; package 4289 (eq (char-after (match-beginning 2)) ?p) ; package
4293 (not (save-match-data 4290 (not (save-match-data
4294 (looking-at "[ \t\n]*;")))) ; Plain text word 'package' 4291 (looking-at "[ \t\n]*;")))) ; Plain text word 'package'
4295 nil) 4292 nil)
4296 ((and 4293 ((and
4297 (match-beginning 2) ; package or sub 4294 (match-beginning 2) ; package or sub
@@ -4301,8 +4298,7 @@ indentation and initial hashes. Behaves usually outside of comment."
4301 (null (get-text-property (match-beginning 1) 'in-pod))) 4298 (null (get-text-property (match-beginning 1) 'in-pod)))
4302 (save-excursion 4299 (save-excursion
4303 (goto-char (match-beginning 2)) 4300 (goto-char (match-beginning 2))
4304 (setq fchar (following-char)) 4301 (setq fchar (following-char)))
4305 )
4306 ;; (if (looking-at "([^()]*)[ \t\n\f]*") 4302 ;; (if (looking-at "([^()]*)[ \t\n\f]*")
4307 ;; (goto-char (match-end 0))) ; Messes what follows 4303 ;; (goto-char (match-end 0))) ; Messes what follows
4308 (setq char (following-char) ; ?\; for "sub foo () ;" 4304 (setq char (following-char) ; ?\; for "sub foo () ;"
@@ -4345,7 +4341,7 @@ indentation and initial hashes. Behaves usually outside of comment."
4345 (push index index-alist)) 4341 (push index index-alist))
4346 (if meth (push index index-meth-alist)) 4342 (if meth (push index index-meth-alist))
4347 (push index index-unsorted-alist))) 4343 (push index index-unsorted-alist)))
4348 ((match-beginning 5) ; Pod section 4344 ((match-beginning 5) ; POD section
4349 ;; (beginning-of-line) 4345 ;; (beginning-of-line)
4350 (setq index (imenu-example--name-and-position) 4346 (setq index (imenu-example--name-and-position)
4351 name (buffer-substring (match-beginning 6) (match-end 6))) 4347 name (buffer-substring (match-beginning 6) (match-end 6)))
@@ -4361,7 +4357,7 @@ indentation and initial hashes. Behaves usually outside of comment."
4361 (setq index-alist 4357 (setq index-alist
4362 (if (default-value 'imenu-sort-function) 4358 (if (default-value 'imenu-sort-function)
4363 (sort index-alist (default-value 'imenu-sort-function)) 4359 (sort index-alist (default-value 'imenu-sort-function))
4364 (nreverse index-alist))) 4360 (nreverse index-alist)))
4365 (and index-pod-alist 4361 (and index-pod-alist
4366 (push (cons "+POD headers+..." 4362 (push (cons "+POD headers+..."
4367 (nreverse index-pod-alist)) 4363 (nreverse index-pod-alist))
@@ -4437,9 +4433,9 @@ indentation and initial hashes. Behaves usually outside of comment."
4437 4433
4438(if (fboundp 'eval-after-load) 4434(if (fboundp 'eval-after-load)
4439 (eval-after-load 4435 (eval-after-load
4440 "mode-compile" 4436 "mode-compile"
4441 '(setq perl-compilation-error-regexp-alist 4437 '(setq perl-compilation-error-regexp-alist
4442 cperl-compilation-error-regexp-alist))) 4438 cperl-compilation-error-regexp-alist)))
4443 4439
4444 4440
4445(defun cperl-windowed-init () 4441(defun cperl-windowed-init ()
@@ -4455,8 +4451,8 @@ indentation and initial hashes. Behaves usually outside of comment."
4455 (or cperl-faces-init (cperl-init-faces))))))) 4451 (or cperl-faces-init (cperl-init-faces)))))))
4456 (if (fboundp 'eval-after-load) 4452 (if (fboundp 'eval-after-load)
4457 (eval-after-load 4453 (eval-after-load
4458 "ps-print" 4454 "ps-print"
4459 '(or cperl-faces-init (cperl-init-faces)))))) 4455 '(or cperl-faces-init (cperl-init-faces))))))
4460 4456
4461(defvar cperl-font-lock-keywords-1 nil 4457(defvar cperl-font-lock-keywords-1 nil
4462 "Additional expressions to highlight in Perl mode. Minimal set.") 4458 "Additional expressions to highlight in Perl mode. Minimal set.")
@@ -4633,7 +4629,7 @@ indentation and initial hashes. Behaves usually outside of comment."
4633 '("[\[ \t{,(]\\(-?[a-zA-Z0-9_:]+\\)[ \t]*=>" 1 4629 '("[\[ \t{,(]\\(-?[a-zA-Z0-9_:]+\\)[ \t]*=>" 1
4634 font-lock-string-face t) 4630 font-lock-string-face t)
4635 '("^[ \t]*\\([a-zA-Z0-9_]+[ \t]*:\\)[ \t]*\\($\\|{\\|\\<\\(until\\|while\\|for\\(each\\)?\\|do\\)\\>\\)" 1 4631 '("^[ \t]*\\([a-zA-Z0-9_]+[ \t]*:\\)[ \t]*\\($\\|{\\|\\<\\(until\\|while\\|for\\(each\\)?\\|do\\)\\>\\)" 1
4636 font-lock-constant-face) ; labels 4632 font-lock-constant-face) ; labels
4637 '("\\<\\(continue\\|next\\|last\\|redo\\|goto\\)\\>[ \t]+\\([a-zA-Z0-9_:]+\\)" ; labels as targets 4633 '("\\<\\(continue\\|next\\|last\\|redo\\|goto\\)\\>[ \t]+\\([a-zA-Z0-9_:]+\\)" ; labels as targets
4638 2 font-lock-constant-face) 4634 2 font-lock-constant-face)
4639 ;; Uncomment to get perl-mode-like vars 4635 ;; Uncomment to get perl-mode-like vars
@@ -4661,7 +4657,7 @@ indentation and initial hashes. Behaves usually outside of comment."
4661 (setq 4657 (setq
4662 t-font-lock-keywords-1 4658 t-font-lock-keywords-1
4663 (and (fboundp 'turn-on-font-lock) ; Check for newer font-lock 4659 (and (fboundp 'turn-on-font-lock) ; Check for newer font-lock
4664 (not cperl-xemacs-p) ; not yet as of XEmacs 19.12 4660 (not cperl-xemacs-p) ; not yet as of XEmacs 19.12
4665 '( 4661 '(
4666 ("\\(\\([@%]\\|\$#\\)[a-zA-Z_:][a-zA-Z0-9_:]*\\)" 1 4662 ("\\(\\([@%]\\|\$#\\)[a-zA-Z_:][a-zA-Z0-9_:]*\\)" 1
4667 (if (eq (char-after (match-beginning 2)) ?%) 4663 (if (eq (char-after (match-beginning 2)) ?%)
@@ -4701,85 +4697,82 @@ indentation and initial hashes. Behaves usually outside of comment."
4701 (if (fboundp 'ps-print-buffer) (cperl-ps-print-init)) 4697 (if (fboundp 'ps-print-buffer) (cperl-ps-print-init))
4702 (if (or (featurep 'choose-color) (featurep 'font-lock-extra)) 4698 (if (or (featurep 'choose-color) (featurep 'font-lock-extra))
4703 (eval ; Avoid a warning 4699 (eval ; Avoid a warning
4704 '(font-lock-require-faces 4700 '(font-lock-require-faces
4705 (list 4701 (list
4706 ;; Color-light Color-dark Gray-light Gray-dark Mono 4702 ;; Color-light Color-dark Gray-light Gray-dark Mono
4707 (list 'font-lock-comment-face 4703 (list 'font-lock-comment-face
4708 ["Firebrick" "OrangeRed" "DimGray" "Gray80"] 4704 ["Firebrick" "OrangeRed" "DimGray" "Gray80"]
4709 nil 4705 nil
4710 [nil nil t t t] 4706 [nil nil t t t]
4711 [nil nil t t t] 4707 [nil nil t t t]
4712 nil) 4708 nil)
4713 (list 'font-lock-string-face 4709 (list 'font-lock-string-face
4714 ["RosyBrown" "LightSalmon" "Gray50" "LightGray"] 4710 ["RosyBrown" "LightSalmon" "Gray50" "LightGray"]
4715 nil 4711 nil
4716 nil 4712 nil
4717 [nil nil t t t] 4713 [nil nil t t t]
4718 nil) 4714 nil)
4719 (list 'font-lock-function-name-face 4715 (list 'font-lock-function-name-face
4720 (vector 4716 (vector
4721 "Blue" "LightSkyBlue" "Gray50" "LightGray" 4717 "Blue" "LightSkyBlue" "Gray50" "LightGray"
4722 (cdr (assq 'background-color ; if mono 4718 (cdr (assq 'background-color ; if mono
4723 (frame-parameters)))) 4719 (frame-parameters))))
4724 (vector 4720 (vector
4725 nil nil nil nil 4721 nil nil nil nil
4726 (cdr (assq 'foreground-color ; if mono 4722 (cdr (assq 'foreground-color ; if mono
4727 (frame-parameters)))) 4723 (frame-parameters))))
4728 [nil nil t t t] 4724 [nil nil t t t]
4729 nil 4725 nil
4730 nil) 4726 nil)
4731 (list 'font-lock-variable-name-face 4727 (list 'font-lock-variable-name-face
4732 ["DarkGoldenrod" "LightGoldenrod" "DimGray" "Gray90"] 4728 ["DarkGoldenrod" "LightGoldenrod" "DimGray" "Gray90"]
4733 nil 4729 nil
4734 [nil nil t t t] 4730 [nil nil t t t]
4735 [nil nil t t t] 4731 [nil nil t t t]
4736 nil) 4732 nil)
4737 (list 'font-lock-type-face 4733 (list 'font-lock-type-face
4738 ["DarkOliveGreen" "PaleGreen" "DimGray" "Gray80"] 4734 ["DarkOliveGreen" "PaleGreen" "DimGray" "Gray80"]
4739 nil 4735 nil
4740 [nil nil t t t] 4736 [nil nil t t t]
4741 nil 4737 nil
4742 [nil nil t t t] 4738 [nil nil t t t])
4743 ) 4739 (list 'font-lock-constant-face
4744 (list 'font-lock-constant-face 4740 ["CadetBlue" "Aquamarine" "Gray50" "LightGray"]
4745 ["CadetBlue" "Aquamarine" "Gray50" "LightGray"] 4741 nil
4746 nil 4742 [nil nil t t t]
4747 [nil nil t t t] 4743 nil
4748 nil 4744 [nil nil t t t])
4749 [nil nil t t t] 4745 (list 'cperl-nonoverridable-face
4750 ) 4746 ["chartreuse3" ("orchid1" "orange")
4751 (list 'cperl-nonoverridable-face 4747 nil "Gray80"]
4752 ["chartreuse3" ("orchid1" "orange") 4748 [nil nil "gray90"]
4753 nil "Gray80"] 4749 [nil nil nil t t]
4754 [nil nil "gray90"] 4750 [nil nil t t]
4755 [nil nil nil t t] 4751 [nil nil t t t])
4756 [nil nil t t] 4752 (list 'cperl-array-face
4757 [nil nil t t t] 4753 ["blue" "yellow" nil "Gray80"]
4758 ) 4754 ["lightyellow2" ("navy" "os2blue" "darkgreen")
4759 (list 'cperl-array-face 4755 "gray90"]
4760 ["blue" "yellow" nil "Gray80"] 4756 t
4761 ["lightyellow2" ("navy" "os2blue" "darkgreen") 4757 nil
4762 "gray90"] 4758 nil)
4763 t 4759 (list 'cperl-hash-face
4764 nil 4760 ["red" "red" nil "Gray80"]
4765 nil) 4761 ["lightyellow2" ("navy" "os2blue" "darkgreen")
4766 (list 'cperl-hash-face 4762 "gray90"]
4767 ["red" "red" nil "Gray80"] 4763 t
4768 ["lightyellow2" ("navy" "os2blue" "darkgreen") 4764 t
4769 "gray90"] 4765 nil))))
4770 t
4771 t
4772 nil))))
4773 ;; Do it the dull way, without choose-color 4766 ;; Do it the dull way, without choose-color
4774 (defvar cperl-guessed-background nil 4767 (defvar cperl-guessed-background nil
4775 "Display characteristics as guessed by cperl.") 4768 "Display characteristics as guessed by cperl.")
4776;; (or (fboundp 'x-color-defined-p) 4769 ;; (or (fboundp 'x-color-defined-p)
4777;; (defalias 'x-color-defined-p 4770 ;; (defalias 'x-color-defined-p
4778;; (cond ((fboundp 'color-defined-p) 'color-defined-p) 4771 ;; (cond ((fboundp 'color-defined-p) 'color-defined-p)
4779;; ;; XEmacs >= 19.12 4772 ;; ;; XEmacs >= 19.12
4780;; ((fboundp 'valid-color-name-p) 'valid-color-name-p) 4773 ;; ((fboundp 'valid-color-name-p) 'valid-color-name-p)
4781;; ;; XEmacs 19.11 4774 ;; ;; XEmacs 19.11
4782;; (t 'x-valid-color-name-p)))) 4775 ;; (t 'x-valid-color-name-p))))
4783 (cperl-force-face font-lock-constant-face 4776 (cperl-force-face font-lock-constant-face
4784 "Face for constant and label names") 4777 "Face for constant and label names")
4785 (cperl-force-face font-lock-variable-name-face 4778 (cperl-force-face font-lock-variable-name-face
@@ -4846,9 +4839,7 @@ indentation and initial hashes. Behaves usually outside of comment."
4846 (if (boundp 'font-lock-background-mode) 4839 (if (boundp 'font-lock-background-mode)
4847 font-lock-background-mode 4840 font-lock-background-mode
4848 'light)) 4841 'light))
4849 (face-list (and (fboundp 'face-list) (face-list))) 4842 (face-list (and (fboundp 'face-list) (face-list))))
4850 ;; cperl-is-face
4851 )
4852;;;; (fset 'cperl-is-face 4843;;;; (fset 'cperl-is-face
4853;;;; (cond ((fboundp 'find-face) 4844;;;; (cond ((fboundp 'find-face)
4854;;;; (symbol-function 'find-face)) 4845;;;; (symbol-function 'find-face))
@@ -4862,10 +4853,9 @@ indentation and initial hashes. Behaves usually outside of comment."
4862 'gray 4853 'gray
4863 background) 4854 background)
4864 "Background as guessed by CPerl mode") 4855 "Background as guessed by CPerl mode")
4865 (if (and 4856 (and (not (cperl-is-face 'font-lock-constant-face))
4866 (not (cperl-is-face 'font-lock-constant-face)) 4857 (cperl-is-face 'font-lock-reference-face)
4867 (cperl-is-face 'font-lock-reference-face)) 4858 (copy-face 'font-lock-reference-face 'font-lock-constant-face))
4868 (copy-face 'font-lock-reference-face 'font-lock-constant-face))
4869 (if (cperl-is-face 'font-lock-type-face) nil 4859 (if (cperl-is-face 'font-lock-type-face) nil
4870 (copy-face 'default 'font-lock-type-face) 4860 (copy-face 'default 'font-lock-type-face)
4871 (cond 4861 (cond
@@ -5023,7 +5013,7 @@ Style of printout regulated by the variable `cperl-ps-print-face-properties'."
5023 cperl-continued-statement-offset)) 5013 cperl-continued-statement-offset))
5024 5014
5025(defconst cperl-style-alist 5015(defconst cperl-style-alist
5026 '(("CPerl" ; =GNU without extra-newline-before-brace 5016 '(("CPerl" ; =GNU without extra-newline-before-brace
5027 (cperl-indent-level . 2) 5017 (cperl-indent-level . 2)
5028 (cperl-brace-offset . 0) 5018 (cperl-brace-offset . 0)
5029 (cperl-continued-brace-offset . 0) 5019 (cperl-continued-brace-offset . 0)
@@ -5031,7 +5021,7 @@ Style of printout regulated by the variable `cperl-ps-print-face-properties'."
5031 (cperl-extra-newline-before-brace . nil) 5021 (cperl-extra-newline-before-brace . nil)
5032 (cperl-merge-trailing-else . t) 5022 (cperl-merge-trailing-else . t)
5033 (cperl-continued-statement-offset . 2)) 5023 (cperl-continued-statement-offset . 2))
5034 ("PerlStyle" ; CPerl with 4 as indent 5024 ("PerlStyle" ; CPerl with 4 as indent
5035 (cperl-indent-level . 4) 5025 (cperl-indent-level . 4)
5036 (cperl-brace-offset . 0) 5026 (cperl-brace-offset . 0)
5037 (cperl-continued-brace-offset . 0) 5027 (cperl-continued-brace-offset . 0)
@@ -5093,7 +5083,7 @@ data already), may be restored by `cperl-set-style-back'.
5093Chosing \"Current\" style will not change style, so this may be used for 5083Chosing \"Current\" style will not change style, so this may be used for
5094side-effect of memorizing only." 5084side-effect of memorizing only."
5095 (interactive 5085 (interactive
5096 (let ((list (mapcar (function (lambda (elt) (list (car elt)))) 5086 (let ((list (mapcar (function (lambda (elt) (list (car elt))))
5097 cperl-style-alist))) 5087 cperl-style-alist)))
5098 (list (completing-read "Enter style: " list nil 'insist)))) 5088 (list (completing-read "Enter style: " list nil 'insist))))
5099 (or cperl-old-style 5089 (or cperl-old-style
@@ -5172,11 +5162,11 @@ Customized by setting variables `cperl-shrink-wrap-info-frame',
5172 (interactive 5162 (interactive
5173 (let* ((default (cperl-word-at-point)) 5163 (let* ((default (cperl-word-at-point))
5174 (read (read-string 5164 (read (read-string
5175 (format "Find doc for Perl function (default %s): " 5165 (format "Find doc for Perl function (default %s): "
5176 default)))) 5166 default))))
5177 (list (if (equal read "") 5167 (list (if (equal read "")
5178 default 5168 default
5179 read)))) 5169 read))))
5180 5170
5181 (let ((buffer (current-buffer)) 5171 (let ((buffer (current-buffer))
5182 (cmd-desc (concat "^" (regexp-quote command) "[^a-zA-Z_0-9]")) ; "tr///" 5172 (cmd-desc (concat "^" (regexp-quote command) "[^a-zA-Z_0-9]")) ; "tr///"
@@ -5235,8 +5225,7 @@ Customized by setting variables `cperl-shrink-wrap-info-frame',
5235 ;; Non-functioning under OS/2: 5225 ;; Non-functioning under OS/2:
5236 (if (eq char-height 1) (setq char-height 18)) 5226 (if (eq char-height 1) (setq char-height 18))
5237 ;; Title, menubar, + 2 for slack 5227 ;; Title, menubar, + 2 for slack
5238 (- (/ (x-display-pixel-height) char-height) 4) 5228 (- (/ (x-display-pixel-height) char-height) 4)))
5239 ))
5240 (if (> height max-height) (setq height max-height)) 5229 (if (> height max-height) (setq height max-height))
5241 ;;(message "was %s doing %s" iniheight height) 5230 ;;(message "was %s doing %s" iniheight height)
5242 (if not-loner 5231 (if not-loner
@@ -5343,7 +5332,7 @@ Will not move the position at the start to the left."
5343 (setq e (point)) 5332 (setq e (point))
5344 (skip-chars-backward " \t") 5333 (skip-chars-backward " \t")
5345 (delete-region (point) e) 5334 (delete-region (point) e)
5346 (indent-to-column col); (make-string (- col (current-column)) ?\ )) 5335 (indent-to-column col) ;(make-string (- col (current-column)) ?\ ))
5347 (beginning-of-line 2) 5336 (beginning-of-line 2)
5348 (and (< (point) end) 5337 (and (< (point) end)
5349 (re-search-forward search end t) 5338 (re-search-forward search end t)
@@ -5458,7 +5447,7 @@ See `cperl-lazy-help-time' too."
5458 (or noninteractive 5447 (or noninteractive
5459 (imenu-progress-message prev-pos)) 5448 (imenu-progress-message prev-pos))
5460 (cond 5449 (cond
5461 ((match-beginning 2) ; SECTION 5450 ((match-beginning 2) ; SECTION
5462 (setq package (buffer-substring (match-beginning 2) (match-end 2))) 5451 (setq package (buffer-substring (match-beginning 2) (match-end 2)))
5463 (goto-char (match-beginning 0)) 5452 (goto-char (match-beginning 0))
5464 (skip-chars-forward " \t") 5453 (skip-chars-forward " \t")
@@ -5491,11 +5480,11 @@ See `cperl-lazy-help-time' too."
5491(defvar cperl-unreadable-ok nil) 5480(defvar cperl-unreadable-ok nil)
5492 5481
5493(defun cperl-find-tags (ifile xs topdir) 5482(defun cperl-find-tags (ifile xs topdir)
5494 (let (ind (b (get-buffer cperl-tmp-buffer)) lst elt pos ret rel 5483 (let ((b (get-buffer cperl-tmp-buffer)) ind lst elt pos ret rel
5495 (cperl-pod-here-fontify nil) f file) 5484 (cperl-pod-here-fontify nil) f file)
5496 (save-excursion 5485 (save-excursion
5497 (if b (set-buffer b) 5486 (if b (set-buffer b)
5498 (cperl-setup-tmp-buf)) 5487 (cperl-setup-tmp-buf))
5499 (erase-buffer) 5488 (erase-buffer)
5500 (condition-case err 5489 (condition-case err
5501 (setq file (car (insert-file-contents ifile))) 5490 (setq file (car (insert-file-contents ifile)))
@@ -5506,72 +5495,72 @@ See `cperl-lazy-help-time' too."
5506 (error "Aborting: unreadable file %s" ifile))))) 5495 (error "Aborting: unreadable file %s" ifile)))))
5507 (if (not file) 5496 (if (not file)
5508 (message "Unreadable file %s" ifile) 5497 (message "Unreadable file %s" ifile)
5509 (message "Scanning file %s ..." file) 5498 (message "Scanning file %s ..." file)
5510 (if (and cperl-use-syntax-table-text-property-for-tags 5499 (if (and cperl-use-syntax-table-text-property-for-tags
5511 (not xs)) 5500 (not xs))
5512 (condition-case err ; after __END__ may have garbage 5501 (condition-case err ; after __END__ may have garbage
5513 (cperl-find-pods-heres nil nil noninteractive) 5502 (cperl-find-pods-heres nil nil noninteractive)
5514 (error (message "While scanning for syntax: %s" err)))) 5503 (error (message "While scanning for syntax: %s" err))))
5515 (if xs 5504 (if xs
5516 (setq lst (cperl-xsub-scan)) 5505 (setq lst (cperl-xsub-scan))
5517 (setq ind (cperl-imenu--create-perl-index)) 5506 (setq ind (cperl-imenu--create-perl-index))
5518 (setq lst (cdr (assoc "+Unsorted List+..." ind)))) 5507 (setq lst (cdr (assoc "+Unsorted List+..." ind))))
5519 (setq lst 5508 (setq lst
5520 (mapcar 5509 (mapcar
5521 (function 5510 (function
5522 (lambda (elt) 5511 (lambda (elt)
5523 (cond ((string-match "^[_a-zA-Z]" (car elt)) 5512 (cond ((string-match "^[_a-zA-Z]" (car elt))
5524 (goto-char (cdr elt)) 5513 (goto-char (cdr elt))
5525 (beginning-of-line) ; pos should be of the start of the line 5514 (beginning-of-line) ; pos should be of the start of the line
5526 (list (car elt) 5515 (list (car elt)
5527 (point) 5516 (point)
5528 (1+ (count-lines 1 (point))) ; 1+ since at beg-o-l 5517 (1+ (count-lines 1 (point))) ; 1+ since at beg-o-l
5529 (buffer-substring (progn 5518 (buffer-substring (progn
5530 (goto-char (cdr elt)) 5519 (goto-char (cdr elt))
5531 ;; After name now... 5520 ;; After name now...
5532 (or (eolp) (forward-char 1)) 5521 (or (eolp) (forward-char 1))
5533 (point)) 5522 (point))
5534 (progn 5523 (progn
5535 (beginning-of-line) 5524 (beginning-of-line)
5536 (point)))))))) 5525 (point))))))))
5537 lst)) 5526 lst))
5538 (erase-buffer) 5527 (erase-buffer)
5539 (while lst 5528 (while lst
5540 (setq elt (car lst) lst (cdr lst)) 5529 (setq elt (car lst) lst (cdr lst))
5541 (if elt 5530 (if elt
5542 (progn 5531 (progn
5543 (insert (elt elt 3) 5532 (insert (elt elt 3)
5544 127 5533 127
5545 (if (string-match "^package " (car elt)) 5534 (if (string-match "^package " (car elt))
5546 (substring (car elt) 8) 5535 (substring (car elt) 8)
5547 (car elt) ) 5536 (car elt) )
5548 1 5537 1
5549 (number-to-string (elt elt 2)) ; Line 5538 (number-to-string (elt elt 2)) ; Line
5550 "," 5539 ","
5551 (number-to-string (1- (elt elt 1))) ; Char pos 0-based 5540 (number-to-string (1- (elt elt 1))) ; Char pos 0-based
5552 "\n") 5541 "\n")
5553 (if (and (string-match "^[_a-zA-Z]+::" (car elt)) 5542 (if (and (string-match "^[_a-zA-Z]+::" (car elt))
5554 (string-match "^sub[ \t]+\\([_a-zA-Z]+\\)[^:_a-zA-Z]" 5543 (string-match "^sub[ \t]+\\([_a-zA-Z]+\\)[^:_a-zA-Z]"
5555 (elt elt 3))) 5544 (elt elt 3)))
5556 ;; Need to insert the name without package as well 5545 ;; Need to insert the name without package as well
5557 (setq lst (cons (cons (substring (elt elt 3) 5546 (setq lst (cons (cons (substring (elt elt 3)
5558 (match-beginning 1) 5547 (match-beginning 1)
5559 (match-end 1)) 5548 (match-end 1))
5560 (cdr elt)) 5549 (cdr elt))
5561 lst)))))) 5550 lst))))))
5562 (setq pos (point)) 5551 (setq pos (point))
5563 (goto-char 1) 5552 (goto-char 1)
5564 (setq rel file) 5553 (setq rel file)
5565 ;; On case-preserving filesystems (EMX on OS/2) case might be encoded in properties 5554 ;; On case-preserving filesystems (EMX on OS/2) case might be encoded in properties
5566 (set-text-properties 0 (length rel) nil rel) 5555 (set-text-properties 0 (length rel) nil rel)
5567 (and (equal topdir (substring rel 0 (length topdir))) 5556 (and (equal topdir (substring rel 0 (length topdir)))
5568 (setq rel (substring file (length topdir)))) 5557 (setq rel (substring file (length topdir))))
5569 (insert "\f\n" rel "," (number-to-string (1- pos)) "\n") 5558 (insert "\f\n" rel "," (number-to-string (1- pos)) "\n")
5570 (setq ret (buffer-substring 1 (point-max))) 5559 (setq ret (buffer-substring 1 (point-max)))
5571 (erase-buffer) 5560 (erase-buffer)
5572 (or noninteractive 5561 (or noninteractive
5573 (message "Scanning file %s finished" file)) 5562 (message "Scanning file %s finished" file))
5574 ret)))) 5563 ret))))
5575 5564
5576(defun cperl-add-tags-recurse-noxs () 5565(defun cperl-add-tags-recurse-noxs ()
5577 "Add to TAGS data for Perl and XSUB files in the current directory and kids. 5566 "Add to TAGS data for Perl and XSUB files in the current directory and kids.
@@ -5606,7 +5595,7 @@ Use as
5606 ((file-exists-p tags-file-name) 5595 ((file-exists-p tags-file-name)
5607 (if cperl-xemacs-p 5596 (if cperl-xemacs-p
5608 (visit-tags-table-buffer) 5597 (visit-tags-table-buffer)
5609 (visit-tags-table-buffer tags-file-name))) 5598 (visit-tags-table-buffer tags-file-name)))
5610 (t (set-buffer (find-file-noselect tags-file-name)))) 5599 (t (set-buffer (find-file-noselect tags-file-name))))
5611 (cond 5600 (cond
5612 (dir 5601 (dir
@@ -5624,46 +5613,46 @@ Use as
5624 (if (y-or-n-p 5613 (if (y-or-n-p
5625 (format "Directory %s unreadable. Continue? " file)) 5614 (format "Directory %s unreadable. Continue? " file))
5626 (setq cperl-unreadable-ok t 5615 (setq cperl-unreadable-ok t
5627 tm nil) ; Return empty list 5616 tm nil) ; Return empty list
5628 (error "Aborting: unreadable directory %s" file))))))) 5617 (error "Aborting: unreadable directory %s" file)))))))
5629 (mapcar (function (lambda (file) 5618 (mapcar (function
5630 (cond 5619 (lambda (file)
5631 ((string-match cperl-noscan-files-regexp file) 5620 (cond
5632 nil) 5621 ((string-match cperl-noscan-files-regexp file)
5633 ((not (file-directory-p file)) 5622 nil)
5634 (if (string-match cperl-scan-files-regexp file) 5623 ((not (file-directory-p file))
5635 (cperl-write-tags file erase recurse nil t noxs topdir))) 5624 (if (string-match cperl-scan-files-regexp file)
5636 ((not recurse) nil) 5625 (cperl-write-tags file erase recurse nil t noxs topdir)))
5637 (t (cperl-write-tags file erase recurse t t noxs topdir))))) 5626 ((not recurse) nil)
5638 files)) 5627 (t (cperl-write-tags file erase recurse t t noxs topdir)))))
5639 ) 5628 files)))
5640 (t 5629 (t
5641 (setq xs (string-match "\\.xs$" file)) 5630 (setq xs (string-match "\\.xs$" file))
5642 (if (not (and xs noxs)) 5631 (if (not (and xs noxs))
5643 (progn 5632 (progn
5644 (cond ((eq erase 'ignore) (goto-char (point-max))) 5633 (cond ((eq erase 'ignore) (goto-char (point-max)))
5645 (erase (erase-buffer)) 5634 (erase (erase-buffer))
5646 (t 5635 (t
5647 (goto-char 1) 5636 (goto-char 1)
5648 (setq rel file) 5637 (setq rel file)
5649 ;; On case-preserving filesystems (EMX on OS/2) case might be encoded in properties 5638 ;; On case-preserving filesystems (EMX on OS/2) case might be encoded in properties
5650 (set-text-properties 0 (length rel) nil rel) 5639 (set-text-properties 0 (length rel) nil rel)
5651 (and (equal topdir (substring rel 0 (length topdir))) 5640 (and (equal topdir (substring rel 0 (length topdir)))
5652 (setq rel (substring file (length topdir)))) 5641 (setq rel (substring file (length topdir))))
5653 (if (search-forward (concat "\f\n" rel ",") nil t) 5642 (if (search-forward (concat "\f\n" rel ",") nil t)
5654 (progn 5643 (progn
5655 (search-backward "\f\n") 5644 (search-backward "\f\n")
5656 (delete-region (point) 5645 (delete-region (point)
5657 (save-excursion 5646 (save-excursion
5658 (forward-char 1) 5647 (forward-char 1)
5659 (if (search-forward "\f\n" 5648 (if (search-forward "\f\n"
5660 nil 'toend) 5649 nil 'toend)
5661 (- (point) 2) 5650 (- (point) 2)
5662 (point-max))))) 5651 (point-max)))))
5663 (goto-char (point-max))))) 5652 (goto-char (point-max)))))
5664 (insert (cperl-find-tags file xs topdir)))))) 5653 (insert (cperl-find-tags file xs topdir))))))
5665 (if inbuffer nil ; Delegate to the caller 5654 (if inbuffer nil ; Delegate to the caller
5666 (save-buffer 0) ; No backup 5655 (save-buffer 0) ; No backup
5667 (if (fboundp 'initialize-new-tags-table) ; Do we need something special in XEmacs? 5656 (if (fboundp 'initialize-new-tags-table) ; Do we need something special in XEmacs?
5668 (initialize-new-tags-table)))))) 5657 (initialize-new-tags-table))))))
5669 5658
@@ -5733,11 +5722,11 @@ One may build such TAGS files from CPerl mode menu."
5733 (require 'etags) 5722 (require 'etags)
5734 (require 'imenu) 5723 (require 'imenu)
5735 (if (or update (null (nth 2 cperl-hierarchy))) 5724 (if (or update (null (nth 2 cperl-hierarchy)))
5736 (let (pack name cons1 to l1 l2 l3 l4 b 5725 (let ((remover (function (lambda (elt) ; (name (file1...) (file2..))
5737 (remover (function (lambda (elt) ; (name (file1...) (file2..)) 5726 (or (nthcdr 2 elt)
5738 (or (nthcdr 2 elt) 5727 ;; Only in one file
5739 ;; Only in one file 5728 (setcdr elt (cdr (nth 1 elt)))))))
5740 (setcdr elt (cdr (nth 1 elt)))))))) 5729 pack name cons1 to l1 l2 l3 l4 b)
5741 ;; (setq cperl-hierarchy '(() () ())) ; Would write into '() later! 5730 ;; (setq cperl-hierarchy '(() () ())) ; Would write into '() later!
5742 (setq cperl-hierarchy (list l1 l2 l3)) 5731 (setq cperl-hierarchy (list l1 l2 l3))
5743 (if cperl-xemacs-p ; Not checked 5732 (if cperl-xemacs-p ; Not checked
@@ -5772,7 +5761,10 @@ One may build such TAGS files from CPerl mode menu."
5772 (error "No items found")) 5761 (error "No items found"))
5773 (setq update 5762 (setq update
5774;;; (imenu-choose-buffer-index "Packages: " (nth 2 cperl-hierarchy)) 5763;;; (imenu-choose-buffer-index "Packages: " (nth 2 cperl-hierarchy))
5775 (if window-system 5764 (if (if (fboundp 'display-popup-menus-p)
5765 (let ((f 'display-popup-menus-p))
5766 (funcall f))
5767 window-system)
5776 (x-popup-menu t (nth 2 cperl-hierarchy)) 5768 (x-popup-menu t (nth 2 cperl-hierarchy))
5777 (require 'tmm) 5769 (require 'tmm)
5778 (tmm-prompt (nth 2 cperl-hierarchy)))) 5770 (tmm-prompt (nth 2 cperl-hierarchy))))
@@ -5853,8 +5845,7 @@ One may build such TAGS files from CPerl mode menu."
5853 (if (default-value 'imenu-sort-function) 5845 (if (default-value 'imenu-sort-function)
5854 (nreverse 5846 (nreverse
5855 (sort root-packages (default-value 'imenu-sort-function))) 5847 (sort root-packages (default-value 'imenu-sort-function)))
5856 root-packages)) 5848 root-packages))))
5857 ))
5858 5849
5859;;;(x-popup-menu t 5850;;;(x-popup-menu t
5860;;; '(keymap "Name1" 5851;;; '(keymap "Name1"
@@ -5901,14 +5892,14 @@ One may build such TAGS files from CPerl mode menu."
5901 5892
5902(defvar cperl-bad-style-regexp 5893(defvar cperl-bad-style-regexp
5903 (mapconcat 'identity 5894 (mapconcat 'identity
5904 '("[^-\n\t <>=+!.&|(*/'`\"#^][-=+<>!|&^]" ; char sign 5895 '("[^-\n\t <>=+!.&|(*/'`\"#^][-=+<>!|&^]" ; char sign
5905 "[-<>=+^&|]+[^- \t\n=+<>~]" ; sign+ char 5896 "[-<>=+^&|]+[^- \t\n=+<>~]") ; sign+ char
5906 ) 5897 "\\|")
5907 "\\|")
5908 "Finds places such that insertion of a whitespace may help a lot.") 5898 "Finds places such that insertion of a whitespace may help a lot.")
5909 5899
5910(defvar cperl-not-bad-style-regexp 5900(defvar cperl-not-bad-style-regexp
5911 (mapconcat 'identity 5901 (mapconcat
5902 'identity
5912 '("[^-\t <>=+]\\(--\\|\\+\\+\\)" ; var-- var++ 5903 '("[^-\t <>=+]\\(--\\|\\+\\+\\)" ; var-- var++
5913 "[a-zA-Z0-9_][|&][a-zA-Z0-9_$]" ; abc|def abc&def are often used. 5904 "[a-zA-Z0-9_][|&][a-zA-Z0-9_$]" ; abc|def abc&def are often used.
5914 "&[(a-zA-Z0-9_$]" ; &subroutine &(var->field) 5905 "&[(a-zA-Z0-9_$]" ; &subroutine &(var->field)
@@ -5927,7 +5918,7 @@ One may build such TAGS files from CPerl mode menu."
5927 "||" 5918 "||"
5928 "&&" 5919 "&&"
5929 "[CBIXSLFZ]<\\(\\sw\\|\\s \\|\\s_\\|[\n]\\)*>" ; C<code like text> 5920 "[CBIXSLFZ]<\\(\\sw\\|\\s \\|\\s_\\|[\n]\\)*>" ; C<code like text>
5930 "-[a-zA-Z_0-9]+[ \t]*=>" ; -option => value 5921 "-[a-zA-Z_0-9]+[ \t]*=>" ; -option => value
5931 ;; Unaddressed trouble spots: = -abc, f(56, -abc) --- specialcased below 5922 ;; Unaddressed trouble spots: = -abc, f(56, -abc) --- specialcased below
5932 ;;"[*/+-|&<.]+=" 5923 ;;"[*/+-|&<.]+="
5933 ) 5924 )
@@ -5946,7 +5937,7 @@ Currently it is tuned to C and Perl syntax."
5946 (setq last-nonmenu-event 13) ; To disable popup 5937 (setq last-nonmenu-event 13) ; To disable popup
5947 (beginning-of-buffer) 5938 (beginning-of-buffer)
5948 (map-y-or-n-p "Insert space here? " 5939 (map-y-or-n-p "Insert space here? "
5949 (function (lambda (arg) (insert " "))) 5940 (lambda (arg) (insert " "))
5950 'cperl-next-bad-style 5941 'cperl-next-bad-style
5951 '("location" "locations" "insert a space into") 5942 '("location" "locations" "insert a space into")
5952 '((?\C-r (lambda (arg) 5943 '((?\C-r (lambda (arg)
@@ -5999,22 +5990,20 @@ Currently it is tuned to C and Perl syntax."
5999 ;;(concat "\\(" 5990 ;;(concat "\\("
6000 (mapconcat 5991 (mapconcat
6001 'identity 5992 'identity
6002 '("[$@%*&][0-9a-zA-Z_:]+\\([ \t]*[[{]\\)?" ; Usual variable 5993 '("[$@%*&][0-9a-zA-Z_:]+\\([ \t]*[[{]\\)?" ; Usual variable
6003 "[$@]\\^[a-zA-Z]" ; Special variable 5994 "[$@]\\^[a-zA-Z]" ; Special variable
6004 "[$@][^ \n\t]" ; Special variable 5995 "[$@][^ \n\t]" ; Special variable
6005 "-[a-zA-Z]" ; File test 5996 "-[a-zA-Z]" ; File test
6006 "\\\\[a-zA-Z0]" ; Special chars 5997 "\\\\[a-zA-Z0]" ; Special chars
6007 "^=[a-z][a-zA-Z0-9_]*" ; Pod sections 5998 "^=[a-z][a-zA-Z0-9_]*" ; POD sections
6008 "[-!&*+,-./<=>?\\\\^|~]+" ; Operator 5999 "[-!&*+,-./<=>?\\\\^|~]+" ; Operator
6009 "[a-zA-Z_0-9:]+" ; symbol or number 6000 "[a-zA-Z_0-9:]+" ; symbol or number
6010 "x=" 6001 "x="
6011 "#!" 6002 "#!")
6012 )
6013 ;;"\\)\\|\\(" 6003 ;;"\\)\\|\\("
6014 "\\|" 6004 "\\|")
6015 ) 6005 ;;"\\)"
6016 ;;"\\)" 6006 ;;)
6017 ;;)
6018 "Matches places in the buffer we can find help for.") 6007 "Matches places in the buffer we can find help for.")
6019 6008
6020(defvar cperl-message-on-help-error t) 6009(defvar cperl-message-on-help-error t)
@@ -6102,22 +6091,22 @@ than a line. Your contribution to update/shorten it is appreciated."
6102 (let ((enable-recursive-minibuffers t) 6091 (let ((enable-recursive-minibuffers t)
6103 args-file regexp) 6092 args-file regexp)
6104 (cond 6093 (cond
6105 ((string-match "^[&*][a-zA-Z_]" val) 6094 ((string-match "^[&*][a-zA-Z_]" val)
6106 (setq val (concat (substring val 0 1) "NAME"))) 6095 (setq val (concat (substring val 0 1) "NAME")))
6107 ((string-match "^[$@]\\([a-zA-Z_:0-9]+\\)[ \t]*\\[" val) 6096 ((string-match "^[$@]\\([a-zA-Z_:0-9]+\\)[ \t]*\\[" val)
6108 (setq val (concat "@" (substring val 1 (match-end 1))))) 6097 (setq val (concat "@" (substring val 1 (match-end 1)))))
6109 ((string-match "^[$@]\\([a-zA-Z_:0-9]+\\)[ \t]*{" val) 6098 ((string-match "^[$@]\\([a-zA-Z_:0-9]+\\)[ \t]*{" val)
6110 (setq val (concat "%" (substring val 1 (match-end 1))))) 6099 (setq val (concat "%" (substring val 1 (match-end 1)))))
6111 ((and (string= val "x") (string-match "^x=" val)) 6100 ((and (string= val "x") (string-match "^x=" val))
6112 (setq val "x=")) 6101 (setq val "x="))
6113 ((string-match "^\\$[\C-a-\C-z]" val) 6102 ((string-match "^\\$[\C-a-\C-z]" val)
6114 (setq val (concat "$^" (char-to-string (+ ?A -1 (aref val 1)))))) 6103 (setq val (concat "$^" (char-to-string (+ ?A -1 (aref val 1))))))
6115 ((string-match "^CORE::" val) 6104 ((string-match "^CORE::" val)
6116 (setq val "CORE::")) 6105 (setq val "CORE::"))
6117 ((string-match "^SUPER::" val) 6106 ((string-match "^SUPER::" val)
6118 (setq val "SUPER::")) 6107 (setq val "SUPER::"))
6119 ((and (string= "<" val) (string-match "^<\\$?[a-zA-Z0-9_:]+>" val)) 6108 ((and (string= "<" val) (string-match "^<\\$?[a-zA-Z0-9_:]+>" val))
6120 (setq val "<NAME>"))) 6109 (setq val "<NAME>")))
6121 (setq regexp (concat "^" 6110 (setq regexp (concat "^"
6122 "\\([^a-zA-Z0-9_:]+[ \t]+\\)?" 6111 "\\([^a-zA-Z0-9_:]+[ \t]+\\)?"
6123 (regexp-quote val) 6112 (regexp-quote val)
@@ -6139,7 +6128,7 @@ than a line. Your contribution to update/shorten it is appreciated."
6139 (if cperl-message-on-help-error 6128 (if cperl-message-on-help-error
6140 (message "No definition for %s" val))))))) 6129 (message "No definition for %s" val)))))))
6141 6130
6142(defvar cperl-short-docs "Ignore my value" 6131(defvar cperl-short-docs 'please-ignore-this-line
6143 ;; Perl4 version was written by Johan Vromans (jvromans@squirrel.nl) 6132 ;; Perl4 version was written by Johan Vromans (jvromans@squirrel.nl)
6144 "# based on '@(#)@ perl-descr.el 1.9 - describe-perl-symbol' [Perl 5] 6133 "# based on '@(#)@ perl-descr.el 1.9 - describe-perl-symbol' [Perl 5]
6145! ... Logical negation. 6134! ... Logical negation.
@@ -6525,7 +6514,7 @@ chomp [LIST] Strips $/ off LIST/$_. Returns count. Special if $/ eq ''!
6525chr Converts a number to char with the same ordinal. 6514chr Converts a number to char with the same ordinal.
6526else Part of if/unless {BLOCK} elsif {BLOCK} else {BLOCK}. 6515else Part of if/unless {BLOCK} elsif {BLOCK} else {BLOCK}.
6527elsif Part of if/unless {BLOCK} elsif {BLOCK} else {BLOCK}. 6516elsif Part of if/unless {BLOCK} elsif {BLOCK} else {BLOCK}.
6528exists $HASH{KEY} True if the key exists. 6517exists $HASH{KEY} True if the key exists.
6529format [NAME] = Start of output format. Ended by a single dot (.) on a line. 6518format [NAME] = Start of output format. Ended by a single dot (.) on a line.
6530formline PICTURE, LIST Backdoor into \"format\" processing. 6519formline PICTURE, LIST Backdoor into \"format\" processing.
6531glob EXPR Synonym of <EXPR>. 6520glob EXPR Synonym of <EXPR>.
@@ -6603,7 +6592,7 @@ prototype \&SUB Returns prototype of the function given a reference.
6603 (goto-char e) 6592 (goto-char e)
6604 (beginning-of-line) 6593 (beginning-of-line)
6605 (if (re-search-forward "[^ \t]" e t) 6594 (if (re-search-forward "[^ \t]" e t)
6606 (progn ; Something before the ending delimiter 6595 (progn ; Something before the ending delimiter
6607 (goto-char e) 6596 (goto-char e)
6608 (delete-horizontal-space) 6597 (delete-horizontal-space)
6609 (insert "\n") 6598 (insert "\n")
@@ -6633,8 +6622,7 @@ prototype \&SUB Returns prototype of the function given a reference.
6633 "\\|" ; Grouping 6622 "\\|" ; Grouping
6634 "\\((\\(\\?\\)?\\)" ; 7 8 6623 "\\((\\(\\?\\)?\\)" ; 7 8
6635 "\\|" ; | 6624 "\\|" ; |
6636 "\\(|\\)" ; 9 6625 "\\(|\\)"))) ; 9
6637 )))
6638 (goto-char (match-end 0)) 6626 (goto-char (match-end 0))
6639 (setq spaces t) 6627 (setq spaces t)
6640 (cond ((match-beginning 1) ; Alphanum word + junk 6628 (cond ((match-beginning 1) ; Alphanum word + junk
@@ -6744,20 +6732,19 @@ prototype \&SUB Returns prototype of the function given a reference.
6744 (not spaces) 6732 (not spaces)
6745 (insert " ")) 6733 (insert " "))
6746 (skip-chars-forward " \t")) 6734 (skip-chars-forward " \t"))
6747 (or (looking-at "[#\n]") 6735 (or (looking-at "[#\n]")
6748 (error "Unknown code `%s' in a regexp" 6736 (error "Unknown code `%s' in a regexp"
6749 (buffer-substring (point) (1+ (point))))) 6737 (buffer-substring (point) (1+ (point)))))
6750 (and inline (end-of-line 2))) 6738 (and inline (end-of-line 2)))
6751 ;; Special-case the last line of group 6739 ;; Special-case the last line of group
6752 (if (and (>= (point) (marker-position e)) 6740 (if (and (>= (point) (marker-position e))
6753 (/= (current-indentation) c)) 6741 (/= (current-indentation) c))
6754 (progn 6742 (progn
6755 (beginning-of-line) 6743 (beginning-of-line)
6756 (setq s (point)) 6744 (setq s (point))
6757 (skip-chars-forward " \t") 6745 (skip-chars-forward " \t")
6758 (delete-region s (point)) 6746 (delete-region s (point))
6759 (indent-to-column c))) 6747 (indent-to-column c)))))
6760 ))
6761 6748
6762(defun cperl-make-regexp-x () 6749(defun cperl-make-regexp-x ()
6763 ;; Returns position of the start 6750 ;; Returns position of the start
@@ -6770,7 +6757,7 @@ prototype \&SUB Returns prototype of the function given a reference.
6770 nil ; good already 6757 nil ; good already
6771 (if (looking-at "\\([smy]\\|qr\\)\\s|") 6758 (if (looking-at "\\([smy]\\|qr\\)\\s|")
6772 (forward-char 1) 6759 (forward-char 1)
6773 (re-search-backward "\\s|"))) ; Assume it is scanned already. 6760 (re-search-backward "\\s|"))) ; Assume it is scanned already.
6774 ;;(forward-char 1) 6761 ;;(forward-char 1)
6775 (let ((b (point)) (e (make-marker)) have-x delim (c (current-column)) 6762 (let ((b (point)) (e (make-marker)) have-x delim (c (current-column))
6776 (sub-p (eq (preceding-char) ?s)) s) 6763 (sub-p (eq (preceding-char) ?s)) s)
@@ -6825,23 +6812,23 @@ We suppose that the regexp is scanned already."
6825We suppose that the regexp is scanned already." 6812We suppose that the regexp is scanned already."
6826 (interactive) 6813 (interactive)
6827 ;; (save-excursion ; Can't, breaks `cperl-contract-levels' 6814 ;; (save-excursion ; Can't, breaks `cperl-contract-levels'
6828 (cperl-regext-to-level-start) 6815 (cperl-regext-to-level-start)
6829 (let ((b (point)) (e (make-marker)) s c) 6816 (let ((b (point)) (e (make-marker)) s c)
6830 (forward-sexp 1) 6817 (forward-sexp 1)
6831 (set-marker e (1- (point))) 6818 (set-marker e (1- (point)))
6832 (goto-char b) 6819 (goto-char b)
6833 (while (re-search-forward "\\(#\\)\\|\n" e 'to-end) 6820 (while (re-search-forward "\\(#\\)\\|\n" e 'to-end)
6834 (cond 6821 (cond
6835 ((match-beginning 1) ; #-comment 6822 ((match-beginning 1) ; #-comment
6836 (or c (setq c (current-indentation))) 6823 (or c (setq c (current-indentation)))
6837 (beginning-of-line 2) ; Skip 6824 (beginning-of-line 2) ; Skip
6838 (setq s (point)) 6825 (setq s (point))
6839 (skip-chars-forward " \t") 6826 (skip-chars-forward " \t")
6840 (delete-region s (point)) 6827 (delete-region s (point))
6841 (indent-to-column c)) 6828 (indent-to-column c))
6842 (t 6829 (t
6843 (delete-char -1) 6830 (delete-char -1)
6844 (just-one-space)))))) 6831 (just-one-space))))))
6845 6832
6846(defun cperl-contract-levels () 6833(defun cperl-contract-levels ()
6847 "Find an enclosing group in regexp and contract all the kids. 6834 "Find an enclosing group in regexp and contract all the kids.
@@ -6881,7 +6868,7 @@ We suppose that the regexp is scanned already."
6881 "Change `if (A) {B}' into `B if A;' etc if possible." 6868 "Change `if (A) {B}' into `B if A;' etc if possible."
6882 (interactive) 6869 (interactive)
6883 (or (looking-at "\\<") 6870 (or (looking-at "\\<")
6884 (forward-sexp -1)) 6871 (forward-sexp -1))
6885 (if (looking-at "\\<\\(if\\|unless\\|while\\|until\\|for\\|foreach\\)\\>") 6872 (if (looking-at "\\<\\(if\\|unless\\|while\\|until\\|for\\|foreach\\)\\>")
6886 (let ((pos1 (point)) 6873 (let ((pos1 (point))
6887 pos2 pos3 pos4 pos5 s1 s2 state p pos45 6874 pos2 pos3 pos4 pos5 s1 s2 state p pos45
@@ -7069,7 +7056,7 @@ We suppose that the regexp is scanned already."
7069 (setq cperl-help-shown nil)) 7056 (setq cperl-help-shown nil))
7070 7057
7071 (defun cperl-get-help-defer () 7058 (defun cperl-get-help-defer ()
7072 (when (memq major-mode '(perl-mode cperl-mode)) 7059 (if (not (memq major-mode '(perl-mode cperl-mode))) nil
7073 (let ((cperl-message-on-help-error nil) (cperl-help-from-timer t)) 7060 (let ((cperl-message-on-help-error nil) (cperl-help-from-timer t))
7074 (cperl-get-help) 7061 (cperl-get-help)
7075 (setq cperl-help-shown t)))) 7062 (setq cperl-help-shown t))))
@@ -7091,8 +7078,9 @@ We suppose that the regexp is scanned already."
7091(defun cperl-fontify-syntaxically (end) 7078(defun cperl-fontify-syntaxically (end)
7092 ;; Some vars for debugging only 7079 ;; Some vars for debugging only
7093 ;; (message "Syntaxifying...") 7080 ;; (message "Syntaxifying...")
7094 (let (start (dbg (point)) (iend end) 7081 (let ((dbg (point)) (iend end)
7095 (istate (car cperl-syntax-state))) 7082 (istate (car cperl-syntax-state))
7083 start)
7096 (and cperl-syntaxify-unwind 7084 (and cperl-syntaxify-unwind
7097 (setq end (cperl-unwind-to-safe t end))) 7085 (setq end (cperl-unwind-to-safe t end)))
7098 (setq start (point)) 7086 (setq start (point))
@@ -7113,7 +7101,7 @@ We suppose that the regexp is scanned already."
7113 dbg iend 7101 dbg iend
7114 start end cperl-syntax-done-to 7102 start end cperl-syntax-done-to
7115 istate (car cperl-syntax-state))) ; For debugging 7103 istate (car cperl-syntax-state))) ; For debugging
7116 nil)) ; Do not iterate 7104 nil)) ; Do not iterate
7117 7105
7118(defun cperl-fontify-update (end) 7106(defun cperl-fontify-update (end)
7119 (let ((pos (point)) prop posend) 7107 (let ((pos (point)) prop posend)
@@ -7122,7 +7110,7 @@ We suppose that the regexp is scanned already."
7122 (setq posend (next-single-property-change pos 'cperl-postpone nil end)) 7110 (setq posend (next-single-property-change pos 'cperl-postpone nil end))
7123 (and prop (put-text-property pos posend (car prop) (cdr prop))) 7111 (and prop (put-text-property pos posend (car prop) (cdr prop)))
7124 (setq pos posend))) 7112 (setq pos posend)))
7125 nil) ; Do not iterate 7113 nil) ; Do not iterate
7126 7114
7127(defun cperl-update-syntaxification (from to) 7115(defun cperl-update-syntaxification (from to)
7128 (if (and cperl-use-syntax-table-text-property 7116 (if (and cperl-use-syntax-table-text-property
@@ -7135,7 +7123,7 @@ We suppose that the regexp is scanned already."
7135 (cperl-fontify-syntaxically to))))) 7123 (cperl-fontify-syntaxically to)))))
7136 7124
7137(defvar cperl-version 7125(defvar cperl-version
7138 (let ((v "Revision: 4.32")) 7126 (let ((v "Revision: 4.35"))
7139 (string-match ":\\s *\\([0-9.]+\\)" v) 7127 (string-match ":\\s *\\([0-9.]+\\)" v)
7140 (substring v (match-beginning 1) (match-end 1))) 7128 (substring v (match-beginning 1) (match-end 1)))
7141 "Version of IZ-supported CPerl package this file is based on.") 7129 "Version of IZ-supported CPerl package this file is based on.")