;;; 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, 2008
+;; 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)))))
(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
)
(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
(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.
((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
(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
(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 (and i2 e1 b1 (> e1 b1))
+ (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)
(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)
","
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.23"))
+ (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