;;; 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
: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
(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
")
;; 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
["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
(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
(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)))))))
","
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
;; 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))
(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.
(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
(function
(lambda (tagsfile)
(message "Updating list of classes... %s" tagsfile)
- (set-buffer (get-file-buffer tagsfile))
- (cperl-tags-hier-fill)))
+ (set-buffer (get-file-buffer tagsfile))
+ (cperl-tags-hier-fill)))
tags-table-list)
(message "Updating list of classes... postprocessing..."))
(mapc remover (car cperl-hierarchy))
;; 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
((featurep 'xemacs)
(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")
(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)
(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.")
(provide 'cperl-mode)
-;;; arch-tag: 42e5b19b-e187-4537-929f-1a7408980ce6
+;; arch-tag: 42e5b19b-e187-4537-929f-1a7408980ce6
;;; cperl-mode.el ends here
HCoop / bpt / emacs.git / blobdiff