;;; cperl-mode.el --- Perl code editing commands for Emacs
;; Copyright (C) 1985, 1986, 1987, 1991, 1992, 1993, 1994, 1995, 1996, 1997,
-;; 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007
+;; 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
;; Free Software Foundation, Inc.
-;; Author: Ilya Zakharevich and Bob Olson
+;; Author: Ilya Zakharevich
+;; Bob Olson
;; Maintainer: Ilya Zakharevich <ilyaz@cpan.org>
;; Keywords: languages, Perl
;; This file is part of GNU Emacs.
-;; GNU Emacs is free software; you can redistribute it and/or modify
+;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 3, or (at your option)
-;; any later version.
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs; see the file COPYING. If not, write to the
-;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
-;; Boston, MA 02110-1301, USA.
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
;;; Corrections made by Ilya Zakharevich ilyaz@cpan.org
(condition-case nil
(require 'man)
(error nil))
- (defconst cperl-xemacs-p (string-match "XEmacs\\|Lucid" emacs-version))
(defvar cperl-can-font-lock
- (or cperl-xemacs-p
+ (or (featurep 'xemacs)
(and (boundp 'emacs-major-version)
(or window-system
(> emacs-major-version 20)))))
(cperl-make-face ,arg ,descr))
(or (boundp (quote ,arg)) ; We use unquoted variants too
(defvar ,arg (quote ,arg) ,descr))))
- (if cperl-xemacs-p
+ (if (featurep 'xemacs)
(defmacro cperl-etags-snarf-tag (file line)
`(progn
(beginning-of-line 2)
(list ,file ,line)))
(defmacro cperl-etags-snarf-tag (file line)
`(etags-snarf-tag)))
- (if cperl-xemacs-p
+ (if (featurep 'xemacs)
(defmacro cperl-etags-goto-tag-location (elt)
;;(progn
;; (switch-to-buffer (get-file-buffer (elt ,elt 0)))
(defmacro cperl-etags-goto-tag-location (elt)
`(etags-goto-tag-location ,elt))))
-(defconst cperl-xemacs-p (string-match "XEmacs\\|Lucid" emacs-version))
-
(defvar cperl-can-font-lock
- (or cperl-xemacs-p
+ (or (featurep 'xemacs)
(and (boundp 'emacs-major-version)
(or window-system
(> emacs-major-version 20)))))
:type 'integer
:group 'cperl-indentation-details)
-;; Is is not unusual to put both perl-indent-level and
+;; Is is not unusual to put both things like perl-indent-level and
;; cperl-indent-level in the local variable section of a file. If only
;; one of perl-mode and cperl-mode is in use, a warning will be issued
-;; about the variable. Autoload this here, so that no warning is
+;; about the variable. Autoload these here, so that no warning is
;; issued when using either perl-mode or cperl-mode.
;;;###autoload(put 'cperl-indent-level 'safe-local-variable 'integerp)
+;;;###autoload(put 'cperl-brace-offset 'safe-local-variable 'integerp)
+;;;###autoload(put 'cperl-continued-brace-offset 'safe-local-variable 'integerp)
+;;;###autoload(put 'cperl-label-offset 'safe-local-variable 'integerp)
+;;;###autoload(put 'cperl-continued-statement-offset 'safe-local-variable 'integerp)
+;;;###autoload(put 'cperl-extra-newline-before-brace 'safe-local-variable 'booleanp)
+;;;###autoload(put 'cperl-merge-trailing-else 'safe-local-variable 'booleanp)
(defcustom cperl-lineup-step nil
"*`cperl-lineup' will always lineup at multiple of this number.
(defvar cperl-vc-header-alist nil)
(make-obsolete-variable
'cperl-vc-header-alist
- "use cperl-vc-rcs-header or cperl-vc-sccs-header instead.")
+ "use cperl-vc-rcs-header or cperl-vc-sccs-header instead."
+ "22.1")
(defcustom cperl-clobber-mode-lists
(not
:group 'cperl-faces)
;;; Some double-evaluation happened with font-locks... Needed with 21.2...
-(defvar cperl-singly-quote-face cperl-xemacs-p)
+(defvar cperl-singly-quote-face (featurep 'xemacs))
(defcustom cperl-invalid-face 'underline
"*Face for highlighting trailing whitespace."
(font-lock-function-name-face nil nil bold italic box)
(font-lock-constant-face nil "LightGray" bold)
(cperl-array-face nil "LightGray" bold underline)
- (cperl-hash-face nil "LightGray" bold italic underline)
+ (cperl-hash-face nil "LightGray" bold italic underline)
(font-lock-comment-face nil "LightGray" italic)
(font-lock-string-face nil nil italic underline)
(cperl-nonoverridable-face nil nil italic underline)
3) Everything is customizable, one-by-one or in a big sweep;
-4) It has many easily-accessable \"tools\":
+4) It has many easily-accessible \"tools\":
a) Can run program, check syntax, start debugger;
b) Can lineup vertically \"middles\" of rows, like `=' in
a = b;
`font-lock-type-face' Overridable keywords
`font-lock-variable-name-face' Variable declarations, indirect array and
hash names, POD headers/item names
- `cperl-invalid' Trailing whitespace
+ `cperl-invalid-face' Trailing whitespace
Note that in several situations the highlighting tries to inform about
possible confusion, such as different colors for function names in
Help with best setup of these faces for printout requested (for each of
the faces: please specify bold, italic, underline, shadow and box.)
-In regular expressions (except character classes):
+In regular expressions (including character classes):
`font-lock-string-face' \"Normal\" stuff and non-0-length constructs
`font-lock-constant-face': Delimiters
`font-lock-warning-face' Special-cased m// and s//foo/,
we couldn't match, misplaced quantifiers,
unrecognized escape sequences
`cperl-nonoverridable-face' Modifiers, as gism in m/REx/gism
- `font-lock-type-face' POSIX classes inside charclasses,
- escape sequences with arguments (\x \23 \p \N)
+ `font-lock-type-face' escape sequences with arguments (\\x \\23 \\p \\N)
and others match-a-char escape sequences
`font-lock-keyword-face' Capturing parens, and |
`font-lock-function-name-face' Special symbols: $ ^ . [ ] [^ ] (?{ }) (??{ })
- `font-lock-builtin-face' \"Remaining\" 0-length constructs, executable
- parts of a REx, not-capturing parens
- `font-lock-variable-name-face' Interpolated constructs, embedded code
+ \"Range -\" in character classes
+ `font-lock-builtin-face' \"Remaining\" 0-length constructs, multipliers
+ ?+*{}, not-capturing parens, leading
+ backslashes of escape sequences
+ `font-lock-variable-name-face' Interpolated constructs, embedded code,
+ POSIX classes (inside charclasses)
`font-lock-comment-face' Embedded comments
")
(defmacro cperl-define-key (emacs-key definition &optional xemacs-key)
`(define-key cperl-mode-map
,(if xemacs-key
- `(if cperl-xemacs-p ,xemacs-key ,emacs-key)
+ `(if (featurep 'xemacs) ,xemacs-key ,emacs-key)
emacs-key)
,definition))
(setq cperl-del-back-ch (aref cperl-del-back-ch 0)))
(defun cperl-mark-active () (mark)) ; Avoid undefined warning
-(if cperl-xemacs-p
+(if (featurep 'xemacs)
(progn
;; "Active regions" are on: use region only if active
;; "Active regions" are off: use region unconditionally
(defun cperl-putback-char (c) ; Emacs 19
(set 'unread-command-events (list c))) ; Avoid undefined warning
-(if cperl-xemacs-p
+(if (featurep 'xemacs)
(defun cperl-putback-char (c) ; XEmacs >= 19.12
(setq unread-command-events (list (eval '(character-to-event c))))))
;; If POST, do not do it with postponed fontification
(if (and post cperl-syntaxify-by-font-lock)
nil
- (put-text-property (max (point-min) (1- from))
+ (put-text-property (max (point-min) (1- from))
to cperl-do-not-fontify t)))
(defcustom cperl-mode-hook nil
;;; (setq interpreter-mode-alist (append interpreter-mode-alist
;;; '(("miniperl" . perl-mode))))))
(eval-when-compile
- (mapcar (lambda (p)
- (condition-case nil
- (require p)
- (error nil)))
- '(imenu easymenu etags timer man info))
+ (mapc (lambda (p)
+ (condition-case nil
+ (require p)
+ (error nil)))
+ '(imenu easymenu etags timer man info))
(if (fboundp 'ps-extend-face-list)
(defmacro cperl-ps-extend-face-list (arg)
`(ps-extend-face-list ,arg))
;;(concat (char-to-string help-char) "v") ; does not work
'cperl-get-help
[(control c) (control h) v]))
- (if (and cperl-xemacs-p
+ (if (and (featurep 'xemacs)
(<= emacs-minor-version 11) (<= emacs-major-version 19))
(progn
;; substitute-key-definition is usefulness-deenhanced...
["Contract groups" cperl-contract-levels
cperl-use-syntax-table-text-property]
"----"
- ["Find next interpolated" cperl-next-interpolated-REx
+ ["Find next interpolated" cperl-next-interpolated-REx
(next-single-property-change (point-min) 'REx-interpolated)]
["Find next interpolated (no //o)"
cperl-next-interpolated-REx-0
(modify-syntax-entry ?$ "." cperl-string-syntax-table)
(modify-syntax-entry ?\{ "." cperl-string-syntax-table)
(modify-syntax-entry ?\} "." cperl-string-syntax-table)
+ (modify-syntax-entry ?\" "." cperl-string-syntax-table)
+ (modify-syntax-entry ?' "." cperl-string-syntax-table)
+ (modify-syntax-entry ?` "." cperl-string-syntax-table)
(modify-syntax-entry ?# "." cperl-string-syntax-table)) ; (?# comment )
2 3))
"Alist that specifies how to match errors in perl output.")
+(defvar compilation-error-regexp-alist)
+
;;;###autoload
(defun cperl-mode ()
"Major mode for editing Perl code.
Part of the indentation style is how different parts of if/elsif/else
statements are broken into lines; in CPerl, this is reflected on how
templates for these constructs are created (controlled by
-`cperl-extra-newline-before-brace'), and how reflow-logic should treat \"continuation\" blocks of else/elsif/continue, controlled by the same variable,
-and by `cperl-extra-newline-before-brace-multiline',
+`cperl-extra-newline-before-brace'), and how reflow-logic should treat
+\"continuation\" blocks of else/elsif/continue, controlled by the same
+variable, and by `cperl-extra-newline-before-brace-multiline',
`cperl-merge-trailing-else', `cperl-indent-region-fix-constructs'.
If `cperl-indent-level' is 0, the statement after opening brace in
(setq paragraph-separate paragraph-start)
(make-local-variable 'paragraph-ignore-fill-prefix)
(setq paragraph-ignore-fill-prefix t)
- (if cperl-xemacs-p
+ (if (featurep 'xemacs)
(progn
(make-local-variable 'paren-backwards-message)
(set 'paren-backwards-message t)))
(set 'vc-sccs-header cperl-vc-sccs-header)
;; This one is obsolete...
(make-local-variable 'vc-header-alist)
- (set 'vc-header-alist (or cperl-vc-header-alist ; Avoid warning
- `((SCCS ,(car cperl-vc-sccs-header))
- (RCS ,(car cperl-vc-rcs-header)))))
+ (with-no-warnings
+ (set 'vc-header-alist (or cperl-vc-header-alist ; Avoid warning
+ `((SCCS ,(car cperl-vc-sccs-header))
+ (RCS ,(car cperl-vc-rcs-header)))))
+ )
(cond ((boundp 'compilation-error-regexp-alist-alist);; xemacs 20.x
(make-local-variable 'compilation-error-regexp-alist-alist)
(set 'compilation-error-regexp-alist-alist
(cons (cons 'cperl (car cperl-compilation-error-regexp-alist))
(symbol-value 'compilation-error-regexp-alist-alist)))
- (if (fboundp 'compilation-build-compilation-error-regexp-alist)
- (let ((f 'compilation-build-compilation-error-regexp-alist))
- (funcall f))
- (make-local-variable 'compilation-error-regexp-alist)
- (push 'cperl compilation-error-regexp-alist)))
+ (if (fboundp 'compilation-build-compilation-error-regexp-alist)
+ (let ((f 'compilation-build-compilation-error-regexp-alist))
+ (funcall f))
+ (make-local-variable 'compilation-error-regexp-alist)
+ (push 'cperl compilation-error-regexp-alist)))
((boundp 'compilation-error-regexp-alist);; xmeacs 19.x
(make-local-variable 'compilation-error-regexp-alist)
(set 'compilation-error-regexp-alist
(or (boundp 'font-lock-unfontify-region-function)
(set 'font-lock-unfontify-region-function
'font-lock-default-unfontify-region))
- (unless cperl-xemacs-p ; Our: just a plug for wrong font-lock
+ (unless (featurep 'xemacs) ; Our: just a plug for wrong font-lock
(make-local-variable 'font-lock-unfontify-region-function)
(set 'font-lock-unfontify-region-function ; not present with old Emacs
'cperl-font-lock-unfontify-region-function))
(save-excursion
(setq insertpos (point-marker))
(goto-char other-end)
- (setq last-command-char ?\{)
+ (setq last-command-event ?\{)
(cperl-electric-lbrace arg insertpos))
(forward-char 1))
;; Check whether we close something "usual" with `}'
- (if (and (eq last-command-char ?\})
+ (if (and (eq last-command-event ?\})
(not
(condition-case nil
(save-excursion
(save-excursion
(skip-chars-backward " \t")
(bolp)))
- (and (eq last-command-char ?\{) ; Do not insert newline
+ (and (eq last-command-event ?\{) ; Do not insert newline
;; if after ")" and `cperl-extra-newline-before-brace'
;; is nil, do not insert extra newline.
(not cperl-extra-newline-before-brace)
(save-excursion
(if insertpos (progn (goto-char insertpos)
(search-forward (make-string
- 1 last-command-char))
+ 1 last-command-event))
(setq insertpos (1- (point)))))
(delete-char -1))))
(if insertpos
(setq cperl-auto-newline nil))
(cperl-electric-brace arg)
(and (cperl-val 'cperl-electric-parens)
- (eq last-command-char ?{)
- (memq last-command-char
+ (eq last-command-event ?{)
+ (memq last-command-event
(append cperl-electric-parens-string nil))
(or (if other-end (goto-char (marker-position other-end)))
t)
- (setq last-command-char ?} pos (point))
+ (setq last-command-event ?} pos (point))
(progn (cperl-electric-brace arg t)
(goto-char pos)))))
(point-marker))
nil)))
(if (and (cperl-val 'cperl-electric-parens)
- (memq last-command-char
+ (memq last-command-event
(append cperl-electric-parens-string nil))
(>= (save-excursion (cperl-to-comment-or-eol) (point)) (point))
;;(not (save-excursion (search-backward "#" beg t)))
- (if (eq last-command-char ?<)
+ (if (eq last-command-event ?<)
(progn
- (and abbrev-mode ; later it is too late, may be after `for'
- (expand-abbrev))
+ ;; This code is too electric, see Bug#3943.
+ ;; (and abbrev-mode ; later it is too late, may be after `for'
+ ;; (expand-abbrev))
(cperl-after-expr-p nil "{;(,:="))
1))
(progn
(if other-end (goto-char (marker-position other-end)))
(insert (make-string
(prefix-numeric-value arg)
- (cdr (assoc last-command-char '((?{ .?})
+ (cdr (assoc last-command-event '((?{ .?})
(?[ . ?])
(?( . ?))
(?< . ?>))))))
(let ((beg (save-excursion (beginning-of-line) (point)))
(other-end (if (and cperl-electric-parens-mark
(cperl-val 'cperl-electric-parens)
- (memq last-command-char
+ (memq last-command-event
(append cperl-electric-parens-string nil))
(cperl-mark-active)
(< (mark) (point)))
p)
(if (and other-end
(cperl-val 'cperl-electric-parens)
- (memq last-command-char '( ?\) ?\] ?\} ?\> ))
+ (memq last-command-event '( ?\) ?\] ?\} ?\> ))
(>= (save-excursion (cperl-to-comment-or-eol) (point)) (point))
;;(not (save-excursion (search-backward "#" beg t)))
)
(if other-end (goto-char other-end))
(insert (make-string
(prefix-numeric-value arg)
- (cdr (assoc last-command-char '((?\} . ?\{)
+ (cdr (assoc last-command-event '((?\} . ?\{)
(?\] . ?\[)
(?\) . ?\()
(?\> . ?\<))))))
Help message may be switched off by setting `cperl-message-electric-keyword'
to nil."
(let ((beg (save-excursion (beginning-of-line) (point)))
- (dollar (and (eq last-command-char ?$)
+ (dollar (and (eq last-command-event ?$)
(eq this-command 'self-insert-command)))
- (delete (and (memq last-command-char '(?\s ?\n ?\t ?\f))
+ (delete (and (memq last-command-event '(?\s ?\n ?\t ?\f))
(memq this-command '(self-insert-command newline))))
my do)
(and (save-excursion
(forward-char 1)
(delete-char 1)))
(search-backward ")")
- (if (eq last-command-char ?\()
+ (if (eq last-command-event ?\()
(progn ; Avoid "if (())"
(delete-backward-char 1)
(delete-backward-char -1))))
(defun cperl-electric-pod ()
"Insert a POD chunk appropriate after a =POD directive."
- (let ((delete (and (memq last-command-char '(?\s ?\n ?\t ?\f))
+ (let ((delete (and (memq last-command-event '(?\s ?\n ?\t ?\f))
(memq this-command '(self-insert-command newline))))
head1 notlast name p really-delete over)
(and (save-excursion
(interactive "P")
(let ((end (point))
(auto (and cperl-auto-newline
- (or (not (eq last-command-char ?:))
+ (or (not (eq last-command-event ?:))
cperl-auto-newline-after-colon)))
insertpos)
(if (and ;;(not arg)
;; Colon is special only after a label
;; So quickly rule out most other uses of colon
;; and do no indentation for them.
- (and (eq last-command-char ?:)
+ (and (eq last-command-event ?:)
(save-excursion
(forward-word 1)
(skip-chars-forward " \t")
(self-insert-command (prefix-numeric-value arg)))))
(defun cperl-electric-backspace (arg)
- "Backspace, or remove the whitespace around the point inserted by an electric
-key. Will untabify if `cperl-electric-backspace-untabify' is non-nil."
+ "Backspace, or remove whitespace around the point inserted by an electric key.
+Will untabify if `cperl-electric-backspace-untabify' is non-nil."
(interactive "p")
(if (and cperl-auto-newline
(memq last-command '(cperl-electric-semi
(t
(skip-chars-forward " \t")
(if (listp indent) (setq indent (car indent)))
- (cond ((looking-at "[A-Za-z_][A-Za-z_0-9]*:[^:]")
+ (cond ((and (looking-at "[A-Za-z_][A-Za-z_0-9]*:[^:]")
+ (not (looking-at "[smy]:\\|tr:")))
(and (> indent 0)
(setq indent (max cperl-min-label-indent
(+ indent cperl-label-offset)))))
)
(defun cperl-sniff-for-indent (&optional parse-data) ; was parse-start
- ;; Old workhorse for calculation of indentation; the major problem
- ;; is that it mixes the sniffer logic to understand what the current line
- ;; MEANS with the logic to actually calculate where to indent it.
- ;; The latter part should be eventually moved to `cperl-calculate-indent';
- ;; actually, this is mostly done now...
+ ;; the sniffer logic to understand what the current line MEANS.
(cperl-update-syntaxification (point) (point))
(let ((res (get-text-property (point) 'syntax-type)))
(save-excursion
(vector 'indentable 'first-line p))))
((get-text-property char-after-pos 'REx-part2)
(vector 'REx-part2 (point)))
- ((nth 3 state)
- [comment])
((nth 4 state)
+ [comment])
+ ((nth 3 state)
[string])
;; XXXX Do we need to special-case this?
((null containing-sexp)
(skip-chars-backward " \t")
(looking-at "[ \t]*[a-zA-Z_][a-zA-Z_0-9]*[ \t]*:")))
(get-text-property (point) 'first-format-line)))
-
+
;; Look at previous line that's at column 0
;; to determine whether we are in top-level decls
;; or function's arg decls. Set basic-indent accordingly.
(let ((colon-line-end 0))
(while
(progn (skip-chars-forward " \t\n")
- (looking-at "#\\|[a-zA-Z0-9_$]*:[^:]\\|=[a-zA-Z]"))
+ ;; s: foo : bar :x is NOT label
+ (and (looking-at "#\\|\\([a-zA-Z0-9_$]+\\):[^:]\\|=[a-zA-Z]")
+ (not (looking-at "[sym]:\\|tr:"))))
;; Skip over comments and labels following openbrace.
(cond ((= (following-char) ?\#)
(forward-line 1))
(vector 'code-start-in-block containing-sexp char-after
(and delim (not is-block)) ; is a HASH
old-indent ; brace first thing on a line
- nil (point) ; nothing interesting before
- ))))))))))))))
+ nil (point))))))))))))))) ; nothing interesting before
(defvar cperl-indent-rules-alist
'((pod nil) ; via `syntax-type' property
"Alist of indentation rules for CPerl mode.
The values mean:
nil: do not indent;
- number: add this amount of indentation.
-
-Not finished.")
+ number: add this amount of indentation.")
(defun cperl-calculate-indent (&optional parse-data) ; was parse-start
"Return appropriate indentation for current line as Perl code.
((eq 'toplevel (elt i 0)) ;; [toplevel start char-after state immed-after-block]
(+ (save-excursion ; To beg-of-defun, or end of last sexp
(goto-char (elt i 1)) ; start = Good place to start parsing
- (- (current-indentation) ;
+ (- (current-indentation) ;
(if (elt i 4) cperl-indent-level 0))) ; immed-after-block
(if (eq (elt i 2) ?{) cperl-continued-brace-offset 0) ; char-after
;; Look at previous line that's at column 0
;;
((eq 'have-prev-sibling (elt i 0))
;; [have-prev-sibling sibling-beg colon-line-end block-start]
- (goto-char (elt i 1))
- (if (> (elt i 2) (point)) ; colon-line-end; After-label, same line
+ (goto-char (elt i 1)) ; sibling-beg
+ (if (> (elt i 2) (point)) ; colon-line-end; have label before point
(if (> (current-indentation)
cperl-min-label-indent)
(- (current-indentation) cperl-label-offset)
(t
(error "Got strange value of indent: %s" i))))))
-(defvar cperl-indent-alist
- '((string nil)
- (comment nil)
- (toplevel 0)
- (toplevel-after-parenth 2)
- (toplevel-continued 2)
- (expression 1))
- "Alist of indentation rules for CPerl mode.
-The values mean:
- nil: do not indent;
- number: add this amount of indentation.
-
-Not finished, not used.")
-
-(defun cperl-where-am-i (&optional parse-start start-state)
- ;; Unfinished
- "Return a list of lists ((TYPE POS)...) of good points before the point.
-POS may be nil if it is hard to find, say, when TYPE is `string' or `comment'.
-
-Not finished, not used."
- (save-excursion
- (let* ((start-point (point)) unused
- (s-s (cperl-get-state))
- (start (nth 0 s-s))
- (state (nth 1 s-s))
- (prestart (nth 3 s-s))
- (containing-sexp (car (cdr state)))
- (case-fold-search nil)
- (res (list (list 'parse-start start) (list 'parse-prestart prestart))))
- (cond ((nth 3 state) ; In string
- (setq res (cons (list 'string nil (nth 3 state)) res))) ; What started string
- ((nth 4 state) ; In comment
- (setq res (cons '(comment) res)))
- ((null containing-sexp)
- ;; Line is at top level.
- ;; Indent like the previous top level line
- ;; unless that ends in a closeparen without semicolon,
- ;; in which case this line is the first argument decl.
- (cperl-backward-to-noncomment (or parse-start (point-min)))
- ;;(skip-chars-backward " \t\f\n")
- (cond
- ((or (bobp)
- (memq (preceding-char) (append ";}" nil)))
- (setq res (cons (list 'toplevel start) res)))
- ((eq (preceding-char) ?\) )
- (setq res (cons (list 'toplevel-after-parenth start) res)))
- (t
- (setq res (cons (list 'toplevel-continued start) res)))))
- ((/= (char-after containing-sexp) ?{)
- ;; line is expression, not statement:
- ;; indent to just after the surrounding open.
- ;; skip blanks if we do not close the expression.
- (setq res (cons (list 'expression-blanks
- (progn
- (goto-char (1+ containing-sexp))
- (or (looking-at "[ \t]*\\(#\\|$\\)")
- (skip-chars-forward " \t"))
- (point)))
- (cons (list 'expression containing-sexp) res))))
- ((progn
- ;; Containing-expr starts with \{. Check whether it is a hash.
- (goto-char containing-sexp)
- (not (cperl-block-p)))
- (setq res (cons (list 'expression-blanks
- (progn
- (goto-char (1+ containing-sexp))
- (or (looking-at "[ \t]*\\(#\\|$\\)")
- (skip-chars-forward " \t"))
- (point)))
- (cons (list 'expression containing-sexp) res))))
- (t
- ;; Statement level.
- (setq res (cons (list 'in-block containing-sexp) res))
- ;; Is it a continuation or a new statement?
- ;; Find previous non-comment character.
- (cperl-backward-to-noncomment containing-sexp)
- ;; Back up over label lines, since they don't
- ;; affect whether our line is a continuation.
- ;; Back up comma-delimited lines too ?????
- (while (or (eq (preceding-char) ?\,)
- (save-excursion (cperl-after-label)))
- (if (eq (preceding-char) ?\,)
- ;; Will go to beginning of line, essentially
- ;; Will ignore embedded sexpr XXXX.
- (cperl-backward-to-start-of-continued-exp containing-sexp))
- (beginning-of-line)
- (cperl-backward-to-noncomment containing-sexp))
- ;; Now we get the answer.
- (if (not (memq (preceding-char) (append ";}{" '(nil)))) ; Was ?\,
- ;; This line is continuation of preceding line's statement.
- (list (list 'statement-continued containing-sexp))
- ;; This line starts a new statement.
- ;; Position following last unclosed open.
- (goto-char containing-sexp)
- ;; Is line first statement after an open-brace?
- (or
- ;; If no, find that first statement and indent like
- ;; it. If the first statement begins with label, do
- ;; not believe when the indentation of the label is too
- ;; small.
- (save-excursion
- (forward-char 1)
- (let ((colon-line-end 0))
- (while (progn (skip-chars-forward " \t\n" start-point)
- (and (< (point) start-point)
- (looking-at
- "#\\|[a-zA-Z_][a-zA-Z0-9_]*:[^:]")))
- ;; Skip over comments and labels following openbrace.
- (cond ((= (following-char) ?\#)
- ;;(forward-line 1)
- (end-of-line))
- ;; label:
- (t
- (save-excursion (end-of-line)
- (setq colon-line-end (point)))
- (search-forward ":"))))
- ;; Now at the point, after label, or at start
- ;; of first statement in the block.
- (and (< (point) start-point)
- (if (> colon-line-end (point))
- ;; Before statement after label
- (if (> (current-indentation)
- cperl-min-label-indent)
- (list (list 'label-in-block (point)))
- ;; Do not believe: `max' is involved
- (list
- (list 'label-in-block-min-indent (point))))
- ;; Before statement
- (list 'statement-in-block (point))))))
- ;; If no previous statement,
- ;; indent it relative to line brace is on.
- ;; For open brace in column zero, don't let statement
- ;; start there too. If cperl-indent-level is zero,
- ;; use cperl-brace-offset + cperl-continued-statement-offset instead.
- ;; For open-braces not the first thing in a line,
- ;; add in cperl-brace-imaginary-offset.
-
- ;; If first thing on a line: ?????
- (setq unused ; This is not finished...
- (+ (if (and (bolp) (zerop cperl-indent-level))
- (+ cperl-brace-offset cperl-continued-statement-offset)
- cperl-indent-level)
- ;; Move back over whitespace before the openbrace.
- ;; If openbrace is not first nonwhite thing on the line,
- ;; add the cperl-brace-imaginary-offset.
- (progn (skip-chars-backward " \t")
- (if (bolp) 0 cperl-brace-imaginary-offset))
- ;; If the openbrace is preceded by a parenthesized exp,
- ;; move to the beginning of that;
- ;; possibly a different line
- (progn
- (if (eq (preceding-char) ?\))
- (forward-sexp -1))
- ;; Get initial indentation of the line we are on.
- ;; If line starts with label, calculate label indentation
- (if (save-excursion
- (beginning-of-line)
- (looking-at "[ \t]*[a-zA-Z_][a-zA-Z_0-9]*:[^:]"))
- (if (> (current-indentation) cperl-min-label-indent)
- (- (current-indentation) cperl-label-offset)
- (cperl-calculate-indent))
- (current-indentation)))))))))
- res)))
-
(defun cperl-calculate-indent-within-comment ()
"Return the indentation amount for line, assuming that
the current line is to be regarded as part of a block comment."
(setq set-st nil)
(setq ender (cperl-forward-re lim end nil st-l err-l
argument starter ender)
- ender (nth 2 ender)))))
+ ender (nth 2 ender)))))
(error (goto-char lim)
(setq set-st nil)
(if reset-st
(set-syntax-table reset-st))
(or end
+ (and cperl-brace-recursing
+ (or (eq ostart ?\{)
+ (eq starter ?\{)))
(message
"End of `%s%s%c ... %c' string/RE not found: %s"
argument
(set-syntax-table reset-st))))
(defsubst cperl-look-at-leading-count (is-x-REx e)
- (if (and (> (point) e)
- ;; return nil on failure, no moving
- (re-search-forward (concat "\\="
- (if is-x-REx "[ \t\n]*" "")
- "[{?+*]")
- (1- e) t))
+ (if (and
+ (< (point) e)
+ (re-search-forward (concat "\\=" (if is-x-REx "[ \t\n]*" "") "[{?+*]")
+ (1- e) t)) ; return nil on failure, no moving
(if (eq ?\{ (preceding-char)) nil
(cperl-postpone-fontification
(1- (point)) (point)
'face font-lock-warning-face))))
+;; Do some smarter-highlighting
+;; XXXX Currently ignores alphanum/dash delims,
+(defsubst cperl-highlight-charclass (endbracket dashface bsface onec-space)
+ (let ((l '(1 5 7)) ll lle lll
+ ;; 2 groups, the first takes the whole match (include \[trnfabe])
+ (singleChar (concat "\\(" "[^\\\\]" "\\|" "\\\\[^cdg-mo-qsu-zA-Z0-9_]" "\\|" "\\\\c." "\\|" "\\\\x" "\\([0-9a-fA-F][0-9a-fA-F]?\\|\\={[0-9a-fA-F]+}\\)" "\\|" "\\\\0?[0-7][0-7]?[0-7]?" "\\|" "\\\\N{[^{}]*}" "\\)")))
+ (while ; look for unescaped - between non-classes
+ (re-search-forward
+ ;; On 19.33, certain simplifications lead
+ ;; to bugs (as in [^a-z] \\| [trnfabe] )
+ (concat ; 1: SingleChar (include \[trnfabe])
+ singleChar
+ ;;"\\(" "[^\\\\]" "\\|" "\\\\[^cdg-mo-qsu-zA-Z0-9_]" "\\|" "\\\\c." "\\|" "\\\\x" "\\([0-9a-fA-F][0-9a-fA-F]?\\|\\={[0-9a-fA-F]+}\\)" "\\|" "\\\\0?[0-7][0-7]?[0-7]?" "\\|" "\\\\N{[^{}]*}" "\\)"
+ "\\(" ; 3: DASH SingleChar (match optionally)
+ "\\(-\\)" ; 4: DASH
+ singleChar ; 5: SingleChar
+ ;;"\\(" "[^\\\\]" "\\|" "\\\\[^cdg-mo-qsu-zA-Z0-9_]" "\\|" "\\\\c." "\\|" "\\\\x" "\\([0-9a-fA-F][0-9a-fA-F]?\\|\\={[0-9a-fA-F]+}\\)" "\\|" "\\\\0?[0-7][0-7]?[0-7]?" "\\|" "\\\\N{[^{}]*}" "\\)"
+ "\\)?"
+ "\\|"
+ "\\(" ; 7: other escapes
+ "\\\\[pP]" "\\([^{]\\|{[^{}]*}\\)"
+ "\\|" "\\\\[^pP]" "\\)"
+ )
+ endbracket 'toend)
+ (if (match-beginning 4)
+ (cperl-postpone-fontification
+ (match-beginning 4) (match-end 4)
+ 'face dashface))
+ ;; save match data (for looking-at)
+ (setq lll (mapcar (function (lambda (elt) (cons (match-beginning elt)
+ (match-end elt)))) l))
+ (while lll
+ (setq ll (car lll))
+ (setq lle (cdr ll)
+ ll (car ll))
+ ;; (message "Got %s of %s" ll l)
+ (if (and ll (eq (char-after ll) ?\\ ))
+ (save-excursion
+ (goto-char ll)
+ (cperl-postpone-fontification ll (1+ ll)
+ 'face bsface)
+ (if (looking-at "\\\\[a-zA-Z0-9]")
+ (cperl-postpone-fontification (1+ ll) lle
+ 'face onec-space))))
+ (setq lll (cdr lll))))
+ (goto-char endbracket) ; just in case something misbehaves???
+ t))
+
;;; Debugging this may require (setq max-specpdl-size 2000)...
(defun cperl-find-pods-heres (&optional min max non-inter end ignore-max end-of-here-doc)
"Scans the buffer for hard-to-parse Perl constructions.
face head-face here-face b e bb tag qtag b1 e1 argument i c tail tb
is-REx is-x-REx REx-subgr-start REx-subgr-end was-subgr i2 hairy-RE
(case-fold-search nil) (inhibit-read-only t) (buffer-undo-list t)
- (modified (buffer-modified-p)) overshoot is-o-REx
+ (modified (buffer-modified-p)) overshoot is-o-REx name
(after-change-functions nil)
(cperl-font-locking t)
(use-syntax-state (and cperl-syntax-state
;;; XXX What to do: foo <<bar ???
;;; XXX Need to support print {a} <<B ???
(forward-sexp -1)
- (save-match-data
+ (save-match-data
; $foo << b; $f .= <<B;
; ($f+1) << b; a($f) . <<B;
; foo 1, <<B; $x{a} <<b;
qtag (regexp-quote tag))
(cond (cperl-pod-here-fontify
;; Highlight the starting delimiter
- (cperl-postpone-fontification
+ (cperl-postpone-fontification
b1 e1 'face my-cperl-delimiters-face)
(cperl-put-do-not-fontify b1 e1 t)))
(forward-line)
;;;m^a[\^b]c^ + m.a[^b]\.c.;
(save-excursion
(goto-char (1+ b))
- ;; First
+ ;; First
(cperl-look-at-leading-count is-x-REx e)
(setq hairy-RE
(concat
;; This is not pretty: the 5.8.7 logic:
;; \0numx -> octal (up to total 3 dig)
;; \DIGIT -> backref unless \0
- ;; \DIGITs -> backref if legal
+ ;; \DIGITs -> backref if valid
;; otherwise up to 3 -> octal
;; Do not try to distinguish, we guess
((or (and (memq qtag (append "01234567" nil))
"\\=[01234567]?[01234567]?"
(1- e) 'to-end))
(and (memq qtag (append "89" nil))
- (re-search-forward
+ (re-search-forward
"\\=[0123456789]*" (1- e) 'to-end))
(and (eq qtag ?x)
(re-search-forward
'face my-cperl-REx-length1-face))))
(setq was-subgr nil)) ; We do stuff here
((match-beginning 3) ; [charclass]
+ ;; Highlight leader, trailer, POSIX classes
(forward-char 1)
(if (eq (char-after b) ?^ )
(and (eq (following-char) ?\\ )
(forward-char 2))
(and (eq (following-char) ?^ )
(forward-char 1)))
- (setq argument b ; continue?
+ (setq argument b ; continue? & end of last POSIX
tag nil ; list of POSIX classes
- qtag (point))
+ qtag (point)) ; after leading ^ if present
(if (eq (char-after b) ?\] )
(and (eq (following-char) ?\\ )
(eq (char-after (cperl-1+ (point)))
(forward-char 2))
(and (eq (following-char) ?\] )
(forward-char 1)))
+ (setq REx-subgr-end qtag) ;EndOf smart-highlighed
;; Apparently, I can't put \] into a charclass
;; in m]]: m][\\\]\]] produces [\\]]
;;; POSIX? [:word:] [:^word:] only inside []
-;;; "\\=\\(\\\\.\\|[^][\\\\]\\|\\[:\\^?\sw+:]\\|\\[[^:]\\)*]")
- (while
+;;; "\\=\\(\\\\.\\|[^][\\\\]\\|\\[:\\^?\sw+:]\\|\\[[^:]\\)*]")
+ (while ; look for unescaped ]
(and argument
(re-search-forward
(if (eq (char-after b) ?\] )
(and
(search-backward "[" argument t)
(< REx-subgr-start (point))
- (not
- (and ; Should work with delim = \
- (eq (preceding-char) ?\\ )
- (= (% (skip-chars-backward
- "\\\\") 2) 0)))
+ (setq argument (point)) ; POSIX-start
+ (or ; Should work with delim = \
+ (not (eq (preceding-char) ?\\ ))
+ ;; XXXX Double \\ is needed with 19.33
+ (= (% (skip-chars-backward "\\\\") 2) 0))
(looking-at
(cond
((eq (char-after b) ?\] )
(char-to-string (char-after b))
"\\|\\sw\\)+:\]"))
(t "\\\\*\\[:\\^?\\sw*:]")))
- (setq argument (point))))
+ (goto-char REx-subgr-end)
+ (cperl-highlight-charclass
+ argument my-cperl-REx-spec-char-face
+ my-cperl-REx-0length-face my-cperl-REx-length1-face)))
(setq tag (cons (cons argument (point))
tag)
- argument (point)) ; continue
+ argument (point)
+ REx-subgr-end argument) ; continue
(setq argument nil)))
(and argument
(message "Couldn't find end of charclass in a REx, pos=%s"
REx-subgr-start))
+ (setq argument (1- (point)))
+ (goto-char REx-subgr-end)
+ (cperl-highlight-charclass
+ argument my-cperl-REx-spec-char-face
+ my-cperl-REx-0length-face my-cperl-REx-length1-face)
+ (forward-char 1)
+ ;; Highlight starter, trailer, POSIX
(if (and cperl-use-syntax-table-text-property
(> (- (point) 2) REx-subgr-start))
(put-text-property
(while tag
(cperl-postpone-fontification
(car (car tag)) (cdr (car tag))
- 'face my-cperl-REx-length1-face)
+ 'face font-lock-variable-name-face) ;my-cperl-REx-length1-face
(setq tag (cdr tag)))
(setq was-subgr nil)) ; did facing already
;; Now rare stuff:
(setq qtag "Can't find })")))
(progn
(goto-char (1- e))
- (message qtag))
+ (message "%s" qtag))
(cperl-postpone-fontification
(1- tag) (1- (point))
'face font-lock-variable-name-face)
(if (and is-REx is-x-REx)
(put-text-property (1+ b) (1- e)
'syntax-subtype 'x-REx)))
- (if i2
- (progn
+ (if (and i2 e1 (or (not b1) (> e1 b1)))
+ (progn ; No errors finding the second part...
(cperl-postpone-fontification
(1- e1) e1 'face my-cperl-delimiters-face)
(if (and (not (eobp))
(beginning-of-line)
(if (memq (setq pr (get-text-property (point) 'syntax-type))
'(pod here-doc here-doc-delim))
- (cperl-unwind-to-safe nil)
- (or (and (looking-at "^[ \t]*\\(#\\|$\\)")
- (not (memq pr '(string prestring))))
- (progn (cperl-to-comment-or-eol) (bolp))
- (progn
- (skip-chars-backward " \t")
- (if (< p (point)) (goto-char p))
- (setq stop t)))))))
+ (progn
+ (cperl-unwind-to-safe nil)
+ (setq pr (get-text-property (point) 'syntax-type))))
+ (or (and (looking-at "^[ \t]*\\(#\\|$\\)")
+ (not (memq pr '(string prestring))))
+ (progn (cperl-to-comment-or-eol) (bolp))
+ (progn
+ (skip-chars-backward " \t")
+ (if (< p (point)) (goto-char p))
+ (setq stop t))))))
;; Used only in `cperl-calculate-indent'...
(defun cperl-block-p () ; Do not C-M-q ! One string contains ";" !
(or (eq (current-indentation) (or old-comm-indent
comment-column))
(setq old-comm-indent nil))))
- (if (and old-comm-indent
+ (if (and old-comm-indent
(not empty)
- (= (current-indentation) old-comm-indent)
+ (= (current-indentation) old-comm-indent)
(not (eq (get-text-property (point) 'syntax-type) 'pod))
(not (eq (get-text-property (point) 'syntax-table)
cperl-st-cfence)))
(indent-for-comment)))
(progn
(setq i (cperl-indent-line indent-info))
- (or comm
- (not i)
- (progn
- (if cperl-indent-region-fix-constructs
+ (or comm
+ (not i)
+ (progn
+ (if cperl-indent-region-fix-constructs
(goto-char (cperl-fix-line-spacing end indent-info)))
(if (setq old-comm-indent
(and (cperl-to-comment-or-eol)
(not (eq (get-text-property (point)
'syntax-table)
cperl-st-cfence))
- (current-column)))
- (progn (indent-for-comment)
- (skip-chars-backward " \t")
- (skip-chars-backward "#")
- (setq new-comm-indent (current-column))))))))
- (beginning-of-line 2)))
+ (current-column)))
+ (progn (indent-for-comment)
+ (skip-chars-backward " \t")
+ (skip-chars-backward "#")
+ (setq new-comm-indent (current-column))))))))
+ (beginning-of-line 2)))
;; Now run the update hooks
(and after-change-functions
cperl-update-end
(looking-at "^[ \t]*#+[ \t]*[^ \t\n#]")))
(point)))
;; Remove existing hashes
- (save-excursion
(goto-char (point-min))
- (while (progn (forward-line 1) (< (point) (point-max)))
- (skip-chars-forward " \t")
- (if (looking-at "#+")
- (progn
- (if (and (eq (point) (match-beginning 0))
- (not (eq (point) (match-end 0)))) nil
+ (save-excursion
+ (while (progn (forward-line 1) (< (point) (point-max)))
+ (skip-chars-forward " \t")
+ (if (looking-at "#+")
+ (progn
+ (if (and (eq (point) (match-beginning 0))
+ (not (eq (point) (match-end 0)))) nil
(error
"Bug in Emacs: `looking-at' in `narrow-to-region': match-data is garbage"))
(delete-char (- (match-end 0) (match-beginning 0)))))))
(t
(or name
(setq name "+++BACK+++"))
- (mapcar (lambda (elt)
- (if (and (listp elt) (listp (cdr elt)))
- (progn
- ;; In the other order it goes up
- ;; one level only ;-(
- (setcdr elt (cons (cons name lst)
- (cdr elt)))
- (cperl-imenu-addback (cdr elt) t name))))
- (if isback (cdr lst) lst))
+ (mapc (lambda (elt)
+ (if (and (listp elt) (listp (cdr elt)))
+ (progn
+ ;; In the other order it goes up
+ ;; one level only ;-(
+ (setcdr elt (cons (cons name lst)
+ (cdr elt)))
+ (cperl-imenu-addback (cdr elt) t name))))
+ (if isback (cdr lst) lst))
lst)))
(defun cperl-imenu--create-perl-index (&optional regexp)
(defun cperl-windowed-init ()
"Initialization under windowed version."
(cond ((featurep 'ps-print)
- (unless cperl-faces-init
- (if (boundp 'font-lock-multiline)
- (setq cperl-font-lock-multiline t))
- (cperl-init-faces)))
+ (or cperl-faces-init
+ (progn
+ (and (boundp 'font-lock-multiline)
+ (setq cperl-font-lock-multiline t))
+ (cperl-init-faces))))
((not cperl-faces-init)
(add-hook 'font-lock-mode-hook
(function
","
cperl-maybe-white-and-comment-rex
"\\([$@%*]\\([a-zA-Z0-9_:]+\\|[^a-zA-Z0-9_]\\)\\)")
- ;; Bug in font-lock: limit is used not only to limit
+ ;; Bug in font-lock: limit is used not only to limit
;; searches, but to set the "extend window for
;; facification" property. Thus we need to minimize.
,(if cperl-font-lock-multiline
(and (fboundp 'turn-on-font-lock) ; Check for newer font-lock
;; not yet as of XEmacs 19.12, works with 21.1.11
(or
- (not cperl-xemacs-p)
+ (not (featurep 'xemacs))
(string< "21.1.9" emacs-version)
(and (string< "21.1.10" emacs-version)
(string< emacs-version "21.1.2")))
;; (defconst cperl-nonoverridable-face
;; 'cperl-nonoverridable-face
;; "Face to use for data types from another group."))
- ;;(if (not cperl-xemacs-p) nil
+ ;;(if (not (featurep 'xemacs)) nil
;; (or (boundp 'font-lock-comment-face)
;; (defconst font-lock-comment-face
;; 'font-lock-comment-face
;; Non-functioning under OS/2:
(if (eq char-height 1) (setq char-height 18))
;; Title, menubar, + 2 for slack
- (- (/ (x-display-pixel-height) char-height) 4)))
+ (- (/ (display-pixel-height) char-height) 4)))
(if (> height max-height) (setq height max-height))
;;(message "was %s doing %s" iniheight height)
(if not-loner
by CPerl."
(interactive "P")
(or arg
- (setq arg (if (eq cperl-syntaxify-by-font-lock
+ (setq arg (if (eq cperl-syntaxify-by-font-lock
(if backtrace 'backtrace 'message)) 0 1)))
(setq arg (if (> arg 0) (if backtrace 'backtrace 'message) t))
(setq cperl-syntaxify-by-font-lock arg)
;; Do not introduce variable if not needed, we check it!
(set 'parse-sexp-lookup-properties t))))
+;; Copied from imenu-example--name-and-position.
+(defvar imenu-use-markers)
+
+(defun cperl-imenu-name-and-position ()
+ "Return the current/previous sexp and its (beginning) location.
+Does not move point."
+ (save-excursion
+ (forward-sexp -1)
+ (let ((beg (if imenu-use-markers (point-marker) (point)))
+ (end (progn (forward-sexp) (point))))
+ (cons (buffer-substring beg end)
+ beg))))
+
(defun cperl-xsub-scan ()
(require 'imenu)
(let ((index-alist '())
((not package) nil) ; C language section
((match-beginning 3) ; XSUB
(goto-char (1+ (match-beginning 3)))
- (setq index (imenu-example--name-and-position))
+ (setq index (cperl-imenu-name-and-position))
(setq name (buffer-substring (match-beginning 3) (match-end 3)))
(if (and prefix (string-match (concat "^" prefix) name))
(setq name (substring name (length prefix))))
(push index index-alist))
(t ; BOOT: section
;; (beginning-of-line)
- (setq index (imenu-example--name-and-position))
+ (setq index (cperl-imenu-name-and-position))
(setcar index (concat package "::BOOT:"))
(push index index-alist)))))
index-alist))
(save-excursion
(cond (inbuffer nil) ; Already there
((file-exists-p tags-file-name)
- (if cperl-xemacs-p
+ (if (featurep 'xemacs)
(visit-tags-table-buffer)
(visit-tags-table-buffer tags-file-name)))
(t (set-buffer (find-file-noselect tags-file-name))))
(setq cperl-unreadable-ok t
tm nil) ; Return empty list
(error "Aborting: unreadable directory %s" file)))))))
- (mapcar (function
- (lambda (file)
- (cond
- ((string-match cperl-noscan-files-regexp file)
- nil)
- ((not (file-directory-p file))
- (if (string-match cperl-scan-files-regexp file)
- (cperl-write-tags file erase recurse nil t noxs topdir)))
- ((not recurse) nil)
- (t (cperl-write-tags file erase recurse t t noxs topdir)))))
- files)))
+ (mapc (function
+ (lambda (file)
+ (cond
+ ((string-match cperl-noscan-files-regexp file)
+ nil)
+ ((not (file-directory-p file))
+ (if (string-match cperl-scan-files-regexp file)
+ (cperl-write-tags file erase recurse nil t noxs topdir)))
+ ((not recurse) nil)
+ (t (cperl-write-tags file erase recurse t t noxs topdir)))))
+ files)))
(t
(setq xs (string-match "\\.xs$" file))
(if (not (and xs noxs))
(cons cons1 (car cperl-hierarchy)))))))
(end-of-line))))
+(declare-function x-popup-menu "menu.c" (position menu))
+
(defun cperl-tags-hier-init (&optional update)
"Show hierarchical menu of classes and methods.
Finds info about classes by a scan of loaded TAGS files.
pack name cons1 to l1 l2 l3 l4 b)
;; (setq cperl-hierarchy '(() () ())) ; Would write into '() later!
(setq cperl-hierarchy (list l1 l2 l3))
- (if cperl-xemacs-p ; Not checked
+ (if (featurep 'xemacs) ; Not checked
(progn
(or tags-file-name
;; Does this work in XEmacs?
- (call-interactively 'visit-tags-table))
- (message "Updating list of classes...")
+ (call-interactively 'visit-tags-table))
+ (message "Updating list of classes...")
(set-buffer (get-file-buffer tags-file-name))
(cperl-tags-hier-fill))
(or tags-table-list
(call-interactively 'visit-tags-table))
- (mapcar
+ (mapc
(function
(lambda (tagsfile)
(message "Updating list of classes... %s" tagsfile)
- (set-buffer (get-file-buffer tagsfile))
- (cperl-tags-hier-fill)))
- tags-table-list)
+ (set-buffer (get-file-buffer tagsfile))
+ (cperl-tags-hier-fill)))
+ tags-table-list)
(message "Updating list of classes... postprocessing..."))
- (mapcar remover (car cperl-hierarchy))
- (mapcar remover (nth 1 cperl-hierarchy))
+ (mapc remover (car cperl-hierarchy))
+ (mapc remover (nth 1 cperl-hierarchy))
(setq to (list nil (cons "Packages: " (nth 1 cperl-hierarchy))
(cons "Methods: " (car cperl-hierarchy))))
(cperl-tags-treeify to 1)
(setcdr to l1) ; Init to dynamic space
(setq writeto to)
(setq ord 1)
- (mapcar move-deeper packages)
+ (mapc move-deeper packages)
(setq ord 2)
- (mapcar move-deeper methods)
+ (mapc move-deeper methods)
(if recurse
- (mapcar (function (lambda (elt)
+ (mapc (function (lambda (elt)
(cperl-tags-treeify elt (1+ level))))
- (cdr to)))
+ (cdr to)))
;;Now clean up leaders with one child only
- (mapcar (function (lambda (elt)
- (if (not (and (listp (cdr elt))
- (eq (length elt) 2))) nil
- (setcar elt (car (nth 1 elt)))
- (setcdr elt (cdr (nth 1 elt))))))
- (cdr to))
+ (mapc (function (lambda (elt)
+ (if (not (and (listp (cdr elt))
+ (eq (length elt) 2))) nil
+ (setcar elt (car (nth 1 elt)))
+ (setcdr elt (cdr (nth 1 elt))))))
+ (cdr to))
;; Sort the roots of subtrees
(if (default-value 'imenu-sort-function)
(setcdr to
(sort (cdr to) (default-value 'imenu-sort-function))))
;; Now add back functions removed from display
- (mapcar (function (lambda (elt)
- (setcdr to (cons elt (cdr to)))))
- (if (default-value 'imenu-sort-function)
- (nreverse
- (sort root-functions (default-value 'imenu-sort-function)))
- root-functions))
+ (mapc (function (lambda (elt)
+ (setcdr to (cons elt (cdr to)))))
+ (if (default-value 'imenu-sort-function)
+ (nreverse
+ (sort root-functions (default-value 'imenu-sort-function)))
+ root-functions))
;; Now add back packages removed from display
- (mapcar (function (lambda (elt)
- (setcdr to (cons (cons (concat "package " (car elt))
- (cdr elt))
- (cdr to)))))
- (if (default-value 'imenu-sort-function)
- (nreverse
- (sort root-packages (default-value 'imenu-sort-function)))
- root-packages))))
+ (mapc (function (lambda (elt)
+ (setcdr to (cons (cons (concat "package " (car elt))
+ (cdr elt))
+ (cdr to)))))
+ (if (default-value 'imenu-sort-function)
+ (nreverse
+ (sort root-packages (default-value 'imenu-sort-function)))
+ root-packages))))
;;;(x-popup-menu t
;;; '(keymap "Name1"
;; LEVEL shows how many levels deep to go
;; position at enter and at leave is not defined
(let (s c tmp (m (make-marker)) (m1 (make-marker)) c1 spaces inline code pos)
- (if (not embed)
- (goto-char (1+ b))
- (goto-char b)
- (cond ((looking-at "(\\?\\\\#") ; (?#) wrongly commented when //x-ing
- (forward-char 2)
- (delete-char 1)
- (forward-char 1))
- ((looking-at "(\\?[^a-zA-Z]")
- (forward-char 3))
- ((looking-at "(\\?") ; (?i)
- (forward-char 2))
- (t
- (forward-char 1))))
- (setq c (if embed (current-indentation) (1- (current-column)))
- c1 (+ c (or cperl-regexp-indent-step cperl-indent-level)))
+ (if embed
+ (progn
+ (goto-char b)
+ (setq c (if (eq embed t) (current-indentation) (current-column)))
+ (cond ((looking-at "(\\?\\\\#") ; (?#) wrongly commented when //x-ing
+ (forward-char 2)
+ (delete-char 1)
+ (forward-char 1))
+ ((looking-at "(\\?[^a-zA-Z]")
+ (forward-char 3))
+ ((looking-at "(\\?") ; (?i)
+ (forward-char 2))
+ (t
+ (forward-char 1))))
+ (goto-char (1+ b))
+ (setq c (1- (current-column))))
+ (setq c1 (+ c (or cperl-regexp-indent-step cperl-indent-level)))
(or (looking-at "[ \t]*[\n#]")
(progn
(insert "\n")))
;; Find the start
(if (looking-at "\\s|")
nil ; good already
- (if (looking-at "\\([smy]\\|qr\\)\\s|")
- (forward-char 1)
+ (if (or (looking-at "\\([smy]\\|qr\\)\\s|")
+ (and (eq (preceding-char) ?q)
+ (looking-at "\\(r\\)\\s|")))
+ (goto-char (match-end 1))
(re-search-backward "\\s|"))) ; Assume it is scanned already.
;;(forward-char 1)
(let ((b (point)) (e (make-marker)) have-x delim (c (current-column))
(let ((b (point)) (e (make-marker)))
(forward-sexp 1)
(set-marker e (1- (point)))
- (cperl-beautify-regexp-piece b e nil deep))))
+ (cperl-beautify-regexp-piece b e 'level deep))))
(defun cperl-invert-if-unless-modifiers ()
"Change `B if A;' into `if (A) {B}' etc if possible.
\(Unfinished.)"
- (interactive) ;
+ (interactive)
(let (A B pre-B post-B pre-if post-if pre-A post-A if-string
(w-rex "\\<\\(if\\|unless\\|while\\|until\\|for\\|foreach\\)\\>"))
(and (= (char-syntax (preceding-char)) ?w)
(documentation-property
'cperl-short-docs
'variable-documentation))))
+ (Man-switches "")
(manual-program (if is-func "perldoc -f" "perldoc")))
(cond
- (cperl-xemacs-p
+ ((featurep 'xemacs)
(let ((Manual-program "perldoc")
(Manual-switches (if is-func (list "-f"))))
(manual-entry word)))
(let* ((pod2man-args (concat buffer-file-name " | nroff -man "))
(bufname (concat "Man " buffer-file-name))
(buffer (generate-new-buffer bufname)))
- (save-excursion
- (set-buffer buffer)
+ (with-current-buffer buffer
(let ((process-environment (copy-sequence process-environment)))
;; Prevent any attempt to use display terminal fanciness.
(setenv "TERM" "dumb")
(interactive)
(require 'man)
(cond
- (cperl-xemacs-p
+ ((featurep 'xemacs)
(let ((Manual-program "perldoc"))
(manual-entry buffer-file-name)))
(t
- (let* ((manual-program "perldoc"))
+ (let* ((manual-program "perldoc")
+ (Man-switches ""))
(Man-getpage-in-background buffer-file-name)))))
(defun cperl-pod2man-build-command ()
(let ((tt (current-time)))
(+ (* 1000 (nth 1 tt)) (/ (nth 2 tt) 1000))))))
(tt (funcall timems)) (c 0) delta tot)
- (goto-line l)
+ (goto-char (point-min))
+ (forward-line (1- l))
(cperl-mode)
(setq tot (- (- tt (setq tt (funcall timems)))))
(message "cperl-mode at %s: %s" l tot)
(message "to %s:%6s,%7s" l delta tot))
tot))
+(defvar font-lock-cache-position)
+
(defun cperl-emulate-lazy-lock (&optional window-size)
"Emulate `lazy-lock' without `condition-case', so `debug-on-error' works.
Start fontifying the buffer from the start (or end) using the given
(cperl-fontify-syntaxically to)))))
(defvar cperl-version
- (let ((v "Revision: 5.22"))
+ (let ((v "Revision: 6.2"))
(string-match ":\\s *\\([0-9.]+\\)" v)
(substring v (match-beginning 1) (match-end 1)))
"Version of IZ-supported CPerl package this file is based on.")
+(defun cperl-mode-unload-function ()
+ "Unload the Cperl mode library."
+ (let ((new-mode (if (eq (symbol-function 'perl-mode) 'cperl-mode)
+ 'fundamental-mode
+ 'perl-mode)))
+ (dolist (buf (buffer-list))
+ (with-current-buffer buf
+ (when (eq major-mode 'cperl-mode)
+ (funcall new-mode)))))
+ ;; continue standard unloading
+ nil)
+
(provide 'cperl-mode)
-;;; arch-tag: 42e5b19b-e187-4537-929f-1a7408980ce6
+;; arch-tag: 42e5b19b-e187-4537-929f-1a7408980ce6
;;; cperl-mode.el ends here