diff options
| -rw-r--r-- | emacs/cperl-mode.el | 611 |
1 files changed, 442 insertions, 169 deletions
diff --git a/emacs/cperl-mode.el b/emacs/cperl-mode.el index 017a7a2f61..b00d77a115 100644 --- a/emacs/cperl-mode.el +++ b/emacs/cperl-mode.el @@ -32,7 +32,7 @@ ;;; Corrections made by Ilya Zakharevich ilya@math.mps.ohio-state.edu ;;; XEmacs changes by Peter Arius arius@informatik.uni-erlangen.de -;; $Id: cperl-mode.el,v 1.33 1997/03/14 06:45:51 ilya Exp ilya $ +;; $Id: cperl-mode.el,v 1.39 1997/10/14 08:28:00 ilya Exp ilya $ ;;; To use this mode put the following into your .emacs file: @@ -53,7 +53,7 @@ ;;; Additional useful commands to put into your .emacs file: ;; (setq auto-mode-alist -;; (append '(("\\.[pP][Llm]$" . perl-mode)) auto-mode-alist )) +;; (append '(("\\.\\([pP][Llm]\\|al\\)$" . perl-mode)) auto-mode-alist )) ;; (setq interpreter-mode-alist (append interpreter-mode-alist ;; '(("miniperl" . perl-mode)))) @@ -399,7 +399,7 @@ ;;;; `cperl-use-syntax-table-text-property'. ;;;; After 1.32.3 -;;; We scan for s{}[] as well. +;;; We scan for s{}[] as well (in simplest situations). ;;; We scan for $blah'foo as well. ;;; The default is to use `syntax-table' text property if Emacs is good enough. ;;; `cperl-lineup' is put on C-M-| (=C-M-S-\\). @@ -411,6 +411,58 @@ ;;; Generation of Class Hierarchy was broken due to a bug in `x-popup-menu' ;;; in 19.34. +;;;; After 1.33: +;;; my,local highlight vars after {} too. +;;; TAGS could not be created before imenu was loaded. +;;; `cperl-indent-left-aligned-comments' created. +;;; Logic of `cperl-indent-exp' changed a little bit, should be more +;;; robust w.r.t. multiline strings. +;;; Recognition of blah'foo takes into account strings. +;;; Added '.al' to the list of Perl extensions. +;;; Class hierarchy is "mostly" sorted (need to rethink algorthm +;;; of pruning one-root-branch subtrees to get yet better sorting.) +;;; Regeneration of TAGS was busted. +;;; Can use `syntax-table' property when generating TAGS +;;; (governed by `cperl-use-syntax-table-text-property-for-tags'). + +;;;; After 1.35: +;;; Can process several =pod/=cut sections one after another. +;;; Knows of `extproc' when under `emx', indents with `__END__' and `__DATA__'. +;;; `cperl-under-as-char' implemented (XEmacs people like broken behaviour). +;;; Beautifier for regexps fixed. +;;; `cperl-beautify-level', `cperl-contract-level' coded +;;; +;;;; Emacs's 20.2 problems: +;;; `imenu.el' has bugs, `imenu-add-to-menubar' does not work. +;;; Couple of others problems with 20.2 were reported, my ability to check/fix +;;; them is very reduced now. + +;;;; After 1.36: +;;; 'C-M-|' in XEmacs fixed + +;;;; After 1.37: +;;; &&s was not recognized as start of regular expression; +;;; Will "preprocess" the contents of //e part of s///e too; +;;; What to do with s# blah # foo #e ? +;;; Should handle s;blah;foo;; better. +;;; Now the only known problems with regular expression recognition: +;;;;;;; s<foo>/bar/ - different delimiters (end ignored) +;;;;;;; s/foo/\\bar/ - backslash at start of subst (made into one chunk) +;;;;;;; s/foo// - empty subst (made into one chunk + '/') +;;;;;;; s/foo/(bar)/ - start-group at start of subst (internal group will not match backwards) + +;;;; After 1.38: +;;; We highlight closing / of s/blah/foo/e; +;;; This handles s# blah # foo #e too; +;;; s//blah/, s///, s/blah// works again, and s#blah## too, the algorithm +;;; is much simpler now; +;;; Next round of changes: s\\\ works, s<blah>/foo/, +;;; comments between the first and the second part allowed +;;; Another problem discovered: +;;;;;;; s[foo] <blah>e - e part delimited by different <> (will not match) +;;; `cperl-find-pods-heres' somehow maybe called when string-face is undefined +;;; - put a stupid workaround for 20.1 + (defconst cperl-xemacs-p (string-match "XEmacs\\|Lucid" emacs-version)) (defvar cperl-extra-newline-before-brace nil @@ -474,7 +526,8 @@ Can be overwritten by `cperl-hairy' if nil.") Can be overwritten by `cperl-hairy' if nil.") (defvar cperl-electric-parens-string "({[]})<" - "*String of parentheses that should be electric in CPerl.") + "*String of parentheses that should be electric in CPerl. +Closing ones are electric only if the region is highlighted.") (defvar cperl-electric-parens nil "*Non-nil (and non-null) means parentheses should be electric in CPerl. @@ -488,10 +541,6 @@ Can be overwritten by `cperl-hairy' if nil.") "*Not-nil means that electric parens look for active mark. Default is yes if there is visual feedback on mark.") -(defvar cperl-electric-parens-mark (and window-system transient-mark-mode) - "*Not-nil means that electric parens look for active mark. -Default is yes if there is visual feedback on mark.") - (defvar cperl-electric-linefeed nil "*If true, LFD should be hairy in CPerl, otherwise C-c LFD is hairy. In any case these two mean plain and hairy linefeeds together. @@ -551,11 +600,14 @@ May require patched `imenu' and `imenu-go'.") Older version of this page was called `perl5', newer `perl'.") (defvar cperl-use-syntax-table-text-property - (and (not cperl-xemacs-p) - (string< "19.34.94" emacs-version)) ; Not all .94 are good, but anyway + (boundp 'parse-sexp-lookup-properties) "*Non-nil means CPerl sets up and uses `syntax-table' text property.") -(defvar cperl-scan-files-regexp "\\.\\([Pp][Llm]\\|xs\\)$" +(defvar cperl-use-syntax-table-text-property-for-tags + cperl-use-syntax-table-text-property + "*Non-nil means: set up and use `syntax-table' text property generating TAGS.") + +(defvar cperl-scan-files-regexp "\\.\\([pP][Llm]\\|xs\\)$" "*Regexp to match files to scan when generating TAGS.") (defvar cperl-noscan-files-regexp "/\\(\\.\\.?\\|SCCS\\|RCS\\|blib\\)$" @@ -565,6 +617,13 @@ Older version of this page was called `perl5', newer `perl'.") "*indentation used when beautifying regexps. If `nil', the value of `cperl-indent-level' will be used.") +(defvar cperl-indent-left-aligned-comments t + "*Non-nil means that the comment starting in leftmost column should indent.") + +(defvar cperl-under-as-char t + "*Non-nil means that the _ (underline) should be treated as word char.") + + ;;; Short extra-docs. @@ -798,11 +857,14 @@ progress indicator for indentation (with `imenu' loaded). (put-text-property (max (point-min) (1- from)) to cperl-do-not-fontify t)) +(defvar cperl-mode-hook nil + "Hook run by `cperl-mode'.") + ;;; Probably it is too late to set these guys already, but it can help later: (setq auto-mode-alist - (append '(("\\.[pP][Llm]$" . perl-mode)) auto-mode-alist )) + (append '(("\\.\\([pP][Llm]\\|al\\)$" . perl-mode)) auto-mode-alist )) (and (boundp 'interpreter-mode-alist) (setq interpreter-mode-alist (append interpreter-mode-alist '(("miniperl" . perl-mode))))) @@ -847,7 +909,8 @@ progress indicator for indentation (with `imenu' loaded). (cperl-define-key "\C-c\C-k" 'cperl-toggle-abbrev) (cperl-define-key "\C-c\C-e" 'cperl-toggle-electric) (cperl-define-key "\e\C-q" 'cperl-indent-exp) ; Usually not bound - (cperl-define-key [?\C-\M-\|] 'cperl-lineup) + (cperl-define-key [?\C-\M-\|] 'cperl-lineup + [(control meta |)]) ;;(cperl-define-key "\M-q" 'cperl-fill-paragraph) ;;(cperl-define-key "\e;" 'cperl-indent-for-comment) (cperl-define-key "\177" 'cperl-electric-backspace) @@ -883,6 +946,7 @@ progress indicator for indentation (with `imenu' loaded). 'indent-for-comment 'cperl-indent-for-comment cperl-mode-map global-map))) +(defvar cperl-menu) (condition-case nil (progn (require 'easymenu) @@ -897,6 +961,10 @@ progress indicator for indentation (with `imenu' loaded). ["Line up a construction" cperl-lineup (cperl-use-region-p)] ["Beautify a regexp" cperl-beautify-regexp cperl-use-syntax-table-text-property] + ["Beautify a group in regexp" cperl-beautify-level + cperl-use-syntax-table-text-property] + ["Contract a group in regexp" cperl-contract-level + cperl-use-syntax-table-text-property] "----" ["Indent region" cperl-indent-region (cperl-use-region-p)] ["Comment region" cperl-comment-region (cperl-use-region-p)] @@ -936,7 +1004,7 @@ progress indicator for indentation (with `imenu' loaded). (cperl-write-tags nil t t t) t] ["Add tags for Perl files in (sub)directories" (cperl-write-tags nil nil t t) t]) - ["Recalculate PODs and HEREs" cperl-find-pods-heres t] + ["Recalculate \"hard\" constructions" cperl-find-pods-heres t] ["Define word at point" imenu-go-find-at-position (fboundp 'imenu-go-find-at-position)] ["Help on function" cperl-info-on-command t] @@ -992,7 +1060,8 @@ The expansion is entirely correct because it uses the C preprocessor." (modify-syntax-entry ?# "<" cperl-mode-syntax-table) (modify-syntax-entry ?' "\"" cperl-mode-syntax-table) (modify-syntax-entry ?` "\"" cperl-mode-syntax-table) - (modify-syntax-entry ?_ "w" cperl-mode-syntax-table) + (if cperl-under-as-char + (modify-syntax-entry ?_ "w" cperl-mode-syntax-table)) (modify-syntax-entry ?: "_" cperl-mode-syntax-table) (modify-syntax-entry ?| "." cperl-mode-syntax-table) (setq cperl-string-syntax-table (copy-syntax-table cperl-mode-syntax-table)) @@ -1014,6 +1083,9 @@ The expansion is entirely correct because it uses the C preprocessor." ;; provide an alias for working with emacs 19. the perl-mode that comes ;; with it is really bad, and this lets us seamlessly replace it. (fset 'perl-mode 'cperl-mode) +(defvar cperl-faces-init) +;; Fix for msb.el +(defvar cperl-msb-fixed nil) (defun cperl-mode () "Major mode for editing Perl code. Expression and list commands understand all C brackets. @@ -1229,7 +1301,8 @@ with no args." (if cperl-use-syntax-table-text-property (progn (make-variable-buffer-local 'parse-sexp-lookup-properties) - (setq parse-sexp-lookup-properties t))) + ;; Do not introduce variable if not needed, we check it! + (set 'parse-sexp-lookup-properties t))) (or (fboundp 'cperl-old-auto-fill-mode) (progn (fset 'cperl-old-auto-fill-mode (symbol-function 'auto-fill-mode)) @@ -1266,8 +1339,6 @@ with no args." nil nil '(gud-perldb-history . 1)))) -;; Fix for msb.el -(defvar cperl-msb-fixed nil) (defun cperl-msb-fix () ;; Adds perl files to msb menu, supposes that msb is already loaded @@ -1881,7 +1952,9 @@ Returns nil if line starts inside a string, t if in a comment." '(pod here-doc here-doc-delim format)) ;; before start of POD - whitespace found since do not have 'pod! (and (looking-at "[ \t]*\n=") - (error "Spaces before pod section!"))) + (error "Spaces before pod section!")) + (and (not cperl-indent-left-aligned-comments) + (looking-at "^#"))) nil (beginning-of-line) (let ((indent-point (point)) @@ -2384,20 +2457,118 @@ Returns true if comment is found." 'syntax-table cperl-string-syntax-table)) (cperl-protect-defun-start bb e)))) +(defun cperl-forward-re (is-2arg set-st st-l err-l argument + &optional ostart oend) + ;; Unfinished + ;; Works *before* syntax recognition is done + ;; May modify syntax-type text property if the situation is too hard + (let (b starter ender st i i2) + (skip-chars-forward " \t") + ;; ender means matching-char matcher. + (setq b (point) + starter (char-after b) + ;; ender: + ender (cdr (assoc starter '(( ?\( . ?\) ) + ( ?\[ . ?\] ) + ( ?\{ . ?\} ) + ( ?\< . ?\> ) + )))) + ;; What if starter == ?\\ ???? + (if set-st + (if (car st-l) + (setq st (car st-l)) + (setcar st-l (make-syntax-table)) + (setq i 0 st (car st-l)) + (while (< i 256) + (modify-syntax-entry i "." st) + (setq i (1+ i))) + (modify-syntax-entry ?\\ "\\" st))) + (setq set-st t) + ;; Whether we have an intermediate point + (setq i nil) + ;; Prepare the syntax table: + (and set-st + (if (not ender) ; m/blah/, s/x//, s/x/y/ + (modify-syntax-entry starter "$" st) + (modify-syntax-entry starter (concat "(" (list ender)) st) + (modify-syntax-entry ender (concat ")" (list starter)) st))) + (condition-case bb + (progn + (if (and (eq starter (char-after (cperl-1+ b))) + (not ender)) + ;; $ has TeXish matching rules, so $$ equiv $... + (forward-char 2) + (set-syntax-table st) + (forward-sexp 1) + (set-syntax-table cperl-mode-syntax-table) + ;; Now the problem is with m;blah;; + (and (not ender) + (eq (preceding-char) + (char-after (- (point) 2))) + (save-excursion + (forward-char -2) + (= 0 (% (skip-chars-backward "\\\\") 2))) + (forward-char -1))) + (and is-2arg ; Have trailing part + (not ender) + (eq (following-char) starter) ; Empty trailing part + (if (eq (char-syntax (following-char)) ?.) + (setq is-2arg nil) ; Ignore the tail + ;; Make trailing letter into punctuation + (setq is-2arg nil) ; Ignore the tail + (put-text-property (point) (1+ (point)) + 'syntax-table cperl-st-punct) + (put-text-property (point) (1+ (point)) 'rear-nonsticky t))) + (if is-2arg ; Not number => have second part + (progn + (setq i (point) i2 i) + (if ender + (if (eq (char-syntax (following-char)) ?\ ) + (progn + (while (looking-at "\\s *#") + (beginning-of-line 2)) + (skip-chars-forward " \t\n\f") + (setq i2 (point)))) + (forward-char -1)) + (modify-syntax-entry starter (if (eq starter ?\\) "\\" ".") st) + (if ender (modify-syntax-entry ender "." st)) + (setq set-st nil) + (setq + ender + (cperl-forward-re nil t st-l err-l argument starter ender) + ender (nth 2 ender))))) + (error (goto-char (point-max)) + (message + "End of `%s%s%c ... %c' string not found: %s" + argument + (if ostart (format "%c ... %c" ostart (or oend ostart)) "") + starter (or ender starter) bb) + (or (car err-l) (setcar err-l b)))) + (if set-st + (progn + (modify-syntax-entry starter (if (eq starter ?\\) "\\" ".") st) + (if ender (modify-syntax-entry ender "." st)))) + (list i i2 ender starter))) + (defun cperl-find-pods-heres (&optional min max) - "Scans the buffer for POD sections and here-documents. + "Scans the buffer for hard-to-parse Perl constructions. If `cperl-pod-here-fontify' is not-nil after evaluation, will fontify the sections using `cperl-pod-head-face', `cperl-pod-face', `cperl-here-face'." (interactive) (or min (setq min (point-min))) (or max (setq max (point-max))) - (let (face head-face here-face b e bb tag qtag err b1 e1 argument st i c + (let (face head-face here-face b e bb tag qtag b1 e1 argument i c tail state (cperl-pod-here-fontify (eval cperl-pod-here-fontify)) (case-fold-search nil) (inhibit-read-only t) (buffer-undo-list t) (modified (buffer-modified-p)) (after-change-functions nil) - (state-point (point-min)) state + (state-point (point-min)) + (st-l '(nil)) (err-l '(nil)) i2 + ;; Somehow font-lock may be not loaded yet... + (font-lock-string-face (if (boundp 'font-lock-string-face) + font-lock-string-face + 'font-lock-string-face)) (search (concat "\\(\\`\n?\\|\n\n\\)=" @@ -2434,12 +2605,16 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', "\\$\\(['{]\\)" "\\|" ;; 1+6+2+1+1+2+1=14 extra () before this: - "\\(\\<sub[ \t\n\f]+\\|[&*$@%]\\)[a-zA-Z0-9_]*'") + "\\(\\<sub[ \t\n\f]+\\|[&*$@%]\\)[a-zA-Z0-9_]*'" + ;; 1+6+2+1+1+2+1+1=15 extra () before this: + "\\|" + "__\\(END\\|DATA\\)__" ; Commented - does not help with indent... + ) "")))) (unwind-protect (progn (save-excursion - (message "Scanning for pods, formats and here-docs...") + (message "Scanning for \"hard\" Perl constructions...") (if cperl-pod-here-fontify ;; We had evals here, do not know why... (setq face cperl-pod-face @@ -2449,6 +2624,11 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', '(syntax-type t in-pod t syntax-table t)) ;; Need to remove face as well... (goto-char min) + (if (and (eq system-type 'emx) + (looking-at "extproc[ \t]")) ; Analogue of #! + (cperl-commentify min + (save-excursion (end-of-line) (point)) + nil)) (while (re-search-forward search max t) (cond ((match-beginning 1) ; POD section @@ -2456,14 +2636,14 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', (if (looking-at "\n*cut\\>") (progn (message "=cut is not preceded by a pod section") - (or err (setq err (point)))) + (or (car err-l) (setcar err-l (point)))) (beginning-of-line) (setq b (point) bb b) (or (re-search-forward "\n\n=cut\\>" max 'toend) (progn (message "Cannot find the end of a pod section") - (or err (setq err b)))) + (or (car err-l) (setcar err-l b)))) (beginning-of-line 2) ; An empty line after =cut is not POD! (setq e (point)) (put-text-property b e 'in-pod t) @@ -2499,7 +2679,9 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', (match-beginning 1) (match-end 1) 'face head-face)))) (cperl-commentify bb e nil) - (goto-char e))) + (goto-char e) + (or (eq e (point-max)) + (forward-char -1)))) ; Prepare for immediate pod start. ;; Here document ;; We do only one here-per-line ;; 1 () ahead @@ -2548,7 +2730,7 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', (cperl-commentify b e1 nil) (cperl-put-do-not-fontify b (match-end 0))) (t (message "End of here-document `%s' not found." tag) - (or err (setq err b)))))) + (or (car err-l) (setcar err-l b)))))) ;; format ((match-beginning 8) ;; 1+6=7 extra () before this: @@ -2587,7 +2769,7 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', (cperl-commentify (point) (+ (point) 2) nil) (cperl-put-do-not-fontify (point) (+ (point) 2))) (message "End of format `%s' not found." name) - (or err (setq err b))) + (or (car err-l) (setcar err-l b))) (forward-line) (put-text-property b (point) 'syntax-type 'format) ;;; (cond ((re-search-forward (concat "^[.;]$") max 'toend) @@ -2604,23 +2786,29 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', ;; Regexp: ((or (match-beginning 10) (match-beginning 11)) ;; 1+6+2=9 extra () before this: - ;; "\\<\\(qx?\\|[my]\\)\\>" + ;; "\\<\\(q[wxq]?\\|[msy]\\|tr\\)\\>" + ;; "\\|" + ;; "\\([?/]\\)" ; /blah/ or ?blah? (setq b1 (if (match-beginning 10) 10 11) argument (buffer-substring (match-beginning b1) (match-end b1)) b (point) i b c (char-after (match-beginning b1)) - bb (or - (memq (char-after (1- (match-beginning b1))) - '(?\$ ?\@ ?\% ?\& ?\*)) - (and - (eq (char-after (1- (match-beginning b1))) ?-) - (eq (char-after (match-beginning b1)) ?s)))) + bb (char-after (1- (match-beginning b1))) ; tmp holder + bb (and ; user variables/whatever + (match-beginning 10) + (or + (memq bb '(?\$ ?\@ ?\% ?\*)) + (and (eq bb ?-) (eq c ?s)) ; -s file test + (and (eq bb ?\&) ; &&m/blah/ + (not (eq (char-after + (- (match-beginning b1) 2)) + ?\&)))))) (or bb (if (eq b1 11) ; bare /blah/ or ?blah? (setq argument "" - bb + bb ; Not a regexp? (progn (goto-char (match-beginning b1)) (cperl-backward-to-noncomment (point-min)) @@ -2635,7 +2823,7 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', (progn (forward-sexp -1) (looking-at - "\\(while\\|if\\|unless\\|until\\|and\\|or\\|not\\|xor\\|split\\|grep\\|map\\)\\>"))) + "\\(while\\|if\\|unless\\|until\\|and\\|or\\|not\\|xor\\|split\\|grep\\|map\\|print\\)\\>"))) (and (eq (preceding-char) ?.) (eq (char-after (- (point) 2)) ?.)) (bobp)))) @@ -2647,83 +2835,32 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', (if (or bb (nth 3 state) (nth 4 state)) (goto-char i) (skip-chars-forward " \t") - ;; qtag means two-argument matcher, may be reset to - ;; 2 or 3 later if some special quoting is needed. - (setq b (point) - tag (char-after b) - qtag (if (string-match "^\\([sy]\\|tr\\)$" argument) t) - e1 (cdr (assoc tag '(( ?\( . ?\) ) - ( ?\[ . ?\] ) - ( ?\{ . ?\} ) - ( ?\< . ?\> ) - )))) - ;; What if tag == ?\\ ???? - (or st - (progn - (setq st (make-syntax-table) i 0) - (while (< i 256) - (modify-syntax-entry i "." st) - (setq i (1+ i))) - (modify-syntax-entry ?\\ "\\" st))) - ;; Whether we have an intermediate point - (setq i nil) - ;; Prepare the syntax table: - (cond - ;; $ has TeXish matching rules, so $$ equiv $... - ((and qtag - (not e1) - (eq tag (char-after (cperl-1+ b))) - (eq tag (char-after (+ 2 b)))) - (setq qtag 3)) ; s/// - ((and qtag - (not e1) - (eq tag (char-after (cperl-1+ b)))) - (setq qtag nil)) ; s//blah/, will work anyway - ((and (not e1) - (eq tag (char-after (cperl-1+ b)))) - (setq qtag 2)) ; m// - ((not e1) - (modify-syntax-entry tag "$" st)) ; m/blah/, s/x//, s/x/y/ - (t ; s{}(), m[] - (modify-syntax-entry tag (concat "(" (list e1)) st) - (modify-syntax-entry e1 (concat ")" (list tag)) st))) - (if (numberp qtag) - (forward-char qtag) - (condition-case bb - (progn - (set-syntax-table st) - (forward-sexp 1) ; Wrong if m// - taken care of... - (if qtag - (if e1 - (progn - (setq i (point)) - (set-syntax-table cperl-mode-syntax-table) - (forward-sexp 1)) ; Should be smarter? - ;; "$" has funny matching rules - (if (/= (char-after (- (point) 2)) - (preceding-char)) - (progn - ;; Commenting \\ is dangerous, what about ( ? - (if (eq (following-char) ?\\) nil - (setq i (point))) - (forward-char -1) - (forward-sexp 1))) - ))) - (error (goto-char (point-max)) - (message - "End of `%s%c ... %c' string not found: %s" - argument tag (or e1 tag) bb) - (or err (setq err b))))) - (set-syntax-table cperl-mode-syntax-table) + ;; qtag means two-arg matcher, may be reset to + ;; 2 or 3 later if some special quoting is needed. + ;; e1 means matching-char matcher. + (setq b (point) + i (cperl-forward-re + (string-match "^\\([sy]\\|tr\\)$" argument) + t st-l err-l argument) + i2 (nth 1 i) ; start of the second part + e1 (nth 2 i) ; ender, true if matching second part + i (car i) ; intermediate point + tail (if (and i (not e1)) (1- (point)))) + ;; Commenting \\ is dangerous, what about ( ? + (and i tail + (eq (char-after i) ?\\) + (setq i nil tail nil)) (if (null i) (cperl-commentify b (point) t) (cperl-commentify b i t) - (if (looking-at "\\sw*e") nil ; s///e - (cperl-commentify i (point) t))) + (if (looking-at "\\sw*e") ; s///e + (cperl-find-pods-heres i2 (1- (point))) + (cperl-commentify i2 (point) t) + (setq tail nil))) (if (eq (char-syntax (following-char)) ?w) - (forward-word 1)) ; skip modifiers s///s - (modify-syntax-entry tag "." st) - (if e1 (modify-syntax-entry e1 "." st)))) + (progn + (forward-word 1) ; skip modifiers s///s + (if tail (cperl-commentify tail (point) t)))))) ((match-beginning 13) ; sub with prototypes (setq b (match-beginning 0)) (if (memq (char-after (1- b)) @@ -2737,6 +2874,8 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', ;; Mark as string (cperl-commentify (match-beginning 13) (match-end 13) t)) (goto-char (match-end 0)))) + ;; 1+6+2+1+1+2=13 extra () before this: + ;; "\\$\\(['{]\\)" ((and (match-beginning 14) (eq (preceding-char) ?\')) ; $' (setq b (1- (point)) @@ -2748,13 +2887,38 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', (put-text-property (1- b) b 'syntax-table cperl-st-punct) (put-text-property (1- b) b 'rear-nonsticky t))) (goto-char (1+ b))) + ;; 1+6+2+1+1+2=13 extra () before this: + ;; "\\$\\(['{]\\)" ((match-beginning 14) ; ${ (setq bb (match-beginning 0)) (put-text-property bb (1+ bb) 'syntax-table cperl-st-punct) (put-text-property bb (1+ bb) 'rear-nonsticky t)) - (t ; old $abc'efg syntax - (setq bb (match-end 0)) - (put-text-property (1- bb) bb 'syntax-table cperl-st-word)))) + ;; 1+6+2+1+1+2+1=14 extra () before this: + ;; "\\(\\<sub[ \t\n\f]+\\|[&*$@%]\\)[a-zA-Z0-9_]*'") + ((match-beginning 15) ; old $abc'efg syntax + (setq bb (match-end 0) + b (match-beginning 0) + state (parse-partial-sexp + state-point b nil nil state) + state-point b) + (if (nth 3 state) ; in string + nil + (put-text-property (1- bb) bb 'syntax-table cperl-st-word)) + (goto-char bb)) + ;; 1+6+2+1+1+2+1+1=15 extra () before this: + ;; "__\\(END\\|DATA\\)__" + (t ; __END__, __DATA__ + (setq bb (match-end 0) + b (match-beginning 0) + state (parse-partial-sexp + state-point b nil nil state) + state-point b) + (if (or (nth 3 state) (nth 4 state)) + nil + ;; (put-text-property b (1+ bb) 'syntax-type 'pod) ; Cheat + (cperl-commentify b bb nil) + ) + (goto-char bb)))) ;;; (while (re-search-forward "\\(\\`\n?\\|\n\n\\)=" max t) ;;; (if (looking-at "\n*cut\\>") ;;; (progn @@ -2850,8 +3014,8 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', ;;; (cperl-put-do-not-fontify b (match-beginning 0))) ;;; (t (message "End of format `%s' not found." name)))) ) - (if err (goto-char err) - (message "Scan for pods, formats and here-docs completed."))) + (if (car err-l) (goto-char (car err-l)) + (message "Scan for \"hard\" Perl constructions completed."))) (and (buffer-modified-p) (not modified) (set-buffer-modified-p nil)) @@ -2864,9 +3028,10 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', (skip-chars-backward " \t\n\f" lim) (setq p (point)) (beginning-of-line) - (if (looking-at "^[ \t]*\\(#\\|$\\)") nil ; Only comment, skip + (if (or (looking-at "^[ \t]*\\(#\\|$\\)") + (progn (cperl-to-comment-or-eol) (bolp))) + nil ; Only comment, skip ;; Else - (cperl-to-comment-or-eol) (skip-chars-backward " \t") (if (< p (point)) (goto-char p)) (setq stop t))))) @@ -2931,8 +3096,8 @@ or looks like continuation of the comment on the previous line." (save-excursion (let ((tmp-end (progn (end-of-line) (point))) top done) (save-excursion + (beginning-of-line) (while (null done) - (beginning-of-line) (setq top (point)) (while (= (nth 0 (parse-partial-sexp (point) tmp-end -1)) -1) @@ -3147,6 +3312,7 @@ indentation and initial hashes. Behaves usually outside of comment." (defun imenu-example--create-perl-index (&optional regexp) (require 'cl) + (require 'imenu) ; May be called from TAGS creator (let ((index-alist '()) (index-pack-alist '()) (index-pod-alist '()) (index-unsorted-alist '()) (i-s-f (default-value 'imenu-sort-function)) (index-meth-alist '()) meth @@ -3162,6 +3328,12 @@ indentation and initial hashes. Behaves usually outside of comment." (imenu-progress-message prev-pos) ;;(backward-up-list 1) (cond + ((and ; Skip some noise if building tags + (match-beginning 2) ; package or sub + (eq (char-after (match-beginning 2)) ?p) ; package + (not (save-match-data + (looking-at "[ \t\n]*;")))) ; Plain text word 'package' + nil) ((and (match-beginning 2) ; package or sub ;; Skip if quoted (will not skip multi-line ''-comments :-(): @@ -3473,12 +3645,12 @@ indentation and initial hashes. Behaves usually outside of comment." (2 '(restart 2 nil) nil t))) nil t))) ; local variables, multiple (font-lock-anchored - '("^[ \t]*\\(my\\|local\\)[ \t]*\\(([ \t]*\\)?\\([$@%*][a-zA-Z0-9_:]+\\)" + '("^[ \t{}]*\\(my\\|local\\)[ \t]*\\(([ \t]*\\)?\\([$@%*][a-zA-Z0-9_:]+\\)" (3 font-lock-variable-name-face) ("\\=[ \t]*,[ \t]*\\([$@%*][a-zA-Z0-9_:]+\\)" nil nil (1 font-lock-variable-name-face)))) - (t '("^[ \t]*\\(my\\|local\\)[ \t]*\\(([ \t]*\\)?\\([$@%*][a-zA-Z0-9_:]+\\)" + (t '("^[ \t{}]*\\(my\\|local\\)[ \t]*\\(([ \t]*\\)?\\([$@%*][a-zA-Z0-9_:]+\\)" 3 font-lock-variable-name-face))) '("\\<for\\(each\\)?[ \t]*\\(\\$[a-zA-Z_][a-zA-Z_0-9]*\\)[ \t]*(" 2 font-lock-variable-name-face))) @@ -4037,7 +4209,7 @@ in subdirectories too." ((eq all 'recursive) ;;(error "Not implemented: recursive") (setq args (append (list "-e" - "sub wanted {push @ARGV, $File::Find::name if /\\.[Pp][Llm]$/} + "sub wanted {push @ARGV, $File::Find::name if /\\.[pP][Llm]$/} use File::Find; find(\\&wanted, '.'); exec @ARGV;" @@ -4086,7 +4258,12 @@ in subdirectories too." (set-buffer (get-buffer-create cperl-tmp-buffer)) (set-syntax-table cperl-mode-syntax-table) (buffer-disable-undo) - (auto-fill-mode 0)) + (auto-fill-mode 0) + (if cperl-use-syntax-table-text-property-for-tags + (progn + (make-variable-buffer-local 'parse-sexp-lookup-properties) + ;; Do not introduce variable if not needed, we check it! + (set 'parse-sexp-lookup-properties t)))) (defun cperl-xsub-scan () (require 'cl) @@ -4136,13 +4313,16 @@ in subdirectories too." index-alist)) (defun cperl-find-tags (file xs) - (let (ind (b (get-buffer cperl-tmp-buffer)) lst elt pos ret) + (let (ind (b (get-buffer cperl-tmp-buffer)) lst elt pos ret + (cperl-pod-here-fontify nil)) (save-excursion (if b (set-buffer b) (cperl-setup-tmp-buf)) (erase-buffer) (setq file (car (insert-file-contents file))) (message "Scanning file %s..." file) + (if cperl-use-syntax-table-text-property-for-tags + (cperl-find-pods-heres)) (if xs (setq lst (cperl-xsub-scan)) (setq ind (imenu-example--create-perl-index)) @@ -4242,10 +4422,11 @@ in subdirectories too." (progn (search-backward "\f\n") (delete-region (point) - (progn + (save-excursion (forward-char 1) - (search-forward "\f\n" nil 'toend) - (point)))) + (if (search-forward "\f\n" nil 'toend) + (- (point) 2) + (point-max))))) (goto-char (point-max))))) (insert (cperl-find-tags file xs)))) (if inbuffer nil ; Delegate to the caller @@ -4362,7 +4543,7 @@ One may build such TAGS files from CPerl mode menu." (if (eq update -999) (cperl-tags-hier-init t))) (defun cperl-tags-treeify (to level) - ;; cadr of to is read-write. On start it is a cons + ;; cadr of `to' is read-write. On start it is a cons (let* ((regexp (concat "^\\(" (mapconcat 'identity (make-list level "[_a-zA-Z0-9]+") @@ -4403,23 +4584,33 @@ One may build such TAGS files from CPerl mode menu." (mapcar (function (lambda (elt) (cperl-tags-treeify elt (1+ level)))) (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)) + ;; 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))))) - root-functions) + (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))))) - root-packages) - ;;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)) + (if (default-value 'imenu-sort-function) + (nreverse + (sort root-packages (default-value 'imenu-sort-function))) + root-packages)) )) ;;;(x-popup-menu t @@ -5136,7 +5327,7 @@ prototype \&SUB Returns prototype of the function given a reference. (defun cperl-beautify-regexp-piece (b e embed) ;; b is before the starting delimiter, e before the ending ;; e should be a marker, may be changed, but remains "correct". - (let (s c tmp (m (make-marker)) (m1 (make-marker)) c1 spaces inline) + (let (s c tmp (m (make-marker)) (m1 (make-marker)) c1 spaces inline code) (if (not embed) (goto-char (1+ b)) (goto-char b) @@ -5150,7 +5341,7 @@ prototype \&SUB Returns prototype of the function given a reference. (forward-char 2)) (t (forward-char 1)))) - (setq c (1- (current-column)) + (setq c (if embed (current-indentation) (1- (current-column))) c1 (+ c (or cperl-regexp-indent-step cperl-indent-level))) (or (looking-at "[ \t]*[\n#]") (progn @@ -5175,18 +5366,18 @@ prototype \&SUB Returns prototype of the function given a reference. (while (and inline (looking-at - (concat "\\([a-zA-Z0-9]+[^*+{?]\\)" ; 1 - "\\|" + (concat "\\([a-zA-Z0-9]+[^*+{?]\\)" ; 1 word + "\\|" ; Embedded variable "\\$\\([a-zA-Z0-9_]+\\([[{]\\)?\\|[^\n \t)|]\\)" ; 2 3 - "\\|" + "\\|" ; $ ^ "[$^]" - "\\|" + "\\|" ; simple-code simple-code*? "\\(\\\\.\\|[^][()#|*+?\n]\\)\\([*+{?]\\??\\)?" ; 4 5 - "\\|" + "\\|" ; Class "\\(\\[\\)" ; 6 - "\\|" + "\\|" ; Grouping "\\((\\(\\?\\)?\\)" ; 7 8 - "\\|" + "\\|" ; | "\\(|\\)" ; 9 ))) (goto-char (match-end 0)) @@ -5223,7 +5414,17 @@ prototype \&SUB Returns prototype of the function given a reference. ;; (error "()-group not terminated"))) (set-marker m (1- (point))) (set-marker m1 (point)) - (cperl-beautify-regexp-piece tmp m t) + (cond + ((not (match-beginning 8)) + (cperl-beautify-regexp-piece tmp m t)) + ((eq (char-after (+ 2 tmp)) ?\{) ; Code + t) + ((eq (char-after (+ 2 tmp)) ?\() ; Conditional + (goto-char (+ 2 tmp)) + (forward-sexp 1) + (cperl-beautify-regexp-piece (point) m t)) + (t + (cperl-beautify-regexp-piece tmp m t))) (goto-char m1) (cond ((looking-at "[*+?]\\??") (goto-char (match-end 0))) @@ -5234,7 +5435,9 @@ prototype \&SUB Returns prototype of the function given a reference. (skip-chars-forward " \t") (setq spaces nil) (if (looking-at "[#\n]") - (beginning-of-line 2) + (progn + (or (eolp) (indent-for-comment)) + (beginning-of-line 2)) (insert "\n")) (end-of-line) (setq inline nil)) @@ -5262,39 +5465,109 @@ prototype \&SUB Returns prototype of the function given a reference. (insert " ")) (skip-chars-forward " \t")) (or (looking-at "[#\n]") - (error "unknown code in a regexp")) + (error "unknown code \"%s\" in a regexp" (buffer-substring (point) + (1+ (point))))) (and inline (end-of-line 2))) + ;; Special-case the last line of group + (if (and (>= (point) (marker-position e)) + (/= (current-indentation) c)) + (progn + (beginning-of-line) + (setq s (point)) + (skip-chars-forward " \t") + (delete-region s (point)) + (indent-to-column c))) )) +(defun cperl-make-regexp-x () + (save-excursion + (or cperl-use-syntax-table-text-property + (error "I need to have regex marked!")) + ;; Find the start + (re-search-backward "\\s|") ; Assume it is scanned already. + ;;(forward-char 1) + (let ((b (point)) (e (make-marker)) have-x delim (c (current-column)) + (sub-p (eq (preceding-char) ?s)) s) + (forward-sexp 1) + (set-marker e (1- (point))) + (setq delim (preceding-char)) + (if (and sub-p (eq delim (char-after (- (point) 2)))) + (error "Possible s/blah// - do not know how to deal with")) + (if sub-p (forward-sexp 1)) + (if (looking-at "\\sw*x") + (setq have-x t) + (insert "x")) + ;; Protect fragile " ", "#" + (if have-x nil + (goto-char (1+ b)) + (while (re-search-forward "\\(\\=\\|[^\\\\]\\)\\(\\\\\\\\\\)*[ \t\n#]" e t) ; Need to include (?#) too? + (forward-char -1) + (insert "\\") + (forward-char 1))) + b))) + (defun cperl-beautify-regexp () - "do it. (Experimental, may change semantics, recheck afterwards.) + "do it. (Experimental, may change semantics, recheck the result.) We suppose that the regexp is scanned already." (interactive) - (or cperl-use-syntax-table-text-property - (error "I need to have regex marked!")) - ;; Find the start + (cperl-make-regexp-x) (re-search-backward "\\s|") ; Assume it is scanned already. ;;(forward-char 1) - (let ((b (point)) (e (make-marker)) have-x delim (c (current-column)) - (sub-p (eq (preceding-char) ?s)) s) + (let ((b (point)) (e (make-marker))) (forward-sexp 1) (set-marker e (1- (point))) - (setq delim (preceding-char)) - (if (and sub-p (eq delim (char-after (- (point) 2)))) - (error "Possible s/blah// - do not know how to deal with")) - (if sub-p (forward-sexp 1)) - (if (looking-at "\\sw*x") - (setq have-x t) - (insert "x")) - ;; Protect fragile " ", "#" - (if have-x nil - (goto-char (1+ b)) - (while (re-search-forward "\\(\\=\\|[^\\\\]\\)\\(\\\\\\\\\\)*[ \t\n#]" e t) ; Need to include (?#) too? - (forward-char -1) - (insert "\\") - (forward-char 1))) (cperl-beautify-regexp-piece b e nil))) +(defun cperl-contract-level () + "Find an enclosing group in regexp and contract it. (Experimental, may change semantics, recheck the result.) Unfinished. +We suppose that the regexp is scanned already." + (interactive) + (let ((bb (cperl-make-regexp-x)) done) + (while (not done) + (or (eq (following-char) ?\() + (search-backward "(" (1+ bb) t) + (error "Cannot find `(' which starts a group")) + (setq done + (save-excursion + (skip-chars-backward "\\") + (looking-at "\\(\\\\\\\\\\)*("))) + (or done (forward-char -1))) + (let ((b (point)) (e (make-marker)) s c) + (forward-sexp 1) + (set-marker e (1- (point))) + (goto-char b) + (while (re-search-forward "\\(#\\)\\|\n" e t) + (cond + ((match-beginning 1) ; #-comment + (or c (setq c (current-indentation))) + (beginning-of-line 2) ; Skip + (setq s (point)) + (skip-chars-forward " \t") + (delete-region s (point)) + (indent-to-column c)) + (t + (delete-char -1) + (just-one-space))))))) + +(defun cperl-beautify-level () + "Find an enclosing group in regexp and beautify it. (Experimental, may change semantics, recheck the result.) +We suppose that the regexp is scanned already." + (interactive) + (let ((bb (cperl-make-regexp-x)) done) + (while (not done) + (or (eq (following-char) ?\() + (search-backward "(" (1+ bb) t) + (error "Cannot find `(' which starts a group")) + (setq done + (save-excursion + (skip-chars-backward "\\") + (looking-at "\\(\\\\\\\\\\)*("))) + (or done (forward-char -1))) + (let ((b (point)) (e (make-marker))) + (forward-sexp 1) + (set-marker e (1- (point))) + (cperl-beautify-regexp-piece b e nil)))) + (if (fboundp 'run-with-idle-timer) (progn (defvar cperl-help-shown nil |