aboutsummaryrefslogtreecommitdiffstats
path: root/lisp/progmodes
diff options
context:
space:
mode:
authorKaroly Lorentey2006-10-14 17:36:28 +0000
committerKaroly Lorentey2006-10-14 17:36:28 +0000
commit12b6af5c7ed2cfdb9783312bf890cf1e6c80c67a (patch)
tree1775f9fd1c92defd8b61304a08ec00da95bc4539 /lisp/progmodes
parent3f87f67ee215ffeecbd2f53bd7f342cdf03f47df (diff)
parentf763da8d0808af7c80d72bc586bf4fcf50b37ddd (diff)
downloademacs-12b6af5c7ed2cfdb9783312bf890cf1e6c80c67a.tar.gz
emacs-12b6af5c7ed2cfdb9783312bf890cf1e6c80c67a.zip
Merged from emacs@sv.gnu.org
Patches applied: * emacs@sv.gnu.org/emacs--devo--0--patch-413 Update from CVS * emacs@sv.gnu.org/emacs--devo--0--patch-414 Update from CVS * emacs@sv.gnu.org/emacs--devo--0--patch-415 Update from CVS * emacs@sv.gnu.org/emacs--devo--0--patch-416 Update from CVS * emacs@sv.gnu.org/emacs--devo--0--patch-417 Update from CVS * emacs@sv.gnu.org/emacs--devo--0--patch-418 Merge from gnus--rel--5.10 * emacs@sv.gnu.org/emacs--devo--0--patch-419 Update from CVS * emacs@sv.gnu.org/emacs--devo--0--patch-420 Update from CVS * emacs@sv.gnu.org/emacs--devo--0--patch-421 Merge from gnus--rel--5.10 * emacs@sv.gnu.org/emacs--devo--0--patch-422 Update from CVS * emacs@sv.gnu.org/emacs--devo--0--patch-423 Update from CVS * emacs@sv.gnu.org/emacs--devo--0--patch-424 Merge from gnus--rel--5.10 * emacs@sv.gnu.org/emacs--devo--0--patch-425 Update from CVS * emacs@sv.gnu.org/emacs--devo--0--patch-426 Update from CVS * emacs@sv.gnu.org/emacs--devo--0--patch-427 Update from CVS * emacs@sv.gnu.org/emacs--devo--0--patch-428 Merge from gnus--rel--5.10 * emacs@sv.gnu.org/emacs--devo--0--patch-429 Update from CVS * emacs@sv.gnu.org/emacs--devo--0--patch-430 Update from CVS * emacs@sv.gnu.org/emacs--devo--0--patch-431 Merge from gnus--rel--5.10 * emacs@sv.gnu.org/emacs--devo--0--patch-432 Update from CVS * emacs@sv.gnu.org/emacs--devo--0--patch-433 Update from CVS * emacs@sv.gnu.org/emacs--devo--0--patch-434 Update from CVS * emacs@sv.gnu.org/emacs--devo--0--patch-435 Update from CVS * emacs@sv.gnu.org/emacs--devo--0--patch-436 Update from CVS * emacs@sv.gnu.org/emacs--devo--0--patch-437 Update from CVS * emacs@sv.gnu.org/emacs--devo--0--patch-438 Update from CVS * emacs@sv.gnu.org/emacs--devo--0--patch-439 Update from CVS * emacs@sv.gnu.org/emacs--devo--0--patch-440 Update from CVS * emacs@sv.gnu.org/emacs--devo--0--patch-441 lisp/url/url-methods.el: Fix format error when http_proxy is empty string * emacs@sv.gnu.org/emacs--devo--0--patch-442 Update from CVS * emacs@sv.gnu.org/emacs--devo--0--patch-443 Update from CVS * emacs@sv.gnu.org/emacs--devo--0--patch-444 Update from CVS * emacs@sv.gnu.org/emacs--devo--0--patch-445 Update from CVS * emacs@sv.gnu.org/emacs--devo--0--patch-446 Merge from gnus--rel--5.10 * emacs@sv.gnu.org/emacs--devo--0--patch-447 Update from CVS * emacs@sv.gnu.org/emacs--devo--0--patch-448 Update from CVS * emacs@sv.gnu.org/emacs--devo--0--patch-449 Update from CVS * emacs@sv.gnu.org/emacs--devo--0--patch-450 Update from CVS * emacs@sv.gnu.org/emacs--devo--0--patch-451 Update from CVS * emacs@sv.gnu.org/emacs--devo--0--patch-452 Update from CVS * emacs@sv.gnu.org/emacs--devo--0--patch-453 Update from CVS * emacs@sv.gnu.org/emacs--devo--0--patch-454 Update from CVS * emacs@sv.gnu.org/emacs--devo--0--patch-455 Update from CVS * emacs@sv.gnu.org/emacs--devo--0--patch-456 Update from CVS * emacs@sv.gnu.org/emacs--devo--0--patch-457 Update from CVS * emacs@sv.gnu.org/emacs--devo--0--patch-458 Update from CVS * emacs@sv.gnu.org/emacs--devo--0--patch-459 Merge from gnus--rel--5.10 * emacs@sv.gnu.org/emacs--devo--0--patch-460 Update from CVS * emacs@sv.gnu.org/emacs--devo--0--patch-461 Update from CVS * emacs@sv.gnu.org/emacs--devo--0--patch-462 Update from CVS * emacs@sv.gnu.org/emacs--devo--0--patch-463 Update from CVS * emacs@sv.gnu.org/emacs--devo--0--patch-464 Update from CVS * emacs@sv.gnu.org/emacs--devo--0--patch-465 Update from CVS * emacs@sv.gnu.org/emacs--devo--0--patch-466 Merge from gnus--rel--5.10 * emacs@sv.gnu.org/emacs--devo--0--patch-467 Update from CVS * emacs@sv.gnu.org/emacs--devo--0--patch-468 Merge from gnus--rel--5.10 * emacs@sv.gnu.org/emacs--devo--0--patch-469 Update from CVS * emacs@sv.gnu.org/emacs--devo--0--patch-470 Update from CVS * emacs@sv.gnu.org/emacs--devo--0--patch-471 Update from CVS * emacs@sv.gnu.org/emacs--devo--0--patch-472 Update from CVS * emacs@sv.gnu.org/emacs--devo--0--patch-473 Update from CVS * emacs@sv.gnu.org/gnus--rel--5.10--patch-128 Update from CVS * emacs@sv.gnu.org/gnus--rel--5.10--patch-129 Merge from emacs--devo--0 * emacs@sv.gnu.org/gnus--rel--5.10--patch-130 Update from CVS * emacs@sv.gnu.org/gnus--rel--5.10--patch-131 Update from CVS * emacs@sv.gnu.org/gnus--rel--5.10--patch-132 Update from CVS * emacs@sv.gnu.org/gnus--rel--5.10--patch-133 Update from CVS * emacs@sv.gnu.org/gnus--rel--5.10--patch-134 Merge from emacs--devo--0 * emacs@sv.gnu.org/gnus--rel--5.10--patch-135 Update from CVS * emacs@sv.gnu.org/gnus--rel--5.10--patch-136 Update from CVS * emacs@sv.gnu.org/gnus--rel--5.10--patch-137 Update from CVS * emacs@sv.gnu.org/gnus--rel--5.10--patch-138 Update from CVS * emacs@sv.gnu.org/gnus--rel--5.10--patch-139 Update from CVS * emacs@sv.gnu.org/gnus--rel--5.10--patch-140 Update from CVS * emacs@sv.gnu.org/gnus--rel--5.10--patch-141 Merge from emacs--devo--0 * emacs@sv.gnu.org/gnus--rel--5.10--patch-142 Update from CVS * emacs@sv.gnu.org/gnus--rel--5.10--patch-143 Update from CVS * emacs@sv.gnu.org/gnus--rel--5.10--patch-144 Update from CVS * emacs@sv.gnu.org/gnus--rel--5.10--patch-145 Merge from emacs--devo--0 * emacs@sv.gnu.org/gnus--rel--5.10--patch-146 Update from CVS * emacs@sv.gnu.org/gnus--rel--5.10--patch-147 Update from CVS * emacs@sv.gnu.org/gnus--rel--5.10--patch-148 Update from CVS * emacs@sv.gnu.org/gnus--rel--5.10--patch-149 Update from CVS git-archimport-id: lorentey@elte.hu--2004/emacs--multi-tty--0--patch-582
Diffstat (limited to 'lisp/progmodes')
-rw-r--r--lisp/progmodes/cfengine.el14
-rw-r--r--lisp/progmodes/compile.el45
-rw-r--r--lisp/progmodes/cperl-mode.el4130
-rw-r--r--lisp/progmodes/ebnf2ps.el225
-rw-r--r--lisp/progmodes/gdb-ui.el42
-rw-r--r--lisp/progmodes/gud.el4
-rw-r--r--lisp/progmodes/idlwave.el942
-rw-r--r--lisp/progmodes/make-mode.el4
-rw-r--r--lisp/progmodes/prolog.el164
-rw-r--r--lisp/progmodes/python.el118
-rw-r--r--lisp/progmodes/sh-script.el81
11 files changed, 3857 insertions, 1912 deletions
diff --git a/lisp/progmodes/cfengine.el b/lisp/progmodes/cfengine.el
index 1b62774a72d..b70fe58b543 100644
--- a/lisp/progmodes/cfengine.el
+++ b/lisp/progmodes/cfengine.el
@@ -85,6 +85,12 @@ This includes those for cfservd as well as cfagent."))
85 ;; File, acl &c in group: { token ... } 85 ;; File, acl &c in group: { token ... }
86 ("{[ \t]*\\([^ \t\n]+\\)" 1 font-lock-constant-face))) 86 ("{[ \t]*\\([^ \t\n]+\\)" 1 font-lock-constant-face)))
87 87
88(defconst cfengine-font-lock-syntactic-keywords
89 ;; In the main syntax-table, backslash is marked as a punctuation, because
90 ;; of its use in DOS-style directory separators. Here we try to recognize
91 ;; the cases where backslash is used as an escape inside strings.
92 '(("\\(\\(?:\\\\\\)+\\)\"" . "\\")))
93
88(defvar cfengine-imenu-expression 94(defvar cfengine-imenu-expression
89 `((nil ,(concat "^[ \t]*" (eval-when-compile 95 `((nil ,(concat "^[ \t]*" (eval-when-compile
90 (regexp-opt cfengine-actions t)) 96 (regexp-opt cfengine-actions t))
@@ -218,7 +224,7 @@ to the action header."
218 ;; variable substitution: 224 ;; variable substitution:
219 (modify-syntax-entry ?$ "." cfengine-mode-syntax-table) 225 (modify-syntax-entry ?$ "." cfengine-mode-syntax-table)
220 ;; Doze path separators: 226 ;; Doze path separators:
221 (modify-syntax-entry ?\\ "_" cfengine-mode-syntax-table) 227 (modify-syntax-entry ?\\ "." cfengine-mode-syntax-table)
222 ;; Otherwise, syntax defaults seem OK to give reasonable word 228 ;; Otherwise, syntax defaults seem OK to give reasonable word
223 ;; movement. 229 ;; movement.
224 230
@@ -237,7 +243,9 @@ to the action header."
237 ;; functions in evaluated classes to string syntax, and then obey 243 ;; functions in evaluated classes to string syntax, and then obey
238 ;; syntax properties. 244 ;; syntax properties.
239 (setq font-lock-defaults 245 (setq font-lock-defaults
240 '(cfengine-font-lock-keywords nil nil nil beginning-of-line)) 246 '(cfengine-font-lock-keywords nil nil nil beginning-of-line
247 (font-lock-syntactic-keywords
248 . cfengine-font-lock-syntactic-keywords)))
241 (setq imenu-generic-expression cfengine-imenu-expression) 249 (setq imenu-generic-expression cfengine-imenu-expression)
242 (set (make-local-variable 'beginning-of-defun-function) 250 (set (make-local-variable 'beginning-of-defun-function)
243 #'cfengine-beginning-of-defun) 251 #'cfengine-beginning-of-defun)
@@ -249,5 +257,5 @@ to the action header."
249 257
250(provide 'cfengine) 258(provide 'cfengine)
251 259
252;;; arch-tag: 6b931be2-1505-4124-afa6-9675971e26d4 260;; arch-tag: 6b931be2-1505-4124-afa6-9675971e26d4
253;;; cfengine.el ends here 261;;; cfengine.el ends here
diff --git a/lisp/progmodes/compile.el b/lisp/progmodes/compile.el
index e8c09113d39..7d9ce41229c 100644
--- a/lisp/progmodes/compile.el
+++ b/lisp/progmodes/compile.el
@@ -218,10 +218,6 @@ of[ \t]+\"?\\([a-zA-Z]?:?[^\":\n]+\\)\"?:" 3 2 nil (1))
218 nil 1 nil 2 0 218 nil 1 nil 2 0
219 (2 (compilation-face '(3)))) 219 (2 (compilation-face '(3))))
220 220
221 (gcc-include
222 "^\\(?:In file included\\| \\) from \
223\\(.+\\):\\([0-9]+\\)\\(?:\\(:\\)\\|\\(,\\)\\)?" 1 2 nil (3 . 4))
224
225 (gnu 221 (gnu
226 ;; I have no idea what this first line is supposed to match, but it 222 ;; I have no idea what this first line is supposed to match, but it
227 ;; makes things ambiguous with output such as "foo:344:50:blabla" since 223 ;; makes things ambiguous with output such as "foo:344:50:blabla" since
@@ -233,7 +229,7 @@ of[ \t]+\"?\\([a-zA-Z]?:?[^\":\n]+\\)\"?:" 3 2 nil (1))
233 ;; the last line tries to rule out message where the info after the 229 ;; the last line tries to rule out message where the info after the
234 ;; line number starts with "SS". --Stef 230 ;; line number starts with "SS". --Stef
235 "^\\(?:[[:alpha:]][-[:alnum:].]+: ?\\)?\ 231 "^\\(?:[[:alpha:]][-[:alnum:].]+: ?\\)?\
236\\([0-9]*[^0-9\n].*?\\): ?\ 232\\([0-9]*[^0-9\n]\\(?:[^\n ]\\| [^-\n]\\)*?\\): ?\
237\\([0-9]+\\)\\(?:\\([.:]\\)\\([0-9]+\\)\\)?\ 233\\([0-9]+\\)\\(?:\\([.:]\\)\\([0-9]+\\)\\)?\
238\\(?:-\\([0-9]+\\)?\\(?:\\3\\([0-9]+\\)\\)?\\)?:\ 234\\(?:-\\([0-9]+\\)?\\(?:\\3\\([0-9]+\\)\\)?\\)?:\
239\\(?: *\\(\\(?:Future\\|Runtime\\)?[Ww]arning\\|W:\\)\\|\ 235\\(?: *\\(\\(?:Future\\|Runtime\\)?[Ww]arning\\|W:\\)\\|\
@@ -241,6 +237,12 @@ of[ \t]+\"?\\([a-zA-Z]?:?[^\":\n]+\\)\"?:" 3 2 nil (1))
241\[0-9]?\\(?:[^0-9\n]\\|$\\)\\|[0-9][0-9][0-9]\\)" 237\[0-9]?\\(?:[^0-9\n]\\|$\\)\\|[0-9][0-9][0-9]\\)"
242 1 (2 . 5) (4 . 6) (7 . 8)) 238 1 (2 . 5) (4 . 6) (7 . 8))
243 239
240 ;; The `gnu' style above can incorrectly match gcc's "In file
241 ;; included from" message, so we process that first. -- cyd
242 (gcc-include
243 "^\\(?:In file included\\| \\) from \
244\\(.+\\):\\([0-9]+\\)\\(?:\\(:\\)\\|\\(,\\)\\)?" 1 2 nil (3 . 4))
245
244 (lcc 246 (lcc
245 "^\\(?:E\\|\\(W\\)\\), \\([^(\n]+\\)(\\([0-9]+\\),[ \t]*\\([0-9]+\\)" 247 "^\\(?:E\\|\\(W\\)\\), \\([^(\n]+\\)(\\([0-9]+\\),[ \t]*\\([0-9]+\\)"
246 2 3 4 (1)) 248 2 3 4 (1))
@@ -623,7 +625,7 @@ Faces `compilation-error-face', `compilation-warning-face',
623 (cons (match-string-no-properties idx) dir)) 625 (cons (match-string-no-properties idx) dir))
624 mouse-face highlight 626 mouse-face highlight
625 keymap compilation-button-map 627 keymap compilation-button-map
626 help-echo "mouse-2: visit current directory"))) 628 help-echo "mouse-2: visit this directory")))
627 629
628;; Data type `reverse-ordered-alist' retriever. This function retrieves the 630;; Data type `reverse-ordered-alist' retriever. This function retrieves the
629;; KEY element from the ALIST, creating it in the right position if not already 631;; KEY element from the ALIST, creating it in the right position if not already
@@ -1066,7 +1068,8 @@ Returns the compilation buffer created."
1066 (window-width)))) 1068 (window-width))))
1067 ;; Set the EMACS variable, but 1069 ;; Set the EMACS variable, but
1068 ;; don't override users' setting of $EMACS. 1070 ;; don't override users' setting of $EMACS.
1069 (unless (getenv "EMACS") '("EMACS=t")) 1071 (unless (getenv "EMACS")
1072 (list (concat "EMACS=" invocation-directory invocation-name)))
1070 (copy-sequence process-environment)))) 1073 (copy-sequence process-environment))))
1071 (set (make-local-variable 'compilation-arguments) 1074 (set (make-local-variable 'compilation-arguments)
1072 (list command mode name-function highlight-regexp)) 1075 (list command mode name-function highlight-regexp))
@@ -1781,17 +1784,31 @@ and overlay is highlighted between MK and END-MK."
1781 (current-buffer))) 1784 (current-buffer)))
1782 (move-overlay compilation-highlight-overlay 1785 (move-overlay compilation-highlight-overlay
1783 (point) end (current-buffer))) 1786 (point) end (current-buffer)))
1784 (if (numberp next-error-highlight) 1787 (if (or (eq next-error-highlight t)
1785 (setq next-error-highlight-timer 1788 (numberp next-error-highlight))
1786 (run-at-time next-error-highlight nil 'delete-overlay 1789 ;; We want highlighting: delete overlay on next input.
1787 compilation-highlight-overlay))) 1790 (add-hook 'pre-command-hook
1788 (if (not (or (eq next-error-highlight t) 1791 'compilation-goto-locus-delete-o)
1789 (numberp next-error-highlight))) 1792 ;; We don't want highlighting: delete overlay now.
1790 (delete-overlay compilation-highlight-overlay)))))) 1793 (delete-overlay compilation-highlight-overlay))
1794 ;; We want highlighting for a limited time:
1795 ;; set up a timer to delete it.
1796 (when (numberp next-error-highlight)
1797 (setq next-error-highlight-timer
1798 (run-at-time next-error-highlight nil
1799 'compilation-goto-locus-delete-o)))))))
1791 (when (and (eq next-error-highlight 'fringe-arrow)) 1800 (when (and (eq next-error-highlight 'fringe-arrow))
1801 ;; We want a fringe arrow (instead of highlighting).
1792 (setq next-error-overlay-arrow-position 1802 (setq next-error-overlay-arrow-position
1793 (copy-marker (line-beginning-position)))))) 1803 (copy-marker (line-beginning-position))))))
1794 1804
1805(defun compilation-goto-locus-delete-o ()
1806 (delete-overlay compilation-highlight-overlay)
1807 ;; Get rid of timer and hook that would try to do this again.
1808 (if (timerp next-error-highlight-timer)
1809 (cancel-timer next-error-highlight-timer))
1810 (remove-hook 'pre-command-hook
1811 'compilation-goto-locus-delete-o))
1795 1812
1796(defun compilation-find-file (marker filename directory &rest formats) 1813(defun compilation-find-file (marker filename directory &rest formats)
1797 "Find a buffer for file FILENAME. 1814 "Find a buffer for file FILENAME.
diff --git a/lisp/progmodes/cperl-mode.el b/lisp/progmodes/cperl-mode.el
index ad44753f352..3264e0e72f6 100644
--- a/lisp/progmodes/cperl-mode.el
+++ b/lisp/progmodes/cperl-mode.el
@@ -5,7 +5,7 @@
5;; Free Software Foundation, Inc. 5;; Free Software Foundation, Inc.
6 6
7;; Author: Ilya Zakharevich and Bob Olson 7;; Author: Ilya Zakharevich and Bob Olson
8;; Maintainer: Ilya Zakharevich <cperl@ilyaz.org> 8;; Maintainer: Ilya Zakharevich <ilyaz@cpan.org>
9;; Keywords: languages, Perl 9;; Keywords: languages, Perl
10 10
11;; This file is part of GNU Emacs. 11;; This file is part of GNU Emacs.
@@ -25,7 +25,7 @@
25;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, 25;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
26;; Boston, MA 02110-1301, USA. 26;; Boston, MA 02110-1301, USA.
27 27
28;;; Corrections made by Ilya Zakharevich cperl@ilyaz.org 28;;; Corrections made by Ilya Zakharevich ilyaz@cpan.org
29 29
30;;; Commentary: 30;;; Commentary:
31 31
@@ -67,67 +67,89 @@
67;; likewise with m, tr, y, q, qX instead of s 67;; likewise with m, tr, y, q, qX instead of s
68 68
69;;; Code: 69;;; Code:
70 70
71(defvar vc-rcs-header) 71(defvar vc-rcs-header)
72(defvar vc-sccs-header) 72(defvar vc-sccs-header)
73 73
74;; Some macros are needed for `defcustom'
75(eval-when-compile 74(eval-when-compile
76 (condition-case nil 75 (condition-case nil
77 (require 'man) 76 (require 'custom)
78 (error nil)) 77 (error nil))
79 (defconst cperl-xemacs-p (string-match "XEmacs\\|Lucid" emacs-version)) 78 (condition-case nil
80 (defvar cperl-can-font-lock 79 (require 'man)
81 (or cperl-xemacs-p 80 (error nil))
82 (and (boundp 'emacs-major-version) 81 (defconst cperl-xemacs-p (string-match "XEmacs\\|Lucid" emacs-version))
83 (or window-system 82 (defvar cperl-can-font-lock
84 (> emacs-major-version 20))))) 83 (or cperl-xemacs-p
85 (if cperl-can-font-lock 84 (and (boundp 'emacs-major-version)
86 (require 'font-lock)) 85 (or window-system
87 (defvar msb-menu-cond) 86 (> emacs-major-version 20)))))
88 (defvar gud-perldb-history) 87 (if cperl-can-font-lock
89 (defvar font-lock-background-mode) ; not in Emacs 88 (require 'font-lock))
90 (defvar font-lock-display-type) ; ditto 89 (defvar msb-menu-cond)
91 (defmacro cperl-is-face (arg) ; Takes quoted arg 90 (defvar gud-perldb-history)
92 (cond ((fboundp 'find-face) 91 (defvar font-lock-background-mode) ; not in Emacs
93 `(find-face ,arg)) 92 (defvar font-lock-display-type) ; ditto
94 (;;(and (fboundp 'face-list) 93 (defvar paren-backwards-message) ; Not in newer XEmacs?
95 ;; (face-list)) 94 (or (fboundp 'defgroup)
96 (fboundp 'face-list) 95 (defmacro defgroup (name val doc &rest arr)
97 `(member ,arg (and (fboundp 'face-list) 96 nil))
98 (face-list)))) 97 (or (fboundp 'custom-declare-variable)
99 (t 98 (defmacro defcustom (name val doc &rest arr)
100 `(boundp ,arg)))) 99 (` (defvar (, name) (, val) (, doc)))))
101 (defmacro cperl-make-face (arg descr) ; Takes unquoted arg 100 (or (and (fboundp 'custom-declare-variable)
102 (cond ((fboundp 'make-face) 101 (string< "19.31" emacs-version)) ; Checked with 19.30: defface does not work
103 `(make-face (quote ,arg))) 102 (defmacro defface (&rest arr)
104 (t 103 nil))
105 `(defvar ,arg (quote ,arg) ,descr)))) 104 ;; Avoid warning (tmp definitions)
106 (defmacro cperl-force-face (arg descr) ; Takes unquoted arg 105 (or (fboundp 'x-color-defined-p)
107 `(progn 106 (defmacro x-color-defined-p (col)
108 (or (cperl-is-face (quote ,arg)) 107 (cond ((fboundp 'color-defined-p) (` (color-defined-p (, col))))
109 (cperl-make-face ,arg ,descr)) 108 ;; XEmacs >= 19.12
110 (or (boundp (quote ,arg)) ; We use unquoted variants too 109 ((fboundp 'valid-color-name-p) (` (valid-color-name-p (, col))))
111 (defvar ,arg (quote ,arg) ,descr)))) 110 ;; XEmacs 19.11
112 (if cperl-xemacs-p 111 ((fboundp 'x-valid-color-name-p) (` (x-valid-color-name-p (, col))))
113 (defmacro cperl-etags-snarf-tag (file line) 112 (t '(error "Cannot implement color-defined-p")))))
114 `(progn 113 (defmacro cperl-is-face (arg) ; Takes quoted arg
115 (beginning-of-line 2) 114 (cond ((fboundp 'find-face)
116 (list ,file ,line))) 115 (` (find-face (, arg))))
117 (defmacro cperl-etags-snarf-tag (file line) 116 (;;(and (fboundp 'face-list)
118 `(etags-snarf-tag))) 117 ;; (face-list))
119 (if cperl-xemacs-p 118 (fboundp 'face-list)
120 (defmacro cperl-etags-goto-tag-location (elt) 119 (` (member (, arg) (and (fboundp 'face-list)
121 ;;(progn 120 (face-list)))))
122 ;; (switch-to-buffer (get-file-buffer (elt (, elt) 0))) 121 (t
123 ;; (set-buffer (get-file-buffer (elt (, elt) 0))) 122 (` (boundp (, arg))))))
124 ;; Probably will not work due to some save-excursion??? 123 (defmacro cperl-make-face (arg descr) ; Takes unquoted arg
125 ;; Or save-file-position? 124 (cond ((fboundp 'make-face)
126 ;; (message "Did I get to line %s?" (elt (, elt) 1)) 125 (` (make-face (quote (, arg)))))
127 `(goto-line (string-to-number (elt ,elt 1)))) 126 (t
128 ;;) 127 (` (defvar (, arg) (quote (, arg)) (, descr))))))
129 (defmacro cperl-etags-goto-tag-location (elt) 128 (defmacro cperl-force-face (arg descr) ; Takes unquoted arg
130 `(etags-goto-tag-location ,elt)))) 129 (` (progn
130 (or (cperl-is-face (quote (, arg)))
131 (cperl-make-face (, arg) (, descr)))
132 (or (boundp (quote (, arg))) ; We use unquoted variants too
133 (defvar (, arg) (quote (, arg)) (, descr))))))
134 (if cperl-xemacs-p
135 (defmacro cperl-etags-snarf-tag (file line)
136 (` (progn
137 (beginning-of-line 2)
138 (list (, file) (, line)))))
139 (defmacro cperl-etags-snarf-tag (file line)
140 (` (etags-snarf-tag))))
141 (if cperl-xemacs-p
142 (defmacro cperl-etags-goto-tag-location (elt)
143 (`;;(progn
144 ;; (switch-to-buffer (get-file-buffer (elt (, elt) 0)))
145 ;; (set-buffer (get-file-buffer (elt (, elt) 0)))
146 ;; Probably will not work due to some save-excursion???
147 ;; Or save-file-position?
148 ;; (message "Did I get to line %s?" (elt (, elt) 1))
149 (goto-line (string-to-int (elt (, elt) 1)))))
150 ;;)
151 (defmacro cperl-etags-goto-tag-location (elt)
152 (` (etags-goto-tag-location (, elt))))))
131 153
132(defconst cperl-xemacs-p (string-match "XEmacs\\|Lucid" emacs-version)) 154(defconst cperl-xemacs-p (string-match "XEmacs\\|Lucid" emacs-version))
133 155
@@ -251,6 +273,12 @@ This is in addition to cperl-continued-statement-offset."
251 :type 'integer 273 :type 'integer
252 :group 'cperl-indentation-details) 274 :group 'cperl-indentation-details)
253 275
276(defcustom cperl-indent-wrt-brace t
277 "*Non-nil means indent statements in if/etc block relative brace, not if/etc.
278Versions 5.2 ... 5.20 behaved as if this were `nil'."
279 :type 'boolean
280 :group 'cperl-indentation-details)
281
254(defcustom cperl-auto-newline nil 282(defcustom cperl-auto-newline nil
255 "*Non-nil means automatically newline before and after braces, 283 "*Non-nil means automatically newline before and after braces,
256and after colons and semicolons, inserted in CPerl code. The following 284and after colons and semicolons, inserted in CPerl code. The following
@@ -347,20 +375,26 @@ Affects: `cperl-font-lock', `cperl-electric-lbrace-space',
347 :type 'integer 375 :type 'integer
348 :group 'cperl-indentation-details) 376 :group 'cperl-indentation-details)
349 377
350(defvar cperl-vc-header-alist nil) 378(defcustom cperl-indent-comment-at-column-0 nil
351(make-obsolete-variable 379 "*Non-nil means that comment started at column 0 should be indentable."
352 'cperl-vc-header-alist 380 :type 'boolean
353 "use cperl-vc-rcs-header or cperl-vc-sccs-header instead.") 381 :group 'cperl-indentation-details)
354 382
355(defcustom cperl-vc-sccs-header '("($sccs) = ('%W\%' =~ /(\\d+(\\.\\d+)+)/) ;") 383(defcustom cperl-vc-sccs-header '("($sccs) = ('%W\%' =~ /(\\d+(\\.\\d+)+)/) ;")
356 "*Special version of `vc-sccs-header' that is used in CPerl mode buffers." 384 "*Special version of `vc-sccs-header' that is used in CPerl mode buffers."
357 :type '(repeat string) 385 :type '(repeat string)
358 :group 'cperl) 386 :group 'cperl)
359 387
360(defcustom cperl-vc-rcs-header '("($rcs) = (' $Id\$ ' =~ /(\\d+(\\.\\d+)+)/) ;") 388(defcustom cperl-vc-rcs-header '("($rcs) = (' $Id\$ ' =~ /(\\d+(\\.\\d+)+)/);")
361 "*Special version of `vc-rcs-header' that is used in CPerl mode buffers." 389 "*Special version of `vc-rcs-header' that is used in CPerl mode buffers."
362 :type '(repeat string) 390 :type '(repeat string)
363 :group 'cperl) 391 :group 'cperl)
392
393;; This became obsolete...
394(defvar cperl-vc-header-alist nil)
395(make-obsolete-variable
396 'cperl-vc-header-alist
397 "use cperl-vc-rcs-header or cperl-vc-sccs-header instead.")
364 398
365(defcustom cperl-clobber-mode-lists 399(defcustom cperl-clobber-mode-lists
366 (not 400 (not
@@ -408,8 +442,15 @@ Font for POD headers."
408 :type 'face 442 :type 'face
409 :group 'cperl-faces) 443 :group 'cperl-faces)
410 444
411(defcustom cperl-invalid-face 'underline 445;;; Some double-evaluation happened with font-locks... Needed with 21.2...
412 "*Face for highlighting trailing whitespace." 446(defvar cperl-singly-quote-face cperl-xemacs-p)
447
448(defcustom cperl-invalid-face ; Does not customize with '' on XEmacs
449 (if cperl-singly-quote-face
450 'underline ''underline) ; On older Emacsen was evaluated by `font-lock'
451 (if cperl-singly-quote-face
452 "*This face is used for highlighting trailing whitespace."
453 "*Face for highlighting trailing whitespace.")
413 :type 'face 454 :type 'face
414 :version "21.1" 455 :version "21.1"
415 :group 'cperl-faces) 456 :group 'cperl-faces)
@@ -441,7 +482,14 @@ You can always make lookup from menu or using \\[cperl-find-pods-heres]."
441 482
442(defcustom cperl-regexp-scan t 483(defcustom cperl-regexp-scan t
443 "*Not-nil means make marking of regular expression more thorough. 484 "*Not-nil means make marking of regular expression more thorough.
444Effective only with `cperl-pod-here-scan'. Not implemented yet." 485Effective only with `cperl-pod-here-scan'."
486 :type 'boolean
487 :group 'cperl-speed)
488
489(defcustom cperl-hook-after-change t
490 "*Not-nil means install hook to know which regions of buffer are changed.
491May significantly speed up delayed fontification. Changes take effect
492after reload."
445 :type 'boolean 493 :type 'boolean
446 :group 'cperl-speed) 494 :group 'cperl-speed)
447 495
@@ -564,17 +612,25 @@ when syntaxifying a chunk of buffer."
564 :type 'boolean 612 :type 'boolean
565 :group 'cperl-speed) 613 :group 'cperl-speed)
566 614
615(defcustom cperl-syntaxify-for-menu
616 t
617 "*Non-nil means that CPerl syntaxifies up to the point before showing menu.
618This way enabling/disabling of menu items is more correct."
619 :type 'boolean
620 :group 'cperl-speed)
621
567(defcustom cperl-ps-print-face-properties 622(defcustom cperl-ps-print-face-properties
568 '((font-lock-keyword-face nil nil bold shadow) 623 '((font-lock-keyword-face nil nil bold shadow)
569 (font-lock-variable-name-face nil nil bold) 624 (font-lock-variable-name-face nil nil bold)
570 (font-lock-function-name-face nil nil bold italic box) 625 (font-lock-function-name-face nil nil bold italic box)
571 (font-lock-constant-face nil "LightGray" bold) 626 (font-lock-constant-face nil "LightGray" bold)
572 (cperl-array nil "LightGray" bold underline) 627 (cperl-array-face nil "LightGray" bold underline)
573 (cperl-hash nil "LightGray" bold italic underline) 628 (cperl-hash-face nil "LightGray" bold italic underline)
574 (font-lock-comment-face nil "LightGray" italic) 629 (font-lock-comment-face nil "LightGray" italic)
575 (font-lock-string-face nil nil italic underline) 630 (font-lock-string-face nil nil italic underline)
576 (cperl-nonoverridable nil nil italic underline) 631 (cperl-nonoverridable-face nil nil italic underline)
577 (font-lock-type-face nil nil underline) 632 (font-lock-type-face nil nil underline)
633 (font-lock-warning-face nil "LightGray" bold italic box)
578 (underline nil "LightGray" strikeout)) 634 (underline nil "LightGray" strikeout))
579 "List given as an argument to `ps-extend-face-list' in `cperl-ps-print'." 635 "List given as an argument to `ps-extend-face-list' in `cperl-ps-print'."
580 :type '(repeat (cons symbol 636 :type '(repeat (cons symbol
@@ -588,7 +644,7 @@ when syntaxifying a chunk of buffer."
588(defvar cperl-dark-foreground 644(defvar cperl-dark-foreground
589 (cperl-choose-color "orchid1" "orange")) 645 (cperl-choose-color "orchid1" "orange"))
590 646
591(defface cperl-nonoverridable 647(defface cperl-nonoverridable-face
592 `((((class grayscale) (background light)) 648 `((((class grayscale) (background light))
593 (:background "Gray90" :slant italic :underline t)) 649 (:background "Gray90" :slant italic :underline t))
594 (((class grayscale) (background dark)) 650 (((class grayscale) (background dark))
@@ -600,10 +656,8 @@ when syntaxifying a chunk of buffer."
600 (t (:weight bold :underline t))) 656 (t (:weight bold :underline t)))
601 "Font Lock mode face used non-overridable keywords and modifiers of regexps." 657 "Font Lock mode face used non-overridable keywords and modifiers of regexps."
602 :group 'cperl-faces) 658 :group 'cperl-faces)
603;; backward-compatibility alias
604(put 'cperl-nonoverridable-face 'face-alias 'cperl-nonoverridable)
605 659
606(defface cperl-array 660(defface cperl-array-face
607 `((((class grayscale) (background light)) 661 `((((class grayscale) (background light))
608 (:background "Gray90" :weight bold)) 662 (:background "Gray90" :weight bold))
609 (((class grayscale) (background dark)) 663 (((class grayscale) (background dark))
@@ -615,10 +669,8 @@ when syntaxifying a chunk of buffer."
615 (t (:weight bold))) 669 (t (:weight bold)))
616 "Font Lock mode face used to highlight array names." 670 "Font Lock mode face used to highlight array names."
617 :group 'cperl-faces) 671 :group 'cperl-faces)
618;; backward-compatibility alias
619(put 'cperl-array-face 'face-alias 'cperl-array)
620 672
621(defface cperl-hash 673(defface cperl-hash-face
622 `((((class grayscale) (background light)) 674 `((((class grayscale) (background light))
623 (:background "Gray90" :weight bold :slant italic)) 675 (:background "Gray90" :weight bold :slant italic))
624 (((class grayscale) (background dark)) 676 (((class grayscale) (background dark))
@@ -630,8 +682,6 @@ when syntaxifying a chunk of buffer."
630 (t (:weight bold :slant italic))) 682 (t (:weight bold :slant italic)))
631 "Font Lock mode face used to highlight hash names." 683 "Font Lock mode face used to highlight hash names."
632 :group 'cperl-faces) 684 :group 'cperl-faces)
633;; backward-compatibility alias
634(put 'cperl-hash-face 'face-alias 'cperl-hash)
635 685
636 686
637 687
@@ -639,9 +689,7 @@ when syntaxifying a chunk of buffer."
639 689
640(defvar cperl-tips 'please-ignore-this-line 690(defvar cperl-tips 'please-ignore-this-line
641 "Get maybe newer version of this package from 691 "Get maybe newer version of this package from
642 ftp://ftp.math.ohio-state.edu/pub/users/ilya/emacs 692 http://ilyaz.org/software/emacs
643and/or
644 ftp://ftp.math.ohio-state.edu/pub/users/ilya/perl
645Subdirectory `cperl-mode' may contain yet newer development releases and/or 693Subdirectory `cperl-mode' may contain yet newer development releases and/or
646patches to related files. 694patches to related files.
647 695
@@ -666,9 +714,9 @@ want it to: put the following into your .emacs file:
666 (defalias 'perl-mode 'cperl-mode) 714 (defalias 'perl-mode 'cperl-mode)
667 715
668Get perl5-info from 716Get perl5-info from
669 $CPAN/doc/manual/info/perl-info.tar.gz 717 $CPAN/doc/manual/info/perl5-old/perl5-info.tar.gz
670older version was on 718Also, one can generate a newer documentation running `pod2texi' converter
671 http://www.metronet.com:70/9/perlinfo/perl5/manual/perl5-info.tar.gz 719 $CPAN/doc/manual/info/perl5/pod2texi-0.1.tar.gz
672 720
673If you use imenu-go, run imenu on perl5-info buffer (you can do it 721If you use imenu-go, run imenu on perl5-info buffer (you can do it
674from Perl menu). If many files are related, generate TAGS files from 722from Perl menu). If many files are related, generate TAGS files from
@@ -700,11 +748,18 @@ micro-docs on what I know about CPerl problems.")
700 "Description of problems in CPerl mode. 748 "Description of problems in CPerl mode.
701Some faces will not be shown on some versions of Emacs unless you 749Some faces will not be shown on some versions of Emacs unless you
702install choose-color.el, available from 750install choose-color.el, available from
703 ftp://ftp.math.ohio-state.edu/pub/users/ilya/emacs/ 751 http://ilyaz.org/software/emacs
704 752
705`fill-paragraph' on a comment may leave the point behind the 753`fill-paragraph' on a comment may leave the point behind the
706paragraph. Parsing of lines with several <<EOF is not implemented 754paragraph. It also triggers a bug in some versions of Emacs (CPerl tries
707yet. 755to detect it and bulk out).
756
757See documentation of a variable `cperl-problems-old-emaxen' for the
758problems which disappear if you upgrade Emacs to a reasonably new
759version (20.3 for Emacs, and those of 2004 for XEmacs).")
760
761(defvar cperl-problems-old-emaxen 'please-ignore-this-line
762 "Description of problems in CPerl mode specific for older Emacs versions.
708 763
709Emacs had a _very_ restricted syntax parsing engine until version 764Emacs had a _very_ restricted syntax parsing engine until version
71020.1. Most problems below are corrected starting from this version of 76520.1. Most problems below are corrected starting from this version of
@@ -812,6 +867,13 @@ voice);
812 o) Highlights trailing whitespace; 867 o) Highlights trailing whitespace;
813 p) Is able to manipulate Perl Regular Expressions to ease 868 p) Is able to manipulate Perl Regular Expressions to ease
814 conversion to a more readable form. 869 conversion to a more readable form.
870 q) Can ispell POD sections and HERE-DOCs.
871 r) Understands comments and character classes inside regular
872 expressions; can find matching () and [] in a regular expression.
873 s) Allows indentation of //x-style regular expressions;
874 t) Highlights different symbols in regular expressions according
875 to their function; much less problems with backslashitis;
876 u) Allows to find regular expressions which contain interpolated parts.
815 877
8165) The indentation engine was very smart, but most of tricks may be 8785) The indentation engine was very smart, but most of tricks may be
817not needed anymore with the support for `syntax-table' property. Has 879not needed anymore with the support for `syntax-table' property. Has
@@ -829,7 +891,10 @@ the settings present before the switch.
829line-breaks/spacing between elements of the construct. 891line-breaks/spacing between elements of the construct.
830 892
83110) Uses a linear-time algorith for indentation of regions (on Emaxen with 89310) Uses a linear-time algorith for indentation of regions (on Emaxen with
832capable syntax engines).") 894capable syntax engines).
895
89611) Syntax-highlight, indentation, sexp-recognition inside regular expressions.
897")
833 898
834(defvar cperl-speed 'please-ignore-this-line 899(defvar cperl-speed 'please-ignore-this-line
835 "This is an incomplete compendium of what is available in other parts 900 "This is an incomplete compendium of what is available in other parts
@@ -878,19 +943,19 @@ B) Speed of editing operations.
878(defvar cperl-tips-faces 'please-ignore-this-line 943(defvar cperl-tips-faces 'please-ignore-this-line
879 "CPerl mode uses following faces for highlighting: 944 "CPerl mode uses following faces for highlighting:
880 945
881 `cperl-array' Array names 946 `cperl-array-face' Array names
882 `cperl-hash' Hash names 947 `cperl-hash-face' Hash names
883 `font-lock-comment-face' Comments, PODs and whatever is considered 948 `font-lock-comment-face' Comments, PODs and whatever is considered
884 syntaxically to be not code 949 syntaxically to be not code
885 `font-lock-constant-face' HERE-doc delimiters, labels, delimiters of 950 `font-lock-constant-face' HERE-doc delimiters, labels, delimiters of
886 2-arg operators s/y/tr/ or of RExen, 951 2-arg operators s/y/tr/ or of RExen,
887 `font-lock-function-name-face' Special-cased m// and s//foo/, _ as 952 `font-lock-warning-face' Special-cased m// and s//foo/,
888 a target of a file tests, file tests, 953 `font-lock-function-name-face' _ as a target of a file tests, file tests,
889 subroutine names at the moment of definition 954 subroutine names at the moment of definition
890 (except those conflicting with Perl operators), 955 (except those conflicting with Perl operators),
891 package names (when recognized), format names 956 package names (when recognized), format names
892 `font-lock-keyword-face' Control flow switch constructs, declarators 957 `font-lock-keyword-face' Control flow switch constructs, declarators
893 `cperl-nonoverridable' Non-overridable keywords, modifiers of RExen 958 `cperl-nonoverridable-face' Non-overridable keywords, modifiers of RExen
894 `font-lock-string-face' Strings, qw() constructs, RExen, POD sections, 959 `font-lock-string-face' Strings, qw() constructs, RExen, POD sections,
895 literal parts and the terminator of formats 960 literal parts and the terminator of formats
896 and whatever is syntaxically considered 961 and whatever is syntaxically considered
@@ -908,7 +973,25 @@ m// and s/// which do not do what one would expect them to do.
908Help with best setup of these faces for printout requested (for each of 973Help with best setup of these faces for printout requested (for each of
909the faces: please specify bold, italic, underline, shadow and box.) 974the faces: please specify bold, italic, underline, shadow and box.)
910 975
911\(Not finished.)") 976In regular expressions (except character classes):
977 `font-lock-string-face' \"Normal\" stuff and non-0-length constructs
978 `font-lock-constant-face': Delimiters
979 `font-lock-warning-face' Special-cased m// and s//foo/,
980 Mismatched closing delimiters, parens
981 we couldn't match, misplaced quantifiers,
982 unrecognized escape sequences
983 `cperl-nonoverridable-face' Modifiers, as gism in m/REx/gism
984 `font-lock-type-face' POSIX classes inside charclasses,
985 escape sequences with arguments (\x \23 \p \N)
986 and others match-a-char escape sequences
987 `font-lock-keyword-face' Capturing parens, and |
988 `font-lock-function-name-face' Special symbols: $ ^ . [ ] [^ ] (?{ }) (??{ })
989 `font-lock-builtin-face' \"Remaining\" 0-length constructs, executable
990 parts of a REx, not-capturing parens
991 `font-lock-variable-name-face' Interpolated constructs, embedded code
992 `font-lock-comment-face' Embedded comments
993
994")
912 995
913 996
914 997
@@ -985,6 +1068,25 @@ the faces: please specify bold, italic, underline, shadow and box.)
985 (cperl-hairy (or hairy t)) 1068 (cperl-hairy (or hairy t))
986 (t (symbol-value symbol)))) 1069 (t (symbol-value symbol))))
987 1070
1071
1072(defun cperl-make-indent (column &optional minimum keep)
1073 "Makes indent of the current line the requested amount.
1074Unless KEEP, removes the old indentation. Works around a bug in ancient
1075versions of Emacs."
1076 (let ((prop (get-text-property (point) 'syntax-type)))
1077 (or keep
1078 (delete-horizontal-space))
1079 (indent-to column minimum)
1080 ;; In old versions (e.g., 19.33) `indent-to' would not inherit properties
1081 (and prop
1082 (> (current-column) 0)
1083 (save-excursion
1084 (beginning-of-line)
1085 (or (get-text-property (point) 'syntax-type)
1086 (and (looking-at "\\=[ \t]")
1087 (put-text-property (point) (match-end 0)
1088 'syntax-type prop)))))))
1089
988;;; Probably it is too late to set these guys already, but it can help later: 1090;;; Probably it is too late to set these guys already, but it can help later:
989 1091
990;;;(and cperl-clobber-mode-lists 1092;;;(and cperl-clobber-mode-lists
@@ -1035,7 +1137,16 @@ the faces: please specify bold, italic, underline, shadow and box.)
1035 (cperl-define-key "\C-c\C-w" 'cperl-toggle-construct-fix) 1137 (cperl-define-key "\C-c\C-w" 'cperl-toggle-construct-fix)
1036 (cperl-define-key "\C-c\C-f" 'auto-fill-mode) 1138 (cperl-define-key "\C-c\C-f" 'auto-fill-mode)
1037 (cperl-define-key "\C-c\C-e" 'cperl-toggle-electric) 1139 (cperl-define-key "\C-c\C-e" 'cperl-toggle-electric)
1140 (cperl-define-key "\C-c\C-b" 'cperl-find-bad-style)
1141 (cperl-define-key "\C-c\C-p" 'cperl-pod-spell)
1142 (cperl-define-key "\C-c\C-d" 'cperl-here-doc-spell)
1143 (cperl-define-key "\C-c\C-n" 'cperl-narrow-to-here-doc)
1144 (cperl-define-key "\C-c\C-v" 'cperl-next-interpolated-REx)
1145 (cperl-define-key "\C-c\C-x" 'cperl-next-interpolated-REx-0)
1146 (cperl-define-key "\C-c\C-y" 'cperl-next-interpolated-REx-1)
1038 (cperl-define-key "\C-c\C-ha" 'cperl-toggle-autohelp) 1147 (cperl-define-key "\C-c\C-ha" 'cperl-toggle-autohelp)
1148 (cperl-define-key "\C-c\C-hp" 'cperl-perldoc)
1149 (cperl-define-key "\C-c\C-hP" 'cperl-perldoc-at-point)
1039 (cperl-define-key "\e\C-q" 'cperl-indent-exp) ; Usually not bound 1150 (cperl-define-key "\e\C-q" 'cperl-indent-exp) ; Usually not bound
1040 (cperl-define-key [?\C-\M-\|] 'cperl-lineup 1151 (cperl-define-key [?\C-\M-\|] 'cperl-lineup
1041 [(control meta |)]) 1152 [(control meta |)])
@@ -1074,9 +1185,13 @@ the faces: please specify bold, italic, underline, shadow and box.)
1074 (<= emacs-minor-version 11) (<= emacs-major-version 19)) 1185 (<= emacs-minor-version 11) (<= emacs-major-version 19))
1075 (progn 1186 (progn
1076 ;; substitute-key-definition is usefulness-deenhanced... 1187 ;; substitute-key-definition is usefulness-deenhanced...
1077 (cperl-define-key "\M-q" 'cperl-fill-paragraph) 1188 ;;;;;(cperl-define-key "\M-q" 'cperl-fill-paragraph)
1078 (cperl-define-key "\e;" 'cperl-indent-for-comment) 1189 (cperl-define-key "\e;" 'cperl-indent-for-comment)
1079 (cperl-define-key "\e\C-\\" 'cperl-indent-region)) 1190 (cperl-define-key "\e\C-\\" 'cperl-indent-region))
1191 (or (boundp 'fill-paragraph-function)
1192 (substitute-key-definition
1193 'fill-paragraph 'cperl-fill-paragraph
1194 cperl-mode-map global-map))
1080 (substitute-key-definition 1195 (substitute-key-definition
1081 'indent-sexp 'cperl-indent-exp 1196 'indent-sexp 'cperl-indent-exp
1082 cperl-mode-map global-map) 1197 cperl-mode-map global-map)
@@ -1094,52 +1209,101 @@ the faces: please specify bold, italic, underline, shadow and box.)
1094 (progn 1209 (progn
1095 (require 'easymenu) 1210 (require 'easymenu)
1096 (easy-menu-define 1211 (easy-menu-define
1097 cperl-menu cperl-mode-map "Menu for CPerl mode" 1212 cperl-menu cperl-mode-map "Menu for CPerl mode"
1098 '("Perl" 1213 '("Perl"
1099 ["Beginning of function" beginning-of-defun t] 1214 ["Beginning of function" beginning-of-defun t]
1100 ["End of function" end-of-defun t] 1215 ["End of function" end-of-defun t]
1101 ["Mark function" mark-defun t] 1216 ["Mark function" mark-defun t]
1102 ["Indent expression" cperl-indent-exp t] 1217 ["Indent expression" cperl-indent-exp t]
1103 ["Fill paragraph/comment" fill-paragraph t] 1218 ["Fill paragraph/comment" fill-paragraph t]
1219 "----"
1220 ["Line up a construction" cperl-lineup (cperl-use-region-p)]
1221 ["Invert if/unless/while etc" cperl-invert-if-unless t]
1222 ("Regexp"
1223 ["Beautify" cperl-beautify-regexp
1224 cperl-use-syntax-table-text-property]
1225 ["Beautify one level deep" (cperl-beautify-regexp 1)
1226 cperl-use-syntax-table-text-property]
1227 ["Beautify a group" cperl-beautify-level
1228 cperl-use-syntax-table-text-property]
1229 ["Beautify a group one level deep" (cperl-beautify-level 1)
1230 cperl-use-syntax-table-text-property]
1231 ["Contract a group" cperl-contract-level
1232 cperl-use-syntax-table-text-property]
1233 ["Contract groups" cperl-contract-levels
1234 cperl-use-syntax-table-text-property]
1104 "----" 1235 "----"
1105 ["Line up a construction" cperl-lineup (cperl-use-region-p)] 1236 ["Find next interpolated" cperl-next-interpolated-REx
1106 ["Invert if/unless/while etc" cperl-invert-if-unless t] 1237 (next-single-property-change (point-min) 'REx-interpolated)]
1107 ("Regexp" 1238 ["Find next interpolated (no //o)"
1108 ["Beautify" cperl-beautify-regexp 1239 cperl-next-interpolated-REx-0
1109 cperl-use-syntax-table-text-property] 1240 (or (text-property-any (point-min) (point-max) 'REx-interpolated t)
1110 ["Beautify one level deep" (cperl-beautify-regexp 1) 1241 (text-property-any (point-min) (point-max) 'REx-interpolated 1))]
1111 cperl-use-syntax-table-text-property] 1242 ["Find next interpolated (neither //o nor whole-REx)"
1112 ["Beautify a group" cperl-beautify-level 1243 cperl-next-interpolated-REx-1
1113 cperl-use-syntax-table-text-property] 1244 (text-property-any (point-min) (point-max) 'REx-interpolated t)])
1114 ["Beautify a group one level deep" (cperl-beautify-level 1) 1245 ["Insert spaces if needed to fix style" cperl-find-bad-style t]
1115 cperl-use-syntax-table-text-property] 1246 ["Refresh \"hard\" constructions" cperl-find-pods-heres t]
1116 ["Contract a group" cperl-contract-level 1247 "----"
1117 cperl-use-syntax-table-text-property] 1248 ["Indent region" cperl-indent-region (cperl-use-region-p)]
1118 ["Contract groups" cperl-contract-levels 1249 ["Comment region" cperl-comment-region (cperl-use-region-p)]
1119 cperl-use-syntax-table-text-property]) 1250 ["Uncomment region" cperl-uncomment-region (cperl-use-region-p)]
1120 ["Refresh \"hard\" constructions" cperl-find-pods-heres t] 1251 "----"
1252 ["Run" mode-compile (fboundp 'mode-compile)]
1253 ["Kill" mode-compile-kill (and (fboundp 'mode-compile-kill)
1254 (get-buffer "*compilation*"))]
1255 ["Next error" next-error (get-buffer "*compilation*")]
1256 ["Check syntax" cperl-check-syntax (fboundp 'mode-compile)]
1257 "----"
1258 ["Debugger" cperl-db t]
1259 "----"
1260 ("Tools"
1261 ["Imenu" imenu (fboundp 'imenu)]
1262 ["Imenu on Perl Info" cperl-imenu-on-info (featurep 'imenu)]
1121 "----" 1263 "----"
1122 ["Indent region" cperl-indent-region (cperl-use-region-p)] 1264 ["Ispell PODs" cperl-pod-spell
1123 ["Comment region" cperl-comment-region (cperl-use-region-p)] 1265 ;; Better not to update syntaxification here:
1124 ["Uncomment region" cperl-uncomment-region (cperl-use-region-p)] 1266 ;; debugging syntaxificatio can be broken by this???
1267 (or
1268 (get-text-property (point-min) 'in-pod)
1269 (< (progn
1270 (and cperl-syntaxify-for-menu
1271 (cperl-update-syntaxification (point-max) (point-max)))
1272 (next-single-property-change (point-min) 'in-pod nil (point-max)))
1273 (point-max)))]
1274 ["Ispell HERE-DOCs" cperl-here-doc-spell
1275 (< (progn
1276 (and cperl-syntaxify-for-menu
1277 (cperl-update-syntaxification (point-max) (point-max)))
1278 (next-single-property-change (point-min) 'here-doc-group nil (point-max)))
1279 (point-max))]
1280 ["Narrow to this HERE-DOC" cperl-narrow-to-here-doc
1281 (eq 'here-doc (progn
1282 (and cperl-syntaxify-for-menu
1283 (cperl-update-syntaxification (point) (point)))
1284 (get-text-property (point) 'syntax-type)))]
1285 ["Select this HERE-DOC or POD section"
1286 cperl-select-this-pod-or-here-doc
1287 (memq (progn
1288 (and cperl-syntaxify-for-menu
1289 (cperl-update-syntaxification (point) (point)))
1290 (get-text-property (point) 'syntax-type))
1291 '(here-doc pod))]
1125 "----" 1292 "----"
1126 ["Run" mode-compile (fboundp 'mode-compile)] 1293 ["CPerl pretty print (exprmntl)" cperl-ps-print
1127 ["Kill" mode-compile-kill (and (fboundp 'mode-compile-kill) 1294 (fboundp 'ps-extend-face-list)]
1128 (get-buffer "*compilation*"))]
1129 ["Next error" next-error (get-buffer "*compilation*")]
1130 ["Check syntax" cperl-check-syntax (fboundp 'mode-compile)]
1131 "----" 1295 "----"
1132 ["Debugger" cperl-db t] 1296 ["Syntaxify region" cperl-find-pods-heres-region
1297 (cperl-use-region-p)]
1298 ["Profile syntaxification" cperl-time-fontification t]
1299 ["Debug errors in delayed fontification" cperl-emulate-lazy-lock t]
1300 ["Debug unwind for syntactic scan" cperl-toggle-set-debug-unwind t]
1301 ["Debug backtrace on syntactic scan (BEWARE!!!)"
1302 (cperl-toggle-set-debug-unwind nil t) t]
1133 "----" 1303 "----"
1134 ("Tools" 1304 ["Class Hierarchy from TAGS" cperl-tags-hier-init t]
1135 ["Imenu" imenu (fboundp 'imenu)] 1305 ;;["Update classes" (cperl-tags-hier-init t) tags-table-list]
1136 ["Insert spaces if needed" cperl-find-bad-style t] 1306 ("Tags"
1137 ["Class Hierarchy from TAGS" cperl-tags-hier-init t]
1138 ;;["Update classes" (cperl-tags-hier-init t) tags-table-list]
1139 ["CPerl pretty print (exprmntl)" cperl-ps-print
1140 (fboundp 'ps-extend-face-list)]
1141 ["Imenu on info" cperl-imenu-on-info (featurep 'imenu)]
1142 ("Tags"
1143;;; ["Create tags for current file" cperl-etags t] 1307;;; ["Create tags for current file" cperl-etags t]
1144;;; ["Add tags for current file" (cperl-etags t) t] 1308;;; ["Add tags for current file" (cperl-etags t) t]
1145;;; ["Create tags for Perl files in directory" (cperl-etags nil t) t] 1309;;; ["Create tags for Perl files in directory" (cperl-etags nil t) t]
@@ -1186,10 +1350,10 @@ the faces: please specify bold, italic, underline, shadow and box.)
1186 ["PerlStyle" (cperl-set-style "PerlStyle") t] 1350 ["PerlStyle" (cperl-set-style "PerlStyle") t]
1187 ["GNU" (cperl-set-style "GNU") t] 1351 ["GNU" (cperl-set-style "GNU") t]
1188 ["C++" (cperl-set-style "C++") t] 1352 ["C++" (cperl-set-style "C++") t]
1189 ["FSF" (cperl-set-style "FSF") t] 1353 ["K&R" (cperl-set-style "K&R") t]
1190 ["BSD" (cperl-set-style "BSD") t] 1354 ["BSD" (cperl-set-style "BSD") t]
1191 ["Whitesmith" (cperl-set-style "Whitesmith") t] 1355 ["Whitesmith" (cperl-set-style "Whitesmith") t]
1192 ["Current" (cperl-set-style "Current") t] 1356 ["Memorize Current" (cperl-set-style "Current") t]
1193 ["Memorized" (cperl-set-style-back) cperl-old-style]) 1357 ["Memorized" (cperl-set-style-back) cperl-old-style])
1194 ("Micro-docs" 1358 ("Micro-docs"
1195 ["Tips" (describe-variable 'cperl-tips) t] 1359 ["Tips" (describe-variable 'cperl-tips) t]
@@ -1208,12 +1372,73 @@ the faces: please specify bold, italic, underline, shadow and box.)
1208The expansion is entirely correct because it uses the C preprocessor." 1372The expansion is entirely correct because it uses the C preprocessor."
1209 t) 1373 t)
1210 1374
1375;;; These two must be unwound, otherwise take exponential time
1376(defconst cperl-maybe-white-and-comment-rex "[ \t\n]*\\(#[^\n]*\n[ \t\n]*\\)*"
1377"Regular expression to match optional whitespace with interpspersed comments.
1378Should contain exactly one group.")
1379
1380;;; This one is tricky to unwind; still very inefficient...
1381(defconst cperl-white-and-comment-rex "\\([ \t\n]\\|#[^\n]*\n\\)+"
1382"Regular expression to match whitespace with interpspersed comments.
1383Should contain exactly one group.")
1384
1385
1386;;; Is incorporated in `cperl-imenu--function-name-regexp-perl'
1387;;; `cperl-outline-regexp', `defun-prompt-regexp'.
1388;;; Details of groups in this may be used in several functions; see comments
1389;;; near mentioned above variable(s)...
1390;;; sub($$):lvalue{} sub:lvalue{} Both allowed...
1391(defsubst cperl-after-sub-regexp (named attr) ; 9 groups without attr...
1392 "Match the text after `sub' in a subroutine declaration.
1393If NAMED is nil, allows anonymous subroutines. Matches up to the first \":\"
1394of attributes (if present), or end of the name or prototype (whatever is
1395the last)."
1396 (concat ; Assume n groups before this...
1397 "\\(" ; n+1=name-group
1398 cperl-white-and-comment-rex ; n+2=pre-name
1399 "\\(::[a-zA-Z_0-9:']+\\|[a-zA-Z_'][a-zA-Z_0-9:']*\\)" ; n+3=name
1400 "\\)" ; END n+1=name-group
1401 (if named "" "?")
1402 "\\(" ; n+4=proto-group
1403 cperl-maybe-white-and-comment-rex ; n+5=pre-proto
1404 "\\(([^()]*)\\)" ; n+6=prototype
1405 "\\)?" ; END n+4=proto-group
1406 "\\(" ; n+7=attr-group
1407 cperl-maybe-white-and-comment-rex ; n+8=pre-attr
1408 "\\(" ; n+9=start-attr
1409 ":"
1410 (if attr (concat
1411 "\\("
1412 cperl-maybe-white-and-comment-rex ; whitespace-comments
1413 "\\(\\sw\\|_\\)+" ; attr-name
1414 ;; attr-arg (1 level of internal parens allowed!)
1415 "\\((\\(\\\\.\\|[^\\\\()]\\|([^\\\\()]*)\\)*)\\)?"
1416 "\\(" ; optional : (XXX allows trailing???)
1417 cperl-maybe-white-and-comment-rex ; whitespace-comments
1418 ":\\)?"
1419 "\\)+")
1420 "[^:]")
1421 "\\)"
1422 "\\)?" ; END n+6=proto-group
1423 ))
1424
1425;;; Details of groups in this are used in `cperl-imenu--create-perl-index'
1426;;; and `cperl-outline-level'.
1427;;;; Was: 2=sub|package; now 2=package-group, 5=package-name 8=sub-name (+3)
1211(defvar cperl-imenu--function-name-regexp-perl 1428(defvar cperl-imenu--function-name-regexp-perl
1212 (concat 1429 (concat
1213 "^\\(" 1430 "^\\(" ; 1 = all
1214 "[ \t]*\\(sub\\|package\\)[ \t\n]+\\([a-zA-Z_0-9:']+\\)[ \t]*\\(([^()]*)[ \t]*\\)?" 1431 "\\([ \t]*package" ; 2 = package-group
1215 "\\|" 1432 "\\(" ; 3 = package-name-group
1216 "=head\\([12]\\)[ \t]+\\([^\n]+\\)$" 1433 cperl-white-and-comment-rex ; 4 = pre-package-name
1434 "\\([a-zA-Z_0-9:']+\\)\\)?\\)" ; 5 = package-name
1435 "\\|"
1436 "[ \t]*sub"
1437 (cperl-after-sub-regexp 'named nil) ; 8=name 11=proto 14=attr-start
1438 cperl-maybe-white-and-comment-rex ; 15=pre-block
1439 "\\|"
1440 "=head\\([1-4]\\)[ \t]+" ; 16=level
1441 "\\([^\n]+\\)$" ; 17=text
1217 "\\)")) 1442 "\\)"))
1218 1443
1219(defvar cperl-outline-regexp 1444(defvar cperl-outline-regexp
@@ -1225,6 +1450,12 @@ The expansion is entirely correct because it uses the C preprocessor."
1225(defvar cperl-string-syntax-table nil 1450(defvar cperl-string-syntax-table nil
1226 "Syntax table in use in CPerl mode string-like chunks.") 1451 "Syntax table in use in CPerl mode string-like chunks.")
1227 1452
1453(defsubst cperl-1- (p)
1454 (max (point-min) (1- p)))
1455
1456(defsubst cperl-1+ (p)
1457 (min (point-max) (1+ p)))
1458
1228(if cperl-mode-syntax-table 1459(if cperl-mode-syntax-table
1229 () 1460 ()
1230 (setq cperl-mode-syntax-table (make-syntax-table)) 1461 (setq cperl-mode-syntax-table (make-syntax-table))
@@ -1249,6 +1480,8 @@ The expansion is entirely correct because it uses the C preprocessor."
1249 (modify-syntax-entry ?| "." cperl-mode-syntax-table) 1480 (modify-syntax-entry ?| "." cperl-mode-syntax-table)
1250 (setq cperl-string-syntax-table (copy-syntax-table cperl-mode-syntax-table)) 1481 (setq cperl-string-syntax-table (copy-syntax-table cperl-mode-syntax-table))
1251 (modify-syntax-entry ?$ "." cperl-string-syntax-table) 1482 (modify-syntax-entry ?$ "." cperl-string-syntax-table)
1483 (modify-syntax-entry ?\{ "." cperl-string-syntax-table)
1484 (modify-syntax-entry ?\} "." cperl-string-syntax-table)
1252 (modify-syntax-entry ?# "." cperl-string-syntax-table)) ; (?# comment ) 1485 (modify-syntax-entry ?# "." cperl-string-syntax-table)) ; (?# comment )
1253 1486
1254 1487
@@ -1257,6 +1490,10 @@ The expansion is entirely correct because it uses the C preprocessor."
1257;; Fix for msb.el 1490;; Fix for msb.el
1258(defvar cperl-msb-fixed nil) 1491(defvar cperl-msb-fixed nil)
1259(defvar cperl-use-major-mode 'cperl-mode) 1492(defvar cperl-use-major-mode 'cperl-mode)
1493(defvar cperl-font-lock-multiline-start nil)
1494(defvar cperl-font-lock-multiline nil)
1495(defvar cperl-compilation-error-regexp-alist nil)
1496(defvar cperl-font-locking nil)
1260 1497
1261;;;###autoload 1498;;;###autoload
1262(defun cperl-mode () 1499(defun cperl-mode ()
@@ -1402,16 +1639,24 @@ Variables controlling indentation style:
1402 `cperl-min-label-indent' 1639 `cperl-min-label-indent'
1403 Minimal indentation for line that is a label. 1640 Minimal indentation for line that is a label.
1404 1641
1405Settings for K&R and BSD indentation styles are 1642Settings for classic indent-styles: K&R BSD=C++ GNU PerlStyle=Whitesmith
1406 `cperl-indent-level' 5 8 1643 `cperl-indent-level' 5 4 2 4
1407 `cperl-continued-statement-offset' 5 8 1644 `cperl-brace-offset' 0 0 0 0
1408 `cperl-brace-offset' -5 -8 1645 `cperl-continued-brace-offset' -5 -4 0 0
1409 `cperl-label-offset' -5 -8 1646 `cperl-label-offset' -5 -4 -2 -4
1647 `cperl-continued-statement-offset' 5 4 2 4
1410 1648
1411CPerl knows several indentation styles, and may bulk set the 1649CPerl knows several indentation styles, and may bulk set the
1412corresponding variables. Use \\[cperl-set-style] to do this. Use 1650corresponding variables. Use \\[cperl-set-style] to do this. Use
1413\\[cperl-set-style-back] to restore the memorized preexisting values 1651\\[cperl-set-style-back] to restore the memorized preexisting values
1414\(both available from menu). 1652\(both available from menu). See examples in `cperl-style-examples'.
1653
1654Part of the indentation style is how different parts of if/elsif/else
1655statements are broken into lines; in CPerl, this is reflected on how
1656templates for these constructs are created (controlled by
1657`cperl-extra-newline-before-brace'), and how reflow-logic should treat \"continuation\" blocks of else/elsif/continue, controlled by the same variable,
1658and by `cperl-extra-newline-before-brace-multiline',
1659`cperl-merge-trailing-else', `cperl-indent-region-fix-constructs'.
1415 1660
1416If `cperl-indent-level' is 0, the statement after opening brace in 1661If `cperl-indent-level' is 0, the statement after opening brace in
1417column 0 is indented on 1662column 0 is indented on
@@ -1465,8 +1710,12 @@ or as help on variables `cperl-tips', `cperl-problems',
1465 ("head2" "head2" cperl-electric-pod 0))) 1710 ("head2" "head2" cperl-electric-pod 0)))
1466 (setq abbrevs-changed prev-a-c))) 1711 (setq abbrevs-changed prev-a-c)))
1467 (setq local-abbrev-table cperl-mode-abbrev-table) 1712 (setq local-abbrev-table cperl-mode-abbrev-table)
1468 (abbrev-mode (if (cperl-val 'cperl-electric-keywords) 1 0)) 1713 (if (cperl-val 'cperl-electric-keywords)
1714 (abbrev-mode 1))
1469 (set-syntax-table cperl-mode-syntax-table) 1715 (set-syntax-table cperl-mode-syntax-table)
1716 ;; Until Emacs is multi-threaded, we do not actually need it local:
1717 (make-local-variable 'cperl-font-lock-multiline-start)
1718 (make-local-variable 'cperl-font-locking)
1470 (make-local-variable 'outline-regexp) 1719 (make-local-variable 'outline-regexp)
1471 ;; (setq outline-regexp imenu-example--function-name-regexp-perl) 1720 ;; (setq outline-regexp imenu-example--function-name-regexp-perl)
1472 (setq outline-regexp cperl-outline-regexp) 1721 (setq outline-regexp cperl-outline-regexp)
@@ -1478,7 +1727,10 @@ or as help on variables `cperl-tips', `cperl-problems',
1478 (setq paragraph-separate paragraph-start) 1727 (setq paragraph-separate paragraph-start)
1479 (make-local-variable 'paragraph-ignore-fill-prefix) 1728 (make-local-variable 'paragraph-ignore-fill-prefix)
1480 (setq paragraph-ignore-fill-prefix t) 1729 (setq paragraph-ignore-fill-prefix t)
1481 (set (make-local-variable 'fill-paragraph-function) 'cperl-fill-paragraph) 1730 (if cperl-xemacs-p
1731 (progn
1732 (make-local-variable 'paren-backwards-message)
1733 (set 'paren-backwards-message t)))
1482 (make-local-variable 'indent-line-function) 1734 (make-local-variable 'indent-line-function)
1483 (setq indent-line-function 'cperl-indent-line) 1735 (setq indent-line-function 'cperl-indent-line)
1484 (make-local-variable 'require-final-newline) 1736 (make-local-variable 'require-final-newline)
@@ -1492,9 +1744,22 @@ or as help on variables `cperl-tips', `cperl-problems',
1492 (make-local-variable 'comment-start-skip) 1744 (make-local-variable 'comment-start-skip)
1493 (setq comment-start-skip "#+ *") 1745 (setq comment-start-skip "#+ *")
1494 (make-local-variable 'defun-prompt-regexp) 1746 (make-local-variable 'defun-prompt-regexp)
1495 (setq defun-prompt-regexp "^[ \t]*sub[ \t\n]+\\([^ \t\n{(;]+\\)\\([ \t\n]*([^()]*)[ \t\n]*\\)?[ \t\n]*") 1747;;; "[ \t]*sub"
1748;;; (cperl-after-sub-regexp 'named nil) ; 8=name 11=proto 14=attr-start
1749;;; cperl-maybe-white-and-comment-rex ; 15=pre-block
1750 (setq defun-prompt-regexp
1751 (concat "^[ \t]*\\(sub"
1752 (cperl-after-sub-regexp 'named 'attr-groups)
1753 "\\|" ; per toke.c
1754 "\\(BEGIN\\|CHECK\\|INIT\\|END\\|AUTOLOAD\\|DESTROY\\)"
1755 "\\)"
1756 cperl-maybe-white-and-comment-rex))
1496 (make-local-variable 'comment-indent-function) 1757 (make-local-variable 'comment-indent-function)
1497 (setq comment-indent-function 'cperl-comment-indent) 1758 (setq comment-indent-function 'cperl-comment-indent)
1759 (and (boundp 'fill-paragraph-function)
1760 (progn
1761 (make-local-variable 'fill-paragraph-function)
1762 (set 'fill-paragraph-function 'cperl-fill-paragraph)))
1498 (make-local-variable 'parse-sexp-ignore-comments) 1763 (make-local-variable 'parse-sexp-ignore-comments)
1499 (setq parse-sexp-ignore-comments t) 1764 (setq parse-sexp-ignore-comments t)
1500 (make-local-variable 'indent-region-function) 1765 (make-local-variable 'indent-region-function)
@@ -1509,21 +1774,40 @@ or as help on variables `cperl-tips', `cperl-problems',
1509 (set 'vc-rcs-header cperl-vc-rcs-header) 1774 (set 'vc-rcs-header cperl-vc-rcs-header)
1510 (make-local-variable 'vc-sccs-header) 1775 (make-local-variable 'vc-sccs-header)
1511 (set 'vc-sccs-header cperl-vc-sccs-header) 1776 (set 'vc-sccs-header cperl-vc-sccs-header)
1777 ;; This one is obsolete...
1778 (make-local-variable 'vc-header-alist)
1779 (set 'vc-header-alist (or cperl-vc-header-alist ; Avoid warning
1780 (` ((SCCS (, (car cperl-vc-sccs-header)))
1781 (RCS (, (car cperl-vc-rcs-header)))))))
1782 (cond ((boundp 'compilation-error-regexp-alist-alist);; xemacs 20.x
1783 (make-local-variable 'compilation-error-regexp-alist-alist)
1784 (set 'compilation-error-regexp-alist-alist
1785 (cons (cons 'cperl cperl-compilation-error-regexp-alist)
1786 (symbol-value 'compilation-error-regexp-alist-alist)))
1787 (if (fboundp 'compilation-build-compilation-error-regexp-alist)
1788 (let ((f 'compilation-build-compilation-error-regexp-alist))
1789 (funcall f))
1790 (push 'cperl compilation-error-regexp-alist)))
1791 ((boundp 'compilation-error-regexp-alist);; xmeacs 19.x
1792 (make-local-variable 'compilation-error-regexp-alist)
1793 (set 'compilation-error-regexp-alist
1794 (cons cperl-compilation-error-regexp-alist
1795 (symbol-value 'compilation-error-regexp-alist)))))
1512 (make-local-variable 'font-lock-defaults) 1796 (make-local-variable 'font-lock-defaults)
1513 (setq font-lock-defaults 1797 (setq font-lock-defaults
1514 (cond 1798 (cond
1515 ((string< emacs-version "19.30") 1799 ((string< emacs-version "19.30")
1516 '(cperl-font-lock-keywords-2)) 1800 '(cperl-font-lock-keywords-2 nil nil ((?_ . "w"))))
1517 ((string< emacs-version "19.33") ; Which one to use? 1801 ((string< emacs-version "19.33") ; Which one to use?
1518 '((cperl-font-lock-keywords 1802 '((cperl-font-lock-keywords
1519 cperl-font-lock-keywords-1 1803 cperl-font-lock-keywords-1
1520 cperl-font-lock-keywords-2))) 1804 cperl-font-lock-keywords-2) nil nil ((?_ . "w"))))
1521 (t 1805 (t
1522 '((cperl-load-font-lock-keywords 1806 '((cperl-load-font-lock-keywords
1523 cperl-load-font-lock-keywords-1 1807 cperl-load-font-lock-keywords-1
1524 cperl-load-font-lock-keywords-2) 1808 cperl-load-font-lock-keywords-2) nil nil ((?_ . "w"))))))
1525 nil nil ((?_ . "w"))))))
1526 (make-local-variable 'cperl-syntax-state) 1809 (make-local-variable 'cperl-syntax-state)
1810 (setq cperl-syntax-state nil) ; reset syntaxification cache
1527 (if cperl-use-syntax-table-text-property 1811 (if cperl-use-syntax-table-text-property
1528 (progn 1812 (progn
1529 (make-local-variable 'parse-sexp-lookup-properties) 1813 (make-local-variable 'parse-sexp-lookup-properties)
@@ -1533,10 +1817,12 @@ or as help on variables `cperl-tips', `cperl-problems',
1533 (or (boundp 'font-lock-unfontify-region-function) 1817 (or (boundp 'font-lock-unfontify-region-function)
1534 (set 'font-lock-unfontify-region-function 1818 (set 'font-lock-unfontify-region-function
1535 'font-lock-default-unfontify-region)) 1819 'font-lock-default-unfontify-region))
1536 (make-local-variable 'font-lock-unfontify-region-function) 1820 (unless cperl-xemacs-p ; Our: just a plug for wrong font-lock
1537 (set 'font-lock-unfontify-region-function ; not present with old Emacs 1821 (make-local-variable 'font-lock-unfontify-region-function)
1538 'cperl-font-lock-unfontify-region-function) 1822 (set 'font-lock-unfontify-region-function ; not present with old Emacs
1823 'cperl-font-lock-unfontify-region-function))
1539 (make-local-variable 'cperl-syntax-done-to) 1824 (make-local-variable 'cperl-syntax-done-to)
1825 (setq cperl-syntax-done-to nil) ; reset syntaxification cache
1540 (make-local-variable 'font-lock-syntactic-keywords) 1826 (make-local-variable 'font-lock-syntactic-keywords)
1541 (setq font-lock-syntactic-keywords 1827 (setq font-lock-syntactic-keywords
1542 (if cperl-syntaxify-by-font-lock 1828 (if cperl-syntaxify-by-font-lock
@@ -1546,10 +1832,20 @@ or as help on variables `cperl-tips', `cperl-problems',
1546 ;; to make font-lock think that font-lock-syntactic-keywords 1832 ;; to make font-lock think that font-lock-syntactic-keywords
1547 ;; are defined. 1833 ;; are defined.
1548 '(t))))) 1834 '(t)))))
1835 (if (boundp 'font-lock-multiline) ; Newer font-lock; use its facilities
1836 (progn
1837 (setq cperl-font-lock-multiline t) ; Not localized...
1838 (set 'font-lock-multiline t)) ; not present with old Emacs; auto-local
1839 (make-local-variable 'font-lock-fontify-region-function)
1840 (set 'font-lock-fontify-region-function ; not present with old Emacs
1841 'cperl-font-lock-fontify-region-function))
1842 (make-local-variable 'font-lock-fontify-region-function)
1843 (set 'font-lock-fontify-region-function ; not present with old Emacs
1844 'cperl-font-lock-fontify-region-function)
1549 (make-local-variable 'cperl-old-style) 1845 (make-local-variable 'cperl-old-style)
1550 (if (boundp 'normal-auto-fill-function) ; 19.33 and later 1846 (if (boundp 'normal-auto-fill-function) ; 19.33 and later
1551 (set (make-local-variable 'normal-auto-fill-function) 1847 (set (make-local-variable 'normal-auto-fill-function)
1552 'cperl-do-auto-fill) ; RMS has it as #'cperl-do-auto-fill ??? 1848 'cperl-do-auto-fill)
1553 (or (fboundp 'cperl-old-auto-fill-mode) 1849 (or (fboundp 'cperl-old-auto-fill-mode)
1554 (progn 1850 (progn
1555 (fset 'cperl-old-auto-fill-mode (symbol-function 'auto-fill-mode)) 1851 (fset 'cperl-old-auto-fill-mode (symbol-function 'auto-fill-mode))
@@ -1562,12 +1858,18 @@ or as help on variables `cperl-tips', `cperl-problems',
1562 (if (cperl-val 'cperl-font-lock) 1858 (if (cperl-val 'cperl-font-lock)
1563 (progn (or cperl-faces-init (cperl-init-faces)) 1859 (progn (or cperl-faces-init (cperl-init-faces))
1564 (font-lock-mode 1)))) 1860 (font-lock-mode 1))))
1861 (set (make-local-variable 'facemenu-add-face-function)
1862 'cperl-facemenu-add-face-function) ; XXXX What this guy is for???
1565 (and (boundp 'msb-menu-cond) 1863 (and (boundp 'msb-menu-cond)
1566 (not cperl-msb-fixed) 1864 (not cperl-msb-fixed)
1567 (cperl-msb-fix)) 1865 (cperl-msb-fix))
1568 (if (featurep 'easymenu) 1866 (if (featurep 'easymenu)
1569 (easy-menu-add cperl-menu)) ; A NOP in Emacs. 1867 (easy-menu-add cperl-menu)) ; A NOP in Emacs.
1570 (run-mode-hooks 'cperl-mode-hook) 1868 (run-mode-hooks 'cperl-mode-hook)
1869 (if cperl-hook-after-change
1870 (progn
1871 (make-local-hook 'after-change-functions)
1872 (add-hook 'after-change-functions 'cperl-after-change-function nil t)))
1571 ;; After hooks since fontification will break this 1873 ;; After hooks since fontification will break this
1572 (if cperl-pod-here-scan 1874 (if cperl-pod-here-scan
1573 (or cperl-syntaxify-by-font-lock 1875 (or cperl-syntaxify-by-font-lock
@@ -1616,31 +1918,37 @@ or as help on variables `cperl-tips', `cperl-problems',
1616(defvar cperl-st-ket '(5 . ?\<)) 1918(defvar cperl-st-ket '(5 . ?\<))
1617 1919
1618 1920
1619(defun cperl-comment-indent () 1921(defun cperl-comment-indent () ; called at point at supposed comment
1620 (let ((p (point)) (c (current-column)) was phony) 1922 (let ((p (point)) (c (current-column)) was phony)
1621 (if (looking-at "^#") 0 ; Existing comment at bol stays there. 1923 (if (and (not cperl-indent-comment-at-column-0)
1924 (looking-at "^#"))
1925 0 ; Existing comment at bol stays there.
1622 ;; Wrong comment found 1926 ;; Wrong comment found
1623 (save-excursion 1927 (save-excursion
1624 (setq was (cperl-to-comment-or-eol) 1928 (setq was (cperl-to-comment-or-eol)
1625 phony (eq (get-text-property (point) 'syntax-table) 1929 phony (eq (get-text-property (point) 'syntax-table)
1626 cperl-st-cfence)) 1930 cperl-st-cfence))
1627 (if phony 1931 (if phony
1628 (progn 1932 (progn ; Too naive???
1629 (re-search-forward "#\\|$") ; Hmm, what about embedded #? 1933 (re-search-forward "#\\|$") ; Hmm, what about embedded #?
1630 (if (eq (preceding-char) ?\#) 1934 (if (eq (preceding-char) ?\#)
1631 (forward-char -1)) 1935 (forward-char -1))
1632 (setq was nil))) 1936 (setq was nil)))
1633 (if (= (point) p) 1937 (if (= (point) p) ; Our caller found a correct place
1634 (progn 1938 (progn
1635 (skip-chars-backward " \t") 1939 (skip-chars-backward " \t")
1636 (max (1+ (current-column)) ; Else indent at comment column 1940 (setq was (current-column))
1637 comment-column)) 1941 (if (eq was 0)
1942 comment-column
1943 (max (1+ was) ; Else indent at comment column
1944 comment-column)))
1945 ;; No, the caller found a random place; we need to edit ourselves
1638 (if was nil 1946 (if was nil
1639 (insert comment-start) 1947 (insert comment-start)
1640 (backward-char (length comment-start))) 1948 (backward-char (length comment-start)))
1641 (setq cperl-wrong-comment t) 1949 (setq cperl-wrong-comment t)
1642 (indent-to comment-column 1) ; Indent minimum 1 1950 (cperl-make-indent comment-column 1) ; Indent min 1
1643 c))))) ; except leave at least one space. 1951 c)))))
1644 1952
1645;;;(defun cperl-comment-indent-fallback () 1953;;;(defun cperl-comment-indent-fallback ()
1646;;; "Is called if the standard comment-search procedure fails. 1954;;; "Is called if the standard comment-search procedure fails.
@@ -1666,7 +1974,7 @@ or as help on variables `cperl-tips', `cperl-problems',
1666 (interactive) 1974 (interactive)
1667 (let (cperl-wrong-comment) 1975 (let (cperl-wrong-comment)
1668 (indent-for-comment) 1976 (indent-for-comment)
1669 (if cperl-wrong-comment 1977 (if cperl-wrong-comment ; set by `cperl-comment-indent'
1670 (progn (cperl-to-comment-or-eol) 1978 (progn (cperl-to-comment-or-eol)
1671 (forward-char (length comment-start)))))) 1979 (forward-char (length comment-start))))))
1672 1980
@@ -1966,15 +2274,10 @@ to nil."
1966 (or 2274 (or
1967 (get-text-property (point) 'in-pod) 2275 (get-text-property (point) 'in-pod)
1968 (cperl-after-expr-p nil "{;:") 2276 (cperl-after-expr-p nil "{;:")
1969 (and (re-search-backward 2277 (and (re-search-backward "\\(\\`\n?\\|^\n\\)=\\sw+" (point-min) t)
1970 ;; "\\(\\`\n?\\|\n\n\\)=\\sw+" 2278 (not (looking-at "\n*=cut"))
1971 "\\(\\`\n?\\|^\n\\)=\\sw+" 2279 (or (not cperl-use-syntax-table-text-property)
1972 (point-min) t) 2280 (eq (get-text-property (point) 'syntax-type) 'pod))))))
1973 (not (or
1974 (looking-at "=cut")
1975 (and cperl-use-syntax-table-text-property
1976 (not (eq (get-text-property (point) 'syntax-type)
1977 'pod)))))))))
1978 (progn 2281 (progn
1979 (save-excursion 2282 (save-excursion
1980 (setq notlast (re-search-forward "^\n=" nil t))) 2283 (setq notlast (re-search-forward "^\n=" nil t)))
@@ -2252,7 +2555,7 @@ key. Will untabify if `cperl-electric-backspace-untabify' is non-nil."
2252 2555
2253(put 'cperl-electric-backspace 'delete-selection 'supersede) 2556(put 'cperl-electric-backspace 'delete-selection 'supersede)
2254 2557
2255(defun cperl-inside-parens-p () 2558(defun cperl-inside-parens-p () ;; NOT USED????
2256 (condition-case () 2559 (condition-case ()
2257 (save-excursion 2560 (save-excursion
2258 (save-restriction 2561 (save-restriction
@@ -2332,8 +2635,9 @@ Return the amount the indentation changed by."
2332 (zerop shift-amt)) 2635 (zerop shift-amt))
2333 (if (> (- (point-max) pos) (point)) 2636 (if (> (- (point-max) pos) (point))
2334 (goto-char (- (point-max) pos))) 2637 (goto-char (- (point-max) pos)))
2335 (delete-region beg (point)) 2638 ;;;(delete-region beg (point))
2336 (indent-to indent) 2639 ;;;(indent-to indent)
2640 (cperl-make-indent indent)
2337 ;; If initial point was within line's indentation, 2641 ;; If initial point was within line's indentation,
2338 ;; position after the indentation. Else stay at same point in text. 2642 ;; position after the indentation. Else stay at same point in text.
2339 (if (> (- (point-max) pos) (point)) 2643 (if (> (- (point-max) pos) (point))
@@ -2380,63 +2684,55 @@ Return the amount the indentation changed by."
2380 (or state (setq state (parse-partial-sexp start start-point -1 nil start-state))) 2684 (or state (setq state (parse-partial-sexp start start-point -1 nil start-state)))
2381 (list start state depth prestart)))) 2685 (list start state depth prestart))))
2382 2686
2383(defun cperl-block-p () ; Do not C-M-q ! One string contains ";" !
2384 ;; Positions is before ?\{. Checks whether it starts a block.
2385 ;; No save-excursion!
2386 (cperl-backward-to-noncomment (point-min))
2387 (or (memq (preceding-char) (append ";){}$@&%\C-@" nil)) ; Or label! \C-@ at bobp
2388 ; Label may be mixed up with `$blah :'
2389 (save-excursion (cperl-after-label))
2390 (and (memq (char-syntax (preceding-char)) '(?w ?_))
2391 (progn
2392 (backward-sexp)
2393 ;; Need take into account `bless', `return', `tr',...
2394 (or (and (looking-at "[a-zA-Z0-9_:]+[ \t\n\f]*[{#]") ; Method call syntax
2395 (not (looking-at "\\(bless\\|return\\|q[wqrx]?\\|tr\\|[smy]\\)\\>")))
2396 (progn
2397 (skip-chars-backward " \t\n\f")
2398 (and (memq (char-syntax (preceding-char)) '(?w ?_))
2399 (progn
2400 (backward-sexp)
2401 (looking-at
2402 "sub[ \t]+[a-zA-Z0-9_:]+[ \t\n\f]*\\(([^()]*)[ \t\n\f]*\\)?[#{]")))))))))
2403
2404(defvar cperl-look-for-prop '((pod in-pod) (here-doc-delim here-doc-group))) 2687(defvar cperl-look-for-prop '((pod in-pod) (here-doc-delim here-doc-group)))
2405 2688
2406(defun cperl-calculate-indent (&optional parse-data) ; was parse-start 2689(defun cperl-beginning-of-property (p prop &optional lim)
2407 "Return appropriate indentation for current line as Perl code. 2690 "Given that P has a property PROP, find where the property starts.
2408In usual case returns an integer: the column to indent to. 2691Will not look before LIM."
2409Returns nil if line starts inside a string, t if in a comment. 2692 ;;; XXXX What to do at point-max???
2410 2693 (or (previous-single-property-change (cperl-1+ p) prop lim)
2411Will not correct the indentation for labels, but will correct it for braces 2694 (point-min))
2412and closing parentheses and brackets." 2695;;; (cond ((eq p (point-min))
2696;;; p)
2697;;; ((and lim (<= p lim))
2698;;; p)
2699;;; ((not (get-text-property (1- p) prop))
2700;;; p)
2701;;; (t (or (previous-single-property-change p look-prop lim)
2702;;; (point-min))))
2703 )
2704
2705(defun cperl-sniff-for-indent (&optional parse-data) ; was parse-start
2706 ;; Old workhorse for calculation of indentation; the major problem
2707 ;; is that it mixes the sniffer logic to understand what the current line
2708 ;; MEANS with the logic to actually calculate where to indent it.
2709 ;; The latter part should be eventually moved to `cperl-calculate-indent';
2710 ;; actually, this is mostly done now...
2413 (cperl-update-syntaxification (point) (point)) 2711 (cperl-update-syntaxification (point) (point))
2414 (save-excursion 2712 (let ((res (get-text-property (point) 'syntax-type)))
2415 (if (or 2713 (save-excursion
2416 (and (memq (get-text-property (point) 'syntax-type) 2714 (cond
2417 '(pod here-doc here-doc-delim format)) 2715 ((and (memq res '(pod here-doc here-doc-delim format))
2418 (not (get-text-property (point) 'indentable))) 2716 (not (get-text-property (point) 'indentable)))
2419 ;; before start of POD - whitespace found since do not have 'pod! 2717 (vector res))
2420 (and (looking-at "[ \t]*\n=") 2718 ;; before start of POD - whitespace found since do not have 'pod!
2421 (error "Spaces before POD section!")) 2719 ((looking-at "[ \t]*\n=")
2422 (and (not cperl-indent-left-aligned-comments) 2720 (error "Spaces before POD section!"))
2423 (looking-at "^#"))) 2721 ((and (not cperl-indent-left-aligned-comments)
2424 nil 2722 (looking-at "^#"))
2425 (beginning-of-line) 2723 [comment-special:at-beginning-of-line])
2426 (let ((indent-point (point)) 2724 ((get-text-property (point) 'in-pod)
2427 (char-after (save-excursion 2725 [in-pod])
2428 (skip-chars-forward " \t") 2726 (t
2429 (following-char))) 2727 (beginning-of-line)
2430 (in-pod (get-text-property (point) 'in-pod)) 2728 (let* ((indent-point (point))
2431 (pre-indent-point (point)) 2729 (char-after-pos (save-excursion
2432 p prop look-prop is-block delim) 2730 (skip-chars-forward " \t")
2433 (cond 2731 (point)))
2434 (in-pod 2732 (char-after (char-after char-after-pos))
2435 ;; In the verbatim part, probably code example. What to do??? 2733 (pre-indent-point (point))
2436 ) 2734 p prop look-prop is-block delim)
2437 (t 2735 (save-excursion ; Know we are not in POD, find appropriate pos before
2438 (save-excursion
2439 ;; Not in POD
2440 (cperl-backward-to-noncomment nil) 2736 (cperl-backward-to-noncomment nil)
2441 (setq p (max (point-min) (1- (point))) 2737 (setq p (max (point-min) (1- (point)))
2442 prop (get-text-property p 'syntax-type) 2738 prop (get-text-property p 'syntax-type)
@@ -2444,437 +2740,597 @@ and closing parentheses and brackets."
2444 'syntax-type)) 2740 'syntax-type))
2445 (if (memq prop '(pod here-doc format here-doc-delim)) 2741 (if (memq prop '(pod here-doc format here-doc-delim))
2446 (progn 2742 (progn
2447 (goto-char (or (previous-single-property-change p look-prop) 2743 (goto-char (cperl-beginning-of-property p look-prop))
2448 (point-min)))
2449 (beginning-of-line) 2744 (beginning-of-line)
2450 (setq pre-indent-point (point))))))) 2745 (setq pre-indent-point (point)))))
2451 (goto-char pre-indent-point) 2746 (goto-char pre-indent-point) ; Orig line skipping preceeding pod/etc
2452 (let* ((case-fold-search nil) 2747 (let* ((case-fold-search nil)
2453 (s-s (cperl-get-state (car parse-data) (nth 1 parse-data))) 2748 (s-s (cperl-get-state (car parse-data) (nth 1 parse-data)))
2454 (start (or (nth 2 parse-data) 2749 (start (or (nth 2 parse-data) ; last complete sexp terminated
2455 (nth 0 s-s))) 2750 (nth 0 s-s))) ; Good place to start parsing
2456 (state (nth 1 s-s)) 2751 (state (nth 1 s-s))
2457 (containing-sexp (car (cdr state))) 2752 (containing-sexp (car (cdr state)))
2458 old-indent) 2753 old-indent)
2459 (if (and 2754 (if (and
2460 ;;containing-sexp ;; We are buggy at toplevel :-( 2755 ;;containing-sexp ;; We are buggy at toplevel :-(
2461 parse-data) 2756 parse-data)
2462 (progn 2757 (progn
2463 (setcar parse-data pre-indent-point) 2758 (setcar parse-data pre-indent-point)
2464 (setcar (cdr parse-data) state) 2759 (setcar (cdr parse-data) state)
2465 (or (nth 2 parse-data) 2760 (or (nth 2 parse-data)
2466 (setcar (cddr parse-data) start)) 2761 (setcar (cddr parse-data) start))
2467 ;; Before this point: end of statement 2762 ;; Before this point: end of statement
2468 (setq old-indent (nth 3 parse-data)))) 2763 (setq old-indent (nth 3 parse-data))))
2469 (cond ((get-text-property (point) 'indentable) 2764 (cond ((get-text-property (point) 'indentable)
2470 ;; indent to just after the surrounding open, 2765 ;; indent to "after" the surrounding open
2471 ;; skip blanks if we do not close the expression. 2766 ;; (same offset as `cperl-beautify-regexp-piece'),
2472 (goto-char (1+ (previous-single-property-change (point) 'indentable))) 2767 ;; skip blanks if we do not close the expression.
2473 (or (memq char-after (append ")]}" nil)) 2768 (setq delim ; We do not close the expression
2474 (looking-at "[ \t]*\\(#\\|$\\)") 2769 (get-text-property
2475 (skip-chars-forward " \t")) 2770 (cperl-1+ char-after-pos) 'indentable)
2476 (current-column)) 2771 p (1+ (cperl-beginning-of-property
2477 ((or (nth 3 state) (nth 4 state)) 2772 (point) 'indentable))
2478 ;; return nil or t if should not change this line 2773 is-block ; misused for: preceeding line in REx
2479 (nth 4 state)) 2774 (save-excursion ; Find preceeding line
2480 ;; XXXX Do we need to special-case this? 2775 (cperl-backward-to-noncomment p)
2481 ((null containing-sexp) 2776 (beginning-of-line)
2482 ;; Line is at top level. May be data or function definition, 2777 (if (<= (point) p)
2483 ;; or may be function argument declaration. 2778 (progn ; get indent from the first line
2484 ;; Indent like the previous top level line 2779 (goto-char p)
2485 ;; unless that ends in a closeparen without semicolon, 2780 (skip-chars-forward " \t")
2486 ;; in which case this line is the first argument decl. 2781 (if (memq (char-after (point))
2487 (skip-chars-forward " \t") 2782 (append "#\n" nil))
2488 (+ (save-excursion 2783 nil ; Can't use intentation of this line...
2489 (goto-char start) 2784 (point)))
2490 (- (current-indentation) 2785 (skip-chars-forward " \t")
2491 (if (nth 2 s-s) cperl-indent-level 0))) 2786 (point)))
2492 (if (= char-after ?{) cperl-continued-brace-offset 0) 2787 prop (parse-partial-sexp p char-after-pos))
2493 (progn 2788 (cond ((not delim) ; End the REx, ignore is-block
2494 (cperl-backward-to-noncomment (or old-indent (point-min))) 2789 (vector 'indentable 'terminator p is-block))
2495 ;; Look at previous line that's at column 0 2790 (is-block ; Indent w.r.t. preceeding line
2496 ;; to determine whether we are in top-level decls 2791 (vector 'indentable 'cont-line char-after-pos
2497 ;; or function's arg decls. Set basic-indent accordingly. 2792 is-block char-after p))
2498 ;; Now add a little if this is a continuation line. 2793 (t ; No preceeding line...
2499 (if (or (bobp) 2794 (vector 'indentable 'first-line p))))
2500 (eq (point) old-indent) ; old-indent was at comment 2795 ((get-text-property char-after-pos 'REx-part2)
2501 (eq (preceding-char) ?\;) 2796 (vector 'REx-part2 (point)))
2502 ;; Had ?\) too 2797 ((nth 3 state)
2503 (and (eq (preceding-char) ?\}) 2798 [comment])
2504 (cperl-after-block-and-statement-beg 2799 ((nth 4 state)
2505 (point-min))) ; Was start - too close 2800 [string])
2506 (memq char-after (append ")]}" nil)) 2801 ;; XXXX Do we need to special-case this?
2507 (and (eq (preceding-char) ?\:) ; label 2802 ((null containing-sexp)
2508 (progn 2803 ;; Line is at top level. May be data or function definition,
2509 (forward-sexp -1) 2804 ;; or may be function argument declaration.
2510 (skip-chars-backward " \t") 2805 ;; Indent like the previous top level line
2511 (looking-at "[ \t]*[a-zA-Z_][a-zA-Z_0-9]*[ \t]*:"))) 2806 ;; unless that ends in a closeparen without semicolon,
2512 (get-text-property (point) 'first-format-line)) 2807 ;; in which case this line is the first argument decl.
2513 (progn 2808 (skip-chars-forward " \t")
2514 (if (and parse-data 2809 (cperl-backward-to-noncomment (or old-indent (point-min)))
2515 (not (eq char-after ?\C-j))) 2810 (setq state
2516 (setcdr (cddr parse-data) 2811 (or (bobp)
2517 (list pre-indent-point))) 2812 (eq (point) old-indent) ; old-indent was at comment
2518 0) 2813 (eq (preceding-char) ?\;)
2519 cperl-continued-statement-offset)))) 2814 ;; Had ?\) too
2520 ((not 2815 (and (eq (preceding-char) ?\})
2521 (or (setq is-block 2816 (cperl-after-block-and-statement-beg
2522 (and (setq delim (= (char-after containing-sexp) ?{)) 2817 (point-min))) ; Was start - too close
2523 (save-excursion ; Is it a hash? 2818 (memq char-after (append ")]}" nil))
2524 (goto-char containing-sexp) 2819 (and (eq (preceding-char) ?\:) ; label
2525 (cperl-block-p))))
2526 cperl-indent-parens-as-block))
2527 ;; group is an expression, not a block:
2528 ;; indent to just after the surrounding open parens,
2529 ;; skip blanks if we do not close the expression.
2530 (goto-char (1+ containing-sexp))
2531 (or (memq char-after
2532 (append (if delim "}" ")]}") nil))
2533 (looking-at "[ \t]*\\(#\\|$\\)")
2534 (skip-chars-forward " \t"))
2535 (+ (current-column)
2536 (if (and delim
2537 (eq char-after ?\}))
2538 ;; Correct indentation of trailing ?\}
2539 (+ cperl-indent-level cperl-close-paren-offset)
2540 0)))
2541;;; ((and (/= (char-after containing-sexp) ?{)
2542;;; (not cperl-indent-parens-as-block))
2543;;; ;; line is expression, not statement:
2544;;; ;; indent to just after the surrounding open,
2545;;; ;; skip blanks if we do not close the expression.
2546;;; (goto-char (1+ containing-sexp))
2547;;; (or (memq char-after (append ")]}" nil))
2548;;; (looking-at "[ \t]*\\(#\\|$\\)")
2549;;; (skip-chars-forward " \t"))
2550;;; (current-column))
2551;;; ((progn
2552;;; ;; Containing-expr starts with \{. Check whether it is a hash.
2553;;; (goto-char containing-sexp)
2554;;; (and (not (cperl-block-p))
2555;;; (not cperl-indent-parens-as-block)))
2556;;; (goto-char (1+ containing-sexp))
2557;;; (or (eq char-after ?\})
2558;;; (looking-at "[ \t]*\\(#\\|$\\)")
2559;;; (skip-chars-forward " \t"))
2560;;; (+ (current-column) ; Correct indentation of trailing ?\}
2561;;; (if (eq char-after ?\}) (+ cperl-indent-level
2562;;; cperl-close-paren-offset)
2563;;; 0)))
2564 (t
2565 ;; Statement level. Is it a continuation or a new statement?
2566 ;; Find previous non-comment character.
2567 (goto-char pre-indent-point)
2568 (cperl-backward-to-noncomment containing-sexp)
2569 ;; Back up over label lines, since they don't
2570 ;; affect whether our line is a continuation.
2571 ;; (Had \, too)
2572 (while ;;(or (eq (preceding-char) ?\,)
2573 (and (eq (preceding-char) ?:)
2574 (or ;;(eq (char-after (- (point) 2)) ?\') ; ????
2575 (memq (char-syntax (char-after (- (point) 2)))
2576 '(?w ?_))))
2577 ;;)
2578 (if (eq (preceding-char) ?\,)
2579 ;; Will go to beginning of line, essentially.
2580 ;; Will ignore embedded sexpr XXXX.
2581 (cperl-backward-to-start-of-continued-exp containing-sexp))
2582 (beginning-of-line)
2583 (cperl-backward-to-noncomment containing-sexp))
2584 ;; Now we get the answer.
2585 (if (not (or (eq (1- (point)) containing-sexp)
2586 (memq (preceding-char)
2587 (append (if is-block " ;{" " ,;{") '(nil)))
2588 (and (eq (preceding-char) ?\})
2589 (cperl-after-block-and-statement-beg
2590 containing-sexp))
2591 (get-text-property (point) 'first-format-line)))
2592 ;; This line is continuation of preceding line's statement;
2593 ;; indent `cperl-continued-statement-offset' more than the
2594 ;; previous line of the statement.
2595 ;;
2596 ;; There might be a label on this line, just
2597 ;; consider it bad style and ignore it.
2598 (progn
2599 (cperl-backward-to-start-of-continued-exp containing-sexp)
2600 (+ (if (memq char-after (append "}])" nil))
2601 0 ; Closing parenth
2602 cperl-continued-statement-offset)
2603 (if (or is-block
2604 (not delim)
2605 (not (eq char-after ?\})))
2606 0
2607 ;; Now it is a hash reference
2608 (+ cperl-indent-level cperl-close-paren-offset))
2609 (if (looking-at "\\w+[ \t]*:")
2610 (if (> (current-indentation) cperl-min-label-indent)
2611 (- (current-indentation) cperl-label-offset)
2612 ;; Do not move `parse-data', this should
2613 ;; be quick anyway (this comment comes
2614 ;; from different location):
2615 (cperl-calculate-indent))
2616 (current-column))
2617 (if (eq char-after ?\{)
2618 cperl-continued-brace-offset 0)))
2619 ;; This line starts a new statement.
2620 ;; Position following last unclosed open.
2621 (goto-char containing-sexp)
2622 ;; Is line first statement after an open-brace?
2623 (or
2624 ;; If no, find that first statement and indent like
2625 ;; it. If the first statement begins with label, do
2626 ;; not believe when the indentation of the label is too
2627 ;; small.
2628 (save-excursion
2629 (forward-char 1)
2630 (setq old-indent (current-indentation))
2631 (let ((colon-line-end 0))
2632 (while
2633 (progn (skip-chars-forward " \t\n")
2634 (looking-at "#\\|[a-zA-Z0-9_$]*:[^:]\\|=[a-zA-Z]"))
2635 ;; Skip over comments and labels following openbrace.
2636 (cond ((= (following-char) ?\#)
2637 (forward-line 1))
2638 ((= (following-char) ?\=)
2639 (goto-char
2640 (or (next-single-property-change (point) 'in-pod)
2641 (point-max)))) ; do not loop if no syntaxification
2642 ;; label:
2643 (t
2644 (save-excursion (end-of-line)
2645 (setq colon-line-end (point)))
2646 (search-forward ":"))))
2647 ;; The first following code counts
2648 ;; if it is before the line we want to indent.
2649 (and (< (point) indent-point)
2650 (if (> colon-line-end (point)) ; After label
2651 (if (> (current-indentation)
2652 cperl-min-label-indent)
2653 (- (current-indentation) cperl-label-offset)
2654 ;; Do not believe: `max' is involved
2655 (+ old-indent cperl-indent-level))
2656 (current-column)))))
2657 ;; If no previous statement,
2658 ;; indent it relative to line brace is on.
2659 ;; For open brace in column zero, don't let statement
2660 ;; start there too. If cperl-indent-level is zero,
2661 ;; use cperl-brace-offset + cperl-continued-statement-offset instead.
2662 ;; For open-braces not the first thing in a line,
2663 ;; add in cperl-brace-imaginary-offset.
2664
2665 ;; If first thing on a line: ?????
2666 (+ (if (and (bolp) (zerop cperl-indent-level))
2667 (+ cperl-brace-offset cperl-continued-statement-offset)
2668 cperl-indent-level)
2669 (if (or is-block
2670 (not delim)
2671 (not (eq char-after ?\})))
2672 0
2673 ;; Now it is a hash reference
2674 (+ cperl-indent-level cperl-close-paren-offset))
2675 ;; Move back over whitespace before the openbrace.
2676 ;; If openbrace is not first nonwhite thing on the line,
2677 ;; add the cperl-brace-imaginary-offset.
2678 (progn (skip-chars-backward " \t")
2679 (if (bolp) 0 cperl-brace-imaginary-offset))
2680 ;; If the openbrace is preceded by a parenthesized exp,
2681 ;; move to the beginning of that;
2682 ;; possibly a different line
2683 (progn
2684 (if (eq (preceding-char) ?\))
2685 (forward-sexp -1))
2686 ;; In the case it starts a subroutine, indent with
2687 ;; respect to `sub', not with respect to the
2688 ;; first thing on the line, say in the case of
2689 ;; anonymous sub in a hash.
2690 ;;
2691 (skip-chars-backward " \t")
2692 (if (and (eq (preceding-char) ?b)
2693 (progn 2820 (progn
2694 (forward-sexp -1) 2821 (forward-sexp -1)
2695 (looking-at "sub\\>")) 2822 (skip-chars-backward " \t")
2696 (setq old-indent 2823 (looking-at "[ \t]*[a-zA-Z_][a-zA-Z_0-9]*[ \t]*:")))
2697 (nth 1 2824 (get-text-property (point) 'first-format-line)))
2698 (parse-partial-sexp 2825
2699 (save-excursion (beginning-of-line) (point)) 2826 ;; Look at previous line that's at column 0
2700 (point))))) 2827 ;; to determine whether we are in top-level decls
2701 (progn (goto-char (1+ old-indent)) 2828 ;; or function's arg decls. Set basic-indent accordingly.
2702 (skip-chars-forward " \t") 2829 ;; Now add a little if this is a continuation line.
2703 (current-column)) 2830 (and state
2704 ;; Get initial indentation of the line we are on. 2831 parse-data
2705 ;; If line starts with label, calculate label indentation 2832 (not (eq char-after ?\C-j))
2706 (if (save-excursion 2833 (setcdr (cddr parse-data)
2707 (beginning-of-line) 2834 (list pre-indent-point)))
2708 (looking-at "[ \t]*[a-zA-Z_][a-zA-Z_0-9]*:[^:]")) 2835 (vector 'toplevel start char-after state (nth 2 s-s)))
2709 (if (> (current-indentation) cperl-min-label-indent) 2836 ((not
2710 (- (current-indentation) cperl-label-offset) 2837 (or (setq is-block
2711 ;; Do not move `parse-data', this should 2838 (and (setq delim (= (char-after containing-sexp) ?{))
2712 ;; be quick anyway: 2839 (save-excursion ; Is it a hash?
2713 (cperl-calculate-indent)) 2840 (goto-char containing-sexp)
2714 (current-indentation)))))))))))))) 2841 (cperl-block-p))))
2715 2842 cperl-indent-parens-as-block))
2716;; (defvar cperl-indent-alist 2843 ;; group is an expression, not a block:
2717;; '((string nil) 2844 ;; indent to just after the surrounding open parens,
2718;; (comment nil) 2845 ;; skip blanks if we do not close the expression.
2719;; (toplevel 0) 2846 (goto-char (1+ containing-sexp))
2720;; (toplevel-after-parenth 2) 2847 (or (memq char-after
2721;; (toplevel-continued 2) 2848 (append (if delim "}" ")]}") nil))
2722;; (expression 1)) 2849 (looking-at "[ \t]*\\(#\\|$\\)")
2723;; "Alist of indentation rules for CPerl mode. 2850 (skip-chars-forward " \t"))
2724;; The values mean: 2851 (setq old-indent (point)) ; delim=is-brace
2725;; nil: do not indent; 2852 (vector 'in-parens char-after (point) delim containing-sexp))
2726;; number: add this amount of indentation. 2853 (t
2727 2854 ;; Statement level. Is it a continuation or a new statement?
2728;; Not finished, not used.") 2855 ;; Find previous non-comment character.
2729 2856 (goto-char pre-indent-point) ; Skip one level of POD/etc
2730;; (defun cperl-where-am-i (&optional parse-start start-state) 2857 (cperl-backward-to-noncomment containing-sexp)
2731;; ;; Unfinished 2858 ;; Back up over label lines, since they don't
2732;; "Return a list of lists ((TYPE POS)...) of good points before the point. 2859 ;; affect whether our line is a continuation.
2733;; ;; POS may be nil if it is hard to find, say, when TYPE is `string' or `comment'. 2860 ;; (Had \, too)
2734 2861 (while;;(or (eq (preceding-char) ?\,)
2735;; ;; Not finished, not used." 2862 (and (eq (preceding-char) ?:)
2736;; (save-excursion 2863 (or;;(eq (char-after (- (point) 2)) ?\') ; ????
2737;; (let* ((start-point (point)) 2864 (memq (char-syntax (char-after (- (point) 2)))
2738;; (s-s (cperl-get-state)) 2865 '(?w ?_))))
2739;; (start (nth 0 s-s)) 2866 ;;)
2740;; (state (nth 1 s-s)) 2867 ;; This is always FALSE?
2741;; (prestart (nth 3 s-s)) 2868 (if (eq (preceding-char) ?\,)
2742;; (containing-sexp (car (cdr state))) 2869 ;; Will go to beginning of line, essentially.
2743;; (case-fold-search nil) 2870 ;; Will ignore embedded sexpr XXXX.
2744;; (res (list (list 'parse-start start) (list 'parse-prestart prestart)))) 2871 (cperl-backward-to-start-of-continued-exp containing-sexp))
2745;; (cond ((nth 3 state) ; In string 2872 (beginning-of-line)
2746;; (setq res (cons (list 'string nil (nth 3 state)) res))) ; What started string 2873 (cperl-backward-to-noncomment containing-sexp))
2747;; ((nth 4 state) ; In comment 2874 ;; Now we get non-label preceeding the indent point
2748;; (setq res (cons '(comment) res))) 2875 (if (not (or (eq (1- (point)) containing-sexp)
2749;; ((null containing-sexp) 2876 (memq (preceding-char)
2750;; ;; Line is at top level. 2877 (append (if is-block " ;{" " ,;{") '(nil)))
2751;; ;; Indent like the previous top level line 2878 (and (eq (preceding-char) ?\})
2752;; ;; unless that ends in a closeparen without semicolon, 2879 (cperl-after-block-and-statement-beg
2753;; ;; in which case this line is the first argument decl. 2880 containing-sexp))
2754;; (cperl-backward-to-noncomment (or parse-start (point-min))) 2881 (get-text-property (point) 'first-format-line)))
2755;; ;;(skip-chars-backward " \t\f\n") 2882 ;; This line is continuation of preceding line's statement;
2756;; (cond 2883 ;; indent `cperl-continued-statement-offset' more than the
2757;; ((or (bobp) 2884 ;; previous line of the statement.
2758;; (memq (preceding-char) (append ";}" nil))) 2885 ;;
2759;; (setq res (cons (list 'toplevel start) res))) 2886 ;; There might be a label on this line, just
2760;; ((eq (preceding-char) ?\) ) 2887 ;; consider it bad style and ignore it.
2761;; (setq res (cons (list 'toplevel-after-parenth start) res))) 2888 (progn
2762;; (t 2889 (cperl-backward-to-start-of-continued-exp containing-sexp)
2763;; (setq res (cons (list 'toplevel-continued start) res))))) 2890 (vector 'continuation (point) char-after is-block delim))
2764;; ((/= (char-after containing-sexp) ?{) 2891 ;; This line starts a new statement.
2765;; ;; line is expression, not statement: 2892 ;; Position following last unclosed open brace
2766;; ;; indent to just after the surrounding open. 2893 (goto-char containing-sexp)
2767;; ;; skip blanks if we do not close the expression. 2894 ;; Is line first statement after an open-brace?
2768;; (setq res (cons (list 'expression-blanks 2895 (or
2769;; (progn 2896 ;; If no, find that first statement and indent like
2770;; (goto-char (1+ containing-sexp)) 2897 ;; it. If the first statement begins with label, do
2771;; (or (looking-at "[ \t]*\\(#\\|$\\)") 2898 ;; not believe when the indentation of the label is too
2772;; (skip-chars-forward " \t")) 2899 ;; small.
2773;; (point))) 2900 (save-excursion
2774;; (cons (list 'expression containing-sexp) res)))) 2901 (forward-char 1)
2775;; ((progn 2902 (let ((colon-line-end 0))
2776;; ;; Containing-expr starts with \{. Check whether it is a hash. 2903 (while
2777;; (goto-char containing-sexp) 2904 (progn (skip-chars-forward " \t\n")
2778;; (not (cperl-block-p))) 2905 (looking-at "#\\|[a-zA-Z0-9_$]*:[^:]\\|=[a-zA-Z]"))
2779;; (setq res (cons (list 'expression-blanks 2906 ;; Skip over comments and labels following openbrace.
2780;; (progn 2907 (cond ((= (following-char) ?\#)
2781;; (goto-char (1+ containing-sexp)) 2908 (forward-line 1))
2782;; (or (looking-at "[ \t]*\\(#\\|$\\)") 2909 ((= (following-char) ?\=)
2783;; (skip-chars-forward " \t")) 2910 (goto-char
2784;; (point))) 2911 (or (next-single-property-change (point) 'in-pod)
2785;; (cons (list 'expression containing-sexp) res)))) 2912 (point-max)))) ; do not loop if no syntaxification
2786;; (t 2913 ;; label:
2787;; ;; Statement level. 2914 (t
2788;; (setq res (cons (list 'in-block containing-sexp) res)) 2915 (save-excursion (end-of-line)
2789;; ;; Is it a continuation or a new statement? 2916 (setq colon-line-end (point)))
2790;; ;; Find previous non-comment character. 2917 (search-forward ":"))))
2791;; (cperl-backward-to-noncomment containing-sexp) 2918 ;; We are at beginning of code (NOT label or comment)
2792;; ;; Back up over label lines, since they don't 2919 ;; First, the following code counts
2793;; ;; affect whether our line is a continuation. 2920 ;; if it is before the line we want to indent.
2794;; ;; Back up comma-delimited lines too ????? 2921 (and (< (point) indent-point)
2795;; (while (or (eq (preceding-char) ?\,) 2922 (vector 'have-prev-sibling (point) colon-line-end
2796;; (save-excursion (cperl-after-label))) 2923 containing-sexp))))
2797;; (if (eq (preceding-char) ?\,) 2924 (progn
2798;; ;; Will go to beginning of line, essentially 2925 ;; If no previous statement,
2799;; ;; Will ignore embedded sexpr XXXX. 2926 ;; indent it relative to line brace is on.
2800;; (cperl-backward-to-start-of-continued-exp containing-sexp)) 2927
2801;; (beginning-of-line) 2928 ;; For open-braces not the first thing in a line,
2802;; (cperl-backward-to-noncomment containing-sexp)) 2929 ;; add in cperl-brace-imaginary-offset.
2803;; ;; Now we get the answer. 2930
2804;; (if (not (memq (preceding-char) (append ";}{" '(nil)))) ; Was ?\, 2931 ;; If first thing on a line: ?????
2805;; ;; This line is continuation of preceding line's statement. 2932 ;; Move back over whitespace before the openbrace.
2806;; (list (list 'statement-continued containing-sexp)) 2933 (setq ; brace first thing on a line
2807;; ;; This line starts a new statement. 2934 old-indent (progn (skip-chars-backward " \t") (bolp)))
2808;; ;; Position following last unclosed open. 2935 ;; Should we indent w.r.t. earlier than start?
2809;; (goto-char containing-sexp) 2936 ;; Move to start of control group, possibly on a different line
2810;; ;; Is line first statement after an open-brace? 2937 (or cperl-indent-wrt-brace
2811;; (or 2938 (cperl-backward-to-noncomment (point-min)))
2812;; ;; If no, find that first statement and indent like 2939 ;; If the openbrace is preceded by a parenthesized exp,
2813;; ;; it. If the first statement begins with label, do 2940 ;; move to the beginning of that;
2814;; ;; not believe when the indentation of the label is too 2941 (if (eq (preceding-char) ?\))
2815;; ;; small. 2942 (progn
2816;; (save-excursion 2943 (forward-sexp -1)
2817;; (forward-char 1) 2944 (cperl-backward-to-noncomment (point-min))))
2818;; (let ((colon-line-end 0)) 2945 ;; In the case it starts a subroutine, indent with
2819;; (while (progn (skip-chars-forward " \t\n" start-point) 2946 ;; respect to `sub', not with respect to the
2820;; (and (< (point) start-point) 2947 ;; first thing on the line, say in the case of
2821;; (looking-at 2948 ;; anonymous sub in a hash.
2822;; "#\\|[a-zA-Z_][a-zA-Z0-9_]*:[^:]"))) 2949 (if (and;; Is it a sub in group starting on this line?
2823;; ;; Skip over comments and labels following openbrace. 2950 (cond ((get-text-property (point) 'attrib-group)
2824;; (cond ((= (following-char) ?\#) 2951 (goto-char (cperl-beginning-of-property
2825;; ;;(forward-line 1) 2952 (point) 'attrib-group)))
2826;; (end-of-line)) 2953 ((eq (preceding-char) ?b)
2827;; ;; label: 2954 (forward-sexp -1)
2828;; (t 2955 (looking-at "sub\\>")))
2829;; (save-excursion (end-of-line) 2956 (setq p (nth 1 ; start of innermost containing list
2830;; (setq colon-line-end (point))) 2957 (parse-partial-sexp
2831;; (search-forward ":")))) 2958 (save-excursion (beginning-of-line)
2832;; ;; Now at the point, after label, or at start 2959 (point))
2833;; ;; of first statement in the block. 2960 (point)))))
2834;; (and (< (point) start-point) 2961 (progn
2835;; (if (> colon-line-end (point)) 2962 (goto-char (1+ p)) ; enclosing block on the same line
2836;; ;; Before statement after label 2963 (skip-chars-forward " \t")
2837;; (if (> (current-indentation) 2964 (vector 'code-start-in-block containing-sexp char-after
2838;; cperl-min-label-indent) 2965 (and delim (not is-block)) ; is a HASH
2839;; (list (list 'label-in-block (point))) 2966 old-indent ; brace first thing on a line
2840;; ;; Do not believe: `max' is involved 2967 t (point) ; have something before...
2841;; (list 2968 )
2842;; (list 'label-in-block-min-indent (point)))) 2969 ;;(current-column)
2843;; ;; Before statement 2970 )
2844;; (list 'statement-in-block (point)))))) 2971 ;; Get initial indentation of the line we are on.
2845;; ;; If no previous statement, 2972 ;; If line starts with label, calculate label indentation
2846;; ;; indent it relative to line brace is on. 2973 (vector 'code-start-in-block containing-sexp char-after
2847;; ;; For open brace in column zero, don't let statement 2974 (and delim (not is-block)) ; is a HASH
2848;; ;; start there too. If cperl-indent-level is zero, 2975 old-indent ; brace first thing on a line
2849;; ;; use cperl-brace-offset + cperl-continued-statement-offset instead. 2976 nil (point) ; nothing interesting before
2850;; ;; For open-braces not the first thing in a line, 2977 ))))))))))))))
2851;; ;; add in cperl-brace-imaginary-offset. 2978
2852 2979(defvar cperl-indent-rules-alist
2853;; ;; If first thing on a line: ????? 2980 '((pod nil) ; via `syntax-type' property
2854;; (+ (if (and (bolp) (zerop cperl-indent-level)) 2981 (here-doc nil) ; via `syntax-type' property
2855;; (+ cperl-brace-offset cperl-continued-statement-offset) 2982 (here-doc-delim nil) ; via `syntax-type' property
2856;; cperl-indent-level) 2983 (format nil) ; via `syntax-type' property
2857;; ;; Move back over whitespace before the openbrace. 2984 (in-pod nil) ; via `in-pod' property
2858;; ;; If openbrace is not first nonwhite thing on the line, 2985 (comment-special:at-beginning-of-line nil)
2859;; ;; add the cperl-brace-imaginary-offset. 2986 (string t)
2860;; (progn (skip-chars-backward " \t") 2987 (comment nil))
2861;; (if (bolp) 0 cperl-brace-imaginary-offset)) 2988 "Alist of indentation rules for CPerl mode.
2862;; ;; If the openbrace is preceded by a parenthesized exp, 2989The values mean:
2863;; ;; move to the beginning of that; 2990 nil: do not indent;
2864;; ;; possibly a different line 2991 number: add this amount of indentation.
2865;; (progn 2992
2866;; (if (eq (preceding-char) ?\)) 2993Not finished.")
2867;; (forward-sexp -1)) 2994
2868;; ;; Get initial indentation of the line we are on. 2995(defun cperl-calculate-indent (&optional parse-data) ; was parse-start
2869;; ;; If line starts with label, calculate label indentation 2996 "Return appropriate indentation for current line as Perl code.
2870;; (if (save-excursion 2997In usual case returns an integer: the column to indent to.
2871;; (beginning-of-line) 2998Returns nil if line starts inside a string, t if in a comment.
2872;; (looking-at "[ \t]*[a-zA-Z_][a-zA-Z_0-9]*:[^:]")) 2999
2873;; (if (> (current-indentation) cperl-min-label-indent) 3000Will not correct the indentation for labels, but will correct it for braces
2874;; (- (current-indentation) cperl-label-offset) 3001and closing parentheses and brackets."
2875;; (cperl-calculate-indent)) 3002 ;; This code is still a broken architecture: in some cases we need to
2876;; (current-indentation)))))))) 3003 ;; compensate for some modifications which `cperl-indent-line' will add later
2877;; res))) 3004 (save-excursion
3005 (let ((i (cperl-sniff-for-indent parse-data)) what p)
3006 (cond
3007 ;;((or (null i) (eq i t) (numberp i))
3008 ;; i)
3009 ((vectorp i)
3010 (setq what (assoc (elt i 0) cperl-indent-rules-alist))
3011 (cond
3012 (what (cadr what)) ; Load from table
3013 ;;
3014 ;; Indenters for regular expressions with //x and qw()
3015 ;;
3016 ((eq 'REx-part2 (elt i 0)) ;; [self start] start of /REP in s//REP/x
3017 (goto-char (elt i 1))
3018 (condition-case nil ; Use indentation of the 1st part
3019 (forward-sexp -1))
3020 (current-column))
3021 ((eq 'indentable (elt i 0)) ; Indenter for REGEXP qw() etc
3022 (cond ;;; [indentable terminator start-pos is-block]
3023 ((eq 'terminator (elt i 1)) ; Lone terminator of "indentable string"
3024 (goto-char (elt i 2)) ; After opening parens
3025 (1- (current-column)))
3026 ((eq 'first-line (elt i 1)); [indentable first-line start-pos]
3027 (goto-char (elt i 2))
3028 (+ (or cperl-regexp-indent-step cperl-indent-level)
3029 -1
3030 (current-column)))
3031 ((eq 'cont-line (elt i 1)); [indentable cont-line pos prev-pos first-char start-pos]
3032 ;; Indent as the level after closing parens
3033 (goto-char (elt i 2)) ; indent line
3034 (skip-chars-forward " \t)") ; Skip closing parens
3035 (setq p (point))
3036 (goto-char (elt i 3)) ; previous line
3037 (skip-chars-forward " \t)") ; Skip closing parens
3038 ;; Number of parens in between:
3039 (setq p (nth 0 (parse-partial-sexp (point) p))
3040 what (elt i 4)) ; First char on current line
3041 (goto-char (elt i 3)) ; previous line
3042 (+ (* p (or cperl-regexp-indent-step cperl-indent-level))
3043 (cond ((eq what ?\) )
3044 (- cperl-close-paren-offset)) ; compensate
3045 ((eq what ?\| )
3046 (- (or cperl-regexp-indent-step cperl-indent-level)))
3047 (t 0))
3048 (if (eq (following-char) ?\| )
3049 (or cperl-regexp-indent-step cperl-indent-level)
3050 0)
3051 (current-column)))
3052 (t
3053 (error "Unrecognized value of indent: %s" i))))
3054 ;;
3055 ;; Indenter for stuff at toplevel
3056 ;;
3057 ((eq 'toplevel (elt i 0)) ;; [toplevel start char-after state immed-after-block]
3058 (+ (save-excursion ; To beg-of-defun, or end of last sexp
3059 (goto-char (elt i 1)) ; start = Good place to start parsing
3060 (- (current-indentation) ;
3061 (if (elt i 4) cperl-indent-level 0))) ; immed-after-block
3062 (if (eq (elt i 2) ?{) cperl-continued-brace-offset 0) ; char-after
3063 ;; Look at previous line that's at column 0
3064 ;; to determine whether we are in top-level decls
3065 ;; or function's arg decls. Set basic-indent accordingly.
3066 ;; Now add a little if this is a continuation line.
3067 (if (elt i 3) ; state (XXX What is the semantic???)
3068 0
3069 cperl-continued-statement-offset)))
3070 ;;
3071 ;; Indenter for stuff in "parentheses" (or brackets, braces-as-hash)
3072 ;;
3073 ((eq 'in-parens (elt i 0))
3074 ;; in-parens char-after old-indent-point is-brace containing-sexp
3075
3076 ;; group is an expression, not a block:
3077 ;; indent to just after the surrounding open parens,
3078 ;; skip blanks if we do not close the expression.
3079 (+ (progn
3080 (goto-char (elt i 2)) ; old-indent-point
3081 (current-column))
3082 (if (and (elt i 3) ; is-brace
3083 (eq (elt i 1) ?\})) ; char-after
3084 ;; Correct indentation of trailing ?\}
3085 (+ cperl-indent-level cperl-close-paren-offset)
3086 0)))
3087 ;;
3088 ;; Indenter for continuation lines
3089 ;;
3090 ((eq 'continuation (elt i 0))
3091 ;; [continuation statement-start char-after is-block is-brace]
3092 (goto-char (elt i 1)) ; statement-start
3093 (+ (if (memq (elt i 2) (append "}])" nil)) ; char-after
3094 0 ; Closing parenth
3095 cperl-continued-statement-offset)
3096 (if (or (elt i 3) ; is-block
3097 (not (elt i 4)) ; is-brace
3098 (not (eq (elt i 2) ?\}))) ; char-after
3099 0
3100 ;; Now it is a hash reference
3101 (+ cperl-indent-level cperl-close-paren-offset))
3102 ;; Labels do not take :: ...
3103 (if (looking-at "\\(\\w\\|_\\)+[ \t]*:")
3104 (if (> (current-indentation) cperl-min-label-indent)
3105 (- (current-indentation) cperl-label-offset)
3106 ;; Do not move `parse-data', this should
3107 ;; be quick anyway (this comment comes
3108 ;; from different location):
3109 (cperl-calculate-indent))
3110 (current-column))
3111 (if (eq (elt i 2) ?\{) ; char-after
3112 cperl-continued-brace-offset 0)))
3113 ;;
3114 ;; Indenter for lines in a block which are not leading lines
3115 ;;
3116 ((eq 'have-prev-sibling (elt i 0))
3117 ;; [have-prev-sibling sibling-beg colon-line-end block-start]
3118 (goto-char (elt i 1))
3119 (if (> (elt i 2) (point)) ; colon-line-end; After-label, same line
3120 (if (> (current-indentation)
3121 cperl-min-label-indent)
3122 (- (current-indentation) cperl-label-offset)
3123 ;; Do not believe: `max' was involved in calculation of indent
3124 (+ cperl-indent-level
3125 (save-excursion
3126 (goto-char (elt i 3)) ; block-start
3127 (current-indentation))))
3128 (current-column)))
3129 ;;
3130 ;; Indenter for the first line in a block
3131 ;;
3132 ((eq 'code-start-in-block (elt i 0))
3133 ;;[code-start-in-block before-brace char-after
3134 ;; is-a-HASH-ref brace-is-first-thing-on-a-line
3135 ;; group-starts-before-start-of-sub start-of-control-group]
3136 (goto-char (elt i 1))
3137 ;; For open brace in column zero, don't let statement
3138 ;; start there too. If cperl-indent-level=0,
3139 ;; use cperl-brace-offset + cperl-continued-statement-offset instead.
3140 (+ (if (and (bolp) (zerop cperl-indent-level))
3141 (+ cperl-brace-offset cperl-continued-statement-offset)
3142 cperl-indent-level)
3143 (if (and (elt i 3) ; is-a-HASH-ref
3144 (eq (elt i 2) ?\})) ; char-after: End of a hash reference
3145 (+ cperl-indent-level cperl-close-paren-offset)
3146 0)
3147 ;; Unless openbrace is the first nonwhite thing on the line,
3148 ;; add the cperl-brace-imaginary-offset.
3149 (if (elt i 4) 0 ; brace-is-first-thing-on-a-line
3150 cperl-brace-imaginary-offset)
3151 (progn
3152 (goto-char (elt i 6)) ; start-of-control-group
3153 (if (elt i 5) ; group-starts-before-start-of-sub
3154 (current-column)
3155 ;; Get initial indentation of the line we are on.
3156 ;; If line starts with label, calculate label indentation
3157 (if (save-excursion
3158 (beginning-of-line)
3159 (looking-at "[ \t]*[a-zA-Z_][a-zA-Z_0-9]*:[^:]"))
3160 (if (> (current-indentation) cperl-min-label-indent)
3161 (- (current-indentation) cperl-label-offset)
3162 ;; Do not move `parse-data', this should
3163 ;; be quick anyway:
3164 (cperl-calculate-indent))
3165 (current-indentation))))))
3166 (t
3167 (error "Unrecognized value of indent: %s" i))))
3168 (t
3169 (error "Got strange value of indent: %s" i))))))
3170
3171(defvar cperl-indent-alist
3172 '((string nil)
3173 (comment nil)
3174 (toplevel 0)
3175 (toplevel-after-parenth 2)
3176 (toplevel-continued 2)
3177 (expression 1))
3178 "Alist of indentation rules for CPerl mode.
3179The values mean:
3180 nil: do not indent;
3181 number: add this amount of indentation.
3182
3183Not finished, not used.")
3184
3185(defun cperl-where-am-i (&optional parse-start start-state)
3186 ;; Unfinished
3187 "Return a list of lists ((TYPE POS)...) of good points before the point.
3188POS may be nil if it is hard to find, say, when TYPE is `string' or `comment'.
3189
3190Not finished, not used."
3191 (save-excursion
3192 (let* ((start-point (point)) unused
3193 (s-s (cperl-get-state))
3194 (start (nth 0 s-s))
3195 (state (nth 1 s-s))
3196 (prestart (nth 3 s-s))
3197 (containing-sexp (car (cdr state)))
3198 (case-fold-search nil)
3199 (res (list (list 'parse-start start) (list 'parse-prestart prestart))))
3200 (cond ((nth 3 state) ; In string
3201 (setq res (cons (list 'string nil (nth 3 state)) res))) ; What started string
3202 ((nth 4 state) ; In comment
3203 (setq res (cons '(comment) res)))
3204 ((null containing-sexp)
3205 ;; Line is at top level.
3206 ;; Indent like the previous top level line
3207 ;; unless that ends in a closeparen without semicolon,
3208 ;; in which case this line is the first argument decl.
3209 (cperl-backward-to-noncomment (or parse-start (point-min)))
3210 ;;(skip-chars-backward " \t\f\n")
3211 (cond
3212 ((or (bobp)
3213 (memq (preceding-char) (append ";}" nil)))
3214 (setq res (cons (list 'toplevel start) res)))
3215 ((eq (preceding-char) ?\) )
3216 (setq res (cons (list 'toplevel-after-parenth start) res)))
3217 (t
3218 (setq res (cons (list 'toplevel-continued start) res)))))
3219 ((/= (char-after containing-sexp) ?{)
3220 ;; line is expression, not statement:
3221 ;; indent to just after the surrounding open.
3222 ;; skip blanks if we do not close the expression.
3223 (setq res (cons (list 'expression-blanks
3224 (progn
3225 (goto-char (1+ containing-sexp))
3226 (or (looking-at "[ \t]*\\(#\\|$\\)")
3227 (skip-chars-forward " \t"))
3228 (point)))
3229 (cons (list 'expression containing-sexp) res))))
3230 ((progn
3231 ;; Containing-expr starts with \{. Check whether it is a hash.
3232 (goto-char containing-sexp)
3233 (not (cperl-block-p)))
3234 (setq res (cons (list 'expression-blanks
3235 (progn
3236 (goto-char (1+ containing-sexp))
3237 (or (looking-at "[ \t]*\\(#\\|$\\)")
3238 (skip-chars-forward " \t"))
3239 (point)))
3240 (cons (list 'expression containing-sexp) res))))
3241 (t
3242 ;; Statement level.
3243 (setq res (cons (list 'in-block containing-sexp) res))
3244 ;; Is it a continuation or a new statement?
3245 ;; Find previous non-comment character.
3246 (cperl-backward-to-noncomment containing-sexp)
3247 ;; Back up over label lines, since they don't
3248 ;; affect whether our line is a continuation.
3249 ;; Back up comma-delimited lines too ?????
3250 (while (or (eq (preceding-char) ?\,)
3251 (save-excursion (cperl-after-label)))
3252 (if (eq (preceding-char) ?\,)
3253 ;; Will go to beginning of line, essentially
3254 ;; Will ignore embedded sexpr XXXX.
3255 (cperl-backward-to-start-of-continued-exp containing-sexp))
3256 (beginning-of-line)
3257 (cperl-backward-to-noncomment containing-sexp))
3258 ;; Now we get the answer.
3259 (if (not (memq (preceding-char) (append ";}{" '(nil)))) ; Was ?\,
3260 ;; This line is continuation of preceding line's statement.
3261 (list (list 'statement-continued containing-sexp))
3262 ;; This line starts a new statement.
3263 ;; Position following last unclosed open.
3264 (goto-char containing-sexp)
3265 ;; Is line first statement after an open-brace?
3266 (or
3267 ;; If no, find that first statement and indent like
3268 ;; it. If the first statement begins with label, do
3269 ;; not believe when the indentation of the label is too
3270 ;; small.
3271 (save-excursion
3272 (forward-char 1)
3273 (let ((colon-line-end 0))
3274 (while (progn (skip-chars-forward " \t\n" start-point)
3275 (and (< (point) start-point)
3276 (looking-at
3277 "#\\|[a-zA-Z_][a-zA-Z0-9_]*:[^:]")))
3278 ;; Skip over comments and labels following openbrace.
3279 (cond ((= (following-char) ?\#)
3280 ;;(forward-line 1)
3281 (end-of-line))
3282 ;; label:
3283 (t
3284 (save-excursion (end-of-line)
3285 (setq colon-line-end (point)))
3286 (search-forward ":"))))
3287 ;; Now at the point, after label, or at start
3288 ;; of first statement in the block.
3289 (and (< (point) start-point)
3290 (if (> colon-line-end (point))
3291 ;; Before statement after label
3292 (if (> (current-indentation)
3293 cperl-min-label-indent)
3294 (list (list 'label-in-block (point)))
3295 ;; Do not believe: `max' is involved
3296 (list
3297 (list 'label-in-block-min-indent (point))))
3298 ;; Before statement
3299 (list 'statement-in-block (point))))))
3300 ;; If no previous statement,
3301 ;; indent it relative to line brace is on.
3302 ;; For open brace in column zero, don't let statement
3303 ;; start there too. If cperl-indent-level is zero,
3304 ;; use cperl-brace-offset + cperl-continued-statement-offset instead.
3305 ;; For open-braces not the first thing in a line,
3306 ;; add in cperl-brace-imaginary-offset.
3307
3308 ;; If first thing on a line: ?????
3309 (setq unused ; This is not finished...
3310 (+ (if (and (bolp) (zerop cperl-indent-level))
3311 (+ cperl-brace-offset cperl-continued-statement-offset)
3312 cperl-indent-level)
3313 ;; Move back over whitespace before the openbrace.
3314 ;; If openbrace is not first nonwhite thing on the line,
3315 ;; add the cperl-brace-imaginary-offset.
3316 (progn (skip-chars-backward " \t")
3317 (if (bolp) 0 cperl-brace-imaginary-offset))
3318 ;; If the openbrace is preceded by a parenthesized exp,
3319 ;; move to the beginning of that;
3320 ;; possibly a different line
3321 (progn
3322 (if (eq (preceding-char) ?\))
3323 (forward-sexp -1))
3324 ;; Get initial indentation of the line we are on.
3325 ;; If line starts with label, calculate label indentation
3326 (if (save-excursion
3327 (beginning-of-line)
3328 (looking-at "[ \t]*[a-zA-Z_][a-zA-Z_0-9]*:[^:]"))
3329 (if (> (current-indentation) cperl-min-label-indent)
3330 (- (current-indentation) cperl-label-offset)
3331 (cperl-calculate-indent))
3332 (current-indentation)))))))))
3333 res)))
2878 3334
2879(defun cperl-calculate-indent-within-comment () 3335(defun cperl-calculate-indent-within-comment ()
2880 "Return the indentation amount for line, assuming that 3336 "Return the indentation amount for line, assuming that
@@ -2894,14 +3350,22 @@ the current line is to be regarded as part of a block comment."
2894 3350
2895(defun cperl-to-comment-or-eol () 3351(defun cperl-to-comment-or-eol ()
2896 "Go to position before comment on the current line, or to end of line. 3352 "Go to position before comment on the current line, or to end of line.
2897Returns true if comment is found." 3353Returns true if comment is found. In POD will not move the point."
2898 (let (state stop-in cpoint (lim (progn (end-of-line) (point)))) 3354 ;; If the line is inside other syntax groups (qq-style strings, HERE-docs)
3355 ;; then looks for literal # or end-of-line.
3356 (let (state stop-in cpoint (lim (progn (end-of-line) (point))) pr e)
3357 (or cperl-font-locking
3358 (cperl-update-syntaxification lim lim))
2899 (beginning-of-line) 3359 (beginning-of-line)
2900 (if (or 3360 (if (setq pr (get-text-property (point) 'syntax-type))
2901 (eq (get-text-property (point) 'syntax-type) 'pod) 3361 (setq e (next-single-property-change (point) 'syntax-type nil (point-max))))
2902 (re-search-forward "\\=[ \t]*\\(#\\|$\\)" lim t)) 3362 (if (or (eq pr 'pod)
3363 (if (or (not e) (> e lim)) ; deep inside a group
3364 (re-search-forward "\\=[ \t]*\\(#\\|$\\)" lim t)))
2903 (if (eq (preceding-char) ?\#) (progn (backward-char 1) t)) 3365 (if (eq (preceding-char) ?\#) (progn (backward-char 1) t))
2904 ;; Else 3366 ;; Else - need to do it the hard way
3367 (and (and e (<= e lim))
3368 (goto-char e))
2905 (while (not stop-in) 3369 (while (not stop-in)
2906 (setq state (parse-partial-sexp (point) lim nil nil nil t)) 3370 (setq state (parse-partial-sexp (point) lim nil nil nil t))
2907 ; stop at comment 3371 ; stop at comment
@@ -2933,17 +3397,11 @@ Returns true if comment is found."
2933 (setq stop-in t))) ; Finish 3397 (setq stop-in t))) ; Finish
2934 (nth 4 state)))) 3398 (nth 4 state))))
2935 3399
2936(defsubst cperl-1- (p)
2937 (max (point-min) (1- p)))
2938
2939(defsubst cperl-1+ (p)
2940 (min (point-max) (1+ p)))
2941
2942(defsubst cperl-modify-syntax-type (at how) 3400(defsubst cperl-modify-syntax-type (at how)
2943 (if (< at (point-max)) 3401 (if (< at (point-max))
2944 (progn 3402 (progn
2945 (put-text-property at (1+ at) 'syntax-table how) 3403 (put-text-property at (1+ at) 'syntax-table how)
2946 (put-text-property at (1+ at) 'rear-nonsticky t)))) 3404 (put-text-property at (1+ at) 'rear-nonsticky '(syntax-table)))))
2947 3405
2948(defun cperl-protect-defun-start (s e) 3406(defun cperl-protect-defun-start (s e)
2949 ;; C code looks for "^\\s(" to skip comment backward in "hard" situations 3407 ;; C code looks for "^\\s(" to skip comment backward in "hard" situations
@@ -2978,35 +3436,53 @@ Returns true if comment is found."
2978 ( ?\{ . ?\} ) 3436 ( ?\{ . ?\} )
2979 ( ?\< . ?\> ))) 3437 ( ?\< . ?\> )))
2980 3438
2981(defun cperl-forward-re (lim end is-2arg set-st st-l err-l argument 3439(defun cperl-cached-syntax-table (st)
3440 "Get a syntax table cached in ST, or create and cache into ST a syntax table.
3441All the entries of the syntax table are \".\", except for a backslash, which
3442is quoting."
3443 (if (car-safe st)
3444 (car st)
3445 (setcar st (make-syntax-table))
3446 (setq st (car st))
3447 (let ((i 0))
3448 (while (< i 256)
3449 (modify-syntax-entry i "." st)
3450 (setq i (1+ i))))
3451 (modify-syntax-entry ?\\ "\\" st)
3452 st))
3453
3454(defun cperl-forward-re (lim end is-2arg st-l err-l argument
2982 &optional ostart oend) 3455 &optional ostart oend)
2983 ;; Works *before* syntax recognition is done 3456"Find the end of a regular expression or a stringish construct (q[] etc).
2984 ;; May modify syntax-type text property if the situation is too hard 3457The point should be before the starting delimiter.
2985 (let (b starter ender st i i2 go-forward reset-st) 3458
3459Goes to LIM if none is found. If IS-2ARG is non-nil, assumes that it
3460is s/// or tr/// like expression. If END is nil, generates an error
3461message if needed. If SET-ST is non-nil, will use (or generate) a
3462cached syntax table in ST-L. If ERR-L is non-nil, will store the
3463error message in its CAR (unless it already contains some error
3464message). ARGUMENT should be the name of the construct (used in error
3465messages). OSTART, OEND may be set in recursive calls when processing
3466the second argument of 2ARG construct.
3467
3468Works *before* syntax recognition is done. In IS-2ARG situation may
3469modify syntax-type text property if the situation is too hard."
3470 (let (b starter ender st i i2 go-forward reset-st set-st)
2986 (skip-chars-forward " \t") 3471 (skip-chars-forward " \t")
2987 ;; ender means matching-char matcher. 3472 ;; ender means matching-char matcher.
2988 (setq b (point) 3473 (setq b (point)
2989 starter (if (eobp) 0 (char-after b)) 3474 starter (if (eobp) 0 (char-after b))
2990 ender (cdr (assoc starter cperl-starters))) 3475 ender (cdr (assoc starter cperl-starters)))
2991 ;; What if starter == ?\\ ???? 3476 ;; What if starter == ?\\ ????
2992 (if set-st 3477 (setq st (cperl-cached-syntax-table st-l))
2993 (if (car st-l)
2994 (setq st (car st-l))
2995 (setcar st-l (make-syntax-table))
2996 (setq i 0 st (car st-l))
2997 (while (< i 256)
2998 (modify-syntax-entry i "." st)
2999 (setq i (1+ i)))
3000 (modify-syntax-entry ?\\ "\\" st)))
3001 (setq set-st t) 3478 (setq set-st t)
3002 ;; Whether we have an intermediate point 3479 ;; Whether we have an intermediate point
3003 (setq i nil) 3480 (setq i nil)
3004 ;; Prepare the syntax table: 3481 ;; Prepare the syntax table:
3005 (and set-st 3482 (if (not ender) ; m/blah/, s/x//, s/x/y/
3006 (if (not ender) ; m/blah/, s/x//, s/x/y/ 3483 (modify-syntax-entry starter "$" st)
3007 (modify-syntax-entry starter "$" st) 3484 (modify-syntax-entry starter (concat "(" (list ender)) st)
3008 (modify-syntax-entry starter (concat "(" (list ender)) st) 3485 (modify-syntax-entry ender (concat ")" (list starter)) st))
3009 (modify-syntax-entry ender (concat ")" (list starter)) st)))
3010 (condition-case bb 3486 (condition-case bb
3011 (progn 3487 (progn
3012 ;; We use `$' syntax class to find matching stuff, but $$ 3488 ;; We use `$' syntax class to find matching stuff, but $$
@@ -3053,7 +3529,7 @@ Returns true if comment is found."
3053 (modify-syntax-entry starter (if (eq starter ?\\) "\\" ".") st) 3529 (modify-syntax-entry starter (if (eq starter ?\\) "\\" ".") st)
3054 (if ender (modify-syntax-entry ender "." st)) 3530 (if ender (modify-syntax-entry ender "." st))
3055 (setq set-st nil) 3531 (setq set-st nil)
3056 (setq ender (cperl-forward-re lim end nil t st-l err-l 3532 (setq ender (cperl-forward-re lim end nil st-l err-l
3057 argument starter ender) 3533 argument starter ender)
3058 ender (nth 2 ender))))) 3534 ender (nth 2 ender)))))
3059 (error (goto-char lim) 3535 (error (goto-char lim)
@@ -3078,6 +3554,33 @@ Returns true if comment is found."
3078 ;; go-forward: has 2 args, and the second part is empty 3554 ;; go-forward: has 2 args, and the second part is empty
3079 (list i i2 ender starter go-forward))) 3555 (list i i2 ender starter go-forward)))
3080 3556
3557(defun cperl-forward-group-in-re (&optional st-l)
3558 "Find the end of a group in a REx.
3559Return the error message (if any). Does not work if delimiter is `)'.
3560Works before syntax recognition is done."
3561 ;; Works *before* syntax recognition is done
3562 (or st-l (setq st-l (list nil))) ; Avoid overwriting '()
3563 (let (st b reset-st)
3564 (condition-case b
3565 (progn
3566 (setq st (cperl-cached-syntax-table st-l))
3567 (modify-syntax-entry ?\( "()" st)
3568 (modify-syntax-entry ?\) ")(" st)
3569 (setq reset-st (syntax-table))
3570 (set-syntax-table st)
3571 (forward-sexp 1))
3572 (error (message
3573 "cperl-forward-group-in-re: error %s" b)))
3574 ;; now restore the initial state
3575 (if st
3576 (progn
3577 (modify-syntax-entry ?\( "." st)
3578 (modify-syntax-entry ?\) "." st)))
3579 (if reset-st
3580 (set-syntax-table reset-st))
3581 b))
3582
3583
3081(defvar font-lock-string-face) 3584(defvar font-lock-string-face)
3082;;(defvar font-lock-reference-face) 3585;;(defvar font-lock-reference-face)
3083(defvar font-lock-constant-face) 3586(defvar font-lock-constant-face)
@@ -3103,13 +3606,24 @@ Returns true if comment is found."
3103;; d) 'Q'uoted string: 3606;; d) 'Q'uoted string:
3104;; part between markers inclusive is marked `syntax-type' ==> `string' 3607;; part between markers inclusive is marked `syntax-type' ==> `string'
3105;; part between `q' and the first marker is marked `syntax-type' ==> `prestring' 3608;; part between `q' and the first marker is marked `syntax-type' ==> `prestring'
3609;; second part of s///e is marked `syntax-type' ==> `multiline'
3610;; e) Attributes of subroutines: `attrib-group' ==> t
3611;; (or 0 if declaration); up to `{' or ';': `syntax-type' => `sub-decl'.
3612;; f) Multiline my/our declaration lists etc: `syntax-type' => `multiline'
3613
3614;;; In addition, some parts of RExes may be marked as `REx-interpolated'
3615;;; (value: 0 in //o, 1 if "interpolated variable" is whole-REx, t otherwise).
3106 3616
3107(defun cperl-unwind-to-safe (before &optional end) 3617(defun cperl-unwind-to-safe (before &optional end)
3108 ;; if BEFORE, go to the previous start-of-line on each step of unwinding 3618 ;; if BEFORE, go to the previous start-of-line on each step of unwinding
3109 (let ((pos (point)) opos) 3619 (let ((pos (point)) opos)
3110 (setq opos pos) 3620 (while (and pos (progn
3111 (while (and pos (get-text-property pos 'syntax-type)) 3621 (beginning-of-line)
3112 (setq pos (previous-single-property-change pos 'syntax-type)) 3622 (get-text-property (setq pos (point)) 'syntax-type)))
3623 (setq opos pos
3624 pos (cperl-beginning-of-property pos 'syntax-type))
3625 (if (eq pos (point-min))
3626 (setq pos nil))
3113 (if pos 3627 (if pos
3114 (if before 3628 (if before
3115 (progn 3629 (progn
@@ -3126,32 +3640,117 @@ Returns true if comment is found."
3126 (setq pos (point)) 3640 (setq pos (point))
3127 (if end 3641 (if end
3128 ;; Do the same for end, going small steps 3642 ;; Do the same for end, going small steps
3129 (progn 3643 (save-excursion
3130 (while (and end (get-text-property end 'syntax-type)) 3644 (while (and end (get-text-property end 'syntax-type))
3131 (setq pos end 3645 (setq pos end
3132 end (next-single-property-change end 'syntax-type))) 3646 end (next-single-property-change end 'syntax-type nil (point-max)))
3647 (if end (progn (goto-char end)
3648 (or (bolp) (forward-line 1))
3649 (setq end (point)))))
3133 (or end pos))))) 3650 (or end pos)))))
3134 3651
3652;;; These are needed for byte-compile (at least with v19)
3135(defvar cperl-nonoverridable-face) 3653(defvar cperl-nonoverridable-face)
3654(defvar font-lock-variable-name-face)
3136(defvar font-lock-function-name-face) 3655(defvar font-lock-function-name-face)
3656(defvar font-lock-keyword-face)
3657(defvar font-lock-builtin-face)
3658(defvar font-lock-type-face)
3137(defvar font-lock-comment-face) 3659(defvar font-lock-comment-face)
3660(defvar font-lock-warning-face)
3138 3661
3139(defun cperl-find-pods-heres (&optional min max non-inter end ignore-max) 3662(defun cperl-find-sub-attrs (&optional st-l b-fname e-fname pos)
3663 "Syntaxically mark (and fontify) attributes of a subroutine.
3664Should be called with the point before leading colon of an attribute."
3665 ;; Works *before* syntax recognition is done
3666 (or st-l (setq st-l (list nil))) ; Avoid overwriting '()
3667 (let (st b p reset-st after-first (start (point)) start1 end1)
3668 (condition-case b
3669 (while (looking-at
3670 (concat
3671 "\\(" ; 1=optional? colon
3672 ":" cperl-maybe-white-and-comment-rex ; 2=whitespace/comment?
3673 "\\)"
3674 (if after-first "?" "")
3675 ;; No space between name and paren allowed...
3676 "\\(\\sw+\\)" ; 3=name
3677 "\\((\\)?")) ; 4=optional paren
3678 (and (match-beginning 1)
3679 (cperl-postpone-fontification
3680 (match-beginning 0) (cperl-1+ (match-beginning 0))
3681 'face font-lock-constant-face))
3682 (setq start1 (match-beginning 3) end1 (match-end 3))
3683 (cperl-postpone-fontification start1 end1
3684 'face font-lock-constant-face)
3685 (goto-char end1) ; end or before `('
3686 (if (match-end 4) ; Have attribute arguments...
3687 (progn
3688 (if st nil
3689 (setq st (cperl-cached-syntax-table st-l))
3690 (modify-syntax-entry ?\( "()" st)
3691 (modify-syntax-entry ?\) ")(" st))
3692 (setq reset-st (syntax-table) p (point))
3693 (set-syntax-table st)
3694 (forward-sexp 1)
3695 (set-syntax-table reset-st)
3696 (setq reset-st nil)
3697 (cperl-commentify p (point) t))) ; mark as string
3698 (forward-comment (buffer-size))
3699 (setq after-first t))
3700 (error (message
3701 "L%d: attribute `%s': %s"
3702 (count-lines (point-min) (point))
3703 (and start1 end1 (buffer-substring start1 end1)) b)
3704 (setq start nil)))
3705 (and start
3706 (progn
3707 (put-text-property start (point)
3708 'attrib-group (if (looking-at "{") t 0))
3709 (and pos
3710 (< 1 (count-lines (+ 3 pos) (point))) ; end of `sub'
3711 ;; Apparently, we do not need `multiline': faces added now
3712 (put-text-property (+ 3 pos) (cperl-1+ (point))
3713 'syntax-type 'sub-decl))
3714 (and b-fname ; Fontify here: the following condition
3715 (cperl-postpone-fontification ; is too hard to determine by
3716 b-fname e-fname 'face ; a REx, so do it here
3717 (if (looking-at "{")
3718 font-lock-function-name-face
3719 font-lock-variable-name-face)))))
3720 ;; now restore the initial state
3721 (if st
3722 (progn
3723 (modify-syntax-entry ?\( "." st)
3724 (modify-syntax-entry ?\) "." st)))
3725 (if reset-st
3726 (set-syntax-table reset-st))))
3727
3728(defsubst cperl-look-at-leading-count (is-x-REx e)
3729 (if (re-search-forward (concat "\\=" (if is-x-REx "[ \t\n]*" "") "[{?+*]")
3730 (1- e) t) ; return nil on failure, no moving
3731 (if (eq ?\{ (preceding-char)) nil
3732 (cperl-postpone-fontification
3733 (1- (point)) (point)
3734 'face font-lock-warning-face))))
3735
3736;;; Debugging this may require (setq max-specpdl-size 2000)...
3737(defun cperl-find-pods-heres (&optional min max non-inter end ignore-max end-of-here-doc)
3140 "Scans the buffer for hard-to-parse Perl constructions. 3738 "Scans the buffer for hard-to-parse Perl constructions.
3141If `cperl-pod-here-fontify' is not-nil after evaluation, will fontify 3739If `cperl-pod-here-fontify' is not-nil after evaluation, will fontify
3142the sections using `cperl-pod-head-face', `cperl-pod-face', 3740the sections using `cperl-pod-head-face', `cperl-pod-face',
3143`cperl-here-face'." 3741`cperl-here-face'."
3144 (interactive) 3742 (interactive)
3145 (or min (setq min (point-min) 3743 (or min (setq min (point-min)
3146 cperl-syntax-state nil 3744 cperl-syntax-state nil
3147 cperl-syntax-done-to min)) 3745 cperl-syntax-done-to min))
3148 (or max (setq max (point-max))) 3746 (or max (setq max (point-max)))
3149 (let* ((cperl-pod-here-fontify (eval cperl-pod-here-fontify)) go tmpend 3747 (let* ((cperl-pod-here-fontify (eval cperl-pod-here-fontify)) go tmpend
3150 face head-face here-face b e bb tag qtag b1 e1 argument i c tail tb 3748 face head-face here-face b e bb tag qtag b1 e1 argument i c tail tb
3151 is-REx is-x-REx REx-comment-start REx-comment-end was-comment i2 3749 is-REx is-x-REx REx-subgr-start REx-subgr-end was-subgr i2 hairy-RE
3152 (case-fold-search nil) (inhibit-read-only t) (buffer-undo-list t) 3750 (case-fold-search nil) (inhibit-read-only t) (buffer-undo-list t)
3153 (modified (buffer-modified-p)) 3751 (modified (buffer-modified-p)) overshoot is-o-REx
3154 (after-change-functions nil) 3752 (after-change-functions nil)
3753 (cperl-font-locking t)
3155 (use-syntax-state (and cperl-syntax-state 3754 (use-syntax-state (and cperl-syntax-state
3156 (>= min (car cperl-syntax-state)))) 3755 (>= min (car cperl-syntax-state))))
3157 (state-point (if use-syntax-state 3756 (state-point (if use-syntax-state
@@ -3162,33 +3761,62 @@ the sections using `cperl-pod-head-face', `cperl-pod-face',
3162 ;; (st-l '(nil)) (err-l '(nil)) ; Would overwrite - propagates from a function call to a function call! 3761 ;; (st-l '(nil)) (err-l '(nil)) ; Would overwrite - propagates from a function call to a function call!
3163 (st-l (list nil)) (err-l (list nil)) 3762 (st-l (list nil)) (err-l (list nil))
3164 ;; Somehow font-lock may be not loaded yet... 3763 ;; Somehow font-lock may be not loaded yet...
3764 ;; (e.g., when building TAGS via command-line call)
3165 (font-lock-string-face (if (boundp 'font-lock-string-face) 3765 (font-lock-string-face (if (boundp 'font-lock-string-face)
3166 font-lock-string-face 3766 font-lock-string-face
3167 'font-lock-string-face)) 3767 'font-lock-string-face))
3168 (font-lock-constant-face (if (boundp 'font-lock-constant-face) 3768 (my-cperl-delimiters-face (if (boundp 'font-lock-constant-face)
3169 font-lock-constant-face 3769 font-lock-constant-face
3170 'font-lock-constant-face)) 3770 'font-lock-constant-face))
3171 (font-lock-function-name-face 3771 (my-cperl-REx-spec-char-face ; [] ^.$ and wrapper-of ({})
3172 (if (boundp 'font-lock-function-name-face) 3772 (if (boundp 'font-lock-function-name-face)
3173 font-lock-function-name-face 3773 font-lock-function-name-face
3174 'font-lock-function-name-face)) 3774 'font-lock-function-name-face))
3775 (font-lock-variable-name-face ; interpolated vars and ({})-code
3776 (if (boundp 'font-lock-variable-name-face)
3777 font-lock-variable-name-face
3778 'font-lock-variable-name-face))
3779 (font-lock-function-name-face ; used in `cperl-find-sub-attrs'
3780 (if (boundp 'font-lock-function-name-face)
3781 font-lock-function-name-face
3782 'font-lock-function-name-face))
3783 (font-lock-constant-face ; used in `cperl-find-sub-attrs'
3784 (if (boundp 'font-lock-constant-face)
3785 font-lock-constant-face
3786 'font-lock-constant-face))
3787 (my-cperl-REx-0length-face ; 0-length, (?:)etc, non-literal \
3788 (if (boundp 'font-lock-builtin-face)
3789 font-lock-builtin-face
3790 'font-lock-builtin-face))
3175 (font-lock-comment-face 3791 (font-lock-comment-face
3176 (if (boundp 'font-lock-comment-face) 3792 (if (boundp 'font-lock-comment-face)
3177 font-lock-comment-face 3793 font-lock-comment-face
3178 'font-lock-comment-face)) 3794 'font-lock-comment-face))
3179 (cperl-nonoverridable-face 3795 (font-lock-warning-face
3796 (if (boundp 'font-lock-warning-face)
3797 font-lock-warning-face
3798 'font-lock-warning-face))
3799 (my-cperl-REx-ctl-face ; (|)
3800 (if (boundp 'font-lock-keyword-face)
3801 font-lock-keyword-face
3802 'font-lock-keyword-face))
3803 (my-cperl-REx-modifiers-face ; //gims
3180 (if (boundp 'cperl-nonoverridable-face) 3804 (if (boundp 'cperl-nonoverridable-face)
3181 cperl-nonoverridable-face 3805 cperl-nonoverridable-face
3182 'cperl-nonoverridable)) 3806 'cperl-nonoverridable-face))
3807 (my-cperl-REx-length1-face ; length=1 escaped chars, POSIX classes
3808 (if (boundp 'font-lock-type-face)
3809 font-lock-type-face
3810 'font-lock-type-face))
3183 (stop-point (if ignore-max 3811 (stop-point (if ignore-max
3184 (point-max) 3812 (point-max)
3185 max)) 3813 max))
3186 (search 3814 (search
3187 (concat 3815 (concat
3188 "\\(\\`\n?\\|^\n\\)=" 3816 "\\(\\`\n?\\|^\n\\)=" ; POD
3189 "\\|" 3817 "\\|"
3190 ;; One extra () before this: 3818 ;; One extra () before this:
3191 "<<" 3819 "<<" ; HERE-DOC
3192 "\\(" ; 1 + 1 3820 "\\(" ; 1 + 1
3193 ;; First variant "BLAH" or just ``. 3821 ;; First variant "BLAH" or just ``.
3194 "[ \t]*" ; Yes, whitespace is allowed! 3822 "[ \t]*" ; Yes, whitespace is allowed!
@@ -3204,36 +3832,44 @@ the sections using `cperl-pod-head-face', `cperl-pod-face',
3204 "\\)" 3832 "\\)"
3205 "\\|" 3833 "\\|"
3206 ;; 1+6 extra () before this: 3834 ;; 1+6 extra () before this:
3207 "^[ \t]*\\(format\\)[ \t]*\\([a-zA-Z0-9_]+\\)?[ \t]*=[ \t]*$" 3835 "^[ \t]*\\(format\\)[ \t]*\\([a-zA-Z0-9_]+\\)?[ \t]*=[ \t]*$" ;FRMAT
3208 (if cperl-use-syntax-table-text-property 3836 (if cperl-use-syntax-table-text-property
3209 (concat 3837 (concat
3210 "\\|" 3838 "\\|"
3211 ;; 1+6+2=9 extra () before this: 3839 ;; 1+6+2=9 extra () before this:
3212 "\\<\\(q[wxqr]?\\|[msy]\\|tr\\)\\>" 3840 "\\<\\(q[wxqr]?\\|[msy]\\|tr\\)\\>" ; QUOTED CONSTRUCT
3213 "\\|" 3841 "\\|"
3214 ;; 1+6+2+1=10 extra () before this: 3842 ;; 1+6+2+1=10 extra () before this:
3215 "\\([?/<]\\)" ; /blah/ or ?blah? or <file*glob> 3843 "\\([?/<]\\)" ; /blah/ or ?blah? or <file*glob>
3216 "\\|" 3844 "\\|"
3217 ;; 1+6+2+1+1=11 extra () before this: 3845 ;; 1+6+2+1+1=11 extra () before this
3218 "\\<sub\\>[ \t]*\\([a-zA-Z_:'0-9]+[ \t]*\\)?\\(([^()]*)\\)" 3846 "\\<sub\\>" ; sub with proto/attr
3847 "\\("
3848 cperl-white-and-comment-rex
3849 "\\(::[a-zA-Z_:'0-9]*\\|[a-zA-Z_'][a-zA-Z_:'0-9]*\\)\\)?" ; name
3850 "\\("
3851 cperl-maybe-white-and-comment-rex
3852 "\\(([^()]*)\\|:[^:]\\)\\)" ; prototype or attribute start
3219 "\\|" 3853 "\\|"
3220 ;; 1+6+2+1+1+2=13 extra () before this: 3854 ;; 1+6+2+1+1+6=17 extra () before this:
3221 "\\$\\(['{]\\)" 3855 "\\$\\(['{]\\)" ; $' or ${foo}
3222 "\\|" 3856 "\\|"
3223 ;; 1+6+2+1+1+2+1=14 extra () before this: 3857 ;; 1+6+2+1+1+6+1=18 extra () before this (old pack'var syntax;
3858 ;; we do not support intervening comments...):
3224 "\\(\\<sub[ \t\n\f]+\\|[&*$@%]\\)[a-zA-Z0-9_]*'" 3859 "\\(\\<sub[ \t\n\f]+\\|[&*$@%]\\)[a-zA-Z0-9_]*'"
3225 ;; 1+6+2+1+1+2+1+1=15 extra () before this: 3860 ;; 1+6+2+1+1+6+1+1=19 extra () before this:
3226 "\\|" 3861 "\\|"
3227 "__\\(END\\|DATA\\)__" 3862 "__\\(END\\|DATA\\)__" ; __END__ or __DATA__
3228 ;; 1+6+2+1+1+2+1+1+1=16 extra () before this: 3863 ;; 1+6+2+1+1+6+1+1+1=20 extra () before this:
3229 "\\|" 3864 "\\|"
3230 "\\\\\\(['`\"($]\\)") 3865 "\\\\\\(['`\"($]\\)") ; BACKWACKED something-hairy
3231 "")))) 3866 ""))))
3232 (unwind-protect 3867 (unwind-protect
3233 (progn 3868 (progn
3234 (save-excursion 3869 (save-excursion
3235 (or non-inter 3870 (or non-inter
3236 (message "Scanning for \"hard\" Perl constructions...")) 3871 (message "Scanning for \"hard\" Perl constructions..."))
3872 ;;(message "find: %s --> %s" min max)
3237 (and cperl-pod-here-fontify 3873 (and cperl-pod-here-fontify
3238 ;; We had evals here, do not know why... 3874 ;; We had evals here, do not know why...
3239 (setq face cperl-pod-face 3875 (setq face cperl-pod-face
@@ -3241,16 +3877,22 @@ the sections using `cperl-pod-head-face', `cperl-pod-face',
3241 here-face cperl-here-face)) 3877 here-face cperl-here-face))
3242 (remove-text-properties min max 3878 (remove-text-properties min max
3243 '(syntax-type t in-pod t syntax-table t 3879 '(syntax-type t in-pod t syntax-table t
3880 attrib-group t
3881 REx-interpolated t
3244 cperl-postpone t 3882 cperl-postpone t
3245 syntax-subtype t 3883 syntax-subtype t
3246 rear-nonsticky t 3884 rear-nonsticky t
3885 front-sticky t
3247 here-doc-group t 3886 here-doc-group t
3248 first-format-line t 3887 first-format-line t
3888 REx-part2 t
3249 indentable t)) 3889 indentable t))
3250 ;; Need to remove face as well... 3890 ;; Need to remove face as well...
3251 (goto-char min) 3891 (goto-char min)
3252 (and (eq system-type 'emx) 3892 (and (eq system-type 'emx)
3253 (looking-at "extproc[ \t]") ; Analogue of #! 3893 (eq (point) 1)
3894 (let ((case-fold-search t))
3895 (looking-at "extproc[ \t]")) ; Analogue of #!
3254 (cperl-commentify min 3896 (cperl-commentify min
3255 (save-excursion (end-of-line) (point)) 3897 (save-excursion (end-of-line) (point))
3256 nil)) 3898 nil))
@@ -3258,11 +3900,38 @@ the sections using `cperl-pod-head-face', `cperl-pod-face',
3258 (< (point) max) 3900 (< (point) max)
3259 (re-search-forward search max t)) 3901 (re-search-forward search max t))
3260 (setq tmpend nil) ; Valid for most cases 3902 (setq tmpend nil) ; Valid for most cases
3903 (setq b (match-beginning 0)
3904 state (save-excursion (parse-partial-sexp
3905 state-point b nil nil state))
3906 state-point b)
3261 (cond 3907 (cond
3908 ;; 1+6+2+1+1+6=17 extra () before this:
3909 ;; "\\$\\(['{]\\)"
3910 ((match-beginning 18) ; $' or ${foo}
3911 (if (eq (preceding-char) ?\') ; $'
3912 (progn
3913 (setq b (1- (point))
3914 state (parse-partial-sexp
3915 state-point (1- b) nil nil state)
3916 state-point (1- b))
3917 (if (nth 3 state) ; in string
3918 (cperl-modify-syntax-type (1- b) cperl-st-punct))
3919 (goto-char (1+ b)))
3920 ;; else: ${
3921 (setq bb (match-beginning 0))
3922 (cperl-modify-syntax-type bb cperl-st-punct)))
3923 ;; No processing in strings/comments beyond this point:
3924 ((or (nth 3 state) (nth 4 state))
3925 t) ; Do nothing in comment/string
3262 ((match-beginning 1) ; POD section 3926 ((match-beginning 1) ; POD section
3263 ;; "\\(\\`\n?\\|^\n\\)=" 3927 ;; "\\(\\`\n?\\|^\n\\)="
3264 (if (looking-at "cut\\>") 3928 (setq b (match-beginning 0)
3265 (if ignore-max 3929 state (parse-partial-sexp
3930 state-point b nil nil state)
3931 state-point b)
3932 (if (or (nth 3 state) (nth 4 state)
3933 (looking-at "cut\\>"))
3934 (if (or (nth 3 state) (nth 4 state) ignore-max)
3266 nil ; Doing a chunk only 3935 nil ; Doing a chunk only
3267 (message "=cut is not preceded by a POD section") 3936 (message "=cut is not preceded by a POD section")
3268 (or (car err-l) (setcar err-l (point)))) 3937 (or (car err-l) (setcar err-l (point))))
@@ -3288,11 +3957,15 @@ the sections using `cperl-pod-head-face', `cperl-pod-face',
3288 (progn 3957 (progn
3289 (remove-text-properties 3958 (remove-text-properties
3290 max e '(syntax-type t in-pod t syntax-table t 3959 max e '(syntax-type t in-pod t syntax-table t
3960 attrib-group t
3961 REx-interpolated t
3291 cperl-postpone t 3962 cperl-postpone t
3292 syntax-subtype t 3963 syntax-subtype t
3293 here-doc-group t 3964 here-doc-group t
3294 rear-nonsticky t 3965 rear-nonsticky t
3966 front-sticky t
3295 first-format-line t 3967 first-format-line t
3968 REx-part2 t
3296 indentable t)) 3969 indentable t))
3297 (setq tmpend tb))) 3970 (setq tmpend tb)))
3298 (put-text-property b e 'in-pod t) 3971 (put-text-property b e 'in-pod t)
@@ -3335,7 +4008,8 @@ the sections using `cperl-pod-head-face', `cperl-pod-face',
3335 (or (eq e (point-max)) 4008 (or (eq e (point-max))
3336 (forward-char -1)))) ; Prepare for immediate POD start. 4009 (forward-char -1)))) ; Prepare for immediate POD start.
3337 ;; Here document 4010 ;; Here document
3338 ;; We do only one here-per-line 4011 ;; We can do many here-per-line;
4012 ;; but multiline quote on the same line as <<HERE confuses us...
3339 ;; ;; One extra () before this: 4013 ;; ;; One extra () before this:
3340 ;;"<<" 4014 ;;"<<"
3341 ;; "\\(" ; 1 + 1 4015 ;; "\\(" ; 1 + 1
@@ -3352,21 +4026,42 @@ the sections using `cperl-pod-head-face', `cperl-pod-face',
3352 ;; "\\(\\)" ; To preserve count of pars :-( 6 + 1 4026 ;; "\\(\\)" ; To preserve count of pars :-( 6 + 1
3353 ;; "\\)" 4027 ;; "\\)"
3354 ((match-beginning 2) ; 1 + 1 4028 ((match-beginning 2) ; 1 + 1
3355 ;; Abort in comment: 4029 (setq b (point)
3356 (setq b (point))
3357 (setq state (parse-partial-sexp state-point b nil nil state)
3358 state-point b
3359 tb (match-beginning 0) 4030 tb (match-beginning 0)
3360 i (or (nth 3 state) (nth 4 state))) 4031 c (and ; not HERE-DOC
3361 (if i 4032 (match-beginning 5)
3362 (setq c t) 4033 (save-match-data
3363 (setq c (and 4034 (or (looking-at "[ \t]*(") ; << function_call()
3364 (match-beginning 5) 4035 (save-excursion ; 1 << func_name, or $foo << 10
3365 (not (match-beginning 6)) ; Empty 4036 (condition-case nil
3366 (looking-at 4037 (progn
3367 "[ \t]*[=0-9$@%&(]")))) 4038 (goto-char tb)
4039 ;;; XXX What to do: foo <<bar ???
4040 ;;; XXX Need to support print {a} <<B ???
4041 (forward-sexp -1)
4042 (save-match-data
4043 ; $foo << b; $f .= <<B;
4044 ; ($f+1) << b; a($f) . <<B;
4045 ; foo 1, <<B; $x{a} <<b;
4046 (cond
4047 ((looking-at "[0-9$({]")
4048 (forward-sexp 1)
4049 (and
4050 (looking-at "[ \t]*<<")
4051 (condition-case nil
4052 ;; print $foo <<EOF
4053 (progn
4054 (forward-sexp -2)
4055 (not
4056 (looking-at "\\(printf?\\|system\\|exec\\|sort\\)\\>")))
4057 (error t)))))))
4058 (error nil))) ; func(<<EOF)
4059 (and (not (match-beginning 6)) ; Empty
4060 (looking-at
4061 "[ \t]*[=0-9$@%&(]"))))))
3368 (if c ; Not here-doc 4062 (if c ; Not here-doc
3369 nil ; Skip it. 4063 nil ; Skip it.
4064 (setq c (match-end 2)) ; 1 + 1
3370 (if (match-beginning 5) ;4 + 1 4065 (if (match-beginning 5) ;4 + 1
3371 (setq b1 (match-beginning 5) ; 4 + 1 4066 (setq b1 (match-beginning 5) ; 4 + 1
3372 e1 (match-end 5)) ; 4 + 1 4067 e1 (match-end 5)) ; 4 + 1
@@ -3376,15 +4071,20 @@ the sections using `cperl-pod-head-face', `cperl-pod-face',
3376 qtag (regexp-quote tag)) 4071 qtag (regexp-quote tag))
3377 (cond (cperl-pod-here-fontify 4072 (cond (cperl-pod-here-fontify
3378 ;; Highlight the starting delimiter 4073 ;; Highlight the starting delimiter
3379 (cperl-postpone-fontification b1 e1 'face font-lock-constant-face) 4074 (cperl-postpone-fontification
4075 b1 e1 'face my-cperl-delimiters-face)
3380 (cperl-put-do-not-fontify b1 e1 t))) 4076 (cperl-put-do-not-fontify b1 e1 t)))
3381 (forward-line) 4077 (forward-line)
4078 (setq i (point))
4079 (if end-of-here-doc
4080 (goto-char end-of-here-doc))
3382 (setq b (point)) 4081 (setq b (point))
3383 ;; We do not search to max, since we may be called from 4082 ;; We do not search to max, since we may be called from
3384 ;; some hook of fontification, and max is random 4083 ;; some hook of fontification, and max is random
3385 (or (and (re-search-forward (concat "^" qtag "$") 4084 (or (and (re-search-forward (concat "^" qtag "$")
3386 stop-point 'toend) 4085 stop-point 'toend)
3387 (eq (following-char) ?\n)) 4086 ;;;(eq (following-char) ?\n) ; XXXX WHY???
4087 )
3388 (progn ; Pretend we matched at the end 4088 (progn ; Pretend we matched at the end
3389 (goto-char (point-max)) 4089 (goto-char (point-max))
3390 (re-search-forward "\\'") 4090 (re-search-forward "\\'")
@@ -3393,8 +4093,9 @@ the sections using `cperl-pod-head-face', `cperl-pod-face',
3393 (if cperl-pod-here-fontify 4093 (if cperl-pod-here-fontify
3394 (progn 4094 (progn
3395 ;; Highlight the ending delimiter 4095 ;; Highlight the ending delimiter
3396 (cperl-postpone-fontification (match-beginning 0) (match-end 0) 4096 (cperl-postpone-fontification
3397 'face font-lock-constant-face) 4097 (match-beginning 0) (match-end 0)
4098 'face my-cperl-delimiters-face)
3398 (cperl-put-do-not-fontify b (match-end 0) t) 4099 (cperl-put-do-not-fontify b (match-end 0) t)
3399 ;; Highlight the HERE-DOC 4100 ;; Highlight the HERE-DOC
3400 (cperl-postpone-fontification b (match-beginning 0) 4101 (cperl-postpone-fontification b (match-beginning 0)
@@ -3404,10 +4105,21 @@ the sections using `cperl-pod-head-face', `cperl-pod-face',
3404 'syntax-type 'here-doc) 4105 'syntax-type 'here-doc)
3405 (put-text-property (match-beginning 0) e1 4106 (put-text-property (match-beginning 0) e1
3406 'syntax-type 'here-doc-delim) 4107 'syntax-type 'here-doc-delim)
3407 (put-text-property b e1 4108 (put-text-property b e1 'here-doc-group t)
3408 'here-doc-group t) 4109 ;; This makes insertion at the start of HERE-DOC update
4110 ;; the whole construct:
4111 (put-text-property b (cperl-1+ b) 'front-sticky '(syntax-type))
3409 (cperl-commentify b e1 nil) 4112 (cperl-commentify b e1 nil)
3410 (cperl-put-do-not-fontify b (match-end 0) t) 4113 (cperl-put-do-not-fontify b (match-end 0) t)
4114 ;; Cache the syntax info...
4115 (setq cperl-syntax-state (cons state-point state))
4116 ;; ... and process the rest of the line...
4117 (setq overshoot
4118 (elt ; non-inter ignore-max
4119 (cperl-find-pods-heres c i t end t e1) 1))
4120 (if (and overshoot (> overshoot (point)))
4121 (goto-char overshoot)
4122 (setq overshoot e1))
3411 (if (> e1 max) 4123 (if (> e1 max)
3412 (setq tmpend tb)))) 4124 (setq tmpend tb))))
3413 ;; format 4125 ;; format
@@ -3462,7 +4174,7 @@ the sections using `cperl-pod-head-face', `cperl-pod-face',
3462 (if (> (point) max) 4174 (if (> (point) max)
3463 (setq tmpend tb)) 4175 (setq tmpend tb))
3464 (put-text-property b (point) 'syntax-type 'format)) 4176 (put-text-property b (point) 'syntax-type 'format))
3465 ;; Regexp: 4177 ;; qq-like String or Regexp:
3466 ((or (match-beginning 10) (match-beginning 11)) 4178 ((or (match-beginning 10) (match-beginning 11))
3467 ;; 1+6+2=9 extra () before this: 4179 ;; 1+6+2=9 extra () before this:
3468 ;; "\\<\\(q[wxqr]?\\|[msy]\\|tr\\)\\>" 4180 ;; "\\<\\(q[wxqr]?\\|[msy]\\|tr\\)\\>"
@@ -3471,10 +4183,10 @@ the sections using `cperl-pod-head-face', `cperl-pod-face',
3471 (setq b1 (if (match-beginning 10) 10 11) 4183 (setq b1 (if (match-beginning 10) 10 11)
3472 argument (buffer-substring 4184 argument (buffer-substring
3473 (match-beginning b1) (match-end b1)) 4185 (match-beginning b1) (match-end b1))
3474 b (point) 4186 b (point) ; end of qq etc
3475 i b 4187 i b
3476 c (char-after (match-beginning b1)) 4188 c (char-after (match-beginning b1))
3477 bb (char-after (1- (match-beginning b1))) ; tmp holder 4189 bb (char-after (1- (match-beginning b1))) ; tmp holder
3478 ;; bb == "Not a stringy" 4190 ;; bb == "Not a stringy"
3479 bb (if (eq b1 10) ; user variables/whatever 4191 bb (if (eq b1 10) ; user variables/whatever
3480 (and (memq bb (append "$@%*#_:-&>" nil)) ; $#y) 4192 (and (memq bb (append "$@%*#_:-&>" nil)) ; $#y)
@@ -3488,7 +4200,7 @@ the sections using `cperl-pod-head-face', `cperl-pod-face',
3488 (- (match-beginning b1) 2)) 4200 (- (match-beginning b1) 2))
3489 ?\-)) 4201 ?\-))
3490 ((eq bb ?\&) 4202 ((eq bb ?\&)
3491 (not (eq (char-after ; &&m/blah/ 4203 (not (eq (char-after ; &&m/blah/
3492 (- (match-beginning b1) 2)) 4204 (- (match-beginning b1) 2))
3493 ?\&))) 4205 ?\&)))
3494 (t t))) 4206 (t t)))
@@ -3506,41 +4218,40 @@ the sections using `cperl-pod-head-face', `cperl-pod-face',
3506 (setq argument "" 4218 (setq argument ""
3507 b1 nil 4219 b1 nil
3508 bb ; Not a regexp? 4220 bb ; Not a regexp?
3509 (progn 4221 (not
3510 (not 4222 ;; What is below: regexp-p?
3511 ;; What is below: regexp-p? 4223 (and
3512 (and 4224 (or (memq (preceding-char)
3513 (or (memq (preceding-char) 4225 (append (if (memq c '(?\? ?\<))
3514 (append (if (memq c '(?\? ?\<)) 4226 ;; $a++ ? 1 : 2
3515 ;; $a++ ? 1 : 2 4227 "~{(=|&*!,;:["
3516 "~{(=|&*!,;:" 4228 "~{(=|&+-*!,;:[") nil))
3517 "~{(=|&+-*!,;:") nil)) 4229 (and (eq (preceding-char) ?\})
3518 (and (eq (preceding-char) ?\}) 4230 (cperl-after-block-p (point-min)))
3519 (cperl-after-block-p (point-min))) 4231 (and (eq (char-syntax (preceding-char)) ?w)
3520 (and (eq (char-syntax (preceding-char)) ?w) 4232 (progn
3521 (progn 4233 (forward-sexp -1)
3522 (forward-sexp -1)
3523;; After these keywords `/' starts a RE. One should add all the 4234;; After these keywords `/' starts a RE. One should add all the
3524;; functions/builtins which expect an argument, but ... 4235;; functions/builtins which expect an argument, but ...
3525 (if (eq (preceding-char) ?-) 4236 (if (eq (preceding-char) ?-)
3526 ;; -d ?foo? is a RE 4237 ;; -d ?foo? is a RE
3527 (looking-at "[a-zA-Z]\\>") 4238 (looking-at "[a-zA-Z]\\>")
3528 (and 4239 (and
3529 (not (memq (preceding-char) 4240 (not (memq (preceding-char)
3530 '(?$ ?@ ?& ?%))) 4241 '(?$ ?@ ?& ?%)))
3531 (looking-at 4242 (looking-at
3532 "\\(while\\|if\\|unless\\|until\\|and\\|or\\|not\\|xor\\|split\\|grep\\|map\\|print\\)\\>"))))) 4243 "\\(while\\|if\\|unless\\|until\\|and\\|or\\|not\\|xor\\|split\\|grep\\|map\\|print\\)\\>")))))
3533 (and (eq (preceding-char) ?.) 4244 (and (eq (preceding-char) ?.)
3534 (eq (char-after (- (point) 2)) ?.)) 4245 (eq (char-after (- (point) 2)) ?.))
3535 (bobp)) 4246 (bobp))
3536 ;; m|blah| ? foo : bar; 4247 ;; m|blah| ? foo : bar;
3537 (not 4248 (not
3538 (and (eq c ?\?) 4249 (and (eq c ?\?)
3539 cperl-use-syntax-table-text-property 4250 cperl-use-syntax-table-text-property
3540 (not (bobp)) 4251 (not (bobp))
3541 (progn 4252 (progn
3542 (forward-char -1) 4253 (forward-char -1)
3543 (looking-at "\\s|"))))))) 4254 (looking-at "\\s|"))))))
3544 b (1- b)) 4255 b (1- b))
3545 ;; s y tr m 4256 ;; s y tr m
3546 ;; Check for $a -> y 4257 ;; Check for $a -> y
@@ -3550,13 +4261,9 @@ the sections using `cperl-pod-head-face', `cperl-pod-face',
3550 (eq (char-after (- go 2)) ?-)) 4261 (eq (char-after (- go 2)) ?-))
3551 ;; Not a regexp 4262 ;; Not a regexp
3552 (setq bb t)))) 4263 (setq bb t))))
3553 (or bb (setq state (parse-partial-sexp
3554 state-point b nil nil state)
3555 state-point b))
3556 (setq bb (or bb (nth 3 state) (nth 4 state)))
3557 (goto-char b)
3558 (or bb 4264 (or bb
3559 (progn 4265 (progn
4266 (goto-char b)
3560 (if (looking-at "[ \t\n\f]+\\(#[^\n]*\n[ \t\n\f]*\\)+") 4267 (if (looking-at "[ \t\n\f]+\\(#[^\n]*\n[ \t\n\f]*\\)+")
3561 (goto-char (match-end 0)) 4268 (goto-char (match-end 0))
3562 (skip-chars-forward " \t\n\f")) 4269 (skip-chars-forward " \t\n\f"))
@@ -3593,6 +4300,8 @@ the sections using `cperl-pod-head-face', `cperl-pod-face',
3593 (skip-chars-backward " \t\n\f") 4300 (skip-chars-backward " \t\n\f")
3594 (memq (preceding-char) 4301 (memq (preceding-char)
3595 (append "$@%&*" nil)))) 4302 (append "$@%&*" nil))))
4303 (setq bb t))
4304 ((eobp)
3596 (setq bb t))))) 4305 (setq bb t)))))
3597 (if bb 4306 (if bb
3598 (goto-char i) 4307 (goto-char i)
@@ -3605,15 +4314,16 @@ the sections using `cperl-pod-head-face', `cperl-pod-face',
3605 ;; qtag means two-arg matcher, may be reset to 4314 ;; qtag means two-arg matcher, may be reset to
3606 ;; 2 or 3 later if some special quoting is needed. 4315 ;; 2 or 3 later if some special quoting is needed.
3607 ;; e1 means matching-char matcher. 4316 ;; e1 means matching-char matcher.
3608 (setq b (point) 4317 (setq b (point) ; before the first delimiter
3609 ;; has 2 args 4318 ;; has 2 args
3610 i2 (string-match "^\\([sy]\\|tr\\)$" argument) 4319 i2 (string-match "^\\([sy]\\|tr\\)$" argument)
3611 ;; We do not search to max, since we may be called from 4320 ;; We do not search to max, since we may be called from
3612 ;; some hook of fontification, and max is random 4321 ;; some hook of fontification, and max is random
3613 i (cperl-forward-re stop-point end 4322 i (cperl-forward-re stop-point end
3614 i2 4323 i2
3615 t st-l err-l argument) 4324 st-l err-l argument)
3616 ;; Note that if `go', then it is considered as 1-arg 4325 ;; If `go', then it is considered as 1-arg, `b1' is nil
4326 ;; as in s/foo//x; the point is before final "slash"
3617 b1 (nth 1 i) ; start of the second part 4327 b1 (nth 1 i) ; start of the second part
3618 tag (nth 2 i) ; ender-char, true if second part 4328 tag (nth 2 i) ; ender-char, true if second part
3619 ; is with matching chars [] 4329 ; is with matching chars []
@@ -3625,13 +4335,18 @@ the sections using `cperl-pod-head-face', `cperl-pod-face',
3625 (1- e1)) 4335 (1- e1))
3626 e (if i i e1) ; end of the first part 4336 e (if i i e1) ; end of the first part
3627 qtag nil ; need to preserve backslashitis 4337 qtag nil ; need to preserve backslashitis
3628 is-x-REx nil) ; REx has //x modifier 4338 is-x-REx nil is-o-REx nil); REx has //x //o modifiers
4339 ;; If s{} (), then b/b1 are at "{", "(", e1/i after ")", "}"
3629 ;; Commenting \\ is dangerous, what about ( ? 4340 ;; Commenting \\ is dangerous, what about ( ?
3630 (and i tail 4341 (and i tail
3631 (eq (char-after i) ?\\) 4342 (eq (char-after i) ?\\)
3632 (setq qtag t)) 4343 (setq qtag t))
3633 (if (looking-at "\\sw*x") ; qr//x 4344 (and (if go (looking-at ".\\sw*x")
3634 (setq is-x-REx t)) 4345 (looking-at "\\sw*x")) ; qr//x
4346 (setq is-x-REx t))
4347 (and (if go (looking-at ".\\sw*o")
4348 (looking-at "\\sw*o")) ; //o
4349 (setq is-o-REx t))
3635 (if (null i) 4350 (if (null i)
3636 ;; Considered as 1arg form 4351 ;; Considered as 1arg form
3637 (progn 4352 (progn
@@ -3648,9 +4363,11 @@ the sections using `cperl-pod-head-face', `cperl-pod-face',
3648 (cperl-commentify b i t) 4363 (cperl-commentify b i t)
3649 (if (looking-at "\\sw*e") ; s///e 4364 (if (looking-at "\\sw*e") ; s///e
3650 (progn 4365 (progn
4366 ;; Cache the syntax info...
4367 (setq cperl-syntax-state (cons state-point state))
3651 (and 4368 (and
3652 ;; silent: 4369 ;; silent:
3653 (cperl-find-pods-heres b1 (1- (point)) t end) 4370 (car (cperl-find-pods-heres b1 (1- (point)) t end))
3654 ;; Error 4371 ;; Error
3655 (goto-char (1+ max))) 4372 (goto-char (1+ max)))
3656 (if (and tag (eq (preceding-char) ?\>)) 4373 (if (and tag (eq (preceding-char) ?\>))
@@ -3658,6 +4375,7 @@ the sections using `cperl-pod-head-face', `cperl-pod-face',
3658 (cperl-modify-syntax-type (1- (point)) cperl-st-ket) 4375 (cperl-modify-syntax-type (1- (point)) cperl-st-ket)
3659 (cperl-modify-syntax-type i cperl-st-bra))) 4376 (cperl-modify-syntax-type i cperl-st-bra)))
3660 (put-text-property b i 'syntax-type 'string) 4377 (put-text-property b i 'syntax-type 'string)
4378 (put-text-property i (point) 'syntax-type 'multiline)
3661 (if is-x-REx 4379 (if is-x-REx
3662 (put-text-property b i 'indentable t))) 4380 (put-text-property b i 'indentable t)))
3663 (cperl-commentify b1 (point) t) 4381 (cperl-commentify b1 (point) t)
@@ -3673,7 +4391,7 @@ the sections using `cperl-pod-head-face', `cperl-pod-face',
3673 (forward-word 1) ; skip modifiers s///s 4391 (forward-word 1) ; skip modifiers s///s
3674 (if tail (cperl-commentify tail (point) t)) 4392 (if tail (cperl-commentify tail (point) t))
3675 (cperl-postpone-fontification 4393 (cperl-postpone-fontification
3676 e1 (point) 'face 'cperl-nonoverridable))) 4394 e1 (point) 'face my-cperl-REx-modifiers-face)))
3677 ;; Check whether it is m// which means "previous match" 4395 ;; Check whether it is m// which means "previous match"
3678 ;; and highlight differently 4396 ;; and highlight differently
3679 (setq is-REx 4397 (setq is-REx
@@ -3691,7 +4409,7 @@ the sections using `cperl-pod-head-face', `cperl-pod-face',
3691 (not (looking-at "split\\>"))) 4409 (not (looking-at "split\\>")))
3692 (error t)))) 4410 (error t))))
3693 (cperl-postpone-fontification 4411 (cperl-postpone-fontification
3694 b e 'face font-lock-function-name-face) 4412 b e 'face font-lock-warning-face)
3695 (if (or i2 ; Has 2 args 4413 (if (or i2 ; Has 2 args
3696 (and cperl-fontify-m-as-s 4414 (and cperl-fontify-m-as-s
3697 (or 4415 (or
@@ -3700,135 +4418,417 @@ the sections using `cperl-pod-head-face', `cperl-pod-face',
3700 (not (eq ?\< (char-after b))))))) 4418 (not (eq ?\< (char-after b)))))))
3701 (progn 4419 (progn
3702 (cperl-postpone-fontification 4420 (cperl-postpone-fontification
3703 b (cperl-1+ b) 'face font-lock-constant-face) 4421 b (cperl-1+ b) 'face my-cperl-delimiters-face)
3704 (cperl-postpone-fontification 4422 (cperl-postpone-fontification
3705 (1- e) e 'face font-lock-constant-face))) 4423 (1- e) e 'face my-cperl-delimiters-face)))
3706 (if (and is-REx cperl-regexp-scan) 4424 (if (and is-REx cperl-regexp-scan)
3707 ;; Process RExen better 4425 ;; Process RExen: embedded comments, charclasses and ]
4426;;;/\3333\xFg\x{FFF}a\ppp\PPP\qqq\C\99f(?{ foo })(??{ foo })/;
4427;;;/a\.b[^a[:ff:]b]x$ab->$[|$,$ab->[cd]->[ef]|$ab[xy].|^${a,b}{c,d}/;
4428;;;/(?<=foo)(?<!bar)(x)(?:$ab|\$\/)$|\\\b\x888\776\[\:$/xxx;
4429;;;m?(\?\?{b,a})? + m/(??{aa})(?(?=xx)aa|bb)(?#aac)/;
4430;;;m$(^ab[c]\$)$ + m+(^ab[c]\$\+)+ + m](^ab[c\]$|.+)] + m)(^ab[c]$|.+\));
4431;;;m^a[\^b]c^ + m.a[^b]\.c.;
3708 (save-excursion 4432 (save-excursion
3709 (goto-char (1+ b)) 4433 (goto-char (1+ b))
4434 ;; First
4435 (cperl-look-at-leading-count is-x-REx e)
4436 (setq hairy-RE
4437 (concat
4438 (if is-x-REx
4439 (if (eq (char-after b) ?\#)
4440 "\\((\\?\\\\#\\)\\|\\(\\\\#\\)"
4441 "\\((\\?#\\)\\|\\(#\\)")
4442 ;; keep the same count: add a fake group
4443 (if (eq (char-after b) ?\#)
4444 "\\((\\?\\\\#\\)\\(\\)"
4445 "\\((\\?#\\)\\(\\)"))
4446 "\\|"
4447 "\\(\\[\\)" ; 3=[
4448 "\\|"
4449 "\\(]\\)" ; 4=]
4450 "\\|"
4451 ;; XXXX Will not be able to use it in s)))
4452 (if (eq (char-after b) ?\) )
4453 "\\())))\\)" ; Will never match
4454 (if (eq (char-after b) ?? )
4455 ;;"\\((\\\\\\?\\(\\\\\\?\\)?{\\)"
4456 "\\((\\\\\\?\\\\\\?{\\|()\\\\\\?{\\)"
4457 "\\((\\?\\??{\\)")) ; 5= (??{ (?{
4458 "\\|" ; 6= 0-length, 7: name, 8,9:code, 10:group
4459 "\\(" ;; XXXX 1-char variables, exc. |()\s
4460 "[$@]"
4461 "\\("
4462 "[_a-zA-Z:][_a-zA-Z0-9:]*"
4463 "\\|"
4464 "{[^{}]*}" ; only one-level allowed
4465 "\\|"
4466 "[^{(|) \t\r\n\f]"
4467 "\\)"
4468 "\\(" ;;8,9:code part of array/hash elt
4469 "\\(" "->" "\\)?"
4470 "\\[[^][]*\\]"
4471 "\\|"
4472 "{[^{}]*}"
4473 "\\)*"
4474 ;; XXXX: what if u is delim?
4475 "\\|"
4476 "[)^|$.*?+]"
4477 "\\|"
4478 "{[0-9]+}"
4479 "\\|"
4480 "{[0-9]+,[0-9]*}"
4481 "\\|"
4482 "\\\\[luLUEQbBAzZG]"
4483 "\\|"
4484 "(" ; Group opener
4485 "\\(" ; 10 group opener follower
4486 "\\?\\((\\?\\)" ; 11: in (?(?=C)A|B)
4487 "\\|"
4488 "\\?[:=!>?{]" ; "?" something
4489 "\\|"
4490 "\\?[-imsx]+[:)]" ; (?i) (?-s:.)
4491 "\\|"
4492 "\\?([0-9]+)" ; (?(1)foo|bar)
4493 "\\|"
4494 "\\?<[=!]"
4495 ;;;"\\|"
4496 ;;; "\\?"
4497 "\\)?"
4498 "\\)"
4499 "\\|"
4500 "\\\\\\(.\\)" ; 12=\SYMBOL
4501 ))
3710 (while 4502 (while
3711 (and (< (point) e) 4503 (and (< (point) (1- e))
3712 (re-search-forward 4504 (re-search-forward hairy-RE (1- e) 'to-end))
3713 (if is-x-REx
3714 (if (eq (char-after b) ?\#)
3715 "\\((\\?\\\\#\\)\\|\\(\\\\#\\)"
3716 "\\((\\?#\\)\\|\\(#\\)")
3717 (if (eq (char-after b) ?\#)
3718 "\\((\\?\\\\#\\)"
3719 "\\((\\?#\\)"))
3720 (1- e) 'to-end))
3721 (goto-char (match-beginning 0)) 4505 (goto-char (match-beginning 0))
3722 (setq REx-comment-start (point) 4506 (setq REx-subgr-start (point)
3723 was-comment t) 4507 was-subgr (following-char))
3724 (if (save-excursion 4508 (cond
3725 (and 4509 ((match-beginning 6) ; 0-length builtins, groups
3726 ;; XXX not working if outside delimiter is # 4510 (goto-char (match-end 0))
3727 (eq (preceding-char) ?\\) 4511 (if (match-beginning 11)
3728 (= (% (skip-chars-backward "$\\\\") 2) -1))) 4512 (goto-char (match-beginning 11)))
3729 ;; Not a comment, avoid loop: 4513 (if (>= (point) e)
3730 (progn (setq was-comment nil) 4514 (goto-char (1- e)))
3731 (forward-char 1)) 4515 (cperl-postpone-fontification
3732 (if (match-beginning 2) 4516 (match-beginning 0) (point)
4517 'face
4518 (cond
4519 ((eq was-subgr ?\) )
4520 (condition-case nil
4521 (save-excursion
4522 (forward-sexp -1)
4523 (if (> (point) b)
4524 (if (if (eq (char-after b) ?? )
4525 (looking-at "(\\\\\\?")
4526 (eq (char-after (1+ (point))) ?\?))
4527 my-cperl-REx-0length-face
4528 my-cperl-REx-ctl-face)
4529 font-lock-warning-face))
4530 (error font-lock-warning-face)))
4531 ((eq was-subgr ?\| )
4532 my-cperl-REx-ctl-face)
4533 ((eq was-subgr ?\$ )
4534 (if (> (point) (1+ REx-subgr-start))
4535 (progn
4536 (put-text-property
4537 (match-beginning 0) (point)
4538 'REx-interpolated
4539 (if is-o-REx 0
4540 (if (and (eq (match-beginning 0)
4541 (1+ b))
4542 (eq (point)
4543 (1- e))) 1 t)))
4544 font-lock-variable-name-face)
4545 my-cperl-REx-spec-char-face))
4546 ((memq was-subgr (append "^." nil) )
4547 my-cperl-REx-spec-char-face)
4548 ((eq was-subgr ?\( )
4549 (if (not (match-beginning 10))
4550 my-cperl-REx-ctl-face
4551 my-cperl-REx-0length-face))
4552 (t my-cperl-REx-0length-face)))
4553 (if (and (memq was-subgr (append "(|" nil))
4554 (not (string-match "(\\?[-imsx]+)"
4555 (match-string 0))))
4556 (cperl-look-at-leading-count is-x-REx e))
4557 (setq was-subgr nil)) ; We do stuff here
4558 ((match-beginning 12) ; \SYMBOL
4559 (forward-char 2)
4560 (if (>= (point) e)
4561 (goto-char (1- e))
4562 ;; How many chars to not highlight:
4563 ;; 0-len special-alnums in other branch =>
4564 ;; Generic: \non-alnum (1), \alnum (1+face)
4565 ;; Is-delim: \non-alnum (1/spec-2) alnum-1 (=what hai)
4566 (setq REx-subgr-start (point)
4567 qtag (preceding-char))
4568 (cperl-postpone-fontification
4569 (- (point) 2) (- (point) 1) 'face
4570 (if (memq qtag
4571 (append "ghijkmoqvFHIJKMORTVY" nil))
4572 font-lock-warning-face
4573 my-cperl-REx-0length-face))
4574 (if (and (eq (char-after b) qtag)
4575 (memq qtag (append ".])^$|*?+" nil)))
4576 (progn
4577 (if (and cperl-use-syntax-table-text-property
4578 (eq qtag ?\) ))
4579 (put-text-property
4580 REx-subgr-start (1- (point))
4581 'syntax-table cperl-st-punct))
4582 (cperl-postpone-fontification
4583 (1- (point)) (point) 'face
4584 ; \] can't appear below
4585 (if (memq qtag (append ".]^$" nil))
4586 'my-cperl-REx-spec-char-face
4587 (if (memq qtag (append "*?+" nil))
4588 'my-cperl-REx-0length-face
4589 'my-cperl-REx-ctl-face))))) ; )|
4590 ;; Test for arguments:
4591 (cond
4592 ;; This is not pretty: the 5.8.7 logic:
4593 ;; \0numx -> octal (up to total 3 dig)
4594 ;; \DIGIT -> backref unless \0
4595 ;; \DIGITs -> backref if legal
4596 ;; otherwise up to 3 -> octal
4597 ;; Do not try to distinguish, we guess
4598 ((or (and (memq qtag (append "01234567" nil))
4599 (re-search-forward
4600 "\\=[01234567]?[01234567]?"
4601 (1- e) 'to-end))
4602 (and (memq qtag (append "89" nil))
4603 (re-search-forward
4604 "\\=[0123456789]*" (1- e) 'to-end))
4605 (and (eq qtag ?x)
4606 (re-search-forward
4607 "\\=[0-9a-fA-F][0-9a-fA-F]?\\|\\={[0-9a-fA-F]+}"
4608 (1- e) 'to-end))
4609 (and (memq qtag (append "pPN" nil))
4610 (re-search-forward "\\={[^{}]+}\\|."
4611 (1- e) 'to-end))
4612 (eq (char-syntax qtag) ?w))
4613 (cperl-postpone-fontification
4614 (1- REx-subgr-start) (point)
4615 'face my-cperl-REx-length1-face))))
4616 (setq was-subgr nil)) ; We do stuff here
4617 ((match-beginning 3) ; [charclass]
4618 (forward-char 1)
4619 (if (eq (char-after b) ?^ )
4620 (and (eq (following-char) ?\\ )
4621 (eq (char-after (cperl-1+ (point)))
4622 ?^ )
4623 (forward-char 2))
4624 (and (eq (following-char) ?^ )
4625 (forward-char 1)))
4626 (setq argument b ; continue?
4627 tag nil ; list of POSIX classes
4628 qtag (point))
4629 (if (eq (char-after b) ?\] )
4630 (and (eq (following-char) ?\\ )
4631 (eq (char-after (cperl-1+ (point)))
4632 ?\] )
4633 (setq qtag (1+ qtag))
4634 (forward-char 2))
4635 (and (eq (following-char) ?\] )
4636 (forward-char 1)))
4637 ;; Apparently, I can't put \] into a charclass
4638 ;; in m]]: m][\\\]\]] produces [\\]]
4639;;; POSIX? [:word:] [:^word:] only inside []
4640;;; "\\=\\(\\\\.\\|[^][\\\\]\\|\\[:\\^?\sw+:]\\|\\[[^:]\\)*]")
4641 (while
4642 (and argument
4643 (re-search-forward
4644 (if (eq (char-after b) ?\] )
4645 "\\=\\(\\\\[^]]\\|[^]\\\\]\\)*\\\\]"
4646 "\\=\\(\\\\.\\|[^]\\\\]\\)*]")
4647 (1- e) 'toend))
4648 ;; Is this ] an end of POSIX class?
4649 (if (save-excursion
4650 (and
4651 (search-backward "[" argument t)
4652 (< REx-subgr-start (point))
4653 (not
4654 (and ; Should work with delim = \
4655 (eq (preceding-char) ?\\ )
4656 (= (% (skip-chars-backward
4657 "\\\\") 2) 0)))
4658 (looking-at
4659 (cond
4660 ((eq (char-after b) ?\] )
4661 "\\\\*\\[:\\^?\\sw+:\\\\\\]")
4662 ((eq (char-after b) ?\: )
4663 "\\\\*\\[\\\\:\\^?\\sw+\\\\:]")
4664 ((eq (char-after b) ?^ )
4665 "\\\\*\\[:\\(\\\\\\^\\)?\\sw+:\]")
4666 ((eq (char-syntax (char-after b))
4667 ?w)
4668 (concat
4669 "\\\\*\\[:\\(\\\\\\^\\)?\\(\\\\"
4670 (char-to-string (char-after b))
4671 "\\|\\sw\\)+:\]"))
4672 (t "\\\\*\\[:\\^?\\sw*:]")))
4673 (setq argument (point))))
4674 (setq tag (cons (cons argument (point))
4675 tag)
4676 argument (point)) ; continue
4677 (setq argument nil)))
4678 (and argument
4679 (message "Couldn't find end of charclass in a REx, pos=%s"
4680 REx-subgr-start))
4681 (if (and cperl-use-syntax-table-text-property
4682 (> (- (point) 2) REx-subgr-start))
4683 (put-text-property
4684 (1+ REx-subgr-start) (1- (point))
4685 'syntax-table cperl-st-punct))
4686 (cperl-postpone-fontification
4687 REx-subgr-start qtag
4688 'face my-cperl-REx-spec-char-face)
4689 (cperl-postpone-fontification
4690 (1- (point)) (point) 'face
4691 my-cperl-REx-spec-char-face)
4692 (if (eq (char-after b) ?\] )
4693 (cperl-postpone-fontification
4694 (- (point) 2) (1- (point))
4695 'face my-cperl-REx-0length-face))
4696 (while tag
4697 (cperl-postpone-fontification
4698 (car (car tag)) (cdr (car tag))
4699 'face my-cperl-REx-length1-face)
4700 (setq tag (cdr tag)))
4701 (setq was-subgr nil)) ; did facing already
4702 ;; Now rare stuff:
4703 ((and (match-beginning 2) ; #-comment
4704 (/= (match-beginning 2) (match-end 2)))
4705 (beginning-of-line 2)
4706 (if (> (point) e)
4707 (goto-char (1- e))))
4708 ((match-beginning 4) ; character "]"
4709 (setq was-subgr nil) ; We do stuff here
4710 (goto-char (match-end 0))
4711 (if cperl-use-syntax-table-text-property
4712 (put-text-property
4713 (1- (point)) (point)
4714 'syntax-table cperl-st-punct))
4715 (cperl-postpone-fontification
4716 (1- (point)) (point)
4717 'face font-lock-warning-face))
4718 ((match-beginning 5) ; before (?{}) (??{})
4719 (setq tag (match-end 0))
4720 (if (or (setq qtag
4721 (cperl-forward-group-in-re st-l))
4722 (and (>= (point) e)
4723 (setq qtag "no matching `)' found"))
4724 (and (not (eq (char-after (- (point) 2))
4725 ?\} ))
4726 (setq qtag "Can't find })")))
3733 (progn 4727 (progn
3734 (beginning-of-line 2) 4728 (goto-char (1- e))
3735 (if (> (point) e) 4729 (message qtag))
3736 (goto-char (1- e)))) 4730 (cperl-postpone-fontification
3737 ;; Works also if the outside delimiters are (). 4731 (1- tag) (1- (point))
3738 (or (search-forward ")" (1- e) 'toend) 4732 'face font-lock-variable-name-face)
3739 (message 4733 (cperl-postpone-fontification
3740 "Couldn't find end of (?#...)-comment in a REx, pos=%s" 4734 REx-subgr-start (1- tag)
3741 REx-comment-start)))) 4735 'face my-cperl-REx-spec-char-face)
4736 (cperl-postpone-fontification
4737 (1- (point)) (point)
4738 'face my-cperl-REx-spec-char-face)
4739 (if cperl-use-syntax-table-text-property
4740 (progn
4741 (put-text-property
4742 (- (point) 2) (1- (point))
4743 'syntax-table cperl-st-cfence)
4744 (put-text-property
4745 (+ REx-subgr-start 2)
4746 (+ REx-subgr-start 3)
4747 'syntax-table cperl-st-cfence))))
4748 (setq was-subgr nil))
4749 (t ; (?#)-comment
4750 ;; Inside "(" and "\" arn't special in any way
4751 ;; Works also if the outside delimiters are ().
4752 (or;;(if (eq (char-after b) ?\) )
4753 ;;(re-search-forward
4754 ;; "[^\\\\]\\(\\\\\\\\\\)*\\\\)"
4755 ;; (1- e) 'toend)
4756 (search-forward ")" (1- e) 'toend)
4757 ;;)
4758 (message
4759 "Couldn't find end of (?#...)-comment in a REx, pos=%s"
4760 REx-subgr-start))))
3742 (if (>= (point) e) 4761 (if (>= (point) e)
3743 (goto-char (1- e))) 4762 (goto-char (1- e)))
3744 (if was-comment 4763 (cond
3745 (progn 4764 (was-subgr
3746 (setq REx-comment-end (point)) 4765 (setq REx-subgr-end (point))
3747 (cperl-commentify 4766 (cperl-commentify
3748 REx-comment-start REx-comment-end nil) 4767 REx-subgr-start REx-subgr-end nil)
3749 (cperl-postpone-fontification 4768 (cperl-postpone-fontification
3750 REx-comment-start REx-comment-end 4769 REx-subgr-start REx-subgr-end
3751 'face font-lock-comment-face)))))) 4770 'face font-lock-comment-face))))))
3752 (if (and is-REx is-x-REx) 4771 (if (and is-REx is-x-REx)
3753 (put-text-property (1+ b) (1- e) 4772 (put-text-property (1+ b) (1- e)
3754 'syntax-subtype 'x-REx))) 4773 'syntax-subtype 'x-REx)))
3755 (if i2 4774 (if i2
3756 (progn 4775 (progn
3757 (cperl-postpone-fontification 4776 (cperl-postpone-fontification
3758 (1- e1) e1 'face font-lock-constant-face) 4777 (1- e1) e1 'face my-cperl-delimiters-face)
3759 (if (assoc (char-after b) cperl-starters) 4778 (if (assoc (char-after b) cperl-starters)
3760 (cperl-postpone-fontification 4779 (progn
3761 b1 (1+ b1) 'face font-lock-constant-face)))) 4780 (cperl-postpone-fontification
4781 b1 (1+ b1) 'face my-cperl-delimiters-face)
4782 (put-text-property b1 (1+ b1)
4783 'REx-part2 t)))))
3762 (if (> (point) max) 4784 (if (> (point) max)
3763 (setq tmpend tb)))) 4785 (setq tmpend tb))))
3764 ((match-beginning 13) ; sub with prototypes 4786 ((match-beginning 17) ; sub with prototype or attribute
3765 (setq b (match-beginning 0)) 4787 ;; 1+6+2+1+1=11 extra () before this (sub with proto/attr):
4788 ;;"\\<sub\\>\\(" ;12
4789 ;; cperl-white-and-comment-rex ;13
4790 ;; "\\([a-zA-Z_:'0-9]+\\)\\)?" ; name ;14
4791 ;;"\\(" cperl-maybe-white-and-comment-rex ;15,16
4792 ;; "\\(([^()]*)\\|:[^:]\\)\\)" ; 17:proto or attribute start
4793 (setq b1 (match-beginning 14) e1 (match-end 14))
3766 (if (memq (char-after (1- b)) 4794 (if (memq (char-after (1- b))
3767 '(?\$ ?\@ ?\% ?\& ?\*)) 4795 '(?\$ ?\@ ?\% ?\& ?\*))
3768 nil 4796 nil
3769 (setq state (parse-partial-sexp 4797 (goto-char b)
3770 state-point b nil nil state) 4798 (if (eq (char-after (match-beginning 17)) ?\( )
3771 state-point b) 4799 (progn
3772 (if (or (nth 3 state) (nth 4 state)) 4800 (cperl-commentify ; Prototypes; mark as string
3773 nil 4801 (match-beginning 17) (match-end 17) t)
3774 ;; Mark as string 4802 (goto-char (match-end 0))
3775 (cperl-commentify (match-beginning 13) (match-end 13) t)) 4803 ;; Now look for attributes after prototype:
3776 (goto-char (match-end 0)))) 4804 (forward-comment (buffer-size))
3777 ;; 1+6+2+1+1+2=13 extra () before this: 4805 (and (looking-at ":[^:]")
3778 ;; "\\$\\(['{]\\)" 4806 (cperl-find-sub-attrs st-l b1 e1 b)))
3779 ((and (match-beginning 14) 4807 ;; treat attributes without prototype
3780 (eq (preceding-char) ?\')) ; $' 4808 (goto-char (match-beginning 17))
3781 (setq b (1- (point)) 4809 (cperl-find-sub-attrs st-l b1 e1 b))))
3782 state (parse-partial-sexp 4810 ;; 1+6+2+1+1+6+1=18 extra () before this:
3783 state-point (1- b) nil nil state)
3784 state-point (1- b))
3785 (if (nth 3 state) ; in string
3786 (cperl-modify-syntax-type (1- b) cperl-st-punct))
3787 (goto-char (1+ b)))
3788 ;; 1+6+2+1+1+2=13 extra () before this:
3789 ;; "\\$\\(['{]\\)"
3790 ((match-beginning 14) ; ${
3791 (setq bb (match-beginning 0))
3792 (cperl-modify-syntax-type bb cperl-st-punct))
3793 ;; 1+6+2+1+1+2+1=14 extra () before this:
3794 ;; "\\(\\<sub[ \t\n\f]+\\|[&*$@%]\\)[a-zA-Z0-9_]*'") 4811 ;; "\\(\\<sub[ \t\n\f]+\\|[&*$@%]\\)[a-zA-Z0-9_]*'")
3795 ((match-beginning 15) ; old $abc'efg syntax 4812 ((match-beginning 19) ; old $abc'efg syntax
3796 (setq bb (match-end 0) 4813 (setq bb (match-end 0))
3797 b (match-beginning 0) 4814 ;;;(if (nth 3 state) nil ; in string
3798 state (parse-partial-sexp 4815 (put-text-property (1- bb) bb 'syntax-table cperl-st-word)
3799 state-point b nil nil state)
3800 state-point b)
3801 (if (nth 3 state) ; in string
3802 nil
3803 (put-text-property (1- bb) bb 'syntax-table cperl-st-word))
3804 (goto-char bb)) 4816 (goto-char bb))
3805 ;; 1+6+2+1+1+2+1+1=15 extra () before this: 4817 ;; 1+6+2+1+1+6+1+1=19 extra () before this:
3806 ;; "__\\(END\\|DATA\\)__" 4818 ;; "__\\(END\\|DATA\\)__"
3807 ((match-beginning 16) ; __END__, __DATA__ 4819 ((match-beginning 20) ; __END__, __DATA__
3808 (setq bb (match-end 0) 4820 (setq bb (match-end 0))
3809 b (match-beginning 0) 4821 ;; (put-text-property b (1+ bb) 'syntax-type 'pod) ; Cheat
3810 state (parse-partial-sexp 4822 (cperl-commentify b bb nil)
3811 state-point b nil nil state) 4823 (setq end t))
3812 state-point b) 4824 ;; "\\\\\\(['`\"($]\\)"
3813 (if (or (nth 3 state) (nth 4 state)) 4825 ((match-beginning 21)
3814 nil 4826 ;; Trailing backslash; make non-quoting outside string/comment
3815 ;; (put-text-property b (1+ bb) 'syntax-type 'pod) ; Cheat 4827 (setq bb (match-end 0))
3816 (cperl-commentify b bb nil)
3817 (setq end t))
3818 (goto-char bb))
3819 ((match-beginning 17) ; "\\\\\\(['`\"($]\\)"
3820 ;; Trailing backslash ==> non-quoting outside string/comment
3821 (setq bb (match-end 0)
3822 b (match-beginning 0))
3823 (goto-char b) 4828 (goto-char b)
3824 (skip-chars-backward "\\\\") 4829 (skip-chars-backward "\\\\")
3825 ;;;(setq i2 (= (% (skip-chars-backward "\\\\") 2) -1)) 4830 ;;;(setq i2 (= (% (skip-chars-backward "\\\\") 2) -1))
3826 (setq state (parse-partial-sexp 4831 (cperl-modify-syntax-type b cperl-st-punct)
3827 state-point b nil nil state)
3828 state-point b)
3829 (if (or (nth 3 state) (nth 4 state) )
3830 nil
3831 (cperl-modify-syntax-type b cperl-st-punct))
3832 (goto-char bb)) 4832 (goto-char bb))
3833 (t (error "Error in regexp of the sniffer"))) 4833 (t (error "Error in regexp of the sniffer")))
3834 (if (> (point) stop-point) 4834 (if (> (point) stop-point)
@@ -3839,7 +4839,10 @@ the sections using `cperl-pod-head-face', `cperl-pod-face',
3839 (or (car err-l) (setcar err-l b))) 4839 (or (car err-l) (setcar err-l b)))
3840 (goto-char stop-point)))) 4840 (goto-char stop-point))))
3841 (setq cperl-syntax-state (cons state-point state) 4841 (setq cperl-syntax-state (cons state-point state)
3842 cperl-syntax-done-to (or tmpend (max (point) max)))) 4842 ;; Do not mark syntax as done past tmpend???
4843 cperl-syntax-done-to (or tmpend (max (point) max)))
4844 ;;(message "state-at=%s, done-to=%s" state-point cperl-syntax-done-to)
4845 )
3843 (if (car err-l) (goto-char (car err-l)) 4846 (if (car err-l) (goto-char (car err-l))
3844 (or non-inter 4847 (or non-inter
3845 (message "Scanning for \"hard\" Perl constructions... done")))) 4848 (message "Scanning for \"hard\" Perl constructions... done"))))
@@ -3851,48 +4854,91 @@ the sections using `cperl-pod-head-face', `cperl-pod-face',
3851 ;; cperl-mode-syntax-table. 4854 ;; cperl-mode-syntax-table.
3852 ;; (set-syntax-table cperl-mode-syntax-table) 4855 ;; (set-syntax-table cperl-mode-syntax-table)
3853 ) 4856 )
3854 (car err-l))) 4857 (list (car err-l) overshoot)))
4858
4859(defun cperl-find-pods-heres-region (min max)
4860 (interactive "r")
4861 (cperl-find-pods-heres min max))
3855 4862
3856(defun cperl-backward-to-noncomment (lim) 4863(defun cperl-backward-to-noncomment (lim)
3857 ;; Stops at lim or after non-whitespace that is not in comment 4864 ;; Stops at lim or after non-whitespace that is not in comment
4865 ;; XXXX Wrongly understands end-of-multiline strings with # as comment
3858 (let (stop p pr) 4866 (let (stop p pr)
3859 (while (and (not stop) (> (point) (or lim 1))) 4867 (while (and (not stop) (> (point) (or lim (point-min))))
3860 (skip-chars-backward " \t\n\f" lim) 4868 (skip-chars-backward " \t\n\f" lim)
3861 (setq p (point)) 4869 (setq p (point))
3862 (beginning-of-line) 4870 (beginning-of-line)
3863 (if (memq (setq pr (get-text-property (point) 'syntax-type)) 4871 (if (memq (setq pr (get-text-property (point) 'syntax-type))
3864 '(pod here-doc here-doc-delim)) 4872 '(pod here-doc here-doc-delim))
3865 (cperl-unwind-to-safe nil) 4873 (cperl-unwind-to-safe nil)
3866 (or (looking-at "^[ \t]*\\(#\\|$\\)") 4874 (or (and (looking-at "^[ \t]*\\(#\\|$\\)")
3867 (progn (cperl-to-comment-or-eol) (bolp)) 4875 (not (memq pr '(string prestring))))
3868 (progn 4876 (progn (cperl-to-comment-or-eol) (bolp))
3869 (skip-chars-backward " \t") 4877 (progn
3870 (if (< p (point)) (goto-char p)) 4878 (skip-chars-backward " \t")
3871 (setq stop t))))))) 4879 (if (< p (point)) (goto-char p))
4880 (setq stop t)))))))
3872 4881
4882;; Used only in `cperl-calculate-indent'...
4883(defun cperl-block-p () ; Do not C-M-q ! One string contains ";" !
4884 ;; Positions is before ?\{. Checks whether it starts a block.
4885 ;; No save-excursion! This is more a distinguisher of a block/hash ref...
4886 (cperl-backward-to-noncomment (point-min))
4887 (or (memq (preceding-char) (append ";){}$@&%\C-@" nil)) ; Or label! \C-@ at bobp
4888 ; Label may be mixed up with `$blah :'
4889 (save-excursion (cperl-after-label))
4890 (get-text-property (cperl-1- (point)) 'attrib-group)
4891 (and (memq (char-syntax (preceding-char)) '(?w ?_))
4892 (progn
4893 (backward-sexp)
4894 ;; sub {BLK}, print {BLK} $data, but NOT `bless', `return', `tr'
4895 (or (and (looking-at "[a-zA-Z0-9_:]+[ \t\n\f]*[{#]") ; Method call syntax
4896 (not (looking-at "\\(bless\\|return\\|q[wqrx]?\\|tr\\|[smy]\\)\\>")))
4897 ;; sub bless::foo {}
4898 (progn
4899 (cperl-backward-to-noncomment (point-min))
4900 (and (eq (preceding-char) ?b)
4901 (progn
4902 (forward-sexp -1)
4903 (looking-at "sub[ \t\n\f#]")))))))))
4904
4905;;; What is the difference of (cperl-after-block-p lim t) and (cperl-block-p)?
4906;;; No save-excursion; condition-case ... In (cperl-block-p) the block
4907;;; may be a part of an in-statement construct, such as
4908;;; ${something()}, print {FH} $data.
4909;;; Moreover, one takes positive approach (looks for else,grep etc)
4910;;; another negative (looks for bless,tr etc)
3873(defun cperl-after-block-p (lim &optional pre-block) 4911(defun cperl-after-block-p (lim &optional pre-block)
3874 "Return true if the preceeding } ends a block or a following { starts one. 4912 "Return true if the preceeding } (if PRE-BLOCK, following {) delimits a block.
3875Would not look before LIM. If PRE-BLOCK is nil checks preceeding }. 4913Would not look before LIM. Assumes that LIM is a good place to begin a
3876otherwise following {." 4914statement. The kind of block we treat here is one after which a new
3877 ;; We suppose that the preceding char is }. 4915statement would start; thus the block in ${func()} does not count."
3878 (save-excursion 4916 (save-excursion
3879 (condition-case nil 4917 (condition-case nil
3880 (progn 4918 (progn
3881 (or pre-block (forward-sexp -1)) 4919 (or pre-block (forward-sexp -1))
3882 (cperl-backward-to-noncomment lim) 4920 (cperl-backward-to-noncomment lim)
3883 (or (eq (point) lim) 4921 (or (eq (point) lim)
3884 (eq (preceding-char) ?\) ) ; if () {} sub f () {} 4922 ;; if () {} // sub f () {} // sub f :a(') {}
3885 (if (eq (char-syntax (preceding-char)) ?w) ; else {} 4923 (eq (preceding-char) ?\) )
4924 ;; label: {}
4925 (save-excursion (cperl-after-label))
4926 ;; sub :attr {}
4927 (get-text-property (cperl-1- (point)) 'attrib-group)
4928 (if (memq (char-syntax (preceding-char)) '(?w ?_)) ; else {}
3886 (save-excursion 4929 (save-excursion
3887 (forward-sexp -1) 4930 (forward-sexp -1)
3888 (or (looking-at "\\(else\\|continue\\|grep\\|map\\|BEGIN\\|END\\|CHECK\\|INIT\\)\\>") 4931 ;; else {} but not else::func {}
4932 (or (and (looking-at "\\(else\\|continue\\|grep\\|map\\|BEGIN\\|END\\|CHECK\\|INIT\\)\\>")
4933 (not (looking-at "\\(\\sw\\|_\\)+::")))
3889 ;; sub f {} 4934 ;; sub f {}
3890 (progn 4935 (progn
3891 (cperl-backward-to-noncomment lim) 4936 (cperl-backward-to-noncomment lim)
3892 (and (eq (char-syntax (preceding-char)) ?w) 4937 (and (eq (preceding-char) ?b)
3893 (progn 4938 (progn
3894 (forward-sexp -1) 4939 (forward-sexp -1)
3895 (looking-at "sub\\>")))))) 4940 (looking-at "sub[ \t\n\f#]"))))))
4941 ;; What preceeds is not word... XXXX Last statement in sub???
3896 (cperl-after-expr-p lim)))) 4942 (cperl-after-expr-p lim))))
3897 (error nil)))) 4943 (error nil))))
3898 4944
@@ -3914,12 +4960,12 @@ CHARS is a string that contains good characters to have before us (however,
3914 (if (get-text-property (point) 'here-doc-group) 4960 (if (get-text-property (point) 'here-doc-group)
3915 (progn 4961 (progn
3916 (goto-char 4962 (goto-char
3917 (previous-single-property-change (point) 'here-doc-group)) 4963 (cperl-beginning-of-property (point) 'here-doc-group))
3918 (beginning-of-line 0))) 4964 (beginning-of-line 0)))
3919 (if (get-text-property (point) 'in-pod) 4965 (if (get-text-property (point) 'in-pod)
3920 (progn 4966 (progn
3921 (goto-char 4967 (goto-char
3922 (previous-single-property-change (point) 'in-pod)) 4968 (cperl-beginning-of-property (point) 'in-pod))
3923 (beginning-of-line 0))) 4969 (beginning-of-line 0)))
3924 (if (looking-at "^[ \t]*\\(#\\|$\\)") nil ; Only comment, skip 4970 (if (looking-at "^[ \t]*\\(#\\|$\\)") nil ; Only comment, skip
3925 ;; Else: last iteration, or a label 4971 ;; Else: last iteration, or a label
@@ -3931,7 +4977,7 @@ CHARS is a string that contains good characters to have before us (however,
3931 (progn 4977 (progn
3932 (forward-char -1) 4978 (forward-char -1)
3933 (skip-chars-backward " \t\n\f" lim) 4979 (skip-chars-backward " \t\n\f" lim)
3934 (eq (char-syntax (preceding-char)) ?w))) 4980 (memq (char-syntax (preceding-char)) '(?w ?_))))
3935 (forward-sexp -1) ; Possibly label. Skip it 4981 (forward-sexp -1) ; Possibly label. Skip it
3936 (goto-char p) 4982 (goto-char p)
3937 (setq stop t)))) 4983 (setq stop t))))
@@ -3947,6 +4993,44 @@ CHARS is a string that contains good characters to have before us (however,
3947 (eq (get-text-property (point) 'syntax-type) 4993 (eq (get-text-property (point) 'syntax-type)
3948 'format))))))))) 4994 'format)))))))))
3949 4995
4996(defun cperl-backward-to-start-of-expr (&optional lim)
4997 (condition-case nil
4998 (progn
4999 (while (and (or (not lim)
5000 (> (point) lim))
5001 (not (cperl-after-expr-p lim)))
5002 (forward-sexp -1)
5003 ;; May be after $, @, $# etc of a variable
5004 (skip-chars-backward "$@%#")))
5005 (error nil)))
5006
5007(defun cperl-at-end-of-expr (&optional lim)
5008 ;; Since the SEXP approach below is very fragile, do some overengineering
5009 (or (looking-at (concat cperl-maybe-white-and-comment-rex "[;}]"))
5010 (condition-case nil
5011 (save-excursion
5012 ;; If nothing interesting after, does as (forward-sexp -1);
5013 ;; otherwise fails, or ends at a start of following sexp.
5014 ;; XXXX PROBLEMS: if what follows (after ";") @FOO, or ${bar}
5015 ;; may be stuck after @ or $; just put some stupid workaround now:
5016 (let ((p (point)))
5017 (forward-sexp 1)
5018 (forward-sexp -1)
5019 (while (memq (preceding-char) (append "%&@$*" nil))
5020 (forward-char -1))
5021 (or (< (point) p)
5022 (cperl-after-expr-p lim))))
5023 (error t))))
5024
5025(defun cperl-forward-to-end-of-expr (&optional lim)
5026 (let ((p (point))))
5027 (condition-case nil
5028 (progn
5029 (while (and (< (point) (or lim (point-max)))
5030 (not (cperl-at-end-of-expr)))
5031 (forward-sexp 1)))
5032 (error nil)))
5033
3950(defun cperl-backward-to-start-of-continued-exp (lim) 5034(defun cperl-backward-to-start-of-continued-exp (lim)
3951 (if (memq (preceding-char) (append ")]}\"'`" nil)) 5035 (if (memq (preceding-char) (append ")]}\"'`" nil))
3952 (forward-sexp -1)) 5036 (forward-sexp -1))
@@ -3987,18 +5071,51 @@ conditional/loop constructs."
3987 (beginning-of-line) 5071 (beginning-of-line)
3988 (while (null done) 5072 (while (null done)
3989 (setq top (point)) 5073 (setq top (point))
3990 (while (= (nth 0 (parse-partial-sexp (point) tmp-end 5074 ;; Plan A: if line has an unfinished paren-group, go to end-of-group
3991 -1)) -1) 5075 (while (= -1 (nth 0 (parse-partial-sexp (point) tmp-end -1)))
3992 (setq top (point))) ; Get the outermost parenths in line 5076 (setq top (point))) ; Get the outermost parenths in line
3993 (goto-char top) 5077 (goto-char top)
3994 (while (< (point) tmp-end) 5078 (while (< (point) tmp-end)
3995 (parse-partial-sexp (point) tmp-end nil t) ; To start-sexp or eol 5079 (parse-partial-sexp (point) tmp-end nil t) ; To start-sexp or eol
3996 (or (eolp) (forward-sexp 1))) 5080 (or (eolp) (forward-sexp 1)))
3997 (if (> (point) tmp-end) 5081 (if (> (point) tmp-end) ; Yes, there an unfinished block
3998 (save-excursion 5082 nil
3999 (end-of-line) 5083 (if (eq ?\) (preceding-char))
4000 (setq tmp-end (point))) 5084 (progn ;; Plan B: find by REGEXP block followup this line
4001 (setq done t))) 5085 (setq top (point))
5086 (condition-case nil
5087 (progn
5088 (forward-sexp -2)
5089 (if (eq (following-char) ?$ ) ; for my $var (list)
5090 (progn
5091 (forward-sexp -1)
5092 (if (looking-at "\\(my\\|local\\|our\\)\\>")
5093 (forward-sexp -1))))
5094 (if (looking-at
5095 (concat "\\(\\elsif\\|if\\|unless\\|while\\|until"
5096 "\\|for\\(each\\)?\\>\\(\\("
5097 cperl-maybe-white-and-comment-rex
5098 "\\(my\\|local\\|our\\)\\)?"
5099 cperl-maybe-white-and-comment-rex
5100 "\\$[_a-zA-Z0-9]+\\)?\\)\\>"))
5101 (progn
5102 (goto-char top)
5103 (forward-sexp 1)
5104 (setq top (point)))))
5105 (error (setq done t)))
5106 (goto-char top))
5107 (if (looking-at ; Try Plan C: continuation block
5108 (concat cperl-maybe-white-and-comment-rex
5109 "\\<\\(else\\|elsif\|continue\\)\\>"))
5110 (progn
5111 (goto-char (match-end 0))
5112 (save-excursion
5113 (end-of-line)
5114 (setq tmp-end (point))))
5115 (setq done t))))
5116 (save-excursion
5117 (end-of-line)
5118 (setq tmp-end (point))))
4002 (goto-char tmp-end) 5119 (goto-char tmp-end)
4003 (setq tmp-end (point-marker))) 5120 (setq tmp-end (point-marker)))
4004 (if cperl-indent-region-fix-constructs 5121 (if cperl-indent-region-fix-constructs
@@ -4027,16 +5144,26 @@ Returns some position at the last line."
4027 ;; Looking at: 5144 ;; Looking at:
4028 ;; } 5145 ;; }
4029 ;; else 5146 ;; else
4030 (if (and cperl-merge-trailing-else 5147 (if cperl-merge-trailing-else
4031 (looking-at 5148 (if (looking-at
4032 "[ \t]*}[ \t]*\n[ \t\n]*\\(els\\(e\\|if\\)\\|continue\\)\\>")) 5149 "[ \t]*}[ \t]*\n[ \t\n]*\\(els\\(e\\|if\\)\\|continue\\)\\>")
4033 (progn 5150 (progn
4034 (search-forward "}") 5151 (search-forward "}")
4035 (setq p (point)) 5152 (setq p (point))
4036 (skip-chars-forward " \t\n") 5153 (skip-chars-forward " \t\n")
4037 (delete-region p (point)) 5154 (delete-region p (point))
4038 (insert (make-string cperl-indent-region-fix-constructs ?\s)) 5155 (insert (make-string cperl-indent-region-fix-constructs ?\s))
4039 (beginning-of-line))) 5156 (beginning-of-line)))
5157 (if (looking-at "[ \t]*}[ \t]*\\(els\\(e\\|if\\)\\|continue\\)\\>")
5158 (save-excursion
5159 (search-forward "}")
5160 (delete-horizontal-space)
5161 (insert "\n")
5162 (setq ret (point))
5163 (if (cperl-indent-line parse-data)
5164 (progn
5165 (cperl-fix-line-spacing end parse-data)
5166 (setq ret (point)))))))
4040 ;; Looking at: 5167 ;; Looking at:
4041 ;; } else 5168 ;; } else
4042 (if (looking-at "[ \t]*}\\(\t*\\|[ \t][ \t]+\\)\\<\\(els\\(e\\|if\\)\\|continue\\)\\>") 5169 (if (looking-at "[ \t]*}\\(\t*\\|[ \t][ \t]+\\)\\<\\(els\\(e\\|if\\)\\|continue\\)\\>")
@@ -4073,19 +5200,19 @@ Returns some position at the last line."
4073 (insert 5200 (insert
4074 (make-string cperl-indent-region-fix-constructs ?\s)) 5201 (make-string cperl-indent-region-fix-constructs ?\s))
4075 (beginning-of-line))) 5202 (beginning-of-line)))
4076 ;; Looking at: 5203 ;; Looking at (with or without "}" at start, ending after "({"):
4077 ;; } foreach my $var () { 5204 ;; } foreach my $var () OR {
4078 (if (looking-at 5205 (if (looking-at
4079 "[ \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]*{") 5206 "[ \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]*{")
4080 (progn 5207 (progn
4081 (setq ml (match-beginning 8)) 5208 (setq ml (match-beginning 8)) ; "(" or "{" after control word
4082 (re-search-forward "[({]") 5209 (re-search-forward "[({]")
4083 (forward-char -1) 5210 (forward-char -1)
4084 (setq p (point)) 5211 (setq p (point))
4085 (if (eq (following-char) ?\( ) 5212 (if (eq (following-char) ?\( )
4086 (progn 5213 (progn
4087 (forward-sexp 1) 5214 (forward-sexp 1)
4088 (setq pp (point))) 5215 (setq pp (point))) ; past parenth-group
4089 ;; after `else' or nothing 5216 ;; after `else' or nothing
4090 (if ml ; after `else' 5217 (if ml ; after `else'
4091 (skip-chars-backward " \t\n") 5218 (skip-chars-backward " \t\n")
@@ -4095,13 +5222,13 @@ Returns some position at the last line."
4095 ;; Multiline expr should be special 5222 ;; Multiline expr should be special
4096 (setq ml (and pp (save-excursion (goto-char p) 5223 (setq ml (and pp (save-excursion (goto-char p)
4097 (search-forward "\n" pp t)))) 5224 (search-forward "\n" pp t))))
4098 (if (and (or (not pp) (< pp end)) 5225 (if (and (or (not pp) (< pp end)) ; Do not go too far...
4099 (looking-at "[ \t\n]*{")) 5226 (looking-at "[ \t\n]*{"))
4100 (progn 5227 (progn
4101 (cond 5228 (cond
4102 ((bolp) ; Were before `{', no if/else/etc 5229 ((bolp) ; Were before `{', no if/else/etc
4103 nil) 5230 nil)
4104 ((looking-at "\\(\t*\\| [ \t]+\\){") 5231 ((looking-at "\\(\t*\\| [ \t]+\\){") ; Not exactly 1 SPACE
4105 (delete-horizontal-space) 5232 (delete-horizontal-space)
4106 (if (if ml 5233 (if (if ml
4107 cperl-extra-newline-before-brace-multiline 5234 cperl-extra-newline-before-brace-multiline
@@ -4124,7 +5251,17 @@ Returns some position at the last line."
4124 (skip-chars-forward " \t\n") 5251 (skip-chars-forward " \t\n")
4125 (delete-region pp (point)) 5252 (delete-region pp (point))
4126 (insert 5253 (insert
4127 (make-string cperl-indent-region-fix-constructs ?\s)))) 5254 (make-string cperl-indent-region-fix-constructs ?\ )))
5255 ((and (looking-at "[\t ]*{")
5256 (if ml cperl-extra-newline-before-brace-multiline
5257 cperl-extra-newline-before-brace))
5258 (delete-horizontal-space)
5259 (insert "\n")
5260 (setq ret (point))
5261 (if (cperl-indent-line parse-data)
5262 (progn
5263 (cperl-fix-line-spacing end parse-data)
5264 (setq ret (point))))))
4128 ;; Now we are before `{' 5265 ;; Now we are before `{'
4129 (if (looking-at "[ \t\n]*{[ \t]*[^ \t\n#]") 5266 (if (looking-at "[ \t\n]*{[ \t]*[^ \t\n#]")
4130 (progn 5267 (progn
@@ -4276,7 +5413,7 @@ indentation and initial hashes. Behaves usually outside of comment."
4276 ;; (interactive "P") ; Only works when called from fill-paragraph. -stef 5413 ;; (interactive "P") ; Only works when called from fill-paragraph. -stef
4277 (let (;; Non-nil if the current line contains a comment. 5414 (let (;; Non-nil if the current line contains a comment.
4278 has-comment 5415 has-comment
4279 5416 fill-paragraph-function ; do not recurse
4280 ;; If has-comment, the appropriate fill-prefix for the comment. 5417 ;; If has-comment, the appropriate fill-prefix for the comment.
4281 comment-fill-prefix 5418 comment-fill-prefix
4282 ;; Line that contains code and comment (or nil) 5419 ;; Line that contains code and comment (or nil)
@@ -4308,7 +5445,7 @@ indentation and initial hashes. Behaves usually outside of comment."
4308 dc (- c (current-column)) len (- start (point)) 5445 dc (- c (current-column)) len (- start (point))
4309 start (point-marker)) 5446 start (point-marker))
4310 (delete-char len) 5447 (delete-char len)
4311 (insert (make-string dc ?-))))) 5448 (insert (make-string dc ?-))))) ; Placeholder (to avoid splitting???)
4312 (if (not has-comment) 5449 (if (not has-comment)
4313 (fill-paragraph justify) ; Do the usual thing outside of comment 5450 (fill-paragraph justify) ; Do the usual thing outside of comment
4314 ;; Narrow to include only the comment, and then fill the region. 5451 ;; Narrow to include only the comment, and then fill the region.
@@ -4330,11 +5467,16 @@ indentation and initial hashes. Behaves usually outside of comment."
4330 (point))) 5467 (point)))
4331 ;; Remove existing hashes 5468 ;; Remove existing hashes
4332 (save-excursion 5469 (save-excursion
4333 (goto-char (point-min)) 5470 (goto-char (point-min))
4334 (while (progn (forward-line 1) (< (point) (point-max))) 5471 (while (progn (forward-line 1) (< (point) (point-max)))
4335 (skip-chars-forward " \t") 5472 (skip-chars-forward " \t")
4336 (and (looking-at "#+") 5473 (if (looking-at "#+")
4337 (delete-char (- (match-end 0) (match-beginning 0)))))) 5474 (progn
5475 (if (and (eq (point) (match-beginning 0))
5476 (not (eq (point) (match-end 0)))) nil
5477 (error
5478 "Bug in Emacs: `looking-at' in `narrow-to-region': match-data is garbage"))
5479 (delete-char (- (match-end 0) (match-beginning 0)))))))
4338 5480
4339 ;; Lines with only hashes on them can be paragraph boundaries. 5481 ;; Lines with only hashes on them can be paragraph boundaries.
4340 (let ((paragraph-start (concat paragraph-start "\\|^[ \t#]*$")) 5482 (let ((paragraph-start (concat paragraph-start "\\|^[ \t#]*$"))
@@ -4350,7 +5492,8 @@ indentation and initial hashes. Behaves usually outside of comment."
4350 (setq comment-column c) 5492 (setq comment-column c)
4351 (indent-for-comment) 5493 (indent-for-comment)
4352 ;; Repeat once more, flagging as iteration 5494 ;; Repeat once more, flagging as iteration
4353 (cperl-fill-paragraph justify t))))))) 5495 (cperl-fill-paragraph justify t))))))
5496 t)
4354 5497
4355(defun cperl-do-auto-fill () 5498(defun cperl-do-auto-fill ()
4356 ;; Break out if the line is short enough 5499 ;; Break out if the line is short enough
@@ -4401,8 +5544,8 @@ indentation and initial hashes. Behaves usually outside of comment."
4401 (let ((index-alist '()) (index-pack-alist '()) (index-pod-alist '()) 5544 (let ((index-alist '()) (index-pack-alist '()) (index-pod-alist '())
4402 (index-unsorted-alist '()) (i-s-f (default-value 'imenu-sort-function)) 5545 (index-unsorted-alist '()) (i-s-f (default-value 'imenu-sort-function))
4403 (index-meth-alist '()) meth 5546 (index-meth-alist '()) meth
4404 packages ends-ranges p marker 5547 packages ends-ranges p marker is-proto
4405 (prev-pos 0) char fchar index index1 name (end-range 0) package) 5548 (prev-pos 0) is-pack index index1 name (end-range 0) package)
4406 (goto-char (point-min)) 5549 (goto-char (point-min))
4407 (cperl-update-syntaxification (point-max) (point-max)) 5550 (cperl-update-syntaxification (point-max) (point-max))
4408 ;; Search for the function 5551 ;; Search for the function
@@ -4410,72 +5553,81 @@ indentation and initial hashes. Behaves usually outside of comment."
4410 (while (re-search-forward 5553 (while (re-search-forward
4411 (or regexp cperl-imenu--function-name-regexp-perl) 5554 (or regexp cperl-imenu--function-name-regexp-perl)
4412 nil t) 5555 nil t)
5556 ;; 2=package-group, 5=package-name 8=sub-name
4413 (cond 5557 (cond
4414 ((and ; Skip some noise if building tags 5558 ((and ; Skip some noise if building tags
4415 (match-beginning 2) ; package or sub 5559 (match-beginning 5) ; package name
4416 (eq (char-after (match-beginning 2)) ?p) ; package 5560 ;;(eq (char-after (match-beginning 2)) ?p) ; package
4417 (not (save-match-data 5561 (not (save-match-data
4418 (looking-at "[ \t\n]*;")))) ; Plain text word 'package' 5562 (looking-at "[ \t\n]*;")))) ; Plain text word 'package'
4419 nil) 5563 nil)
4420 ((and 5564 ((and
4421 (match-beginning 2) ; package or sub 5565 (or (match-beginning 2)
5566 (match-beginning 8)) ; package or sub
4422 ;; Skip if quoted (will not skip multi-line ''-strings :-(): 5567 ;; Skip if quoted (will not skip multi-line ''-strings :-():
4423 (null (get-text-property (match-beginning 1) 'syntax-table)) 5568 (null (get-text-property (match-beginning 1) 'syntax-table))
4424 (null (get-text-property (match-beginning 1) 'syntax-type)) 5569 (null (get-text-property (match-beginning 1) 'syntax-type))
4425 (null (get-text-property (match-beginning 1) 'in-pod))) 5570 (null (get-text-property (match-beginning 1) 'in-pod)))
4426 (save-excursion 5571 (setq is-pack (match-beginning 2))
4427 (goto-char (match-beginning 2))
4428 (setq fchar (following-char)))
4429 ;; (if (looking-at "([^()]*)[ \t\n\f]*") 5572 ;; (if (looking-at "([^()]*)[ \t\n\f]*")
4430 ;; (goto-char (match-end 0))) ; Messes what follows 5573 ;; (goto-char (match-end 0))) ; Messes what follows
4431 (setq char (following-char) ; ?\; for "sub foo () ;" 5574 (setq meth nil
4432 meth nil
4433 p (point)) 5575 p (point))
4434 (while (and ends-ranges (>= p (car ends-ranges))) 5576 (while (and ends-ranges (>= p (car ends-ranges)))
4435 ;; delete obsolete entries 5577 ;; delete obsolete entries
4436 (setq ends-ranges (cdr ends-ranges) packages (cdr packages))) 5578 (setq ends-ranges (cdr ends-ranges) packages (cdr packages)))
4437 (setq package (or (car packages) "") 5579 (setq package (or (car packages) "")
4438 end-range (or (car ends-ranges) 0)) 5580 end-range (or (car ends-ranges) 0))
4439 (if (eq fchar ?p) 5581 (if is-pack ; doing "package"
4440 (setq name (buffer-substring (match-beginning 3) (match-end 3)) 5582 (progn
4441 name (progn 5583 (if (match-beginning 5) ; named package
4442 (set-text-properties 0 (length name) nil name) 5584 (setq name (buffer-substring (match-beginning 5)
4443 name) 5585 (match-end 5))
4444 package (concat name "::") 5586 name (progn
4445 name (concat "package " name) 5587 (set-text-properties 0 (length name) nil name)
4446 end-range 5588 name)
4447 (save-excursion 5589 package (concat name "::")
4448 (parse-partial-sexp (point) (point-max) -1) (point)) 5590 name (concat "package " name))
4449 ends-ranges (cons end-range ends-ranges) 5591 ;; Support nameless packages
4450 packages (cons package packages))) 5592 (setq name "package;" package ""))
4451 ;; ) 5593 (setq end-range
5594 (save-excursion
5595 (parse-partial-sexp (point) (point-max) -1) (point))
5596 ends-ranges (cons end-range ends-ranges)
5597 packages (cons package packages)))
5598 (setq is-proto
5599 (or (eq (following-char) ?\;)
5600 (eq 0 (get-text-property (point) 'attrib-group)))))
4452 ;; Skip this function name if it is a prototype declaration. 5601 ;; Skip this function name if it is a prototype declaration.
4453 (if (and (eq fchar ?s) (eq char ?\;)) nil 5602 (if (and is-proto (not is-pack)) nil
4454 (setq name (buffer-substring (match-beginning 3) (match-end 3)) 5603 (or is-pack
4455 marker (make-marker)) 5604 (setq name
4456 (set-text-properties 0 (length name) nil name) 5605 (buffer-substring (match-beginning 8) (match-end 8)))
4457 (set-marker marker (match-end 3)) 5606 (set-text-properties 0 (length name) nil name))
4458 (if (eq fchar ?p) 5607 (setq marker (make-marker))
4459 (setq name (concat "package " name)) 5608 (set-marker marker (match-end (if is-pack 2 8)))
4460 (cond ((string-match "[:']" name) 5609 (cond (is-pack nil)
4461 (setq meth t)) 5610 ((string-match "[:']" name)
4462 ((> p end-range) nil) 5611 (setq meth t))
4463 (t 5612 ((> p end-range) nil)
4464 (setq name (concat package name) meth t)))) 5613 (t
5614 (setq name (concat package name) meth t)))
4465 (setq index (cons name marker)) 5615 (setq index (cons name marker))
4466 (if (eq fchar ?p) 5616 (if is-pack
4467 (push index index-pack-alist) 5617 (push index index-pack-alist)
4468 (push index index-alist)) 5618 (push index index-alist))
4469 (if meth (push index index-meth-alist)) 5619 (if meth (push index index-meth-alist))
4470 (push index index-unsorted-alist))) 5620 (push index index-unsorted-alist)))
4471 ((match-beginning 5) ; POD section 5621 ((match-beginning 16) ; POD section
4472 ;; (beginning-of-line) 5622 (setq name (buffer-substring (match-beginning 17) (match-end 17))
4473 (setq index (imenu-example--name-and-position) 5623 marker (make-marker))
4474 name (buffer-substring (match-beginning 6) (match-end 6))) 5624 (set-marker marker (match-beginning 17))
4475 (set-text-properties 0 (length name) nil name) 5625 (set-text-properties 0 (length name) nil name)
4476 (if (eq (char-after (match-beginning 5)) ?2) 5626 (setq name (concat (make-string
4477 (setq name (concat " " name))) 5627 (* 3 (- (char-after (match-beginning 16)) ?1))
4478 (setcar index name) 5628 ?\ )
5629 name)
5630 index (cons name marker))
4479 (setq index1 (cons (concat "=" name) (cdr index))) 5631 (setq index1 (cons (concat "=" name) (cdr index)))
4480 (push index index-pod-alist) 5632 (push index index-pod-alist)
4481 (push index1 index-unsorted-alist))))) 5633 (push index1 index-unsorted-alist)))))
@@ -4539,29 +5691,20 @@ indentation and initial hashes. Behaves usually outside of comment."
4539(defun cperl-outline-level () 5691(defun cperl-outline-level ()
4540 (looking-at outline-regexp) 5692 (looking-at outline-regexp)
4541 (cond ((not (match-beginning 1)) 0) ; beginning-of-file 5693 (cond ((not (match-beginning 1)) 0) ; beginning-of-file
4542 ((match-beginning 2) 5694;;;; 2=package-group, 5=package-name 8=sub-name 16=head-level
4543 (if (eq (char-after (match-beginning 2)) ?p) 5695 ((match-beginning 2) 0) ; package
4544 0 ; package 5696 ((match-beginning 8) 1) ; sub
4545 1)) ; sub 5697 ((match-beginning 16)
4546 ((match-beginning 5) 5698 (- (char-after (match-beginning 16)) ?0)) ; headN ==> N
4547 (if (eq (char-after (match-beginning 5)) ?1) 5699 (t 5))) ; should not happen
4548 1 ; head1
4549 2)) ; head2
4550 (t 3))) ; should not happen
4551 5700
4552 5701
4553(defvar cperl-compilation-error-regexp-alist 5702(defvar cperl-compilation-error-regexp-alist
4554 ;; This look like a paranoiac regexp: could anybody find a better one? (which WORK). 5703 ;; This look like a paranoiac regexp: could anybody find a better one? (which WORKS).
4555 '(("^[^\n]* \\(file\\|at\\) \\([^ \t\n]+\\) [^\n]*line \\([0-9]+\\)[\\., \n]" 5704 '(("^[^\n]* \\(file\\|at\\) \\([^ \t\n]+\\) [^\n]*line \\([0-9]+\\)[\\., \n]"
4556 2 3)) 5705 2 3))
4557 "Alist that specifies how to match errors in perl output.") 5706 "Alist that specifies how to match errors in perl output.")
4558 5707
4559(if (fboundp 'eval-after-load)
4560 (eval-after-load
4561 "mode-compile"
4562 '(setq perl-compilation-error-regexp-alist
4563 cperl-compilation-error-regexp-alist)))
4564
4565 5708
4566(defun cperl-windowed-init () 5709(defun cperl-windowed-init ()
4567 "Initialization under windowed version." 5710 "Initialization under windowed version."
@@ -4602,9 +5745,12 @@ indentation and initial hashes. Behaves usually outside of comment."
4602 ;; Allow `cperl-find-pods-heres' to run. 5745 ;; Allow `cperl-find-pods-heres' to run.
4603 (or (boundp 'font-lock-constant-face) 5746 (or (boundp 'font-lock-constant-face)
4604 (cperl-force-face font-lock-constant-face 5747 (cperl-force-face font-lock-constant-face
4605 "Face for constant and label names") 5748 "Face for constant and label names"))
4606 ;;(setq font-lock-constant-face 'font-lock-constant-face) 5749 (or (boundp 'font-lock-warning-face)
4607 )) 5750 (cperl-force-face font-lock-warning-face
5751 "Face for things which should stand out"))
5752 ;;(setq font-lock-constant-face 'font-lock-constant-face)
5753 )
4608 5754
4609(defun cperl-init-faces () 5755(defun cperl-init-faces ()
4610 (condition-case errs 5756 (condition-case errs
@@ -4627,7 +5773,7 @@ indentation and initial hashes. Behaves usually outside of comment."
4627 'identity 5773 'identity
4628 '("if" "until" "while" "elsif" "else" "unless" "for" 5774 '("if" "until" "while" "elsif" "else" "unless" "for"
4629 "foreach" "continue" "exit" "die" "last" "goto" "next" 5775 "foreach" "continue" "exit" "die" "last" "goto" "next"
4630 "redo" "return" "local" "exec" "sub" "do" "dump" "use" 5776 "redo" "return" "local" "exec" "sub" "do" "dump" "use" "our"
4631 "require" "package" "eval" "my" "BEGIN" "END" "CHECK" "INIT") 5777 "require" "package" "eval" "my" "BEGIN" "END" "CHECK" "INIT")
4632 "\\|") ; Flow control 5778 "\\|") ; Flow control
4633 "\\)\\>") 2) ; was "\\)[ \n\t;():,\|&]" 5779 "\\)\\>") 2) ; was "\\)[ \n\t;():,\|&]"
@@ -4711,7 +5857,7 @@ indentation and initial hashes. Behaves usually outside of comment."
4711 ;; "chop" "defined" "delete" "do" "each" "else" "elsif" 5857 ;; "chop" "defined" "delete" "do" "each" "else" "elsif"
4712 ;; "eval" "exists" "for" "foreach" "format" "goto" 5858 ;; "eval" "exists" "for" "foreach" "format" "goto"
4713 ;; "grep" "if" "keys" "last" "local" "map" "my" "next" 5859 ;; "grep" "if" "keys" "last" "local" "map" "my" "next"
4714 ;; "no" "package" "pop" "pos" "print" "printf" "push" 5860 ;; "no" "our" "package" "pop" "pos" "print" "printf" "push"
4715 ;; "q" "qq" "qw" "qx" "redo" "return" "scalar" "shift" 5861 ;; "q" "qq" "qw" "qx" "redo" "return" "scalar" "shift"
4716 ;; "sort" "splice" "split" "study" "sub" "tie" "tr" 5862 ;; "sort" "splice" "split" "study" "sub" "tie" "tr"
4717 ;; "undef" "unless" "unshift" "untie" "until" "use" 5863 ;; "undef" "unless" "unshift" "untie" "until" "use"
@@ -4726,15 +5872,38 @@ indentation and initial hashes. Behaves usually outside of comment."
4726 "u\\(se\\|n\\(shift\\|ti\\(l\\|e\\)\\|def\\|less\\)\\)\\|" 5872 "u\\(se\\|n\\(shift\\|ti\\(l\\|e\\)\\|def\\|less\\)\\)\\|"
4727 "while\\|y\\|__\\(END\\|DATA\\)__" ;__DATA__ added manually 5873 "while\\|y\\|__\\(END\\|DATA\\)__" ;__DATA__ added manually
4728 "\\|[sm]" ; Added manually 5874 "\\|[sm]" ; Added manually
4729 "\\)\\>") 2 'cperl-nonoverridable) 5875 "\\)\\>") 2 'cperl-nonoverridable-face)
4730 ;; (mapconcat 'identity 5876 ;; (mapconcat 'identity
4731 ;; '("#endif" "#else" "#ifdef" "#ifndef" "#if" 5877 ;; '("#endif" "#else" "#ifdef" "#ifndef" "#if"
4732 ;; "#include" "#define" "#undef") 5878 ;; "#include" "#define" "#undef")
4733 ;; "\\|") 5879 ;; "\\|")
4734 '("-[rwxoRWXOezsfdlpSbctugkTBMAC]\\>\\([ \t]+_\\>\\)?" 0 5880 '("-[rwxoRWXOezsfdlpSbctugkTBMAC]\\>\\([ \t]+_\\>\\)?" 0
4735 font-lock-function-name-face keep) ; Not very good, triggers at "[a-z]" 5881 font-lock-function-name-face keep) ; Not very good, triggers at "[a-z]"
4736 '("\\<sub[ \t]+\\([^ \t{;()]+\\)[ \t]*\\(([^()]*)[ \t]*\\)?[#{\n]" 1 5882 ;; This highlights declarations and definitions differenty.
4737 font-lock-function-name-face) 5883 ;; We do not try to highlight in the case of attributes:
5884 ;; it is already done by `cperl-find-pods-heres'
5885 (list (concat "\\<sub"
5886 cperl-white-and-comment-rex ; whitespace/comments
5887 "\\([^ \n\t{;()]+\\)" ; 2=name (assume non-anonymous)
5888 "\\("
5889 cperl-maybe-white-and-comment-rex ;whitespace/comments?
5890 "([^()]*)\\)?" ; prototype
5891 cperl-maybe-white-and-comment-rex ; whitespace/comments?
5892 "[{;]")
5893 2 (if cperl-font-lock-multiline
5894 '(if (eq (char-after (cperl-1- (match-end 0))) ?\{ )
5895 'font-lock-function-name-face
5896 'font-lock-variable-name-face)
5897 ;; need to manually set 'multiline' for older font-locks
5898 '(progn
5899 (if (< 1 (count-lines (match-beginning 0)
5900 (match-end 0)))
5901 (put-text-property
5902 (+ 3 (match-beginning 0)) (match-end 0)
5903 'syntax-type 'multiline))
5904 (if (eq (char-after (cperl-1- (match-end 0))) ?\{ )
5905 'font-lock-function-name-face
5906 'font-lock-variable-name-face))))
4738 '("\\<\\(package\\|require\\|use\\|import\\|no\\|bootstrap\\)[ \t]+\\([a-zA-z_][a-zA-z_0-9:]*\\)[ \t;]" ; require A if B; 5907 '("\\<\\(package\\|require\\|use\\|import\\|no\\|bootstrap\\)[ \t]+\\([a-zA-z_][a-zA-z_0-9:]*\\)[ \t;]" ; require A if B;
4739 2 font-lock-function-name-face) 5908 2 font-lock-function-name-face)
4740 '("^[ \t]*format[ \t]+\\([a-zA-z_][a-zA-z_0-9:]*\\)[ \t]*=[ \t]*$" 5909 '("^[ \t]*format[ \t]+\\([a-zA-z_][a-zA-z_0-9:]*\\)[ \t]*=[ \t]*$"
@@ -4770,12 +5939,56 @@ indentation and initial hashes. Behaves usually outside of comment."
4770 (2 '(restart 2 nil) nil t))) 5939 (2 '(restart 2 nil) nil t)))
4771 nil t))) ; local variables, multiple 5940 nil t))) ; local variables, multiple
4772 (font-lock-anchored 5941 (font-lock-anchored
4773 '("^[ \t{}]*\\(my\\|local\\|our\\)[ \t]*\\(([ \t]*\\)?\\([$@%*][a-zA-Z0-9_:]+\\)" 5942 ;; 1=my_etc, 2=white? 3=(+white? 4=white? 5=var
4774 (3 font-lock-variable-name-face) 5943 (` ((, (concat "\\<\\(my\\|local\\|our\\)"
4775 ("\\=[ \t]*,[ \t]*\\([$@%*][a-zA-Z0-9_:]+\\)" 5944 cperl-maybe-white-and-comment-rex
4776 nil nil 5945 "\\(("
4777 (1 font-lock-variable-name-face)))) 5946 cperl-maybe-white-and-comment-rex
4778 (t '("^[ \t{}]*\\(my\\|local\\our\\)[ \t]*\\(([ \t]*\\)?\\([$@%*][a-zA-Z0-9_:]+\\)" 5947 "\\)?\\([$@%*]\\([a-zA-Z0-9_:]+\\|[^a-zA-Z0-9_]\\)\\)"))
5948 (5 (, (if cperl-font-lock-multiline
5949 'font-lock-variable-name-face
5950 '(progn (setq cperl-font-lock-multiline-start
5951 (match-beginning 0))
5952 'font-lock-variable-name-face))))
5953 ((, (concat "\\="
5954 cperl-maybe-white-and-comment-rex
5955 ","
5956 cperl-maybe-white-and-comment-rex
5957 "\\([$@%*]\\([a-zA-Z0-9_:]+\\|[^a-zA-Z0-9_]\\)\\)"))
5958 ;; Bug in font-lock: limit is used not only to limit
5959 ;; searches, but to set the "extend window for
5960 ;; facification" property. Thus we need to minimize.
5961 (, (if cperl-font-lock-multiline
5962 '(if (match-beginning 3)
5963 (save-excursion
5964 (goto-char (match-beginning 3))
5965 (condition-case nil
5966 (forward-sexp 1)
5967 (error
5968 (condition-case nil
5969 (forward-char 200)
5970 (error nil)))) ; typeahead
5971 (1- (point))) ; report limit
5972 (forward-char -2)) ; disable continued expr
5973 '(if (match-beginning 3)
5974 (point-max) ; No limit for continuation
5975 (forward-char -2)))) ; disable continued expr
5976 (, (if cperl-font-lock-multiline
5977 nil
5978 '(progn ; Do at end
5979 ;; "my" may be already fontified (POD),
5980 ;; so cperl-font-lock-multiline-start is nil
5981 (if (or (not cperl-font-lock-multiline-start)
5982 (> 2 (count-lines
5983 cperl-font-lock-multiline-start
5984 (point))))
5985 nil
5986 (put-text-property
5987 (1+ cperl-font-lock-multiline-start) (point)
5988 'syntax-type 'multiline))
5989 (setq cperl-font-lock-multiline-start nil))))
5990 (3 font-lock-variable-name-face)))))
5991 (t '("^[ \t{}]*\\(my\\|local\\|our\\)[ \t]*\\(([ \t]*\\)?\\([$@%*][a-zA-Z0-9_:]+\\)"
4779 3 font-lock-variable-name-face))) 5992 3 font-lock-variable-name-face)))
4780 '("\\<for\\(each\\)?\\([ \t]+\\(my\\|local\\|our\\)\\)?[ \t]*\\(\\$[a-zA-Z_][a-zA-Z_0-9]*\\)[ \t]*(" 5993 '("\\<for\\(each\\)?\\([ \t]+\\(my\\|local\\|our\\)\\)?[ \t]*\\(\\$[a-zA-Z_][a-zA-Z_0-9]*\\)[ \t]*("
4781 4 font-lock-variable-name-face) 5994 4 font-lock-variable-name-face)
@@ -4785,21 +5998,32 @@ indentation and initial hashes. Behaves usually outside of comment."
4785 (setq 5998 (setq
4786 t-font-lock-keywords-1 5999 t-font-lock-keywords-1
4787 (and (fboundp 'turn-on-font-lock) ; Check for newer font-lock 6000 (and (fboundp 'turn-on-font-lock) ; Check for newer font-lock
4788 (not cperl-xemacs-p) ; not yet as of XEmacs 19.12 6001 ;; not yet as of XEmacs 19.12, works with 21.1.11
6002 (or
6003 (not cperl-xemacs-p)
6004 (string< "21.1.9" emacs-version)
6005 (and (string< "21.1.10" emacs-version)
6006 (string< emacs-version "21.1.2")))
4789 '( 6007 '(
4790 ("\\(\\([@%]\\|\$#\\)[a-zA-Z_:][a-zA-Z0-9_:]*\\)" 1 6008 ("\\(\\([@%]\\|\$#\\)[a-zA-Z_:][a-zA-Z0-9_:]*\\)" 1
4791 (if (eq (char-after (match-beginning 2)) ?%) 6009 (if (eq (char-after (match-beginning 2)) ?%)
4792 'cperl-hash 6010 'cperl-hash-face
4793 'cperl-array) 6011 'cperl-array-face)
4794 t) ; arrays and hashes 6012 t) ; arrays and hashes
4795 ("\\(\\([$@]+\\)[a-zA-Z_:][a-zA-Z0-9_:]*\\)[ \t]*\\([[{]\\)" 6013 ("\\(\\([$@]+\\)[a-zA-Z_:][a-zA-Z0-9_:]*\\)[ \t]*\\([[{]\\)"
4796 1 6014 1
4797 (if (= (- (match-end 2) (match-beginning 2)) 1) 6015 (if (= (- (match-end 2) (match-beginning 2)) 1)
4798 (if (eq (char-after (match-beginning 3)) ?{) 6016 (if (eq (char-after (match-beginning 3)) ?{)
4799 'cperl-hash 6017 'cperl-hash-face
4800 'cperl-array) ; arrays and hashes 6018 'cperl-array-face) ; arrays and hashes
4801 font-lock-variable-name-face) ; Just to put something 6019 font-lock-variable-name-face) ; Just to put something
4802 t) 6020 t)
6021 ("\\(@\\|\\$#\\)\\(\\$+\\([a-zA-Z_:][a-zA-Z0-9_:]*\\|[^ \t\n]\\)\\)"
6022 (1 cperl-array-face)
6023 (2 font-lock-variable-name-face))
6024 ("\\(%\\)\\(\\$+\\([a-zA-Z_:][a-zA-Z0-9_:]*\\|[^ \t\n]\\)\\)"
6025 (1 cperl-hash-face)
6026 (2 font-lock-variable-name-face))
4803 ;;("\\([smy]\\|tr\\)\\([^a-z_A-Z0-9]\\)\\(\\([^\n\\]*||\\)\\)\\2") 6027 ;;("\\([smy]\\|tr\\)\\([^a-z_A-Z0-9]\\)\\(\\([^\n\\]*||\\)\\)\\2")
4804 ;;; Too much noise from \s* @s[ and friends 6028 ;;; Too much noise from \s* @s[ and friends
4805 ;;("\\(\\<\\([msy]\\|tr\\)[ \t]*\\([^ \t\na-zA-Z0-9_]\\)\\|\\(/\\)\\)" 6029 ;;("\\(\\<\\([msy]\\|tr\\)[ \t]*\\([^ \t\na-zA-Z0-9_]\\)\\|\\(/\\)\\)"
@@ -4811,7 +6035,7 @@ indentation and initial hashes. Behaves usually outside of comment."
4811 (if cperl-highlight-variables-indiscriminately 6035 (if cperl-highlight-variables-indiscriminately
4812 (setq t-font-lock-keywords-1 6036 (setq t-font-lock-keywords-1
4813 (append t-font-lock-keywords-1 6037 (append t-font-lock-keywords-1
4814 (list '("[$*]{?\\(\\sw+\\)" 1 6038 (list '("\\([$*]{?\\sw+\\)" 1
4815 font-lock-variable-name-face))))) 6039 font-lock-variable-name-face)))))
4816 (setq cperl-font-lock-keywords-1 6040 (setq cperl-font-lock-keywords-1
4817 (if cperl-syntaxify-by-font-lock 6041 (if cperl-syntaxify-by-font-lock
@@ -4864,27 +6088,35 @@ indentation and initial hashes. Behaves usually outside of comment."
4864 [nil nil t t t] 6088 [nil nil t t t]
4865 nil 6089 nil
4866 [nil nil t t t]) 6090 [nil nil t t t])
6091 (list 'font-lock-warning-face
6092 ["Pink" "Red" "Gray50" "LightGray"]
6093 ["gray20" "gray90"
6094 "gray80" "gray20"]
6095 [nil nil t t t]
6096 nil
6097 [nil nil t t t]
6098 )
4867 (list 'font-lock-constant-face 6099 (list 'font-lock-constant-face
4868 ["CadetBlue" "Aquamarine" "Gray50" "LightGray"] 6100 ["CadetBlue" "Aquamarine" "Gray50" "LightGray"]
4869 nil 6101 nil
4870 [nil nil t t t] 6102 [nil nil t t t]
4871 nil 6103 nil
4872 [nil nil t t t]) 6104 [nil nil t t t])
4873 (list 'cperl-nonoverridable 6105 (list 'cperl-nonoverridable-face
4874 ["chartreuse3" ("orchid1" "orange") 6106 ["chartreuse3" ("orchid1" "orange")
4875 nil "Gray80"] 6107 nil "Gray80"]
4876 [nil nil "gray90"] 6108 [nil nil "gray90"]
4877 [nil nil nil t t] 6109 [nil nil nil t t]
4878 [nil nil t t] 6110 [nil nil t t]
4879 [nil nil t t t]) 6111 [nil nil t t t])
4880 (list 'cperl-array 6112 (list 'cperl-array-face
4881 ["blue" "yellow" nil "Gray80"] 6113 ["blue" "yellow" nil "Gray80"]
4882 ["lightyellow2" ("navy" "os2blue" "darkgreen") 6114 ["lightyellow2" ("navy" "os2blue" "darkgreen")
4883 "gray90"] 6115 "gray90"]
4884 t 6116 t
4885 nil 6117 nil
4886 nil) 6118 nil)
4887 (list 'cperl-hash 6119 (list 'cperl-hash-face
4888 ["red" "red" nil "Gray80"] 6120 ["red" "red" nil "Gray80"]
4889 ["lightyellow2" ("navy" "os2blue" "darkgreen") 6121 ["lightyellow2" ("navy" "os2blue" "darkgreen")
4890 "gray90"] 6122 "gray90"]
@@ -4907,15 +6139,17 @@ indentation and initial hashes. Behaves usually outside of comment."
4907 "Face for variable names") 6139 "Face for variable names")
4908 (cperl-force-face font-lock-type-face 6140 (cperl-force-face font-lock-type-face
4909 "Face for data types") 6141 "Face for data types")
4910 (cperl-force-face cperl-nonoverridable 6142 (cperl-force-face cperl-nonoverridable-face
4911 "Face for data types from another group") 6143 "Face for data types from another group")
6144 (cperl-force-face font-lock-warning-face
6145 "Face for things which should stand out")
4912 (cperl-force-face font-lock-comment-face 6146 (cperl-force-face font-lock-comment-face
4913 "Face for comments") 6147 "Face for comments")
4914 (cperl-force-face font-lock-function-name-face 6148 (cperl-force-face font-lock-function-name-face
4915 "Face for function names") 6149 "Face for function names")
4916 (cperl-force-face cperl-hash 6150 (cperl-force-face cperl-hash-face
4917 "Face for hashes") 6151 "Face for hashes")
4918 (cperl-force-face cperl-array 6152 (cperl-force-face cperl-array-face
4919 "Face for arrays") 6153 "Face for arrays")
4920 ;;(defvar font-lock-constant-face 'font-lock-constant-face) 6154 ;;(defvar font-lock-constant-face 'font-lock-constant-face)
4921 ;;(defvar font-lock-variable-name-face 'font-lock-variable-name-face) 6155 ;;(defvar font-lock-variable-name-face 'font-lock-variable-name-face)
@@ -4925,7 +6159,7 @@ indentation and initial hashes. Behaves usually outside of comment."
4925 ;; "Face to use for data types.")) 6159 ;; "Face to use for data types."))
4926 ;;(or (boundp 'cperl-nonoverridable-face) 6160 ;;(or (boundp 'cperl-nonoverridable-face)
4927 ;; (defconst cperl-nonoverridable-face 6161 ;; (defconst cperl-nonoverridable-face
4928 ;; 'cperl-nonoverridable 6162 ;; 'cperl-nonoverridable-face
4929 ;; "Face to use for data types from another group.")) 6163 ;; "Face to use for data types from another group."))
4930 ;;(if (not cperl-xemacs-p) nil 6164 ;;(if (not cperl-xemacs-p) nil
4931 ;; (or (boundp 'font-lock-comment-face) 6165 ;; (or (boundp 'font-lock-comment-face)
@@ -4941,24 +6175,24 @@ indentation and initial hashes. Behaves usually outside of comment."
4941 ;; 'font-lock-function-name-face 6175 ;; 'font-lock-function-name-face
4942 ;; "Face to use for function names."))) 6176 ;; "Face to use for function names.")))
4943 (if (and 6177 (if (and
4944 (not (cperl-is-face 'cperl-array)) 6178 (not (cperl-is-face 'cperl-array-face))
4945 (cperl-is-face 'font-lock-emphasized-face)) 6179 (cperl-is-face 'font-lock-emphasized-face))
4946 (copy-face 'font-lock-emphasized-face 'cperl-array)) 6180 (copy-face 'font-lock-emphasized-face 'cperl-array-face))
4947 (if (and 6181 (if (and
4948 (not (cperl-is-face 'cperl-hash)) 6182 (not (cperl-is-face 'cperl-hash-face))
4949 (cperl-is-face 'font-lock-other-emphasized-face)) 6183 (cperl-is-face 'font-lock-other-emphasized-face))
4950 (copy-face 'font-lock-other-emphasized-face 'cperl-hash)) 6184 (copy-face 'font-lock-other-emphasized-face 'cperl-hash-face))
4951 (if (and 6185 (if (and
4952 (not (cperl-is-face 'cperl-nonoverridable)) 6186 (not (cperl-is-face 'cperl-nonoverridable-face))
4953 (cperl-is-face 'font-lock-other-type-face)) 6187 (cperl-is-face 'font-lock-other-type-face))
4954 (copy-face 'font-lock-other-type-face 'cperl-nonoverridable)) 6188 (copy-face 'font-lock-other-type-face 'cperl-nonoverridable-face))
4955 ;;(or (boundp 'cperl-hash-face) 6189 ;;(or (boundp 'cperl-hash-face)
4956 ;; (defconst cperl-hash-face 6190 ;; (defconst cperl-hash-face
4957 ;; 'cperl-hash 6191 ;; 'cperl-hash-face
4958 ;; "Face to use for hashes.")) 6192 ;; "Face to use for hashes."))
4959 ;;(or (boundp 'cperl-array-face) 6193 ;;(or (boundp 'cperl-array-face)
4960 ;; (defconst cperl-array-face 6194 ;; (defconst cperl-array-face
4961 ;; 'cperl-array 6195 ;; 'cperl-array-face
4962 ;; "Face to use for arrays.")) 6196 ;; "Face to use for arrays."))
4963 ;; Here we try to guess background 6197 ;; Here we try to guess background
4964 (let ((background 6198 (let ((background
@@ -4997,17 +6231,17 @@ indentation and initial hashes. Behaves usually outside of comment."
4997 "pink"))) 6231 "pink")))
4998 (t 6232 (t
4999 (set-face-background 'font-lock-type-face "gray90")))) 6233 (set-face-background 'font-lock-type-face "gray90"))))
5000 (if (cperl-is-face 'cperl-nonoverridable) 6234 (if (cperl-is-face 'cperl-nonoverridable-face)
5001 nil 6235 nil
5002 (copy-face 'font-lock-type-face 'cperl-nonoverridable) 6236 (copy-face 'font-lock-type-face 'cperl-nonoverridable-face)
5003 (cond 6237 (cond
5004 ((eq background 'light) 6238 ((eq background 'light)
5005 (set-face-foreground 'cperl-nonoverridable 6239 (set-face-foreground 'cperl-nonoverridable-face
5006 (if (x-color-defined-p "chartreuse3") 6240 (if (x-color-defined-p "chartreuse3")
5007 "chartreuse3" 6241 "chartreuse3"
5008 "chartreuse"))) 6242 "chartreuse")))
5009 ((eq background 'dark) 6243 ((eq background 'dark)
5010 (set-face-foreground 'cperl-nonoverridable 6244 (set-face-foreground 'cperl-nonoverridable-face
5011 (if (x-color-defined-p "orchid1") 6245 (if (x-color-defined-p "orchid1")
5012 "orchid1" 6246 "orchid1"
5013 "orange"))))) 6247 "orange")))))
@@ -5059,15 +6293,15 @@ indentation and initial hashes. Behaves usually outside of comment."
5059 '(setq ps-bold-faces 6293 '(setq ps-bold-faces
5060 ;; font-lock-variable-name-face 6294 ;; font-lock-variable-name-face
5061 ;; font-lock-constant-face 6295 ;; font-lock-constant-face
5062 (append '(cperl-array cperl-hash) 6296 (append '(cperl-array-face cperl-hash-face)
5063 ps-bold-faces) 6297 ps-bold-faces)
5064 ps-italic-faces 6298 ps-italic-faces
5065 ;; font-lock-constant-face 6299 ;; font-lock-constant-face
5066 (append '(cperl-nonoverridable cperl-hash) 6300 (append '(cperl-nonoverridable-face cperl-hash-face)
5067 ps-italic-faces) 6301 ps-italic-faces)
5068 ps-underlined-faces 6302 ps-underlined-faces
5069 ;; font-lock-type-face 6303 ;; font-lock-type-face
5070 (append '(cperl-array cperl-hash underline cperl-nonoverridable) 6304 (append '(cperl-array-face cperl-hash-face underline cperl-nonoverridable-face)
5071 ps-underlined-faces)))) 6305 ps-underlined-faces))))
5072 6306
5073(defvar ps-print-face-extension-alist) 6307(defvar ps-print-face-extension-alist)
@@ -5100,27 +6334,27 @@ Style of printout regulated by the variable `cperl-ps-print-face-properties'."
5100;;; (defvar ps-italic-faces nil) 6334;;; (defvar ps-italic-faces nil)
5101;;; (setq ps-bold-faces 6335;;; (setq ps-bold-faces
5102;;; (append '(font-lock-emphasized-face 6336;;; (append '(font-lock-emphasized-face
5103;;; cperl-array 6337;;; cperl-array-face
5104;;; font-lock-keyword-face 6338;;; font-lock-keyword-face
5105;;; font-lock-variable-name-face 6339;;; font-lock-variable-name-face
5106;;; font-lock-constant-face 6340;;; font-lock-constant-face
5107;;; font-lock-reference-face 6341;;; font-lock-reference-face
5108;;; font-lock-other-emphasized-face 6342;;; font-lock-other-emphasized-face
5109;;; cperl-hash) 6343;;; cperl-hash-face)
5110;;; ps-bold-faces)) 6344;;; ps-bold-faces))
5111;;; (setq ps-italic-faces 6345;;; (setq ps-italic-faces
5112;;; (append '(cperl-nonoverridable 6346;;; (append '(cperl-nonoverridable-face
5113;;; font-lock-constant-face 6347;;; font-lock-constant-face
5114;;; font-lock-reference-face 6348;;; font-lock-reference-face
5115;;; font-lock-other-emphasized-face 6349;;; font-lock-other-emphasized-face
5116;;; cperl-hash) 6350;;; cperl-hash-face)
5117;;; ps-italic-faces)) 6351;;; ps-italic-faces))
5118;;; (setq ps-underlined-faces 6352;;; (setq ps-underlined-faces
5119;;; (append '(font-lock-emphasized-face 6353;;; (append '(font-lock-emphasized-face
5120;;; cperl-array 6354;;; cperl-array-face
5121;;; font-lock-other-emphasized-face 6355;;; font-lock-other-emphasized-face
5122;;; cperl-hash 6356;;; cperl-hash-face
5123;;; cperl-nonoverridable font-lock-type-face) 6357;;; cperl-nonoverridable-face font-lock-type-face)
5124;;; ps-underlined-faces)) 6358;;; ps-underlined-faces))
5125;;; (cons 'font-lock-type-face ps-underlined-faces)) 6359;;; (cons 'font-lock-type-face ps-underlined-faces))
5126 6360
@@ -5130,79 +6364,211 @@ Style of printout regulated by the variable `cperl-ps-print-face-properties'."
5130(defconst cperl-styles-entries 6364(defconst cperl-styles-entries
5131 '(cperl-indent-level cperl-brace-offset cperl-continued-brace-offset 6365 '(cperl-indent-level cperl-brace-offset cperl-continued-brace-offset
5132 cperl-label-offset cperl-extra-newline-before-brace 6366 cperl-label-offset cperl-extra-newline-before-brace
6367 cperl-extra-newline-before-brace-multiline
5133 cperl-merge-trailing-else 6368 cperl-merge-trailing-else
5134 cperl-continued-statement-offset)) 6369 cperl-continued-statement-offset))
5135 6370
6371(defconst cperl-style-examples
6372"##### Numbers etc are: cperl-indent-level cperl-brace-offset
6373##### cperl-continued-brace-offset cperl-label-offset
6374##### cperl-continued-statement-offset
6375##### cperl-merge-trailing-else cperl-extra-newline-before-brace
6376
6377########### (Do not forget cperl-extra-newline-before-brace-multiline)
6378
6379### CPerl (=GNU - extra-newline-before-brace + merge-trailing-else) 2/0/0/-2/2/t/nil
6380if (foo) {
6381 bar
6382 baz;
6383 label:
6384 {
6385 boon;
6386 }
6387} else {
6388 stop;
6389}
6390
6391### PerlStyle (=CPerl with 4 as indent) 4/0/0/-4/4/t/nil
6392if (foo) {
6393 bar
6394 baz;
6395 label:
6396 {
6397 boon;
6398 }
6399} else {
6400 stop;
6401}
6402
6403### GNU 2/0/0/-2/2/nil/t
6404if (foo)
6405 {
6406 bar
6407 baz;
6408 label:
6409 {
6410 boon;
6411 }
6412 }
6413else
6414 {
6415 stop;
6416 }
6417
6418### C++ (=PerlStyle with braces aligned with control words) 4/0/-4/-4/4/nil/t
6419if (foo)
6420{
6421 bar
6422 baz;
6423 label:
6424 {
6425 boon;
6426 }
6427}
6428else
6429{
6430 stop;
6431}
6432
6433### BSD (=C++, but will not change preexisting merge-trailing-else
6434### and extra-newline-before-brace ) 4/0/-4/-4/4
6435if (foo)
6436{
6437 bar
6438 baz;
6439 label:
6440 {
6441 boon;
6442 }
6443}
6444else
6445{
6446 stop;
6447}
6448
6449### K&R (=C++ with indent 5 - merge-trailing-else, but will not
6450### change preexisting extra-newline-before-brace) 5/0/-5/-5/5/nil
6451if (foo)
6452{
6453 bar
6454 baz;
6455 label:
6456 {
6457 boon;
6458 }
6459}
6460else
6461{
6462 stop;
6463}
6464
6465### Whitesmith (=PerlStyle, but will not change preexisting
6466### extra-newline-before-brace and merge-trailing-else) 4/0/0/-4/4
6467if (foo)
6468 {
6469 bar
6470 baz;
6471 label:
6472 {
6473 boon;
6474 }
6475 }
6476else
6477 {
6478 stop;
6479 }
6480"
6481"Examples of if/else with different indent styles (with v4.23).")
6482
5136(defconst cperl-style-alist 6483(defconst cperl-style-alist
5137 '(("CPerl" ; =GNU without extra-newline-before-brace 6484 '(("CPerl" ;; =GNU - extra-newline-before-brace + cperl-merge-trailing-else
5138 (cperl-indent-level . 2) 6485 (cperl-indent-level . 2)
5139 (cperl-brace-offset . 0) 6486 (cperl-brace-offset . 0)
5140 (cperl-continued-brace-offset . 0) 6487 (cperl-continued-brace-offset . 0)
5141 (cperl-label-offset . -2) 6488 (cperl-label-offset . -2)
6489 (cperl-continued-statement-offset . 2)
5142 (cperl-extra-newline-before-brace . nil) 6490 (cperl-extra-newline-before-brace . nil)
5143 (cperl-merge-trailing-else . t) 6491 (cperl-extra-newline-before-brace-multiline . nil)
5144 (cperl-continued-statement-offset . 2)) 6492 (cperl-merge-trailing-else . t))
6493
5145 ("PerlStyle" ; CPerl with 4 as indent 6494 ("PerlStyle" ; CPerl with 4 as indent
5146 (cperl-indent-level . 4) 6495 (cperl-indent-level . 4)
5147 (cperl-brace-offset . 0) 6496 (cperl-brace-offset . 0)
5148 (cperl-continued-brace-offset . 0) 6497 (cperl-continued-brace-offset . 0)
5149 (cperl-label-offset . -4) 6498 (cperl-label-offset . -4)
6499 (cperl-continued-statement-offset . 4)
5150 (cperl-extra-newline-before-brace . nil) 6500 (cperl-extra-newline-before-brace . nil)
5151 (cperl-merge-trailing-else . t) 6501 (cperl-extra-newline-before-brace-multiline . nil)
5152 (cperl-continued-statement-offset . 4)) 6502 (cperl-merge-trailing-else . t))
6503
5153 ("GNU" 6504 ("GNU"
5154 (cperl-indent-level . 2) 6505 (cperl-indent-level . 2)
5155 (cperl-brace-offset . 0) 6506 (cperl-brace-offset . 0)
5156 (cperl-continued-brace-offset . 0) 6507 (cperl-continued-brace-offset . 0)
5157 (cperl-label-offset . -2) 6508 (cperl-label-offset . -2)
6509 (cperl-continued-statement-offset . 2)
5158 (cperl-extra-newline-before-brace . t) 6510 (cperl-extra-newline-before-brace . t)
5159 (cperl-merge-trailing-else . nil) 6511 (cperl-extra-newline-before-brace-multiline . t)
5160 (cperl-continued-statement-offset . 2)) 6512 (cperl-merge-trailing-else . nil))
6513
5161 ("K&R" 6514 ("K&R"
5162 (cperl-indent-level . 5) 6515 (cperl-indent-level . 5)
5163 (cperl-brace-offset . 0) 6516 (cperl-brace-offset . 0)
5164 (cperl-continued-brace-offset . -5) 6517 (cperl-continued-brace-offset . -5)
5165 (cperl-label-offset . -5) 6518 (cperl-label-offset . -5)
6519 (cperl-continued-statement-offset . 5)
5166 ;;(cperl-extra-newline-before-brace . nil) ; ??? 6520 ;;(cperl-extra-newline-before-brace . nil) ; ???
5167 (cperl-merge-trailing-else . nil) 6521 ;;(cperl-extra-newline-before-brace-multiline . nil)
5168 (cperl-continued-statement-offset . 5)) 6522 (cperl-merge-trailing-else . nil))
6523
5169 ("BSD" 6524 ("BSD"
5170 (cperl-indent-level . 4) 6525 (cperl-indent-level . 4)
5171 (cperl-brace-offset . 0) 6526 (cperl-brace-offset . 0)
5172 (cperl-continued-brace-offset . -4) 6527 (cperl-continued-brace-offset . -4)
5173 (cperl-label-offset . -4) 6528 (cperl-label-offset . -4)
6529 (cperl-continued-statement-offset . 4)
5174 ;;(cperl-extra-newline-before-brace . nil) ; ??? 6530 ;;(cperl-extra-newline-before-brace . nil) ; ???
5175 (cperl-continued-statement-offset . 4)) 6531 ;;(cperl-extra-newline-before-brace-multiline . nil)
6532 ;;(cperl-merge-trailing-else . nil) ; ???
6533 )
6534
5176 ("C++" 6535 ("C++"
5177 (cperl-indent-level . 4) 6536 (cperl-indent-level . 4)
5178 (cperl-brace-offset . 0) 6537 (cperl-brace-offset . 0)
5179 (cperl-continued-brace-offset . -4) 6538 (cperl-continued-brace-offset . -4)
5180 (cperl-label-offset . -4) 6539 (cperl-label-offset . -4)
5181 (cperl-continued-statement-offset . 4) 6540 (cperl-continued-statement-offset . 4)
5182 (cperl-merge-trailing-else . nil) 6541 (cperl-extra-newline-before-brace . t)
5183 (cperl-extra-newline-before-brace . t)) 6542 (cperl-extra-newline-before-brace-multiline . t)
5184 ("Current") 6543 (cperl-merge-trailing-else . nil))
6544
5185 ("Whitesmith" 6545 ("Whitesmith"
5186 (cperl-indent-level . 4) 6546 (cperl-indent-level . 4)
5187 (cperl-brace-offset . 0) 6547 (cperl-brace-offset . 0)
5188 (cperl-continued-brace-offset . 0) 6548 (cperl-continued-brace-offset . 0)
5189 (cperl-label-offset . -4) 6549 (cperl-label-offset . -4)
6550 (cperl-continued-statement-offset . 4)
5190 ;;(cperl-extra-newline-before-brace . nil) ; ??? 6551 ;;(cperl-extra-newline-before-brace . nil) ; ???
5191 (cperl-continued-statement-offset . 4))) 6552 ;;(cperl-extra-newline-before-brace-multiline . nil)
5192 "(Experimental) list of variables to set to get a particular indentation style. 6553 ;;(cperl-merge-trailing-else . nil) ; ???
5193Should be used via `cperl-set-style' or via Perl menu.") 6554 )
6555 ("Current"))
6556 "List of variables to set to get a particular indentation style.
6557Should be used via `cperl-set-style' or via Perl menu.
6558
6559See examples in `cperl-style-examples'.")
5194 6560
5195(defun cperl-set-style (style) 6561(defun cperl-set-style (style)
5196 "Set CPerl mode variables to use one of several different indentation styles. 6562 "Set CPerl mode variables to use one of several different indentation styles.
5197The arguments are a string representing the desired style. 6563The arguments are a string representing the desired style.
5198The list of styles is in `cperl-style-alist', available styles 6564The list of styles is in `cperl-style-alist', available styles
5199are GNU, K&R, BSD, C++ and Whitesmith. 6565are CPerl, PerlStyle, GNU, K&R, BSD, C++ and Whitesmith.
5200 6566
5201The current value of style is memorized (unless there is a memorized 6567The current value of style is memorized (unless there is a memorized
5202data already), may be restored by `cperl-set-style-back'. 6568data already), may be restored by `cperl-set-style-back'.
5203 6569
5204Chosing \"Current\" style will not change style, so this may be used for 6570Chosing \"Current\" style will not change style, so this may be used for
5205side-effect of memorizing only." 6571side-effect of memorizing only. Examples in `cperl-style-examples'."
5206 (interactive 6572 (interactive
5207 (let ((list (mapcar (function (lambda (elt) (list (car elt)))) 6573 (let ((list (mapcar (function (lambda (elt) (list (car elt))))
5208 cperl-style-alist))) 6574 cperl-style-alist)))
@@ -5373,6 +6739,8 @@ Customized by setting variables `cperl-shrink-wrap-info-frame',
5373 (match-beginning 1) (match-end 1))) 6739 (match-beginning 1) (match-end 1)))
5374 6740
5375(defun cperl-imenu-on-info () 6741(defun cperl-imenu-on-info ()
6742 "Shows imenu for Perl Info Buffer.
6743Opens Perl Info buffer if needed."
5376 (interactive) 6744 (interactive)
5377 (let* ((buffer (current-buffer)) 6745 (let* ((buffer (current-buffer))
5378 imenu-create-index-function 6746 imenu-create-index-function
@@ -5412,7 +6780,7 @@ If STEP is nil, `cperl-lineup-step' will be used
5412\(or `cperl-indent-level', if `cperl-lineup-step' is nil). 6780\(or `cperl-indent-level', if `cperl-lineup-step' is nil).
5413Will not move the position at the start to the left." 6781Will not move the position at the start to the left."
5414 (interactive "r") 6782 (interactive "r")
5415 (let (search col tcol seen b e) 6783 (let (search col tcol seen b)
5416 (save-excursion 6784 (save-excursion
5417 (goto-char end) 6785 (goto-char end)
5418 (end-of-line) 6786 (end-of-line)
@@ -5450,22 +6818,25 @@ Will not move the position at the start to the left."
5450 (if (/= (% col step) 0) (setq step (* step (1+ (/ col step))))) 6818 (if (/= (% col step) 0) (setq step (* step (1+ (/ col step)))))
5451 (while 6819 (while
5452 (progn 6820 (progn
5453 (setq e (point)) 6821 (cperl-make-indent col)
5454 (skip-chars-backward " \t")
5455 (delete-region (point) e)
5456 (indent-to-column col) ;(make-string (- col (current-column)) ?\s))
5457 (beginning-of-line 2) 6822 (beginning-of-line 2)
5458 (and (< (point) end) 6823 (and (< (point) end)
5459 (re-search-forward search end t) 6824 (re-search-forward search end t)
5460 (goto-char (match-beginning 0)))))))) ; No body 6825 (goto-char (match-beginning 0)))))))) ; No body
5461 6826
5462(defun cperl-etags (&optional add all files) 6827(defun cperl-etags (&optional add all files) ;; NOT USED???
5463 "Run etags with appropriate options for Perl files. 6828 "Run etags with appropriate options for Perl files.
5464If optional argument ALL is `recursive', will process Perl files 6829If optional argument ALL is `recursive', will process Perl files
5465in subdirectories too." 6830in subdirectories too."
5466 (interactive) 6831 (interactive)
5467 (let ((cmd "etags") 6832 (let ((cmd "etags")
5468 (args '("-l" "none" "-r" "/\\<\\(package\\|sub\\)[ \\t]+\\(\\([a-zA-Z0-9:_]*::\\)?\\([a-zA-Z0-9_]+\\)[ \\t]*\\(([^()]*)[ \t]*\\)?\\([{#]\\|$\\)\\)/\\4/")) 6833 (args '("-l" "none" "-r"
6834 ;; 1=fullname 2=package? 3=name 4=proto? 5=attrs? (VERY APPROX!)
6835 "/\\<sub[ \\t]+\\(\\([a-zA-Z0-9:_]*::\\)?\\([a-zA-Z0-9_]+\\)\\)[ \\t]*\\(([^()]*)[ \t]*\\)?\\([ \t]*:[^#{;]*\\)?\\([{#]\\|$\\)/\\3/"
6836 "-r"
6837 "/\\<package[ \\t]+\\(\\([a-zA-Z0-9:_]*::\\)?\\([a-zA-Z0-9_]+\\)\\)[ \\t]*\\([#;]\\|$\\)/\\1/"
6838 "-r"
6839 "/\\<\\(package\\)[ \\t]*;/\\1;/"))
5469 res) 6840 res)
5470 (if add (setq args (cons "-a" args))) 6841 (if add (setq args (cons "-a" args)))
5471 (or files (setq files (list buffer-file-name))) 6842 (or files (setq files (list buffer-file-name)))
@@ -5537,6 +6908,29 @@ Delay of auto-help controlled by `cperl-lazy-help-time'."
5537 (message "indent-region/indent-sexp will %sbe automatically fix whitespace." 6908 (message "indent-region/indent-sexp will %sbe automatically fix whitespace."
5538 (if cperl-indent-region-fix-constructs "" "not "))) 6909 (if cperl-indent-region-fix-constructs "" "not ")))
5539 6910
6911(defun cperl-toggle-set-debug-unwind (arg &optional backtrace)
6912 "Toggle (or, with numeric argument, set) debugging state of syntaxification.
6913Nonpositive numeric argument disables debugging messages. The message
6914summarizes which regions it was decided to rescan for syntactic constructs.
6915
6916The message looks like this:
6917
6918 Syxify req=123..138 actual=101..146 done-to: 112=>146 statepos: 73=>117
6919
6920Numbers are character positions in the buffer. REQ provides the range to
6921rescan requested by `font-lock'. ACTUAL is the range actually resyntaxified;
6922for correct operation it should start and end outside any special syntactic
6923construct. DONE-TO and STATEPOS indicate changes to internal caches maintained
6924by CPerl."
6925 (interactive "P")
6926 (or arg
6927 (setq arg (if (eq cperl-syntaxify-by-font-lock
6928 (if backtrace 'backtrace 'message)) 0 1)))
6929 (setq arg (if (> arg 0) (if backtrace 'backtrace 'message) t))
6930 (setq cperl-syntaxify-by-font-lock arg)
6931 (message "Debugging messages of syntax unwind %sabled."
6932 (if (eq arg t) "dis" "en")))
6933
5540;;;; Tags file creation. 6934;;;; Tags file creation.
5541 6935
5542(defvar cperl-tmp-buffer " *cperl-tmp*") 6936(defvar cperl-tmp-buffer " *cperl-tmp*")
@@ -5677,13 +7071,22 @@ Delay of auto-help controlled by `cperl-lazy-help-time'."
5677 ret)))) 7071 ret))))
5678 7072
5679(defun cperl-add-tags-recurse-noxs () 7073(defun cperl-add-tags-recurse-noxs ()
5680 "Add to TAGS data for Perl and XSUB files in the current directory and kids. 7074 "Add to TAGS data for \"pure\" Perl files in the current directory and kids.
5681Use as 7075Use as
5682 emacs -batch -q -no-site-file -l emacs/cperl-mode.el \ 7076 emacs -batch -q -no-site-file -l emacs/cperl-mode.el \
5683 -f cperl-add-tags-recurse 7077 -f cperl-add-tags-recurse-noxs
5684" 7078"
5685 (cperl-write-tags nil nil t t nil t)) 7079 (cperl-write-tags nil nil t t nil t))
5686 7080
7081(defun cperl-add-tags-recurse-noxs-fullpath ()
7082 "Add to TAGS data for \"pure\" Perl in the current directory and kids.
7083Writes down fullpath, so TAGS is relocatable (but if the build directory
7084is relocated, the file TAGS inside it breaks). Use as
7085 emacs -batch -q -no-site-file -l emacs/cperl-mode.el \
7086 -f cperl-add-tags-recurse-noxs-fullpath
7087"
7088 (cperl-write-tags nil nil t t nil t ""))
7089
5687(defun cperl-add-tags-recurse () 7090(defun cperl-add-tags-recurse ()
5688 "Add to TAGS file data for Perl files in the current directory and kids. 7091 "Add to TAGS file data for Perl files in the current directory and kids.
5689Use as 7092Use as
@@ -5853,9 +7256,9 @@ One may build such TAGS files from CPerl mode menu."
5853 (cperl-tags-hier-fill)) 7256 (cperl-tags-hier-fill))
5854 (or tags-table-list 7257 (or tags-table-list
5855 (call-interactively 'visit-tags-table)) 7258 (call-interactively 'visit-tags-table))
5856 (mapcar 7259 (mapcar
5857 (function 7260 (function
5858 (lambda (tagsfile) 7261 (lambda (tagsfile)
5859 (message "Updating list of classes... %s" tagsfile) 7262 (message "Updating list of classes... %s" tagsfile)
5860 (set-buffer (get-file-buffer tagsfile)) 7263 (set-buffer (get-file-buffer tagsfile))
5861 (cperl-tags-hier-fill))) 7264 (cperl-tags-hier-fill)))
@@ -6017,7 +7420,7 @@ One may build such TAGS files from CPerl mode menu."
6017 '("[^-\t <>=+]\\(--\\|\\+\\+\\)" ; var-- var++ 7420 '("[^-\t <>=+]\\(--\\|\\+\\+\\)" ; var-- var++
6018 "[a-zA-Z0-9_][|&][a-zA-Z0-9_$]" ; abc|def abc&def are often used. 7421 "[a-zA-Z0-9_][|&][a-zA-Z0-9_$]" ; abc|def abc&def are often used.
6019 "&[(a-zA-Z0-9_$]" ; &subroutine &(var->field) 7422 "&[(a-zA-Z0-9_$]" ; &subroutine &(var->field)
6020 "<\\$?\\sw+\\(\\.\\sw+\\)?>" ; <IN> <stdin.h> 7423 "<\\$?\\sw+\\(\\.\\(\\sw\\|_\\)+\\)?>" ; <IN> <stdin.h>
6021 "-[a-zA-Z][ \t]+[_$\"'`a-zA-Z]" ; -f file, -t STDIN 7424 "-[a-zA-Z][ \t]+[_$\"'`a-zA-Z]" ; -f file, -t STDIN
6022 "-[0-9]" ; -5 7425 "-[0-9]" ; -5
6023 "\\+\\+" ; ++var 7426 "\\+\\+" ; ++var
@@ -6049,8 +7452,7 @@ Currently it is tuned to C and Perl syntax."
6049 (interactive) 7452 (interactive)
6050 (let (found-bad (p (point))) 7453 (let (found-bad (p (point)))
6051 (setq last-nonmenu-event 13) ; To disable popup 7454 (setq last-nonmenu-event 13) ; To disable popup
6052 (with-no-warnings ; It is useful to push the mark here. 7455 (goto-char (point-min))
6053 (beginning-of-buffer))
6054 (map-y-or-n-p "Insert space here? " 7456 (map-y-or-n-p "Insert space here? "
6055 (lambda (arg) (insert " ")) 7457 (lambda (arg) (insert " "))
6056 'cperl-next-bad-style 7458 'cperl-next-bad-style
@@ -6446,7 +7848,7 @@ endservent
6446eof[([FILEHANDLE])] 7848eof[([FILEHANDLE])]
6447... eq ... String equality. 7849... eq ... String equality.
6448eval(EXPR) or eval { BLOCK } 7850eval(EXPR) or eval { BLOCK }
6449exec(LIST) 7851exec([TRUENAME] ARGV0, ARGVs) or exec(SHELL_COMMAND_LINE)
6450exit(EXPR) 7852exit(EXPR)
6451exp(EXPR) 7853exp(EXPR)
6452fcntl(FILEHANDLE,FUNCTION,SCALAR) 7854fcntl(FILEHANDLE,FUNCTION,SCALAR)
@@ -6582,7 +7984,7 @@ substr(EXPR,OFFSET[,LEN])
6582symlink(OLDFILE,NEWFILE) 7984symlink(OLDFILE,NEWFILE)
6583syscall(LIST) 7985syscall(LIST)
6584sysread(FILEHANDLE,SCALAR,LENGTH[,OFFSET]) 7986sysread(FILEHANDLE,SCALAR,LENGTH[,OFFSET])
6585system(LIST) 7987system([TRUENAME] ARGV0 [,ARGV]) or system(SHELL_COMMAND_LINE)
6586syswrite(FILEHANDLE,SCALAR,LENGTH[,OFFSET]) 7988syswrite(FILEHANDLE,SCALAR,LENGTH[,OFFSET])
6587tell[(FILEHANDLE)] 7989tell[(FILEHANDLE)]
6588telldir(DIRHANDLE) 7990telldir(DIRHANDLE)
@@ -6683,7 +8085,7 @@ prototype \\&SUB Returns prototype of the function given a reference.
6683 ;; b is before the starting delimiter, e before the ending 8085 ;; b is before the starting delimiter, e before the ending
6684 ;; e should be a marker, may be changed, but remains "correct". 8086 ;; e should be a marker, may be changed, but remains "correct".
6685 ;; EMBED is nil iff we process the whole REx. 8087 ;; EMBED is nil iff we process the whole REx.
6686 ;; The REx is guarantied to have //x 8088 ;; The REx is guaranteed to have //x
6687 ;; LEVEL shows how many levels deep to go 8089 ;; LEVEL shows how many levels deep to go
6688 ;; position at enter and at leave is not defined 8090 ;; position at enter and at leave is not defined
6689 (let (s c tmp (m (make-marker)) (m1 (make-marker)) c1 spaces inline code pos) 8091 (let (s c tmp (m (make-marker)) (m1 (make-marker)) c1 spaces inline code pos)
@@ -6712,7 +8114,7 @@ prototype \\&SUB Returns prototype of the function given a reference.
6712 (goto-char e) 8114 (goto-char e)
6713 (delete-horizontal-space) 8115 (delete-horizontal-space)
6714 (insert "\n") 8116 (insert "\n")
6715 (indent-to-column c) 8117 (cperl-make-indent c)
6716 (set-marker e (point)))) 8118 (set-marker e (point))))
6717 (goto-char b) 8119 (goto-char b)
6718 (end-of-line 2) 8120 (end-of-line 2)
@@ -6722,7 +8124,7 @@ prototype \\&SUB Returns prototype of the function given a reference.
6722 inline t) 8124 inline t)
6723 (skip-chars-forward " \t") 8125 (skip-chars-forward " \t")
6724 (delete-region s (point)) 8126 (delete-region s (point))
6725 (indent-to-column c1) 8127 (cperl-make-indent c1)
6726 (while (and 8128 (while (and
6727 inline 8129 inline
6728 (looking-at 8130 (looking-at
@@ -6748,6 +8150,16 @@ prototype \\&SUB Returns prototype of the function given a reference.
6748 (eq (preceding-char) ?\{))) 8150 (eq (preceding-char) ?\{)))
6749 (forward-char -1) 8151 (forward-char -1)
6750 (forward-sexp 1)) 8152 (forward-sexp 1))
8153 ((and ; [], already syntaxified
8154 (match-beginning 6)
8155 cperl-regexp-scan
8156 cperl-use-syntax-table-text-property)
8157 (forward-char -1)
8158 (forward-sexp 1)
8159 (or (eq (preceding-char) ?\])
8160 (error "[]-group not terminated"))
8161 (re-search-forward
8162 "\\=\\([*+?]\\|{[0-9]+\\(,[0-9]*\\)?}\\)\\??" e t))
6751 ((match-beginning 6) ; [] 8163 ((match-beginning 6) ; []
6752 (setq tmp (point)) 8164 (setq tmp (point))
6753 (if (looking-at "\\^?\\]") 8165 (if (looking-at "\\^?\\]")
@@ -6761,12 +8173,8 @@ prototype \\&SUB Returns prototype of the function given a reference.
6761 (setq pos t))) 8173 (setq pos t)))
6762 (or (eq (preceding-char) ?\]) 8174 (or (eq (preceding-char) ?\])
6763 (error "[]-group not terminated")) 8175 (error "[]-group not terminated"))
6764 (if (eq (following-char) ?\{) 8176 (re-search-forward
6765 (progn 8177 "\\=\\([*+?]\\|{[0-9]+\\(,[0-9]*\\)?}\\)\\??" e t))
6766 (forward-sexp 1)
6767 (and (eq (following-char) ??)
6768 (forward-char 1)))
6769 (re-search-forward "\\=\\([*+?]\\??\\)" e t)))
6770 ((match-beginning 7) ; () 8178 ((match-beginning 7) ; ()
6771 (goto-char (match-beginning 0)) 8179 (goto-char (match-beginning 0))
6772 (setq pos (current-column)) 8180 (setq pos (current-column))
@@ -6774,7 +8182,7 @@ prototype \\&SUB Returns prototype of the function given a reference.
6774 (progn 8182 (progn
6775 (delete-horizontal-space) 8183 (delete-horizontal-space)
6776 (insert "\n") 8184 (insert "\n")
6777 (indent-to-column c1))) 8185 (cperl-make-indent c1)))
6778 (setq tmp (point)) 8186 (setq tmp (point))
6779 (forward-sexp 1) 8187 (forward-sexp 1)
6780 ;; (or (forward-sexp 1) 8188 ;; (or (forward-sexp 1)
@@ -6834,7 +8242,7 @@ prototype \\&SUB Returns prototype of the function given a reference.
6834 (insert "\n")) 8242 (insert "\n"))
6835 ;; first at line 8243 ;; first at line
6836 (delete-region (point) tmp)) 8244 (delete-region (point) tmp))
6837 (indent-to-column c) 8245 (cperl-make-indent c)
6838 (forward-char 1) 8246 (forward-char 1)
6839 (skip-chars-forward " \t") 8247 (skip-chars-forward " \t")
6840 (setq spaces nil) 8248 (setq spaces nil)
@@ -6857,10 +8265,7 @@ prototype \\&SUB Returns prototype of the function given a reference.
6857 (/= (current-indentation) c)) 8265 (/= (current-indentation) c))
6858 (progn 8266 (progn
6859 (beginning-of-line) 8267 (beginning-of-line)
6860 (setq s (point)) 8268 (cperl-make-indent c)))))
6861 (skip-chars-forward " \t")
6862 (delete-region s (point))
6863 (indent-to-column c)))))
6864 8269
6865(defun cperl-make-regexp-x () 8270(defun cperl-make-regexp-x ()
6866 ;; Returns position of the start 8271 ;; Returns position of the start
@@ -6929,7 +8334,7 @@ We suppose that the regexp is scanned already."
6929 (interactive) 8334 (interactive)
6930 ;; (save-excursion ; Can't, breaks `cperl-contract-levels' 8335 ;; (save-excursion ; Can't, breaks `cperl-contract-levels'
6931 (cperl-regext-to-level-start) 8336 (cperl-regext-to-level-start)
6932 (let ((b (point)) (e (make-marker)) s c) 8337 (let ((b (point)) (e (make-marker)) c)
6933 (forward-sexp 1) 8338 (forward-sexp 1)
6934 (set-marker e (1- (point))) 8339 (set-marker e (1- (point)))
6935 (goto-char b) 8340 (goto-char b)
@@ -6938,10 +8343,7 @@ We suppose that the regexp is scanned already."
6938 ((match-beginning 1) ; #-comment 8343 ((match-beginning 1) ; #-comment
6939 (or c (setq c (current-indentation))) 8344 (or c (setq c (current-indentation)))
6940 (beginning-of-line 2) ; Skip 8345 (beginning-of-line 2) ; Skip
6941 (setq s (point)) 8346 (cperl-make-indent c))
6942 (skip-chars-forward " \t")
6943 (delete-region s (point))
6944 (indent-to-column c))
6945 (t 8347 (t
6946 (delete-char -1) 8348 (delete-char -1)
6947 (just-one-space)))))) 8349 (just-one-space))))))
@@ -6980,96 +8382,197 @@ We suppose that the regexp is scanned already."
6980 (set-marker e (1- (point))) 8382 (set-marker e (1- (point)))
6981 (cperl-beautify-regexp-piece b e nil deep)))) 8383 (cperl-beautify-regexp-piece b e nil deep))))
6982 8384
8385(defun cperl-invert-if-unless-modifiers ()
8386 "Change `B if A;' into `if (A) {B}' etc if possible.
8387\(Unfinished.)"
8388 (interactive) ;
8389 (let (A B pre-B post-B pre-if post-if pre-A post-A if-string
8390 (w-rex "\\<\\(if\\|unless\\|while\\|until\\|for\\|foreach\\)\\>"))
8391 (and (= (char-syntax (preceding-char)) ?w)
8392 (forward-sexp -1))
8393 (setq pre-if (point))
8394 (cperl-backward-to-start-of-expr)
8395 (setq pre-B (point))
8396 (forward-sexp 1) ; otherwise forward-to-end-of-expr is NOP
8397 (cperl-forward-to-end-of-expr)
8398 (setq post-A (point))
8399 (goto-char pre-if)
8400 (or (looking-at w-rex)
8401 ;; Find the position
8402 (progn (goto-char post-A)
8403 (while (and
8404 (not (looking-at w-rex))
8405 (> (point) pre-B))
8406 (forward-sexp -1))
8407 (setq pre-if (point))))
8408 (or (looking-at w-rex)
8409 (error "Can't find `if', `unless', `while', `until', `for' or `foreach'"))
8410 ;; 1 B 2 ... 3 B-com ... 4 if 5 ... if-com 6 ... 7 A 8
8411 (setq if-string (buffer-substring (match-beginning 0) (match-end 0)))
8412 ;; First, simple part: find code boundaries
8413 (forward-sexp 1)
8414 (setq post-if (point))
8415 (forward-sexp -2)
8416 (forward-sexp 1)
8417 (setq post-B (point))
8418 (cperl-backward-to-start-of-expr)
8419 (setq pre-B (point))
8420 (setq B (buffer-substring pre-B post-B))
8421 (goto-char pre-if)
8422 (forward-sexp 2)
8423 (forward-sexp -1)
8424 ;; May be after $, @, $# etc of a variable
8425 (skip-chars-backward "$@%#")
8426 (setq pre-A (point))
8427 (cperl-forward-to-end-of-expr)
8428 (setq post-A (point))
8429 (setq A (buffer-substring pre-A post-A))
8430 ;; Now modify (from end, to not break the stuff)
8431 (skip-chars-forward " \t;")
8432 (delete-region pre-A (point)) ; we move to pre-A
8433 (insert "\n" B ";\n}")
8434 (and (looking-at "[ \t]*#") (cperl-indent-for-comment))
8435 (delete-region pre-if post-if)
8436 (delete-region pre-B post-B)
8437 (goto-char pre-B)
8438 (insert if-string " (" A ") {")
8439 (setq post-B (point))
8440 (if (looking-at "[ \t]+$")
8441 (delete-horizontal-space)
8442 (if (looking-at "[ \t]*#")
8443 (cperl-indent-for-comment)
8444 (just-one-space)))
8445 (forward-line 1)
8446 (if (looking-at "[ \t]*$")
8447 (progn ; delete line
8448 (delete-horizontal-space)
8449 (delete-region (point) (1+ (point)))))
8450 (cperl-indent-line)
8451 (goto-char (1- post-B))
8452 (forward-sexp 1)
8453 (cperl-indent-line)
8454 (goto-char pre-B)))
8455
6983(defun cperl-invert-if-unless () 8456(defun cperl-invert-if-unless ()
6984 "Change `if (A) {B}' into `B if A;' etc if possible." 8457 "Change `if (A) {B}' into `B if A;' etc (or visa versa) if possible.
8458If the cursor is not on the leading keyword of the BLOCK flavor of
8459construct, will assume it is the STATEMENT flavor, so will try to find
8460the appropriate statement modifier."
6985 (interactive) 8461 (interactive)
6986 (or (looking-at "\\<") 8462 (and (= (char-syntax (preceding-char)) ?w)
6987 (forward-sexp -1)) 8463 (forward-sexp -1))
6988 (if (looking-at "\\<\\(if\\|unless\\|while\\|until\\|for\\|foreach\\)\\>") 8464 (if (looking-at "\\<\\(if\\|unless\\|while\\|until\\|for\\|foreach\\)\\>")
6989 (let ((pos1 (point)) 8465 (let ((pre-if (point))
6990 pos2 pos3 pos4 pos5 s1 s2 state p pos45 8466 pre-A post-A pre-B post-B A B state p end-B-code is-block B-comment
6991 (s0 (buffer-substring (match-beginning 0) (match-end 0)))) 8467 (if-string (buffer-substring (match-beginning 0) (match-end 0))))
6992 (forward-sexp 2) 8468 (forward-sexp 2)
6993 (setq pos3 (point)) 8469 (setq post-A (point))
6994 (forward-sexp -1) 8470 (forward-sexp -1)
6995 (setq pos2 (point)) 8471 (setq pre-A (point))
6996 (if (eq (following-char) ?\( ) 8472 (setq is-block (and (eq (following-char) ?\( )
8473 (save-excursion
8474 (condition-case nil
8475 (progn
8476 (forward-sexp 2)
8477 (forward-sexp -1)
8478 (eq (following-char) ?\{ ))
8479 (error nil)))))
8480 (if is-block
6997 (progn 8481 (progn
6998 (goto-char pos3) 8482 (goto-char post-A)
6999 (forward-sexp 1) 8483 (forward-sexp 1)
7000 (setq pos5 (point)) 8484 (setq post-B (point))
7001 (forward-sexp -1) 8485 (forward-sexp -1)
7002 (setq pos4 (point)) 8486 (setq pre-B (point))
7003 ;; XXXX In fact may be `A if (B); {C}' ...
7004 (if (and (eq (following-char) ?\{ ) 8487 (if (and (eq (following-char) ?\{ )
7005 (progn 8488 (progn
7006 (cperl-backward-to-noncomment pos3) 8489 (cperl-backward-to-noncomment post-A)
7007 (eq (preceding-char) ?\) ))) 8490 (eq (preceding-char) ?\) )))
7008 (if (condition-case nil 8491 (if (condition-case nil
7009 (progn 8492 (progn
7010 (goto-char pos5) 8493 (goto-char post-B)
7011 (forward-sexp 1) 8494 (forward-sexp 1)
7012 (forward-sexp -1) 8495 (forward-sexp -1)
7013 (looking-at "\\<els\\(e\\|if\\)\\>")) 8496 (looking-at "\\<els\\(e\\|if\\)\\>"))
7014 (error nil)) 8497 (error nil))
7015 (error 8498 (error
7016 "`%s' (EXPR) {BLOCK} with `else'/`elsif'" s0) 8499 "`%s' (EXPR) {BLOCK} with `else'/`elsif'" if-string)
7017 (goto-char (1- pos5)) 8500 (goto-char (1- post-B))
7018 (cperl-backward-to-noncomment pos4) 8501 (cperl-backward-to-noncomment pre-B)
7019 (if (eq (preceding-char) ?\;) 8502 (if (eq (preceding-char) ?\;)
7020 (forward-char -1)) 8503 (forward-char -1))
7021 (setq pos45 (point)) 8504 (setq end-B-code (point))
7022 (goto-char pos4) 8505 (goto-char pre-B)
7023 (while (re-search-forward "\\<\\(for\\|foreach\\|if\\|unless\\|while\\|until\\)\\>\\|;" pos45 t) 8506 (while (re-search-forward "\\<\\(for\\|foreach\\|if\\|unless\\|while\\|until\\)\\>\\|;" end-B-code t)
7024 (setq p (match-beginning 0) 8507 (setq p (match-beginning 0)
7025 s1 (buffer-substring p (match-end 0)) 8508 A (buffer-substring p (match-end 0))
7026 state (parse-partial-sexp pos4 p)) 8509 state (parse-partial-sexp pre-B p))
7027 (or (nth 3 state) 8510 (or (nth 3 state)
7028 (nth 4 state) 8511 (nth 4 state)
7029 (nth 5 state) 8512 (nth 5 state)
7030 (error "`%s' inside `%s' BLOCK" s1 s0)) 8513 (error "`%s' inside `%s' BLOCK" A if-string))
7031 (goto-char (match-end 0))) 8514 (goto-char (match-end 0)))
7032 ;; Finally got it 8515 ;; Finally got it
7033 (goto-char (1+ pos4)) 8516 (goto-char (1+ pre-B))
7034 (skip-chars-forward " \t\n") 8517 (skip-chars-forward " \t\n")
7035 (setq s2 (buffer-substring (point) pos45)) 8518 (setq B (buffer-substring (point) end-B-code))
7036 (goto-char pos45) 8519 (goto-char end-B-code)
7037 (or (looking-at ";?[ \t\n]*}") 8520 (or (looking-at ";?[ \t\n]*}")
7038 (progn 8521 (progn
7039 (skip-chars-forward "; \t\n") 8522 (skip-chars-forward "; \t\n")
7040 (setq s2 (concat s2 "\n" (buffer-substring (point) (1- pos5)))))) 8523 (setq B-comment
7041 (and (equal s2 "") 8524 (buffer-substring (point) (1- post-B)))))
7042 (setq s2 "1")) 8525 (and (equal B "")
7043 (goto-char (1- pos3)) 8526 (setq B "1"))
7044 (cperl-backward-to-noncomment pos2) 8527 (goto-char (1- post-A))
8528 (cperl-backward-to-noncomment pre-A)
7045 (or (looking-at "[ \t\n]*)") 8529 (or (looking-at "[ \t\n]*)")
7046 (goto-char (1- pos3))) 8530 (goto-char (1- post-A)))
7047 (setq p (point)) 8531 (setq p (point))
7048 (goto-char (1+ pos2)) 8532 (goto-char (1+ pre-A))
7049 (skip-chars-forward " \t\n") 8533 (skip-chars-forward " \t\n")
7050 (setq s1 (buffer-substring (point) p)) 8534 (setq A (buffer-substring (point) p))
7051 (delete-region pos4 pos5) 8535 (delete-region pre-B post-B)
7052 (delete-region pos2 pos3) 8536 (delete-region pre-A post-A)
7053 (goto-char pos1) 8537 (goto-char pre-if)
7054 (insert s2 " ") 8538 (insert B " ")
8539 (and B-comment (insert B-comment " "))
7055 (just-one-space) 8540 (just-one-space)
7056 (forward-word 1) 8541 (forward-word 1)
7057 (setq pos1 (point)) 8542 (setq pre-A (point))
7058 (insert " " s1 ";") 8543 (insert " " A ";")
7059 (delete-horizontal-space) 8544 (delete-horizontal-space)
8545 (setq post-B (point))
8546 (if (looking-at "#")
8547 (indent-for-comment))
8548 (goto-char post-B)
7060 (forward-char -1) 8549 (forward-char -1)
7061 (delete-horizontal-space) 8550 (delete-horizontal-space)
7062 (goto-char pos1) 8551 (goto-char pre-A)
7063 (just-one-space) 8552 (just-one-space)
7064 (cperl-indent-line)) 8553 (goto-char pre-if)
7065 (error "`%s' (EXPR) not with an {BLOCK}" s0))) 8554 (setq pre-A (set-marker (make-marker) pre-A))
7066 (error "`%s' not with an (EXPR)" s0))) 8555 (while (<= (point) (marker-position pre-A))
7067 (error "Not at `if', `unless', `while', `until', `for' or `foreach'"))) 8556 (cperl-indent-line)
8557 (forward-line 1))
8558 (goto-char (marker-position pre-A))
8559 (if B-comment
8560 (progn
8561 (forward-line -1)
8562 (indent-for-comment)
8563 (goto-char (marker-position pre-A)))))
8564 (error "`%s' (EXPR) not with an {BLOCK}" if-string)))
8565 ;; (error "`%s' not with an (EXPR)" if-string)
8566 (forward-sexp -1)
8567 (cperl-invert-if-unless-modifiers)))
8568 ;;(error "Not at `if', `unless', `while', `until', `for' or `foreach'")
8569 (cperl-invert-if-unless-modifiers)))
7068 8570
7069;;; By Anthony Foiani <afoiani@uswest.com> 8571;;; By Anthony Foiani <afoiani@uswest.com>
7070;;; Getting help on modules in C-h f ? 8572;;; Getting help on modules in C-h f ?
7071;;; This is a modified version of `man'. 8573;;; This is a modified version of `man'.
7072;;; Need to teach it how to lookup functions 8574;;; Need to teach it how to lookup functions
8575;;;###autoload
7073(defun cperl-perldoc (word) 8576(defun cperl-perldoc (word)
7074 "Run `perldoc' on WORD." 8577 "Run `perldoc' on WORD."
7075 (interactive 8578 (interactive
@@ -7101,6 +8604,7 @@ We suppose that the regexp is scanned already."
7101 (t 8604 (t
7102 (Man-getpage-in-background word))))) 8605 (Man-getpage-in-background word)))))
7103 8606
8607;;;###autoload
7104(defun cperl-perldoc-at-point () 8608(defun cperl-perldoc-at-point ()
7105 "Run a `perldoc' on the word around point." 8609 "Run a `perldoc' on the word around point."
7106 (interactive) 8610 (interactive)
@@ -7145,7 +8649,7 @@ We suppose that the regexp is scanned already."
7145(defun cperl-pod2man-build-command () 8649(defun cperl-pod2man-build-command ()
7146 "Builds the entire background manpage and cleaning command." 8650 "Builds the entire background manpage and cleaning command."
7147 (let ((command (concat pod2man-program " %s 2>/dev/null")) 8651 (let ((command (concat pod2man-program " %s 2>/dev/null"))
7148 (flist Man-filter-list)) 8652 (flist (and (boundp 'Man-filter-list) Man-filter-list)))
7149 (while (and flist (car flist)) 8653 (while (and flist (car flist))
7150 (let ((pcom (car (car flist))) 8654 (let ((pcom (car (car flist)))
7151 (pargs (cdr (car flist)))) 8655 (pargs (cdr (car flist))))
@@ -7159,6 +8663,205 @@ We suppose that the regexp is scanned already."
7159 (setq flist (cdr flist)))) 8663 (setq flist (cdr flist))))
7160 command)) 8664 command))
7161 8665
8666
8667(defun cperl-next-interpolated-REx-1 ()
8668 "Move point to next REx which has interpolated parts without //o.
8669Skips RExes consisting of one interpolated variable.
8670
8671Note that skipped RExen are not performance hits."
8672 (interactive "")
8673 (cperl-next-interpolated-REx 1))
8674
8675(defun cperl-next-interpolated-REx-0 ()
8676 "Move point to next REx which has interpolated parts without //o."
8677 (interactive "")
8678 (cperl-next-interpolated-REx 0))
8679
8680(defun cperl-next-interpolated-REx (&optional skip beg limit)
8681 "Move point to next REx which has interpolated parts.
8682SKIP is a list of possible types to skip, BEG and LIMIT are the starting
8683point and the limit of search (default to point and end of buffer).
8684
8685SKIP may be a number, then it behaves as list of numbers up to SKIP; this
8686semantic may be used as a numeric argument.
8687
8688Types are 0 for / $rex /o (interpolated once), 1 for /$rex/ (if $rex is
8689a result of qr//, this is not a performance hit), t for the rest."
8690 (interactive "P")
8691 (if (numberp skip) (setq skip (list 0 skip)))
8692 (or beg (setq beg (point)))
8693 (or limit (setq limit (point-max))) ; needed for n-s-p-c
8694 (let (pp)
8695 (and (eq (get-text-property beg 'syntax-type) 'string)
8696 (setq beg (next-single-property-change beg 'syntax-type nil limit)))
8697 (cperl-map-pods-heres
8698 (function (lambda (s e p)
8699 (if (memq (get-text-property s 'REx-interpolated) skip)
8700 t
8701 (setq pp s)
8702 nil))) ; nil stops
8703 'REx-interpolated beg limit)
8704 (if pp (goto-char pp)
8705 (message "No more interpolated REx"))))
8706
8707;;; Initial version contributed by Trey Belew
8708(defun cperl-here-doc-spell (&optional beg end)
8709 "Spell-check HERE-documents in the Perl buffer.
8710If a region is highlighted, restricts to the region."
8711 (interactive "")
8712 (cperl-pod-spell t beg end))
8713
8714(defun cperl-pod-spell (&optional do-heres beg end)
8715 "Spell-check POD documentation.
8716If invoked with prefix argument, will do HERE-DOCs instead.
8717If a region is highlighted, restricts to the region."
8718 (interactive "P")
8719 (save-excursion
8720 (let (beg end)
8721 (if (cperl-mark-active)
8722 (setq beg (min (mark) (point))
8723 end (max (mark) (point)))
8724 (setq beg (point-min)
8725 end (point-max)))
8726 (cperl-map-pods-heres (function
8727 (lambda (s e p)
8728 (if do-heres
8729 (setq e (save-excursion
8730 (goto-char e)
8731 (forward-line -1)
8732 (point))))
8733 (ispell-region s e)
8734 t))
8735 (if do-heres 'here-doc-group 'in-pod)
8736 beg end))))
8737
8738(defun cperl-map-pods-heres (func &optional prop s end)
8739 "Executes a function over regions of pods or here-documents.
8740PROP is the text-property to search for; default to `in-pod'. Stop when
8741function returns nil."
8742 (let (pos posend has-prop (cont t))
8743 (or prop (setq prop 'in-pod))
8744 (or s (setq s (point-min)))
8745 (or end (setq end (point-max)))
8746 (cperl-update-syntaxification end end)
8747 (save-excursion
8748 (goto-char (setq pos s))
8749 (while (and cont (< pos end))
8750 (setq has-prop (get-text-property pos prop))
8751 (setq posend (next-single-property-change pos prop nil end))
8752 (and has-prop
8753 (setq cont (funcall func pos posend prop)))
8754 (setq pos posend)))))
8755
8756;;; Based on code by Masatake YAMATO:
8757(defun cperl-get-here-doc-region (&optional pos pod)
8758 "Return HERE document region around the point.
8759Return nil if the point is not in a HERE document region. If POD is non-nil,
8760will return a POD section if point is in a POD section."
8761 (or pos (setq pos (point)))
8762 (cperl-update-syntaxification pos pos)
8763 (if (or (eq 'here-doc (get-text-property pos 'syntax-type))
8764 (and pod
8765 (eq 'pod (get-text-property pos 'syntax-type))))
8766 (let ((b (cperl-beginning-of-property pos 'syntax-type))
8767 (e (next-single-property-change pos 'syntax-type)))
8768 (cons b (or e (point-max))))))
8769
8770(defun cperl-narrow-to-here-doc (&optional pos)
8771 "Narrows editing region to the HERE-DOC at POS.
8772POS defaults to the point."
8773 (interactive "d")
8774 (or pos (setq pos (point)))
8775 (let ((p (cperl-get-here-doc-region pos)))
8776 (or p (error "Not inside a HERE document"))
8777 (narrow-to-region (car p) (cdr p))
8778 (message
8779 "When you are finished with narrow editing, type C-x n w")))
8780
8781(defun cperl-select-this-pod-or-here-doc (&optional pos)
8782 "Select the HERE-DOC (or POD section) at POS.
8783POS defaults to the point."
8784 (interactive "d")
8785 (let ((p (cperl-get-here-doc-region pos t)))
8786 (if p
8787 (progn
8788 (goto-char (car p))
8789 (push-mark (cdr p) nil t)) ; Message, activate in transient-mode
8790 (message "I do not think POS is in POD or a HERE-doc..."))))
8791
8792(defun cperl-facemenu-add-face-function (face end)
8793 "A callback to process user-initiated font-change requests.
8794Translates `bold', `italic', and `bold-italic' requests to insertion of
8795corresponding POD directives, and `underline' to C<> POD directive.
8796
8797Such requests are usually bound to M-o LETTER."
8798 (or (get-text-property (point) 'in-pod)
8799 (error "Faces can only be set within POD"))
8800 (setq facemenu-end-add-face (if (eq face 'bold-italic) ">>" ">"))
8801 (cdr (or (assq face '((bold . "B<")
8802 (italic . "I<")
8803 (bold-italic . "B<I<")
8804 (underline . "C<")))
8805 (error "Face %s not configured for cperl-mode"
8806 face))))
8807
8808(defun cperl-time-fontification (&optional l step lim)
8809 "Times how long it takes to do incremental fontification in a region.
8810L is the line to start at, STEP is the number of lines to skip when
8811doing next incremental fontification, LIM is the maximal number of
8812incremental fontification to perform. Messages are accumulated in
8813*Messages* buffer.
8814
8815May be used for pinpointing which construct slows down buffer fontification:
8816start with default arguments, then refine the slowdown regions."
8817 (interactive "nLine to start at: \nnStep to do incremental fontification: ")
8818 (or l (setq l 1))
8819 (or step (setq step 500))
8820 (or lim (setq lim 40))
8821 (let* ((timems (function (lambda ()
8822 (let ((tt (current-time)))
8823 (+ (* 1000 (nth 1 tt)) (/ (nth 2 tt) 1000))))))
8824 (tt (funcall timems)) (c 0) delta tot)
8825 (goto-line l)
8826 (cperl-mode)
8827 (setq tot (- (- tt (setq tt (funcall timems)))))
8828 (message "cperl-mode at %s: %s" l tot)
8829 (while (and (< c lim) (not (eobp)))
8830 (forward-line step)
8831 (setq l (+ l step))
8832 (setq c (1+ c))
8833 (cperl-update-syntaxification (point) (point))
8834 (setq delta (- (- tt (setq tt (funcall timems)))) tot (+ tot delta))
8835 (message "to %s:%6s,%7s" l delta tot))
8836 tot))
8837
8838(defun cperl-emulate-lazy-lock (&optional window-size)
8839 "Emulate `lazy-lock' without `condition-case', so `debug-on-error' works.
8840Start fontifying the buffer from the start (or end) using the given
8841WINDOW-SIZE (units is lines). Negative WINDOW-SIZE starts at end, and
8842goes backwards; default is -50. This function is not CPerl-specific; it
8843may be used to debug problems with delayed incremental fontification."
8844 (interactive
8845 "nSize of window for incremental fontification, negative goes backwards: ")
8846 (or window-size (setq window-size -50))
8847 (let ((pos (if (> window-size 0)
8848 (point-min)
8849 (point-max)))
8850 p)
8851 (goto-char pos)
8852 (normal-mode)
8853 ;; Why needed??? With older font-locks???
8854 (set (make-local-variable 'font-lock-cache-position) (make-marker))
8855 (while (if (> window-size 0)
8856 (< pos (point-max))
8857 (> pos (point-min)))
8858 (setq p (progn
8859 (forward-line window-size)
8860 (point)))
8861 (font-lock-fontify-region (min p pos) (max p pos))
8862 (setq pos p))))
8863
8864
7162(defun cperl-lazy-install ()) ; Avoid a warning 8865(defun cperl-lazy-install ()) ; Avoid a warning
7163(defun cperl-lazy-unstall ()) ; Avoid a warning 8866(defun cperl-lazy-unstall ()) ; Avoid a warning
7164 8867
@@ -7174,7 +8877,7 @@ We suppose that the regexp is scanned already."
7174 "Switches on Auto-Help on Perl constructs (put in the message area). 8877 "Switches on Auto-Help on Perl constructs (put in the message area).
7175Delay of auto-help controlled by `cperl-lazy-help-time'." 8878Delay of auto-help controlled by `cperl-lazy-help-time'."
7176 (interactive) 8879 (interactive)
7177 (make-variable-buffer-local 'cperl-help-shown) 8880 (make-local-variable 'cperl-help-shown)
7178 (if (and (cperl-val 'cperl-lazy-help-time) 8881 (if (and (cperl-val 'cperl-lazy-help-time)
7179 (not cperl-lazy-installed)) 8882 (not cperl-lazy-installed))
7180 (progn 8883 (progn
@@ -7207,48 +8910,109 @@ Delay of auto-help controlled by `cperl-lazy-help-time'."
7207;;; Plug for wrong font-lock: 8910;;; Plug for wrong font-lock:
7208 8911
7209(defun cperl-font-lock-unfontify-region-function (beg end) 8912(defun cperl-font-lock-unfontify-region-function (beg end)
7210 ;; Simplified now that font-lock-unfontify-region uses save-buffer-state. 8913 (let* ((modified (buffer-modified-p)) (buffer-undo-list t)
7211 (let (before-change-functions after-change-functions) 8914 (inhibit-read-only t) (inhibit-point-motion-hooks t)
7212 (remove-text-properties beg end '(face nil)))) 8915 before-change-functions after-change-functions
8916 deactivate-mark buffer-file-name buffer-file-truename)
8917 (remove-text-properties beg end '(face nil))
8918 (if (and (not modified) (buffer-modified-p))
8919 (set-buffer-modified-p nil))))
8920
8921(defun cperl-font-lock-fontify-region-function (beg end loudly)
8922 "Extends the region to safe positions, then calls the default function.
8923Newer `font-lock's can do it themselves.
8924We unwind only as far as needed for fontification. Syntaxification may
8925do extra unwind via `cperl-unwind-to-safe'."
8926 (save-excursion
8927 (goto-char beg)
8928 (while (and beg
8929 (progn
8930 (beginning-of-line)
8931 (eq (get-text-property (setq beg (point)) 'syntax-type)
8932 'multiline)))
8933 (if (setq beg (cperl-beginning-of-property beg 'syntax-type))
8934 (goto-char beg)))
8935 (setq beg (point))
8936 (goto-char end)
8937 (while (and end
8938 (progn
8939 (or (bolp) (condition-case nil
8940 (forward-line 1)
8941 (error nil)))
8942 (eq (get-text-property (setq end (point)) 'syntax-type)
8943 'multiline)))
8944 (setq end (next-single-property-change end 'syntax-type nil (point-max)))
8945 (goto-char end))
8946 (setq end (point)))
8947 (font-lock-default-fontify-region beg end loudly))
7213 8948
7214(defvar cperl-d-l nil) 8949(defvar cperl-d-l nil)
7215(defun cperl-fontify-syntaxically (end) 8950(defun cperl-fontify-syntaxically (end)
7216 ;; Some vars for debugging only 8951 ;; Some vars for debugging only
7217 ;; (message "Syntaxifying...") 8952 ;; (message "Syntaxifying...")
7218 (let ((dbg (point)) (iend end) 8953 (let ((dbg (point)) (iend end) (idone cperl-syntax-done-to)
7219 (istate (car cperl-syntax-state)) 8954 (istate (car cperl-syntax-state))
7220 start) 8955 start from-start edebug-backtrace-buffer)
7221 (and cperl-syntaxify-unwind 8956 (if (eq cperl-syntaxify-by-font-lock 'backtrace)
7222 (setq end (cperl-unwind-to-safe t end))) 8957 (progn
7223 (setq start (point)) 8958 (require 'edebug)
8959 (let ((f 'edebug-backtrace))
8960 (funcall f)))) ; Avoid compile-time warning
7224 (or cperl-syntax-done-to 8961 (or cperl-syntax-done-to
7225 (setq cperl-syntax-done-to (point-min))) 8962 (setq cperl-syntax-done-to (point-min)
7226 (if (or (not (boundp 'font-lock-hot-pass)) 8963 from-start t))
7227 (eval 'font-lock-hot-pass) 8964 (setq start (if (and cperl-hook-after-change
7228 t) ; Not debugged otherwise 8965 (not from-start))
7229 ;; Need to forget what is after `start' 8966 cperl-syntax-done-to ; Fontify without change; ignore start
7230 (setq start (min cperl-syntax-done-to start)) 8967 ;; Need to forget what is after `start'
7231 ;; Fontification without a change 8968 (min cperl-syntax-done-to (point))))
7232 (setq start (max cperl-syntax-done-to start))) 8969 (goto-char start)
8970 (beginning-of-line)
8971 (setq start (point))
8972 (and cperl-syntaxify-unwind
8973 (setq end (cperl-unwind-to-safe t end)
8974 start (point)))
7233 (and (> end start) 8975 (and (> end start)
7234 (setq cperl-syntax-done-to start) ; In case what follows fails 8976 (setq cperl-syntax-done-to start) ; In case what follows fails
7235 (cperl-find-pods-heres start end t nil t)) 8977 (cperl-find-pods-heres start end t nil t))
7236 (if (eq cperl-syntaxify-by-font-lock 'message) 8978 (if (memq cperl-syntaxify-by-font-lock '(backtrace message))
7237 (message "Syntaxified %s..%s from %s to %s(%s), state %s-->%s" 8979 (message "Syxify req=%s..%s actual=%s..%s done-to: %s=>%s statepos: %s=>%s"
7238 dbg iend 8980 dbg iend start end idone cperl-syntax-done-to
7239 start end cperl-syntax-done-to
7240 istate (car cperl-syntax-state))) ; For debugging 8981 istate (car cperl-syntax-state))) ; For debugging
7241 nil)) ; Do not iterate 8982 nil)) ; Do not iterate
7242 8983
7243(defun cperl-fontify-update (end) 8984(defun cperl-fontify-update (end)
7244 (let ((pos (point)) prop posend) 8985 (let ((pos (point-min)) prop posend)
8986 (setq end (point-max))
7245 (while (< pos end) 8987 (while (< pos end)
7246 (setq prop (get-text-property pos 'cperl-postpone)) 8988 (setq prop (get-text-property pos 'cperl-postpone)
7247 (setq posend (next-single-property-change pos 'cperl-postpone nil end)) 8989 posend (next-single-property-change pos 'cperl-postpone nil end))
7248 (and prop (put-text-property pos posend (car prop) (cdr prop))) 8990 (and prop (put-text-property pos posend (car prop) (cdr prop)))
7249 (setq pos posend))) 8991 (setq pos posend)))
7250 nil) ; Do not iterate 8992 nil) ; Do not iterate
7251 8993
8994(defun cperl-fontify-update-bad (end)
8995 ;; Since fontification happens with different region than syntaxification,
8996 ;; do to the end of buffer, not to END;;; likewise, start earlier if needed
8997 (let* ((pos (point)) (prop (get-text-property pos 'cperl-postpone)) posend)
8998 (if prop
8999 (setq pos (or (cperl-beginning-of-property
9000 (cperl-1+ pos) 'cperl-postpone)
9001 (point-min))))
9002 (while (< pos end)
9003 (setq posend (next-single-property-change pos 'cperl-postpone))
9004 (and prop (put-text-property pos posend (car prop) (cdr prop)))
9005 (setq pos posend)
9006 (setq prop (get-text-property pos 'cperl-postpone))))
9007 nil) ; Do not iterate
9008
9009;; Called when any modification is made to buffer text.
9010(defun cperl-after-change-function (beg end old-len)
9011 ;; We should have been informed about changes by `font-lock'. Since it
9012 ;; does not inform as which calls are defered, do it ourselves
9013 (if cperl-syntax-done-to
9014 (setq cperl-syntax-done-to (min cperl-syntax-done-to beg))))
9015
7252(defun cperl-update-syntaxification (from to) 9016(defun cperl-update-syntaxification (from to)
7253 (if (and cperl-use-syntax-table-text-property 9017 (if (and cperl-use-syntax-table-text-property
7254 cperl-syntaxify-by-font-lock 9018 cperl-syntaxify-by-font-lock
@@ -7260,7 +9024,7 @@ Delay of auto-help controlled by `cperl-lazy-help-time'."
7260 (cperl-fontify-syntaxically to))))) 9024 (cperl-fontify-syntaxically to)))))
7261 9025
7262(defvar cperl-version 9026(defvar cperl-version
7263 (let ((v "Revision: 5.0")) 9027 (let ((v "Revision: 5.22"))
7264 (string-match ":\\s *\\([0-9.]+\\)" v) 9028 (string-match ":\\s *\\([0-9.]+\\)" v)
7265 (substring v (match-beginning 1) (match-end 1))) 9029 (substring v (match-beginning 1) (match-end 1)))
7266 "Version of IZ-supported CPerl package this file is based on.") 9030 "Version of IZ-supported CPerl package this file is based on.")
diff --git a/lisp/progmodes/ebnf2ps.el b/lisp/progmodes/ebnf2ps.el
index bce4381c614..9f27c8a60f1 100644
--- a/lisp/progmodes/ebnf2ps.el
+++ b/lisp/progmodes/ebnf2ps.el
@@ -5,10 +5,10 @@
5 5
6;; Author: Vinicius Jose Latorre <viniciusjl@ig.com.br> 6;; Author: Vinicius Jose Latorre <viniciusjl@ig.com.br>
7;; Maintainer: Vinicius Jose Latorre <viniciusjl@ig.com.br> 7;; Maintainer: Vinicius Jose Latorre <viniciusjl@ig.com.br>
8;; Time-stamp: <2005-09-18 07:27:20 deego> 8;; Time-stamp: <2006/09/26 21:49:46 vinicius>
9;; Keywords: wp, ebnf, PostScript 9;; Keywords: wp, ebnf, PostScript
10;; Version: 4.2 10;; Version: 4.3
11;; X-URL: http://www.cpqd.com.br/~vinicius/emacs/ 11;; X-URL: http://www.emacswiki.org/cgi-bin/wiki/ViniciusJoseLatorre
12 12
13;; This file is part of GNU Emacs. 13;; This file is part of GNU Emacs.
14 14
@@ -27,8 +27,8 @@
27;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, 27;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
28;; Boston, MA 02110-1301, USA. 28;; Boston, MA 02110-1301, USA.
29 29
30(defconst ebnf-version "4.2" 30(defconst ebnf-version "4.3"
31 "ebnf2ps.el, v 4.2 <2004/04/04 vinicius> 31 "ebnf2ps.el, v 4.3 <2006/09/26 vinicius>
32 32
33Vinicius's last change version. When reporting bugs, please also 33Vinicius's last change version. When reporting bugs, please also
34report the version of Emacs, if any, that ebnf2ps was running with. 34report the version of Emacs, if any, that ebnf2ps was running with.
@@ -73,18 +73,18 @@ Please send all bug fixes and enhancements to
73;; ebnf2ps provides the following commands for generating PostScript syntactic 73;; ebnf2ps provides the following commands for generating PostScript syntactic
74;; chart images of Emacs buffers: 74;; chart images of Emacs buffers:
75;; 75;;
76;; ebnf-print-directory 76;; ebnf-print-directory
77;; ebnf-print-file 77;; ebnf-print-file
78;; ebnf-print-buffer 78;; ebnf-print-buffer
79;; ebnf-print-region 79;; ebnf-print-region
80;; ebnf-spool-directory 80;; ebnf-spool-directory
81;; ebnf-spool-file 81;; ebnf-spool-file
82;; ebnf-spool-buffer 82;; ebnf-spool-buffer
83;; ebnf-spool-region 83;; ebnf-spool-region
84;; ebnf-eps-directory 84;; ebnf-eps-directory
85;; ebnf-eps-file 85;; ebnf-eps-file
86;; ebnf-eps-buffer 86;; ebnf-eps-buffer
87;; ebnf-eps-region 87;; ebnf-eps-region
88;; 88;;
89;; These commands all perform essentially the same function: they generate 89;; These commands all perform essentially the same function: they generate
90;; PostScript syntactic chart images suitable for printing on a PostScript 90;; PostScript syntactic chart images suitable for printing on a PostScript
@@ -94,14 +94,14 @@ Please send all bug fixes and enhancements to
94;; The word "print", "spool" and "eps" in the command name determines when the 94;; The word "print", "spool" and "eps" in the command name determines when the
95;; PostScript image is sent to the printer (or file): 95;; PostScript image is sent to the printer (or file):
96;; 96;;
97;; print - The PostScript image is immediately sent to the printer; 97;; print - The PostScript image is immediately sent to the printer;
98;; 98;;
99;; spool - The PostScript image is saved temporarily in an Emacs buffer. 99;; spool - The PostScript image is saved temporarily in an Emacs buffer.
100;; Many images may be spooled locally before printing them. To 100;; Many images may be spooled locally before printing them. To
101;; send the spooled images to the printer, use the command 101;; send the spooled images to the printer, use the command
102;; `ebnf-despool'. 102;; `ebnf-despool'.
103;; 103;;
104;; eps - The PostScript image is immediately sent to a EPS file. 104;; eps - The PostScript image is immediately sent to a EPS file.
105;; 105;;
106;; The spooling mechanism is the same as used by ps-print and was designed for 106;; The spooling mechanism is the same as used by ps-print and was designed for
107;; printing lots of small files to save paper that would otherwise be wasted on 107;; printing lots of small files to save paper that would otherwise be wasted on
@@ -120,22 +120,22 @@ Please send all bug fixes and enhancements to
120;; The word "directory", "file", "buffer" or "region" in the command name 120;; The word "directory", "file", "buffer" or "region" in the command name
121;; determines how much of the buffer is printed: 121;; determines how much of the buffer is printed:
122;; 122;;
123;; directory - Read files in the directory and print them. 123;; directory - Read files in the directory and print them.
124;; 124;;
125;; file - Read file and print it. 125;; file - Read file and print it.
126;; 126;;
127;; buffer - Print the entire buffer. 127;; buffer - Print the entire buffer.
128;; 128;;
129;; region - Print just the current region. 129;; region - Print just the current region.
130;; 130;;
131;; Two ebnf- command examples: 131;; Two ebnf- command examples:
132;; 132;;
133;; ebnf-print-buffer - translate and print the entire buffer, and send it 133;; ebnf-print-buffer - translate and print the entire buffer, and send it
134;; immediately to the printer. 134;; immediately to the printer.
135;; 135;;
136;; ebnf-spool-region - translate and print just the current region, and 136;; ebnf-spool-region - translate and print just the current region, and
137;; spool the image in Emacs to send to the printer 137;; spool the image in Emacs to send to the printer
138;; later. 138;; later.
139;; 139;;
140;; Note that `ebnf-eps-directory', `ebnf-eps-file', `ebnf-eps-buffer' and 140;; Note that `ebnf-eps-directory', `ebnf-eps-file', `ebnf-eps-buffer' and
141;; `ebnf-eps-region' never spool the EPS image, so they don't use the ps-print 141;; `ebnf-eps-region' never spool the EPS image, so they don't use the ps-print
@@ -148,13 +148,13 @@ Please send all bug fixes and enhancements to
148;; 148;;
149;; To translate and print your buffer, type 149;; To translate and print your buffer, type
150;; 150;;
151;; M-x ebnf-print-buffer 151;; M-x ebnf-print-buffer
152;; 152;;
153;; or substitute one of the other four ebnf- commands. The command will 153;; or substitute one of the other four ebnf- commands. The command will
154;; generate the PostScript image and print or spool it as specified. By giving 154;; generate the PostScript image and print or spool it as specified. By giving
155;; the command a prefix argument 155;; the command a prefix argument
156;; 156;;
157;; C-u M-x ebnf-print-buffer 157;; C-u M-x ebnf-print-buffer
158;; 158;;
159;; it will save the PostScript image to a file instead of sending it to the 159;; it will save the PostScript image to a file instead of sending it to the
160;; printer; you will be prompted for the name of the file to save the image to. 160;; printer; you will be prompted for the name of the file to save the image to.
@@ -162,7 +162,7 @@ Please send all bug fixes and enhancements to
162;; you may save the spooled images to a file by giving a prefix argument to 162;; you may save the spooled images to a file by giving a prefix argument to
163;; `ebnf-despool': 163;; `ebnf-despool':
164;; 164;;
165;; C-u M-x ebnf-despool 165;; C-u M-x ebnf-despool
166;; 166;;
167;; When invoked this way, `ebnf-despool' will prompt you for the name of the 167;; When invoked this way, `ebnf-despool' will prompt you for the name of the
168;; file to save to. 168;; file to save to.
@@ -172,9 +172,9 @@ Please send all bug fixes and enhancements to
172;; 172;;
173;; Any of the `ebnf-' commands can be bound to keys. Here are some examples: 173;; Any of the `ebnf-' commands can be bound to keys. Here are some examples:
174;; 174;;
175;; (global-set-key 'f22 'ebnf-print-buffer) ;f22 is prsc 175;; (global-set-key 'f22 'ebnf-print-buffer) ;f22 is prsc
176;; (global-set-key '(shift f22) 'ebnf-print-region) 176;; (global-set-key '(shift f22) 'ebnf-print-region)
177;; (global-set-key '(control f22) 'ebnf-despool) 177;; (global-set-key '(control f22) 'ebnf-despool)
178;; 178;;
179;; 179;;
180;; Invoking Ebnf2ps in Batch 180;; Invoking Ebnf2ps in Batch
@@ -523,14 +523,14 @@ Please send all bug fixes and enhancements to
523;; 523;;
524;; The following table summarizes the results: 524;; The following table summarizes the results:
525;; 525;;
526;; EPS FILE NAME NO SORT ASCENDING SORT DESCENDING SORT 526;; EPS FILE NAME NO SORT ASCENDING SORT DESCENDING SORT
527;; ebnf--AA.eps A C A C C A 527;; ebnf--AA.eps A C A C C A
528;; ebnf--BB.eps C B B C C B 528;; ebnf--BB.eps C B B C C B
529;; ebnf--CC.eps A C B F A B C F F C B A 529;; ebnf--CC.eps A C B F A B C F F C B A
530;; ebnf--D.eps D D D 530;; ebnf--D.eps D D D
531;; ebnf--E.eps E E E 531;; ebnf--E.eps E E E
532;; ebnf--G.eps G G G 532;; ebnf--G.eps G G G
533;; ebnf--Z.eps Z Z Z 533;; ebnf--Z.eps Z Z Z
534;; 534;;
535;; As you can see if EPS actions is not used, each single production is 535;; As you can see if EPS actions is not used, each single production is
536;; generated per EPS file. To avoid overriding EPS files, use names in ;[ that 536;; generated per EPS file. To avoid overriding EPS files, use names in ;[ that
@@ -692,6 +692,11 @@ Please send all bug fixes and enhancements to
692;; 692;;
693;; `ebnf-line-color' Specify flow line color. 693;; `ebnf-line-color' Specify flow line color.
694;; 694;;
695;; `ebnf-arrow-extra-width' Specify extra width for arrow shape
696;; drawing.
697;;
698;; `ebnf-arrow-scale' Specify the arrow scale.
699;;
695;; `ebnf-user-arrow' Specify a sexp for user arrow shape (a 700;; `ebnf-user-arrow' Specify a sexp for user arrow shape (a
696;; PostScript code). 701;; PostScript code).
697;; 702;;
@@ -824,6 +829,8 @@ Please send all bug fixes and enhancements to
824;; entry is the vertical position used to know where it should 829;; entry is the vertical position used to know where it should
825;; be drawn the flow line in the current element. 830;; be drawn the flow line in the current element.
826;; 831;;
832;; extra is given by `ebnf-arrow-extra-width'.
833;;
827;; 834;;
828;; * SPECIAL, TERMINAL and NON-TERMINAL 835;; * SPECIAL, TERMINAL and NON-TERMINAL
829;; 836;;
@@ -835,17 +842,17 @@ Please send all bug fixes and enhancements to
835;; : | : : | : } font height / 2 } 842;; : | : : | : } font height / 2 }
836;; : +==============+...:............................... 843;; : +==============+...:...............................
837;; : : : : : : 844;; : : : : : :
838;; : : : : : :...................... 845;; : : : : : :.........................
839;; : : : : : } font height } 846;; : : : : : } font height }
840;; : : : : :....... } 847;; : : : : :....... }
841;; : : : : } font height / 2 } 848;; : : : : } font height / 2 }
842;; : : : :........... } 849;; : : : :........... }
843;; : : : } text width } width 850;; : : : } text width } width
844;; : : :.................. } 851;; : : :.................. }
845;; : : } font height / 2 } 852;; : : } font height / 2 }
846;; : :...................... } 853;; : :...................... }
847;; : } font height } 854;; : } font height + extra }
848;; :............................................. 855;; :.................................................
849;; 856;;
850;; 857;;
851;; * OPTIONAL 858;; * OPTIONAL
@@ -976,21 +983,21 @@ Please send all bug fixes and enhancements to
976;; : | : : : : | : } font height / 2 } 983;; : | : : : : | : } font height / 2 }
977;; : +================+...:............................... 984;; : +================+...:...............................
978;; : : : : : : : : 985;; : : : : : : : :
979;; : : : : : : : :...................... 986;; : : : : : : : :..........................
980;; : : : : : : : } font height } 987;; : : : : : : : } font height }
981;; : : : : : : :....... } 988;; : : : : : : :....... }
982;; : : : : : : } font height / 2 } 989;; : : : : : : } font height / 2 }
983;; : : : : : :........... } 990;; : : : : : :........... }
984;; : : : : : } X width } 991;; : : : : : } X width }
985;; : : : : :............... } 992;; : : : : :............... }
986;; : : : : } font height / 2 } width 993;; : : : : } font height / 2 } width
987;; : : : :.................. } 994;; : : : :.................. }
988;; : : : } text width } 995;; : : : } text width }
989;; : : :..................... } 996;; : : :..................... }
990;; : : } font height / 2 } 997;; : : } font height / 2 }
991;; : :........................ } 998;; : :........................ }
992;; : } font height } 999;; : } font height + extra }
993;; :............................................... 1000;; :...................................................
994;; 1001;;
995;; 1002;;
996;; * EXCEPT 1003;; * EXCEPT
@@ -1003,21 +1010,21 @@ Please send all bug fixes and enhancements to
1003;; : | : : : : | : } font height / 2 } 1010;; : | : : : : | : } font height / 2 }
1004;; : +==================+...:............................... 1011;; : +==================+...:...............................
1005;; : : : : : : : : 1012;; : : : : : : : :
1006;; : : : : : : : :...................... 1013;; : : : : : : : :..........................
1007;; : : : : : : : } font height } 1014;; : : : : : : : } font height }
1008;; : : : : : : :....... } 1015;; : : : : : : :....... }
1009;; : : : : : : } font height / 2 } 1016;; : : : : : : } font height / 2 }
1010;; : : : : : :........... } 1017;; : : : : : :........... }
1011;; : : : : : } Y width } 1018;; : : : : : } Y width }
1012;; : : : : :............... } 1019;; : : : : :............... }
1013;; : : : : } font height } width 1020;; : : : : } font height } width
1014;; : : : :................... } 1021;; : : : :................... }
1015;; : : : } X width } 1022;; : : : } X width }
1016;; : : :....................... } 1023;; : : :....................... }
1017;; : : } font height / 2 } 1024;; : : } font height / 2 }
1018;; : :.......................... } 1025;; : :.......................... }
1019;; : } font height } 1026;; : } font height + extra }
1020;; :................................................. 1027;; :.....................................................
1021;; 1028;;
1022;; NOTE: If Y element is empty, it's draw nothing at Y place. 1029;; NOTE: If Y element is empty, it's draw nothing at Y place.
1023;; 1030;;
@@ -1089,7 +1096,8 @@ Please send all bug fixes and enhancements to
1089;; ---------------- 1096;; ----------------
1090;; 1097;;
1091;; Thanks to Drew Adams <drew.adams@oracle.com> for suggestions: 1098;; Thanks to Drew Adams <drew.adams@oracle.com> for suggestions:
1092;; - `ebnf-production-name-p', `ebnf-stop-on-error', 1099;; - `ebnf-arrow-extra-width', `ebnf-arrow-scale',
1100;; `ebnf-production-name-p', `ebnf-stop-on-error',
1093;; `ebnf-file-suffix-regexp'and `ebnf-special-show-delimiter' variables. 1101;; `ebnf-file-suffix-regexp'and `ebnf-special-show-delimiter' variables.
1094;; - `ebnf-delete-style', `ebnf-eps-file' and `ebnf-eps-directory' 1102;; - `ebnf-delete-style', `ebnf-eps-file' and `ebnf-eps-directory'
1095;; commands. 1103;; commands.
@@ -1911,6 +1919,29 @@ special."
1911 :group 'ebnf2ps) 1919 :group 'ebnf2ps)
1912 1920
1913 1921
1922(defcustom ebnf-arrow-extra-width
1923 (if (eq ebnf-arrow-shape 'none)
1924 0.0
1925 (* (sqrt 5.0) 0.65 ebnf-line-width))
1926 "*Specify extra width for arrow shape drawing.
1927
1928The extra width is used to avoid that the arrowhead and the terminal border
1929overlap. It depens on `ebnf-arrow-shape' and `ebnf-line-width'."
1930 :type 'number
1931 :version "22"
1932 :group 'ebnf-shape)
1933
1934
1935(defcustom ebnf-arrow-scale 1.0
1936 "*Specify the arrow scale.
1937
1938Values lower than 1.0, shrink the arrow.
1939Values greater than 1.0, expand the arrow."
1940 :type 'number
1941 :version "22"
1942 :group 'ebnf-shape)
1943
1944
1914(defcustom ebnf-debug-ps nil 1945(defcustom ebnf-debug-ps nil
1915 "*Non-nil means to generate PostScript debug procedures. 1946 "*Non-nil means to generate PostScript debug procedures.
1916 1947
@@ -2859,9 +2890,9 @@ See documentation for `ebnf-terminal-shape', `ebnf-non-terminal-shape' and
2859/HeightNT FontHeight FontHeight add def 2890/HeightNT FontHeight FontHeight add def
2860 2891
2861/T HeightT HeightNT add 0.5 mul def 2892/T HeightT HeightNT add 0.5 mul def
2862/hT T 0.5 mul def 2893/hT T 0.5 mul def
2863/hT2 hT 0.5 mul def 2894/hT2 hT 0.5 mul ArrowScale mul def
2864/hT4 hT 0.25 mul def 2895/hT4 hT 0.25 mul ArrowScale mul def
2865 2896
2866/Er 0.1 def % Error factor 2897/Er 0.1 def % Error factor
2867 2898
@@ -2947,6 +2978,7 @@ See documentation for `ebnf-terminal-shape', `ebnf-non-terminal-shape' and
2947 RA-vector ArrowShape get exec 2978 RA-vector ArrowShape get exec
2948 Gstroke 2979 Gstroke
2949 moveto 2980 moveto
2981 ExtraWidth 0 rmoveto
2950}def 2982}def
2951 2983
2952% rotation DrawArrow 2984% rotation DrawArrow
@@ -3245,7 +3277,7 @@ See documentation for `ebnf-terminal-shape', `ebnf-non-terminal-shape' and
3245% string width prepare-width |- string 3277% string width prepare-width |- string
3246/prepare-width 3278/prepare-width
3247{/width exch def 3279{/width exch def
3248 dup stringwidth pop space add space add width exch sub 0.5 mul 3280 dup stringwidth pop space add space add width exch sub ExtraWidth sub 0.5 mul
3249 /w exch def 3281 /w exch def
3250}def 3282}def
3251 3283
@@ -4877,7 +4909,6 @@ killed after process termination."
4877 (progn 4909 (progn
4878 ;; adjust creator comment 4910 ;; adjust creator comment
4879 (end-of-line) 4911 (end-of-line)
4880 (backward-char)
4881 (insert " & ebnf2ps v" ebnf-version) 4912 (insert " & ebnf2ps v" ebnf-version)
4882 ;; insert ebnf settings & engine 4913 ;; insert ebnf settings & engine
4883 (goto-char (point-max)) 4914 (goto-char (point-max))
@@ -5066,6 +5097,10 @@ killed after process termination."
5066 (format "/ShadowR %s def\n" 5097 (format "/ShadowR %s def\n"
5067 (ebnf-boolean ebnf-repeat-shadow)) 5098 (ebnf-boolean ebnf-repeat-shadow))
5068 ;; miscellaneous 5099 ;; miscellaneous
5100 (format "/ExtraWidth %s def\n"
5101 (ebnf-format-float ebnf-arrow-extra-width))
5102 (format "/ArrowScale %s def\n"
5103 (ebnf-format-float ebnf-arrow-scale))
5069 (format "/DefaultWidth %s def\n" 5104 (format "/DefaultWidth %s def\n"
5070 (ebnf-format-float ebnf-default-width)) 5105 (ebnf-format-float ebnf-default-width))
5071 (format "/LineWidth %s def\n" 5106 (format "/LineWidth %s def\n"
@@ -5152,7 +5187,7 @@ killed after process termination."
5152 (len (length (ebnf-node-name node)))) 5187 (len (length (ebnf-node-name node))))
5153 (ebnf-node-entry node (* height 0.5)) 5188 (ebnf-node-entry node (* height 0.5))
5154 (ebnf-node-height node height) 5189 (ebnf-node-height node height)
5155 (ebnf-node-width node (+ ebnf-basic-width space 5190 (ebnf-node-width node (+ ebnf-basic-width ebnf-arrow-extra-width space
5156 (* len font-width) 5191 (* len font-width)
5157 space ebnf-basic-width)))) 5192 space ebnf-basic-width))))
5158 5193
@@ -5173,6 +5208,7 @@ killed after process termination."
5173 ebnf-font-height-S) 5208 ebnf-font-height-S)
5174 ebnf-space-R ebnf-space-R)) 5209 ebnf-space-R ebnf-space-R))
5175 (ebnf-node-width repeat (+ (ebnf-node-width element) 5210 (ebnf-node-width repeat (+ (ebnf-node-width element)
5211 ebnf-arrow-extra-width
5176 ebnf-space-R ebnf-space-R ebnf-space-R 5212 ebnf-space-R ebnf-space-R ebnf-space-R
5177 ebnf-horizontal-space 5213 ebnf-horizontal-space
5178 (* (length times) ebnf-font-width-R))))) 5214 (* (length times) ebnf-font-width-R)))))
@@ -5194,6 +5230,7 @@ killed after process termination."
5194 ebnf-space-E ebnf-space-E)) 5230 ebnf-space-E ebnf-space-E))
5195 (ebnf-node-width except (+ (ebnf-node-width factor) 5231 (ebnf-node-width except (+ (ebnf-node-width factor)
5196 (ebnf-node-width element) 5232 (ebnf-node-width element)
5233 ebnf-arrow-extra-width
5197 ebnf-space-E ebnf-space-E 5234 ebnf-space-E ebnf-space-E
5198 ebnf-space-E ebnf-space-E 5235 ebnf-space-E ebnf-space-E
5199 ebnf-font-width-E 5236 ebnf-font-width-E
diff --git a/lisp/progmodes/gdb-ui.el b/lisp/progmodes/gdb-ui.el
index f45bb2fe524..52360a73970 100644
--- a/lisp/progmodes/gdb-ui.el
+++ b/lisp/progmodes/gdb-ui.el
@@ -782,7 +782,7 @@ With arg, enter name of variable to be watched in the minibuffer."
782 782
783(defconst gdb-var-list-children-regexp 783(defconst gdb-var-list-children-regexp
784 "child={.*?name=\"\\(.*?\\)\",.*?exp=\"\\(.*?\\)\",.*?\ 784 "child={.*?name=\"\\(.*?\\)\",.*?exp=\"\\(.*?\\)\",.*?\
785numchild=\"\\(.*?\\)\",.*?type=\"\\(.*?\\)\".*?}") 785numchild=\"\\(.*?\\)\"\\(}\\|,.*?\\(type=\"\\(.*?\\)\"\\)?.*?}\\)")
786 786
787(defun gdb-var-list-children-handler (varnum) 787(defun gdb-var-list-children-handler (varnum)
788 (goto-char (point-min)) 788 (goto-char (point-min))
@@ -796,7 +796,7 @@ numchild=\"\\(.*?\\)\",.*?type=\"\\(.*?\\)\".*?}")
796 (let ((varchild (list (match-string 1) 796 (let ((varchild (list (match-string 1)
797 (match-string 2) 797 (match-string 2)
798 (match-string 3) 798 (match-string 3)
799 (match-string 4) 799 (match-string 6)
800 nil nil))) 800 nil nil)))
801 (if (assoc (car varchild) gdb-var-list) 801 (if (assoc (car varchild) gdb-var-list)
802 (throw 'child-already-watched nil)) 802 (throw 'child-already-watched nil))
@@ -902,20 +902,23 @@ Changed values are highlighted with the face `font-lock-warning-face'."
902TEXT is the text of the button we clicked on, a + or - item. 902TEXT is the text of the button we clicked on, a + or - item.
903TOKEN is data related to this node. 903TOKEN is data related to this node.
904INDENT is the current indentation depth." 904INDENT is the current indentation depth."
905 (cond ((string-match "+" text) ;expand this node 905 (if (and gud-comint-buffer (buffer-name gud-comint-buffer))
906 (if (and 906 (progn
907 (eq (buffer-local-value 'gud-minor-mode gud-comint-buffer) 'gdba) 907 (cond ((string-match "+" text) ;expand this node
908 (string-equal gdb-version "pre-6.4")) 908 (if (and (eq (buffer-local-value
909 (gdb-var-list-children token) 909 'gud-minor-mode gud-comint-buffer) 'gdba)
910 (gdb-var-list-children-1 token))) 910 (string-equal gdb-version "pre-6.4"))
911 ((string-match "-" text) ;contract this node 911 (gdb-var-list-children token)
912 (dolist (var gdb-var-list) 912 (gdb-var-list-children-1 token)))
913 (if (string-match (concat token "\\.") (car var)) 913 ((string-match "-" text) ;contract this node
914 (setq gdb-var-list (delq var gdb-var-list)))) 914 (dolist (var gdb-var-list)
915 (speedbar-change-expand-button-char ?+) 915 (if (string-match (concat token "\\.") (car var))
916 (speedbar-delete-subblock indent)) 916 (setq gdb-var-list (delq var gdb-var-list))))
917 (t (error "Ooops... not sure what to do"))) 917 (speedbar-change-expand-button-char ?+)
918 (speedbar-center-buffer-smartly)) 918 (speedbar-delete-subblock indent))
919 (t (error "Ooops... not sure what to do")))
920 (speedbar-center-buffer-smartly))
921 (message-box "GUD session has been killed")))
919 922
920(defun gdb-get-target-string () 923(defun gdb-get-target-string ()
921 (with-current-buffer gud-comint-buffer 924 (with-current-buffer gud-comint-buffer
@@ -1132,7 +1135,7 @@ This filter may simply queue input for a later time."
1132 (if gdb-prompting 1135 (if gdb-prompting
1133 (progn 1136 (progn
1134 (gdb-send-item item) 1137 (gdb-send-item item)
1135 (setq gdb-prompting nil)) 1138 (setq gdb-prompting nil))
1136 (push item gdb-input-queue)))) 1139 (push item gdb-input-queue))))
1137 1140
1138(defun gdb-dequeue-input () 1141(defun gdb-dequeue-input ()
@@ -3346,7 +3349,8 @@ is set in them."
3346 3349
3347(defconst gdb-var-list-children-regexp-1 3350(defconst gdb-var-list-children-regexp-1
3348 "child={.*?name=\"\\(.+?\\)\",.*?exp=\"\\(.+?\\)\",.*?\ 3351 "child={.*?name=\"\\(.+?\\)\",.*?exp=\"\\(.+?\\)\",.*?\
3349numchild=\"\\(.+?\\)\",.*?value=\\(\".*?\"\\),.*?type=\"\\(.+?\\)\".*?}") 3352numchild=\"\\(.+?\\)\",.*?value=\\(\".*?\"\\)\
3353\\(}\\|,.*?\\(type=\"\\(.+?\\)\"\\)?.*?}\\)")
3350 3354
3351(defun gdb-var-list-children-handler-1 (varnum) 3355(defun gdb-var-list-children-handler-1 (varnum)
3352 (goto-char (point-min)) 3356 (goto-char (point-min))
@@ -3360,7 +3364,7 @@ numchild=\"\\(.+?\\)\",.*?value=\\(\".*?\"\\),.*?type=\"\\(.+?\\)\".*?}")
3360 (let ((varchild (list (match-string 1) 3364 (let ((varchild (list (match-string 1)
3361 (match-string 2) 3365 (match-string 2)
3362 (match-string 3) 3366 (match-string 3)
3363 (match-string 5) 3367 (match-string 7)
3364 (read (match-string 4)) 3368 (read (match-string 4))
3365 nil))) 3369 nil)))
3366 (if (assoc (car varchild) gdb-var-list) 3370 (if (assoc (car varchild) gdb-var-list)
diff --git a/lisp/progmodes/gud.el b/lisp/progmodes/gud.el
index 84b40e8ba80..b42e1b7fdc7 100644
--- a/lisp/progmodes/gud.el
+++ b/lisp/progmodes/gud.el
@@ -456,8 +456,8 @@ required by the caller."
456 (while var-list 456 (while var-list
457 (let* (char (depth 0) (start 0) (var (car var-list)) 457 (let* (char (depth 0) (start 0) (var (car var-list))
458 (varnum (car var)) (expr (nth 1 var)) 458 (varnum (car var)) (expr (nth 1 var))
459 (type (nth 3 var)) (value (nth 4 var)) 459 (type (if (nth 3 var) (nth 3 var) " "))
460 (status (nth 5 var))) 460 (value (nth 4 var)) (status (nth 5 var)))
461 (put-text-property 461 (put-text-property
462 0 (length expr) 'face font-lock-variable-name-face expr) 462 0 (length expr) 'face font-lock-variable-name-face expr)
463 (put-text-property 463 (put-text-property
diff --git a/lisp/progmodes/idlwave.el b/lisp/progmodes/idlwave.el
index 2f26c90ac21..52cfa602e59 100644
--- a/lisp/progmodes/idlwave.el
+++ b/lisp/progmodes/idlwave.el
@@ -75,7 +75,7 @@
75;; of the documentation is available from the maintainers webpage (see 75;; of the documentation is available from the maintainers webpage (see
76;; SOURCE). 76;; SOURCE).
77;; 77;;
78;; 78;;
79;; ACKNOWLEDGMENTS 79;; ACKNOWLEDGMENTS
80;; =============== 80;; ===============
81;; 81;;
@@ -125,7 +125,7 @@
125;; up inserting the character that expanded the abbrev after moving 125;; up inserting the character that expanded the abbrev after moving
126;; point backward, e.g., "\cl" expanded with a space becomes 126;; point backward, e.g., "\cl" expanded with a space becomes
127;; "LONG( )" with point before the close paren. This is solved by 127;; "LONG( )" with point before the close paren. This is solved by
128;; using a temporary function in `post-command-hook' - not pretty, 128;; using a temporary function in `post-command-hook' - not pretty,
129;; but it works. 129;; but it works.
130;; 130;;
131;; Tabs and spaces are treated equally as whitespace when filling a 131;; Tabs and spaces are treated equally as whitespace when filling a
@@ -178,13 +178,13 @@
178 nil ;; We've got what we needed 178 nil ;; We've got what we needed
179 ;; We have the old or no custom-library, hack around it! 179 ;; We have the old or no custom-library, hack around it!
180 (defmacro defgroup (&rest args) nil) 180 (defmacro defgroup (&rest args) nil)
181 (defmacro defcustom (var value doc &rest args) 181 (defmacro defcustom (var value doc &rest args)
182 `(defvar ,var ,value ,doc)))) 182 `(defvar ,var ,value ,doc))))
183 183
184(defgroup idlwave nil 184(defgroup idlwave nil
185 "Major mode for editing IDL .pro files." 185 "Major mode for editing IDL .pro files."
186 :tag "IDLWAVE" 186 :tag "IDLWAVE"
187 :link '(url-link :tag "Home Page" 187 :link '(url-link :tag "Home Page"
188 "http://idlwave.org") 188 "http://idlwave.org")
189 :link '(emacs-commentary-link :tag "Commentary in idlw-shell.el" 189 :link '(emacs-commentary-link :tag "Commentary in idlw-shell.el"
190 "idlw-shell.el") 190 "idlw-shell.el")
@@ -298,8 +298,8 @@ extends to the end of the match for the regular expression."
298 298
299(defcustom idlwave-auto-fill-split-string t 299(defcustom idlwave-auto-fill-split-string t
300 "*If non-nil then auto fill will split strings with the IDL `+' operator. 300 "*If non-nil then auto fill will split strings with the IDL `+' operator.
301When the line end falls within a string, string concatenation with the 301When the line end falls within a string, string concatenation with the
302'+' operator will be used to distribute a long string over lines. 302'+' operator will be used to distribute a long string over lines.
303If nil and a string is split then a terminal beep and warning are issued. 303If nil and a string is split then a terminal beep and warning are issued.
304 304
305This variable is ignored when `idlwave-fill-comment-line-only' is 305This variable is ignored when `idlwave-fill-comment-line-only' is
@@ -418,7 +418,7 @@ t All available
418 (const :tag "When saving a buffer" save-buffer) 418 (const :tag "When saving a buffer" save-buffer)
419 (const :tag "After a buffer was killed" kill-buffer) 419 (const :tag "After a buffer was killed" kill-buffer)
420 (const :tag "After a buffer was compiled successfully, update shell info" compile-buffer)))) 420 (const :tag "After a buffer was compiled successfully, update shell info" compile-buffer))))
421 421
422(defcustom idlwave-rinfo-max-source-lines 5 422(defcustom idlwave-rinfo-max-source-lines 5
423 "*Maximum number of source files displayed in the Routine Info window. 423 "*Maximum number of source files displayed in the Routine Info window.
424When an integer, it is the maximum number of source files displayed. 424When an integer, it is the maximum number of source files displayed.
@@ -453,7 +453,7 @@ value of `!DIR'. See also `idlwave-library-path'."
453 :type 'directory) 453 :type 'directory)
454 454
455;; Configuration files 455;; Configuration files
456(defcustom idlwave-config-directory 456(defcustom idlwave-config-directory
457 (convert-standard-filename "~/.idlwave") 457 (convert-standard-filename "~/.idlwave")
458 "*Directory for configuration files and user-library catalog." 458 "*Directory for configuration files and user-library catalog."
459 :group 'idlwave-routine-info 459 :group 'idlwave-routine-info
@@ -469,7 +469,7 @@ value of `!DIR'. See also `idlwave-library-path'."
469(defcustom idlwave-special-lib-alist nil 469(defcustom idlwave-special-lib-alist nil
470 "Alist of regular expressions matching special library directories. 470 "Alist of regular expressions matching special library directories.
471When listing routine source locations, IDLWAVE gives a short hint where 471When listing routine source locations, IDLWAVE gives a short hint where
472the file defining the routine is located. By default it lists `SystemLib' 472the file defining the routine is located. By default it lists `SystemLib'
473for routines in the system library `!DIR/lib' and `Library' for anything 473for routines in the system library `!DIR/lib' and `Library' for anything
474else. This variable can define additional types. The car of each entry 474else. This variable can define additional types. The car of each entry
475is a regular expression matching the file name (they normally will match 475is a regular expression matching the file name (they normally will match
@@ -480,7 +480,7 @@ chars are allowed."
480 (cons regexp string))) 480 (cons regexp string)))
481 481
482(defcustom idlwave-auto-write-paths t 482(defcustom idlwave-auto-write-paths t
483 "Write out path (!PATH) and system directory (!DIR) info automatically. 483 "Write out path (!PATH) and system directory (!DIR) info automatically.
484Path info is needed to locate library catalog files. If non-nil, 484Path info is needed to locate library catalog files. If non-nil,
485whenever the path-list changes as a result of shell-query, etc., it is 485whenever the path-list changes as a result of shell-query, etc., it is
486written to file. Otherwise, the menu option \"Write Paths\" can be 486written to file. Otherwise, the menu option \"Write Paths\" can be
@@ -511,7 +511,7 @@ used to force a write."
511This variable determines the case (UPPER/lower/Capitalized...) of 511This variable determines the case (UPPER/lower/Capitalized...) of
512words inserted into the buffer by completion. The preferred case can 512words inserted into the buffer by completion. The preferred case can
513be specified separately for routine names, keywords, classes and 513be specified separately for routine names, keywords, classes and
514methods. 514methods.
515This alist should therefore have entries for `routine' (normal 515This alist should therefore have entries for `routine' (normal
516functions and procedures, i.e. non-methods), `keyword', `class', and 516functions and procedures, i.e. non-methods), `keyword', `class', and
517`method'. Plausible values are 517`method'. Plausible values are
@@ -598,7 +598,7 @@ certain methods this assumption is almost always true. The methods
598for which to assume this can be set here." 598for which to assume this can be set here."
599 :group 'idlwave-routine-info 599 :group 'idlwave-routine-info
600 :type '(repeat (regexp :tag "Match method:"))) 600 :type '(repeat (regexp :tag "Match method:")))
601 601
602 602
603(defcustom idlwave-completion-show-classes 1 603(defcustom idlwave-completion-show-classes 1
604 "*Number of classes to show when completing object methods and keywords. 604 "*Number of classes to show when completing object methods and keywords.
@@ -663,7 +663,7 @@ should contain at least two elements: (method-default . VALUE) and
663specify if the class should be found during method and keyword 663specify if the class should be found during method and keyword
664completion, respectively. 664completion, respectively.
665 665
666The alist may have additional entries specifying exceptions from the 666The alist may have additional entries specifying exceptions from the
667keyword completion rule for specific methods, like INIT or 667keyword completion rule for specific methods, like INIT or
668GETPROPERTY. In order to turn on class specification for the INIT 668GETPROPERTY. In order to turn on class specification for the INIT
669method, add an entry (\"INIT\" . t). The method name must be ALL-CAPS." 669method, add an entry (\"INIT\" . t). The method name must be ALL-CAPS."
@@ -687,7 +687,7 @@ particular object method call. This happens during the commands
687value of the variable `idlwave-query-class'. 687value of the variable `idlwave-query-class'.
688 688
689When you specify a class, this information can be stored as a text 689When you specify a class, this information can be stored as a text
690property on the `->' arrow in the source code, so that during the same 690property on the `->' arrow in the source code, so that during the same
691editing session, IDLWAVE will not have to ask again. When this 691editing session, IDLWAVE will not have to ask again. When this
692variable is non-nil, IDLWAVE will store and reuse the class information. 692variable is non-nil, IDLWAVE will store and reuse the class information.
693The class stored can be checked and removed with `\\[idlwave-routine-info]' 693The class stored can be checked and removed with `\\[idlwave-routine-info]'
@@ -1065,7 +1065,7 @@ IDL process is made."
1065 :group 'idlwave-misc 1065 :group 'idlwave-misc
1066 :type 'boolean) 1066 :type 'boolean)
1067 1067
1068(defcustom idlwave-default-font-lock-items 1068(defcustom idlwave-default-font-lock-items
1069 '(pros-and-functions batch-files idlwave-idl-keywords label goto 1069 '(pros-and-functions batch-files idlwave-idl-keywords label goto
1070 common-blocks class-arrows) 1070 common-blocks class-arrows)
1071 "Items which should be fontified on the default fontification level 2. 1071 "Items which should be fontified on the default fontification level 2.
@@ -1127,25 +1127,25 @@ As a user, you should not set this to t.")
1127;;; and Carsten Dominik... 1127;;; and Carsten Dominik...
1128 1128
1129;; The following are the reserved words in IDL. Maybe we should 1129;; The following are the reserved words in IDL. Maybe we should
1130;; highlight some more stuff as well? 1130;; highlight some more stuff as well?
1131;; Procedure declarations. Fontify keyword plus procedure name. 1131;; Procedure declarations. Fontify keyword plus procedure name.
1132(defvar idlwave-idl-keywords 1132(defvar idlwave-idl-keywords
1133 ;; To update this regexp, update the list of keywords and 1133 ;; To update this regexp, update the list of keywords and
1134 ;; evaluate the form. 1134 ;; evaluate the form.
1135 ;; (insert 1135 ;; (insert
1136 ;; (prin1-to-string 1136 ;; (prin1-to-string
1137 ;; (concat 1137 ;; (concat
1138 ;; "\\<\\(" 1138 ;; "\\<\\("
1139 ;; (regexp-opt 1139 ;; (regexp-opt
1140 ;; '("||" "&&" "and" "or" "xor" "not" 1140 ;; '("||" "&&" "and" "or" "xor" "not"
1141 ;; "eq" "ge" "gt" "le" "lt" "ne" 1141 ;; "eq" "ge" "gt" "le" "lt" "ne"
1142 ;; "for" "do" "endfor" 1142 ;; "for" "do" "endfor"
1143 ;; "if" "then" "endif" "else" "endelse" 1143 ;; "if" "then" "endif" "else" "endelse"
1144 ;; "case" "of" "endcase" 1144 ;; "case" "of" "endcase"
1145 ;; "switch" "break" "continue" "endswitch" 1145 ;; "switch" "break" "continue" "endswitch"
1146 ;; "begin" "end" 1146 ;; "begin" "end"
1147 ;; "repeat" "until" "endrep" 1147 ;; "repeat" "until" "endrep"
1148 ;; "while" "endwhile" 1148 ;; "while" "endwhile"
1149 ;; "goto" "return" 1149 ;; "goto" "return"
1150 ;; "inherits" "mod" 1150 ;; "inherits" "mod"
1151 ;; "compile_opt" "forward_function" 1151 ;; "compile_opt" "forward_function"
@@ -1168,7 +1168,7 @@ As a user, you should not set this to t.")
1168 (2 font-lock-reference-face nil t) ; block name 1168 (2 font-lock-reference-face nil t) ; block name
1169 ("[ \t]*\\(\\sw+\\)[ ,]*" 1169 ("[ \t]*\\(\\sw+\\)[ ,]*"
1170 ;; Start with point after block name and comma 1170 ;; Start with point after block name and comma
1171 (goto-char (match-end 0)) ; needed for XEmacs, could be nil 1171 (goto-char (match-end 0)) ; needed for XEmacs, could be nil
1172 nil 1172 nil
1173 (1 font-lock-variable-name-face) ; variable names 1173 (1 font-lock-variable-name-face) ; variable names
1174 ))) 1174 )))
@@ -1223,7 +1223,7 @@ As a user, you should not set this to t.")
1223 ;; All operators (not used because too noisy) 1223 ;; All operators (not used because too noisy)
1224 (all-operators 1224 (all-operators
1225 '("[-*^#+<>/]" (0 font-lock-keyword-face))) 1225 '("[-*^#+<>/]" (0 font-lock-keyword-face)))
1226 1226
1227 ;; Arrows with text property `idlwave-class' 1227 ;; Arrows with text property `idlwave-class'
1228 (class-arrows 1228 (class-arrows
1229 '(idlwave-match-class-arrows (0 idlwave-class-arrow-face)))) 1229 '(idlwave-match-class-arrows (0 idlwave-class-arrow-face))))
@@ -1260,14 +1260,14 @@ As a user, you should not set this to t.")
1260 1260
1261(defvar idlwave-font-lock-defaults 1261(defvar idlwave-font-lock-defaults
1262 '((idlwave-font-lock-keywords 1262 '((idlwave-font-lock-keywords
1263 idlwave-font-lock-keywords-1 1263 idlwave-font-lock-keywords-1
1264 idlwave-font-lock-keywords-2 1264 idlwave-font-lock-keywords-2
1265 idlwave-font-lock-keywords-3) 1265 idlwave-font-lock-keywords-3)
1266 nil t 1266 nil t
1267 ((?$ . "w") (?_ . "w") (?. . "w") (?| . "w") (?& . "w")) 1267 ((?$ . "w") (?_ . "w") (?. . "w") (?| . "w") (?& . "w"))
1268 beginning-of-line)) 1268 beginning-of-line))
1269 1269
1270(put 'idlwave-mode 'font-lock-defaults 1270(put 'idlwave-mode 'font-lock-defaults
1271 idlwave-font-lock-defaults) ; XEmacs 1271 idlwave-font-lock-defaults) ; XEmacs
1272 1272
1273(defconst idlwave-comment-line-start-skip "^[ \t]*;" 1273(defconst idlwave-comment-line-start-skip "^[ \t]*;"
@@ -1275,7 +1275,7 @@ As a user, you should not set this to t.")
1275That is the _beginning_ of a line containing a comment delimiter `;' preceded 1275That is the _beginning_ of a line containing a comment delimiter `;' preceded
1276only by whitespace.") 1276only by whitespace.")
1277 1277
1278(defconst idlwave-begin-block-reg 1278(defconst idlwave-begin-block-reg
1279 "\\<\\(pro\\|function\\|begin\\|case\\|switch\\)\\>" 1279 "\\<\\(pro\\|function\\|begin\\|case\\|switch\\)\\>"
1280 "Regular expression to find the beginning of a block. The case does 1280 "Regular expression to find the beginning of a block. The case does
1281not matter. The search skips matches in comments.") 1281not matter. The search skips matches in comments.")
@@ -1352,17 +1352,17 @@ blocks starting with a BEGIN statement. The matches must have associations
1352 '(goto . ("goto\\>" nil)) 1352 '(goto . ("goto\\>" nil))
1353 '(case . ("case\\>" nil)) 1353 '(case . ("case\\>" nil))
1354 '(switch . ("switch\\>" nil)) 1354 '(switch . ("switch\\>" nil))
1355 (cons 'call (list (concat "\\(" idlwave-variable "\\) *= *" 1355 (cons 'call (list (concat "\\(" idlwave-variable "\\) *= *"
1356 "\\(" idlwave-method-call "\\s *\\)?" 1356 "\\(" idlwave-method-call "\\s *\\)?"
1357 idlwave-identifier 1357 idlwave-identifier
1358 "\\s *(") nil)) 1358 "\\s *(") nil))
1359 (cons 'call (list (concat 1359 (cons 'call (list (concat
1360 "\\(" idlwave-method-call "\\s *\\)?" 1360 "\\(" idlwave-method-call "\\s *\\)?"
1361 idlwave-identifier 1361 idlwave-identifier
1362 "\\( *\\($\\|\\$\\)\\|\\s *,\\)") nil)) 1362 "\\( *\\($\\|\\$\\)\\|\\s *,\\)") nil))
1363 (cons 'assign (list (concat 1363 (cons 'assign (list (concat
1364 "\\(" idlwave-variable "\\) *=") nil))) 1364 "\\(" idlwave-variable "\\) *=") nil)))
1365 1365
1366 "Associated list of statement matching regular expressions. 1366 "Associated list of statement matching regular expressions.
1367Each regular expression matches the start of an IDL statement. The 1367Each regular expression matches the start of an IDL statement. The
1368first element of each association is a symbol giving the statement 1368first element of each association is a symbol giving the statement
@@ -1385,7 +1385,7 @@ the leftover unidentified statements containing an equal sign." )
1385;; Note that this is documented in the v18 manuals as being a string 1385;; Note that this is documented in the v18 manuals as being a string
1386;; of length one rather than a single character. 1386;; of length one rather than a single character.
1387;; The code in this file accepts either format for compatibility. 1387;; The code in this file accepts either format for compatibility.
1388(defvar idlwave-comment-indent-char ?\ 1388(defvar idlwave-comment-indent-char ?\
1389 "Character to be inserted for IDL comment indentation. 1389 "Character to be inserted for IDL comment indentation.
1390Normally a space.") 1390Normally a space.")
1391 1391
@@ -1557,15 +1557,15 @@ Capitalize system variables - action only
1557 (not (equal idlwave-shell-debug-modifiers '()))) 1557 (not (equal idlwave-shell-debug-modifiers '())))
1558 ;; Bind the debug commands also with the special modifiers. 1558 ;; Bind the debug commands also with the special modifiers.
1559 (let ((shift (memq 'shift idlwave-shell-debug-modifiers)) 1559 (let ((shift (memq 'shift idlwave-shell-debug-modifiers))
1560 (mods-noshift (delq 'shift 1560 (mods-noshift (delq 'shift
1561 (copy-sequence idlwave-shell-debug-modifiers)))) 1561 (copy-sequence idlwave-shell-debug-modifiers))))
1562 (define-key idlwave-mode-map 1562 (define-key idlwave-mode-map
1563 (vector (append mods-noshift (list (if shift ?C ?c)))) 1563 (vector (append mods-noshift (list (if shift ?C ?c))))
1564 'idlwave-shell-save-and-run) 1564 'idlwave-shell-save-and-run)
1565 (define-key idlwave-mode-map 1565 (define-key idlwave-mode-map
1566 (vector (append mods-noshift (list (if shift ?B ?b)))) 1566 (vector (append mods-noshift (list (if shift ?B ?b))))
1567 'idlwave-shell-break-here) 1567 'idlwave-shell-break-here)
1568 (define-key idlwave-mode-map 1568 (define-key idlwave-mode-map
1569 (vector (append mods-noshift (list (if shift ?E ?e)))) 1569 (vector (append mods-noshift (list (if shift ?E ?e))))
1570 'idlwave-shell-run-region))) 1570 'idlwave-shell-run-region)))
1571(define-key idlwave-mode-map "\C-c\C-d\C-c" 'idlwave-shell-save-and-run) 1571(define-key idlwave-mode-map "\C-c\C-d\C-c" 'idlwave-shell-save-and-run)
@@ -1602,7 +1602,7 @@ Capitalize system variables - action only
1602(define-key idlwave-mode-map "\M-\C-i" 'idlwave-complete) 1602(define-key idlwave-mode-map "\M-\C-i" 'idlwave-complete)
1603(define-key idlwave-mode-map "\C-c\C-i" 'idlwave-update-routine-info) 1603(define-key idlwave-mode-map "\C-c\C-i" 'idlwave-update-routine-info)
1604(define-key idlwave-mode-map "\C-c=" 'idlwave-resolve) 1604(define-key idlwave-mode-map "\C-c=" 'idlwave-resolve)
1605(define-key idlwave-mode-map 1605(define-key idlwave-mode-map
1606 (if (featurep 'xemacs) [(shift button3)] [(shift mouse-3)]) 1606 (if (featurep 'xemacs) [(shift button3)] [(shift mouse-3)])
1607 'idlwave-mouse-context-help) 1607 'idlwave-mouse-context-help)
1608 1608
@@ -1617,7 +1617,7 @@ Capitalize system variables - action only
1617;; to go ahead of > and <, so >= and <= will be treated correctly 1617;; to go ahead of > and <, so >= and <= will be treated correctly
1618(idlwave-action-and-binding "=" '(idlwave-expand-equal -1 -1)) 1618(idlwave-action-and-binding "=" '(idlwave-expand-equal -1 -1))
1619 1619
1620;; Actions for > and < are complicated by >=, <=, and ->... 1620;; Actions for > and < are complicated by >=, <=, and ->...
1621(idlwave-action-and-binding "<" '(idlwave-custom-ltgtr-surround nil)) 1621(idlwave-action-and-binding "<" '(idlwave-custom-ltgtr-surround nil))
1622(idlwave-action-and-binding ">" '(idlwave-custom-ltgtr-surround 'gtr)) 1622(idlwave-action-and-binding ">" '(idlwave-custom-ltgtr-surround 'gtr))
1623 1623
@@ -1650,7 +1650,7 @@ idlwave-mode-abbrev-table unless TABLE is non-nil."
1650 (error (apply 'define-abbrev args))))) 1650 (error (apply 'define-abbrev args)))))
1651 1651
1652(condition-case nil 1652(condition-case nil
1653 (modify-syntax-entry (string-to-char idlwave-abbrev-start-char) 1653 (modify-syntax-entry (string-to-char idlwave-abbrev-start-char)
1654 "w" idlwave-mode-syntax-table) 1654 "w" idlwave-mode-syntax-table)
1655 (error nil)) 1655 (error nil))
1656 1656
@@ -1774,7 +1774,7 @@ idlwave-mode-abbrev-table unless TABLE is non-nil."
1774(defvar imenu-extract-index-name-function) 1774(defvar imenu-extract-index-name-function)
1775(defvar imenu-prev-index-position-function) 1775(defvar imenu-prev-index-position-function)
1776;; defined later - so just make the compiler hush 1776;; defined later - so just make the compiler hush
1777(defvar idlwave-mode-menu) 1777(defvar idlwave-mode-menu)
1778(defvar idlwave-mode-debug-menu) 1778(defvar idlwave-mode-debug-menu)
1779 1779
1780;;;###autoload 1780;;;###autoload
@@ -1858,7 +1858,7 @@ The main features of this mode are
1858 \\i IF statement template 1858 \\i IF statement template
1859 \\elif IF-ELSE statement template 1859 \\elif IF-ELSE statement template
1860 \\b BEGIN 1860 \\b BEGIN
1861 1861
1862 For a full list, use \\[idlwave-list-abbrevs]. Some templates also 1862 For a full list, use \\[idlwave-list-abbrevs]. Some templates also
1863 have direct keybindings - see the list of keybindings below. 1863 have direct keybindings - see the list of keybindings below.
1864 1864
@@ -1900,19 +1900,19 @@ The main features of this mode are
1900 1900
1901 (interactive) 1901 (interactive)
1902 (kill-all-local-variables) 1902 (kill-all-local-variables)
1903 1903
1904 (if idlwave-startup-message 1904 (if idlwave-startup-message
1905 (message "Emacs IDLWAVE mode version %s." idlwave-mode-version)) 1905 (message "Emacs IDLWAVE mode version %s." idlwave-mode-version))
1906 (setq idlwave-startup-message nil) 1906 (setq idlwave-startup-message nil)
1907 1907
1908 (setq local-abbrev-table idlwave-mode-abbrev-table) 1908 (setq local-abbrev-table idlwave-mode-abbrev-table)
1909 (set-syntax-table idlwave-mode-syntax-table) 1909 (set-syntax-table idlwave-mode-syntax-table)
1910 1910
1911 (set (make-local-variable 'indent-line-function) 'idlwave-indent-and-action) 1911 (set (make-local-variable 'indent-line-function) 'idlwave-indent-and-action)
1912 1912
1913 (make-local-variable idlwave-comment-indent-function) 1913 (make-local-variable idlwave-comment-indent-function)
1914 (set idlwave-comment-indent-function 'idlwave-comment-hook) 1914 (set idlwave-comment-indent-function 'idlwave-comment-hook)
1915 1915
1916 (set (make-local-variable 'comment-start-skip) ";+[ \t]*") 1916 (set (make-local-variable 'comment-start-skip) ";+[ \t]*")
1917 (set (make-local-variable 'comment-start) ";") 1917 (set (make-local-variable 'comment-start) ";")
1918 (set (make-local-variable 'comment-add) 1) ; ";;" for new and regions 1918 (set (make-local-variable 'comment-add) 1) ; ";;" for new and regions
@@ -1920,7 +1920,7 @@ The main features of this mode are
1920 (set (make-local-variable 'abbrev-all-caps) t) 1920 (set (make-local-variable 'abbrev-all-caps) t)
1921 (set (make-local-variable 'indent-tabs-mode) nil) 1921 (set (make-local-variable 'indent-tabs-mode) nil)
1922 (set (make-local-variable 'completion-ignore-case) t) 1922 (set (make-local-variable 'completion-ignore-case) t)
1923 1923
1924 (use-local-map idlwave-mode-map) 1924 (use-local-map idlwave-mode-map)
1925 1925
1926 (when (featurep 'easymenu) 1926 (when (featurep 'easymenu)
@@ -1930,11 +1930,11 @@ The main features of this mode are
1930 (setq mode-name "IDLWAVE") 1930 (setq mode-name "IDLWAVE")
1931 (setq major-mode 'idlwave-mode) 1931 (setq major-mode 'idlwave-mode)
1932 (setq abbrev-mode t) 1932 (setq abbrev-mode t)
1933 1933
1934 (set (make-local-variable idlwave-fill-function) 'idlwave-auto-fill) 1934 (set (make-local-variable idlwave-fill-function) 'idlwave-auto-fill)
1935 (setq comment-end "") 1935 (setq comment-end "")
1936 (set (make-local-variable 'comment-multi-line) nil) 1936 (set (make-local-variable 'comment-multi-line) nil)
1937 (set (make-local-variable 'paragraph-separate) 1937 (set (make-local-variable 'paragraph-separate)
1938 "[ \t\f]*$\\|[ \t]*;+[ \t]*$\\|;+[+=-_*]+$") 1938 "[ \t\f]*$\\|[ \t]*;+[ \t]*$\\|;+[+=-_*]+$")
1939 (set (make-local-variable 'paragraph-start) "[ \t\f]\\|[ \t]*;+[ \t]") 1939 (set (make-local-variable 'paragraph-start) "[ \t\f]\\|[ \t]*;+[ \t]")
1940 (set (make-local-variable 'paragraph-ignore-fill-prefix) nil) 1940 (set (make-local-variable 'paragraph-ignore-fill-prefix) nil)
@@ -1943,7 +1943,7 @@ The main features of this mode are
1943 ;; Set tag table list to use IDLTAGS as file name. 1943 ;; Set tag table list to use IDLTAGS as file name.
1944 (if (boundp 'tag-table-alist) 1944 (if (boundp 'tag-table-alist)
1945 (add-to-list 'tag-table-alist '("\\.pro$" . "IDLTAGS"))) 1945 (add-to-list 'tag-table-alist '("\\.pro$" . "IDLTAGS")))
1946 1946
1947 ;; Font-lock additions - originally Phil Williams, then Ulrik Dickow 1947 ;; Font-lock additions - originally Phil Williams, then Ulrik Dickow
1948 ;; Following line is for Emacs - XEmacs uses the corresponding property 1948 ;; Following line is for Emacs - XEmacs uses the corresponding property
1949 ;; on the `idlwave-mode' symbol. 1949 ;; on the `idlwave-mode' symbol.
@@ -1968,7 +1968,7 @@ The main features of this mode are
1968 idlwave-end-block-reg 1968 idlwave-end-block-reg
1969 ";" 1969 ";"
1970 'idlwave-forward-block nil)) 1970 'idlwave-forward-block nil))
1971 1971
1972 1972
1973 ;; Make a local post-command-hook and add our hook to it 1973 ;; Make a local post-command-hook and add our hook to it
1974 ;; NB: `make-local-hook' needed for older/alternative Emacs compatibility 1974 ;; NB: `make-local-hook' needed for older/alternative Emacs compatibility
@@ -2000,16 +2000,16 @@ The main features of this mode are
2000 (unless idlwave-setup-done 2000 (unless idlwave-setup-done
2001 (if (not (file-directory-p idlwave-config-directory)) 2001 (if (not (file-directory-p idlwave-config-directory))
2002 (make-directory idlwave-config-directory)) 2002 (make-directory idlwave-config-directory))
2003 (setq 2003 (setq
2004 idlwave-user-catalog-file (expand-file-name 2004 idlwave-user-catalog-file (expand-file-name
2005 idlwave-user-catalog-file 2005 idlwave-user-catalog-file
2006 idlwave-config-directory) 2006 idlwave-config-directory)
2007 idlwave-xml-system-rinfo-converted-file 2007 idlwave-xml-system-rinfo-converted-file
2008 (expand-file-name 2008 (expand-file-name
2009 idlwave-xml-system-rinfo-converted-file 2009 idlwave-xml-system-rinfo-converted-file
2010 idlwave-config-directory) 2010 idlwave-config-directory)
2011 idlwave-path-file (expand-file-name 2011 idlwave-path-file (expand-file-name
2012 idlwave-path-file 2012 idlwave-path-file
2013 idlwave-config-directory)) 2013 idlwave-config-directory))
2014 (idlwave-read-paths) ; we may need these early 2014 (idlwave-read-paths) ; we may need these early
2015 (setq idlwave-setup-done t))) 2015 (setq idlwave-setup-done t)))
@@ -2028,7 +2028,7 @@ The main features of this mode are
2028 2028
2029;; 2029;;
2030;; Code Formatting ---------------------------------------------------- 2030;; Code Formatting ----------------------------------------------------
2031;; 2031;;
2032 2032
2033(defun idlwave-hard-tab () 2033(defun idlwave-hard-tab ()
2034 "Inserts TAB in buffer in current position." 2034 "Inserts TAB in buffer in current position."
@@ -2171,7 +2171,7 @@ Also checks if the correct end statement has been used."
2171 (if (> end-pos eol-pos) 2171 (if (> end-pos eol-pos)
2172 (setq end-pos pos)) 2172 (setq end-pos pos))
2173 (goto-char end-pos) 2173 (goto-char end-pos)
2174 (setq end (buffer-substring 2174 (setq end (buffer-substring
2175 (progn 2175 (progn
2176 (skip-chars-backward "a-zA-Z") 2176 (skip-chars-backward "a-zA-Z")
2177 (point)) 2177 (point))
@@ -2193,7 +2193,7 @@ Also checks if the correct end statement has been used."
2193 (sit-for 1)) 2193 (sit-for 1))
2194 (t 2194 (t
2195 (beep) 2195 (beep)
2196 (message "Warning: Shouldn't this be \"%s\" instead of \"%s\"?" 2196 (message "Warning: Shouldn't this be \"%s\" instead of \"%s\"?"
2197 end1 end) 2197 end1 end)
2198 (sit-for 1)))))))) 2198 (sit-for 1))))))))
2199 ;;(delete-char 1)) 2199 ;;(delete-char 1))
@@ -2205,8 +2205,8 @@ Also checks if the correct end statement has been used."
2205 ((looking-at "pro\\|case\\|switch\\|function\\>") 2205 ((looking-at "pro\\|case\\|switch\\|function\\>")
2206 (assoc (downcase (match-string 0)) idlwave-block-matches)) 2206 (assoc (downcase (match-string 0)) idlwave-block-matches))
2207 ((looking-at "begin\\>") 2207 ((looking-at "begin\\>")
2208 (let ((limit (save-excursion 2208 (let ((limit (save-excursion
2209 (idlwave-beginning-of-statement) 2209 (idlwave-beginning-of-statement)
2210 (point)))) 2210 (point))))
2211 (cond 2211 (cond
2212 ((re-search-backward ":[ \t]*\\=" limit t) 2212 ((re-search-backward ":[ \t]*\\=" limit t)
@@ -2490,7 +2490,7 @@ Returns non-nil if successfull."
2490 (let ((eos (save-excursion 2490 (let ((eos (save-excursion
2491 (idlwave-block-jump-out -1 'nomark) 2491 (idlwave-block-jump-out -1 'nomark)
2492 (point)))) 2492 (point))))
2493 (if (setq status (idlwave-find-key 2493 (if (setq status (idlwave-find-key
2494 idlwave-end-block-reg -1 'nomark eos)) 2494 idlwave-end-block-reg -1 'nomark eos))
2495 (idlwave-beginning-of-statement) 2495 (idlwave-beginning-of-statement)
2496 (message "No nested block before beginning of containing block."))) 2496 (message "No nested block before beginning of containing block.")))
@@ -2498,7 +2498,7 @@ Returns non-nil if successfull."
2498 (let ((eos (save-excursion 2498 (let ((eos (save-excursion
2499 (idlwave-block-jump-out 1 'nomark) 2499 (idlwave-block-jump-out 1 'nomark)
2500 (point)))) 2500 (point))))
2501 (if (setq status (idlwave-find-key 2501 (if (setq status (idlwave-find-key
2502 idlwave-begin-block-reg 1 'nomark eos)) 2502 idlwave-begin-block-reg 1 'nomark eos))
2503 (idlwave-end-of-statement) 2503 (idlwave-end-of-statement)
2504 (message "No nested block before end of containing block.")))) 2504 (message "No nested block before end of containing block."))))
@@ -2512,7 +2512,7 @@ The marks are pushed."
2512 (here (point))) 2512 (here (point)))
2513 (goto-char (point-max)) 2513 (goto-char (point-max))
2514 (if (re-search-backward idlwave-doclib-start nil t) 2514 (if (re-search-backward idlwave-doclib-start nil t)
2515 (progn 2515 (progn
2516 (setq beg (progn (beginning-of-line) (point))) 2516 (setq beg (progn (beginning-of-line) (point)))
2517 (if (re-search-forward idlwave-doclib-end nil t) 2517 (if (re-search-forward idlwave-doclib-end nil t)
2518 (progn 2518 (progn
@@ -2545,7 +2545,7 @@ actual statement."
2545 ((eq major-mode 'idlwave-shell-mode) 2545 ((eq major-mode 'idlwave-shell-mode)
2546 (if (re-search-backward idlwave-shell-prompt-pattern nil t) 2546 (if (re-search-backward idlwave-shell-prompt-pattern nil t)
2547 (goto-char (match-end 0)))) 2547 (goto-char (match-end 0))))
2548 (t 2548 (t
2549 (if (save-excursion (forward-line -1) (idlwave-is-continuation-line)) 2549 (if (save-excursion (forward-line -1) (idlwave-is-continuation-line))
2550 (idlwave-previous-statement) 2550 (idlwave-previous-statement)
2551 (beginning-of-line))))) 2551 (beginning-of-line)))))
@@ -2622,7 +2622,7 @@ If not in a statement just moves to end of line. Returns position."
2622 (let ((save-point (point))) 2622 (let ((save-point (point)))
2623 (when (re-search-forward ".*&" lim t) 2623 (when (re-search-forward ".*&" lim t)
2624 (goto-char (match-end 0)) 2624 (goto-char (match-end 0))
2625 (if (idlwave-quoted) 2625 (if (idlwave-quoted)
2626 (goto-char save-point) 2626 (goto-char save-point)
2627 (if (eq (char-after (- (point) 2)) ?&) (goto-char save-point)))) 2627 (if (eq (char-after (- (point) 2)) ?&) (goto-char save-point))))
2628 (point))) 2628 (point)))
@@ -2639,7 +2639,7 @@ If there is no label point is not moved and nil is returned."
2639 ;; - not in parenthesis (like a[0:3]) 2639 ;; - not in parenthesis (like a[0:3])
2640 ;; - not followed by another ":" in explicit class, ala a->b::c 2640 ;; - not followed by another ":" in explicit class, ala a->b::c
2641 ;; As many in this mode, this function is heuristic and not an exact 2641 ;; As many in this mode, this function is heuristic and not an exact
2642 ;; parser. 2642 ;; parser.
2643 (let* ((start (point)) 2643 (let* ((start (point))
2644 (eos (save-excursion (idlwave-end-of-statement) (point))) 2644 (eos (save-excursion (idlwave-end-of-statement) (point)))
2645 (end (idlwave-find-key ":" 1 'nomark eos))) 2645 (end (idlwave-find-key ":" 1 'nomark eos)))
@@ -2716,7 +2716,7 @@ equal sign will be surrounded by BEFORE and AFTER blanks. If
2716`idlwave-pad-keyword' is t then keyword assignment is treated just 2716`idlwave-pad-keyword' is t then keyword assignment is treated just
2717like assignment statements. When nil, spaces are removed for keyword 2717like assignment statements. When nil, spaces are removed for keyword
2718assignment. Any other value keeps the current space around the `='. 2718assignment. Any other value keeps the current space around the `='.
2719Limits in for loops are treated as keyword assignment. 2719Limits in for loops are treated as keyword assignment.
2720 2720
2721Starting with IDL 6.0, a number of op= assignments are available. 2721Starting with IDL 6.0, a number of op= assignments are available.
2722Since ambiguities of the form: 2722Since ambiguities of the form:
@@ -2733,25 +2733,25 @@ IS-ACTION is ignored.
2733 2733
2734See `idlwave-surround'." 2734See `idlwave-surround'."
2735 (if idlwave-surround-by-blank 2735 (if idlwave-surround-by-blank
2736 (let 2736 (let
2737 ((non-an-ops "\\(##\\|\\*\\|\\+\\|-\\|/\\|<\\|>\\|\\^\\)\\=") 2737 ((non-an-ops "\\(##\\|\\*\\|\\+\\|-\\|/\\|<\\|>\\|\\^\\)\\=")
2738 (an-ops 2738 (an-ops
2739 "\\s-\\(AND\\|EQ\\|GE\\|GT\\|LE\\|LT\\|MOD\\|NE\\|OR\\|XOR\\)\\=") 2739 "\\s-\\(AND\\|EQ\\|GE\\|GT\\|LE\\|LT\\|MOD\\|NE\\|OR\\|XOR\\)\\=")
2740 (len 1)) 2740 (len 1))
2741 2741
2742 (save-excursion 2742 (save-excursion
2743 (let ((case-fold-search t)) 2743 (let ((case-fold-search t))
2744 (backward-char) 2744 (backward-char)
2745 (if (or 2745 (if (or
2746 (re-search-backward non-an-ops nil t) 2746 (re-search-backward non-an-ops nil t)
2747 ;; Why doesn't ##? work for both? 2747 ;; Why doesn't ##? work for both?
2748 (re-search-backward "\\(#\\)\\=" nil t)) 2748 (re-search-backward "\\(#\\)\\=" nil t))
2749 (setq len (1+ (length (match-string 1)))) 2749 (setq len (1+ (length (match-string 1))))
2750 (when (re-search-backward an-ops nil t) 2750 (when (re-search-backward an-ops nil t)
2751 ;(setq begin nil) ; won't modify begin 2751 ;(setq begin nil) ; won't modify begin
2752 (setq len (1+ (length (match-string 1)))))))) 2752 (setq len (1+ (length (match-string 1))))))))
2753 2753
2754 (if (eq t idlwave-pad-keyword) 2754 (if (eq t idlwave-pad-keyword)
2755 ;; Everything gets padded equally 2755 ;; Everything gets padded equally
2756 (idlwave-surround before after len) 2756 (idlwave-surround before after len)
2757 ;; Treating keywords/for variables specially... 2757 ;; Treating keywords/for variables specially...
@@ -2762,22 +2762,22 @@ See `idlwave-surround'."
2762 (skip-chars-backward "= \t") 2762 (skip-chars-backward "= \t")
2763 (nth 2 (idlwave-where))))) 2763 (nth 2 (idlwave-where)))))
2764 (cond ((or (memq what '(function-keyword procedure-keyword)) 2764 (cond ((or (memq what '(function-keyword procedure-keyword))
2765 (memq (caar st) '(for pdef))) 2765 (memq (caar st) '(for pdef)))
2766 (cond 2766 (cond
2767 ((null idlwave-pad-keyword) 2767 ((null idlwave-pad-keyword)
2768 (idlwave-surround 0 0) 2768 (idlwave-surround 0 0)
2769 ) ; remove space 2769 ) ; remove space
2770 (t))) ; leave any spaces alone 2770 (t))) ; leave any spaces alone
2771 (t (idlwave-surround before after len)))))))) 2771 (t (idlwave-surround before after len))))))))
2772 2772
2773 2773
2774(defun idlwave-indent-and-action (&optional arg) 2774(defun idlwave-indent-and-action (&optional arg)
2775 "Call `idlwave-indent-line' and do expand actions. 2775 "Call `idlwave-indent-line' and do expand actions.
2776With prefix ARG non-nil, indent the entire sub-statement." 2776With prefix ARG non-nil, indent the entire sub-statement."
2777 (interactive "p") 2777 (interactive "p")
2778 (save-excursion 2778 (save-excursion
2779 (if (and idlwave-expand-generic-end 2779 (if (and idlwave-expand-generic-end
2780 (re-search-backward "\\<\\(end\\)\\s-*\\=" 2780 (re-search-backward "\\<\\(end\\)\\s-*\\="
2781 (max 0 (- (point) 10)) t) 2781 (max 0 (- (point) 10)) t)
2782 (looking-at "\\(end\\)\\([ \n\t]\\|\\'\\)")) 2782 (looking-at "\\(end\\)\\([ \n\t]\\|\\'\\)"))
2783 (progn (goto-char (match-end 1)) 2783 (progn (goto-char (match-end 1))
@@ -2787,7 +2787,7 @@ With prefix ARG non-nil, indent the entire sub-statement."
2787 (when (and (not arg) current-prefix-arg) 2787 (when (and (not arg) current-prefix-arg)
2788 (setq arg current-prefix-arg) 2788 (setq arg current-prefix-arg)
2789 (setq current-prefix-arg nil)) 2789 (setq current-prefix-arg nil))
2790 (if arg 2790 (if arg
2791 (idlwave-indent-statement) 2791 (idlwave-indent-statement)
2792 (idlwave-indent-line t))) 2792 (idlwave-indent-line t)))
2793 2793
@@ -2922,7 +2922,7 @@ Inserts spaces before markers at point."
2922 (save-excursion 2922 (save-excursion
2923 (cond 2923 (cond
2924 ;; Beginning of file 2924 ;; Beginning of file
2925 ((prog1 2925 ((prog1
2926 (idlwave-previous-statement) 2926 (idlwave-previous-statement)
2927 (setq beg-prev-pos (point))) 2927 (setq beg-prev-pos (point)))
2928 0) 2928 0)
@@ -2932,7 +2932,7 @@ Inserts spaces before markers at point."
2932 idlwave-main-block-indent)) 2932 idlwave-main-block-indent))
2933 ;; Begin block 2933 ;; Begin block
2934 ((idlwave-look-at idlwave-begin-block-reg t) 2934 ((idlwave-look-at idlwave-begin-block-reg t)
2935 (+ (idlwave-min-current-statement-indent) 2935 (+ (idlwave-min-current-statement-indent)
2936 idlwave-block-indent)) 2936 idlwave-block-indent))
2937 ;; End Block 2937 ;; End Block
2938 ((idlwave-look-at idlwave-end-block-reg t) 2938 ((idlwave-look-at idlwave-end-block-reg t)
@@ -2943,7 +2943,7 @@ Inserts spaces before markers at point."
2943 (idlwave-min-current-statement-indent))) 2943 (idlwave-min-current-statement-indent)))
2944 ;; idlwave-end-offset 2944 ;; idlwave-end-offset
2945 ;; idlwave-block-indent)) 2945 ;; idlwave-block-indent))
2946 2946
2947 ;; Default to current indent 2947 ;; Default to current indent
2948 ((idlwave-current-statement-indent)))))) 2948 ((idlwave-current-statement-indent))))))
2949 ;; adjust the indentation based on the current statement 2949 ;; adjust the indentation based on the current statement
@@ -2959,7 +2959,7 @@ Inserts spaces before markers at point."
2959 2959
2960(defun idlwave-calculate-paren-indent (beg-reg end-reg close-exp) 2960(defun idlwave-calculate-paren-indent (beg-reg end-reg close-exp)
2961 "Calculate the continuation indent inside a paren group. 2961 "Calculate the continuation indent inside a paren group.
2962Returns a cons-cell with (open . indent), where open is the 2962Returns a cons-cell with (open . indent), where open is the
2963location of the open paren" 2963location of the open paren"
2964 (let ((open (nth 1 (parse-partial-sexp beg-reg end-reg)))) 2964 (let ((open (nth 1 (parse-partial-sexp beg-reg end-reg))))
2965 ;; Found an innermost open paren. 2965 ;; Found an innermost open paren.
@@ -3000,24 +3000,24 @@ groupings, are treated separately."
3000 (end-reg (progn (beginning-of-line) (point))) 3000 (end-reg (progn (beginning-of-line) (point)))
3001 (beg-last-statement (save-excursion (idlwave-previous-statement) 3001 (beg-last-statement (save-excursion (idlwave-previous-statement)
3002 (point))) 3002 (point)))
3003 (beg-reg (progn (idlwave-start-of-substatement 'pre) 3003 (beg-reg (progn (idlwave-start-of-substatement 'pre)
3004 (if (eq (line-beginning-position) end-reg) 3004 (if (eq (line-beginning-position) end-reg)
3005 (goto-char beg-last-statement) 3005 (goto-char beg-last-statement)
3006 (point)))) 3006 (point))))
3007 (basic-indent (+ (idlwave-min-current-statement-indent end-reg) 3007 (basic-indent (+ (idlwave-min-current-statement-indent end-reg)
3008 idlwave-continuation-indent)) 3008 idlwave-continuation-indent))
3009 fancy-nonparen-indent fancy-paren-indent) 3009 fancy-nonparen-indent fancy-paren-indent)
3010 (cond 3010 (cond
3011 ;; Align then with its matching if, etc. 3011 ;; Align then with its matching if, etc.
3012 ((let ((matchers '(("\\<if\\>" . "[ \t]*then") 3012 ((let ((matchers '(("\\<if\\>" . "[ \t]*then")
3013 ("\\<\\(if\\|end\\(if\\)?\\)\\>" . "[ \t]*else") 3013 ("\\<\\(if\\|end\\(if\\)?\\)\\>" . "[ \t]*else")
3014 ("\\<\\(for\\|while\\)\\>" . "[ \t]*do") 3014 ("\\<\\(for\\|while\\)\\>" . "[ \t]*do")
3015 ("\\<\\(repeat\\|end\\(rep\\)?\\)\\>" . 3015 ("\\<\\(repeat\\|end\\(rep\\)?\\)\\>" .
3016 "[ \t]*until") 3016 "[ \t]*until")
3017 ("\\<case\\>" . "[ \t]*of"))) 3017 ("\\<case\\>" . "[ \t]*of")))
3018 match cont-re) 3018 match cont-re)
3019 (goto-char end-reg) 3019 (goto-char end-reg)
3020 (and 3020 (and
3021 (setq cont-re 3021 (setq cont-re
3022 (catch 'exit 3022 (catch 'exit
3023 (while (setq match (car matchers)) 3023 (while (setq match (car matchers))
@@ -3026,7 +3026,7 @@ groupings, are treated separately."
3026 (setq matchers (cdr matchers))))) 3026 (setq matchers (cdr matchers)))))
3027 (idlwave-find-key cont-re -1 'nomark beg-last-statement))) 3027 (idlwave-find-key cont-re -1 'nomark beg-last-statement)))
3028 (if (looking-at "end") ;; that one's special 3028 (if (looking-at "end") ;; that one's special
3029 (- (idlwave-current-indent) 3029 (- (idlwave-current-indent)
3030 (+ idlwave-block-indent idlwave-end-offset)) 3030 (+ idlwave-block-indent idlwave-end-offset))
3031 (idlwave-current-indent))) 3031 (idlwave-current-indent)))
3032 3032
@@ -3052,7 +3052,7 @@ groupings, are treated separately."
3052 (let* ((end-reg end-reg) 3052 (let* ((end-reg end-reg)
3053 (close-exp (progn 3053 (close-exp (progn
3054 (goto-char end-reg) 3054 (goto-char end-reg)
3055 (skip-chars-forward " \t") 3055 (skip-chars-forward " \t")
3056 (looking-at "\\s)"))) 3056 (looking-at "\\s)")))
3057 indent-cons) 3057 indent-cons)
3058 (catch 'loop 3058 (catch 'loop
@@ -3086,12 +3086,12 @@ groupings, are treated separately."
3086 (if (save-match-data (looking-at "[ \t$]*\\(;.*\\)?$")) 3086 (if (save-match-data (looking-at "[ \t$]*\\(;.*\\)?$"))
3087 nil 3087 nil
3088 (current-column))) 3088 (current-column)))
3089 3089
3090 ;; Continued assignment (with =): 3090 ;; Continued assignment (with =):
3091 ((catch 'assign ; 3091 ((catch 'assign ;
3092 (while (looking-at "[^=\n\r]*\\(=\\)[ \t]*") 3092 (while (looking-at "[^=\n\r]*\\(=\\)[ \t]*")
3093 (goto-char (match-end 0)) 3093 (goto-char (match-end 0))
3094 (if (null (idlwave-what-function beg-reg)) 3094 (if (null (idlwave-what-function beg-reg))
3095 (throw 'assign t)))) 3095 (throw 'assign t))))
3096 (unless (or 3096 (unless (or
3097 (idlwave-in-quote) 3097 (idlwave-in-quote)
@@ -3153,7 +3153,7 @@ possibility of unbalanced blocks."
3153 (let* ((here (point)) 3153 (let* ((here (point))
3154 (case-fold-search t) 3154 (case-fold-search t)
3155 (limit (if (>= dir 0) (point-max) (point-min))) 3155 (limit (if (>= dir 0) (point-max) (point-min)))
3156 (block-limit (if (>= dir 0) 3156 (block-limit (if (>= dir 0)
3157 idlwave-begin-block-reg 3157 idlwave-begin-block-reg
3158 idlwave-end-block-reg)) 3158 idlwave-end-block-reg))
3159 found 3159 found
@@ -3164,7 +3164,7 @@ possibility of unbalanced blocks."
3164 (idlwave-find-key 3164 (idlwave-find-key
3165 idlwave-begin-unit-reg dir t limit) 3165 idlwave-begin-unit-reg dir t limit)
3166 (end-of-line) 3166 (end-of-line)
3167 (idlwave-find-key 3167 (idlwave-find-key
3168 idlwave-end-unit-reg dir t limit))) 3168 idlwave-end-unit-reg dir t limit)))
3169 limit))) 3169 limit)))
3170 (if (>= dir 0) (end-of-line)) ;Make sure we are in current block 3170 (if (>= dir 0) (end-of-line)) ;Make sure we are in current block
@@ -3189,7 +3189,7 @@ possibility of unbalanced blocks."
3189 (or (null end-reg) (< (point) end-reg))) 3189 (or (null end-reg) (< (point) end-reg)))
3190 (unless comm-or-empty (setq min (min min (idlwave-current-indent))))) 3190 (unless comm-or-empty (setq min (min min (idlwave-current-indent)))))
3191 (if (or comm-or-empty (and end-reg (>= (point) end-reg))) 3191 (if (or comm-or-empty (and end-reg (>= (point) end-reg)))
3192 min 3192 min
3193 (min min (idlwave-current-indent)))))) 3193 (min min (idlwave-current-indent))))))
3194 3194
3195(defun idlwave-current-statement-indent (&optional last-line) 3195(defun idlwave-current-statement-indent (&optional last-line)
@@ -3216,10 +3216,10 @@ Blank or comment-only lines following regular continuation lines (with
3216`$') count as continuations too." 3216`$') count as continuations too."
3217 (let (p) 3217 (let (p)
3218 (save-excursion 3218 (save-excursion
3219 (or 3219 (or
3220 (idlwave-look-at "\\<\\$") 3220 (idlwave-look-at "\\<\\$")
3221 (catch 'loop 3221 (catch 'loop
3222 (while (and (looking-at "^[ \t]*\\(;.*\\)?$") 3222 (while (and (looking-at "^[ \t]*\\(;.*\\)?$")
3223 (eq (forward-line -1) 0)) 3223 (eq (forward-line -1) 0))
3224 (if (setq p (idlwave-look-at "\\<\\$")) (throw 'loop p)))))))) 3224 (if (setq p (idlwave-look-at "\\<\\$")) (throw 'loop p))))))))
3225 3225
@@ -3317,7 +3317,7 @@ ignored."
3317 (beginning-of-line) (point)) 3317 (beginning-of-line) (point))
3318 (point)))) 3318 (point))))
3319 "[^;]")) 3319 "[^;]"))
3320 3320
3321 ;; Mark the beginning and end of the paragraph 3321 ;; Mark the beginning and end of the paragraph
3322 (goto-char bcl) 3322 (goto-char bcl)
3323 (while (and (looking-at fill-prefix-reg) 3323 (while (and (looking-at fill-prefix-reg)
@@ -3381,7 +3381,7 @@ ignored."
3381 (insert (make-string diff ?\ )))) 3381 (insert (make-string diff ?\ ))))
3382 (forward-line -1)) 3382 (forward-line -1))
3383 ) 3383 )
3384 3384
3385 ;; No hang. Instead find minimum indentation of paragraph 3385 ;; No hang. Instead find minimum indentation of paragraph
3386 ;; after first line. 3386 ;; after first line.
3387 ;; For the following while statement, since START is at the 3387 ;; For the following while statement, since START is at the
@@ -3413,7 +3413,7 @@ ignored."
3413 t) 3413 t)
3414 (current-column)) 3414 (current-column))
3415 indent)) 3415 indent))
3416 3416
3417 ;; try to keep point at its original place 3417 ;; try to keep point at its original place
3418 (goto-char here) 3418 (goto-char here)
3419 3419
@@ -3462,7 +3462,7 @@ If not found returns nil."
3462 (current-column))))) 3462 (current-column)))))
3463 3463
3464(defun idlwave-auto-fill () 3464(defun idlwave-auto-fill ()
3465 "Called to break lines in auto fill mode. 3465 "Called to break lines in auto fill mode.
3466Only fills non-comment lines if `idlwave-fill-comment-line-only' is 3466Only fills non-comment lines if `idlwave-fill-comment-line-only' is
3467non-nil. Places a continuation character at the end of the line if 3467non-nil. Places a continuation character at the end of the line if
3468not in a comment. Splits strings with IDL concatenation operator `+' 3468not in a comment. Splits strings with IDL concatenation operator `+'
@@ -3613,7 +3613,7 @@ is non-nil."
3613 (insert (current-time-string)) 3613 (insert (current-time-string))
3614 (insert ", " (user-full-name)) 3614 (insert ", " (user-full-name))
3615 (if (boundp 'user-mail-address) 3615 (if (boundp 'user-mail-address)
3616 (insert " <" user-mail-address ">") 3616 (insert " <" user-mail-address ">")
3617 (insert " <" (user-login-name) "@" (system-name) ">")) 3617 (insert " <" (user-login-name) "@" (system-name) ">"))
3618 ;; Remove extra spaces from line 3618 ;; Remove extra spaces from line
3619 (idlwave-fill-paragraph) 3619 (idlwave-fill-paragraph)
@@ -3639,7 +3639,7 @@ location on mark ring so that the user can return to previous point."
3639 (setq end (match-end 0))) 3639 (setq end (match-end 0)))
3640 (progn 3640 (progn
3641 (goto-char beg) 3641 (goto-char beg)
3642 (if (re-search-forward 3642 (if (re-search-forward
3643 (concat idlwave-doc-modifications-keyword ":") 3643 (concat idlwave-doc-modifications-keyword ":")
3644 end t) 3644 end t)
3645 (end-of-line) 3645 (end-of-line)
@@ -3737,7 +3737,7 @@ constants - a double quote followed by an octal digit."
3737 (not (idlwave-in-quote)) 3737 (not (idlwave-in-quote))
3738 (save-excursion 3738 (save-excursion
3739 (forward-char) 3739 (forward-char)
3740 (re-search-backward (concat "\\(" idlwave-idl-keywords 3740 (re-search-backward (concat "\\(" idlwave-idl-keywords
3741 "\\|[[(*+-/=,^><]\\)\\s-*\\*") limit t))))) 3741 "\\|[[(*+-/=,^><]\\)\\s-*\\*") limit t)))))
3742 3742
3743 3743
@@ -3783,7 +3783,7 @@ unless the optional second argument NOINDENT is non-nil."
3783 (indent-region beg end nil)) 3783 (indent-region beg end nil))
3784 (if (stringp prompt) 3784 (if (stringp prompt)
3785 (message prompt))))) 3785 (message prompt)))))
3786 3786
3787(defun idlwave-rw-case (string) 3787(defun idlwave-rw-case (string)
3788 "Make STRING have the case required by `idlwave-reserved-word-upcase'." 3788 "Make STRING have the case required by `idlwave-reserved-word-upcase'."
3789 (if idlwave-reserved-word-upcase 3789 (if idlwave-reserved-word-upcase
@@ -3801,7 +3801,7 @@ unless the optional second argument NOINDENT is non-nil."
3801(defun idlwave-case () 3801(defun idlwave-case ()
3802 "Build skeleton IDL case statement." 3802 "Build skeleton IDL case statement."
3803 (interactive) 3803 (interactive)
3804 (idlwave-template 3804 (idlwave-template
3805 (idlwave-rw-case "case") 3805 (idlwave-rw-case "case")
3806 (idlwave-rw-case " of\n\nendcase") 3806 (idlwave-rw-case " of\n\nendcase")
3807 "Selector expression")) 3807 "Selector expression"))
@@ -3809,7 +3809,7 @@ unless the optional second argument NOINDENT is non-nil."
3809(defun idlwave-switch () 3809(defun idlwave-switch ()
3810 "Build skeleton IDL switch statement." 3810 "Build skeleton IDL switch statement."
3811 (interactive) 3811 (interactive)
3812 (idlwave-template 3812 (idlwave-template
3813 (idlwave-rw-case "switch") 3813 (idlwave-rw-case "switch")
3814 (idlwave-rw-case " of\n\nendswitch") 3814 (idlwave-rw-case " of\n\nendswitch")
3815 "Selector expression")) 3815 "Selector expression"))
@@ -3817,7 +3817,7 @@ unless the optional second argument NOINDENT is non-nil."
3817(defun idlwave-for () 3817(defun idlwave-for ()
3818 "Build skeleton for loop statment." 3818 "Build skeleton for loop statment."
3819 (interactive) 3819 (interactive)
3820 (idlwave-template 3820 (idlwave-template
3821 (idlwave-rw-case "for") 3821 (idlwave-rw-case "for")
3822 (idlwave-rw-case " do begin\n\nendfor") 3822 (idlwave-rw-case " do begin\n\nendfor")
3823 "Loop expression")) 3823 "Loop expression"))
@@ -3832,14 +3832,14 @@ unless the optional second argument NOINDENT is non-nil."
3832 3832
3833(defun idlwave-procedure () 3833(defun idlwave-procedure ()
3834 (interactive) 3834 (interactive)
3835 (idlwave-template 3835 (idlwave-template
3836 (idlwave-rw-case "pro") 3836 (idlwave-rw-case "pro")
3837 (idlwave-rw-case "\n\nreturn\nend") 3837 (idlwave-rw-case "\n\nreturn\nend")
3838 "Procedure name")) 3838 "Procedure name"))
3839 3839
3840(defun idlwave-function () 3840(defun idlwave-function ()
3841 (interactive) 3841 (interactive)
3842 (idlwave-template 3842 (idlwave-template
3843 (idlwave-rw-case "function") 3843 (idlwave-rw-case "function")
3844 (idlwave-rw-case "\n\nreturn\nend") 3844 (idlwave-rw-case "\n\nreturn\nend")
3845 "Function name")) 3845 "Function name"))
@@ -3853,7 +3853,7 @@ unless the optional second argument NOINDENT is non-nil."
3853 3853
3854(defun idlwave-while () 3854(defun idlwave-while ()
3855 (interactive) 3855 (interactive)
3856 (idlwave-template 3856 (idlwave-template
3857 (idlwave-rw-case "while") 3857 (idlwave-rw-case "while")
3858 (idlwave-rw-case " do begin\n\nendwhile") 3858 (idlwave-rw-case " do begin\n\nendwhile")
3859 "Entry condition")) 3859 "Entry condition"))
@@ -3932,8 +3932,8 @@ Buffer containing unsaved changes require confirmation before they are killed."
3932(defun idlwave-count-outlawed-buffers (tag) 3932(defun idlwave-count-outlawed-buffers (tag)
3933 "How many outlawed buffers have tag TAG?" 3933 "How many outlawed buffers have tag TAG?"
3934 (length (delq nil 3934 (length (delq nil
3935 (mapcar 3935 (mapcar
3936 (lambda (x) (eq (cdr x) tag)) 3936 (lambda (x) (eq (cdr x) tag))
3937 idlwave-outlawed-buffers)))) 3937 idlwave-outlawed-buffers))))
3938 3938
3939(defun idlwave-do-kill-autoloaded-buffers (&rest reasons) 3939(defun idlwave-do-kill-autoloaded-buffers (&rest reasons)
@@ -3947,9 +3947,9 @@ Buffer containing unsaved changes require confirmation before they are killed."
3947 (memq (cdr entry) reasons)) 3947 (memq (cdr entry) reasons))
3948 (kill-buffer (car entry)) 3948 (kill-buffer (car entry))
3949 (incf cnt) 3949 (incf cnt)
3950 (setq idlwave-outlawed-buffers 3950 (setq idlwave-outlawed-buffers
3951 (delq entry idlwave-outlawed-buffers))) 3951 (delq entry idlwave-outlawed-buffers)))
3952 (setq idlwave-outlawed-buffers 3952 (setq idlwave-outlawed-buffers
3953 (delq entry idlwave-outlawed-buffers)))) 3953 (delq entry idlwave-outlawed-buffers))))
3954 (message "%d buffer%s killed" cnt (if (= cnt 1) "" "s")))) 3954 (message "%d buffer%s killed" cnt (if (= cnt 1) "" "s"))))
3955 3955
@@ -3961,7 +3961,7 @@ Intended for `after-save-hook'."
3961 (entry (assq buf idlwave-outlawed-buffers))) 3961 (entry (assq buf idlwave-outlawed-buffers)))
3962 ;; Revoke license 3962 ;; Revoke license
3963 (if entry 3963 (if entry
3964 (setq idlwave-outlawed-buffers 3964 (setq idlwave-outlawed-buffers
3965 (delq entry idlwave-outlawed-buffers))) 3965 (delq entry idlwave-outlawed-buffers)))
3966 ;; Remove this function from the hook. 3966 ;; Remove this function from the hook.
3967 (remove-hook 'after-save-hook 'idlwave-revoke-license-to-kill 'local))) 3967 (remove-hook 'after-save-hook 'idlwave-revoke-license-to-kill 'local)))
@@ -3980,7 +3980,7 @@ Intended for `after-save-hook'."
3980(defun idlwave-expand-lib-file-name (file) 3980(defun idlwave-expand-lib-file-name (file)
3981 ;; Find FILE on the scanned lib path and return a buffer visiting it 3981 ;; Find FILE on the scanned lib path and return a buffer visiting it
3982 ;; This is for, e.g., finding source with no user catalog 3982 ;; This is for, e.g., finding source with no user catalog
3983 (cond 3983 (cond
3984 ((null file) nil) 3984 ((null file) nil)
3985 ((file-name-absolute-p file) file) 3985 ((file-name-absolute-p file) file)
3986 (t (idlwave-locate-lib-file file)))) 3986 (t (idlwave-locate-lib-file file))))
@@ -3995,7 +3995,7 @@ you specify /."
3995 (interactive) 3995 (interactive)
3996 (let (directory directories cmd append status numdirs dir getsubdirs 3996 (let (directory directories cmd append status numdirs dir getsubdirs
3997 buffer save_buffer files numfiles item errbuf) 3997 buffer save_buffer files numfiles item errbuf)
3998 3998
3999 ;; 3999 ;;
4000 ;; Read list of directories 4000 ;; Read list of directories
4001 (setq directory (read-string "Tag Directories: " ".")) 4001 (setq directory (read-string "Tag Directories: " "."))
@@ -4047,7 +4047,7 @@ you specify /."
4047 (message "%s" (concat "Tagging " item "...")) 4047 (message "%s" (concat "Tagging " item "..."))
4048 (setq errbuf (get-buffer-create "*idltags-error*")) 4048 (setq errbuf (get-buffer-create "*idltags-error*"))
4049 (setq status (+ status 4049 (setq status (+ status
4050 (if (eq 0 (call-process 4050 (if (eq 0 (call-process
4051 "sh" nil errbuf nil "-c" 4051 "sh" nil errbuf nil "-c"
4052 (concat cmd append item))) 4052 (concat cmd append item)))
4053 0 4053 0
@@ -4061,13 +4061,13 @@ you specify /."
4061 (setq numfiles (1+ numfiles)) 4061 (setq numfiles (1+ numfiles))
4062 (setq item (nth numfiles files)) 4062 (setq item (nth numfiles files))
4063 ))) 4063 )))
4064 4064
4065 (setq numdirs (1+ numdirs)) 4065 (setq numdirs (1+ numdirs))
4066 (setq dir (nth numdirs directories))) 4066 (setq dir (nth numdirs directories)))
4067 (progn 4067 (progn
4068 (setq numdirs (1+ numdirs)) 4068 (setq numdirs (1+ numdirs))
4069 (setq dir (nth numdirs directories))))) 4069 (setq dir (nth numdirs directories)))))
4070 4070
4071 (setq errbuf (get-buffer-create "*idltags-error*")) 4071 (setq errbuf (get-buffer-create "*idltags-error*"))
4072 (if (= status 0) 4072 (if (= status 0)
4073 (kill-buffer errbuf)) 4073 (kill-buffer errbuf))
@@ -4143,7 +4143,7 @@ blank lines."
4143 ;; Make sure the hash functions are accessible. 4143 ;; Make sure the hash functions are accessible.
4144 (if (or (not (fboundp 'gethash)) 4144 (if (or (not (fboundp 'gethash))
4145 (not (fboundp 'puthash))) 4145 (not (fboundp 'puthash)))
4146 (progn 4146 (progn
4147 (require 'cl) 4147 (require 'cl)
4148 (or (fboundp 'puthash) 4148 (or (fboundp 'puthash)
4149 (defalias 'puthash 'cl-puthash)))) 4149 (defalias 'puthash 'cl-puthash))))
@@ -4162,7 +4162,7 @@ blank lines."
4162 (null (cdr idlwave-sint-routines))) 4162 (null (cdr idlwave-sint-routines)))
4163 (loop for entry in entries 4163 (loop for entry in entries
4164 for var = (car entry) for size = (nth 1 entry) 4164 for var = (car entry) for size = (nth 1 entry)
4165 do (setcdr (symbol-value var) 4165 do (setcdr (symbol-value var)
4166 (make-hash-table ':size size ':test 'equal))) 4166 (make-hash-table ':size size ':test 'equal)))
4167 (setq idlwave-sint-dirs nil 4167 (setq idlwave-sint-dirs nil
4168 idlwave-sint-libnames nil)) 4168 idlwave-sint-libnames nil))
@@ -4172,7 +4172,7 @@ blank lines."
4172 (null (car idlwave-sint-routines))) 4172 (null (car idlwave-sint-routines)))
4173 (loop for entry in entries 4173 (loop for entry in entries
4174 for var = (car entry) for size = (nth 1 entry) 4174 for var = (car entry) for size = (nth 1 entry)
4175 do (setcar (symbol-value var) 4175 do (setcar (symbol-value var)
4176 (make-hash-table ':size size ':test 'equal)))))) 4176 (make-hash-table ':size size ':test 'equal))))))
4177 4177
4178(defun idlwave-sintern-routine-or-method (name &optional class set) 4178(defun idlwave-sintern-routine-or-method (name &optional class set)
@@ -4259,11 +4259,11 @@ If DEFAULT-DIR is passed, it is used as the base of the directory"
4259 (setq class (idlwave-sintern-class class set)) 4259 (setq class (idlwave-sintern-class class set))
4260 (setq name (idlwave-sintern-method name set))) 4260 (setq name (idlwave-sintern-method name set)))
4261 (setq name (idlwave-sintern-routine name set))) 4261 (setq name (idlwave-sintern-routine name set)))
4262 4262
4263 ;; The source 4263 ;; The source
4264 (let ((source-type (car source)) 4264 (let ((source-type (car source))
4265 (source-file (nth 1 source)) 4265 (source-file (nth 1 source))
4266 (source-dir (if default-dir 4266 (source-dir (if default-dir
4267 (file-name-as-directory default-dir) 4267 (file-name-as-directory default-dir)
4268 (nth 2 source))) 4268 (nth 2 source)))
4269 (source-lib (nth 3 source))) 4269 (source-lib (nth 3 source)))
@@ -4272,7 +4272,7 @@ If DEFAULT-DIR is passed, it is used as the base of the directory"
4272 (if (stringp source-lib) 4272 (if (stringp source-lib)
4273 (setq source-lib (idlwave-sintern-libname source-lib set))) 4273 (setq source-lib (idlwave-sintern-libname source-lib set)))
4274 (setq source (list source-type source-file source-dir source-lib))) 4274 (setq source (list source-type source-file source-dir source-lib)))
4275 4275
4276 ;; The keywords 4276 ;; The keywords
4277 (setq kwds (mapcar (lambda (x) 4277 (setq kwds (mapcar (lambda (x)
4278 (idlwave-sintern-keyword-list x set)) 4278 (idlwave-sintern-keyword-list x set))
@@ -4407,15 +4407,15 @@ will re-read the catalog."
4407 (not (stringp idlwave-user-catalog-file)) 4407 (not (stringp idlwave-user-catalog-file))
4408 (not (file-regular-p idlwave-user-catalog-file))) 4408 (not (file-regular-p idlwave-user-catalog-file)))
4409 (error "No catalog has been produced yet")) 4409 (error "No catalog has been produced yet"))
4410 (let* ((emacs (expand-file-name (invocation-name) (invocation-directory))) 4410 (let* ((emacs (concat invocation-directory invocation-name))
4411 (args (list "-batch" 4411 (args (list "-batch"
4412 "-l" (expand-file-name "~/.emacs") 4412 "-l" (expand-file-name "~/.emacs")
4413 "-l" "idlwave" 4413 "-l" "idlwave"
4414 "-f" "idlwave-rescan-catalog-directories")) 4414 "-f" "idlwave-rescan-catalog-directories"))
4415 (process (apply 'start-process "idlcat" 4415 (process (apply 'start-process "idlcat"
4416 nil emacs args))) 4416 nil emacs args)))
4417 (setq idlwave-catalog-process process) 4417 (setq idlwave-catalog-process process)
4418 (set-process-sentinel 4418 (set-process-sentinel
4419 process 4419 process
4420 (lambda (pro why) 4420 (lambda (pro why)
4421 (when (string-match "finished" why) 4421 (when (string-match "finished" why)
@@ -4432,7 +4432,7 @@ will re-read the catalog."
4432;; ("ROUTINE" type class 4432;; ("ROUTINE" type class
4433;; (system) | (lib pro_file dir "LIBNAME") | (user pro_file dir "USERLIB") | 4433;; (system) | (lib pro_file dir "LIBNAME") | (user pro_file dir "USERLIB") |
4434;; (buffer pro_file dir) | (compiled pro_file dir) 4434;; (buffer pro_file dir) | (compiled pro_file dir)
4435;; "calling_string" ("HELPFILE" (("KWD1" . link1) ...)) 4435;; "calling_string" ("HELPFILE" (("KWD1" . link1) ...))
4436;; ("HELPFILE2" (("KWD2" . link) ...)) ...) 4436;; ("HELPFILE2" (("KWD2" . link) ...)) ...)
4437;; 4437;;
4438;; DIR will be supplied dynamically while loading library catalogs, 4438;; DIR will be supplied dynamically while loading library catalogs,
@@ -4491,7 +4491,7 @@ information updated immediately, leave NO-CONCATENATE nil."
4491 ;; The override-idle means, even if the idle timer has done some 4491 ;; The override-idle means, even if the idle timer has done some
4492 ;; preparing work, load and renormalize everything anyway. 4492 ;; preparing work, load and renormalize everything anyway.
4493 (override-idle (or arg idlwave-buffer-case-takes-precedence))) 4493 (override-idle (or arg idlwave-buffer-case-takes-precedence)))
4494 4494
4495 (setq idlwave-buffer-routines nil 4495 (setq idlwave-buffer-routines nil
4496 idlwave-compiled-routines nil 4496 idlwave-compiled-routines nil
4497 idlwave-unresolved-routines nil) 4497 idlwave-unresolved-routines nil)
@@ -4502,7 +4502,7 @@ information updated immediately, leave NO-CONCATENATE nil."
4502 (idlwave-reset-sintern (cond (load t) 4502 (idlwave-reset-sintern (cond (load t)
4503 ((null idlwave-system-routines) t) 4503 ((null idlwave-system-routines) t)
4504 (t 'bufsh)))) 4504 (t 'bufsh))))
4505 4505
4506 (if idlwave-buffer-case-takes-precedence 4506 (if idlwave-buffer-case-takes-precedence
4507 ;; We can safely scan the buffer stuff first 4507 ;; We can safely scan the buffer stuff first
4508 (progn 4508 (progn
@@ -4517,9 +4517,9 @@ information updated immediately, leave NO-CONCATENATE nil."
4517 (idlwave-shell-is-running))) 4517 (idlwave-shell-is-running)))
4518 (ask-shell (and shell-is-running 4518 (ask-shell (and shell-is-running
4519 idlwave-query-shell-for-routine-info))) 4519 idlwave-query-shell-for-routine-info)))
4520 4520
4521 ;; Load the library catalogs again, first re-scanning the path 4521 ;; Load the library catalogs again, first re-scanning the path
4522 (when arg 4522 (when arg
4523 (if shell-is-running 4523 (if shell-is-running
4524 (idlwave-shell-send-command idlwave-shell-path-query 4524 (idlwave-shell-send-command idlwave-shell-path-query
4525 '(progn 4525 '(progn
@@ -4539,7 +4539,7 @@ information updated immediately, leave NO-CONCATENATE nil."
4539 ;; Therefore, we do a concatenation now, even though 4539 ;; Therefore, we do a concatenation now, even though
4540 ;; the shell might do it again. 4540 ;; the shell might do it again.
4541 (idlwave-concatenate-rinfo-lists nil 'run-hooks)) 4541 (idlwave-concatenate-rinfo-lists nil 'run-hooks))
4542 4542
4543 (when ask-shell 4543 (when ask-shell
4544 ;; Ask the shell about the routines it knows of. 4544 ;; Ask the shell about the routines it knows of.
4545 (message "Querying the shell") 4545 (message "Querying the shell")
@@ -4576,26 +4576,26 @@ information updated immediately, leave NO-CONCATENATE nil."
4576 ;; which, if necessary, will be re-created from the XML file on 4576 ;; which, if necessary, will be re-created from the XML file on
4577 ;; disk. As a last fallback, load the (likely outdated) idlw-rinfo 4577 ;; disk. As a last fallback, load the (likely outdated) idlw-rinfo
4578 ;; file distributed with older IDLWAVE versions (<6.0) 4578 ;; file distributed with older IDLWAVE versions (<6.0)
4579 (unless (and (load idlwave-xml-system-rinfo-converted-file 4579 (unless (and (load idlwave-xml-system-rinfo-converted-file
4580 'noerror 'nomessage) 4580 'noerror 'nomessage)
4581 (idlwave-xml-system-routine-info-up-to-date)) 4581 (idlwave-xml-system-routine-info-up-to-date))
4582 ;; See if we can create it from XML source 4582 ;; See if we can create it from XML source
4583 (condition-case nil 4583 (condition-case nil
4584 (idlwave-convert-xml-system-routine-info) 4584 (idlwave-convert-xml-system-routine-info)
4585 (error 4585 (error
4586 (unless (load idlwave-xml-system-rinfo-converted-file 4586 (unless (load idlwave-xml-system-rinfo-converted-file
4587 'noerror 'nomessage) 4587 'noerror 'nomessage)
4588 (if idlwave-system-routines 4588 (if idlwave-system-routines
4589 (message 4589 (message
4590 "Failed to load converted routine info, using old conversion.") 4590 "Failed to load converted routine info, using old conversion.")
4591 (message 4591 (message
4592 "Failed to convert XML routine info, falling back on idlw-rinfo.") 4592 "Failed to convert XML routine info, falling back on idlw-rinfo.")
4593 (if (not (load "idlw-rinfo" 'noerror 'nomessage)) 4593 (if (not (load "idlw-rinfo" 'noerror 'nomessage))
4594 (message 4594 (message
4595 "Could not locate any system routine information.")))))))) 4595 "Could not locate any system routine information."))))))))
4596 4596
4597(defun idlwave-xml-system-routine-info-up-to-date() 4597(defun idlwave-xml-system-routine-info-up-to-date()
4598 (let* ((dir (file-name-as-directory 4598 (let* ((dir (file-name-as-directory
4599 (expand-file-name "help/online_help" (idlwave-sys-dir)))) 4599 (expand-file-name "help/online_help" (idlwave-sys-dir))))
4600 (catalog-file (expand-file-name "idl_catalog.xml" dir))) 4600 (catalog-file (expand-file-name "idl_catalog.xml" dir)))
4601 (file-newer-than-file-p ;converted file is newer than catalog 4601 (file-newer-than-file-p ;converted file is newer than catalog
@@ -4610,15 +4610,15 @@ Gets set in cached XML rinfo, or `idlw-rinfo.el'.")
4610 "Alist of system variables and their help files.") 4610 "Alist of system variables and their help files.")
4611(defvar idlwave-help-special-topic-words nil) 4611(defvar idlwave-help-special-topic-words nil)
4612 4612
4613 4613
4614(defun idlwave-shorten-syntax (syntax name &optional class) 4614(defun idlwave-shorten-syntax (syntax name &optional class)
4615 ;; From a list of syntax statments, shorten with %s and group with "or" 4615 ;; From a list of syntax statments, shorten with %s and group with "or"
4616 (let ((case-fold-search t)) 4616 (let ((case-fold-search t))
4617 (mapconcat 4617 (mapconcat
4618 (lambda (x) 4618 (lambda (x)
4619 (while (string-match name x) 4619 (while (string-match name x)
4620 (setq x (replace-match "%s" t t x))) 4620 (setq x (replace-match "%s" t t x)))
4621 (if class 4621 (if class
4622 (while (string-match class x) 4622 (while (string-match class x)
4623 (setq x (replace-match "%s" t t x)))) 4623 (setq x (replace-match "%s" t t x))))
4624 x) 4624 x)
@@ -4670,8 +4670,8 @@ Gets set in cached XML rinfo, or `idlw-rinfo.el'.")
4670 (put 'set-props 'matched t) 4670 (put 'set-props 'matched t)
4671 set-props) 4671 set-props)
4672 (t nil))) 4672 (t nil)))
4673 (setq methods-entry 4673 (setq methods-entry
4674 (nconc (idlwave-xml-create-rinfo-list pelem class extra-kwds) 4674 (nconc (idlwave-xml-create-rinfo-list pelem class extra-kwds)
4675 methods-entry))) 4675 methods-entry)))
4676 (t))) 4676 (t)))
4677 (setq params (cdr params))) 4677 (setq params (cdr params)))
@@ -4681,12 +4681,12 @@ Gets set in cached XML rinfo, or `idlw-rinfo.el'.")
4681 ; (message "Failed to match GetProperty in class %s" class)) 4681 ; (message "Failed to match GetProperty in class %s" class))
4682 ;(unless (get 'set-props 'matched) 4682 ;(unless (get 'set-props 'matched)
4683 ; (message "Failed to match SetProperty in class %s" class)) 4683 ; (message "Failed to match SetProperty in class %s" class))
4684 (setq class-entry 4684 (setq class-entry
4685 (if inherits 4685 (if inherits
4686 (list class (append '(inherits) inherits) (list 'link link)) 4686 (list class (append '(inherits) inherits) (list 'link link))
4687 (list class (list 'link link)))) 4687 (list class (list 'link link))))
4688 (cons class-entry methods-entry))) 4688 (cons class-entry methods-entry)))
4689 4689
4690(defun idlwave-xml-create-rinfo-list (xml-entry &optional class extra-kws) 4690(defun idlwave-xml-create-rinfo-list (xml-entry &optional class extra-kws)
4691 ;; Create correctly structured list elements from ROUTINE or METHOD 4691 ;; Create correctly structured list elements from ROUTINE or METHOD
4692 ;; XML list structures. Return a list of list elements, with more 4692 ;; XML list structures. Return a list of list elements, with more
@@ -4722,8 +4722,8 @@ Gets set in cached XML rinfo, or `idlw-rinfo.el'.")
4722 (setq kwd (cdr (assq 'name props)) 4722 (setq kwd (cdr (assq 'name props))
4723 klink (cdr (assq 'link props))) 4723 klink (cdr (assq 'link props)))
4724 (if (string-match "^\\[XY\\(Z?\\)\\]" kwd) 4724 (if (string-match "^\\[XY\\(Z?\\)\\]" kwd)
4725 (progn 4725 (progn
4726 (setq pref-list 4726 (setq pref-list
4727 (if (match-string 1 kwd) '("X" "Y" "Z") '("X" "Y")) 4727 (if (match-string 1 kwd) '("X" "Y" "Z") '("X" "Y"))
4728 kwd (substring kwd (match-end 0))) 4728 kwd (substring kwd (match-end 0)))
4729 (loop for x in pref-list do 4729 (loop for x in pref-list do
@@ -4732,7 +4732,7 @@ Gets set in cached XML rinfo, or `idlw-rinfo.el'.")
4732 4732
4733 (t))); Do nothing for the others 4733 (t))); Do nothing for the others
4734 (setq params (cdr params))) 4734 (setq params (cdr params)))
4735 4735
4736 ;; Debug 4736 ;; Debug
4737; (if (and (null (aref syntax-vec 0)) 4737; (if (and (null (aref syntax-vec 0))
4738; (null (aref syntax-vec 1)) 4738; (null (aref syntax-vec 1))
@@ -4749,16 +4749,16 @@ Gets set in cached XML rinfo, or `idlw-rinfo.el'.")
4749 (setq kwds (idlwave-rinfo-group-keywords kwds link)) 4749 (setq kwds (idlwave-rinfo-group-keywords kwds link))
4750 (loop for idx from 0 to 1 do 4750 (loop for idx from 0 to 1 do
4751 (if (aref syntax-vec idx) 4751 (if (aref syntax-vec idx)
4752 (push (append (list name (if (eq idx 0) 'pro 'fun) 4752 (push (append (list name (if (eq idx 0) 'pro 'fun)
4753 class '(system) 4753 class '(system)
4754 (idlwave-shorten-syntax 4754 (idlwave-shorten-syntax
4755 (aref syntax-vec idx) name class)) 4755 (aref syntax-vec idx) name class))
4756 kwds) result))) 4756 kwds) result)))
4757 result))) 4757 result)))
4758 4758
4759 4759
4760(defun idlwave-rinfo-group-keywords (kwds master-link) 4760(defun idlwave-rinfo-group-keywords (kwds master-link)
4761 ;; Group keywords by link file, as a list with elements 4761 ;; Group keywords by link file, as a list with elements
4762 ;; (linkfile ( ("KWD1" . link1) ("KWD2" . link2)) 4762 ;; (linkfile ( ("KWD1" . link1) ("KWD2" . link2))
4763 (let (kwd link anchor linkfiles block master-elt) 4763 (let (kwd link anchor linkfiles block master-elt)
4764 (while kwds 4764 (while kwds
@@ -4777,7 +4777,7 @@ Gets set in cached XML rinfo, or `idlw-rinfo.el'.")
4777 linkfiles 4777 linkfiles
4778 (cons master-elt (delq master-elt linkfiles))) 4778 (cons master-elt (delq master-elt linkfiles)))
4779 (push (list master-link) linkfiles)))) 4779 (push (list master-link) linkfiles))))
4780 4780
4781(defun idlwave-convert-xml-clean-statement-aliases (aliases) 4781(defun idlwave-convert-xml-clean-statement-aliases (aliases)
4782 ;; Clean up the syntax of routines which are actually aliases by 4782 ;; Clean up the syntax of routines which are actually aliases by
4783 ;; removing the "OR" from the statements 4783 ;; removing the "OR" from the statements
@@ -4790,7 +4790,7 @@ Gets set in cached XML rinfo, or `idlw-rinfo.el'.")
4790 4790
4791(defun idlwave-convert-xml-clean-routine-aliases (aliases) 4791(defun idlwave-convert-xml-clean-routine-aliases (aliases)
4792 ;; Duplicate and trim original routine aliases from rinfo list 4792 ;; Duplicate and trim original routine aliases from rinfo list
4793 ;; This if for, e.g. OPENR/OPENW/OPENU 4793 ;; This if for, e.g. OPENR/OPENW/OPENU
4794 (let (alias remove-list new parts all-parts) 4794 (let (alias remove-list new parts all-parts)
4795 (loop for x in aliases do 4795 (loop for x in aliases do
4796 (when (setq parts (split-string (cdr x) "/")) 4796 (when (setq parts (split-string (cdr x) "/"))
@@ -4799,7 +4799,7 @@ Gets set in cached XML rinfo, or `idlw-rinfo.el'.")
4799 (setq new (cons (cdr x) parts)) 4799 (setq new (cons (cdr x) parts))
4800 (push new all-parts)) 4800 (push new all-parts))
4801 (setcdr new (delete (car x) (cdr new))))) 4801 (setcdr new (delete (car x) (cdr new)))))
4802 4802
4803 ;; Add any missing aliases (separate by slashes) 4803 ;; Add any missing aliases (separate by slashes)
4804 (loop for x in all-parts do 4804 (loop for x in all-parts do
4805 (if (cdr x) 4805 (if (cdr x)
@@ -4843,7 +4843,7 @@ Gets set in cached XML rinfo, or `idlw-rinfo.el'.")
4843 props (car (cdr pelem))) 4843 props (car (cdr pelem)))
4844 (cond 4844 (cond
4845 ((eq ptype 'FIELD) 4845 ((eq ptype 'FIELD)
4846 (push (cons (cdr (assq 'name props)) 4846 (push (cons (cdr (assq 'name props))
4847 (cdr 4847 (cdr
4848 (idlwave-split-link-target (cdr (assq 'link props))))) 4848 (idlwave-split-link-target (cdr (assq 'link props)))))
4849 tags)))) 4849 tags))))
@@ -4857,10 +4857,10 @@ Gets set in cached XML rinfo, or `idlw-rinfo.el'.")
4857(defun idlwave-save-routine-info () 4857(defun idlwave-save-routine-info ()
4858 (if idlwave-xml-routine-info-file 4858 (if idlwave-xml-routine-info-file
4859 (with-temp-file idlwave-xml-system-rinfo-converted-file 4859 (with-temp-file idlwave-xml-system-rinfo-converted-file
4860 (insert 4860 (insert
4861 (concat ";; *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* 4861 (concat ";; *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*
4862;; IDLWAVE Routine Information File (IDLWAVE version " idlwave-mode-version ") 4862;; IDLWAVE Routine Information File (IDLWAVE version " idlwave-mode-version ")
4863;; Automatically generated from source file: 4863;; Automatically generated from source file:
4864;; " idlwave-xml-routine-info-file " 4864;; " idlwave-xml-routine-info-file "
4865;; on " (current-time-string) " 4865;; on " (current-time-string) "
4866;; Do not edit.")) 4866;; Do not edit."))
@@ -4886,11 +4886,11 @@ Gets set in cached XML rinfo, or `idlw-rinfo.el'.")
4886 "Convert XML supplied IDL routine info into internal form. 4886 "Convert XML supplied IDL routine info into internal form.
4887Cache to disk for quick recovery." 4887Cache to disk for quick recovery."
4888 (interactive) 4888 (interactive)
4889 (let* ((dir (file-name-as-directory 4889 (let* ((dir (file-name-as-directory
4890 (expand-file-name "help/online_help" (idlwave-sys-dir)))) 4890 (expand-file-name "help/online_help" (idlwave-sys-dir))))
4891 (catalog-file (expand-file-name "idl_catalog.xml" dir)) 4891 (catalog-file (expand-file-name "idl_catalog.xml" dir))
4892 (elem-cnt 0) 4892 (elem-cnt 0)
4893 props rinfo msg-cnt elem type nelem class-result alias 4893 props rinfo msg-cnt elem type nelem class-result alias
4894 routines routine-aliases statement-aliases sysvar-aliases 4894 routines routine-aliases statement-aliases sysvar-aliases
4895 buf version-string) 4895 buf version-string)
4896 (if (not (file-exists-p catalog-file)) 4896 (if (not (file-exists-p catalog-file))
@@ -4898,7 +4898,7 @@ Cache to disk for quick recovery."
4898 (if (not (file-readable-p catalog-file)) 4898 (if (not (file-readable-p catalog-file))
4899 (error "Cannot read XML routine info file: %s" catalog-file))) 4899 (error "Cannot read XML routine info file: %s" catalog-file)))
4900 (require 'xml) 4900 (require 'xml)
4901 (message "Reading XML routine info...") 4901 (message "Reading XML routine info...")
4902 (unwind-protect 4902 (unwind-protect
4903 (progn 4903 (progn
4904 ;; avoid warnings about read-only files 4904 ;; avoid warnings about read-only files
@@ -4909,13 +4909,13 @@ Cache to disk for quick recovery."
4909 (setq rinfo (assq 'CATALOG rinfo)) 4909 (setq rinfo (assq 'CATALOG rinfo))
4910 (unless rinfo (error "Failed to parse XML routine info")) 4910 (unless rinfo (error "Failed to parse XML routine info"))
4911 ;;(setq rinfo (car rinfo)) ; Skip the catalog stuff. 4911 ;;(setq rinfo (car rinfo)) ; Skip the catalog stuff.
4912 4912
4913 (setq version-string (cdr (assq 'version (nth 1 rinfo))) 4913 (setq version-string (cdr (assq 'version (nth 1 rinfo)))
4914 rinfo (cddr rinfo)) 4914 rinfo (cddr rinfo))
4915 4915
4916 (setq nelem (length rinfo) 4916 (setq nelem (length rinfo)
4917 msg-cnt (/ nelem 20)) 4917 msg-cnt (/ nelem 20))
4918 4918
4919 (setq idlwave-xml-routine-info-file nil) 4919 (setq idlwave-xml-routine-info-file nil)
4920 (message "Converting XML routine info...") 4920 (message "Converting XML routine info...")
4921 (setq idlwave-system-routines nil 4921 (setq idlwave-system-routines nil
@@ -4932,12 +4932,12 @@ Cache to disk for quick recovery."
4932 (setq type (car elem) 4932 (setq type (car elem)
4933 props (car (cdr elem))) 4933 props (car (cdr elem)))
4934 (if (= (mod elem-cnt msg-cnt) 0) 4934 (if (= (mod elem-cnt msg-cnt) 0)
4935 (message "Converting XML routine info...%2d%%" 4935 (message "Converting XML routine info...%2d%%"
4936 (/ (* elem-cnt 100) nelem))) 4936 (/ (* elem-cnt 100) nelem)))
4937 (cond 4937 (cond
4938 ((eq type 'ROUTINE) 4938 ((eq type 'ROUTINE)
4939 (if (setq alias (assq 'alias_to props)) 4939 (if (setq alias (assq 'alias_to props))
4940 (push (cons (cdr (assq 'name props)) (cdr alias)) 4940 (push (cons (cdr (assq 'name props)) (cdr alias))
4941 routine-aliases) 4941 routine-aliases)
4942 (setq routines (idlwave-xml-create-rinfo-list elem)) 4942 (setq routines (idlwave-xml-create-rinfo-list elem))
4943 (if (listp (cdr routines)) 4943 (if (listp (cdr routines))
@@ -4945,7 +4945,7 @@ Cache to disk for quick recovery."
4945 (nconc idlwave-system-routines routines)) 4945 (nconc idlwave-system-routines routines))
4946 ;; a cons cell is an executive commands 4946 ;; a cons cell is an executive commands
4947 (push routines idlwave-executive-commands-alist)))) 4947 (push routines idlwave-executive-commands-alist))))
4948 4948
4949 ((eq type 'CLASS) 4949 ((eq type 'CLASS)
4950 (setq class-result (idlwave-xml-create-class-method-lists elem)) 4950 (setq class-result (idlwave-xml-create-class-method-lists elem))
4951 (push (car class-result) idlwave-system-class-info) 4951 (push (car class-result) idlwave-system-class-info)
@@ -4963,10 +4963,10 @@ Cache to disk for quick recovery."
4963 4963
4964 ((eq type 'SYSVAR) 4964 ((eq type 'SYSVAR)
4965 (if (setq alias (cdr (assq 'alias_to props))) 4965 (if (setq alias (cdr (assq 'alias_to props)))
4966 (push (cons (substring (cdr (assq 'name props)) 1) 4966 (push (cons (substring (cdr (assq 'name props)) 1)
4967 (substring alias 1)) 4967 (substring alias 1))
4968 sysvar-aliases) 4968 sysvar-aliases)
4969 (push (idlwave-xml-create-sysvar-alist elem) 4969 (push (idlwave-xml-create-sysvar-alist elem)
4970 idlwave-system-variables-alist))) 4970 idlwave-system-variables-alist)))
4971 (t)))) 4971 (t))))
4972 (idlwave-convert-xml-clean-routine-aliases routine-aliases) 4972 (idlwave-convert-xml-clean-routine-aliases routine-aliases)
@@ -4976,12 +4976,12 @@ Cache to disk for quick recovery."
4976 (setq idlwave-xml-routine-info-file catalog-file) 4976 (setq idlwave-xml-routine-info-file catalog-file)
4977 (idlwave-save-routine-info) 4977 (idlwave-save-routine-info)
4978 (message "Converting XML routine info...done"))) 4978 (message "Converting XML routine info...done")))
4979 4979
4980 4980
4981;; ("ROUTINE" type class 4981;; ("ROUTINE" type class
4982;; (system) | (lib pro_file dir "LIBNAME") | (user pro_file dir "USERLIB") | 4982;; (system) | (lib pro_file dir "LIBNAME") | (user pro_file dir "USERLIB") |
4983;; (buffer pro_file dir) | (compiled pro_file dir) 4983;; (buffer pro_file dir) | (compiled pro_file dir)
4984;; "calling_string" ("HELPFILE" (("KWD1" . link1) ...)) 4984;; "calling_string" ("HELPFILE" (("KWD1" . link1) ...))
4985;; ("HELPFILE2" (("KWD2" . link) ...)) ...) 4985;; ("HELPFILE2" (("KWD2" . link) ...)) ...)
4986 4986
4987 4987
@@ -4996,7 +4996,7 @@ Cache to disk for quick recovery."
4996 (message "Loading system routine info in idle time...done") 4996 (message "Loading system routine info in idle time...done")
4997 (aset arr 0 t) 4997 (aset arr 0 t)
4998 (throw 'exit t)) 4998 (throw 'exit t))
4999 4999
5000 (when (not (aref arr 1)) 5000 (when (not (aref arr 1))
5001 (message "Normalizing idlwave-system-routines in idle time...") 5001 (message "Normalizing idlwave-system-routines in idle time...")
5002 (idlwave-reset-sintern t) 5002 (idlwave-reset-sintern t)
@@ -5021,7 +5021,7 @@ Cache to disk for quick recovery."
5021 (progn 5021 (progn
5022 (setq idlwave-library-routines nil) 5022 (setq idlwave-library-routines nil)
5023 (ding) 5023 (ding)
5024 (message "Outdated user catalog: %s... recreate" 5024 (message "Outdated user catalog: %s... recreate"
5025 idlwave-user-catalog-file)) 5025 idlwave-user-catalog-file))
5026 (message "Loading user catalog in idle time...done"))) 5026 (message "Loading user catalog in idle time...done")))
5027 (aset arr 2 t) 5027 (aset arr 2 t)
@@ -5030,16 +5030,16 @@ Cache to disk for quick recovery."
5030 (when (not (aref arr 3)) 5030 (when (not (aref arr 3))
5031 (when idlwave-user-catalog-routines 5031 (when idlwave-user-catalog-routines
5032 (message "Normalizing user catalog routines in idle time...") 5032 (message "Normalizing user catalog routines in idle time...")
5033 (setq idlwave-user-catalog-routines 5033 (setq idlwave-user-catalog-routines
5034 (idlwave-sintern-rinfo-list 5034 (idlwave-sintern-rinfo-list
5035 idlwave-user-catalog-routines 'sys)) 5035 idlwave-user-catalog-routines 'sys))
5036 (message 5036 (message
5037 "Normalizing user catalog routines in idle time...done")) 5037 "Normalizing user catalog routines in idle time...done"))
5038 (aset arr 3 t) 5038 (aset arr 3 t)
5039 (throw 'exit t)) 5039 (throw 'exit t))
5040 5040
5041 (when (not (aref arr 4)) 5041 (when (not (aref arr 4))
5042 (idlwave-scan-library-catalogs 5042 (idlwave-scan-library-catalogs
5043 "Loading and normalizing library catalogs in idle time...") 5043 "Loading and normalizing library catalogs in idle time...")
5044 (aset arr 4 t) 5044 (aset arr 4 t)
5045 (throw 'exit t)) 5045 (throw 'exit t))
@@ -5047,7 +5047,7 @@ Cache to disk for quick recovery."
5047 (message "Finishing initialization in idle time...") 5047 (message "Finishing initialization in idle time...")
5048 (idlwave-routines) 5048 (idlwave-routines)
5049 (message "Finishing initialization in idle time...done") 5049 (message "Finishing initialization in idle time...done")
5050 (aset arr 5 t) 5050 (aset arr 5 t)
5051 (throw 'exit nil))) 5051 (throw 'exit nil)))
5052 ;; restart the timer 5052 ;; restart the timer
5053 (if (sit-for 1) 5053 (if (sit-for 1)
@@ -5082,17 +5082,17 @@ Cache to disk for quick recovery."
5082 (when (or force (not (aref idlwave-load-rinfo-steps-done 2))) 5082 (when (or force (not (aref idlwave-load-rinfo-steps-done 2)))
5083 (load-file idlwave-user-catalog-file)) 5083 (load-file idlwave-user-catalog-file))
5084 (error nil)) 5084 (error nil))
5085 (when (and 5085 (when (and
5086 (boundp 'idlwave-library-routines) 5086 (boundp 'idlwave-library-routines)
5087 idlwave-library-routines) 5087 idlwave-library-routines)
5088 (setq idlwave-library-routines nil) 5088 (setq idlwave-library-routines nil)
5089 (error "Outdated user catalog: %s... recreate" 5089 (error "Outdated user catalog: %s... recreate"
5090 idlwave-user-catalog-file)) 5090 idlwave-user-catalog-file))
5091 (setq idlwave-true-path-alist nil) 5091 (setq idlwave-true-path-alist nil)
5092 (when (or force (not (aref idlwave-load-rinfo-steps-done 3))) 5092 (when (or force (not (aref idlwave-load-rinfo-steps-done 3)))
5093 (message "Normalizing user catalog routines...") 5093 (message "Normalizing user catalog routines...")
5094 (setq idlwave-user-catalog-routines 5094 (setq idlwave-user-catalog-routines
5095 (idlwave-sintern-rinfo-list 5095 (idlwave-sintern-rinfo-list
5096 idlwave-user-catalog-routines 'sys)) 5096 idlwave-user-catalog-routines 'sys))
5097 (message "Normalizing user catalog routines...done"))) 5097 (message "Normalizing user catalog routines...done")))
5098 5098
@@ -5105,11 +5105,11 @@ Cache to disk for quick recovery."
5105 5105
5106(defun idlwave-update-buffer-routine-info () 5106(defun idlwave-update-buffer-routine-info ()
5107 (let (res) 5107 (let (res)
5108 (cond 5108 (cond
5109 ((eq idlwave-scan-all-buffers-for-routine-info t) 5109 ((eq idlwave-scan-all-buffers-for-routine-info t)
5110 ;; Scan all buffers, current buffer last 5110 ;; Scan all buffers, current buffer last
5111 (message "Scanning all buffers...") 5111 (message "Scanning all buffers...")
5112 (setq res (idlwave-get-routine-info-from-buffers 5112 (setq res (idlwave-get-routine-info-from-buffers
5113 (reverse (buffer-list))))) 5113 (reverse (buffer-list)))))
5114 ((null idlwave-scan-all-buffers-for-routine-info) 5114 ((null idlwave-scan-all-buffers-for-routine-info)
5115 ;; Don't scan any buffers 5115 ;; Don't scan any buffers
@@ -5122,12 +5122,12 @@ Cache to disk for quick recovery."
5122 (setq res (idlwave-get-routine-info-from-buffers 5122 (setq res (idlwave-get-routine-info-from-buffers
5123 (list (current-buffer)))))))) 5123 (list (current-buffer))))))))
5124 ;; Put the result into the correct variable 5124 ;; Put the result into the correct variable
5125 (setq idlwave-buffer-routines 5125 (setq idlwave-buffer-routines
5126 (idlwave-sintern-rinfo-list res 'set)))) 5126 (idlwave-sintern-rinfo-list res 'set))))
5127 5127
5128(defun idlwave-concatenate-rinfo-lists (&optional quiet run-hook) 5128(defun idlwave-concatenate-rinfo-lists (&optional quiet run-hook)
5129 "Put the different sources for routine information together." 5129 "Put the different sources for routine information together."
5130 ;; The sequence here is important because earlier definitions shadow 5130 ;; The sequence here is important because earlier definitions shadow
5131 ;; later ones. We assume that if things in the buffers are newer 5131 ;; later ones. We assume that if things in the buffers are newer
5132 ;; then in the shell of the system, they are meant to be different. 5132 ;; then in the shell of the system, they are meant to be different.
5133 (setcdr idlwave-last-system-routine-info-cons-cell 5133 (setcdr idlwave-last-system-routine-info-cons-cell
@@ -5139,7 +5139,7 @@ Cache to disk for quick recovery."
5139 5139
5140 ;; Give a message with information about the number of routines we have. 5140 ;; Give a message with information about the number of routines we have.
5141 (unless quiet 5141 (unless quiet
5142 (message 5142 (message
5143 "Routines Found: buffer(%d) compiled(%d) library(%d) user(%d) system(%d)" 5143 "Routines Found: buffer(%d) compiled(%d) library(%d) user(%d) system(%d)"
5144 (length idlwave-buffer-routines) 5144 (length idlwave-buffer-routines)
5145 (length idlwave-compiled-routines) 5145 (length idlwave-compiled-routines)
@@ -5157,7 +5157,7 @@ Cache to disk for quick recovery."
5157 (when (and (setq class (nth 2 x)) 5157 (when (and (setq class (nth 2 x))
5158 (not (assq class idlwave-class-alist))) 5158 (not (assq class idlwave-class-alist)))
5159 (push (list class) idlwave-class-alist))) 5159 (push (list class) idlwave-class-alist)))
5160 idlwave-class-alist))) 5160 idlwave-class-alist)))
5161 5161
5162;; Three functions for the hooks 5162;; Three functions for the hooks
5163(defun idlwave-save-buffer-update () 5163(defun idlwave-save-buffer-update ()
@@ -5190,7 +5190,7 @@ Cache to disk for quick recovery."
5190 5190
5191(defun idlwave-replace-buffer-routine-info (file new) 5191(defun idlwave-replace-buffer-routine-info (file new)
5192 "Cut the part from FILE out of `idlwave-buffer-routines' and add NEW." 5192 "Cut the part from FILE out of `idlwave-buffer-routines' and add NEW."
5193 (let ((list idlwave-buffer-routines) 5193 (let ((list idlwave-buffer-routines)
5194 found) 5194 found)
5195 (while list 5195 (while list
5196 ;; The following test uses eq to make sure it works correctly 5196 ;; The following test uses eq to make sure it works correctly
@@ -5201,7 +5201,7 @@ Cache to disk for quick recovery."
5201 (setcar list nil) 5201 (setcar list nil)
5202 (setq found t)) 5202 (setq found t))
5203 (if found 5203 (if found
5204 ;; End of that section reached. Jump. 5204 ;; End of that section reached. Jump.
5205 (setq list nil))) 5205 (setq list nil)))
5206 (setq list (cdr list))) 5206 (setq list (cdr list)))
5207 (setq idlwave-buffer-routines 5207 (setq idlwave-buffer-routines
@@ -5233,11 +5233,11 @@ Cache to disk for quick recovery."
5233 (save-restriction 5233 (save-restriction
5234 (widen) 5234 (widen)
5235 (goto-char (point-min)) 5235 (goto-char (point-min))
5236 (while (re-search-forward 5236 (while (re-search-forward
5237 "^[ \t]*\\(pro\\|function\\)[ \t]" nil t) 5237 "^[ \t]*\\(pro\\|function\\)[ \t]" nil t)
5238 (setq string (buffer-substring-no-properties 5238 (setq string (buffer-substring-no-properties
5239 (match-beginning 0) 5239 (match-beginning 0)
5240 (progn 5240 (progn
5241 (idlwave-end-of-statement) 5241 (idlwave-end-of-statement)
5242 (point)))) 5242 (point))))
5243 (setq entry (idlwave-parse-definition string)) 5243 (setq entry (idlwave-parse-definition string))
@@ -5275,7 +5275,7 @@ Cache to disk for quick recovery."
5275 (push (match-string 1 string) args))) 5275 (push (match-string 1 string) args)))
5276 ;; Normalize and sort. 5276 ;; Normalize and sort.
5277 (setq args (nreverse args)) 5277 (setq args (nreverse args))
5278 (setq keywords (sort keywords (lambda (a b) 5278 (setq keywords (sort keywords (lambda (a b)
5279 (string< (downcase a) (downcase b))))) 5279 (string< (downcase a) (downcase b)))))
5280 ;; Make and return the entry 5280 ;; Make and return the entry
5281 ;; We don't know which argument are optional, so this information 5281 ;; We don't know which argument are optional, so this information
@@ -5285,7 +5285,7 @@ Cache to disk for quick recovery."
5285 class 5285 class
5286 (cond ((not (boundp 'idlwave-scanning-lib)) 5286 (cond ((not (boundp 'idlwave-scanning-lib))
5287 (list 'buffer (buffer-file-name))) 5287 (list 'buffer (buffer-file-name)))
5288; ((string= (downcase 5288; ((string= (downcase
5289; (file-name-sans-extension 5289; (file-name-sans-extension
5290; (file-name-nondirectory (buffer-file-name)))) 5290; (file-name-nondirectory (buffer-file-name))))
5291; (downcase name)) 5291; (downcase name))
@@ -5293,7 +5293,7 @@ Cache to disk for quick recovery."
5293; (t (cons 'lib (file-name-nondirectory (buffer-file-name)))) 5293; (t (cons 'lib (file-name-nondirectory (buffer-file-name))))
5294 (t (list 'user (file-name-nondirectory (buffer-file-name)) 5294 (t (list 'user (file-name-nondirectory (buffer-file-name))
5295 idlwave-scanning-lib-dir "UserLib"))) 5295 idlwave-scanning-lib-dir "UserLib")))
5296 (concat 5296 (concat
5297 (if (string= type "function") "Result = " "") 5297 (if (string= type "function") "Result = " "")
5298 (if class "Obj ->[%s::]" "") 5298 (if class "Obj ->[%s::]" "")
5299 "%s" 5299 "%s"
@@ -5339,10 +5339,10 @@ time - so no widget will pop up."
5339 (> (length idlwave-user-catalog-file) 0) 5339 (> (length idlwave-user-catalog-file) 0)
5340 (file-accessible-directory-p 5340 (file-accessible-directory-p
5341 (file-name-directory idlwave-user-catalog-file)) 5341 (file-name-directory idlwave-user-catalog-file))
5342 (not (string= "" (file-name-nondirectory 5342 (not (string= "" (file-name-nondirectory
5343 idlwave-user-catalog-file)))) 5343 idlwave-user-catalog-file))))
5344 (error "`idlwave-user-catalog-file' does not point to a file in an accessible directory")) 5344 (error "`idlwave-user-catalog-file' does not point to a file in an accessible directory"))
5345 5345
5346 (cond 5346 (cond
5347 ;; Rescan the known directories 5347 ;; Rescan the known directories
5348 ((and arg idlwave-path-alist 5348 ((and arg idlwave-path-alist
@@ -5352,13 +5352,13 @@ time - so no widget will pop up."
5352 ;; Expand the directories from library-path and run the widget 5352 ;; Expand the directories from library-path and run the widget
5353 (idlwave-library-path 5353 (idlwave-library-path
5354 (idlwave-display-user-catalog-widget 5354 (idlwave-display-user-catalog-widget
5355 (if idlwave-true-path-alist 5355 (if idlwave-true-path-alist
5356 ;; Propagate any flags on the existing path-alist 5356 ;; Propagate any flags on the existing path-alist
5357 (mapcar (lambda (x) 5357 (mapcar (lambda (x)
5358 (let ((path-entry (assoc (file-truename x) 5358 (let ((path-entry (assoc (file-truename x)
5359 idlwave-true-path-alist))) 5359 idlwave-true-path-alist)))
5360 (if path-entry 5360 (if path-entry
5361 (cons x (cdr path-entry)) 5361 (cons x (cdr path-entry))
5362 (list x)))) 5362 (list x))))
5363 (idlwave-expand-path idlwave-library-path)) 5363 (idlwave-expand-path idlwave-library-path))
5364 (mapcar 'list (idlwave-expand-path idlwave-library-path))))) 5364 (mapcar 'list (idlwave-expand-path idlwave-library-path)))))
@@ -5383,7 +5383,7 @@ time - so no widget will pop up."
5383 (idlwave-scan-library-catalogs "Locating library catalogs..." 'no-load) 5383 (idlwave-scan-library-catalogs "Locating library catalogs..." 'no-load)
5384 (idlwave-display-user-catalog-widget idlwave-path-alist))) 5384 (idlwave-display-user-catalog-widget idlwave-path-alist)))
5385 5385
5386(defconst idlwave-user-catalog-widget-help-string 5386(defconst idlwave-user-catalog-widget-help-string
5387 "This is the front-end to the creation of the IDLWAVE user catalog. 5387 "This is the front-end to the creation of the IDLWAVE user catalog.
5388Please select the directories on IDL's search path from which you 5388Please select the directories on IDL's search path from which you
5389would like to extract routine information, to be stored in the file: 5389would like to extract routine information, to be stored in the file:
@@ -5418,7 +5418,7 @@ directories and save the routine info.
5418 (make-local-variable 'idlwave-widget) 5418 (make-local-variable 'idlwave-widget)
5419 (widget-insert (format idlwave-user-catalog-widget-help-string 5419 (widget-insert (format idlwave-user-catalog-widget-help-string
5420 idlwave-user-catalog-file)) 5420 idlwave-user-catalog-file))
5421 5421
5422 (widget-create 'push-button 5422 (widget-create 'push-button
5423 :notify 'idlwave-widget-scan-user-lib-files 5423 :notify 'idlwave-widget-scan-user-lib-files
5424 "Scan & Save") 5424 "Scan & Save")
@@ -5428,7 +5428,7 @@ directories and save the routine info.
5428 "Delete File") 5428 "Delete File")
5429 (widget-insert " ") 5429 (widget-insert " ")
5430 (widget-create 'push-button 5430 (widget-create 'push-button
5431 :notify 5431 :notify
5432 '(lambda (&rest ignore) 5432 '(lambda (&rest ignore)
5433 (let ((path-list (widget-get idlwave-widget :path-dirs))) 5433 (let ((path-list (widget-get idlwave-widget :path-dirs)))
5434 (mapcar (lambda (x) 5434 (mapcar (lambda (x)
@@ -5439,7 +5439,7 @@ directories and save the routine info.
5439 "Select All Non-Lib") 5439 "Select All Non-Lib")
5440 (widget-insert " ") 5440 (widget-insert " ")
5441 (widget-create 'push-button 5441 (widget-create 'push-button
5442 :notify 5442 :notify
5443 '(lambda (&rest ignore) 5443 '(lambda (&rest ignore)
5444 (let ((path-list (widget-get idlwave-widget :path-dirs))) 5444 (let ((path-list (widget-get idlwave-widget :path-dirs)))
5445 (mapcar (lambda (x) 5445 (mapcar (lambda (x)
@@ -5455,18 +5455,18 @@ directories and save the routine info.
5455 (widget-insert "\n\n") 5455 (widget-insert "\n\n")
5456 5456
5457 (widget-insert "Select Directories: \n") 5457 (widget-insert "Select Directories: \n")
5458 5458
5459 (setq idlwave-widget 5459 (setq idlwave-widget
5460 (apply 'widget-create 5460 (apply 'widget-create
5461 'checklist 5461 'checklist
5462 :value (delq nil (mapcar (lambda (x) 5462 :value (delq nil (mapcar (lambda (x)
5463 (if (memq 'user (cdr x)) 5463 (if (memq 'user (cdr x))
5464 (car x))) 5464 (car x)))
5465 dirs-list)) 5465 dirs-list))
5466 :greedy t 5466 :greedy t
5467 :tag "List of directories" 5467 :tag "List of directories"
5468 (mapcar (lambda (x) 5468 (mapcar (lambda (x)
5469 (list 'item 5469 (list 'item
5470 (if (memq 'lib (cdr x)) 5470 (if (memq 'lib (cdr x))
5471 (concat "[LIB] " (car x) ) 5471 (concat "[LIB] " (car x) )
5472 (car x)))) dirs-list))) 5472 (car x)))) dirs-list)))
@@ -5476,7 +5476,7 @@ directories and save the routine info.
5476 (widget-setup) 5476 (widget-setup)
5477 (goto-char (point-min)) 5477 (goto-char (point-min))
5478 (delete-other-windows)) 5478 (delete-other-windows))
5479 5479
5480(defun idlwave-delete-user-catalog-file (&rest ignore) 5480(defun idlwave-delete-user-catalog-file (&rest ignore)
5481 (if (yes-or-no-p 5481 (if (yes-or-no-p
5482 (format "Delete file %s " idlwave-user-catalog-file)) 5482 (format "Delete file %s " idlwave-user-catalog-file))
@@ -5492,7 +5492,7 @@ directories and save the routine info.
5492 (this-path-alist path-alist) 5492 (this-path-alist path-alist)
5493 dir-entry) 5493 dir-entry)
5494 (while (setq dir-entry (pop this-path-alist)) 5494 (while (setq dir-entry (pop this-path-alist))
5495 (if (member 5495 (if (member
5496 (if (memq 'lib (cdr dir-entry)) 5496 (if (memq 'lib (cdr dir-entry))
5497 (concat "[LIB] " (car dir-entry)) 5497 (concat "[LIB] " (car dir-entry))
5498 (car dir-entry)) 5498 (car dir-entry))
@@ -5589,7 +5589,7 @@ directories and save the routine info.
5589 ;; Define the variable which knows the value of "!DIR" 5589 ;; Define the variable which knows the value of "!DIR"
5590 (insert (format "\n(setq idlwave-system-directory \"%s\")\n" 5590 (insert (format "\n(setq idlwave-system-directory \"%s\")\n"
5591 idlwave-system-directory)) 5591 idlwave-system-directory))
5592 5592
5593 ;; Define the variable which contains a list of all scanned directories 5593 ;; Define the variable which contains a list of all scanned directories
5594 (insert "\n(setq idlwave-path-alist\n '(") 5594 (insert "\n(setq idlwave-path-alist\n '(")
5595 (let ((standard-output (current-buffer))) 5595 (let ((standard-output (current-buffer)))
@@ -5629,7 +5629,7 @@ directories and save the routine info.
5629 (when (file-directory-p dir) 5629 (when (file-directory-p dir)
5630 (setq files (nreverse (directory-files dir t "[^.]"))) 5630 (setq files (nreverse (directory-files dir t "[^.]")))
5631 (while (setq file (pop files)) 5631 (while (setq file (pop files))
5632 (if (file-directory-p file) 5632 (if (file-directory-p file)
5633 (push (file-name-as-directory file) path))) 5633 (push (file-name-as-directory file) path)))
5634 (push dir path1))) 5634 (push dir path1)))
5635 path1)) 5635 path1))
@@ -5641,7 +5641,7 @@ directories and save the routine info.
5641 5641
5642 5642
5643(defun idlwave-scan-library-catalogs (&optional message-base no-load) 5643(defun idlwave-scan-library-catalogs (&optional message-base no-load)
5644 "Scan for library catalog files (.idlwave_catalog) and ingest. 5644 "Scan for library catalog files (.idlwave_catalog) and ingest.
5645 5645
5646All directories on `idlwave-path-alist' (or `idlwave-library-path' 5646All directories on `idlwave-path-alist' (or `idlwave-library-path'
5647instead, if present) are searched. Print MESSAGE-BASE along with the 5647instead, if present) are searched. Print MESSAGE-BASE along with the
@@ -5649,7 +5649,7 @@ libraries being loaded, if passed, and skip loading/normalizing if
5649NO-LOAD is non-nil. The variable `idlwave-use-library-catalogs' can 5649NO-LOAD is non-nil. The variable `idlwave-use-library-catalogs' can
5650be set to nil to disable library catalog scanning." 5650be set to nil to disable library catalog scanning."
5651 (when idlwave-use-library-catalogs 5651 (when idlwave-use-library-catalogs
5652 (let ((dirs 5652 (let ((dirs
5653 (if idlwave-library-path 5653 (if idlwave-library-path
5654 (idlwave-expand-path idlwave-library-path) 5654 (idlwave-expand-path idlwave-library-path)
5655 (mapcar 'car idlwave-path-alist))) 5655 (mapcar 'car idlwave-path-alist)))
@@ -5658,7 +5658,7 @@ be set to nil to disable library catalog scanning."
5658 (if message-base (message message-base)) 5658 (if message-base (message message-base))
5659 (while (setq dir (pop dirs)) 5659 (while (setq dir (pop dirs))
5660 (catch 'continue 5660 (catch 'continue
5661 (when (file-readable-p 5661 (when (file-readable-p
5662 (setq catalog (expand-file-name ".idlwave_catalog" dir))) 5662 (setq catalog (expand-file-name ".idlwave_catalog" dir)))
5663 (unless no-load 5663 (unless no-load
5664 (setq idlwave-library-catalog-routines nil) 5664 (setq idlwave-library-catalog-routines nil)
@@ -5666,20 +5666,20 @@ be set to nil to disable library catalog scanning."
5666 (condition-case nil 5666 (condition-case nil
5667 (load catalog t t t) 5667 (load catalog t t t)
5668 (error (throw 'continue t))) 5668 (error (throw 'continue t)))
5669 (when (and 5669 (when (and
5670 message-base 5670 message-base
5671 (not (string= idlwave-library-catalog-libname 5671 (not (string= idlwave-library-catalog-libname
5672 old-libname))) 5672 old-libname)))
5673 (message "%s" (concat message-base 5673 (message "%s" (concat message-base
5674 idlwave-library-catalog-libname)) 5674 idlwave-library-catalog-libname))
5675 (setq old-libname idlwave-library-catalog-libname)) 5675 (setq old-libname idlwave-library-catalog-libname))
5676 (when idlwave-library-catalog-routines 5676 (when idlwave-library-catalog-routines
5677 (setq all-routines 5677 (setq all-routines
5678 (append 5678 (append
5679 (idlwave-sintern-rinfo-list 5679 (idlwave-sintern-rinfo-list
5680 idlwave-library-catalog-routines 'sys dir) 5680 idlwave-library-catalog-routines 'sys dir)
5681 all-routines)))) 5681 all-routines))))
5682 5682
5683 ;; Add a 'lib flag if on path-alist 5683 ;; Add a 'lib flag if on path-alist
5684 (when (and idlwave-path-alist 5684 (when (and idlwave-path-alist
5685 (setq dir-entry (assoc dir idlwave-path-alist))) 5685 (setq dir-entry (assoc dir idlwave-path-alist)))
@@ -5690,7 +5690,7 @@ be set to nil to disable library catalog scanning."
5690;;----- Communicating with the Shell ------------------- 5690;;----- Communicating with the Shell -------------------
5691 5691
5692;; First, here is the idl program which can be used to query IDL for 5692;; First, here is the idl program which can be used to query IDL for
5693;; defined routines. 5693;; defined routines.
5694(defconst idlwave-routine-info.pro 5694(defconst idlwave-routine-info.pro
5695 " 5695 "
5696;; START OF IDLWAVE SUPPORT ROUTINES 5696;; START OF IDLWAVE SUPPORT ROUTINES
@@ -5708,10 +5708,10 @@ end
5708pro idlwave_print_info_entry,name,func=func,separator=sep 5708pro idlwave_print_info_entry,name,func=func,separator=sep
5709 ;; See if it's an object method 5709 ;; See if it's an object method
5710 if name eq '' then return 5710 if name eq '' then return
5711 func = keyword_set(func) 5711 func = keyword_set(func)
5712 methsep = strpos(name,'::') 5712 methsep = strpos(name,'::')
5713 meth = methsep ne -1 5713 meth = methsep ne -1
5714 5714
5715 ;; Get routine info 5715 ;; Get routine info
5716 pars = routine_info(name,/parameters,functions=func) 5716 pars = routine_info(name,/parameters,functions=func)
5717 source = routine_info(name,/source,functions=func) 5717 source = routine_info(name,/source,functions=func)
@@ -5719,12 +5719,12 @@ pro idlwave_print_info_entry,name,func=func,separator=sep
5719 nkw = pars.num_kw_args 5719 nkw = pars.num_kw_args
5720 if nargs gt 0 then args = pars.args 5720 if nargs gt 0 then args = pars.args
5721 if nkw gt 0 then kwargs = pars.kw_args 5721 if nkw gt 0 then kwargs = pars.kw_args
5722 5722
5723 ;; Trim the class, and make the name 5723 ;; Trim the class, and make the name
5724 if meth then begin 5724 if meth then begin
5725 class = strmid(name,0,methsep) 5725 class = strmid(name,0,methsep)
5726 name = strmid(name,methsep+2,strlen(name)-1) 5726 name = strmid(name,methsep+2,strlen(name)-1)
5727 if nargs gt 0 then begin 5727 if nargs gt 0 then begin
5728 ;; remove the self argument 5728 ;; remove the self argument
5729 wh = where(args ne 'SELF',nargs) 5729 wh = where(args ne 'SELF',nargs)
5730 if nargs gt 0 then args = args[wh] 5730 if nargs gt 0 then args = args[wh]
@@ -5733,7 +5733,7 @@ pro idlwave_print_info_entry,name,func=func,separator=sep
5733 ;; No class, just a normal routine. 5733 ;; No class, just a normal routine.
5734 class = \"\" 5734 class = \"\"
5735 endelse 5735 endelse
5736 5736
5737 ;; Calling sequence 5737 ;; Calling sequence
5738 cs = \"\" 5738 cs = \"\"
5739 if func then cs = 'Result = ' 5739 if func then cs = 'Result = '
@@ -5754,9 +5754,9 @@ pro idlwave_print_info_entry,name,func=func,separator=sep
5754 kwstring = kwstring + ' ' + kwargs[j] 5754 kwstring = kwstring + ' ' + kwargs[j]
5755 endfor 5755 endfor
5756 endif 5756 endif
5757 5757
5758 ret=(['IDLWAVE-PRO','IDLWAVE-FUN'])[func] 5758 ret=(['IDLWAVE-PRO','IDLWAVE-FUN'])[func]
5759 5759
5760 print,ret + ': ' + name + sep + class + sep + source[0].path $ 5760 print,ret + ': ' + name + sep + class + sep + source[0].path $
5761 + sep + cs + sep + kwstring 5761 + sep + cs + sep + kwstring
5762end 5762end
@@ -5768,19 +5768,19 @@ pro idlwave_routine_info,file
5768 all = routine_info() 5768 all = routine_info()
5769 fileQ=n_elements(file) ne 0 5769 fileQ=n_elements(file) ne 0
5770 if fileQ then file=strtrim(file,2) 5770 if fileQ then file=strtrim(file,2)
5771 for i=0L,n_elements(all)-1L do begin 5771 for i=0L,n_elements(all)-1L do begin
5772 if fileQ then begin 5772 if fileQ then begin
5773 if (routine_info(all[i],/SOURCE)).path eq file then $ 5773 if (routine_info(all[i],/SOURCE)).path eq file then $
5774 idlwave_print_info_entry,all[i],separator=sep 5774 idlwave_print_info_entry,all[i],separator=sep
5775 endif else idlwave_print_info_entry,all[i],separator=sep 5775 endif else idlwave_print_info_entry,all[i],separator=sep
5776 endfor 5776 endfor
5777 all = routine_info(/functions) 5777 all = routine_info(/functions)
5778 for i=0L,n_elements(all)-1L do begin 5778 for i=0L,n_elements(all)-1L do begin
5779 if fileQ then begin 5779 if fileQ then begin
5780 if (routine_info(all[i],/FUNCTIONS,/SOURCE)).path eq file then $ 5780 if (routine_info(all[i],/FUNCTIONS,/SOURCE)).path eq file then $
5781 idlwave_print_info_entry,all[i],separator=sep,/FUNC 5781 idlwave_print_info_entry,all[i],separator=sep,/FUNC
5782 endif else idlwave_print_info_entry,all[i],separator=sep,/FUNC 5782 endif else idlwave_print_info_entry,all[i],separator=sep,/FUNC
5783 endfor 5783 endfor
5784 print,'>>>END OF IDLWAVE ROUTINE INFO' 5784 print,'>>>END OF IDLWAVE ROUTINE INFO'
5785end 5785end
5786 5786
@@ -5806,7 +5806,7 @@ pro idlwave_get_class_tags, class
5806 if res then print,'IDLWAVE-CLASS-TAGS: '+class+' '+strjoin(tags,' ',/single) 5806 if res then print,'IDLWAVE-CLASS-TAGS: '+class+' '+strjoin(tags,' ',/single)
5807end 5807end
5808;; END OF IDLWAVE SUPPORT ROUTINES 5808;; END OF IDLWAVE SUPPORT ROUTINES
5809" 5809"
5810 "The idl programs to get info from the shell.") 5810 "The idl programs to get info from the shell.")
5811 5811
5812(defvar idlwave-idlwave_routine_info-compiled nil 5812(defvar idlwave-idlwave_routine_info-compiled nil
@@ -5824,11 +5824,11 @@ end
5824 (erase-buffer) 5824 (erase-buffer)
5825 (insert idlwave-routine-info.pro) 5825 (insert idlwave-routine-info.pro)
5826 (save-buffer 0)) 5826 (save-buffer 0))
5827 (idlwave-shell-send-command 5827 (idlwave-shell-send-command
5828 (concat ".run \"" idlwave-shell-temp-pro-file "\"") 5828 (concat ".run \"" idlwave-shell-temp-pro-file "\"")
5829 nil 'hide wait) 5829 nil 'hide wait)
5830 (idlwave-shell-send-command 5830 (idlwave-shell-send-command
5831 (format "save,'idlwave_print_safe','idlwave_routine_info','idlwave_print_info_entry','idlwave_get_class_tags','idlwave_get_sysvars',FILE='%s',/ROUTINES" 5831 (format "save,'idlwave_print_safe','idlwave_routine_info','idlwave_print_info_entry','idlwave_get_class_tags','idlwave_get_sysvars',FILE='%s',/ROUTINES"
5832 (idlwave-shell-temp-file 'rinfo)) 5832 (idlwave-shell-temp-file 'rinfo))
5833 nil 'hide) 5833 nil 'hide)
5834 (setq idlwave-idlwave_routine_info-compiled t)) 5834 (setq idlwave-idlwave_routine_info-compiled t))
@@ -5929,7 +5929,7 @@ When we force a method or a method keyword, CLASS can specify the class."
5929 (completion-regexp-list 5929 (completion-regexp-list
5930 (if (equal arg '(16)) 5930 (if (equal arg '(16))
5931 (list (read-string (concat "Completion Regexp: ")))))) 5931 (list (read-string (concat "Completion Regexp: "))))))
5932 5932
5933 (if (and module (string-match "::" module)) 5933 (if (and module (string-match "::" module))
5934 (setq class (substring module 0 (match-beginning 0)) 5934 (setq class (substring module 0 (match-beginning 0))
5935 module (substring module (match-end 0)))) 5935 module (substring module (match-end 0))))
@@ -5950,7 +5950,7 @@ When we force a method or a method keyword, CLASS can specify the class."
5950 ;; Check for any special completion functions 5950 ;; Check for any special completion functions
5951 ((and idlwave-complete-special 5951 ((and idlwave-complete-special
5952 (idlwave-call-special idlwave-complete-special))) 5952 (idlwave-call-special idlwave-complete-special)))
5953 5953
5954 ((null what) 5954 ((null what)
5955 (error "Nothing to complete here")) 5955 (error "Nothing to complete here"))
5956 5956
@@ -5967,7 +5967,7 @@ When we force a method or a method keyword, CLASS can specify the class."
5967 (idlwave-all-class-inherits class-selector))) 5967 (idlwave-all-class-inherits class-selector)))
5968 (isa (concat "procedure" (if class-selector "-method" ""))) 5968 (isa (concat "procedure" (if class-selector "-method" "")))
5969 (type-selector 'pro)) 5969 (type-selector 'pro))
5970 (setq idlwave-completion-help-info 5970 (setq idlwave-completion-help-info
5971 (list 'routine nil type-selector class-selector nil super-classes)) 5971 (list 'routine nil type-selector class-selector nil super-classes))
5972 (idlwave-complete-in-buffer 5972 (idlwave-complete-in-buffer
5973 'procedure (if class-selector 'method 'routine) 5973 'procedure (if class-selector 'method 'routine)
@@ -5975,8 +5975,8 @@ When we force a method or a method keyword, CLASS can specify the class."
5975 (format "Select a %s name%s" 5975 (format "Select a %s name%s"
5976 isa 5976 isa
5977 (if class-selector 5977 (if class-selector
5978 (format " (class is %s)" 5978 (format " (class is %s)"
5979 (if (eq class-selector t) 5979 (if (eq class-selector t)
5980 "unknown" class-selector)) 5980 "unknown" class-selector))
5981 "")) 5981 ""))
5982 isa 5982 isa
@@ -5990,7 +5990,7 @@ When we force a method or a method keyword, CLASS can specify the class."
5990 (idlwave-all-class-inherits class-selector))) 5990 (idlwave-all-class-inherits class-selector)))
5991 (isa (concat "function" (if class-selector "-method" ""))) 5991 (isa (concat "function" (if class-selector "-method" "")))
5992 (type-selector 'fun)) 5992 (type-selector 'fun))
5993 (setq idlwave-completion-help-info 5993 (setq idlwave-completion-help-info
5994 (list 'routine nil type-selector class-selector nil super-classes)) 5994 (list 'routine nil type-selector class-selector nil super-classes))
5995 (idlwave-complete-in-buffer 5995 (idlwave-complete-in-buffer
5996 'function (if class-selector 'method 'routine) 5996 'function (if class-selector 'method 'routine)
@@ -5998,7 +5998,7 @@ When we force a method or a method keyword, CLASS can specify the class."
5998 (format "Select a %s name%s" 5998 (format "Select a %s name%s"
5999 isa 5999 isa
6000 (if class-selector 6000 (if class-selector
6001 (format " (class is %s)" 6001 (format " (class is %s)"
6002 (if (eq class-selector t) 6002 (if (eq class-selector t)
6003 "unknown" class-selector)) 6003 "unknown" class-selector))
6004 "")) 6004 ""))
@@ -6026,18 +6026,18 @@ When we force a method or a method keyword, CLASS can specify the class."
6026 (unless (or entry (eq class t)) 6026 (unless (or entry (eq class t))
6027 (error "Nothing known about procedure %s" 6027 (error "Nothing known about procedure %s"
6028 (idlwave-make-full-name class name))) 6028 (idlwave-make-full-name class name)))
6029 (setq list (idlwave-fix-keywords name 'pro class list 6029 (setq list (idlwave-fix-keywords name 'pro class list
6030 super-classes system)) 6030 super-classes system))
6031 (unless list (error "No keywords available for procedure %s" 6031 (unless list (error "No keywords available for procedure %s"
6032 (idlwave-make-full-name class name))) 6032 (idlwave-make-full-name class name)))
6033 (setq idlwave-completion-help-info 6033 (setq idlwave-completion-help-info
6034 (list 'keyword name type-selector class-selector entry super-classes)) 6034 (list 'keyword name type-selector class-selector entry super-classes))
6035 (idlwave-complete-in-buffer 6035 (idlwave-complete-in-buffer
6036 'keyword 'keyword list nil 6036 'keyword 'keyword list nil
6037 (format "Select keyword for procedure %s%s" 6037 (format "Select keyword for procedure %s%s"
6038 (idlwave-make-full-name class name) 6038 (idlwave-make-full-name class name)
6039 (if (or (member '("_EXTRA") list) 6039 (if (or (member '("_EXTRA") list)
6040 (member '("_REF_EXTRA") list)) 6040 (member '("_REF_EXTRA") list))
6041 " (note _EXTRA)" "")) 6041 " (note _EXTRA)" ""))
6042 isa 6042 isa
6043 'idlwave-attach-keyword-classes))) 6043 'idlwave-attach-keyword-classes)))
@@ -6060,7 +6060,7 @@ When we force a method or a method keyword, CLASS can specify the class."
6060 (unless (or entry (eq class t)) 6060 (unless (or entry (eq class t))
6061 (error "Nothing known about function %s" 6061 (error "Nothing known about function %s"
6062 (idlwave-make-full-name class name))) 6062 (idlwave-make-full-name class name)))
6063 (setq list (idlwave-fix-keywords name 'fun class list 6063 (setq list (idlwave-fix-keywords name 'fun class list
6064 super-classes system)) 6064 super-classes system))
6065 ;; OBJ_NEW: Messages mention the proper Init method 6065 ;; OBJ_NEW: Messages mention the proper Init method
6066 (setq msg-name (if (and (null class) 6066 (setq msg-name (if (and (null class)
@@ -6070,13 +6070,13 @@ When we force a method or a method keyword, CLASS can specify the class."
6070 (idlwave-make-full-name class name))) 6070 (idlwave-make-full-name class name)))
6071 (unless list (error "No keywords available for function %s" 6071 (unless list (error "No keywords available for function %s"
6072 msg-name)) 6072 msg-name))
6073 (setq idlwave-completion-help-info 6073 (setq idlwave-completion-help-info
6074 (list 'keyword name type-selector class-selector nil super-classes)) 6074 (list 'keyword name type-selector class-selector nil super-classes))
6075 (idlwave-complete-in-buffer 6075 (idlwave-complete-in-buffer
6076 'keyword 'keyword list nil 6076 'keyword 'keyword list nil
6077 (format "Select keyword for function %s%s" msg-name 6077 (format "Select keyword for function %s%s" msg-name
6078 (if (or (member '("_EXTRA") list) 6078 (if (or (member '("_EXTRA") list)
6079 (member '("_REF_EXTRA") list)) 6079 (member '("_REF_EXTRA") list))
6080 " (note _EXTRA)" "")) 6080 " (note _EXTRA)" ""))
6081 isa 6081 isa
6082 'idlwave-attach-keyword-classes))) 6082 'idlwave-attach-keyword-classes)))
@@ -6114,10 +6114,10 @@ other completions will be tried.")
6114 ("class"))) 6114 ("class")))
6115 (module (idlwave-sintern-routine-or-method module class)) 6115 (module (idlwave-sintern-routine-or-method module class))
6116 (class (idlwave-sintern-class class)) 6116 (class (idlwave-sintern-class class))
6117 (what (cond 6117 (what (cond
6118 ((equal what 0) 6118 ((equal what 0)
6119 (setq what 6119 (setq what
6120 (intern (completing-read 6120 (intern (completing-read
6121 "Complete what? " what-list nil t)))) 6121 "Complete what? " what-list nil t))))
6122 ((integerp what) 6122 ((integerp what)
6123 (setq what (intern (car (nth (1- what) what-list))))) 6123 (setq what (intern (car (nth (1- what) what-list)))))
@@ -6139,7 +6139,7 @@ other completions will be tried.")
6139 (super-classes nil) 6139 (super-classes nil)
6140 (type-selector 'pro) 6140 (type-selector 'pro)
6141 (pro (or module 6141 (pro (or module
6142 (idlwave-completing-read 6142 (idlwave-completing-read
6143 "Procedure: " (idlwave-routines) 'idlwave-selector)))) 6143 "Procedure: " (idlwave-routines) 'idlwave-selector))))
6144 (setq pro (idlwave-sintern-routine pro)) 6144 (setq pro (idlwave-sintern-routine pro))
6145 (list nil-list nil-list 'procedure-keyword 6145 (list nil-list nil-list 'procedure-keyword
@@ -6153,7 +6153,7 @@ other completions will be tried.")
6153 (super-classes nil) 6153 (super-classes nil)
6154 (type-selector 'fun) 6154 (type-selector 'fun)
6155 (func (or module 6155 (func (or module
6156 (idlwave-completing-read 6156 (idlwave-completing-read
6157 "Function: " (idlwave-routines) 'idlwave-selector)))) 6157 "Function: " (idlwave-routines) 'idlwave-selector))))
6158 (setq func (idlwave-sintern-routine func)) 6158 (setq func (idlwave-sintern-routine func))
6159 (list nil-list nil-list 'function-keyword 6159 (list nil-list nil-list 'function-keyword
@@ -6193,7 +6193,7 @@ other completions will be tried.")
6193 6193
6194 ((eq what 'class) 6194 ((eq what 'class)
6195 (list nil-list nil-list 'class nil-list nil)) 6195 (list nil-list nil-list 'class nil-list nil))
6196 6196
6197 (t (error "Invalid value for WHAT"))))) 6197 (t (error "Invalid value for WHAT")))))
6198 6198
6199(defun idlwave-completing-read (&rest args) 6199(defun idlwave-completing-read (&rest args)
@@ -6216,7 +6216,7 @@ other completions will be tried.")
6216 (stringp idlwave-shell-default-directory) 6216 (stringp idlwave-shell-default-directory)
6217 (file-directory-p idlwave-shell-default-directory)) 6217 (file-directory-p idlwave-shell-default-directory))
6218 idlwave-shell-default-directory 6218 idlwave-shell-default-directory
6219 default-directory))) 6219 default-directory)))
6220 (comint-dynamic-complete-filename))) 6220 (comint-dynamic-complete-filename)))
6221 6221
6222(defun idlwave-make-full-name (class name) 6222(defun idlwave-make-full-name (class name)
@@ -6225,7 +6225,7 @@ other completions will be tried.")
6225 6225
6226(defun idlwave-rinfo-assoc (name type class list) 6226(defun idlwave-rinfo-assoc (name type class list)
6227 "Like `idlwave-rinfo-assq', but sintern strings first." 6227 "Like `idlwave-rinfo-assq', but sintern strings first."
6228 (idlwave-rinfo-assq 6228 (idlwave-rinfo-assq
6229 (idlwave-sintern-routine-or-method name class) 6229 (idlwave-sintern-routine-or-method name class)
6230 type (idlwave-sintern-class class) list)) 6230 type (idlwave-sintern-class class) list))
6231 6231
@@ -6249,7 +6249,7 @@ other completions will be tried.")
6249 (setq classes nil))) 6249 (setq classes nil)))
6250 rtn)) 6250 rtn))
6251 6251
6252(defun idlwave-best-rinfo-assq (name type class list &optional with-file 6252(defun idlwave-best-rinfo-assq (name type class list &optional with-file
6253 keep-system) 6253 keep-system)
6254 "Like `idlwave-rinfo-assq', but get all twins and sort, then return first. 6254 "Like `idlwave-rinfo-assq', but get all twins and sort, then return first.
6255If WITH-FILE is passed, find the best rinfo entry with a file 6255If WITH-FILE is passed, find the best rinfo entry with a file
@@ -6274,7 +6274,7 @@ syslib files."
6274 twins))))) 6274 twins)))))
6275 (car twins))) 6275 (car twins)))
6276 6276
6277(defun idlwave-best-rinfo-assoc (name type class list &optional with-file 6277(defun idlwave-best-rinfo-assoc (name type class list &optional with-file
6278 keep-system) 6278 keep-system)
6279 "Like `idlwave-best-rinfo-assq', but sintern strings first." 6279 "Like `idlwave-best-rinfo-assq', but sintern strings first."
6280 (idlwave-best-rinfo-assq 6280 (idlwave-best-rinfo-assq
@@ -6365,7 +6365,7 @@ INFO is as returned by idlwave-what-function or -procedure."
6365Must accept two arguments: `apos' and `info'") 6365Must accept two arguments: `apos' and `info'")
6366 6366
6367(defun idlwave-determine-class (info type) 6367(defun idlwave-determine-class (info type)
6368 ;; Determine the class of a routine call. 6368 ;; Determine the class of a routine call.
6369 ;; INFO is the `cw-list' structure as returned by idlwave-where. 6369 ;; INFO is the `cw-list' structure as returned by idlwave-where.
6370 ;; The second element in this structure is the class. When nil, we 6370 ;; The second element in this structure is the class. When nil, we
6371 ;; return nil. When t, try to get the class from text properties at 6371 ;; return nil. When t, try to get the class from text properties at
@@ -6385,7 +6385,7 @@ Must accept two arguments: `apos' and `info'")
6385 (dassoc (cdr dassoc)) 6385 (dassoc (cdr dassoc))
6386 (t t))) 6386 (t t)))
6387 (arrow (and apos (string= (buffer-substring apos (+ 2 apos)) "->"))) 6387 (arrow (and apos (string= (buffer-substring apos (+ 2 apos)) "->")))
6388 (is-self 6388 (is-self
6389 (and arrow 6389 (and arrow
6390 (save-excursion (goto-char apos) 6390 (save-excursion (goto-char apos)
6391 (forward-word -1) 6391 (forward-word -1)
@@ -6406,19 +6406,19 @@ Must accept two arguments: `apos' and `info'")
6406 (setq class (or (nth 2 (idlwave-current-routine)) class))) 6406 (setq class (or (nth 2 (idlwave-current-routine)) class)))
6407 6407
6408 ;; Before prompting, try any special class determination routines 6408 ;; Before prompting, try any special class determination routines
6409 (when (and (eq t class) 6409 (when (and (eq t class)
6410 idlwave-determine-class-special 6410 idlwave-determine-class-special
6411 (not force-query)) 6411 (not force-query))
6412 (setq special-class 6412 (setq special-class
6413 (idlwave-call-special idlwave-determine-class-special apos)) 6413 (idlwave-call-special idlwave-determine-class-special apos))
6414 (if special-class 6414 (if special-class
6415 (setq class (idlwave-sintern-class special-class) 6415 (setq class (idlwave-sintern-class special-class)
6416 store idlwave-store-inquired-class))) 6416 store idlwave-store-inquired-class)))
6417 6417
6418 ;; Prompt for a class, if we need to 6418 ;; Prompt for a class, if we need to
6419 (when (and (eq class t) 6419 (when (and (eq class t)
6420 (or force-query query)) 6420 (or force-query query))
6421 (setq class-alist 6421 (setq class-alist
6422 (mapcar 'list (idlwave-all-method-classes (car info) type))) 6422 (mapcar 'list (idlwave-all-method-classes (car info) type)))
6423 (setq class 6423 (setq class
6424 (idlwave-sintern-class 6424 (idlwave-sintern-class
@@ -6427,9 +6427,9 @@ Must accept two arguments: `apos' and `info'")
6427 (error "No classes available with method %s" (car info))) 6427 (error "No classes available with method %s" (car info)))
6428 ((and (= (length class-alist) 1) (not force-query)) 6428 ((and (= (length class-alist) 1) (not force-query))
6429 (car (car class-alist))) 6429 (car (car class-alist)))
6430 (t 6430 (t
6431 (setq store idlwave-store-inquired-class) 6431 (setq store idlwave-store-inquired-class)
6432 (idlwave-completing-read 6432 (idlwave-completing-read
6433 (format "Class%s: " (if (stringp (car info)) 6433 (format "Class%s: " (if (stringp (car info))
6434 (format " for %s method %s" 6434 (format " for %s method %s"
6435 type (car info)) 6435 type (car info))
@@ -6441,9 +6441,9 @@ Must accept two arguments: `apos' and `info'")
6441 ;; We have a real class here 6441 ;; We have a real class here
6442 (when (and store arrow) 6442 (when (and store arrow)
6443 (condition-case () 6443 (condition-case ()
6444 (add-text-properties 6444 (add-text-properties
6445 apos (+ apos 2) 6445 apos (+ apos 2)
6446 `(idlwave-class ,class face ,idlwave-class-arrow-face 6446 `(idlwave-class ,class face ,idlwave-class-arrow-face
6447 rear-nonsticky t)) 6447 rear-nonsticky t))
6448 (error nil))) 6448 (error nil)))
6449 (setf (nth 2 info) class)) 6449 (setf (nth 2 info) class))
@@ -6471,14 +6471,14 @@ Must accept two arguments: `apos' and `info'")
6471 6471
6472 6472
6473(defun idlwave-where () 6473(defun idlwave-where ()
6474 "Find out where we are. 6474 "Find out where we are.
6475The return value is a list with the following stuff: 6475The return value is a list with the following stuff:
6476\(PRO-LIST FUNC-LIST COMPLETE-WHAT CW-LIST LAST-CHAR) 6476\(PRO-LIST FUNC-LIST COMPLETE-WHAT CW-LIST LAST-CHAR)
6477 6477
6478PRO-LIST (PRO POINT CLASS ARROW) 6478PRO-LIST (PRO POINT CLASS ARROW)
6479FUNC-LIST (FUNC POINT CLASS ARROW) 6479FUNC-LIST (FUNC POINT CLASS ARROW)
6480COMPLETE-WHAT a symbol indicating what kind of completion makes sense here 6480COMPLETE-WHAT a symbol indicating what kind of completion makes sense here
6481CW-LIST (PRO-OR-FUNC POINT CLASS ARROW) Like PRO-LIST, for what can 6481CW-LIST (PRO-OR-FUNC POINT CLASS ARROW) Like PRO-LIST, for what can
6482 be completed here. 6482 be completed here.
6483LAST-CHAR last relevant character before point (non-white non-comment, 6483LAST-CHAR last relevant character before point (non-white non-comment,
6484 not part of current identifier or leading slash). 6484 not part of current identifier or leading slash).
@@ -6490,7 +6490,7 @@ POINT: Where is this
6490CLASS: What class has the routine (nil=no, t=is method, but class unknown) 6490CLASS: What class has the routine (nil=no, t=is method, but class unknown)
6491ARROW: Location of the arrow" 6491ARROW: Location of the arrow"
6492 (idlwave-routines) 6492 (idlwave-routines)
6493 (let* (;(bos (save-excursion (idlwave-beginning-of-statement) (point))) 6493 (let* (;(bos (save-excursion (idlwave-beginning-of-statement) (point)))
6494 (bos (save-excursion (idlwave-start-of-substatement 'pre) (point))) 6494 (bos (save-excursion (idlwave-start-of-substatement 'pre) (point)))
6495 (func-entry (idlwave-what-function bos)) 6495 (func-entry (idlwave-what-function bos))
6496 (func (car func-entry)) 6496 (func (car func-entry))
@@ -6512,8 +6512,8 @@ ARROW: Location of the arrow"
6512 ((string-match "\\`[ \t]*\\(pro\\|function\\)[ \t]+[a-zA-Z0-9_]*\\'" 6512 ((string-match "\\`[ \t]*\\(pro\\|function\\)[ \t]+[a-zA-Z0-9_]*\\'"
6513 match-string) 6513 match-string)
6514 (setq cw 'class)) 6514 (setq cw 'class))
6515 ((string-match 6515 ((string-match
6516 "\\`[ \t]*\\([a-zA-Z][a-zA-Z0-9$_]*\\)?\\'" 6516 "\\`[ \t]*\\([a-zA-Z][a-zA-Z0-9$_]*\\)?\\'"
6517 (if (> pro-point 0) 6517 (if (> pro-point 0)
6518 (buffer-substring pro-point (point)) 6518 (buffer-substring pro-point (point))
6519 match-string)) 6519 match-string))
@@ -6524,11 +6524,11 @@ ARROW: Location of the arrow"
6524 nil) 6524 nil)
6525 ((string-match "OBJ_NEW([ \t]*['\"]\\([a-zA-Z0-9$_]*\\)?\\'" 6525 ((string-match "OBJ_NEW([ \t]*['\"]\\([a-zA-Z0-9$_]*\\)?\\'"
6526 match-string) 6526 match-string)
6527 (setq cw 'class)) 6527 (setq cw 'class))
6528 ((string-match "\\<inherits\\s-+\\([a-zA-Z0-9$_]*\\)?\\'" 6528 ((string-match "\\<inherits\\s-+\\([a-zA-Z0-9$_]*\\)?\\'"
6529 match-string) 6529 match-string)
6530 (setq cw 'class)) 6530 (setq cw 'class))
6531 ((and func 6531 ((and func
6532 (> func-point pro-point) 6532 (> func-point pro-point)
6533 (= func-level 1) 6533 (= func-level 1)
6534 (memq last-char '(?\( ?,))) 6534 (memq last-char '(?\( ?,)))
@@ -6574,7 +6574,7 @@ ARROW: Location of the arrow"
6574 ;; searches to this point. 6574 ;; searches to this point.
6575 6575
6576 (catch 'exit 6576 (catch 'exit
6577 (let (pos 6577 (let (pos
6578 func-point 6578 func-point
6579 (cnt 0) 6579 (cnt 0)
6580 func arrow-start class) 6580 func arrow-start class)
@@ -6589,18 +6589,18 @@ ARROW: Location of the arrow"
6589 (setq pos (point)) 6589 (setq pos (point))
6590 (incf cnt) 6590 (incf cnt)
6591 (when (and (= (following-char) ?\() 6591 (when (and (= (following-char) ?\()
6592 (re-search-backward 6592 (re-search-backward
6593 "\\(::\\|\\<\\)\\([a-zA-Z][a-zA-Z0-9$_]*\\)[ \t]*\\=" 6593 "\\(::\\|\\<\\)\\([a-zA-Z][a-zA-Z0-9$_]*\\)[ \t]*\\="
6594 bound t)) 6594 bound t))
6595 (setq func (match-string 2) 6595 (setq func (match-string 2)
6596 func-point (goto-char (match-beginning 2)) 6596 func-point (goto-char (match-beginning 2))
6597 pos func-point) 6597 pos func-point)
6598 (if (re-search-backward 6598 (if (re-search-backward
6599 "->[ \t]*\\(\\([a-zA-Z][a-zA-Z0-9$_]*\\)::\\)?\\=" bound t) 6599 "->[ \t]*\\(\\([a-zA-Z][a-zA-Z0-9$_]*\\)::\\)?\\=" bound t)
6600 (setq arrow-start (copy-marker (match-beginning 0)) 6600 (setq arrow-start (copy-marker (match-beginning 0))
6601 class (or (match-string 2) t))) 6601 class (or (match-string 2) t)))
6602 (throw 6602 (throw
6603 'exit 6603 'exit
6604 (list 6604 (list
6605 (idlwave-sintern-routine-or-method func class) 6605 (idlwave-sintern-routine-or-method func class)
6606 (idlwave-sintern-class class) 6606 (idlwave-sintern-class class)
@@ -6616,18 +6616,18 @@ ARROW: Location of the arrow"
6616 ;; searches to this point. 6616 ;; searches to this point.
6617 (let ((pos (point)) pro-point 6617 (let ((pos (point)) pro-point
6618 pro class arrow-start string) 6618 pro class arrow-start string)
6619 (save-excursion 6619 (save-excursion
6620 ;;(idlwave-beginning-of-statement) 6620 ;;(idlwave-beginning-of-statement)
6621 (idlwave-start-of-substatement 'pre) 6621 (idlwave-start-of-substatement 'pre)
6622 (setq string (buffer-substring (point) pos)) 6622 (setq string (buffer-substring (point) pos))
6623 (if (string-match 6623 (if (string-match
6624 "\\`[ \t]*\\([a-zA-Z][a-zA-Z0-9$_]*\\)[ \t]*\\(,\\|\\'\\)" string) 6624 "\\`[ \t]*\\([a-zA-Z][a-zA-Z0-9$_]*\\)[ \t]*\\(,\\|\\'\\)" string)
6625 (setq pro (match-string 1 string) 6625 (setq pro (match-string 1 string)
6626 pro-point (+ (point) (match-beginning 1))) 6626 pro-point (+ (point) (match-beginning 1)))
6627 (if (and (idlwave-skip-object) 6627 (if (and (idlwave-skip-object)
6628 (setq string (buffer-substring (point) pos)) 6628 (setq string (buffer-substring (point) pos))
6629 (string-match 6629 (string-match
6630 "\\`[ \t]*\\(->\\)[ \t]*\\(\\([a-zA-Z][a-zA-Z0-9$_]*\\)::\\)?\\([a-zA-Z][a-zA-Z0-9$_]*\\)?[ \t]*\\(,\\|\\(\\$\\s *\\(;.*\\)?\\)?$\\)" 6630 "\\`[ \t]*\\(->\\)[ \t]*\\(\\([a-zA-Z][a-zA-Z0-9$_]*\\)::\\)?\\([a-zA-Z][a-zA-Z0-9$_]*\\)?[ \t]*\\(,\\|\\(\\$\\s *\\(;.*\\)?\\)?$\\)"
6631 string)) 6631 string))
6632 (setq pro (if (match-beginning 4) 6632 (setq pro (if (match-beginning 4)
6633 (match-string 4 string)) 6633 (match-string 4 string))
@@ -6671,7 +6671,7 @@ ARROW: Location of the arrow"
6671 (throw 'exit nil)))) 6671 (throw 'exit nil))))
6672 (goto-char pos) 6672 (goto-char pos)
6673 nil))) 6673 nil)))
6674 6674
6675(defun idlwave-last-valid-char () 6675(defun idlwave-last-valid-char ()
6676 "Return the last character before point which is not white or a comment 6676 "Return the last character before point which is not white or a comment
6677and also not part of the current identifier. Since we do this in 6677and also not part of the current identifier. Since we do this in
@@ -6761,23 +6761,23 @@ accumulate information on matching completions."
6761 ((or (eq completion t) 6761 ((or (eq completion t)
6762 (and (= 1 (length (setq all-completions 6762 (and (= 1 (length (setq all-completions
6763 (idlwave-uniquify 6763 (idlwave-uniquify
6764 (all-completions part list 6764 (all-completions part list
6765 (or special-selector 6765 (or special-selector
6766 selector)))))) 6766 selector))))))
6767 (equal dpart dcompletion))) 6767 (equal dpart dcompletion)))
6768 ;; This is already complete 6768 ;; This is already complete
6769 (idlwave-after-successful-completion type slash beg) 6769 (idlwave-after-successful-completion type slash beg)
6770 (message "%s is already the complete %s" part isa) 6770 (message "%s is already the complete %s" part isa)
6771 nil) 6771 nil)
6772 (t 6772 (t
6773 ;; We cannot add something - offer a list. 6773 ;; We cannot add something - offer a list.
6774 (message "Making completion list...") 6774 (message "Making completion list...")
6775 6775
6776 (unless idlwave-completion-help-links ; already set somewhere? 6776 (unless idlwave-completion-help-links ; already set somewhere?
6777 (mapcar (lambda (x) ; Pass link prop through to highlight-linked 6777 (mapcar (lambda (x) ; Pass link prop through to highlight-linked
6778 (let ((link (get-text-property 0 'link (car x)))) 6778 (let ((link (get-text-property 0 'link (car x))))
6779 (if link 6779 (if link
6780 (push (cons (car x) link) 6780 (push (cons (car x) link)
6781 idlwave-completion-help-links)))) 6781 idlwave-completion-help-links))))
6782 list)) 6782 list))
6783 (let* ((list all-completions) 6783 (let* ((list all-completions)
@@ -6787,7 +6787,7 @@ accumulate information on matching completions."
6787; (completion-fixup-function ; Emacs 6787; (completion-fixup-function ; Emacs
6788; (lambda () (and (eq (preceding-char) ?>) 6788; (lambda () (and (eq (preceding-char) ?>)
6789; (re-search-backward " <" beg t))))) 6789; (re-search-backward " <" beg t)))))
6790 6790
6791 (setq list (sort list (lambda (a b) 6791 (setq list (sort list (lambda (a b)
6792 (string< (downcase a) (downcase b))))) 6792 (string< (downcase a) (downcase b)))))
6793 (if prepare-display-function 6793 (if prepare-display-function
@@ -6797,7 +6797,7 @@ accumulate information on matching completions."
6797 idlwave-complete-empty-string-as-lower-case) 6797 idlwave-complete-empty-string-as-lower-case)
6798 (not idlwave-completion-force-default-case)) 6798 (not idlwave-completion-force-default-case))
6799 (setq list (mapcar (lambda (x) 6799 (setq list (mapcar (lambda (x)
6800 (if (listp x) 6800 (if (listp x)
6801 (setcar x (downcase (car x))) 6801 (setcar x (downcase (car x)))
6802 (setq x (downcase x))) 6802 (setq x (downcase x)))
6803 x) 6803 x)
@@ -6817,19 +6817,19 @@ accumulate information on matching completions."
6817 (re-search-backward "\\<\\(pro\\|function\\)[ \t]+\\=" 6817 (re-search-backward "\\<\\(pro\\|function\\)[ \t]+\\="
6818 (- (point) 15) t) 6818 (- (point) 15) t)
6819 (goto-char (point-min)) 6819 (goto-char (point-min))
6820 (re-search-forward 6820 (re-search-forward
6821 "^[ \t]*\\(pro\\|function\\)[ \t]+\\([a-zA-Z0-9_]+::\\)" nil t)))) 6821 "^[ \t]*\\(pro\\|function\\)[ \t]+\\([a-zA-Z0-9_]+::\\)" nil t))))
6822 ;; Yank the full class specification 6822 ;; Yank the full class specification
6823 (insert (match-string 2)) 6823 (insert (match-string 2))
6824 ;; Do the completion, using list gathered from `idlwave-routines' 6824 ;; Do the completion, using list gathered from `idlwave-routines'
6825 (idlwave-complete-in-buffer 6825 (idlwave-complete-in-buffer
6826 'class 'class (idlwave-class-alist) nil 6826 'class 'class (idlwave-class-alist) nil
6827 "Select a class" "class" 6827 "Select a class" "class"
6828 '(lambda (list) ;; Push it to help-links if system help available 6828 '(lambda (list) ;; Push it to help-links if system help available
6829 (mapcar (lambda (x) 6829 (mapcar (lambda (x)
6830 (let* ((entry (idlwave-class-info x)) 6830 (let* ((entry (idlwave-class-info x))
6831 (link (nth 1 (assq 'link entry)))) 6831 (link (nth 1 (assq 'link entry))))
6832 (if link (push (cons x link) 6832 (if link (push (cons x link)
6833 idlwave-completion-help-links)) 6833 idlwave-completion-help-links))
6834 x)) 6834 x))
6835 list))))) 6835 list)))))
@@ -6841,7 +6841,7 @@ accumulate information on matching completions."
6841 ;; SHOW-CLASSES is the value of `idlwave-completion-show-classes'. 6841 ;; SHOW-CLASSES is the value of `idlwave-completion-show-classes'.
6842 (if (or (null show-classes) ; don't want to see classes 6842 (if (or (null show-classes) ; don't want to see classes
6843 (null class-selector) ; not a method call 6843 (null class-selector) ; not a method call
6844 (and 6844 (and
6845 (stringp class-selector) ; the class is already known 6845 (stringp class-selector) ; the class is already known
6846 (not super-classes))) ; no possibilities for inheritance 6846 (not super-classes))) ; no possibilities for inheritance
6847 ;; In these cases, we do not have to do anything 6847 ;; In these cases, we do not have to do anything
@@ -6856,13 +6856,13 @@ accumulate information on matching completions."
6856 (max (abs show-classes)) 6856 (max (abs show-classes))
6857 (lmax (if do-dots (apply 'max (mapcar 'length list)))) 6857 (lmax (if do-dots (apply 'max (mapcar 'length list))))
6858 classes nclasses class-info space) 6858 classes nclasses class-info space)
6859 (mapcar 6859 (mapcar
6860 (lambda (x) 6860 (lambda (x)
6861 ;; get the classes 6861 ;; get the classes
6862 (if (eq type 'class-tag) 6862 (if (eq type 'class-tag)
6863 ;; Just one class for tags 6863 ;; Just one class for tags
6864 (setq classes 6864 (setq classes
6865 (list 6865 (list
6866 (idlwave-class-or-superclass-with-tag class-selector x))) 6866 (idlwave-class-or-superclass-with-tag class-selector x)))
6867 ;; Multiple classes for method or method-keyword 6867 ;; Multiple classes for method or method-keyword
6868 (setq classes 6868 (setq classes
@@ -6871,7 +6871,7 @@ accumulate information on matching completions."
6871 method-selector x type-selector) 6871 method-selector x type-selector)
6872 (idlwave-all-method-classes x type-selector))) 6872 (idlwave-all-method-classes x type-selector)))
6873 (if inherit 6873 (if inherit
6874 (setq classes 6874 (setq classes
6875 (delq nil 6875 (delq nil
6876 (mapcar (lambda (x) (if (memq x inherit) x nil)) 6876 (mapcar (lambda (x) (if (memq x inherit) x nil))
6877 classes))))) 6877 classes)))))
@@ -6908,7 +6908,7 @@ accumulate information on matching completions."
6908(defun idlwave-attach-class-tag-classes (list) 6908(defun idlwave-attach-class-tag-classes (list)
6909 ;; Call idlwave-attach-classes with class structure tags 6909 ;; Call idlwave-attach-classes with class structure tags
6910 (idlwave-attach-classes list 'class-tag idlwave-completion-show-classes)) 6910 (idlwave-attach-classes list 'class-tag idlwave-completion-show-classes))
6911 6911
6912 6912
6913;;---------------------------------------------------------------------- 6913;;----------------------------------------------------------------------
6914;;---------------------------------------------------------------------- 6914;;----------------------------------------------------------------------
@@ -6929,7 +6929,7 @@ sort the list before displaying"
6929 ((= 1 (length list)) 6929 ((= 1 (length list))
6930 (setq rtn (car list))) 6930 (setq rtn (car list)))
6931 ((featurep 'xemacs) 6931 ((featurep 'xemacs)
6932 (if sort (setq list (sort list (lambda (a b) 6932 (if sort (setq list (sort list (lambda (a b)
6933 (string< (upcase a) (upcase b)))))) 6933 (string< (upcase a) (upcase b))))))
6934 (setq menu 6934 (setq menu
6935 (append (list title) 6935 (append (list title)
@@ -6940,7 +6940,7 @@ sort the list before displaying"
6940 (setq resp (get-popup-menu-response menu)) 6940 (setq resp (get-popup-menu-response menu))
6941 (funcall (event-function resp) (event-object resp))) 6941 (funcall (event-function resp) (event-object resp)))
6942 (t 6942 (t
6943 (if sort (setq list (sort list (lambda (a b) 6943 (if sort (setq list (sort list (lambda (a b)
6944 (string< (upcase a) (upcase b)))))) 6944 (string< (upcase a) (upcase b))))))
6945 (setq menu (cons title 6945 (setq menu (cons title
6946 (list 6946 (list
@@ -7031,7 +7031,7 @@ sort the list before displaying"
7031 (setq idlwave-before-completion-wconf (current-window-configuration))) 7031 (setq idlwave-before-completion-wconf (current-window-configuration)))
7032 7032
7033 (if (featurep 'xemacs) 7033 (if (featurep 'xemacs)
7034 (idlwave-display-completion-list-xemacs 7034 (idlwave-display-completion-list-xemacs
7035 list) 7035 list)
7036 (idlwave-display-completion-list-emacs list)) 7036 (idlwave-display-completion-list-emacs list))
7037 7037
@@ -7112,7 +7112,7 @@ If these don't exist, a letter in the string is automatically selected."
7112 (mapcar (lambda(x) 7112 (mapcar (lambda(x)
7113 (princ (nth 1 x)) 7113 (princ (nth 1 x))
7114 (princ "\n")) 7114 (princ "\n"))
7115 keys-alist)) 7115 keys-alist))
7116 (setq char (read-char))) 7116 (setq char (read-char)))
7117 (setq char (read-char))) 7117 (setq char (read-char)))
7118 (message nil) 7118 (message nil)
@@ -7232,7 +7232,7 @@ If these don't exist, a letter in the string is automatically selected."
7232(defun idlwave-make-modified-completion-map-emacs (old-map) 7232(defun idlwave-make-modified-completion-map-emacs (old-map)
7233 "Replace `choose-completion' and `mouse-choose-completion' in OLD-MAP." 7233 "Replace `choose-completion' and `mouse-choose-completion' in OLD-MAP."
7234 (let ((new-map (copy-keymap old-map))) 7234 (let ((new-map (copy-keymap old-map)))
7235 (substitute-key-definition 7235 (substitute-key-definition
7236 'choose-completion 'idlwave-choose-completion new-map) 7236 'choose-completion 'idlwave-choose-completion new-map)
7237 (substitute-key-definition 7237 (substitute-key-definition
7238 'mouse-choose-completion 'idlwave-mouse-choose-completion new-map) 7238 'mouse-choose-completion 'idlwave-mouse-choose-completion new-map)
@@ -7258,8 +7258,8 @@ If these don't exist, a letter in the string is automatically selected."
7258;; 7258;;
7259;; - Go again over the documentation how to write a completion 7259;; - Go again over the documentation how to write a completion
7260;; plugin. It is in self.el, but currently still very bad. 7260;; plugin. It is in self.el, but currently still very bad.
7261;; This could be in a separate file in the distribution, or 7261;; This could be in a separate file in the distribution, or
7262;; in an appendix for the manual. 7262;; in an appendix for the manual.
7263 7263
7264(defvar idlwave-struct-skip 7264(defvar idlwave-struct-skip
7265 "[ \t]*\\(\\$.*\n\\(^[ \t]*\\(\\$[ \t]*\\)?\\(;.*\\)?\n\\)*\\)?[ \t]*" 7265 "[ \t]*\\(\\$.*\n\\(^[ \t]*\\(\\$[ \t]*\\)?\\(;.*\\)?\n\\)*\\)?[ \t]*"
@@ -7298,7 +7298,7 @@ Point is expected just before the opening `{' of the struct definition."
7298 (beg (car borders)) 7298 (beg (car borders))
7299 (end (cdr borders)) 7299 (end (cdr borders))
7300 (case-fold-search t)) 7300 (case-fold-search t))
7301 (re-search-forward (concat "\\(^[ \t]*\\|[,{][ \t]*\\)" tag "[ \t]*:") 7301 (re-search-forward (concat "\\(^[ \t]*\\|[,{][ \t]*\\)" tag "[ \t]*:")
7302 end t))) 7302 end t)))
7303 7303
7304(defun idlwave-struct-inherits () 7304(defun idlwave-struct-inherits ()
@@ -7313,7 +7313,7 @@ Point is expected just before the opening `{' of the struct definition."
7313 (goto-char beg) 7313 (goto-char beg)
7314 (save-restriction 7314 (save-restriction
7315 (narrow-to-region beg end) 7315 (narrow-to-region beg end)
7316 (while (re-search-forward 7316 (while (re-search-forward
7317 (concat "[{,]" ;leading comma/brace 7317 (concat "[{,]" ;leading comma/brace
7318 idlwave-struct-skip ; 4 groups 7318 idlwave-struct-skip ; 4 groups
7319 "inherits" ; The INHERITS tag 7319 "inherits" ; The INHERITS tag
@@ -7363,9 +7363,9 @@ backward."
7363 (concat "\\<" (regexp-quote (downcase var)) "\\>" ws) 7363 (concat "\\<" (regexp-quote (downcase var)) "\\>" ws)
7364 "\\(\\)") 7364 "\\(\\)")
7365 "=" ws "\\({\\)" 7365 "=" ws "\\({\\)"
7366 (if name 7366 (if name
7367 (if (stringp name) 7367 (if (stringp name)
7368 (concat ws "\\(\\<" (downcase name) "\\)[^a-zA-Z0-9_$]") 7368 (concat ws "\\(\\<" (downcase name) "\\)[^a-zA-Z0-9_$]")
7369 ;; Just a generic name 7369 ;; Just a generic name
7370 (concat ws "\\<\\([a-zA-Z_0-9$]+\\)" ws ",")) 7370 (concat ws "\\<\\([a-zA-Z_0-9$]+\\)" ws ","))
7371 "")))) 7371 ""))))
@@ -7376,7 +7376,7 @@ backward."
7376 (goto-char (match-beginning 3)) 7376 (goto-char (match-beginning 3))
7377 (match-string-no-properties 5))))) 7377 (match-string-no-properties 5)))))
7378 7378
7379(defvar idlwave-class-info nil) 7379(defvar idlwave-class-info nil)
7380(defvar idlwave-class-reset nil) ; to reset buffer-local classes 7380(defvar idlwave-class-reset nil) ; to reset buffer-local classes
7381 7381
7382(add-hook 'idlwave-update-rinfo-hook 7382(add-hook 'idlwave-update-rinfo-hook
@@ -7388,13 +7388,13 @@ backward."
7388 (let (list entry) 7388 (let (list entry)
7389 (if idlwave-class-info 7389 (if idlwave-class-info
7390 (if idlwave-class-reset 7390 (if idlwave-class-reset
7391 (setq 7391 (setq
7392 idlwave-class-reset nil 7392 idlwave-class-reset nil
7393 idlwave-class-info ; Remove any visited in a buffer 7393 idlwave-class-info ; Remove any visited in a buffer
7394 (delq nil (mapcar 7394 (delq nil (mapcar
7395 (lambda (x) 7395 (lambda (x)
7396 (let ((filebuf 7396 (let ((filebuf
7397 (idlwave-class-file-or-buffer 7397 (idlwave-class-file-or-buffer
7398 (or (cdr (assq 'found-in x)) (car x))))) 7398 (or (cdr (assq 'found-in x)) (car x)))))
7399 (if (cdr filebuf) 7399 (if (cdr filebuf)
7400 nil 7400 nil
@@ -7432,7 +7432,7 @@ class/struct definition"
7432 (progn 7432 (progn
7433 ;; For everything there 7433 ;; For everything there
7434 (setq end-lim (save-excursion (idlwave-end-of-subprogram) (point))) 7434 (setq end-lim (save-excursion (idlwave-end-of-subprogram) (point)))
7435 (while (setq name 7435 (while (setq name
7436 (idlwave-find-structure-definition nil t end-lim)) 7436 (idlwave-find-structure-definition nil t end-lim))
7437 (funcall all-hook name))) 7437 (funcall all-hook name)))
7438 (idlwave-find-structure-definition nil (or alt-class class)))))) 7438 (idlwave-find-structure-definition nil (or alt-class class))))))
@@ -7470,11 +7470,11 @@ class/struct definition"
7470 (insert-file-contents file)) 7470 (insert-file-contents file))
7471 (save-excursion 7471 (save-excursion
7472 (goto-char 1) 7472 (goto-char 1)
7473 (idlwave-find-class-definition class 7473 (idlwave-find-class-definition class
7474 ;; Scan all of the structures found there 7474 ;; Scan all of the structures found there
7475 (lambda (name) 7475 (lambda (name)
7476 (let* ((this-class (idlwave-sintern-class name)) 7476 (let* ((this-class (idlwave-sintern-class name))
7477 (entry 7477 (entry
7478 (list this-class 7478 (list this-class
7479 (cons 'tags (idlwave-struct-tags)) 7479 (cons 'tags (idlwave-struct-tags))
7480 (cons 'inherits (idlwave-struct-inherits))))) 7480 (cons 'inherits (idlwave-struct-inherits)))))
@@ -7499,7 +7499,7 @@ class/struct definition"
7499 (condition-case err 7499 (condition-case err
7500 (apply 'append (mapcar 'idlwave-class-tags 7500 (apply 'append (mapcar 'idlwave-class-tags
7501 (cons class (idlwave-all-class-inherits class)))) 7501 (cons class (idlwave-all-class-inherits class))))
7502 (error 7502 (error
7503 (idlwave-class-tag-reset) 7503 (idlwave-class-tag-reset)
7504 (error "%s" (error-message-string err))))) 7504 (error "%s" (error-message-string err)))))
7505 7505
@@ -7536,24 +7536,24 @@ The list is cached in `idlwave-class-info' for faster access."
7536 all-inherits)))))) 7536 all-inherits))))))
7537 7537
7538(defun idlwave-entry-keywords (entry &optional record-link) 7538(defun idlwave-entry-keywords (entry &optional record-link)
7539 "Return the flat entry keywords alist from routine-info entry. 7539 "Return the flat entry keywords alist from routine-info entry.
7540If RECORD-LINK is non-nil, the keyword text is copied and a text 7540If RECORD-LINK is non-nil, the keyword text is copied and a text
7541property indicating the link is added." 7541property indicating the link is added."
7542 (let (kwds) 7542 (let (kwds)
7543 (mapcar 7543 (mapcar
7544 (lambda (key-list) 7544 (lambda (key-list)
7545 (let ((file (car key-list))) 7545 (let ((file (car key-list)))
7546 (mapcar (lambda (key-cons) 7546 (mapcar (lambda (key-cons)
7547 (let ((key (car key-cons)) 7547 (let ((key (car key-cons))
7548 (link (cdr key-cons))) 7548 (link (cdr key-cons)))
7549 (when (and record-link file) 7549 (when (and record-link file)
7550 (setq key (copy-sequence key)) 7550 (setq key (copy-sequence key))
7551 (put-text-property 7551 (put-text-property
7552 0 (length key) 7552 0 (length key)
7553 'link 7553 'link
7554 (concat 7554 (concat
7555 file 7555 file
7556 (if link 7556 (if link
7557 (concat idlwave-html-link-sep 7557 (concat idlwave-html-link-sep
7558 (number-to-string link)))) 7558 (number-to-string link))))
7559 key)) 7559 key))
@@ -7566,13 +7566,13 @@ property indicating the link is added."
7566 "Find keyword KEYWORD in entry ENTRY, and return (with link) if set" 7566 "Find keyword KEYWORD in entry ENTRY, and return (with link) if set"
7567 (catch 'exit 7567 (catch 'exit
7568 (mapc 7568 (mapc
7569 (lambda (key-list) 7569 (lambda (key-list)
7570 (let ((file (car key-list)) 7570 (let ((file (car key-list))
7571 (kwd (assoc keyword (cdr key-list)))) 7571 (kwd (assoc keyword (cdr key-list))))
7572 (when kwd 7572 (when kwd
7573 (setq kwd (cons (car kwd) 7573 (setq kwd (cons (car kwd)
7574 (if (and file (cdr kwd)) 7574 (if (and file (cdr kwd))
7575 (concat file 7575 (concat file
7576 idlwave-html-link-sep 7576 idlwave-html-link-sep
7577 (number-to-string (cdr kwd))) 7577 (number-to-string (cdr kwd)))
7578 (cdr kwd)))) 7578 (cdr kwd))))
@@ -7610,14 +7610,14 @@ property indicating the link is added."
7610 ;; Check if we need to update the "current" class 7610 ;; Check if we need to update the "current" class
7611 (if (not (equal class-selector idlwave-current-tags-class)) 7611 (if (not (equal class-selector idlwave-current-tags-class))
7612 (idlwave-prepare-class-tag-completion class-selector)) 7612 (idlwave-prepare-class-tag-completion class-selector))
7613 (setq idlwave-completion-help-info 7613 (setq idlwave-completion-help-info
7614 (list 'idlwave-complete-class-structure-tag-help 7614 (list 'idlwave-complete-class-structure-tag-help
7615 (idlwave-sintern-routine 7615 (idlwave-sintern-routine
7616 (concat class-selector "__define")) 7616 (concat class-selector "__define"))
7617 nil)) 7617 nil))
7618 (let ((idlwave-cpl-bold idlwave-current-native-class-tags)) 7618 (let ((idlwave-cpl-bold idlwave-current-native-class-tags))
7619 (idlwave-complete-in-buffer 7619 (idlwave-complete-in-buffer
7620 'class-tag 'class-tag 7620 'class-tag 'class-tag
7621 idlwave-current-class-tags nil 7621 idlwave-current-class-tags nil
7622 (format "Select a tag of class %s" class-selector) 7622 (format "Select a tag of class %s" class-selector)
7623 "class tag" 7623 "class tag"
@@ -7663,7 +7663,7 @@ property indicating the link is added."
7663 (skip-chars-backward "[a-zA-Z0-9_$]") 7663 (skip-chars-backward "[a-zA-Z0-9_$]")
7664 (equal (char-before) ?!)) 7664 (equal (char-before) ?!))
7665 (setq idlwave-completion-help-info '(idlwave-complete-sysvar-help)) 7665 (setq idlwave-completion-help-info '(idlwave-complete-sysvar-help))
7666 (idlwave-complete-in-buffer 'sysvar 'sysvar 7666 (idlwave-complete-in-buffer 'sysvar 'sysvar
7667 idlwave-system-variables-alist nil 7667 idlwave-system-variables-alist nil
7668 "Select a system variable" 7668 "Select a system variable"
7669 "system variable") 7669 "system variable")
@@ -7682,7 +7682,7 @@ property indicating the link is added."
7682 (or tags (error "System variable !%s is not a structure" var)) 7682 (or tags (error "System variable !%s is not a structure" var))
7683 (setq idlwave-completion-help-info 7683 (setq idlwave-completion-help-info
7684 (list 'idlwave-complete-sysvar-tag-help var)) 7684 (list 'idlwave-complete-sysvar-tag-help var))
7685 (idlwave-complete-in-buffer 'sysvartag 'sysvartag 7685 (idlwave-complete-in-buffer 'sysvartag 'sysvartag
7686 tags nil 7686 tags nil
7687 "Select a system variable tag" 7687 "Select a system variable tag"
7688 "system variable tag") 7688 "system variable tag")
@@ -7711,8 +7711,8 @@ property indicating the link is added."
7711 ((eq mode 'test) ; we can at least link the main 7711 ((eq mode 'test) ; we can at least link the main
7712 (and (stringp word) entry main)) 7712 (and (stringp word) entry main))
7713 ((eq mode 'set) 7713 ((eq mode 'set)
7714 (if entry 7714 (if entry
7715 (setq link 7715 (setq link
7716 (if (setq target (cdr (assoc word tags))) 7716 (if (setq target (cdr (assoc word tags)))
7717 (idlwave-substitute-link-target main target) 7717 (idlwave-substitute-link-target main target)
7718 main)))) ;; setting dynamic!!! 7718 main)))) ;; setting dynamic!!!
@@ -7736,7 +7736,7 @@ property indicating the link is added."
7736 7736
7737;; Fake help in the source buffer for class structure tags. 7737;; Fake help in the source buffer for class structure tags.
7738;; KWD AND NAME ARE GLOBAL-VARIABLES HERE. 7738;; KWD AND NAME ARE GLOBAL-VARIABLES HERE.
7739(defvar name) 7739(defvar name)
7740(defvar kwd) 7740(defvar kwd)
7741(defvar idlwave-help-do-class-struct-tag nil) 7741(defvar idlwave-help-do-class-struct-tag nil)
7742(defun idlwave-complete-class-structure-tag-help (mode word) 7742(defun idlwave-complete-class-structure-tag-help (mode word)
@@ -7745,11 +7745,11 @@ property indicating the link is added."
7745 nil) 7745 nil)
7746 ((eq mode 'set) 7746 ((eq mode 'set)
7747 (let (class-with found-in) 7747 (let (class-with found-in)
7748 (when (setq class-with 7748 (when (setq class-with
7749 (idlwave-class-or-superclass-with-tag 7749 (idlwave-class-or-superclass-with-tag
7750 idlwave-current-tags-class 7750 idlwave-current-tags-class
7751 word)) 7751 word))
7752 (if (assq (idlwave-sintern-class class-with) 7752 (if (assq (idlwave-sintern-class class-with)
7753 idlwave-system-class-info) 7753 idlwave-system-class-info)
7754 (error "No help available for system class tags")) 7754 (error "No help available for system class tags"))
7755 (if (setq found-in (idlwave-class-found-in class-with)) 7755 (if (setq found-in (idlwave-class-found-in class-with))
@@ -7762,7 +7762,7 @@ property indicating the link is added."
7762(defun idlwave-class-or-superclass-with-tag (class tag) 7762(defun idlwave-class-or-superclass-with-tag (class tag)
7763 "Find and return the CLASS or one of its superclass with the 7763 "Find and return the CLASS or one of its superclass with the
7764associated TAG, if any." 7764associated TAG, if any."
7765 (let ((sclasses (cons class (cdr (assq 'all-inherits 7765 (let ((sclasses (cons class (cdr (assq 'all-inherits
7766 (idlwave-class-info class))))) 7766 (idlwave-class-info class)))))
7767 cl) 7767 cl)
7768 (catch 'exit 7768 (catch 'exit
@@ -7771,7 +7771,7 @@ associated TAG, if any."
7771 (let ((tags (idlwave-class-tags cl))) 7771 (let ((tags (idlwave-class-tags cl)))
7772 (while tags 7772 (while tags
7773 (if (eq t (compare-strings tag 0 nil (car tags) 0 nil t)) 7773 (if (eq t (compare-strings tag 0 nil (car tags) 0 nil t))
7774 (throw 'exit cl)) 7774 (throw 'exit cl))
7775 (setq tags (cdr tags)))))))) 7775 (setq tags (cdr tags))))))))
7776 7776
7777 7777
@@ -7794,8 +7794,8 @@ associated TAG, if any."
7794 (setcar entry (idlwave-sintern-sysvar (car entry) 'set)) 7794 (setcar entry (idlwave-sintern-sysvar (car entry) 'set))
7795 (setq tags (assq 'tags entry)) 7795 (setq tags (assq 'tags entry))
7796 (if tags 7796 (if tags
7797 (setcdr tags 7797 (setcdr tags
7798 (mapcar (lambda (x) 7798 (mapcar (lambda (x)
7799 (cons (idlwave-sintern-sysvartag (car x) 'set) 7799 (cons (idlwave-sintern-sysvartag (car x) 'set)
7800 (cdr x))) 7800 (cdr x)))
7801 (cdr tags))))))) 7801 (cdr tags)))))))
@@ -7812,19 +7812,19 @@ associated TAG, if any."
7812 text start) 7812 text start)
7813 (setq start (match-end 0) 7813 (setq start (match-end 0)
7814 var (match-string 1 text) 7814 var (match-string 1 text)
7815 tags (if (match-end 3) 7815 tags (if (match-end 3)
7816 (idlwave-split-string (match-string 3 text)))) 7816 (idlwave-split-string (match-string 3 text))))
7817 ;; Maintain old links, if present 7817 ;; Maintain old links, if present
7818 (setq old-entry (assq (idlwave-sintern-sysvar var) old)) 7818 (setq old-entry (assq (idlwave-sintern-sysvar var) old))
7819 (setq link (assq 'link old-entry)) 7819 (setq link (assq 'link old-entry))
7820 (setq idlwave-system-variables-alist 7820 (setq idlwave-system-variables-alist
7821 (cons (list var 7821 (cons (list var
7822 (cons 7822 (cons
7823 'tags 7823 'tags
7824 (mapcar (lambda (x) 7824 (mapcar (lambda (x)
7825 (cons x 7825 (cons x
7826 (cdr (assq 7826 (cdr (assq
7827 (idlwave-sintern-sysvartag x) 7827 (idlwave-sintern-sysvartag x)
7828 (cdr (assq 'tags old-entry)))))) 7828 (cdr (assq 'tags old-entry))))))
7829 tags)) link) 7829 tags)) link)
7830 idlwave-system-variables-alist))) 7830 idlwave-system-variables-alist)))
@@ -7846,9 +7846,9 @@ associated TAG, if any."
7846 7846
7847(defun idlwave-uniquify (list) 7847(defun idlwave-uniquify (list)
7848 (let ((ht (make-hash-table :size (length list) :test 'equal))) 7848 (let ((ht (make-hash-table :size (length list) :test 'equal)))
7849 (delq nil 7849 (delq nil
7850 (mapcar (lambda (x) 7850 (mapcar (lambda (x)
7851 (unless (gethash x ht) 7851 (unless (gethash x ht)
7852 (puthash x t ht) 7852 (puthash x t ht)
7853 x)) 7853 x))
7854 list)))) 7854 list))))
@@ -7876,11 +7876,11 @@ Restore the pre-completion window configuration if possible."
7876 nil))) 7876 nil)))
7877 7877
7878 ;; Restore the pre-completion window configuration if this is safe. 7878 ;; Restore the pre-completion window configuration if this is safe.
7879 7879
7880 (if (or (eq verify 'force) ; force 7880 (if (or (eq verify 'force) ; force
7881 (and 7881 (and
7882 (get-buffer-window "*Completions*") ; visible 7882 (get-buffer-window "*Completions*") ; visible
7883 (idlwave-local-value 'idlwave-completion-p 7883 (idlwave-local-value 'idlwave-completion-p
7884 "*Completions*") ; cib-buffer 7884 "*Completions*") ; cib-buffer
7885 (eq (marker-buffer idlwave-completion-mark) 7885 (eq (marker-buffer idlwave-completion-mark)
7886 (current-buffer)) ; buffer OK 7886 (current-buffer)) ; buffer OK
@@ -7978,7 +7978,7 @@ With ARG, enforce query for the class of object methods."
7978 (if (string-match "\\(pro\\|function\\)[ \t]+\\(\\(.*\\)::\\)?\\(.*\\)" 7978 (if (string-match "\\(pro\\|function\\)[ \t]+\\(\\(.*\\)::\\)?\\(.*\\)"
7979 resolve) 7979 resolve)
7980 (setq type (match-string 1 resolve) 7980 (setq type (match-string 1 resolve)
7981 class (if (match-beginning 2) 7981 class (if (match-beginning 2)
7982 (match-string 3 resolve) 7982 (match-string 3 resolve)
7983 nil) 7983 nil)
7984 name (match-string 4 resolve))) 7984 name (match-string 4 resolve)))
@@ -7987,15 +7987,15 @@ With ARG, enforce query for the class of object methods."
7987 7987
7988 (cond 7988 (cond
7989 ((null class) 7989 ((null class)
7990 (idlwave-shell-send-command 7990 (idlwave-shell-send-command
7991 (format "resolve_routine,'%s'%s" (downcase name) kwd) 7991 (format "resolve_routine,'%s'%s" (downcase name) kwd)
7992 'idlwave-update-routine-info 7992 'idlwave-update-routine-info
7993 nil t)) 7993 nil t))
7994 (t 7994 (t
7995 (idlwave-shell-send-command 7995 (idlwave-shell-send-command
7996 (format "resolve_routine,'%s__define'%s" (downcase class) kwd) 7996 (format "resolve_routine,'%s__define'%s" (downcase class) kwd)
7997 (list 'idlwave-shell-send-command 7997 (list 'idlwave-shell-send-command
7998 (format "resolve_routine,'%s__%s'%s" 7998 (format "resolve_routine,'%s__%s'%s"
7999 (downcase class) (downcase name) kwd) 7999 (downcase class) (downcase name) kwd)
8000 '(idlwave-update-routine-info) 8000 '(idlwave-update-routine-info)
8001 nil t)))))) 8001 nil t))))))
@@ -8016,19 +8016,19 @@ force class query for object methods."
8016 (this-buffer (equal arg '(4))) 8016 (this-buffer (equal arg '(4)))
8017 (module (idlwave-fix-module-if-obj_new (idlwave-what-module))) 8017 (module (idlwave-fix-module-if-obj_new (idlwave-what-module)))
8018 (default (if module 8018 (default (if module
8019 (concat (idlwave-make-full-name 8019 (concat (idlwave-make-full-name
8020 (nth 2 module) (car module)) 8020 (nth 2 module) (car module))
8021 (if (eq (nth 1 module) 'pro) "<p>" "<f>")) 8021 (if (eq (nth 1 module) 'pro) "<p>" "<f>"))
8022 "none")) 8022 "none"))
8023 (list 8023 (list
8024 (idlwave-uniquify 8024 (idlwave-uniquify
8025 (delq nil 8025 (delq nil
8026 (mapcar (lambda (x) 8026 (mapcar (lambda (x)
8027 (if (eq 'system (car-safe (nth 3 x))) 8027 (if (eq 'system (car-safe (nth 3 x)))
8028 ;; Take out system routines with no source. 8028 ;; Take out system routines with no source.
8029 nil 8029 nil
8030 (list 8030 (list
8031 (concat (idlwave-make-full-name 8031 (concat (idlwave-make-full-name
8032 (nth 2 x) (car x)) 8032 (nth 2 x) (car x))
8033 (if (eq (nth 1 x) 'pro) "<p>" "<f>"))))) 8033 (if (eq (nth 1 x) 'pro) "<p>" "<f>")))))
8034 (if this-buffer 8034 (if this-buffer
@@ -8057,10 +8057,10 @@ force class query for object methods."
8057 (t t))) 8057 (t t)))
8058 (idlwave-do-find-module name type class nil this-buffer))) 8058 (idlwave-do-find-module name type class nil this-buffer)))
8059 8059
8060(defun idlwave-do-find-module (name type class 8060(defun idlwave-do-find-module (name type class
8061 &optional force-source this-buffer) 8061 &optional force-source this-buffer)
8062 (let ((name1 (idlwave-make-full-name class name)) 8062 (let ((name1 (idlwave-make-full-name class name))
8063 source buf1 entry 8063 source buf1 entry
8064 (buf (current-buffer)) 8064 (buf (current-buffer))
8065 (pos (point)) 8065 (pos (point))
8066 file name2) 8066 file name2)
@@ -8070,11 +8070,11 @@ force class query for object methods."
8070 name2 (if (nth 2 entry) 8070 name2 (if (nth 2 entry)
8071 (idlwave-make-full-name (nth 2 entry) name) 8071 (idlwave-make-full-name (nth 2 entry) name)
8072 name1)) 8072 name1))
8073 (if source 8073 (if source
8074 (setq file (idlwave-routine-source-file source))) 8074 (setq file (idlwave-routine-source-file source)))
8075 (unless file ; Try to find it on the path. 8075 (unless file ; Try to find it on the path.
8076 (setq file 8076 (setq file
8077 (idlwave-expand-lib-file-name 8077 (idlwave-expand-lib-file-name
8078 (if class 8078 (if class
8079 (format "%s__define.pro" (downcase class)) 8079 (format "%s__define.pro" (downcase class))
8080 (format "%s.pro" (downcase name)))))) 8080 (format "%s.pro" (downcase name))))))
@@ -8082,14 +8082,14 @@ force class query for object methods."
8082 ((or (null name) (equal name "")) 8082 ((or (null name) (equal name ""))
8083 (error "Abort")) 8083 (error "Abort"))
8084 ((eq (car source) 'system) 8084 ((eq (car source) 'system)
8085 (error "Source code for system routine %s is not available" 8085 (error "Source code for system routine %s is not available"
8086 name2)) 8086 name2))
8087 ((or (not file) (not (file-regular-p file))) 8087 ((or (not file) (not (file-regular-p file)))
8088 (error "Source code for routine %s is not available" 8088 (error "Source code for routine %s is not available"
8089 name2)) 8089 name2))
8090 (t 8090 (t
8091 (when (not this-buffer) 8091 (when (not this-buffer)
8092 (setq buf1 8092 (setq buf1
8093 (idlwave-find-file-noselect file 'find)) 8093 (idlwave-find-file-noselect file 'find))
8094 (pop-to-buffer buf1 t)) 8094 (pop-to-buffer buf1 t))
8095 (goto-char (point-max)) 8095 (goto-char (point-max))
@@ -8099,7 +8099,7 @@ force class query for object methods."
8099 (cond ((eq type 'fun) "function") 8099 (cond ((eq type 'fun) "function")
8100 ((eq type 'pro) "pro") 8100 ((eq type 'pro) "pro")
8101 (t "\\(pro\\|function\\)")) 8101 (t "\\(pro\\|function\\)"))
8102 "\\>[ \t]+" 8102 "\\>[ \t]+"
8103 (regexp-quote (downcase name2)) 8103 (regexp-quote (downcase name2))
8104 "[^a-zA-Z0-9_$]") 8104 "[^a-zA-Z0-9_$]")
8105 nil t) 8105 nil t)
@@ -8136,17 +8136,17 @@ Used by `idlwave-routine-info' and `idlwave-find-module'."
8136 (cond 8136 (cond
8137 ((and (eq cw 'procedure) 8137 ((and (eq cw 'procedure)
8138 (not (equal this-word ""))) 8138 (not (equal this-word "")))
8139 (setq this-word (idlwave-sintern-routine-or-method 8139 (setq this-word (idlwave-sintern-routine-or-method
8140 this-word (nth 2 (nth 3 where)))) 8140 this-word (nth 2 (nth 3 where))))
8141 (list this-word 'pro 8141 (list this-word 'pro
8142 (idlwave-determine-class 8142 (idlwave-determine-class
8143 (cons this-word (cdr (nth 3 where))) 8143 (cons this-word (cdr (nth 3 where)))
8144 'pro))) 8144 'pro)))
8145 ((and (eq cw 'function) 8145 ((and (eq cw 'function)
8146 (not (equal this-word "")) 8146 (not (equal this-word ""))
8147 (or (eq next-char ?\() ; exclude arrays, vars. 8147 (or (eq next-char ?\() ; exclude arrays, vars.
8148 (looking-at "[a-zA-Z0-9_]*[ \t]*("))) 8148 (looking-at "[a-zA-Z0-9_]*[ \t]*(")))
8149 (setq this-word (idlwave-sintern-routine-or-method 8149 (setq this-word (idlwave-sintern-routine-or-method
8150 this-word (nth 2 (nth 3 where)))) 8150 this-word (nth 2 (nth 3 where))))
8151 (list this-word 'fun 8151 (list this-word 'fun
8152 (idlwave-determine-class 8152 (idlwave-determine-class
@@ -8183,7 +8183,7 @@ Used by `idlwave-routine-info' and `idlwave-find-module'."
8183 class))) 8183 class)))
8184 8184
8185(defun idlwave-fix-module-if-obj_new (module) 8185(defun idlwave-fix-module-if-obj_new (module)
8186 "Check if MODULE points to obj_new. 8186 "Check if MODULE points to obj_new.
8187If yes, and if the cursor is in the keyword region, change to the 8187If yes, and if the cursor is in the keyword region, change to the
8188appropriate Init method." 8188appropriate Init method."
8189 (let* ((name (car module)) 8189 (let* ((name (car module))
@@ -8204,7 +8204,7 @@ appropriate Init method."
8204 (idlwave-sintern-class class))))) 8204 (idlwave-sintern-class class)))))
8205 module)) 8205 module))
8206 8206
8207(defun idlwave-fix-keywords (name type class keywords 8207(defun idlwave-fix-keywords (name type class keywords
8208 &optional super-classes system) 8208 &optional super-classes system)
8209 "Update a list of keywords. 8209 "Update a list of keywords.
8210Translate OBJ_NEW, adding all super-class keywords, or all keywords 8210Translate OBJ_NEW, adding all super-class keywords, or all keywords
@@ -8225,34 +8225,34 @@ demand _EXTRA in the keyword list."
8225 string) 8225 string)
8226 (setq class (idlwave-sintern-class (match-string 1 string))) 8226 (setq class (idlwave-sintern-class (match-string 1 string)))
8227 (setq idlwave-current-obj_new-class class) 8227 (setq idlwave-current-obj_new-class class)
8228 (setq keywords 8228 (setq keywords
8229 (append keywords 8229 (append keywords
8230 (idlwave-entry-keywords 8230 (idlwave-entry-keywords
8231 (idlwave-rinfo-assq 8231 (idlwave-rinfo-assq
8232 (idlwave-sintern-method "INIT") 8232 (idlwave-sintern-method "INIT")
8233 'fun 8233 'fun
8234 class 8234 class
8235 (idlwave-routines)) 'do-link)))))) 8235 (idlwave-routines)) 'do-link))))))
8236 8236
8237 ;; If the class is `t', combine all keywords of all methods NAME 8237 ;; If the class is `t', combine all keywords of all methods NAME
8238 (when (eq class t) 8238 (when (eq class t)
8239 (mapc (lambda (entry) 8239 (mapc (lambda (entry)
8240 (and 8240 (and
8241 (nth 2 entry) ; non-nil class 8241 (nth 2 entry) ; non-nil class
8242 (eq (nth 1 entry) type) ; correct type 8242 (eq (nth 1 entry) type) ; correct type
8243 (setq keywords 8243 (setq keywords
8244 (append keywords 8244 (append keywords
8245 (idlwave-entry-keywords entry 'do-link))))) 8245 (idlwave-entry-keywords entry 'do-link)))))
8246 (idlwave-all-assq name (idlwave-routines))) 8246 (idlwave-all-assq name (idlwave-routines)))
8247 (setq keywords (idlwave-uniquify keywords))) 8247 (setq keywords (idlwave-uniquify keywords)))
8248 8248
8249 ;; If we have inheritance, add all keywords from superclasses, if 8249 ;; If we have inheritance, add all keywords from superclasses, if
8250 ;; the user indicated that method in `idlwave-keyword-class-inheritance' 8250 ;; the user indicated that method in `idlwave-keyword-class-inheritance'
8251 (when (and 8251 (when (and
8252 super-classes 8252 super-classes
8253 idlwave-keyword-class-inheritance 8253 idlwave-keyword-class-inheritance
8254 (stringp class) 8254 (stringp class)
8255 (or 8255 (or
8256 system 8256 system
8257 (assq (idlwave-sintern-keyword "_extra") keywords) 8257 (assq (idlwave-sintern-keyword "_extra") keywords)
8258 (assq (idlwave-sintern-keyword "_ref_extra") keywords)) 8258 (assq (idlwave-sintern-keyword "_ref_extra") keywords))
@@ -8270,7 +8270,7 @@ demand _EXTRA in the keyword list."
8270 (mapcar (lambda (k) (add-to-list 'keywords k)) 8270 (mapcar (lambda (k) (add-to-list 'keywords k))
8271 (idlwave-entry-keywords entry 'do-link)))) 8271 (idlwave-entry-keywords entry 'do-link))))
8272 (setq keywords (idlwave-uniquify keywords))) 8272 (setq keywords (idlwave-uniquify keywords)))
8273 8273
8274 ;; Return the final list 8274 ;; Return the final list
8275 keywords)) 8275 keywords))
8276 8276
@@ -8295,14 +8295,14 @@ If we do not know about MODULE, just return KEYWORD literally."
8295 (assq (idlwave-sintern-keyword "_REF_EXTRA") kwd-alist))) 8295 (assq (idlwave-sintern-keyword "_REF_EXTRA") kwd-alist)))
8296 (completion-ignore-case t) 8296 (completion-ignore-case t)
8297 candidates) 8297 candidates)
8298 (cond ((assq kwd kwd-alist) 8298 (cond ((assq kwd kwd-alist)
8299 kwd) 8299 kwd)
8300 ((setq candidates (all-completions kwd kwd-alist)) 8300 ((setq candidates (all-completions kwd kwd-alist))
8301 (if (= (length candidates) 1) 8301 (if (= (length candidates) 1)
8302 (car candidates) 8302 (car candidates)
8303 candidates)) 8303 candidates))
8304 ((and entry extra) 8304 ((and entry extra)
8305 ;; Inheritance may cause this keyword to be correct 8305 ;; Inheritance may cause this keyword to be correct
8306 keyword) 8306 keyword)
8307 (entry 8307 (entry
8308 ;; We do know the function, which does not have the keyword. 8308 ;; We do know the function, which does not have the keyword.
@@ -8314,13 +8314,13 @@ If we do not know about MODULE, just return KEYWORD literally."
8314 8314
8315(defvar idlwave-rinfo-mouse-map (make-sparse-keymap)) 8315(defvar idlwave-rinfo-mouse-map (make-sparse-keymap))
8316(defvar idlwave-rinfo-map (make-sparse-keymap)) 8316(defvar idlwave-rinfo-map (make-sparse-keymap))
8317(define-key idlwave-rinfo-mouse-map 8317(define-key idlwave-rinfo-mouse-map
8318 (if (featurep 'xemacs) [button2] [mouse-2]) 8318 (if (featurep 'xemacs) [button2] [mouse-2])
8319 'idlwave-mouse-active-rinfo) 8319 'idlwave-mouse-active-rinfo)
8320(define-key idlwave-rinfo-mouse-map 8320(define-key idlwave-rinfo-mouse-map
8321 (if (featurep 'xemacs) [(shift button2)] [(shift mouse-2)]) 8321 (if (featurep 'xemacs) [(shift button2)] [(shift mouse-2)])
8322 'idlwave-mouse-active-rinfo-shift) 8322 'idlwave-mouse-active-rinfo-shift)
8323(define-key idlwave-rinfo-mouse-map 8323(define-key idlwave-rinfo-mouse-map
8324 (if (featurep 'xemacs) [button3] [mouse-3]) 8324 (if (featurep 'xemacs) [button3] [mouse-3])
8325 'idlwave-mouse-active-rinfo-right) 8325 'idlwave-mouse-active-rinfo-right)
8326(define-key idlwave-rinfo-mouse-map " " 'idlwave-active-rinfo-space) 8326(define-key idlwave-rinfo-mouse-map " " 'idlwave-active-rinfo-space)
@@ -8346,7 +8346,7 @@ If we do not know about MODULE, just return KEYWORD literally."
8346 (let* ((initial-class (or initial-class class)) 8346 (let* ((initial-class (or initial-class class))
8347 (entry (or (idlwave-best-rinfo-assq name type class 8347 (entry (or (idlwave-best-rinfo-assq name type class
8348 (idlwave-routines)) 8348 (idlwave-routines))
8349 (idlwave-rinfo-assq name type class 8349 (idlwave-rinfo-assq name type class
8350 idlwave-unresolved-routines))) 8350 idlwave-unresolved-routines)))
8351 (name (or (car entry) name)) 8351 (name (or (car entry) name))
8352 (class (or (nth 2 entry) class)) 8352 (class (or (nth 2 entry) class))
@@ -8371,7 +8371,7 @@ If we do not know about MODULE, just return KEYWORD literally."
8371 (km-prop (if (featurep 'xemacs) 'keymap 'local-map)) 8371 (km-prop (if (featurep 'xemacs) 'keymap 'local-map))
8372 (face 'idlwave-help-link) 8372 (face 'idlwave-help-link)
8373 beg props win cnt total) 8373 beg props win cnt total)
8374 ;; Fix keywords, but don't add chained super-classes, since these 8374 ;; Fix keywords, but don't add chained super-classes, since these
8375 ;; are shown separately for that super-class 8375 ;; are shown separately for that super-class
8376 (setq keywords (idlwave-fix-keywords name type class keywords)) 8376 (setq keywords (idlwave-fix-keywords name type class keywords))
8377 (cond 8377 (cond
@@ -8413,7 +8413,7 @@ If we do not know about MODULE, just return KEYWORD literally."
8413 km-prop idlwave-rinfo-mouse-map 8413 km-prop idlwave-rinfo-mouse-map
8414 'help-echo help-echo-use 8414 'help-echo help-echo-use
8415 'data (cons 'usage data))) 8415 'data (cons 'usage data)))
8416 (if html-file (setq props (append (list 'face face 'link html-file) 8416 (if html-file (setq props (append (list 'face face 'link html-file)
8417 props))) 8417 props)))
8418 (insert "Usage: ") 8418 (insert "Usage: ")
8419 (setq beg (point)) 8419 (setq beg (point))
@@ -8422,14 +8422,14 @@ If we do not know about MODULE, just return KEYWORD literally."
8422 (format calling-seq name name name name)) 8422 (format calling-seq name name name name))
8423 "\n") 8423 "\n")
8424 (add-text-properties beg (point) props) 8424 (add-text-properties beg (point) props)
8425 8425
8426 (insert "Keywords:") 8426 (insert "Keywords:")
8427 (if (null keywords) 8427 (if (null keywords)
8428 (insert " No keywords accepted.") 8428 (insert " No keywords accepted.")
8429 (setq col 9) 8429 (setq col 9)
8430 (mapcar 8430 (mapcar
8431 (lambda (x) 8431 (lambda (x)
8432 (if (>= (+ col 1 (length (car x))) 8432 (if (>= (+ col 1 (length (car x)))
8433 (window-width)) 8433 (window-width))
8434 (progn 8434 (progn
8435 (insert "\n ") 8435 (insert "\n ")
@@ -8447,7 +8447,7 @@ If we do not know about MODULE, just return KEYWORD literally."
8447 (add-text-properties beg (point) props) 8447 (add-text-properties beg (point) props)
8448 (setq col (+ col 1 (length (car x))))) 8448 (setq col (+ col 1 (length (car x)))))
8449 keywords)) 8449 keywords))
8450 8450
8451 (setq cnt 1 total (length all)) 8451 (setq cnt 1 total (length all))
8452 ;; Here entry is (key file (list of type-conses)) 8452 ;; Here entry is (key file (list of type-conses))
8453 (while (setq entry (pop all)) 8453 (while (setq entry (pop all))
@@ -8460,7 +8460,7 @@ If we do not know about MODULE, just return KEYWORD literally."
8460 (cdr (car (nth 2 entry)))) 8460 (cdr (car (nth 2 entry))))
8461 'data (cons 'source data))) 8461 'data (cons 'source data)))
8462 (idlwave-insert-source-location 8462 (idlwave-insert-source-location
8463 (format "\n%-8s %s" 8463 (format "\n%-8s %s"
8464 (if (equal cnt 1) 8464 (if (equal cnt 1)
8465 (if (> total 1) "Sources:" "Source:") 8465 (if (> total 1) "Sources:" "Source:")
8466 "") 8466 "")
@@ -8469,7 +8469,7 @@ If we do not know about MODULE, just return KEYWORD literally."
8469 (incf cnt) 8469 (incf cnt)
8470 (when (and all (> cnt idlwave-rinfo-max-source-lines)) 8470 (when (and all (> cnt idlwave-rinfo-max-source-lines))
8471 ;; No more source lines, please 8471 ;; No more source lines, please
8472 (insert (format 8472 (insert (format
8473 "\n Source information truncated to %d entries." 8473 "\n Source information truncated to %d entries."
8474 idlwave-rinfo-max-source-lines)) 8474 idlwave-rinfo-max-source-lines))
8475 (setq all nil))) 8475 (setq all nil)))
@@ -8483,7 +8483,7 @@ If we do not know about MODULE, just return KEYWORD literally."
8483 (unwind-protect 8483 (unwind-protect
8484 (progn 8484 (progn
8485 (select-window win) 8485 (select-window win)
8486 (enlarge-window (- (/ (frame-height) 2) 8486 (enlarge-window (- (/ (frame-height) 2)
8487 (window-height))) 8487 (window-height)))
8488 (shrink-window-if-larger-than-buffer)) 8488 (shrink-window-if-larger-than-buffer))
8489 (select-window ww))))))))) 8489 (select-window ww)))))))))
@@ -8520,9 +8520,9 @@ it."
8520 ((and (not file) shell-flag) 8520 ((and (not file) shell-flag)
8521 (insert "Unresolved")) 8521 (insert "Unresolved"))
8522 8522
8523 ((null file) 8523 ((null file)
8524 (insert "ERROR")) 8524 (insert "ERROR"))
8525 8525
8526 ((idlwave-syslib-p file) 8526 ((idlwave-syslib-p file)
8527 (if (string-match "obsolete" (file-name-directory file)) 8527 (if (string-match "obsolete" (file-name-directory file))
8528 (insert "Obsolete ") 8528 (insert "Obsolete ")
@@ -8536,7 +8536,7 @@ it."
8536 ;; Old special syntax: a matching regexp 8536 ;; Old special syntax: a matching regexp
8537 ((setq special (idlwave-special-lib-test file)) 8537 ((setq special (idlwave-special-lib-test file))
8538 (insert (format "%-10s" special))) 8538 (insert (format "%-10s" special)))
8539 8539
8540 ;; Catch-all with file 8540 ;; Catch-all with file
8541 ((idlwave-lib-p file) (insert "Library ")) 8541 ((idlwave-lib-p file) (insert "Library "))
8542 8542
@@ -8551,7 +8551,7 @@ it."
8551 (if shell-flag "S" "-") 8551 (if shell-flag "S" "-")
8552 (if buffer-flag "B" "-") 8552 (if buffer-flag "B" "-")
8553 "] "))) 8553 "] ")))
8554 (when (> ndupl 1) 8554 (when (> ndupl 1)
8555 (setq beg (point)) 8555 (setq beg (point))
8556 (insert (format "(%dx) " ndupl)) 8556 (insert (format "(%dx) " ndupl))
8557 (add-text-properties beg (point) (list 'face 'bold))) 8557 (add-text-properties beg (point) (list 'face 'bold)))
@@ -8575,7 +8575,7 @@ Return the name of the special lib if there is a match."
8575 alist nil))) 8575 alist nil)))
8576 rtn) 8576 rtn)
8577 (t nil)))) 8577 (t nil))))
8578 8578
8579(defun idlwave-mouse-active-rinfo-right (ev) 8579(defun idlwave-mouse-active-rinfo-right (ev)
8580 (interactive "e") 8580 (interactive "e")
8581 (idlwave-mouse-active-rinfo ev 'right)) 8581 (idlwave-mouse-active-rinfo ev 'right))
@@ -8594,7 +8594,7 @@ Optional args RIGHT and SHIFT indicate, if mouse-3 was used, and if SHIFT
8594was pressed." 8594was pressed."
8595 (interactive "e") 8595 (interactive "e")
8596 (if ev (mouse-set-point ev)) 8596 (if ev (mouse-set-point ev))
8597 (let (data id name type class buf bufwin source link keyword 8597 (let (data id name type class buf bufwin source link keyword
8598 word initial-class) 8598 word initial-class)
8599 (setq data (get-text-property (point) 'data) 8599 (setq data (get-text-property (point) 'data)
8600 source (get-text-property (point) 'source) 8600 source (get-text-property (point) 'source)
@@ -8609,9 +8609,9 @@ was pressed."
8609 8609
8610 (cond ((eq id 'class) ; Switch class being displayed 8610 (cond ((eq id 'class) ; Switch class being displayed
8611 (if (window-live-p bufwin) (select-window bufwin)) 8611 (if (window-live-p bufwin) (select-window bufwin))
8612 (idlwave-display-calling-sequence 8612 (idlwave-display-calling-sequence
8613 (idlwave-sintern-method name) 8613 (idlwave-sintern-method name)
8614 type (idlwave-sintern-class word) 8614 type (idlwave-sintern-class word)
8615 initial-class)) 8615 initial-class))
8616 ((eq id 'usage) ; Online help on this routine 8616 ((eq id 'usage) ; Online help on this routine
8617 (idlwave-online-help link name type class)) 8617 (idlwave-online-help link name type class))
@@ -8652,9 +8652,9 @@ was pressed."
8652 (setq bwin (get-buffer-window buffer))) 8652 (setq bwin (get-buffer-window buffer)))
8653 (if (eq (preceding-char) ?/) 8653 (if (eq (preceding-char) ?/)
8654 (insert keyword) 8654 (insert keyword)
8655 (unless (save-excursion 8655 (unless (save-excursion
8656 (re-search-backward 8656 (re-search-backward
8657 "[(,][ \t]*\\(\\$[ \t]*\\(;.*\\)?\n\\)?[ \t]*\\=" 8657 "[(,][ \t]*\\(\\$[ \t]*\\(;.*\\)?\n\\)?[ \t]*\\="
8658 (min (- (point) 100) (point-min)) t)) 8658 (min (- (point) 100) (point-min)) t))
8659 (insert ", ")) 8659 (insert ", "))
8660 (if shift (insert "/")) 8660 (if shift (insert "/"))
@@ -8706,7 +8706,7 @@ the load path in order to find a definition. The output of this
8706command can be used to detect possible name clashes during this process." 8706command can be used to detect possible name clashes during this process."
8707 (idlwave-routines) ; Make sure everything is loaded. 8707 (idlwave-routines) ; Make sure everything is loaded.
8708 (unless (or idlwave-user-catalog-routines idlwave-library-catalog-routines) 8708 (unless (or idlwave-user-catalog-routines idlwave-library-catalog-routines)
8709 (or (y-or-n-p 8709 (or (y-or-n-p
8710 "You don't have any user or library catalogs. Continue anyway? ") 8710 "You don't have any user or library catalogs. Continue anyway? ")
8711 (error "Abort"))) 8711 (error "Abort")))
8712 (let* ((routines (append idlwave-system-routines 8712 (let* ((routines (append idlwave-system-routines
@@ -8719,7 +8719,7 @@ command can be used to detect possible name clashes during this process."
8719 (keymap (make-sparse-keymap)) 8719 (keymap (make-sparse-keymap))
8720 (props (list 'mouse-face 'highlight 8720 (props (list 'mouse-face 'highlight
8721 km-prop keymap 8721 km-prop keymap
8722 'help-echo "Mouse2: Find source")) 8722 'help-echo "Mouse2: Find source"))
8723 (nroutines (length (or special-routines routines))) 8723 (nroutines (length (or special-routines routines)))
8724 (step (/ nroutines 100)) 8724 (step (/ nroutines 100))
8725 (n 0) 8725 (n 0)
@@ -8742,13 +8742,13 @@ command can be used to detect possible name clashes during this process."
8742 (message "Sorting routines...done") 8742 (message "Sorting routines...done")
8743 8743
8744 (define-key keymap (if (featurep 'xemacs) [(button2)] [(mouse-2)]) 8744 (define-key keymap (if (featurep 'xemacs) [(button2)] [(mouse-2)])
8745 (lambda (ev) 8745 (lambda (ev)
8746 (interactive "e") 8746 (interactive "e")
8747 (mouse-set-point ev) 8747 (mouse-set-point ev)
8748 (apply 'idlwave-do-find-module 8748 (apply 'idlwave-do-find-module
8749 (get-text-property (point) 'find-args)))) 8749 (get-text-property (point) 'find-args))))
8750 (define-key keymap [(return)] 8750 (define-key keymap [(return)]
8751 (lambda () 8751 (lambda ()
8752 (interactive) 8752 (interactive)
8753 (apply 'idlwave-do-find-module 8753 (apply 'idlwave-do-find-module
8754 (get-text-property (point) 'find-args)))) 8754 (get-text-property (point) 'find-args))))
@@ -8774,13 +8774,13 @@ command can be used to detect possible name clashes during this process."
8774 (> (idlwave-count-memq 'buffer (nth 2 (car dtwins))) 1)) 8774 (> (idlwave-count-memq 'buffer (nth 2 (car dtwins))) 1))
8775 (incf cnt) 8775 (incf cnt)
8776 (insert (format "\n%s%s" 8776 (insert (format "\n%s%s"
8777 (idlwave-make-full-name (nth 2 routine) 8777 (idlwave-make-full-name (nth 2 routine)
8778 (car routine)) 8778 (car routine))
8779 (if (eq (nth 1 routine) 'fun) "()" ""))) 8779 (if (eq (nth 1 routine) 'fun) "()" "")))
8780 (while (setq twin (pop dtwins)) 8780 (while (setq twin (pop dtwins))
8781 (setq props1 (append (list 'find-args 8781 (setq props1 (append (list 'find-args
8782 (list (nth 0 routine) 8782 (list (nth 0 routine)
8783 (nth 1 routine) 8783 (nth 1 routine)
8784 (nth 2 routine))) 8784 (nth 2 routine)))
8785 props)) 8785 props))
8786 (idlwave-insert-source-location "\n - " twin props1)))) 8786 (idlwave-insert-source-location "\n - " twin props1))))
@@ -8803,7 +8803,7 @@ command can be used to detect possible name clashes during this process."
8803 (or (not (stringp sfile)) 8803 (or (not (stringp sfile))
8804 (not (string-match "\\S-" sfile)))) 8804 (not (string-match "\\S-" sfile))))
8805 (setq stype 'unresolved)) 8805 (setq stype 'unresolved))
8806 (princ (format " %-10s %s\n" 8806 (princ (format " %-10s %s\n"
8807 stype 8807 stype
8808 (if sfile sfile "No source code available"))))) 8808 (if sfile sfile "No source code available")))))
8809 8809
@@ -8822,20 +8822,20 @@ ENTRY will also be returned, as the first item of this list."
8822 (eq type (nth 1 candidate)) 8822 (eq type (nth 1 candidate))
8823 (eq class (nth 2 candidate))) 8823 (eq class (nth 2 candidate)))
8824 (push candidate twins))) 8824 (push candidate twins)))
8825 (if (setq candidate (idlwave-rinfo-assq name type class 8825 (if (setq candidate (idlwave-rinfo-assq name type class
8826 idlwave-unresolved-routines)) 8826 idlwave-unresolved-routines))
8827 (push candidate twins)) 8827 (push candidate twins))
8828 (cons entry (nreverse twins)))) 8828 (cons entry (nreverse twins))))
8829 8829
8830(defun idlwave-study-twins (entries) 8830(defun idlwave-study-twins (entries)
8831 "Return dangerous twins of first entry in ENTRIES. 8831 "Return dangerous twins of first entry in ENTRIES.
8832Dangerous twins are routines with same name, but in different files on 8832Dangerous twins are routines with same name, but in different files on
8833the load path. If a file is in the system library and has an entry in 8833the load path. If a file is in the system library and has an entry in
8834the `idlwave-system-routines' list, we omit the latter as 8834the `idlwave-system-routines' list, we omit the latter as
8835non-dangerous because many IDL routines are implemented as library 8835non-dangerous because many IDL routines are implemented as library
8836routines, and may have been scanned." 8836routines, and may have been scanned."
8837 (let* ((entry (car entries)) 8837 (let* ((entry (car entries))
8838 (name (car entry)) ; 8838 (name (car entry)) ;
8839 (type (nth 1 entry)) ; Must be bound for 8839 (type (nth 1 entry)) ; Must be bound for
8840 (class (nth 2 entry)) ; idlwave-routine-twin-compare 8840 (class (nth 2 entry)) ; idlwave-routine-twin-compare
8841 (cnt 0) 8841 (cnt 0)
@@ -8853,23 +8853,23 @@ routines, and may have been scanned."
8853 (t 'unresolved))) 8853 (t 'unresolved)))
8854 8854
8855 ;; Check for an entry in the system library 8855 ;; Check for an entry in the system library
8856 (if (and file 8856 (if (and file
8857 (not syslibp) 8857 (not syslibp)
8858 (idlwave-syslib-p file)) 8858 (idlwave-syslib-p file))
8859 (setq syslibp t)) 8859 (setq syslibp t))
8860 8860
8861 ;; If there's more than one matching entry for the same file, just 8861 ;; If there's more than one matching entry for the same file, just
8862 ;; append the type-cons to the type list. 8862 ;; append the type-cons to the type list.
8863 (if (setq entry (assoc key alist)) 8863 (if (setq entry (assoc key alist))
8864 (push type-cons (nth 2 entry)) 8864 (push type-cons (nth 2 entry))
8865 (push (list key file (list type-cons)) alist))) 8865 (push (list key file (list type-cons)) alist)))
8866 8866
8867 (setq alist (nreverse alist)) 8867 (setq alist (nreverse alist))
8868 8868
8869 (when syslibp 8869 (when syslibp
8870 ;; File is in system *library* - remove any 'system entry 8870 ;; File is in system *library* - remove any 'system entry
8871 (setq alist (delq (assq 'system alist) alist))) 8871 (setq alist (delq (assq 'system alist) alist)))
8872 8872
8873 ;; If 'system remains and we've scanned the syslib, it's a builtin 8873 ;; If 'system remains and we've scanned the syslib, it's a builtin
8874 ;; (rather than a !DIR/lib/.pro file bundled as source). 8874 ;; (rather than a !DIR/lib/.pro file bundled as source).
8875 (when (and (idlwave-syslib-scanned-p) 8875 (when (and (idlwave-syslib-scanned-p)
@@ -8905,7 +8905,7 @@ compares twins on the basis of their file names and path locations."
8905 ((not (eq type (nth 1 b))) 8905 ((not (eq type (nth 1 b)))
8906 ;; Type decides 8906 ;; Type decides
8907 (< (if (eq type 'fun) 1 0) (if (eq (nth 1 b) 'fun) 1 0))) 8907 (< (if (eq type 'fun) 1 0) (if (eq (nth 1 b) 'fun) 1 0)))
8908 (t 8908 (t
8909 ;; A and B are twins - so the decision is more complicated. 8909 ;; A and B are twins - so the decision is more complicated.
8910 ;; Call twin-compare with the proper arguments. 8910 ;; Call twin-compare with the proper arguments.
8911 (idlwave-routine-entry-compare-twins a b))))) 8911 (idlwave-routine-entry-compare-twins a b)))))
@@ -8957,7 +8957,7 @@ This expects NAME TYPE CLASS to be bound to the right values."
8957 (tpath-alist (idlwave-true-path-alist)) 8957 (tpath-alist (idlwave-true-path-alist))
8958 (apathp (and (stringp akey) 8958 (apathp (and (stringp akey)
8959 (assoc (file-name-directory akey) tpath-alist))) 8959 (assoc (file-name-directory akey) tpath-alist)))
8960 (bpathp (and (stringp bkey) 8960 (bpathp (and (stringp bkey)
8961 (assoc (file-name-directory bkey) tpath-alist))) 8961 (assoc (file-name-directory bkey) tpath-alist)))
8962 ;; How early on search path? High number means early since we 8962 ;; How early on search path? High number means early since we
8963 ;; measure the tail of the path list 8963 ;; measure the tail of the path list
@@ -8993,7 +8993,7 @@ This expects NAME TYPE CLASS to be bound to the right values."
8993 (t nil)))) ; Default 8993 (t nil)))) ; Default
8994 8994
8995(defun idlwave-routine-source-file (source) 8995(defun idlwave-routine-source-file (source)
8996 (if (nth 2 source) 8996 (if (nth 2 source)
8997 (expand-file-name (nth 1 source) (nth 2 source)) 8997 (expand-file-name (nth 1 source) (nth 2 source))
8998 (nth 1 source))) 8998 (nth 1 source)))
8999 8999
@@ -9083,7 +9083,7 @@ Assumes that point is at the beginning of the unit as found by
9083 (forward-sexp 2) 9083 (forward-sexp 2)
9084 (forward-sexp -1) 9084 (forward-sexp -1)
9085 (let ((begin (point))) 9085 (let ((begin (point)))
9086 (re-search-forward 9086 (re-search-forward
9087 "[a-zA-Z_][a-zA-Z0-9$_]+\\(::[a-zA-Z_][a-zA-Z0-9$_]+\\)?") 9087 "[a-zA-Z_][a-zA-Z0-9$_]+\\(::[a-zA-Z_][a-zA-Z0-9$_]+\\)?")
9088 (if (fboundp 'buffer-substring-no-properties) 9088 (if (fboundp 'buffer-substring-no-properties)
9089 (buffer-substring-no-properties begin (point)) 9089 (buffer-substring-no-properties begin (point))
@@ -9123,7 +9123,7 @@ Assumes that point is at the beginning of the unit as found by
9123 (start-process "idldeclient" nil 9123 (start-process "idldeclient" nil
9124 idlwave-shell-explicit-file-name "-c" "-e" 9124 idlwave-shell-explicit-file-name "-c" "-e"
9125 (buffer-file-name))) 9125 (buffer-file-name)))
9126 9126
9127(defvar idlwave-help-use-assistant) 9127(defvar idlwave-help-use-assistant)
9128(defun idlwave-launch-idlhelp () 9128(defun idlwave-launch-idlhelp ()
9129 "Start the IDLhelp application." 9129 "Start the IDLhelp application."
@@ -9131,7 +9131,7 @@ Assumes that point is at the beginning of the unit as found by
9131 (if idlwave-help-use-assistant 9131 (if idlwave-help-use-assistant
9132 (idlwave-help-assistant-raise) 9132 (idlwave-help-assistant-raise)
9133 (start-process "idlhelp" nil idlwave-help-application))) 9133 (start-process "idlhelp" nil idlwave-help-application)))
9134 9134
9135;; Menus - using easymenu.el 9135;; Menus - using easymenu.el
9136(defvar idlwave-mode-menu-def 9136(defvar idlwave-mode-menu-def
9137 `("IDLWAVE" 9137 `("IDLWAVE"
@@ -9150,7 +9150,7 @@ Assumes that point is at the beginning of the unit as found by
9150 ["Block" idlwave-mark-block t] 9150 ["Block" idlwave-mark-block t]
9151 ["Header" idlwave-mark-doclib t]) 9151 ["Header" idlwave-mark-doclib t])
9152 ("Format" 9152 ("Format"
9153 ["Indent Entire Statement" idlwave-indent-statement 9153 ["Indent Entire Statement" idlwave-indent-statement
9154 :active t :keys "C-u \\[indent-for-tab-command]" ] 9154 :active t :keys "C-u \\[indent-for-tab-command]" ]
9155 ["Indent Subprogram" idlwave-indent-subprogram t] 9155 ["Indent Subprogram" idlwave-indent-subprogram t]
9156 ["(Un)Comment Region" idlwave-toggle-comment-region t] 9156 ["(Un)Comment Region" idlwave-toggle-comment-region t]
@@ -9220,7 +9220,7 @@ Assumes that point is at the beginning of the unit as found by
9220 ("Customize" 9220 ("Customize"
9221 ["Browse IDLWAVE Group" idlwave-customize t] 9221 ["Browse IDLWAVE Group" idlwave-customize t]
9222 "--" 9222 "--"
9223 ["Build Full Customize Menu" idlwave-create-customize-menu 9223 ["Build Full Customize Menu" idlwave-create-customize-menu
9224 (fboundp 'customize-menu-create)]) 9224 (fboundp 'customize-menu-create)])
9225 ("Documentation" 9225 ("Documentation"
9226 ["Describe Mode" describe-mode t] 9226 ["Describe Mode" describe-mode t]
@@ -9237,22 +9237,22 @@ Assumes that point is at the beginning of the unit as found by
9237 '("Debug" 9237 '("Debug"
9238 ["Start IDL shell" idlwave-shell t] 9238 ["Start IDL shell" idlwave-shell t]
9239 ["Save and .RUN buffer" idlwave-shell-save-and-run 9239 ["Save and .RUN buffer" idlwave-shell-save-and-run
9240 (and (boundp 'idlwave-shell-automatic-start) 9240 (and (boundp 'idlwave-shell-automatic-start)
9241 idlwave-shell-automatic-start)])) 9241 idlwave-shell-automatic-start)]))
9242 9242
9243(if (or (featurep 'easymenu) (load "easymenu" t)) 9243(if (or (featurep 'easymenu) (load "easymenu" t))
9244 (progn 9244 (progn
9245 (easy-menu-define idlwave-mode-menu idlwave-mode-map 9245 (easy-menu-define idlwave-mode-menu idlwave-mode-map
9246 "IDL and WAVE CL editing menu" 9246 "IDL and WAVE CL editing menu"
9247 idlwave-mode-menu-def) 9247 idlwave-mode-menu-def)
9248 (easy-menu-define idlwave-mode-debug-menu idlwave-mode-map 9248 (easy-menu-define idlwave-mode-debug-menu idlwave-mode-map
9249 "IDL and WAVE CL editing menu" 9249 "IDL and WAVE CL editing menu"
9250 idlwave-mode-debug-menu-def))) 9250 idlwave-mode-debug-menu-def)))
9251 9251
9252(defun idlwave-customize () 9252(defun idlwave-customize ()
9253 "Call the customize function with idlwave as argument." 9253 "Call the customize function with idlwave as argument."
9254 (interactive) 9254 (interactive)
9255 ;; Try to load the code for the shell, so that we can customize it 9255 ;; Try to load the code for the shell, so that we can customize it
9256 ;; as well. 9256 ;; as well.
9257 (or (featurep 'idlw-shell) 9257 (or (featurep 'idlw-shell)
9258 (load "idlw-shell" t)) 9258 (load "idlw-shell" t))
@@ -9263,11 +9263,11 @@ Assumes that point is at the beginning of the unit as found by
9263 (interactive) 9263 (interactive)
9264 (if (fboundp 'customize-menu-create) 9264 (if (fboundp 'customize-menu-create)
9265 (progn 9265 (progn
9266 ;; Try to load the code for the shell, so that we can customize it 9266 ;; Try to load the code for the shell, so that we can customize it
9267 ;; as well. 9267 ;; as well.
9268 (or (featurep 'idlw-shell) 9268 (or (featurep 'idlw-shell)
9269 (load "idlw-shell" t)) 9269 (load "idlw-shell" t))
9270 (easy-menu-change 9270 (easy-menu-change
9271 '("IDLWAVE") "Customize" 9271 '("IDLWAVE") "Customize"
9272 `(["Browse IDLWAVE group" idlwave-customize t] 9272 `(["Browse IDLWAVE group" idlwave-customize t]
9273 "--" 9273 "--"
@@ -9315,7 +9315,7 @@ This function was written since `list-abbrevs' looks terrible for IDLWAVE mode."
9315 (let ((table (symbol-value 'idlwave-mode-abbrev-table)) 9315 (let ((table (symbol-value 'idlwave-mode-abbrev-table))
9316 abbrevs 9316 abbrevs
9317 str rpl func fmt (len-str 0) (len-rpl 0)) 9317 str rpl func fmt (len-str 0) (len-rpl 0))
9318 (mapatoms 9318 (mapatoms
9319 (lambda (sym) 9319 (lambda (sym)
9320 (if (symbol-value sym) 9320 (if (symbol-value sym)
9321 (progn 9321 (progn
@@ -9341,7 +9341,7 @@ This function was written since `list-abbrevs' looks terrible for IDLWAVE mode."
9341 (with-output-to-temp-buffer "*Help*" 9341 (with-output-to-temp-buffer "*Help*"
9342 (if arg 9342 (if arg
9343 (progn 9343 (progn
9344 (princ "Abbreviations and Actions in IDLWAVE-Mode\n") 9344 (princ "Abbreviations and Actions in IDLWAVE-Mode\n")
9345 (princ "=========================================\n\n") 9345 (princ "=========================================\n\n")
9346 (princ (format fmt "KEY" "REPLACE" "HOOK")) 9346 (princ (format fmt "KEY" "REPLACE" "HOOK"))
9347 (princ (format fmt "---" "-------" "----"))) 9347 (princ (format fmt "---" "-------" "----")))
diff --git a/lisp/progmodes/make-mode.el b/lisp/progmodes/make-mode.el
index 109455e9e61..c7341a9f871 100644
--- a/lisp/progmodes/make-mode.el
+++ b/lisp/progmodes/make-mode.el
@@ -836,8 +836,8 @@ Makefile mode can be configured by modifying the following variables:
836 nil nil 836 nil nil
837 ((?$ . ".")) 837 ((?$ . "."))
838 backward-paragraph 838 backward-paragraph
839 (font-lock-syntactic-keywords . makefile-font-lock-syntactic-keywords) 839 (font-lock-syntactic-keywords
840 (font-lock-support-mode))) ; JIT breaks on long series of continuation lines. 840 . makefile-font-lock-syntactic-keywords)))
841 841
842 ;; Add-log. 842 ;; Add-log.
843 (make-local-variable 'add-log-current-defun-function) 843 (make-local-variable 'add-log-current-defun-function)
diff --git a/lisp/progmodes/prolog.el b/lisp/progmodes/prolog.el
index 14b47475eb1..c29a259c3a6 100644
--- a/lisp/progmodes/prolog.el
+++ b/lisp/progmodes/prolog.el
@@ -41,27 +41,27 @@
41 41
42 42
43(defcustom prolog-program-name 43(defcustom prolog-program-name
44 (let ((names '("prolog" "gprolog"))) 44 (let ((names '("prolog" "gprolog" "swipl")))
45 (while (and names 45 (while (and names
46 (not (executable-find (car names)))) 46 (not (executable-find (car names))))
47 (setq names (cdr names))) 47 (setq names (cdr names)))
48 (or (car names) "prolog")) 48 (or (car names) "prolog"))
49 "*Program name for invoking an inferior Prolog with `run-prolog'." 49 "Program name for invoking an inferior Prolog with `run-prolog'."
50 :type 'string 50 :type 'string
51 :group 'prolog) 51 :group 'prolog)
52 52
53(defcustom prolog-consult-string "reconsult(user).\n" 53(defcustom prolog-consult-string "reconsult(user).\n"
54 "*(Re)Consult mode (for C-Prolog and Quintus Prolog). " 54 "(Re)Consult mode (for C-Prolog and Quintus Prolog). "
55 :type 'string 55 :type 'string
56 :group 'prolog) 56 :group 'prolog)
57 57
58(defcustom prolog-compile-string "compile(user).\n" 58(defcustom prolog-compile-string "compile(user).\n"
59 "*Compile mode (for Quintus Prolog)." 59 "Compile mode (for Quintus Prolog)."
60 :type 'string 60 :type 'string
61 :group 'prolog) 61 :group 'prolog)
62 62
63(defcustom prolog-eof-string "end_of_file.\n" 63(defcustom prolog-eof-string "end_of_file.\n"
64 "*String that represents end of file for Prolog. 64 "String that represents end of file for Prolog.
65When nil, send actual operating system end of file." 65When nil, send actual operating system end of file."
66 :type 'string 66 :type 'string
67 :group 'prolog) 67 :group 'prolog)
@@ -121,7 +121,21 @@ When nil, send actual operating system end of file."
121(defvar prolog-mode-map 121(defvar prolog-mode-map
122 (let ((map (make-sparse-keymap))) 122 (let ((map (make-sparse-keymap)))
123 (define-key map "\e\C-x" 'prolog-consult-region) 123 (define-key map "\e\C-x" 'prolog-consult-region)
124 (define-key map "\C-c\C-l" 'inferior-prolog-load-file)
125 (define-key map "\C-c\C-z" 'switch-to-prolog)
124 map)) 126 map))
127
128(easy-menu-define prolog-mode-menu prolog-mode-map "Menu for Prolog mode."
129 ;; Mostly copied from scheme-mode's menu.
130 ;; Not tremendously useful, but it's a start.
131 '("Prolog"
132 ["Indent line" indent-according-to-mode t]
133 ["Indent region" indent-region t]
134 ["Comment region" comment-region t]
135 ["Uncomment region" uncomment-region t]
136 "--"
137 ["Run interactive Prolog session" run-prolog t]
138 ))
125 139
126;;;###autoload 140;;;###autoload
127(defun prolog-mode () 141(defun prolog-mode ()
@@ -138,29 +152,24 @@ if that value is non-nil."
138 (setq major-mode 'prolog-mode) 152 (setq major-mode 'prolog-mode)
139 (setq mode-name "Prolog") 153 (setq mode-name "Prolog")
140 (prolog-mode-variables) 154 (prolog-mode-variables)
155 (set (make-local-variable 'comment-add) 1)
141 ;; font lock 156 ;; font lock
142 (setq font-lock-defaults '(prolog-font-lock-keywords 157 (setq font-lock-defaults '(prolog-font-lock-keywords
143 nil nil nil 158 nil nil nil
144 beginning-of-line)) 159 beginning-of-line))
145 (run-mode-hooks 'prolog-mode-hook)) 160 (run-mode-hooks 'prolog-mode-hook))
146 161
147(defun prolog-indent-line (&optional whole-exp) 162(defun prolog-indent-line ()
148 "Indent current line as Prolog code. 163 "Indent current line as Prolog code.
149With argument, indent any additional lines of the same clause 164With argument, indent any additional lines of the same clause
150rigidly along with this one (not yet)." 165rigidly along with this one (not yet)."
151 (interactive "p") 166 (interactive "p")
152 (let ((indent (prolog-indent-level)) 167 (let ((indent (prolog-indent-level))
153 (pos (- (point-max) (point))) beg) 168 (pos (- (point-max) (point))))
154 (beginning-of-line) 169 (beginning-of-line)
155 (setq beg (point)) 170 (indent-line-to indent)
156 (skip-chars-forward " \t")
157 (if (zerop (- indent (current-column)))
158 nil
159 (delete-region beg (point))
160 (indent-to indent))
161 (if (> (- (point-max) pos) (point)) 171 (if (> (- (point-max) pos) (point))
162 (goto-char (- (point-max) pos))) 172 (goto-char (- (point-max) pos)))))
163 ))
164 173
165(defun prolog-indent-level () 174(defun prolog-indent-level ()
166 "Compute Prolog indentation level." 175 "Compute Prolog indentation level."
@@ -224,6 +233,8 @@ rigidly along with this one (not yet)."
224 (let ((map (make-sparse-keymap))) 233 (let ((map (make-sparse-keymap)))
225 ;; This map will inherit from `comint-mode-map' when entering 234 ;; This map will inherit from `comint-mode-map' when entering
226 ;; inferior-prolog-mode. 235 ;; inferior-prolog-mode.
236 (define-key map [remap self-insert-command]
237 'inferior-prolog-self-insert-command)
227 map)) 238 map))
228 239
229(defvar inferior-prolog-mode-syntax-table prolog-mode-syntax-table) 240(defvar inferior-prolog-mode-syntax-table prolog-mode-syntax-table)
@@ -256,36 +267,129 @@ Return not at end copies rest of line to end and sends it.
256 (setq comint-prompt-regexp "^| [ ?][- ] *") 267 (setq comint-prompt-regexp "^| [ ?][- ] *")
257 (prolog-mode-variables)) 268 (prolog-mode-variables))
258 269
270(defvar inferior-prolog-buffer nil)
271
272(defun inferior-prolog-run (&optional name)
273 (with-current-buffer (make-comint "prolog" (or name prolog-program-name))
274 (inferior-prolog-mode)
275 (setq-default inferior-prolog-buffer (current-buffer))
276 (make-local-variable 'inferior-prolog-buffer)
277 (when (and name (not (equal name prolog-program-name)))
278 (set (make-local-variable 'prolog-program-name) name))
279 (set (make-local-variable 'inferior-prolog-flavor)
280 ;; Force re-detection.
281 (let* ((proc (get-buffer-process (current-buffer)))
282 (pmark (and proc (marker-position (process-mark proc)))))
283 (cond
284 ((null pmark) (1- (point-min)))
285 ;; The use of insert-before-markers in comint.el together with
286 ;; the potential use of comint-truncate-buffer in the output
287 ;; filter, means that it's difficult to reliably keep track of
288 ;; the buffer position where the process's output started.
289 ;; If possible we use a marker at "start - 1", so that
290 ;; insert-before-marker at `start' won't shift it. And if not,
291 ;; we fall back on using a plain integer.
292 ((> pmark (point-min)) (copy-marker (1- pmark)))
293 (t (1- pmark)))))
294 (add-hook 'comint-output-filter-functions
295 'inferior-prolog-guess-flavor nil t)))
296
297(defun inferior-prolog-process (&optional dontstart)
298 (or (and (buffer-live-p inferior-prolog-buffer)
299 (get-buffer-process inferior-prolog-buffer))
300 (unless dontstart
301 (inferior-prolog-run)
302 ;; Try again.
303 (inferior-prolog-process))))
304
305(defvar inferior-prolog-flavor 'unknown
306 "Either a symbol or a buffer position offset by one.
307If a buffer position, the flavor has not been determined yet and
308it is expected that the process's output has been or will
309be inserted at that position plus one.")
310
311(defun inferior-prolog-guess-flavor (&optional ignored)
312 (save-excursion
313 (goto-char (1+ inferior-prolog-flavor))
314 (setq inferior-prolog-flavor
315 (cond
316 ((looking-at "GNU Prolog") 'gnu)
317 ((looking-at "Welcome to SWI-Prolog") 'swi)
318 ((looking-at ".*\n") 'unknown) ;There's at least one line.
319 (t inferior-prolog-flavor))))
320 (when (symbolp inferior-prolog-flavor)
321 (remove-hook 'comint-output-filter-functions
322 'inferior-prolog-guess-flavor t)
323 (if (eq inferior-prolog-flavor 'gnu)
324 (set (make-local-variable 'comint-process-echoes) t))))
325
259;;;###autoload 326;;;###autoload
260(defun run-prolog () 327(defalias 'run-prolog 'switch-to-prolog)
261 "Run an inferior Prolog process, input and output via buffer *prolog*." 328;;;###autoload
329(defun switch-to-prolog (&optional name)
330 "Run an inferior Prolog process, input and output via buffer *prolog*.
331With prefix argument \\[universal-prefix], prompt for the program to use."
332 (interactive
333 (list (when current-prefix-arg
334 (let ((proc (inferior-prolog-process 'dontstart)))
335 (if proc
336 (if (yes-or-no-p "Kill current process before starting new one? ")
337 (kill-process proc)
338 (error "Abort")))
339 (read-string "Run Prolog: " prolog-program-name)))))
340 (unless (inferior-prolog-process 'dontstart)
341 (inferior-prolog-run name))
342 (pop-to-buffer inferior-prolog-buffer))
343
344(defun inferior-prolog-self-insert-command ()
345 "Insert the char in the buffer or pass it directly to the process."
262 (interactive) 346 (interactive)
263 (require 'comint) 347 (let* ((proc (get-buffer-process (current-buffer)))
264 (pop-to-buffer (make-comint "prolog" prolog-program-name)) 348 (pmark (and proc (marker-position (process-mark proc)))))
265 (inferior-prolog-mode)) 349 (if (and (eq inferior-prolog-flavor 'gnu)
350 pmark
351 (null current-prefix-arg)
352 (eobp)
353 (eq (point) pmark)
354 (save-excursion
355 (goto-char (- pmark 3))
356 (looking-at " \\? ")))
357 (comint-send-string proc (string last-command-char))
358 (call-interactively 'self-insert-command))))
266 359
267(defun prolog-consult-region (compile beg end) 360(defun prolog-consult-region (compile beg end)
268 "Send the region to the Prolog process made by \"M-x run-prolog\". 361 "Send the region to the Prolog process made by \"M-x run-prolog\".
269If COMPILE (prefix arg) is not nil, use compile mode rather than consult mode." 362If COMPILE (prefix arg) is not nil, use compile mode rather than consult mode."
270 (interactive "P\nr") 363 (interactive "P\nr")
271 (save-excursion 364 (let ((proc (inferior-prolog-process)))
272 (if compile 365 (comint-send-string proc
273 (process-send-string "prolog" prolog-compile-string) 366 (if compile prolog-compile-string
274 (process-send-string "prolog" prolog-consult-string)) 367 prolog-consult-string))
275 (process-send-region "prolog" beg end) 368 (comint-send-region proc beg end)
276 (process-send-string "prolog" "\n") ;May be unnecessary 369 (comint-send-string proc "\n") ;May be unnecessary
277 (if prolog-eof-string 370 (if prolog-eof-string
278 (process-send-string "prolog" prolog-eof-string) 371 (comint-send-string proc prolog-eof-string)
279 (process-send-eof "prolog")))) ;Send eof to prolog process. 372 (with-current-buffer (process-buffer proc)
373 (comint-send-eof))))) ;Send eof to prolog process.
280 374
281(defun prolog-consult-region-and-go (compile beg end) 375(defun prolog-consult-region-and-go (compile beg end)
282 "Send the region to the inferior Prolog, and switch to *prolog* buffer. 376 "Send the region to the inferior Prolog, and switch to *prolog* buffer.
283If COMPILE (prefix arg) is not nil, use compile mode rather than consult mode." 377If COMPILE (prefix arg) is not nil, use compile mode rather than consult mode."
284 (interactive "P\nr") 378 (interactive "P\nr")
285 (prolog-consult-region compile beg end) 379 (prolog-consult-region compile beg end)
286 (switch-to-buffer "*prolog*")) 380 (pop-to-buffer inferior-prolog-buffer))
381
382(defun inferior-prolog-load-file ()
383 "Pass the current buffer's file to the inferior prolog process."
384 (interactive)
385 (save-buffer)
386 (let ((file buffer-file-name)
387 (proc (inferior-prolog-process)))
388 (with-current-buffer (process-buffer proc)
389 (comint-send-string proc (concat "['" (file-relative-name file) "'].\n"))
390 (pop-to-buffer (current-buffer)))))
287 391
288(provide 'prolog) 392(provide 'prolog)
289 393
290;;; arch-tag: f3ec6748-1272-4ab6-8826-c50cb1607636 394;; arch-tag: f3ec6748-1272-4ab6-8826-c50cb1607636
291;;; prolog.el ends here 395;;; prolog.el ends here
diff --git a/lisp/progmodes/python.el b/lisp/progmodes/python.el
index c38a6e82f83..0387c05134e 100644
--- a/lisp/progmodes/python.el
+++ b/lisp/progmodes/python.el
@@ -67,7 +67,8 @@
67(eval-when-compile 67(eval-when-compile
68 (require 'cl) 68 (require 'cl)
69 (require 'compile) 69 (require 'compile)
70 (require 'comint)) 70 (require 'comint)
71 (require 'hippie-exp))
71 72
72(autoload 'comint-mode "comint") 73(autoload 'comint-mode "comint")
73 74
@@ -95,7 +96,9 @@
95 "import" "in" "is" "lambda" "not" "or" "pass" "print" 96 "import" "in" "is" "lambda" "not" "or" "pass" "print"
96 "raise" "return" "try" "while" "yield" 97 "raise" "return" "try" "while" "yield"
97 ;; Future keywords 98 ;; Future keywords
98 "as" "None") 99 "as" "None"
100 ;; Not real keywords, but close enough to be fontified as such
101 "self" "True" "False")
99 symbol-end) 102 symbol-end)
100 ;; Definitions 103 ;; Definitions
101 (,(rx symbol-start (group "class") (1+ space) (group (1+ (or word ?_)))) 104 (,(rx symbol-start (group "class") (1+ space) (group (1+ (or word ?_))))
@@ -1286,7 +1289,7 @@ Don't save anything for STR matching `inferior-python-filter-regexp'."
1286 ;; Maybe we could be more selective here. 1289 ;; Maybe we could be more selective here.
1287 (if (zerop (length res)) 1290 (if (zerop (length res))
1288 (not (bolp)) 1291 (not (bolp))
1289 (string-match res ".\\'")))) 1292 (string-match ".\\'" res))))
1290 ;; The need for this seems to be system-dependent: 1293 ;; The need for this seems to be system-dependent:
1291 ;; What is this all about, exactly? --Stef 1294 ;; What is this all about, exactly? --Stef
1292 ;; (if (and (eq ?. (aref s 0))) 1295 ;; (if (and (eq ?. (aref s 0)))
@@ -1330,30 +1333,30 @@ buffer for a list of commands.)"
1330 ;; (not a name) in Python buffers from which `run-python' &c is 1333 ;; (not a name) in Python buffers from which `run-python' &c is
1331 ;; invoked. Would support multiple processes better. 1334 ;; invoked. Would support multiple processes better.
1332 (when (or new (not (comint-check-proc python-buffer))) 1335 (when (or new (not (comint-check-proc python-buffer)))
1333 (save-current-buffer 1336 (with-current-buffer
1334 (let* ((cmdlist (append (python-args-to-list cmd) '("-i"))) 1337 (let* ((cmdlist (append (python-args-to-list cmd) '("-i")))
1335 (path (getenv "PYTHONPATH")) 1338 (path (getenv "PYTHONPATH"))
1336 (process-environment ; to import emacs.py 1339 (process-environment ; to import emacs.py
1337 (cons (concat "PYTHONPATH=" data-directory 1340 (cons (concat "PYTHONPATH=" data-directory
1338 (if path (concat ":" path))) 1341 (if path (concat ":" path)))
1339 process-environment))) 1342 process-environment)))
1340 (set-buffer (apply 'make-comint-in-buffer "Python" 1343 (apply 'make-comint-in-buffer "Python"
1341 (generate-new-buffer "*Python*") 1344 (if new (generate-new-buffer "*Python*") "*Python*")
1342 (car cmdlist) nil (cdr cmdlist))) 1345 (car cmdlist) nil (cdr cmdlist)))
1343 (setq-default python-buffer (current-buffer)) 1346 (setq-default python-buffer (current-buffer))
1344 (setq python-buffer (current-buffer))) 1347 (setq python-buffer (current-buffer))
1345 (accept-process-output (get-buffer-process python-buffer) 5) 1348 (accept-process-output (get-buffer-process python-buffer) 5)
1346 (inferior-python-mode))) 1349 (inferior-python-mode)
1350 ;; Load function definitions we need.
1351 ;; Before the preoutput function was used, this was done via -c in
1352 ;; cmdlist, but that loses the banner and doesn't run the startup
1353 ;; file. The code might be inline here, but there's enough that it
1354 ;; seems worth putting in a separate file, and it's probably cleaner
1355 ;; to put it in a module.
1356 ;; Ensure we're at a prompt before doing anything else.
1357 (python-send-receive "import emacs; print '_emacs_out ()'")))
1347 (if (derived-mode-p 'python-mode) 1358 (if (derived-mode-p 'python-mode)
1348 (setq python-buffer (default-value 'python-buffer))) ; buffer-local 1359 (setq python-buffer (default-value 'python-buffer))) ; buffer-local
1349 ;; Load function definitions we need.
1350 ;; Before the preoutput function was used, this was done via -c in
1351 ;; cmdlist, but that loses the banner and doesn't run the startup
1352 ;; file. The code might be inline here, but there's enough that it
1353 ;; seems worth putting in a separate file, and it's probably cleaner
1354 ;; to put it in a module.
1355 ;; Ensure we're at a prompt before doing anything else.
1356 (python-send-receive "import emacs; print '_emacs_out ()'")
1357 ;; Without this, help output goes into the inferior python buffer if 1360 ;; Without this, help output goes into the inferior python buffer if
1358 ;; the process isn't already running. 1361 ;; the process isn't already running.
1359 (sit-for 1 t) ;Should we use accept-process-output instead? --Stef 1362 (sit-for 1 t) ;Should we use accept-process-output instead? --Stef
@@ -1369,15 +1372,20 @@ buffer for a list of commands.)"
1369(defun python-send-command (command) 1372(defun python-send-command (command)
1370 "Like `python-send-string' but resets `compilation-shell-minor-mode'. 1373 "Like `python-send-string' but resets `compilation-shell-minor-mode'.
1371COMMAND should be a single statement." 1374COMMAND should be a single statement."
1372 (assert (not (string-match "\n" command))) 1375 ;; (assert (not (string-match "\n" command)))
1373 (let ((end (marker-position (process-mark (python-proc))))) 1376 ;; (let ((end (marker-position (process-mark (python-proc)))))
1374 (with-current-buffer python-buffer (goto-char (point-max))) 1377 (with-current-buffer python-buffer (goto-char (point-max)))
1375 (compilation-forget-errors) 1378 (compilation-forget-errors)
1376 ;; Must wait until this has completed before re-setting variables below. 1379 (python-send-string command)
1377 (python-send-receive (concat command "; print '_emacs_out ()'"))
1378 (with-current-buffer python-buffer 1380 (with-current-buffer python-buffer
1379 (set-marker compilation-parsing-end end) 1381 (setq compilation-last-buffer (current-buffer)))
1380 (setq compilation-last-buffer (current-buffer))))) 1382 ;; No idea what this is for but it breaks the call to
1383 ;; compilation-fake-loc in python-send-region. -- Stef
1384 ;; Must wait until this has completed before re-setting variables below.
1385 ;; (python-send-receive "print '_emacs_out ()'")
1386 ;; (with-current-buffer python-buffer
1387 ;; (set-marker compilation-parsing-end end))
1388 ) ;;)
1381 1389
1382(defun python-send-region (start end) 1390(defun python-send-region (start end)
1383 "Send the region to the inferior Python process." 1391 "Send the region to the inferior Python process."
@@ -1419,11 +1427,13 @@ COMMAND should be a single statement."
1419 "Evaluate STRING in inferior Python process." 1427 "Evaluate STRING in inferior Python process."
1420 (interactive "sPython command: ") 1428 (interactive "sPython command: ")
1421 (comint-send-string (python-proc) string) 1429 (comint-send-string (python-proc) string)
1422 (comint-send-string (python-proc) 1430 (unless (string-match "\n\\'" string)
1423 ;; If the string is single-line or if it ends with \n, 1431 ;; Make sure the text is properly LF-terminated.
1424 ;; only add a single \n, otherwise add 2, so as to 1432 (comint-send-string (python-proc) "\n"))
1425 ;; make sure we terminate the multiline instruction. 1433 (when (string-match "\n[ \t].*\n?\\'" string)
1426 (if (string-match "\n.+\\'" string) "\n\n" "\n"))) 1434 ;; If the string contains a final indented line, add a second newline so
1435 ;; as to make sure we terminate the multiline instruction.
1436 (comint-send-string (python-proc) "\n")))
1427 1437
1428(defun python-send-buffer () 1438(defun python-send-buffer ()
1429 "Send the current buffer to the inferior Python process." 1439 "Send the current buffer to the inferior Python process."
@@ -1594,24 +1604,26 @@ Only works when point is in a function name, not its arg list, for
1594instance. Assumes an inferior Python is running." 1604instance. Assumes an inferior Python is running."
1595 (let ((symbol (with-syntax-table python-dotty-syntax-table 1605 (let ((symbol (with-syntax-table python-dotty-syntax-table
1596 (current-word)))) 1606 (current-word))))
1597 ;; First try the symbol we're on. 1607 ;; This is run from timers, so inhibit-quit tends to be set.
1598 (or (and symbol 1608 (with-local-quit
1599 (python-send-receive (format "emacs.eargs(%S, %s)" 1609 ;; First try the symbol we're on.
1600 symbol python-imports))) 1610 (or (and symbol
1601 ;; Try moving to symbol before enclosing parens. 1611 (python-send-receive (format "emacs.eargs(%S, %s)"
1602 (let ((s (syntax-ppss))) 1612 symbol python-imports)))
1603 (unless (zerop (car s)) 1613 ;; Try moving to symbol before enclosing parens.
1604 (when (eq ?\( (char-after (nth 1 s))) 1614 (let ((s (syntax-ppss)))
1605 (save-excursion 1615 (unless (zerop (car s))
1606 (goto-char (nth 1 s)) 1616 (when (eq ?\( (char-after (nth 1 s)))
1607 (skip-syntax-backward "-") 1617 (save-excursion
1608 (let ((point (point))) 1618 (goto-char (nth 1 s))
1609 (skip-chars-backward "a-zA-Z._") 1619 (skip-syntax-backward "-")
1610 (if (< (point) point) 1620 (let ((point (point)))
1611 (python-send-receive 1621 (skip-chars-backward "a-zA-Z._")
1612 (format "emacs.eargs(%S, %s)" 1622 (if (< (point) point)
1613 (buffer-substring-no-properties (point) point) 1623 (python-send-receive
1614 python-imports))))))))))) 1624 (format "emacs.eargs(%S, %s)"
1625 (buffer-substring-no-properties (point) point)
1626 python-imports))))))))))))
1615 1627
1616;;;; Info-look functionality. 1628;;;; Info-look functionality.
1617 1629
diff --git a/lisp/progmodes/sh-script.el b/lisp/progmodes/sh-script.el
index f828c36917b..83b4bdea759 100644
--- a/lisp/progmodes/sh-script.el
+++ b/lisp/progmodes/sh-script.el
@@ -2460,46 +2460,45 @@ we go to the end of the previous line and do not check for continuations."
2460 ;; 2460 ;;
2461 (if (bolp) 2461 (if (bolp)
2462 nil 2462 nil
2463 (let (c min-point 2463 (let ((start (point))
2464 (start (point))) 2464 (min-point (if (sh-this-is-a-continuation)
2465 (save-restriction 2465 (sh-prev-line nil)
2466 (narrow-to-region 2466 (line-beginning-position))))
2467 (if (sh-this-is-a-continuation) 2467 (skip-chars-backward " \t;" min-point)
2468 (setq min-point (sh-prev-line nil)) 2468 (if (looking-at "\\s-*;;")
2469 (save-excursion 2469 ;; (message "Found ;; !")
2470 (beginning-of-line) 2470 ";;"
2471 (setq min-point (point)))) 2471 (skip-chars-backward "^)}];\"'`({[" min-point)
2472 (point)) 2472 (let ((c (if (> (point) min-point) (char-before))))
2473 (skip-chars-backward " \t;") 2473 (sh-debug "stopping at %d c is %s start=%d min-point=%d"
2474 (unless (looking-at "\\s-*;;") 2474 (point) c start min-point)
2475 (skip-chars-backward "^)}];\"'`({[") 2475 (if (not (memq c '(?\n nil ?\;)))
2476 (setq c (char-before)))) 2476 ;; c -- return a string
2477 (sh-debug "stopping at %d c is %s start=%d min-point=%d" 2477 (char-to-string c)
2478 (point) c start min-point) 2478 ;; Return the leading keyword of the "command" we supposedly
2479 (if (< (point) min-point) 2479 ;; skipped over. Maybe we skipped too far (e.g. past a `do' or
2480 (error "point %d < min-point %d" (point) min-point)) 2480 ;; `then' that precedes the actual command), so check whether
2481 (cond 2481 ;; we're looking at such a keyword and if so, move back forward.
2482 ((looking-at "\\s-*;;") 2482 (let ((boundary (point))
2483 ;; (message "Found ;; !") 2483 kwd next)
2484 ";;") 2484 (while
2485 ((or (eq c ?\n) 2485 (progn
2486 (eq c nil) 2486 ;; Skip forward over white space newline and \ at eol.
2487 (eq c ?\;)) 2487 (skip-chars-forward " \t\n\\\\" start)
2488 (save-excursion 2488 (if (>= (point) start)
2489 ;; skip forward over white space newline and \ at eol 2489 (progn
2490 (skip-chars-forward " \t\n\\\\") 2490 (sh-debug "point: %d >= start: %d" (point) start)
2491 (sh-debug "Now at %d start=%d" (point) start) 2491 nil)
2492 (if (>= (point) start) 2492 (if next (setq boundary next))
2493 (progn 2493 (sh-debug "Now at %d start=%d" (point) start)
2494 (sh-debug "point: %d >= start: %d" (point) start) 2494 (setq kwd (sh-get-word))
2495 nil) 2495 (if (member kwd (sh-feature sh-leading-keywords))
2496 (sh-get-word)) 2496 (progn
2497 )) 2497 (setq next (point))
2498 (t 2498 t)
2499 ;; c -- return a string 2499 nil))))
2500 (char-to-string c) 2500 (goto-char boundary)
2501 )) 2501 kwd)))))))
2502 )))
2503 2502
2504 2503
2505(defun sh-this-is-a-continuation () 2504(defun sh-this-is-a-continuation ()
@@ -2518,7 +2517,7 @@ If AND-MOVE is non-nil then move to end of word."
2518 (goto-char where)) 2517 (goto-char where))
2519 (prog1 2518 (prog1
2520 (buffer-substring (point) 2519 (buffer-substring (point)
2521 (progn (skip-chars-forward "^ \t\n;&")(point))) 2520 (progn (skip-chars-forward "^ \t\n;&|()")(point)))
2522 (unless and-move 2521 (unless and-move
2523 (goto-char start))))) 2522 (goto-char start)))))
2524 2523