;;; Commentary:
-;; $Id: cperl-mode.el,v 5.16 2006/02/21 11:18:21 vera Exp vera $
+;; $Id: cperl-mode.el,v 5.19 2006/06/01 11:11:57 vera Exp vera $
;;; If your Emacs does not default to `cperl-mode' on Perl files:
;;; To use this mode put the following into
;;; Highlight many others 0-length builtins
;;; `cperl-praise': Mention indenting and highlight in RExen.
+;;; After 5.15:
+;;; `cperl-find-pods-heres': Highlight capturing parens in REx
+
+;;; After 5.16:
+;;; `cperl-find-pods-heres': Highlight '|' for alternation
+;;; Initialize `font-lock-warning-face' if not present
+;;; `cperl-find-pods-heres': Use `font-lock-warning-face' instead of
+;;; `font-lock-function-name-face'
+;;; `cperl-look-at-leading-count': Likewise
+;;; `cperl-find-pods-heres': localize `font-lock-variable-name-face'
+;;; `font-lock-keyword-face' (needed for
+;;; batch processing) etc
+;;; Use `font-lock-builtin-face' for builtin in REx
+;;; Now `font-lock-variable-name-face'
+;;; is used for interpolated variables.
+;;; Use "talking aliases" for faces inside REx
+;;; Highlight parts of REx (except in charclasses)
+;;; according to the syntax and/or semantic
+;;; Syntax-mark a {}-part of (?{}) as "comment"
+;;; (it was the ()-part)
+;;; Better logic to distinguish what is what in REx
+;;; `cperl-tips-faces': Document REx highlighting
+;;; `cperl-praise': Mention REx syntax highlight etc.
+
+;;; After 5.17:
+;;; `cperl-find-sub-attrs': Would not always manage to print error message
+;;; `cperl-find-pods-heres': localize `font-lock-constant-face'
+
+;;; After 5.18:
+;;; `cperl-find-pods-heres': Misprint in REx for parsing REx
+;;; Very minor optimization
+;;; `my-cperl-REx-modifiers-face' got quoted
+;;; Recognize "print $foo <<END" as HERE-doc.
+;;; Put `REx-interpolated' text attribute if needed
+;;; `cperl-invert-if-unless-modifiers': New function.
+;;; `cperl-backward-to-start-of-expr': Likewise
+;;; `cperl-forward-to-end-of-expr': Likewise
+;;; `cperl-invert-if-unless': Works in "the opposite way" too.
+;;; Cursor position on return is on the switch-word
+;;; Indents comments better
+;;; `REx-interpolated': New text attribute
+;;; `cperl-next-interpolated-REx': New function.
+;;; `cperl-next-interpolated-REx-0': Likewise.
+;;; `cperl-next-interpolated-REx-1': Likewise.
+;;; "\C-c\C-x", "\C-c\C-y", "\C-c\C-v": New keybinding for these functions
+;;; Perl/Regexp menu: 3 new entries for `cperl-next-interpolated-REx'
+;;; `cperl-praise': Mention finded interpolated RExen.
+
;;; Code:
\f
(if (fboundp 'eval-when-compile)
(font-lock-string-face nil nil italic underline)
(cperl-nonoverridable-face nil nil italic underline)
(font-lock-type-face nil nil underline)
+ (font-lock-warning-face nil "LightGray" bold italic box)
(underline nil "LightGray" strikeout))
"List given as an argument to `ps-extend-face-list' in `cperl-ps-print'."
:type '(repeat (cons symbol
expressions; can find matching () and [] in a regular expression.
s) Allows indentation of //x-style regular expressions;
t) Highlights different symbols in regular expressions according
- to their function; much less problems with backslashitis.
+ to their function; much less problems with backslashitis;
+ u) Allows to find regular expressions which contain interpolated parts.
5) The indentation engine was very smart, but most of tricks may be
not needed anymore with the support for `syntax-table' property. Has
line-breaks/spacing between elements of the construct.
10) Uses a linear-time algorith for indentation of regions (on Emaxen with
-capable syntax engines).")
+capable syntax engines).
+
+11) Syntax-highlight, indentation, sexp-recognition inside regular expressions.
+")
(defvar cperl-speed 'please-ignore-this-line
"This is an incomplete compendium of what is available in other parts
syntaxically to be not code
`font-lock-constant-face' HERE-doc delimiters, labels, delimiters of
2-arg operators s/y/tr/ or of RExen,
- `font-lock-function-name-face' Special-cased m// and s//foo/, _ as
- a target of a file tests, file tests,
+ `font-lock-warning-face' Special-cased m// and s//foo/,
+ `font-lock-function-name-face' _ as a target of a file tests, file tests,
subroutine names at the moment of definition
(except those conflicting with Perl operators),
package names (when recognized), format names
Help with best setup of these faces for printout requested (for each of
the faces: please specify bold, italic, underline, shadow and box.)
-\(Not finished.)")
+In regular expressions (except 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/,
+ Mismatched closing delimiters, parens
+ 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)
+ 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
+ `font-lock-comment-face' Embedded comments
+
+")
\f
(cperl-define-key "\C-c\C-p" 'cperl-pod-spell)
(cperl-define-key "\C-c\C-d" 'cperl-here-doc-spell)
(cperl-define-key "\C-c\C-n" 'cperl-narrow-to-here-doc)
+ (cperl-define-key "\C-c\C-v" 'cperl-next-interpolated-REx)
+ (cperl-define-key "\C-c\C-x" 'cperl-next-interpolated-REx-0)
+ (cperl-define-key "\C-c\C-y" 'cperl-next-interpolated-REx-1)
(cperl-define-key "\C-c\C-ha" 'cperl-toggle-autohelp)
(cperl-define-key "\C-c\C-hp" 'cperl-perldoc)
(cperl-define-key "\C-c\C-hP" 'cperl-perldoc-at-point)
["Contract a group" cperl-contract-level
cperl-use-syntax-table-text-property]
["Contract groups" cperl-contract-levels
- cperl-use-syntax-table-text-property])
+ cperl-use-syntax-table-text-property]
+ "----"
+ ["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
+ (or (text-property-any (point-min) (point-max) 'REx-interpolated t)
+ (text-property-any (point-min) (point-max) 'REx-interpolated 1))]
+ ["Find next interpolated (neither //o nor whole-REx)"
+ cperl-next-interpolated-REx-1
+ (text-property-any (point-min) (point-max) 'REx-interpolated t)])
["Insert spaces if needed to fix style" cperl-find-bad-style t]
["Refresh \"hard\" constructions" cperl-find-pods-heres t]
"----"
(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 cperl-compilation-error-regexp-alist)
+ (symbol-value 'compilation-error-regexp-alist-alist)))
+ (let ((f 'compilation-build-compilation-error-regexp-alist))
+ (funcall f)))
+ ((boundp 'compilation-error-regexp-alist);; xmeacs 19.x
+ (make-local-variable 'compilation-error-regexp-alist)
+ (set 'compilation-error-regexp-alist
+ (cons cperl-compilation-error-regexp-alist
+ (symbol-value 'compilation-error-regexp-alist)))))
(make-local-variable 'font-lock-defaults)
(setq font-lock-defaults
(cond
;; (or 0 if declaration); up to `{' or ';': `syntax-type' => `sub-decl'.
;; f) Multiline my/our declaration lists etc: `syntax-type' => `multiline'
+;;; In addition, some parts of RExes may be marked as `REx-interpolated'
+;;; (value: 0 in //o, 1 if "interpolated variable" is whole-REx, t otherwise).
+
(defun cperl-unwind-to-safe (before &optional end)
;; if BEFORE, go to the previous start-of-line on each step of unwinding
(let ((pos (point)) opos)
(setq end (point)))))
(or end pos)))))
+;;; These are needed for byte-compile (at least with v19)
(defvar cperl-nonoverridable-face)
+(defvar font-lock-variable-name-face)
(defvar font-lock-function-name-face)
+(defvar font-lock-keyword-face)
+(defvar font-lock-builtin-face)
+(defvar font-lock-type-face)
(defvar font-lock-comment-face)
+(defvar font-lock-warning-face)
(defun cperl-find-sub-attrs (&optional st-l b-fname e-fname pos)
"Syntaxically mark (and fontify) attributes of a subroutine.
(setq after-first t))
(error (message
"L%d: attribute `%s': %s"
- (count-lines (point-min) (point)) (buffer-substring start1 end1) b)
+ (count-lines (point-min) (point))
+ (and start1 end1 (buffer-substring start1 end1)) b)
(setq start nil)))
(and start
(progn
(if (eq ?\{ (preceding-char)) nil
(cperl-postpone-fontification
(1- (point)) (point)
- 'face font-lock-function-name-face))))
+ 'face font-lock-warning-face))))
;;; 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)
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
+ (modified (buffer-modified-p)) overshoot is-o-REx
(after-change-functions nil)
(cperl-font-locking t)
(use-syntax-state (and cperl-syntax-state
;; (st-l '(nil)) (err-l '(nil)) ; Would overwrite - propagates from a function call to a function call!
(st-l (list nil)) (err-l (list nil))
;; Somehow font-lock may be not loaded yet...
+ ;; (e.g., when building TAGS via command-line call)
(font-lock-string-face (if (boundp 'font-lock-string-face)
font-lock-string-face
'font-lock-string-face))
- (font-lock-constant-face (if (boundp 'font-lock-constant-face)
+ (my-cperl-delimiters-face (if (boundp 'font-lock-constant-face)
font-lock-constant-face
'font-lock-constant-face))
- (font-lock-function-name-face
+ (my-cperl-REx-spec-char-face ; [] ^.$ and wrapper-of ({})
+ (if (boundp 'font-lock-function-name-face)
+ font-lock-function-name-face
+ 'font-lock-function-name-face))
+ (font-lock-variable-name-face ; interpolated vars and ({})-code
+ (if (boundp 'font-lock-variable-name-face)
+ font-lock-variable-name-face
+ 'font-lock-variable-name-face))
+ (font-lock-function-name-face ; used in `cperl-find-sub-attrs'
(if (boundp 'font-lock-function-name-face)
font-lock-function-name-face
'font-lock-function-name-face))
+ (font-lock-constant-face ; used in `cperl-find-sub-attrs'
+ (if (boundp 'font-lock-constant-face)
+ font-lock-constant-face
+ 'font-lock-constant-face))
+ (my-cperl-REx-0length-face ; 0-length, (?:)etc, non-literal \
+ (if (boundp 'font-lock-builtin-face)
+ font-lock-builtin-face
+ 'font-lock-builtin-face))
(font-lock-comment-face
(if (boundp 'font-lock-comment-face)
font-lock-comment-face
'font-lock-comment-face))
- (cperl-nonoverridable-face
+ (font-lock-warning-face
+ (if (boundp 'font-lock-warning-face)
+ font-lock-warning-face
+ 'font-lock-warning-face))
+ (my-cperl-REx-ctl-face ; (|)
+ (if (boundp 'font-lock-keyword-face)
+ font-lock-keyword-face
+ 'font-lock-keyword-face))
+ (my-cperl-REx-modifiers-face ; //gims
(if (boundp 'cperl-nonoverridable-face)
cperl-nonoverridable-face
'cperl-nonoverridable-face))
+ (my-cperl-REx-length1-face ; length=1 escaped chars, POSIX classes
+ (if (boundp 'font-lock-type-face)
+ font-lock-type-face
+ 'font-lock-type-face))
(stop-point (if ignore-max
(point-max)
max))
(remove-text-properties min max
'(syntax-type t in-pod t syntax-table t
attrib-group t
+ REx-interpolated t
cperl-postpone t
syntax-subtype t
rear-nonsticky t
(remove-text-properties
max e '(syntax-type t in-pod t syntax-table t
attrib-group t
+ REx-interpolated t
cperl-postpone t
syntax-subtype t
here-doc-group t
(cond
((looking-at "[0-9$({]")
(forward-sexp 1)
- (looking-at "[ \t]*<<")))))
+ (and
+ (looking-at "[ \t]*<<")
+ (condition-case nil
+ ;; print $foo <<EOF
+ (progn
+ (forward-sexp -2)
+ (not
+ (looking-at "print\\>")))
+ (error t)))))))
(error nil))) ; func(<<EOF)
(and (not (match-beginning 6)) ; Empty
(looking-at
qtag (regexp-quote tag))
(cond (cperl-pod-here-fontify
;; Highlight the starting delimiter
- (cperl-postpone-fontification b1 e1 'face font-lock-constant-face)
+ (cperl-postpone-fontification
+ b1 e1 'face my-cperl-delimiters-face)
(cperl-put-do-not-fontify b1 e1 t)))
(forward-line)
(setq i (point))
(if cperl-pod-here-fontify
(progn
;; Highlight the ending delimiter
- (cperl-postpone-fontification (match-beginning 0) (match-end 0)
- 'face font-lock-constant-face)
+ (cperl-postpone-fontification
+ (match-beginning 0) (match-end 0)
+ 'face my-cperl-delimiters-face)
(cperl-put-do-not-fontify b (match-end 0) t)
;; Highlight the HERE-DOC
(cperl-postpone-fontification b (match-beginning 0)
(1- e1))
e (if i i e1) ; end of the first part
qtag nil ; need to preserve backslashitis
- is-x-REx nil) ; REx has //x modifier
+ is-x-REx nil is-o-REx nil); REx has //x //o modifiers
;; If s{} (), then b/b1 are at "{", "(", e1/i after ")", "}"
;; Commenting \\ is dangerous, what about ( ?
(and i tail
(and (if go (looking-at ".\\sw*x")
(looking-at "\\sw*x")) ; qr//x
(setq is-x-REx t))
+ (and (if go (looking-at ".\\sw*o")
+ (looking-at "\\sw*o")) ; //o
+ (setq is-o-REx t))
(if (null i)
;; Considered as 1arg form
(progn
(forward-word 1) ; skip modifiers s///s
(if tail (cperl-commentify tail (point) t))
(cperl-postpone-fontification
- e1 (point) 'face 'cperl-nonoverridable-face)))
+ e1 (point) 'face my-cperl-REx-modifiers-face)))
;; Check whether it is m// which means "previous match"
;; and highlight differently
(setq is-REx
(not (looking-at "split\\>")))
(error t))))
(cperl-postpone-fontification
- b e 'face font-lock-function-name-face)
+ b e 'face font-lock-warning-face)
(if (or i2 ; Has 2 args
(and cperl-fontify-m-as-s
(or
(not (eq ?\< (char-after b)))))))
(progn
(cperl-postpone-fontification
- b (cperl-1+ b) 'face font-lock-constant-face)
+ b (cperl-1+ b) 'face my-cperl-delimiters-face)
(cperl-postpone-fontification
- (1- e) e 'face font-lock-constant-face)))
+ (1- e) e 'face my-cperl-delimiters-face)))
(if (and is-REx cperl-regexp-scan)
;; Process RExen: embedded comments, charclasses and ]
+;;;/\3333\xFg\x{FFF}a\ppp\PPP\qqq\C\99f(?{ foo })(??{ foo })/;
+;;;/a\.b[^a[:ff:]b]x$ab->$[|$,$ab->[cd]->[ef]|$ab[xy].|^${a,b}{c,d}/;
+;;;/(?<=foo)(?<!bar)(x)(?:$ab|\$\/)$|\\\b\x888\776\[\:$/xxx;
+;;;m?(\?\?{b,a})? + m/(??{aa})(?(?=xx)aa|bb)(?#aac)/;
+;;;m$(^ab[c]\$)$ + m+(^ab[c]\$\+)+ + m](^ab[c\]$|.+)] + m)(^ab[c]$|.+\));
+;;;m^a[\^b]c^ + m.a[^b]\.c.;
(save-excursion
(goto-char (1+ b))
;; First
"\\(\\[\\)" ; 3=[
"\\|"
"\\(]\\)" ; 4=]
- "\\|" ; 5=builtin 0-length, 6
+ "\\|"
+ ;; XXXX Will not be able to use it in s)))
+ (if (eq (char-after b) ?\) )
+ "\\())))\\)" ; Will never match
+ (if (eq (char-after b) ?? )
+ ;;"\\((\\\\\\?\\(\\\\\\?\\)?{\\)"
+ "\\((\\\\\\?\\\\\\?{\\|()\\\\\\?{\\)"
+ "\\((\\?\\??{\\)")) ; 5= (??{ (?{
+ "\\|" ; 6= 0-length, 7: name, 8,9:code, 10:group
+ "\\(" ;; XXXX 1-char variables, exc. |()\s
+ "[$@]"
+ "\\("
+ "[_a-zA-Z:][_a-zA-Z0-9:]*"
+ "\\|"
+ "{[^{}]*}" ; only one-level allowed
+ "\\|"
+ "[^{(|) \t\r\n\f]"
+ "\\)"
+ "\\(" ;;8,9:code part of array/hash elt
+ "\\(" "->" "\\)?"
+ "\\[[^][]*\\]"
+ "\\|"
+ "{[^{}]*}"
+ "\\)*"
;; XXXX: what if u is delim?
- "\\("
- "[)^$|]"
"\\|"
- "[*?+]" ; Do not need \?? !
+ "[)^|$.*?+]"
"\\|"
"{[0-9]+}"
"\\|"
"\\|"
"\\\\[luLUEQbBAzZG]"
"\\|"
- "("
- "\\("
- "\\?[:=!>]"
+ "(" ; Group opener
+ "\\(" ; 10 group opener follower
+ "\\?\\((\\?\\)" ; 11: in (?(?=C)A|B)
+ "\\|"
+ "\\?[:=!>?{]" ; "?" something
"\\|"
"\\?[-imsx]+[:)]" ; (?i) (?-s:.)
"\\|"
"\\?([0-9]+)" ; (?(1)foo|bar)
"\\|"
"\\?<[=!]"
- "\\|"
- "\\?" ; (?(?=foo)bar|baz)
+ ;;;"\\|"
+ ;;; "\\?"
"\\)?"
"\\)"
- ;; XXXX Need {5,6}?
"\\|"
- "\\\\\\(.\\)" ; 7=\SYMBOL
- ;; XXXX Will not be able to use it in s)))
- (if (eq (char-after b) ?\) ) ""
- (concat
- "\\|"
- (if (eq (char-after b) ?? ) ; 8 = (?{
- "\\((\\\\\\?\\(\\\\\\?\\)?{\\)"
- "\\((\\?\\(\\?\\)?{\\)"))))) ; 8 = opt ?
+ "\\\\\\(.\\)" ; 12=\SYMBOL
+ ))
(while
(and (< (point) (1- e))
(re-search-forward hairy-RE (1- e) 'to-end))
(goto-char (match-beginning 0))
(setq REx-subgr-start (point)
- was-subgr t)
- (if (save-excursion
- (and
- nil ; Not needed now, when we skip \SYMBOL
- (/= (1+ b) (point)) ; \ may be delim
- (eq (preceding-char) ?\\)
- (= (% (skip-chars-backward "\\\\") 2)
- (if (and (eq (char-after b) ?\#)
- (eq (following-char) ?\#))
- 0
- -1))))
- ;; Not a subgr, avoid loop:
- (progn (setq was-subgr nil)
- (forward-char 1))
- (cond
- ((match-beginning 5) ; 0-length builtins
- (setq was-subgr nil) ; We do stuff here
- (goto-char (match-end 5))
- (if (>= (point) e)
- (goto-char (1- e)))
+ was-subgr (following-char))
+ (cond
+ ((match-beginning 6) ; 0-length builtins, groups
+ (goto-char (match-end 0))
+ (if (match-beginning 11)
+ (goto-char (match-beginning 11)))
+ (if (>= (point) e)
+ (goto-char (1- e)))
+ (cperl-postpone-fontification
+ (match-beginning 0) (point)
+ 'face
+ (cond
+ ((eq was-subgr ?\) )
+ (condition-case nil
+ (save-excursion
+ (forward-sexp -1)
+ (if (> (point) b)
+ (if (if (eq (char-after b) ?? )
+ (looking-at "(\\\\\\?")
+ (eq (char-after (1+ (point))) ?\?))
+ my-cperl-REx-0length-face
+ my-cperl-REx-ctl-face)
+ font-lock-warning-face))
+ (error font-lock-warning-face)))
+ ((eq was-subgr ?\| )
+ my-cperl-REx-ctl-face)
+ ((eq was-subgr ?\$ )
+ (if (> (point) (1+ REx-subgr-start))
+ (progn
+ (put-text-property
+ (match-beginning 0) (point)
+ 'REx-interpolated
+ (if is-o-REx 0
+ (if (and (eq (match-beginning 0)
+ (1+ b))
+ (eq (point)
+ (1- e))) 1 t)))
+ font-lock-variable-name-face)
+ my-cperl-REx-spec-char-face))
+ ((memq was-subgr (append "^." nil) )
+ my-cperl-REx-spec-char-face)
+ ((eq was-subgr ?\( )
+ (if (not (match-beginning 10))
+ my-cperl-REx-ctl-face
+ my-cperl-REx-0length-face))
+ (t my-cperl-REx-0length-face)))
+ (if (and (memq was-subgr (append "(|" nil))
+ (not (string-match "(\\?[-imsx]+)"
+ (match-string 0))))
+ (cperl-look-at-leading-count is-x-REx e))
+ (setq was-subgr nil)) ; We do stuff here
+ ((match-beginning 12) ; \SYMBOL
+ (forward-char 2)
+ (if (>= (point) e)
+ (goto-char (1- e))
+ ;; How many chars to not highlight:
+ ;; 0-len special-alnums in other branch =>
+ ;; Generic: \non-alnum (1), \alnum (1+face)
+ ;; Is-delim: \non-alnum (1/spec-2) alnum-1 (=what hai)
+ (setq REx-subgr-start (point)
+ qtag (preceding-char))
(cperl-postpone-fontification
- (match-beginning 5) (point)
- 'face font-lock-variable-name-face)
- (if (and (memq (string-to-char (match-string 5))
- (append "(|" nil))
- (not (string-match "(\?[-imsx]+)"
- (match-string 5))))
- (cperl-look-at-leading-count is-x-REx e)))
- ((match-beginning 7) ; \SYMBOL
- (forward-char 2)
- (if (>= (point) e)
- (goto-char (1- e))
- ;; 0-len special-alnums in other branch =>
- ;; Generic: \non-alnum (1), \alnum NO
- ;; Is-delim: \non-alnum (1/spec-2) alnum-1 (=what hai)
- ;; How many chars to not highlight
- (setq was-subgr (if (eq (char-after b)
- (string-to-char
- (match-string 7)))
- (if (string-match
- "[][)^$|*?+]"
- (match-string 7))
- 0
- 1)
- (if (string-match
- "[a-zA-Z0-9]"
- (match-string 7))
- nil
- 1)))
- (if was-subgr
+ (- (point) 2) (- (point) 1) 'face
+ (if (memq qtag
+ (append "ghijkmoqvFHIJKMORTVY" nil))
+ font-lock-warning-face
+ my-cperl-REx-0length-face))
+ (if (and (eq (char-after b) qtag)
+ (memq qtag (append ".])^$|*?+" nil)))
+ (progn
+ (if (and cperl-use-syntax-table-text-property
+ (eq qtag ?\) ))
+ (put-text-property
+ REx-subgr-start (1- (point))
+ 'syntax-table cperl-st-punct))
(cperl-postpone-fontification
- (- (point) 2) (- (point) was-subgr)
- 'face font-lock-variable-name-face)))
- (setq was-subgr nil)) ; We do stuff here
- ((match-beginning 3) ; [charclass]
- ;; Mismatch for /$patterns->[1]/
- (forward-char 1)
- (setq qtag 0) ; leaders
- (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 argument b ; continue?
- tag nil ; list of POSIX classes
- qtag (point))
- (if (eq (char-after b) ?\] )
- (and (eq (following-char) ?\\ )
- (eq (char-after (cperl-1+ (point)))
- ?\] )
- (setq qtag (1+ qtag))
- (forward-char 2))
- (and (eq (following-char) ?\] )
- (forward-char 1)))
- ;; Apparently, I can't put \] into a charclass
- ;; in m]]: m][\\\]\]] produces [\\]]
+ (1- (point)) (point) 'face
+ ; \] can't appear below
+ (if (memq qtag (append ".]^$" nil))
+ 'my-cperl-REx-spec-char-face
+ (if (memq qtag (append "*?+" nil))
+ 'my-cperl-REx-0length-face
+ 'my-cperl-REx-ctl-face))))) ; )|
+ ;; Test for arguments:
+ (cond
+ ;; This is not pretty: the 5.8.7 logic:
+ ;; \0numx -> octal (up to total 3 dig)
+ ;; \DIGIT -> backref unless \0
+ ;; \DIGITs -> backref if legal
+ ;; otherwise up to 3 -> octal
+ ;; Do not try to distinguish, we guess
+ ((or (and (memq qtag (append "01234567" nil))
+ (re-search-forward
+ "\\=[01234567]?[01234567]?"
+ (1- e) 'to-end))
+ (and (memq qtag (append "89" nil))
+ (re-search-forward
+ "\\=[0123456789]*" (1- e) 'to-end))
+ (and (eq qtag ?x)
+ (re-search-forward
+ "\\=[0-9a-fA-F][0-9a-fA-F]?\\|\\={[0-9a-fA-F]+}"
+ (1- e) 'to-end))
+ (and (memq qtag (append "pPN" nil))
+ (re-search-forward "\\={[^{}]+}\\|."
+ (1- e) 'to-end))
+ (eq (char-syntax qtag) ?w))
+ (cperl-postpone-fontification
+ (1- REx-subgr-start) (point)
+ 'face my-cperl-REx-length1-face))))
+ (setq was-subgr nil)) ; We do stuff here
+ ((match-beginning 3) ; [charclass]
+ (forward-char 1)
+ (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 argument b ; continue?
+ tag nil ; list of POSIX classes
+ qtag (point))
+ (if (eq (char-after b) ?\] )
+ (and (eq (following-char) ?\\ )
+ (eq (char-after (cperl-1+ (point)))
+ ?\] )
+ (setq qtag (1+ qtag))
+ (forward-char 2))
+ (and (eq (following-char) ?\] )
+ (forward-char 1)))
+ ;; Apparently, I can't put \] into a charclass
+ ;; in m]]: m][\\\]\]] produces [\\]]
;;; POSIX? [:word:] [:^word:] only inside []
;;; "\\=\\(\\\\.\\|[^][\\\\]\\|\\[:\\^?\sw+:]\\|\\[[^:]\\)*]")
- (while
- (and argument
- (re-search-forward
- (if (eq (char-after b) ?\] )
- "\\=\\(\\\\[^]]\\|[^]\\\\]\\)*\\\\]"
- "\\=\\(\\\\.\\|[^]\\\\]\\)*]")
- (1- e) 'toend))
- ;; Is this ] the end of POSIX class?
- (if (save-excursion
- (and
- (search-backward "[" argument t)
- (< REx-subgr-start (point))
- (not
- (and ; Should work with delim = \
- (eq (preceding-char) ?\\ )
- (= (% (skip-chars-backward
- "\\\\") 2) 0)))
- (looking-at
- (cond
- ((eq (char-after b) ?\] )
- "\\\\*\\[:\\^?\\sw+:\\\\\\]")
- ((eq (char-after b) ?\: )
- "\\\\*\\[\\\\:\\^?\\sw+\\\\:]")
- ((eq (char-after b) ?^ )
- "\\\\*\\[:\\(\\\\\\^\\)?\\sw+:\]")
- ((eq (char-syntax (char-after b))
- ?w)
- (concat
- "\\\\*\\[:\\(\\\\\\^\\)?\\(\\\\"
- (char-to-string (char-after b))
- "\\|\\sw\\)+:\]"))
- (t "\\\\*\\[:\\^?\\sw*:]")))
- (setq argument (point))))
- (setq tag (cons (cons argument (point))
- tag)
- argument (point)) ; continue
- (setq argument nil)))
- (and argument
- (message "Couldn't find end of charclass in a REx, pos=%s"
- REx-subgr-start))
- (if (and cperl-use-syntax-table-text-property
- (> (- (point) 2) REx-subgr-start))
- (put-text-property
- (1+ REx-subgr-start) (1- (point))
- 'syntax-table cperl-st-punct))
+ (while
+ (and argument
+ (re-search-forward
+ (if (eq (char-after b) ?\] )
+ "\\=\\(\\\\[^]]\\|[^]\\\\]\\)*\\\\]"
+ "\\=\\(\\\\.\\|[^]\\\\]\\)*]")
+ (1- e) 'toend))
+ ;; Is this ] an end of POSIX class?
+ (if (save-excursion
+ (and
+ (search-backward "[" argument t)
+ (< REx-subgr-start (point))
+ (not
+ (and ; Should work with delim = \
+ (eq (preceding-char) ?\\ )
+ (= (% (skip-chars-backward
+ "\\\\") 2) 0)))
+ (looking-at
+ (cond
+ ((eq (char-after b) ?\] )
+ "\\\\*\\[:\\^?\\sw+:\\\\\\]")
+ ((eq (char-after b) ?\: )
+ "\\\\*\\[\\\\:\\^?\\sw+\\\\:]")
+ ((eq (char-after b) ?^ )
+ "\\\\*\\[:\\(\\\\\\^\\)?\\sw+:\]")
+ ((eq (char-syntax (char-after b))
+ ?w)
+ (concat
+ "\\\\*\\[:\\(\\\\\\^\\)?\\(\\\\"
+ (char-to-string (char-after b))
+ "\\|\\sw\\)+:\]"))
+ (t "\\\\*\\[:\\^?\\sw*:]")))
+ (setq argument (point))))
+ (setq tag (cons (cons argument (point))
+ tag)
+ argument (point)) ; continue
+ (setq argument nil)))
+ (and argument
+ (message "Couldn't find end of charclass in a REx, pos=%s"
+ REx-subgr-start))
+ (if (and cperl-use-syntax-table-text-property
+ (> (- (point) 2) REx-subgr-start))
+ (put-text-property
+ (1+ REx-subgr-start) (1- (point))
+ 'syntax-table cperl-st-punct))
+ (cperl-postpone-fontification
+ REx-subgr-start qtag
+ 'face my-cperl-REx-spec-char-face)
+ (cperl-postpone-fontification
+ (1- (point)) (point) 'face
+ my-cperl-REx-spec-char-face)
+ (if (eq (char-after b) ?\] )
+ (cperl-postpone-fontification
+ (- (point) 2) (1- (point))
+ 'face my-cperl-REx-0length-face))
+ (while tag
(cperl-postpone-fontification
- REx-subgr-start qtag
+ (car (car tag)) (cdr (car tag))
+ 'face my-cperl-REx-length1-face)
+ (setq tag (cdr tag)))
+ (setq was-subgr nil)) ; did facing already
+ ;; Now rare stuff:
+ ((and (match-beginning 2) ; #-comment
+ (/= (match-beginning 2) (match-end 2)))
+ (beginning-of-line 2)
+ (if (> (point) e)
+ (goto-char (1- e))))
+ ((match-beginning 4) ; character "]"
+ (setq was-subgr nil) ; We do stuff here
+ (goto-char (match-end 0))
+ (if cperl-use-syntax-table-text-property
+ (put-text-property
+ (1- (point)) (point)
+ 'syntax-table cperl-st-punct))
+ (cperl-postpone-fontification
+ (1- (point)) (point)
+ 'face font-lock-warning-face))
+ ((match-beginning 5) ; before (?{}) (??{})
+ (setq tag (match-end 0))
+ (if (or (setq qtag
+ (cperl-forward-group-in-re st-l))
+ (and (>= (point) e)
+ (setq qtag "no matching `)' found"))
+ (and (not (eq (char-after (- (point) 2))
+ ?\} ))
+ (setq qtag "Can't find })")))
+ (progn
+ (goto-char (1- e))
+ (message qtag))
+ (cperl-postpone-fontification
+ (1- tag) (1- (point))
'face font-lock-variable-name-face)
(cperl-postpone-fontification
- (if (eq (char-after b) ?\] )
- (- (point) 2)
- (1- (point)))
- (point) 'face font-lock-variable-name-face)
- (while tag
- (cperl-postpone-fontification
- (car (car tag)) (cdr (car tag))
- 'face font-lock-type-face)
- (setq tag (cdr tag)))
- (setq was-subgr nil)) ; did facing already
- ;; Now rare stuff:
- ((and (match-beginning 2) ; #-comment
- (/= (match-beginning 2) (match-end 2)))
- (beginning-of-line 2)
- (if (> (point) e)
- (goto-char (1- e))))
- ((match-beginning 4) ; character "]"
- (setq was-subgr nil) ; We do stuff here
- (goto-char (match-end 0))
- (if cperl-use-syntax-table-text-property
- (put-text-property
- (1- (point)) (point)
- 'syntax-table cperl-st-punct))
+ REx-subgr-start (1- tag)
+ 'face my-cperl-REx-spec-char-face)
(cperl-postpone-fontification
(1- (point)) (point)
- 'face font-lock-function-name-face))
- ((match-beginning 8) ; (?{})
- (setq was-subgr (point)
- tag (match-end 0))
- (if (or
- (setq qtag
- (cperl-forward-group-in-re st-l))
- (and (>= (point) e)
- (setq qtag "no matching `)' found"))
- (and
- (not (eq (char-after (- (point) 2))
- ?\} ))
- (setq qtag "Can't find })")))
+ 'face my-cperl-REx-spec-char-face)
+ (if cperl-use-syntax-table-text-property
(progn
- (goto-char (1- e))
- (message qtag))
- (cperl-postpone-fontification
- (1- tag) (1- (point))
- 'face font-lock-variable-name-face)
- (if cperl-use-syntax-table-text-property
- (progn
- (put-text-property
- (1- (point)) (point)
- 'syntax-table cperl-st-cfence)
- (put-text-property
- was-subgr (1+ was-subgr)
- 'syntax-table cperl-st-cfence))))
- (setq was-subgr nil))
- (t ; (?#)-comment
- ;; Inside "(" and "\" arn't special in any way
- ;; Works also if the outside delimiters are ().
- (or ;;(if (eq (char-after b) ?\) )
- ;;(re-search-forward
- ;; "[^\\\\]\\(\\\\\\\\\\)*\\\\)"
- ;; (1- e) 'toend)
- (search-forward ")" (1- e) 'toend)
- ;;)
- (message
- "Couldn't find end of (?#...)-comment in a REx, pos=%s"
- REx-subgr-start)))))
+ (put-text-property
+ (- (point) 2) (1- (point))
+ 'syntax-table cperl-st-cfence)
+ (put-text-property
+ (+ REx-subgr-start 2)
+ (+ REx-subgr-start 3)
+ 'syntax-table cperl-st-cfence))))
+ (setq was-subgr nil))
+ (t ; (?#)-comment
+ ;; Inside "(" and "\" arn't special in any way
+ ;; Works also if the outside delimiters are ().
+ (or;;(if (eq (char-after b) ?\) )
+ ;;(re-search-forward
+ ;; "[^\\\\]\\(\\\\\\\\\\)*\\\\)"
+ ;; (1- e) 'toend)
+ (search-forward ")" (1- e) 'toend)
+ ;;)
+ (message
+ "Couldn't find end of (?#...)-comment in a REx, pos=%s"
+ REx-subgr-start))))
(if (>= (point) e)
(goto-char (1- e)))
(cond
- ((eq was-subgr t)
+ (was-subgr
(setq REx-subgr-end (point))
(cperl-commentify
REx-subgr-start REx-subgr-end nil)
(if i2
(progn
(cperl-postpone-fontification
- (1- e1) e1 'face font-lock-constant-face)
+ (1- e1) e1 'face my-cperl-delimiters-face)
(if (assoc (char-after b) cperl-starters)
(progn
(cperl-postpone-fontification
- b1 (1+ b1) 'face font-lock-constant-face)
+ b1 (1+ b1) 'face my-cperl-delimiters-face)
(put-text-property b1 (1+ b1)
'REx-part2 t)))))
(if (> (point) max)
(eq (get-text-property (point) 'syntax-type)
'format)))))))))
+(defun cperl-backward-to-start-of-expr (&optional lim)
+ (condition-case nil
+ (progn
+ (while (and (or (not lim)
+ (> (point) lim))
+ (not (cperl-after-expr-p lim)))
+ (forward-sexp -1)))
+ (error nil)))
+
+(defun cperl-at-end-of-expr (&optional lim)
+ (condition-case nil
+ (save-excursion
+ ;; If nothing interesting after, same as (forward-sexp -1); otherwise
+ ;; fails, or at a start of following sexp:
+ (let ((p (point)))
+ (forward-sexp 1)
+ (forward-sexp -1)
+ (or (< (point) p)
+ (cperl-after-expr-p lim))))
+ (error t)))
+
+(defun cperl-forward-to-end-of-expr (&optional lim)
+ (let ((p (point))))
+ (condition-case nil
+ (progn
+ (while (and (< (point) (or lim (point-max)))
+ (not (cperl-at-end-of-expr)))
+ (forward-sexp 1)))
+ (error nil)))
+
(defun cperl-backward-to-start-of-continued-exp (lim)
(if (memq (preceding-char) (append ")]}\"'`" nil))
(forward-sexp -1))
;; Allow `cperl-find-pods-heres' to run.
(or (boundp 'font-lock-constant-face)
(cperl-force-face font-lock-constant-face
- "Face for constant and label names")
- ;;(setq font-lock-constant-face 'font-lock-constant-face)
- ))
+ "Face for constant and label names"))
+ (or (boundp 'font-lock-warning-face)
+ (cperl-force-face font-lock-warning-face
+ "Face for things which should stand out"))
+ ;;(setq font-lock-constant-face 'font-lock-constant-face)
+ )
(defun cperl-init-faces ()
(condition-case errs
[nil nil t t t]
nil
[nil nil t t t])
+ (list 'font-lock-warning-face
+ ["Pink" "Red" "Gray50" "LightGray"]
+ ["gray20" "gray90"
+ "gray80" "gray20"]
+ [nil nil t t t]
+ nil
+ [nil nil t t t]
+ )
(list 'font-lock-constant-face
["CadetBlue" "Aquamarine" "Gray50" "LightGray"]
nil
"Face for data types")
(cperl-force-face cperl-nonoverridable-face
"Face for data types from another group")
+ (cperl-force-face font-lock-warning-face
+ "Face for things which should stand out")
(cperl-force-face font-lock-comment-face
"Face for comments")
(cperl-force-face font-lock-function-name-face
(set-marker e (1- (point)))
(cperl-beautify-regexp-piece b e nil deep))))
+(defun cperl-invert-if-unless-modifiers ()
+ "Change `B if A;' into `if (A) {B}' etc if possible.
+\(Unfinished.)"
+ (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)
+ (forward-sexp -1))
+ (setq pre-if (point))
+ (cperl-backward-to-start-of-expr)
+ (setq pre-B (point))
+ (forward-sexp 1) ; otherwise forward-to-end-of-expr is NOP
+ (cperl-forward-to-end-of-expr)
+ (setq post-A (point))
+ (goto-char pre-if)
+ (or (looking-at w-rex)
+ ;; Find the position
+ (progn (goto-char post-A)
+ (while (and
+ (not (looking-at w-rex))
+ (> (point) pre-B))
+ (forward-sexp -1))
+ (setq pre-if (point))))
+ (or (looking-at w-rex)
+ (error "Can't find `if', `unless', `while', `until', `for' or `foreach'"))
+ ;; 1 B 2 ... 3 B-com ... 4 if 5 ... if-com 6 ... 7 A 8
+ (setq if-string (buffer-substring (match-beginning 0) (match-end 0)))
+ ;; First, simple part: find code boundaries
+ (forward-sexp 1)
+ (setq post-if (point))
+ (forward-sexp -2)
+ (forward-sexp 1)
+ (setq post-B (point))
+ (cperl-backward-to-start-of-expr)
+ (setq pre-B (point))
+ (setq B (buffer-substring pre-B post-B))
+ (goto-char pre-if)
+ (forward-sexp 2)
+ (forward-sexp -1)
+ (setq pre-A (point))
+ (cperl-forward-to-end-of-expr)
+ (setq post-A (point))
+ (setq A (buffer-substring pre-A post-A))
+ ;; Now modify (from end, to not break the stuff)
+ (skip-chars-forward " \t;")
+ (delete-region pre-A (point)) ; we move to pre-A
+ (insert "\n" B ";\n}")
+ (and (looking-at "[ \t]*#") (cperl-indent-for-comment))
+ (delete-region pre-if post-if)
+ (delete-region pre-B post-B)
+ (goto-char pre-B)
+ (insert if-string " (" A ") {")
+ (setq post-B (point))
+ (if (looking-at "[ \t]+$")
+ (delete-horizontal-space)
+ (if (looking-at "[ \t]*#")
+ (cperl-indent-for-comment)
+ (just-one-space)))
+ (forward-line 1)
+ (if (looking-at "[ \t]*$")
+ (progn ; delete line
+ (delete-horizontal-space)
+ (delete-region (point) (1+ (point)))))
+ (cperl-indent-line)
+ (goto-char (1- post-B))
+ (forward-sexp 1)
+ (cperl-indent-line)
+ (goto-char pre-B)))
+
(defun cperl-invert-if-unless ()
- "Change `if (A) {B}' into `B if A;' etc if possible."
+ "Change `if (A) {B}' into `B if A;' etc (or visa versa) if possible.
+If the cursor is not on the leading keyword of the BLOCK flavor of
+construct, will assume it is the STATEMENT flavor, so will try to find
+the appropriate statement modifier."
(interactive)
- (or (looking-at "\\<")
- (forward-sexp -1))
+ (and (= (char-syntax (preceding-char)) ?w)
+ (forward-sexp -1))
(if (looking-at "\\<\\(if\\|unless\\|while\\|until\\|for\\|foreach\\)\\>")
- (let ((pos1 (point))
- pos2 pos3 pos4 pos5 s1 s2 state p pos45
- (s0 (buffer-substring (match-beginning 0) (match-end 0))))
+ (let ((pre-if (point))
+ pre-A post-A pre-B post-B A B state p end-B-code is-block B-comment
+ (if-string (buffer-substring (match-beginning 0) (match-end 0))))
(forward-sexp 2)
- (setq pos3 (point))
+ (setq post-A (point))
(forward-sexp -1)
- (setq pos2 (point))
- (if (eq (following-char) ?\( )
+ (setq pre-A (point))
+ (setq is-block (and (eq (following-char) ?\( )
+ (save-excursion
+ (condition-case nil
+ (progn
+ (forward-sexp 2)
+ (forward-sexp -1)
+ (eq (following-char) ?\{ ))
+ (error nil)))))
+ (if is-block
(progn
- (goto-char pos3)
+ (goto-char post-A)
(forward-sexp 1)
- (setq pos5 (point))
+ (setq post-B (point))
(forward-sexp -1)
- (setq pos4 (point))
- ;; XXXX In fact may be `A if (B); {C}' ...
+ (setq pre-B (point))
(if (and (eq (following-char) ?\{ )
(progn
- (cperl-backward-to-noncomment pos3)
+ (cperl-backward-to-noncomment post-A)
(eq (preceding-char) ?\) )))
(if (condition-case nil
(progn
- (goto-char pos5)
+ (goto-char post-B)
(forward-sexp 1)
(forward-sexp -1)
(looking-at "\\<els\\(e\\|if\\)\\>"))
(error nil))
(error
- "`%s' (EXPR) {BLOCK} with `else'/`elsif'" s0)
- (goto-char (1- pos5))
- (cperl-backward-to-noncomment pos4)
+ "`%s' (EXPR) {BLOCK} with `else'/`elsif'" if-string)
+ (goto-char (1- post-B))
+ (cperl-backward-to-noncomment pre-B)
(if (eq (preceding-char) ?\;)
(forward-char -1))
- (setq pos45 (point))
- (goto-char pos4)
- (while (re-search-forward "\\<\\(for\\|foreach\\|if\\|unless\\|while\\|until\\)\\>\\|;" pos45 t)
+ (setq end-B-code (point))
+ (goto-char pre-B)
+ (while (re-search-forward "\\<\\(for\\|foreach\\|if\\|unless\\|while\\|until\\)\\>\\|;" end-B-code t)
(setq p (match-beginning 0)
- s1 (buffer-substring p (match-end 0))
- state (parse-partial-sexp pos4 p))
+ A (buffer-substring p (match-end 0))
+ state (parse-partial-sexp pre-B p))
(or (nth 3 state)
(nth 4 state)
(nth 5 state)
- (error "`%s' inside `%s' BLOCK" s1 s0))
+ (error "`%s' inside `%s' BLOCK" A if-string))
(goto-char (match-end 0)))
;; Finally got it
- (goto-char (1+ pos4))
+ (goto-char (1+ pre-B))
(skip-chars-forward " \t\n")
- (setq s2 (buffer-substring (point) pos45))
- (goto-char pos45)
+ (setq B (buffer-substring (point) end-B-code))
+ (goto-char end-B-code)
(or (looking-at ";?[ \t\n]*}")
(progn
(skip-chars-forward "; \t\n")
- (setq s2 (concat s2 "\n" (buffer-substring (point) (1- pos5))))))
- (and (equal s2 "")
- (setq s2 "1"))
- (goto-char (1- pos3))
- (cperl-backward-to-noncomment pos2)
+ (setq B-comment
+ (buffer-substring (point) (1- post-B)))))
+ (and (equal B "")
+ (setq B "1"))
+ (goto-char (1- post-A))
+ (cperl-backward-to-noncomment pre-A)
(or (looking-at "[ \t\n]*)")
- (goto-char (1- pos3)))
+ (goto-char (1- post-A)))
(setq p (point))
- (goto-char (1+ pos2))
+ (goto-char (1+ pre-A))
(skip-chars-forward " \t\n")
- (setq s1 (buffer-substring (point) p))
- (delete-region pos4 pos5)
- (delete-region pos2 pos3)
- (goto-char pos1)
- (insert s2 " ")
+ (setq A (buffer-substring (point) p))
+ (delete-region pre-B post-B)
+ (delete-region pre-A post-A)
+ (goto-char pre-if)
+ (insert B " ")
+ (and B-comment (insert B-comment " "))
(just-one-space)
(forward-word 1)
- (setq pos1 (point))
- (insert " " s1 ";")
+ (setq pre-A (point))
+ (insert " " A ";")
(delete-horizontal-space)
+ (setq post-B (point))
+ (if (looking-at "#")
+ (indent-for-comment))
+ (goto-char post-B)
(forward-char -1)
(delete-horizontal-space)
- (goto-char pos1)
+ (goto-char pre-A)
(just-one-space)
- (cperl-indent-line))
- (error "`%s' (EXPR) not with an {BLOCK}" s0)))
- (error "`%s' not with an (EXPR)" s0)))
- (error "Not at `if', `unless', `while', `until', `for' or `foreach'")))
+ (goto-char pre-if)
+ (setq pre-A (set-marker (make-marker) pre-A))
+ (while (<= (point) (marker-position pre-A))
+ (cperl-indent-line)
+ (forward-line 1))
+ (goto-char (marker-position pre-A))
+ (if B-comment
+ (progn
+ (forward-line -1)
+ (indent-for-comment)
+ (goto-char (marker-position pre-A)))))
+ (error "`%s' (EXPR) not with an {BLOCK}" if-string)))
+ ;; (error "`%s' not with an (EXPR)" if-string)
+ (forward-sexp -1)
+ (cperl-invert-if-unless-modifiers)))
+ ;;(error "Not at `if', `unless', `while', `until', `for' or `foreach'")
+ (cperl-invert-if-unless-modifiers)))
;;; By Anthony Foiani <afoiani@uswest.com>
;;; Getting help on modules in C-h f ?
(setq flist (cdr flist))))
command))
+
+(defun cperl-next-interpolated-REx-1 ()
+ "Move point to next REx which has interpolated parts without //o.
+Skips RExes consisting of one interpolated variable.
+
+Note that skipped RExen are not performance hits."
+ (interactive "")
+ (cperl-next-interpolated-REx 1))
+
+(defun cperl-next-interpolated-REx-0 ()
+ "Move point to next REx which has interpolated parts without //o."
+ (interactive "")
+ (cperl-next-interpolated-REx 0))
+
+(defun cperl-next-interpolated-REx (&optional skip beg limit)
+ "Move point to next REx which has interpolated parts.
+SKIP is a list of possible types to skip, BEG and LIMIT are the starting
+point and the limit of search (default to point and end of buffer).
+
+SKIP may be a number, then it behaves as list of numbers up to SKIP; this
+semantic may be used as a numeric argument.
+
+Types are 0 for / $rex /o (interpolated once), 1 for /$rex/ (if $rex is
+a result of qr//, this is not a performance hit), t for the rest."
+ (interactive "P")
+ (if (numberp skip) (setq skip (list 0 skip)))
+ (or beg (setq beg (point)))
+ (or limit (setq limit (point-max))) ; needed for n-s-p-c
+ (let (pp)
+ (and (eq (get-text-property beg 'syntax-type) 'string)
+ (setq beg (next-single-property-change beg 'syntax-type nil limit)))
+ (cperl-map-pods-heres
+ (function (lambda (s e p)
+ (if (memq (get-text-property s 'REx-interpolated) skip)
+ t
+ (setq pp s)
+ nil))) ; nil stops
+ 'REx-interpolated beg limit)
+ (if pp (goto-char pp)
+ (message "No more interpolated REx"))))
+
;;; Initial version contributed by Trey Belew
(defun cperl-here-doc-spell (&optional beg end)
"Spell-check HERE-documents in the Perl buffer.
(cperl-fontify-syntaxically to)))))
(defvar cperl-version
- (let ((v "$Revision: 5.16 $"))
+ (let ((v "$Revision: 5.19 $"))
(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.")
projects / lib.git / commitdiff