X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=emacs%2Fcperl-mode.el;h=e3dea854e5ce19fac8045b6c1a4ad6fe1c6acadd;hb=97abc6adffcd3efcbaee73cbdad2055b2d06be4f;hp=ba4a863be58a7f73c97121794fa2cf8d8fa6042c;hpb=55497cffdd24c959994f9a8ddd56db8ce85e1c5b;p=p5sagit%2Fp5-mst-13.2.git diff --git a/emacs/cperl-mode.el b/emacs/cperl-mode.el index ba4a863..e3dea85 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.29 1996/11/18 23:10:26 ilya Exp ilya $ +;; $Id: cperl-mode.el,v 1.41 1997/11/17 18:09:39 ilya Exp ilya $ ;;; To use this mode put the following into your .emacs file: @@ -46,14 +46,18 @@ ;;; in your .emacs file. (Emacs rulers do not consider it politically ;;; correct to make whistles enabled by default.) +;;; DO NOT FORGET to read micro-docs. (available from `Perl' menu). <<<<<< +;;; or as help on variables `cperl-tips', `cperl-problems', <<<<<< +;;; `cperl-non-problems', `cperl-praise'. <<<<<< + ;;; 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)))) -;;; The mode information (on C-h m) provides customization help. +;;; The mode information (on C-h m) provides some customization help. ;;; If you use font-lock feature of this mode, it is advisable to use ;;; either lazy-lock-mode or fast-lock-mode (available on ELisp ;;; archive in files lazy-lock.el and fast-lock.el). I prefer lazy-lock. @@ -328,6 +332,161 @@ ;;; Minor updates to `cperl-short-docs'. ;;; Will not consider <<= as start of here-doc. +;;;; After 1.29 +;;; Added an extra advice to look into Micro-docs. ;-). +;;; Enclosing of region when you press a closing parenth is regulated by +;;; `cperl-electric-parens-string'. +;;; Minor updates to `cperl-short-docs'. +;;; `initialize-new-tags-table' called only if present (Does this help +;;; with generation of tags under XEmacs?). +;;; When creating/updating tag files, new info is written at the old place, +;;; or at the end (is this a wanted behaviour? I need this in perl build directory). + +;;;; After 1.30 +;;; All the keywords from keywords.pl included (maybe with dummy explanation). +;;; No auto-help inside strings, comment, here-docs, formats, and pods. +;;; Shrinkwrapping of info, regulated by `cperl-max-help-size', +;;; `cperl-shrink-wrap-info-frame'. +;;; Info on variables as well. +;;; Recognision of HERE-DOCS improved yet more. +;;; Autonewline works on `}' without warnings. +;;; Autohelp works again on $_[0]. + +;;;; After 1.31 +;;; perl-descr.el found its author - hi, Johan! +;;; Some support for correct indent after here-docs and friends (may +;;; be superseeded by eminent change to Emacs internals). +;;; Should work with older Emaxen as well ( `-style stuff removed). + +;;;; After 1.32 + +;;; Started to add support for `syntax-table' property (should work +;;; with patched Emaxen), controlled by +;;; `cperl-use-syntax-table-text-property'. Currently recognized: +;;; All quote-like operators: m, s, y, tr, qq, qw, qx, q, +;;; // in most frequent context: +;;; after block or +;;; ~ { ( = | & + - * ! , ; +;;; or +;;; while if unless until and or not xor split grep map +;;; Here-documents, formats, PODs, +;;; ${...} +;;; 'abc$' +;;; sub a ($); sub a ($) {} +;;; (provide 'cperl-mode) was missing! +;;; `cperl-after-expr-p' is now much smarter after `}'. +;;; `cperl-praise' added to mini-docs. +;;; Utilities try to support subs-with-prototypes. + +;;;; After 1.32.1 +;;; `cperl-after-expr-p' is now much smarter after "() {}" and "word {}": +;;; if word is "else, map, grep". +;;; Updated for new values of syntax-table constants. +;;; Uses `help-char' (at last!) (disabled, does not work?!) +;;; A couple of regexps where missing _ in character classes. +;;; -s could be considered as start of regexp, 1../blah/ was not, +;;; as was not /blah/ at start of file. + +;;;; After 1.32.2 +;;; "\C-hv" was wrongly "\C-hf" +;;; C-hv was not working on `[index()]' because of [] in skip-chars-*. +;;; `__PACKAGE__' supported. +;;; Thanks for Greg Badros: `cperl-lazy-unstall' is more complete, +;;; `cperl-get-help' is made compatible with `query-replace'. + +;;;; As of Apr 15, development version of 19.34 supports +;;;; `syntax-table' text properties. Try setting +;;;; `cperl-use-syntax-table-text-property'. + +;;;; After 1.32.3 +;;; 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-\\). +;;; Start of `cperl-beautify-regexp'. + +;;;; After 1.32.4 +;;; `cperl-tags-hier-init' did not work in text-mode. +;;; `cperl-noscan-files-regexp' had a misprint. +;;; 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/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/foo/, +;;; comments between the first and the second part allowed +;;; Another problem discovered: +;;;;;;; s[foo] 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 + +;;;; After 1.39: +;;; Could indent here-docs for comments; +;;; These problems fixed: +;;;;;;; s/foo/\\bar/ - backslash at start of subst (made into two chunk) +;;;;;;; s[foo] e - "e" part delimited by "different" <> (will match) +;;; Matching brackets honor prefices, may expand abbreviations; +;;; When expanding abbrevs, will remove last char only after +;;; self-inserted whitespace; +;;; More convenient "Refress hard constructs" in menu; +;;; `cperl-add-tags-recurse', `cperl-add-tags-recurse-noxs' +;;; added (for -batch mode); +;;; Better handling of errors when scanning for Perl constructs; +;;;;;;; Possible "problem" with class hierarchy in Perl distribution +;;;;;;; directory: ./ext duplicates ./lib; +;;; Write relative paths for generated TAGS; + +;;;; After 1.40: +;;; s /// may be separated by "\n\f" too; +;;; `s #blah' recognized as a comment; +;;; Would highlight s/abc//s wrong; +;;; Debugging code in `cperl-electric-keywords' was leaking a message; + +(defconst cperl-xemacs-p (string-match "XEmacs\\|Lucid" emacs-version)) + (defvar cperl-extra-newline-before-brace nil "*Non-nil means that if, elsif, while, until, else, for, foreach and do constructs look like: @@ -385,11 +544,12 @@ regardless of where in the line point is when the TAB command is used.") Can be overwritten by `cperl-hairy' if nil.") (defvar cperl-electric-lbrace-space nil - "*Non-nil (and non-null) means { after $ in CPerl buffers should be preceeded by ` '. + "*Non-nil (and non-null) means { after $ in CPerl buffers should be preceded by ` '. Can be overwritten by `cperl-hairy' if nil.") -(defvar cperl-electric-parens-string "({[<" - "*String of parentheses that should be electric in CPerl.") +(defvar cperl-electric-parens-string "({[]})<" + "*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. @@ -403,10 +563,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. @@ -455,10 +611,41 @@ You can always make lookup from menu or using \\[cperl-find-pods-heres].") "*Not-nil means add backreferences to generated `imenu's. May require patched `imenu' and `imenu-go'.") +(defvar cperl-max-help-size 66 + "*Non-nil means shrink-wrapping of info-buffer allowed up to these percents.") + +(defvar cperl-shrink-wrap-info-frame t + "*Non-nil means shrink-wrapping of info-buffer-frame allowed.") + (defvar cperl-info-page "perl" - "Name of the info page containing perl docs. + "*Name of the info page containing perl docs. Older version of this page was called `perl5', newer `perl'.") +(defvar cperl-use-syntax-table-text-property + (boundp 'parse-sexp-lookup-properties) + "*Non-nil means CPerl sets up and uses `syntax-table' text property.") + +(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\\)$" + "*Regexp to match files/dirs to skip when generating TAGS.") + +(defvar cperl-regexp-indent-step nil + "*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. @@ -514,7 +701,8 @@ indentation, electric keywords, electric braces. This may be confusing, since the regexp s#//#/#\; may be highlighted as a comment, but it will be recognized as a regexp by the indentation code. Or the opposite case, when a pod section is highlighted, but -breaks the indentation of the following code. +may break the indentation of the following code (though indentation +should work if the balance of delimiters is not broken by POD). The main trick (to make $ a \"backslash\") makes constructions like ${aaa} look like unbalanced braces. The only trick I can think of is @@ -530,15 +718,15 @@ as /($|\\s)/. Note that such a transposition is not always possible Most the time, if you write your own code, you may find an equivalent \(and almost as readable) expression. -Try to help it: add comments with embedded quotes to fix CPerl +Try to help CPerl: add comments with embedded quotes to fix CPerl misunderstandings about the end of quotation: $a='500$'; # '; You won't need it too often. The reason: $ \"quotes\" the following character (this saves a life a lot of times in CPerl), thus due to -Emacs parsing rules it does not consider tick after the dollar as a -closing one, but as a usual character. +Emacs parsing rules it does not consider tick (i.e., ' ) after a +dollar as a closing one, but as a usual character. Now the indentation code is pretty wise. The only drawback is that it relies on Emacs parsing to find matching parentheses. And Emacs @@ -548,6 +736,10 @@ will not break indentation, but 1 if ( s#//#/# ); will. +By similar reasons + s\"abc\"def\"; +will confuse CPerl a lot. + If you still get wrong indentation in situation that you think the code should be able to parse, try: @@ -569,17 +761,78 @@ Imenu in 19.31 is broken. Set `imenu-use-keymap-menu' to t, and remove `car' before `imenu-choose-buffer-index' in `imenu'. ") +(defvar cperl-praise 'please-ignore-this-line + "RMS asked me to list good things about CPerl. Here they go: + +0) It uses the newest `syntax-table' property ;-); + +1) It does 99% of Perl syntax correct (as opposed to 80-90% in Perl +mode - but the latter number may have improved too in last years) even +without `syntax-table' property; When using this property, it should +handle 99.995% of lines correct - or somesuch. + +2) It is generally belived to be \"the most user-friendly Emacs +package\" whatever it may mean (I doubt that the people who say similar +things tried _all_ the rest of Emacs ;-), but this was not a lonely +voice); + +3) Everything is customizable, one-by-one or in a big sweep; + +4) It has many easily-accessable \"tools\": + a) Can run program, check syntax, start debugger; + b) Can lineup vertically \"middles\" of rows, like `=' in + a = b; + cc = d; + c) Can insert spaces where this impoves readability (in one + interactive sweep over the buffer); + d) Has support for imenu, including: + 1) Separate unordered list of \"interesting places\"; + 2) Separate TOC of POD sections; + 3) Separate list of packages; + 4) Hierarchical view of methods in (sub)packages; + 5) and functions (by the full name - with package); + e) Has an interface to INFO docs for Perl; The interface is + very flexible, including shrink-wrapping of + documentation buffer/frame; + f) Has a builtin list of one-line explanations for perl constructs. + g) Can show these explanations if you stay long enough at the + corresponding place (or on demand); + h) Has an enhanced fontification (using 3 or 4 additional faces + comparing to font-lock - basically, different + namespaces in Perl have different colors); + i) Can construct TAGS basing on its knowledge of Perl syntax, + the standard menu has 6 different way to generate + TAGS (if by directory, .xs files - with C-language + bindings - are included in the scan); + j) Can build a hierarchical view of classes (via imenu) basing + on generated TAGS file; + k) Has electric parentheses, electric newlines, uses Abbrev + for electric logical constructs + while () {} + with different styles of expansion (context sensitive + to be not so bothering). Electric parentheses behave + \"as they should\" in a presence of a visible region. + l) Changes msb.el \"on the fly\" to insert a group \"Perl files\"; + +5) The indentation engine was very smart, but most of tricks may be +not needed anymore with the support for `syntax-table' property. Has +progress indicator for indentation (with `imenu' loaded). + +6) Indent-region improves inline-comments as well; + +7) Fill-paragraph correctly handles multi-line comments; +") + ;;; Portability stuff: -(defconst cperl-xemacs-p (string-match "XEmacs\\|Lucid" emacs-version)) (defmacro cperl-define-key (fsf-key definition &optional xemacs-key) - `(define-key cperl-mode-map - ,(if xemacs-key - `(if cperl-xemacs-p ,xemacs-key ,fsf-key) - fsf-key) - ,definition)) + (` (define-key cperl-mode-map + (, (if xemacs-key + (` (if cperl-xemacs-p (, xemacs-key) (, fsf-key))) + fsf-key)) + (, definition)))) (defvar del-back-ch (car (append (where-is-internal 'delete-backward-char) (where-is-internal 'backward-delete-char-untabify))) @@ -626,11 +879,14 @@ Imenu in 19.31 is broken. Set `imenu-use-keymap-menu' to t, and remove (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))))) @@ -675,15 +931,23 @@ Imenu in 19.31 is broken. Set `imenu-use-keymap-menu' to t, and remove (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 + [(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) (cperl-define-key "\t" 'cperl-indent-command) ;; don't clobber the backspace binding: - (cperl-define-key "\C-hf" 'cperl-info-on-command [(control h) f]) (cperl-define-key "\C-c\C-hf" 'cperl-info-on-current-command [(control c) (control h) f]) - (cperl-define-key "\C-hv" 'cperl-get-help [(control h) v]) + (cperl-define-key "\C-hf" + ;;(concat (char-to-string help-char) "f") ; does not work + 'cperl-info-on-command + [(control h) f]) + (cperl-define-key "\C-hv" + ;;(concat (char-to-string help-char) "v") ; does not work + 'cperl-get-help + [(control h) v]) (if (and cperl-xemacs-p (<= emacs-minor-version 11) (<= emacs-major-version 19)) (progn @@ -704,6 +968,7 @@ Imenu in 19.31 is broken. Set `imenu-use-keymap-menu' to t, and remove 'indent-for-comment 'cperl-indent-for-comment cperl-mode-map global-map))) +(defvar cperl-menu) (condition-case nil (progn (require 'easymenu) @@ -714,7 +979,15 @@ Imenu in 19.31 is broken. Set `imenu-use-keymap-menu' to t, and remove ["Mark function" mark-defun t] ["Indent expression" cperl-indent-exp t] ["Fill paragraph/comment" cperl-fill-paragraph t] + "----" ["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] + ["Refresh \"hard\" constructions" cperl-find-pods-heres t] "----" ["Indent region" cperl-indent-region (cperl-use-region-p)] ["Comment region" cperl-comment-region (cperl-use-region-p)] @@ -754,7 +1027,6 @@ Imenu in 19.31 is broken. Set `imenu-use-keymap-menu' to t, and remove (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] ["Define word at point" imenu-go-find-at-position (fboundp 'imenu-go-find-at-position)] ["Help on function" cperl-info-on-command t] @@ -777,7 +1049,8 @@ Imenu in 19.31 is broken. Set `imenu-use-keymap-menu' to t, and remove ("Micro-docs" ["Tips" (describe-variable 'cperl-tips) t] ["Problems" (describe-variable 'cperl-problems) t] - ["Non-problems" (describe-variable 'cperl-non-problems) t])))) + ["Non-problems" (describe-variable 'cperl-non-problems) t] + ["Praise" (describe-variable 'cperl-praise) t])))) (error nil)) (autoload 'c-macro-expand "cmacexp" @@ -788,6 +1061,9 @@ The expansion is entirely correct because it uses the C preprocessor." (defvar cperl-mode-syntax-table nil "Syntax table in use in Cperl-mode buffers.") +(defvar cperl-string-syntax-table nil + "Syntax table in use in Cperl-mode string-like chunks.") + (if cperl-mode-syntax-table () (setq cperl-mode-syntax-table (make-syntax-table)) @@ -806,9 +1082,14 @@ 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)) + (modify-syntax-entry ?| "." cperl-mode-syntax-table) + (setq cperl-string-syntax-table (copy-syntax-table cperl-mode-syntax-table)) + (modify-syntax-entry ?$ "." cperl-string-syntax-table) + (modify-syntax-entry ?# "." cperl-string-syntax-table) ; (?# comment ) +) @@ -824,6 +1105,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. @@ -905,6 +1189,10 @@ with `cperl-hairy' is 5 secs idle time if the value of this variable is nil. It is also possible to switch this on/off from the menu. Requires `run-with-idle-timer'. +Use \\[cperl-lineup] to vertically lineup some construction - put the +beginning of the region at the start of construction, and make region +span the needed amount of lines. + Variables `cperl-pod-here-scan', `cperl-pod-here-fontify', `cperl-pod-face', `cperl-pod-head-face' control processing of pod and here-docs sections. In a future version results of scan may be used @@ -1010,7 +1298,7 @@ with no args." (make-local-variable 'comment-start-skip) (setq comment-start-skip "#+ *") (make-local-variable 'defun-prompt-regexp) - (setq defun-prompt-regexp "^[ \t]*sub[ \t]+\\([^ \t\n{;]+\\)[ \t]*") + (setq defun-prompt-regexp "^[ \t]*sub[ \t]+\\([^ \t\n{(;]+\\)[ \t]*") (make-local-variable 'comment-indent-function) (setq comment-indent-function 'cperl-comment-indent) (make-local-variable 'parse-sexp-ignore-comments) @@ -1032,6 +1320,11 @@ with no args." '((perl-font-lock-keywords perl-font-lock-keywords-1 perl-font-lock-keywords-2)))) + (if cperl-use-syntax-table-text-property + (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))) (or (fboundp 'cperl-old-auto-fill-mode) (progn (fset 'cperl-old-auto-fill-mode (symbol-function 'auto-fill-mode)) @@ -1068,8 +1361,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 @@ -1194,10 +1485,10 @@ char is \"{\", insert extra newline before only if (if cperl-auto-newline (progn (cperl-indent-line) (newline) t) nil))) (progn - (if cperl-auto-newline - (setq insertpos (point))) - (insert last-command-char) + (self-insert-command (prefix-numeric-value arg)) (cperl-indent-line) + (if cperl-auto-newline + (setq insertpos (1- (point)))) (if (and cperl-auto-newline (null only-before)) (progn (newline) @@ -1233,8 +1524,8 @@ char is \"{\", insert extra newline before only if (save-excursion (skip-chars-backward "$") (looking-at "\\(\\$\\$\\)*\\$\\([^\\$]\\|$\\)")) - (insert ? )) - (if (cperl-after-expr-p nil "{};)") nil (setq cperl-auto-newline nil)) + (insert ?\ )) + (if (cperl-after-expr-p nil "{;)") nil (setq cperl-auto-newline nil)) (cperl-electric-brace arg) (and (cperl-val 'cperl-electric-parens) (eq last-command-char ?{) @@ -1263,18 +1554,22 @@ char is \"{\", insert extra newline before only if (>= (save-excursion (cperl-to-comment-or-eol) (point)) (point)) ;;(not (save-excursion (search-backward "#" beg t))) (if (eq last-command-char ?<) - (cperl-after-expr-p nil "{};(,:=") + (progn + (and abbrev-mode ; later it is too late, may be after `for' + (expand-abbrev)) + (cperl-after-expr-p nil "{;(,:=")) 1)) (progn - (insert last-command-char) + (self-insert-command (prefix-numeric-value arg)) (if other-end (goto-char (marker-position other-end))) - (insert (cdr (assoc last-command-char '((?{ .?}) - (?[ . ?]) - (?( . ?)) - (?< . ?>))))) - (forward-char -1)) - (insert last-command-char) - ))) + (insert (make-string + (prefix-numeric-value arg) + (cdr (assoc last-command-char '((?{ .?}) + (?[ . ?]) + (?( . ?)) + (?< . ?>)))))) + (forward-char (- (prefix-numeric-value arg)))) + (self-insert-command (prefix-numeric-value arg))))) (defun cperl-electric-rparen (arg) "Insert a matching pair of parentheses if marking is active. @@ -1282,6 +1577,9 @@ If not, or if we are not at the end of marking range, would self-insert." (interactive "P") (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 + (append cperl-electric-parens-string nil)) (cperl-mark-active) (< (mark) (point))) (mark) @@ -1294,24 +1592,28 @@ If not, or if we are not at the end of marking range, would self-insert." ;;(not (save-excursion (search-backward "#" beg t))) ) (progn - (insert last-command-char) + (self-insert-command (prefix-numeric-value arg)) (setq p (point)) (if other-end (goto-char other-end)) - (insert (cdr (assoc last-command-char '((?\} . ?\{) + (insert (make-string + (prefix-numeric-value arg) + (cdr (assoc last-command-char '((?\} . ?\{) (?\] . ?\[) (?\) . ?\() - (?\> . ?\<))))) + (?\> . ?\<)))))) (goto-char (1+ p))) - (call-interactively 'self-insert-command) - ))) + (self-insert-command (prefix-numeric-value arg))))) (defun cperl-electric-keyword () "Insert a construction appropriate after a keyword." (let ((beg (save-excursion (beginning-of-line) (point))) - (dollar (eq last-command-char ?$))) + (dollar (and (eq last-command-char ?$) + (eq this-command 'self-insert-command))) + (delete (and (memq last-command-char '(?\ ?\n ?\t ?\f)) + (memq this-command '(self-insert-command newline))))) (and (save-excursion (backward-sexp 1) - (cperl-after-expr-p nil "{};:")) + (cperl-after-expr-p nil "{;:")) (save-excursion (not (re-search-backward @@ -1337,16 +1639,19 @@ If not, or if we are not at the end of marking range, would self-insert." (or (looking-at "[ \t]\\|$") (insert " ")) (cperl-indent-line) (if dollar (progn (search-backward "$") + (delete-char 1) + (forward-char -1) (forward-char 1)) (search-backward ")")) - (cperl-putback-char del-back-ch))))) + (if delete + (cperl-putback-char del-back-ch)))))) (defun cperl-electric-else () "Insert a construction appropriate after a keyword." (let ((beg (save-excursion (beginning-of-line) (point)))) (and (save-excursion (backward-sexp 1) - (cperl-after-expr-p nil "{};:")) + (cperl-after-expr-p nil "{;:")) (save-excursion (not (re-search-backward @@ -1482,7 +1787,7 @@ If not, or if we are not at the end of marking range, would self-insert." (let ((pps (parse-partial-sexp (point) end))) (or (nth 3 pps) (nth 4 pps) (nth 5 pps)))))))) (progn - (insert last-command-char) + (self-insert-command (prefix-numeric-value arg)) ;;(forward-char -1) (if auto (setq insertpos (point-marker))) ;;(forward-char 1) @@ -1577,7 +1882,7 @@ Return the amount the indentation changed by." (setq indent (cperl-calculate-indent nil symbol)) (beginning-of-line) (setq beg (point)) - (cond ((eq indent nil) + (cond ((or (eq indent nil) (eq indent t)) (setq indent (current-indentation))) ;;((eq indent t) ; Never? ;; (setq indent (cperl-calculate-indent-within-comment))) @@ -1586,7 +1891,7 @@ Return the amount the indentation changed by." (t (skip-chars-forward " \t") (if (listp indent) (setq indent (car indent))) - (cond ((looking-at "[A-Za-z]+:[^:]") + (cond ((looking-at "[A-Za-z_][A-Za-z_0-9]*:[^:]") (and (> indent 0) (setq indent (max cperl-min-label-indent (+ indent cperl-label-offset))))) @@ -1666,24 +1971,56 @@ Return the amount the indentation changed by." (progn (backward-sexp) (looking-at - "sub[ \t]+[a-zA-Z0-9_:]+[ \t\n\f]*[#{]"))))))))) + "sub[ \t]+[a-zA-Z0-9_:]+[ \t\n\f]*\\(([^()]*)[ \t\n\f]*\\)?[#{]"))))))))) + +(defvar cperl-look-for-prop '((pod in-pod) (here-doc-delim here-doc-group))) (defun cperl-calculate-indent (&optional parse-start symbol) "Return appropriate indentation for current line as Perl code. In usual case returns an integer: the column to indent to. Returns nil if line starts inside a string, t if in a comment." (save-excursion - (if (memq (get-text-property (point) 'syntax-type) '(pod here-doc)) nil - (beginning-of-line) - (let* ((indent-point (point)) - (case-fold-search nil) + (if (or + (memq (get-text-property (point) 'syntax-type) + '(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!")) + (and (not cperl-indent-left-aligned-comments) + (looking-at "^#"))) + nil + (beginning-of-line) + (let ((indent-point (point)) + (char-after (save-excursion + (skip-chars-forward " \t") + (following-char))) + (in-pod (get-text-property (point) 'in-pod)) + (pre-indent-point (point)) + p prop look-prop) + (cond + (in-pod + ;; In the verbatim part, probably code example. What to do??? + ) + (t + (save-excursion + ;; Not in pod + (cperl-backward-to-noncomment nil) + (setq p (max (point-min) (1- (point))) + prop (get-text-property p 'syntax-type) + look-prop (or (nth 1 (assoc prop cperl-look-for-prop)) + 'syntax-type)) + (if (memq prop '(pod here-doc format here-doc-delim)) + (progn + (goto-char (or (previous-single-property-change p look-prop) + (point-min))) + (beginning-of-line) + (setq pre-indent-point (point))))))) + (goto-char pre-indent-point) + (let* ((case-fold-search nil) (s-s (cperl-get-state)) (start (nth 0 s-s)) (state (nth 1 s-s)) (containing-sexp (car (cdr state))) - (char-after (save-excursion - (skip-chars-forward " \t") - (following-char))) (start-indent (save-excursion (goto-char start) (- (current-indentation) @@ -1781,7 +2118,7 @@ Returns nil if line starts inside a string, t if in a comment." (t ;; Statement level. Is it a continuation or a new statement? ;; Find previous non-comment character. - (goto-char indent-point) + (goto-char pre-indent-point) (cperl-backward-to-noncomment containing-sexp) ;; Back up over label lines, since they don't ;; affect whether our line is a continuation. @@ -1873,7 +2210,7 @@ Returns nil if line starts inside a string, t if in a comment." (skip-chars-backward " \t") (if (and (eq (preceding-char) ?b) (progn - (forward-word -1) + (forward-sexp -1) (looking-at "sub\\>")) (setq old-indent (nth 1 @@ -1887,13 +2224,13 @@ Returns nil if line starts inside a string, t if in a comment." ;; If line starts with label, calculate label indentation (if (save-excursion (beginning-of-line) - (looking-at "[ \t]*[a-zA-Z_][a-zA-Z_]*:[^:]")) + (looking-at "[ \t]*[a-zA-Z_][a-zA-Z_0-9]*:[^:]")) (if (> (current-indentation) cperl-min-label-indent) (- (current-indentation) cperl-label-offset) (cperl-calculate-indent (if (and parse-start (<= parse-start (point))) parse-start))) - (current-indentation))))))))))))) + (current-indentation)))))))))))))) (defvar cperl-indent-alist '((string nil) @@ -2047,7 +2384,7 @@ POS may be nil if it is hard to find, say, when TYPE is `string' or `comment'." ;; If line starts with label, calculate label indentation (if (save-excursion (beginning-of-line) - (looking-at "[ \t]*[a-zA-Z_][a-zA-Z_]*:[^:]")) + (looking-at "[ \t]*[a-zA-Z_][a-zA-Z_0-9]*:[^:]")) (if (> (current-indentation) cperl-min-label-indent) (- (current-indentation) cperl-label-offset) (cperl-calculate-indent @@ -2077,7 +2414,9 @@ the current line is to be regarded as part of a block comment." Returns true if comment is found." (let (state stop-in cpoint (lim (progn (end-of-line) (point)))) (beginning-of-line) - (if (re-search-forward "\\=[ \t]*\\(#\\|$\\)" lim t) + (if (or + (eq (get-text-property (point) 'syntax-type) 'pod) + (re-search-forward "\\=[ \t]*\\(#\\|$\\)" lim t)) (if (eq (preceding-char) ?\#) (progn (backward-char 1) t)) ;; Else (while (not stop-in) @@ -2119,60 +2458,239 @@ Returns true if comment is found." ) (nth 4 state)))) -(defun cperl-find-pods-heres (&optional min max) - "Scans the buffer for POD sections and here-documents. +(defsubst cperl-1- (p) + (max (point-min) (1- p))) + +(defsubst cperl-1+ (p) + (min (point-max) (1+ p))) + +(defvar cperl-st-cfence '(14)) ; Comment-fence +(defvar cperl-st-sfence '(15)) ; String-fence +(defvar cperl-st-punct '(1)) +(defvar cperl-st-word '(2)) +(defvar cperl-st-bra '(4 . ?\>)) +(defvar cperl-st-ket '(5 . ?\<)) + +(defsubst cperl-modify-syntax-type (at how) + (if (< at (point-max)) + (progn + (put-text-property at (1+ at) 'syntax-table how) + (put-text-property at (1+ at) 'rear-nonsticky t)))) + +(defun cperl-protect-defun-start (s e) + ;; C code looks for "^\\s(" to skip comment backward in "hard" situations + (save-excursion + (goto-char s) + (while (re-search-forward "^\\s(" e 'to-end) + (put-text-property (1- (point)) (point) 'syntax-table cperl-st-punct)))) + +(defun cperl-commentify (bb e string) + (if cperl-use-syntax-table-text-property + (progn + ;; We suppose that e is _after_ the end of construction, as after eol. + (setq string (if string cperl-st-sfence cperl-st-cfence)) + (cperl-modify-syntax-type bb string) + (cperl-modify-syntax-type (1- e) string) + (if (and (eq string cperl-st-sfence) (> (- e 2) bb)) + (put-text-property (1+ bb) (1- e) + 'syntax-table cperl-string-syntax-table)) + (cperl-protect-defun-start bb e)))) + +(defun cperl-forward-re (lim end is-2arg set-st st-l err-l argument + &optional ostart oend) + ;; 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 go-forward) + (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 + (progn + (or (eq (char-syntax (following-char)) ?.) + ;; Make trailing letter into punctuation + (cperl-modify-syntax-type (point) cperl-st-punct)) + (setq is-2arg nil go-forward t))) ; Ignore the tail + (if is-2arg ; Not number => have second part + (progn + (setq i (point) i2 i) + (if ender + (if (memq (following-char) '(?\ ?\t ?\n ?\f)) + (progn + (if (looking-at "[ \t\n\f]+\\(#[^\n]*\n[ \t\n\f]*\\)+") + (goto-char (match-end 0)) + (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 lim end nil t st-l err-l argument starter ender) + ender (nth 2 ender))))) + (error (goto-char lim) + (setq set-st nil) + (or end + (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 go-forward))) + +(defun cperl-find-pods-heres (&optional min max non-inter end) + "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 - (cperl-pod-here-fontify (eval cperl-pod-here-fontify)) + (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)) go (case-fold-search nil) (inhibit-read-only t) (buffer-undo-list t) (modified (buffer-modified-p)) (after-change-functions nil) + (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\\)=" "\\|" ;; One extra () before this: - "<<\\(\\([\"'`]\\)\\([^\"'`\n]*\\)\\3\\|\\(\\([a-zA-Z_][a-zA-Z_0-9]*\\)?\\)[^=]\\)" ; [^=] to avoid <<=. + "<<" + "\\(" + ;; First variant "BLAH" or just ``. + "\\([\"'`]\\)" + "\\([^\"'`\n]*\\)" + "\\3" + "\\|" + ;; Second variant: Identifier or empty + "\\(\\([a-zA-Z_][a-zA-Z_0-9]*\\)?\\)" + ;; Check that we do not have <<= or << 30 or << $blah. + "\\([^= \t$@%&]\\|[ \t]+[^ \t\n0-9$@%&]\\)" + "\\)" "\\|" - ;; 1+5 extra () before this: - "^[ \t]*format[ \t]*\\([a-zA-Z0-9_]+\\)?[ \t]*=[ \t]*$"))) + ;; 1+6 extra () before this: + "^[ \t]*\\(format\\)[ \t]*\\([a-zA-Z0-9_]+\\)?[ \t]*=[ \t]*$" + (if cperl-use-syntax-table-text-property + (concat + "\\|" + ;; 1+6+2=9 extra () before this: + "\\<\\(q[wxq]?\\|[msy]\\|tr\\)\\>" + "\\|" + ;; 1+6+2+1=10 extra () before this: + "\\([?/]\\)" ; /blah/ or ?blah? + "\\|" + ;; 1+6+2+1+1=11 extra () before this: + "\\[ \t]*\\([a-zA-Z_:'0-9]+[ \t]*\\)?\\(([^()]*)\\)" + "\\|" + ;; 1+6+2+1+1+2=13 extra () before this: + "\\$\\(['{]\\)" + "\\|" + ;; 1+6+2+1+1+2+1=14 extra () before this: + "\\(\\") (progn - (message "=cut is not preceeded by a pod section") - (setq err (point))) + (message "=cut is not preceded by a POD section") + (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) - (message "Cannot find the end of a pod section")) - (beginning-of-line 3) + (progn + (message "End of a POD section not marked by =cut") + (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) (goto-char b) (while (re-search-forward "\n\n[ \t]" e t) + ;; We start 'pod 1 char earlier to include the preceding line (beginning-of-line) - (put-text-property b (point) 'syntax-type 'pod) + (put-text-property (cperl-1- b) (point) 'syntax-type 'pod) (cperl-put-do-not-fontify b (point)) ;;(put-text-property (max (point-min) (1- b)) ;; (point) cperl-do-not-fontify t) @@ -2180,7 +2698,7 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', (re-search-forward "\n\n[^ \t\f\n]" e 'toend) (beginning-of-line) (setq b (point))) - (put-text-property (point) e 'syntax-type 'pod) + (put-text-property (cperl-1- (point)) e 'syntax-type 'pod) (cperl-put-do-not-fontify (point) e) ;;(put-text-property (max (point-min) (1- (point))) ;; e cperl-do-not-fontify t) @@ -2188,28 +2706,35 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', (progn (put-text-property (point) e 'face face) (goto-char bb) (if (looking-at - "=[a-zA-Z0-9]+\\>[ \t]*\\(\\(\n?[^\n]\\)+\\)$") + "=[a-zA-Z0-9_]+\\>[ \t]*\\(\\(\n?[^\n]\\)+\\)$") (put-text-property (match-beginning 1) (match-end 1) 'face head-face)) (while (re-search-forward ;; One paragraph - "\n\n=[a-zA-Z0-9]+\\>[ \t]*\\(\\(\n?[^\n]\\)+\\)$" + "\n\n=[a-zA-Z0-9_]+\\>[ \t]*\\(\\(\n?[^\n]\\)+\\)$" e 'toend) (put-text-property (match-beginning 1) (match-end 1) 'face head-face)))) - (goto-char e))) + (cperl-commentify bb e nil) + (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 ;; "<<\\(\\([\"'`]\\)\\([^\"'`\n]*\\)\\3\\|\\(\\([a-zA-Z_][a-zA-Z_0-9]*\\)?\\)\\)" ((match-beginning 2) ; 1 + 1 - ;; Abort in comment (_extremely_ simplified): + ;; Abort in comment: (setq b (point)) - (if (save-excursion - (beginning-of-line) - (search-forward "#" b t)) - nil + (setq state (parse-partial-sexp state-point b nil nil state) + state-point b) + (if ;;(save-excursion + ;; (beginning-of-line) + ;; (search-forward "#" b t)) + (or (nth 3 state) (nth 4 state)) + (goto-char (match-end 2)) (if (match-beginning 5) ;4 + 1 (setq b1 (match-beginning 5) ; 4 + 1 e1 (match-end 5)) ; 4 + 1 @@ -2234,18 +2759,25 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', ;; cperl-do-not-fontify t) (put-text-property b (match-beginning 0) 'face here-face))) + (setq e1 (cperl-1+ (match-end 0))) (put-text-property b (match-beginning 0) 'syntax-type 'here-doc) - (cperl-put-do-not-fontify b (match-beginning 0))) - (t (message "End of here-document `%s' not found." tag))))) + (put-text-property (match-beginning 0) e1 + 'syntax-type 'here-doc-delim) + (put-text-property b e1 + 'here-doc-group t) + (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 (car err-l) (setcar err-l b)))))) ;; format - (t - ;; 1+5=6 extra () before this: - ;; "^[ \t]*format[ \t]*\\([a-zA-Z0-9_]+\\)?[ \t]*=[ \t]*$"))) + ((match-beginning 8) + ;; 1+6=7 extra () before this: + ;;"^[ \t]*\\(format\\)[ \t]*\\([a-zA-Z0-9_]+\\)?[ \t]*=[ \t]*$" (setq b (point) - name (if (match-beginning 7) ; 6 + 1 - (buffer-substring (match-beginning 7) ; 6 + 1 - (match-end 7)) ; 6 + 1 + name (if (match-beginning 8) ; 7 + 1 + (buffer-substring (match-beginning 8) ; 7 + 1 + (match-end 8)) ; 7 + 1 "")) (setq argument nil) (if cperl-pod-here-fontify @@ -2265,6 +2797,7 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', (end-of-line) (put-text-property b1 (point) 'face font-lock-string-face) + (cperl-commentify b1 (point) nil) (cperl-put-do-not-fontify b1 (point))))) (re-search-forward (concat "^[.;]$") max 'toend)) (beginning-of-line) @@ -2272,8 +2805,10 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', (progn (put-text-property (point) (+ (point) 2) 'face font-lock-string-face) + (cperl-commentify (point) (+ (point) 2) nil) (cperl-put-do-not-fontify (point) (+ (point) 2))) - (message "End of format `%s' not found." name)) + (message "End of format `%s' not found." name) + (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) @@ -2286,11 +2821,179 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', ;;; 'syntax-type 'format) ;;; (cperl-put-do-not-fontify b (match-beginning 0))) ;;; (t (message "End of format `%s' not found." name))) - ))) + ) + ;; Regexp: + ((or (match-beginning 10) (match-beginning 11)) + ;; 1+6+2=9 extra () before this: + ;; "\\<\\(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 (char-after (1- (match-beginning b1))) ; tmp holder + bb (and ; user variables/whatever + (match-beginning 10) + (or + (memq bb '(?\$ ?\@ ?\% ?\* ?\#)) ; $#y + (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 ; Not a regexp? + (progn + (goto-char (match-beginning b1)) + (cperl-backward-to-noncomment (point-min)) + (not + ;; What is below: regexp-p? + (and + (or (memq (preceding-char) + (append (if (eq c ?\?) + ;; $a++ ? 1 : 2 + "~{(=|&*!,;" + "~{(=|&+-*!,;") nil)) + (and (eq (preceding-char) ?\}) + (cperl-after-block-p (point-min))) + (and (eq (char-syntax (preceding-char)) ?w) + (progn + (forward-sexp -1) + (looking-at + "\\(while\\|if\\|unless\\|until\\|and\\|or\\|not\\|xor\\|split\\|grep\\|map\\|print\\)\\>"))) + (and (eq (preceding-char) ?.) + (eq (char-after (- (point) 2)) ?.)) + (bobp)) + ;; m|blah| ? foo : bar; + (not + (and (eq c ?\?) + cperl-use-syntax-table-text-property + (not (bobp)) + (progn + (forward-char -1) + (looking-at "\\s|"))))))) + b (1- b)))) + (or bb (setq state (parse-partial-sexp + state-point b nil nil state) + state-point b)) + (goto-char b) + (if (or bb (nth 3 state) (nth 4 state)) + (goto-char i) + (if (looking-at "[ \t\n\f]+\\(#[^\n]*\n[ \t\n\f]*\\)+") + (goto-char (match-end 0)) + (skip-chars-forward " \t\n\f")) + ;; 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 max end + (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 + go (nth 4 i) ; There is a 1-char part after the end + i (car i) ; intermediate point + tail (if (and i (not e1)) (1- (point))) + e nil) ; need to preserve backslashitis + ;; Commenting \\ is dangerous, what about ( ? + (and i tail + (eq (char-after i) ?\\) + (setq e t)) + (if (null i) + (progn + (cperl-commentify b (point) t) + (if go (forward-char 1))) + (cperl-commentify b i t) + (if (looking-at "\\sw*e") ; s///e + (progn + (and + ;; silent: + (cperl-find-pods-heres i2 (1- (point)) t end) + ;; Error + (goto-char (1+ max))) + (if (and e1 (eq (preceding-char) ?\>)) + (progn + (cperl-modify-syntax-type (1- (point)) cperl-st-ket) + (cperl-modify-syntax-type i cperl-st-bra)))) + (cperl-commentify i2 (point) t) + (if e + (cperl-modify-syntax-type (1+ i) cperl-st-punct)) + (setq tail nil))) + (if (eq (char-syntax (following-char)) ?w) + (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)) + '(?\$ ?\@ ?\% ?\& ?\*)) + nil + (setq state (parse-partial-sexp + state-point (1- b) nil nil state) + state-point (1- b)) + (if (or (nth 3 state) (nth 4 state)) + nil + ;; 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)) + state (parse-partial-sexp + state-point (1- b) nil nil state) + state-point (1- b)) + (if (nth 3 state) ; in string + (cperl-modify-syntax-type (1- b) cperl-st-punct)) + (goto-char (1+ b))) + ;; 1+6+2+1+1+2=13 extra () before this: + ;; "\\$\\(['{]\\)" + ((match-beginning 14) ; ${ + (setq bb (match-beginning 0)) + (cperl-modify-syntax-type bb cperl-st-punct)) + ;; 1+6+2+1+1+2+1=14 extra () before this: + ;; "\\(\\ (point) max) + (progn + (if end + (message "Garbage after __END__/__DATA__ ignored") + (message "Unbalanced syntax found while scanning") + (or (car err-l) (setcar err-l b))) + (goto-char max)))) ;;; (while (re-search-forward "\\(\\`\n?\\|\n\n\\)=" max t) ;;; (if (looking-at "\n*cut\\>") ;;; (progn -;;; (message "=cut is not preceeded by a pod section") +;;; (message "=cut is not preceded by a pod section") ;;; (setq err (point))) ;;; (beginning-of-line) @@ -2381,12 +3084,15 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', ;;; 'syntax-type 'format) ;;; (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)) + (or noninteractive + (message "Scan for \"hard\" Perl constructions completed.")))) (and (buffer-modified-p) (not modified) - (set-buffer-modified-p nil))))) + (set-buffer-modified-p nil)) + (set-syntax-table cperl-mode-syntax-table)) + (car err-l))) (defun cperl-backward-to-noncomment (lim) ;; Stops at lim or after non-whitespace that is not in comment @@ -2395,20 +3101,38 @@ 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))))) +(defun cperl-after-block-p (lim) + ;; We suppose that the preceding char is }. + (save-excursion + (condition-case nil + (progn + (forward-sexp -1) + (cperl-backward-to-noncomment lim) + (or (eq (preceding-char) ?\) ) ; if () {} + (and (eq (char-syntax (preceding-char)) ?w) ; else {} + (progn + (forward-sexp -1) + (looking-at "\\(else\\|grep\\|map\\)\\>"))) + (cperl-after-expr-p lim))) + (error nil)))) + (defun cperl-after-expr-p (&optional lim chars test) "Returns true if the position is good for start of expression. TEST is the expression to evaluate at the found position. If absent, -CHARS is a string that contains good characters to have before us." - (let (stop p) +CHARS is a string that contains good characters to have before us (however, +`}' is treated \"smartly\" if it is not in the list)." + (let (stop p + (lim (or lim (point-min)))) (save-excursion - (while (and (not stop) (> (point) (or lim 1))) + (while (and (not stop) (> (point) lim)) (skip-chars-backward " \t\n\f" lim) (setq p (point)) (beginning-of-line) @@ -2420,9 +3144,10 @@ CHARS is a string that contains good characters to have before us." (setq stop t))) (or (bobp) (progn - (backward-char 1) (if test (eval test) - (memq (following-char) (append (or chars "{};") nil)))))))) + (or (memq (preceding-char) (append (or chars "{;") nil)) + (and (eq (preceding-char) ?\}) + (cperl-after-block-p lim))))))))) (defun cperl-backward-to-start-of-continued-exp (lim) (if (memq (preceding-char) (append ")]}\"'`" nil)) @@ -2444,8 +3169,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) @@ -2490,15 +3215,20 @@ inclusive." comment-column)) (setq old-comm-indent nil))) (if (and old-comm-indent - (= (current-indentation) old-comm-indent)) + (= (current-indentation) old-comm-indent) + (not (eq (get-text-property (point) 'syntax-type) 'pod))) (let ((comment-column new-comm-indent)) (indent-for-comment))) (progn (cperl-indent-line 'indent-info) (or comm (progn - (if (setq old-comm-indent (and (cperl-to-comment-or-eol) - (current-column))) + (if (setq old-comm-indent + (and (cperl-to-comment-or-eol) + (not (memq (get-text-property (point) + 'syntax-type) + '(pod here-doc))) + (current-column))) (progn (indent-for-comment) (skip-chars-backward " \t") (skip-chars-backward "#") @@ -2508,16 +3238,16 @@ inclusive." (imenu-progress-message pm 100) (message nil))))) -(defun cperl-slash-is-regexp (&optional pos) - (save-excursion - (goto-char (if pos pos (1- (point)))) - (and - (not (memq (get-text-property (point) 'face) - '(font-lock-string-face font-lock-comment-face))) - (cperl-after-expr-p nil nil ' - (or (looking-at "[^]a-zA-Z0-9_)}]") - (eq (get-text-property (point) 'face) - 'font-lock-keyword-face)))))) +;;(defun cperl-slash-is-regexp (&optional pos) +;; (save-excursion +;; (goto-char (if pos pos (1- (point)))) +;; (and +;; (not (memq (get-text-property (point) 'face) +;; '(font-lock-string-face font-lock-comment-face))) +;; (cperl-after-expr-p nil nil ' +;; (or (looking-at "[^]a-zA-Z0-9_)}]") +;; (eq (get-text-property (point) 'face) +;; 'font-lock-keyword-face)))))) ;; Stolen from lisp-mode with a lot of improvements @@ -2629,7 +3359,12 @@ indentation and initial hashes. Behaves usually outside of comment." (or (memq (preceding-char) '(?\ ?\t)) (insert " ")))))) (defvar imenu-example--function-name-regexp-perl - "^\\([ \t]*\\(sub\\|package\\)[ \t\n]+\\([a-zA-Z_0-9:']+\\)[ \t]*\\|=head\\([12]\\)[ \t]+\\([^\n]+\\)$\\)") + (concat + "^\\(" + "[ \t]*\\(sub\\|package\\)[ \t\n]+\\([a-zA-Z_0-9:']+\\)[ \t]*\\(([^()]*)[ \t]*\\)?" + "\\|" + "=head\\([12]\\)[ \t]+\\([^\n]+\\)$" + "\\)")) (defun cperl-imenu-addback (lst &optional isback name) ;; We suppose that the lst is a DAG, unless the first element only @@ -2653,28 +3388,46 @@ 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 packages ends-ranges p (prev-pos 0) char fchar index index1 name (end-range 0) package) (goto-char (point-min)) - (imenu-progress-message prev-pos 0) + (if noninteractive + (message "Scanning Perl for index") + (imenu-progress-message prev-pos 0)) ;; Search for the function (progn ;;save-match-data (while (re-search-forward (or regexp imenu-example--function-name-regexp-perl) nil t) - (imenu-progress-message prev-pos) + (or noninteractive + (imenu-progress-message prev-pos)) ;;(backward-up-list 1) (cond - ((match-beginning 2) ; package or sub + ((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 :-(): + (null (get-text-property (match-beginning 1) 'syntax-table)) + (null (get-text-property (match-beginning 1) 'syntax-type)) + (null (get-text-property (match-beginning 1) 'in-pod))) (save-excursion (goto-char (match-beginning 2)) (setq fchar (following-char)) ) - (setq char (following-char) meth nil) - (setq p (point)) + ;; (if (looking-at "([^()]*)[ \t\n\f]*") + ;; (goto-char (match-end 0))) ; Messes what follows + (setq char (following-char) + meth nil + p (point)) (while (and ends-ranges (>= p (car ends-ranges))) ;; delete obsolete entries (setq ends-ranges (cdr ends-ranges) packages (cdr packages))) @@ -2710,18 +3463,19 @@ indentation and initial hashes. Behaves usually outside of comment." (push index index-alist)) (if meth (push index index-meth-alist)) (push index index-unsorted-alist))) - (t ; Pod section + ((match-beginning 5) ; Pod section ;; (beginning-of-line) (setq index (imenu-example--name-and-position) - name (buffer-substring (match-beginning 5) (match-end 5))) + name (buffer-substring (match-beginning 6) (match-end 6))) (set-text-properties 0 (length name) nil name) - (if (eq (char-after (match-beginning 4)) ?2) + (if (eq (char-after (match-beginning 5)) ?2) (setq name (concat " " name))) (setcar index name) (setq index1 (cons (concat "=" name) (cdr index))) (push index index-pod-alist) (push index1 index-unsorted-alist))))) - (imenu-progress-message prev-pos 100) + (or noninteractive + (imenu-progress-message prev-pos 100)) (setq index-alist (if (default-value 'imenu-sort-function) (sort index-alist (default-value 'imenu-sort-function)) @@ -2904,7 +3658,7 @@ indentation and initial hashes. Behaves usually outside of comment." "ell\\(\\|dir\\)\\|ime\\(\\|s\\)\\)\\|u\\(c\\(\\|first\\)\\|" "time\\|mask\\|n\\(pack\\|link\\)\\)\\|v\\(alues\\|ec\\)\\|" "w\\(a\\(rn\\|it\\(pid\\|\\)\\|ntarray\\)\\|rite\\)\\|" - "x\\(\\|or\\)\\|__\\(FILE__\\|LINE__\\)" + "x\\(\\|or\\)\\|__\\(FILE__\\|LINE__\\|PACKAGE__\\)" "\\)\\>") 2 'font-lock-type-face) ;; In what follows we use `other' style ;; for nonoverwritable builtins @@ -2938,7 +3692,7 @@ indentation and initial hashes. Behaves usually outside of comment." ;; "\\|") '("-[rwxoRWXOezsfdlpSbctugkTBMAC]\\>\\([ \t]+_\\>\\)?" 0 font-lock-function-name-face keep) ; Not very good, triggers at "[a-z]" - '("\\ height max-height) (setq height max-height)) + ;;(message "was %s doing %s" iniheight height) + (if not-loner + (enlarge-window (- height iniheight)) + (set-frame-height (window-frame win) (1+ height))))) (set-window-start (selected-window) pos)) (message "No entry for %s found." command)) - (pop-to-buffer buffer))) + ;;(pop-to-buffer buffer) + (select-window iniwin))) (defun cperl-info-on-current-command () "Shows documentation for Perl command at point in other window." @@ -3358,7 +4181,7 @@ Available styles are GNU, K&R, BSD and Whitesmith." (defun cperl-imenu-info-imenu-search () (if (looking-at "^-X[ \t\n]") nil (re-search-backward - "^\n\\([-a-zA-Z]+\\)[ \t\n]") + "^\n\\([-a-zA-Z_]+\\)[ \t\n]") (forward-line 1))) (defun cperl-imenu-info-imenu-name () @@ -3373,7 +4196,7 @@ Available styles are GNU, K&R, BSD and Whitesmith." imenu-extract-index-name-function (index-item (save-restriction (save-window-excursion - (set-buffer (cperl-info-buffer)) + (set-buffer (cperl-info-buffer nil)) (setq imenu-create-index-function 'imenu-default-create-index-function imenu-prev-index-position-function @@ -3458,7 +4281,7 @@ If optional argument ALL is `recursive', will process Perl files in subdirectories too." (interactive) (let ((cmd "etags") - (args '("-l" "none" "-r" "/\\<\\(package\\|sub\\)[ \\t]+\\(\\([a-zA-Z0-9:_]*::\\)?\\([a-zA-Z0-9_]+\\)[ \\t]*\\([{#]\\|$\\)\\)/\\4/")) + (args '("-l" "none" "-r" "/\\<\\(package\\|sub\\)[ \\t]+\\(\\([a-zA-Z0-9:_]*::\\)?\\([a-zA-Z0-9_]+\\)[ \\t]*\\(([^()]*)[ \t]*\\)?\\([{#]\\|$\\)\\)/\\4/")) res) (if add (setq args (cons "-a" args))) (or files (setq files (list buffer-file-name))) @@ -3466,7 +4289,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;" @@ -3515,7 +4338,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) @@ -3523,13 +4351,16 @@ in subdirectories too." (let ((index-alist '()) (prev-pos 0) index index1 name package prefix) (goto-char (point-min)) - (imenu-progress-message prev-pos 0) + (if noninteractive + (message "Scanning XSUB for index") + (imenu-progress-message prev-pos 0)) ;; Search for the function (progn ;;save-match-data (while (re-search-forward "^\\([ \t]*MODULE\\>[^\n]*\\\\|\\([a-zA-Z_][a-zA-Z_0-9]*\\)(\\|[ \t]*BOOT:\\)" nil t) - (imenu-progress-message prev-pos) + (or noninteractive + (imenu-progress-message prev-pos)) (cond ((match-beginning 2) ; SECTION (setq package (buffer-substring (match-beginning 2) (match-end 2))) @@ -3557,21 +4388,28 @@ in subdirectories too." (setq index (imenu-example--name-and-position)) (setcar index (concat package "::BOOT:")) (push index index-alist))))) - (imenu-progress-message prev-pos 100) + (or noninteractive + (imenu-progress-message prev-pos 100)) ;;(setq index-alist ;; (if (default-value 'imenu-sort-function) ;; (sort index-alist (default-value 'imenu-sort-function)) ;; (nreverse index-alist))) index-alist)) -(defun cperl-find-tags (file xs) - (let (ind (b (get-buffer cperl-tmp-buffer)) lst elt pos ret) +(defun cperl-find-tags (file xs topdir) + (let (ind (b (get-buffer cperl-tmp-buffer)) lst elt pos ret rel + (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) + (message "Scanning file %s ..." file) + (if (and cperl-use-syntax-table-text-property-for-tags + (not xs)) + (condition-case err ; after __END__ may have garbage + (cperl-find-pods-heres) + (error (message "While scanning for syntax: %s" err)))) (if xs (setq lst (cperl-xsub-scan)) (setq ind (imenu-example--create-perl-index)) @@ -3619,19 +4457,43 @@ in subdirectories too." lst)))))) (setq pos (point)) (goto-char 1) - (insert "\f\n" file "," (number-to-string (1- pos)) "\n") + (setq rel file) + ;; On case-preserving filesystems (EMX on OS/2) case might be encoded in properties + (set-text-properties 0 (length rel) nil rel) + (and (equal topdir (substring rel 0 (length topdir))) + (setq rel (substring file (length topdir)))) + (insert "\f\n" rel "," (number-to-string (1- pos)) "\n") (setq ret (buffer-substring 1 (point-max))) (erase-buffer) - (message "Scanning file %s finished" file) + (or noninteractive + (message "Scanning file %s finished" file)) ret))) -(defun cperl-write-tags (&optional file erase recurse dir inbuffer) +(defun cperl-add-tags-recurse-noxs () + "Add to TAGS data for Perl and XSUB files in the current directory and kids. +Use as + emacs -batch -q -no-site-file -l emacs/cperl-mode.el \ + -f cperl-add-tags-recurse +" + (cperl-write-tags nil nil t t nil t)) + +(defun cperl-add-tags-recurse () + "Add to TAGS file data for Perl files in the current directory and kids. +Use as + emacs -batch -q -no-site-file -l emacs/cperl-mode.el \ + -f cperl-add-tags-recurse +" + (cperl-write-tags nil nil t t)) + +(defun cperl-write-tags (&optional file erase recurse dir inbuffer noxs topdir) ;; If INBUFFER, do not select buffer, and do not save ;; If ERASE is `ignore', do not erase, and do not try to delete old info. (require 'etags) (if file nil (setq file (if dir default-directory (buffer-file-name))) (if (and (not dir) (buffer-modified-p)) (error "Save buffer first!"))) + (or topdir + (setq topdir default-directory)) (let ((tags-file-name "TAGS") (case-fold-search (eq system-type 'emx)) xs) @@ -3647,39 +4509,56 @@ in subdirectories too." (erase-buffer) (setq erase 'ignore))) (let ((files - (directory-files file t (if recurse nil "\\.[Pp][Llm]$") t))) + (directory-files file t + (if recurse nil cperl-scan-files-regexp) + t))) (mapcar (function (lambda (file) (cond - ((string-match "/\\.\\.?$" file) nil) + ((string-match cperl-noscan-files-regexp file) + nil) ((not (file-directory-p file)) - (if (string-match "\\.\\([Pp][Llm]\\|xs\\)$" file) - (cperl-write-tags file erase recurse nil t))) + (if (string-match cperl-scan-files-regexp file) + (cperl-write-tags file erase recurse nil t noxs topdir))) ((not recurse) nil) - (t (cperl-write-tags file erase recurse t t))))) + (t (cperl-write-tags file erase recurse t t noxs topdir))))) files)) ) (t (setq xs (string-match "\\.xs$" file)) - (cond ((eq erase 'ignore) nil) - (erase (erase-buffer)) - (t - (goto-char 1) - (if (search-forward (concat "\f\n" file ",") nil t) - (progn - (search-backward "\f\n") - (delete-region (point) - (progn - (forward-char 1) - (search-forward "\f\n" nil 'toend) - (point))) - (goto-char 1))))) - (insert (cperl-find-tags file xs)))) + (if (not (and xs noxs)) + (progn + (cond ((eq erase 'ignore) (goto-char (point-max))) + (erase (erase-buffer)) + (t + (goto-char 1) + (if (search-forward (concat "\f\n" file ",") nil t) + (progn + (search-backward "\f\n") + (delete-region (point) + (save-excursion + (forward-char 1) + (if (search-forward "\f\n" + nil 'toend) + (- (point) 2) + (point-max))))) + (goto-char (point-max))))) + (insert (cperl-find-tags file xs topdir)))))) (if inbuffer nil ; Delegate to the caller (save-buffer 0) ; No backup - (initialize-new-tags-table))))) + (if (fboundp 'initialize-new-tags-table) ; Do we need something special in XEmacs? + (initialize-new-tags-table)))))) (defvar cperl-tags-hier-regexp-list - "^\\(\\(package\\)\\>\\|sub\\>[^\n]+::\\|[a-zA-Z_][a-zA-Z_0-9:]*(\C-?[^\n]+::\\|[ \t]*BOOT:\C-?[^\n]+::\\)") + (concat + "^\\(" + "\\(package\\)\\>" + "\\|" + "sub\\>[^\n]+::" + "\\|" + "[a-zA-Z_][a-zA-Z_0-9:]*(\C-?[^\n]+::" ; XSUB? + "\\|" + "[ \t]*BOOT:\C-?[^\n]+::" ; BOOT section + "\\)")) (defvar cperl-hierarchy '(() ()) "Global hierarchy of classes") @@ -3692,7 +4571,14 @@ in subdirectories too." (setq pos (match-beginning 0) pack (match-beginning 2)) (beginning-of-line) - (if (looking-at "\\([^\n]+\\)\C-?\\([^\n]+\\)\C-a\\([0-9]+\\),\\([0-9]+\\)") + (if (looking-at (concat + "\\([^\n]+\\)" + "\C-?" + "\\([^\n]+\\)" + "\C-a" + "\\([0-9]+\\)" + "," + "\\([0-9]+\\)")) (progn (setq ;;str (buffer-substring (match-beginning 1) (match-end 1)) name (buffer-substring (match-beginning 2) (match-end 2)) @@ -3760,7 +4646,7 @@ One may build such TAGS files from CPerl mode menu." (if window-system (x-popup-menu t (nth 2 cperl-hierarchy)) (require 'tmm) - (tmm-prompt t (nth 2 cperl-hierarchy)))) + (tmm-prompt (nth 2 cperl-hierarchy)))) (if (and update (listp update)) (progn (while (cdr update) (setq update (cdr update))) (setq update (car update)))) ; Get the last from the list @@ -3771,7 +4657,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]+") @@ -3812,23 +4698,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 @@ -3870,7 +4766,7 @@ One may build such TAGS files from CPerl mode menu." (cons (car elt) (cperl-menu-to-keymap list)))) (t - (list (cdr elt) (car elt)))))) + (list (cdr elt) (car elt) t))))) ; t is needed in 19.34 (cperl-list-fold menu "Root" imenu-max-items))))) @@ -3885,8 +4781,8 @@ One may build such TAGS files from CPerl mode menu." (defvar cperl-not-bad-style-regexp (mapconcat 'identity '("[^-\t <>=+]\\(--\\|\\+\\+\\)" ; var-- var++ - "[a-zA-Z0-9][|&][a-zA-Z0-9$]" ; abc|def abc&def are often used. - "&[(a-zA-Z0-9$]" ; &subroutine &(var->field) + "[a-zA-Z0-9_][|&][a-zA-Z0-9_$]" ; abc|def abc&def are often used. + "&[(a-zA-Z0-9_$]" ; &subroutine &(var->field) "<\\$?\\sw+\\(\\.\\sw+\\)?>" ; "-[a-zA-Z][ \t]+[_$\"'`]" ; -f file "-[0-9]" ; -5 @@ -3899,7 +4795,7 @@ One may build such TAGS files from CPerl mode menu." "||" "&&" "[CBIXSLFZ]<\\(\\sw\\|\\s \\|\\s_\\|[\n]\\)*>" ; C - "-[a-zA-Z0-9]+[ \t]*=>" ; -option => value + "-[a-zA-Z_0-9]+[ \t]*=>" ; -option => value ;; Unaddressed trouble spots: = -abc, f(56, -abc) --- specialcased below ;;"[*/+-|&<.]+=" ) @@ -3971,11 +4867,12 @@ Currently it is tuned to C and Perl syntax." ;;(concat "\\(" (mapconcat 'identity - '("[$@%*&][0-9a-zA-Z_:]+" ; Usual variable + '("[$@%*&][0-9a-zA-Z_:]+\\([ \t]*[[{]\\)?" ; Usual variable "[$@]\\^[a-zA-Z]" ; Special variable "[$@][^ \n\t]" ; Special variable "-[a-zA-Z]" ; File test "\\\\[a-zA-Z0]" ; Special chars + "^=[a-z][a-zA-Z0-9_]*" ; Pod sections "[-!&*+,-./<=>?\\\\^|~]+" ; Operator "[a-zA-Z_0-9:]+" ; symbol or number "x=" @@ -3989,63 +4886,79 @@ Currently it is tuned to C and Perl syntax." "Matches places in the buffer we can find help for.") (defvar cperl-message-on-help-error t) +(defvar cperl-help-from-timer nil) + +(defun cperl-word-at-point-hard () + ;; Does not save-excursion + ;; Get to the something meaningful + (or (eobp) (eolp) (forward-char 1)) + (re-search-backward "[-a-zA-Z0-9_:!&*+,-./<=>?\\\\^|~$%@]" + (save-excursion (beginning-of-line) (point)) + 'to-beg) + ;; (cond + ;; ((or (eobp) (looking-at "[][ \t\n{}();,]")) ; Not at a symbol + ;; (skip-chars-backward " \n\t\r({[]});,") + ;; (or (bobp) (backward-char 1)))) + ;; Try to backtrace + (cond + ((looking-at "[a-zA-Z0-9_:]") ; symbol + (skip-chars-backward "a-zA-Z0-9_:") + (cond + ((and (eq (preceding-char) ?^) ; $^I + (eq (char-after (- (point) 2)) ?\$)) + (forward-char -2)) + ((memq (preceding-char) (append "*$@%&\\" nil)) ; *glob + (forward-char -1)) + ((and (eq (preceding-char) ?\=) + (eq (current-column) 1)) + (forward-char -1))) ; =head1 + (if (and (eq (preceding-char) ?\<) + (looking-at "\\$?[a-zA-Z0-9_:]+>")) ; + (forward-char -1))) + ((and (looking-at "=") (eq (preceding-char) ?x)) ; x= + (forward-char -1)) + ((and (looking-at "\\^") (eq (preceding-char) ?\$)) ; $^I + (forward-char -1)) + ((looking-at "[-!&*+,-./<=>?\\\\^|~]") + (skip-chars-backward "-!&*+,-./<=>?\\\\^|~") + (cond + ((and (eq (preceding-char) ?\$) + (not (eq (char-after (- (point) 2)) ?\$))) ; $- + (forward-char -1)) + ((and (eq (following-char) ?\>) + (string-match "[a-zA-Z0-9_]" (char-to-string (preceding-char))) + (save-excursion + (forward-sexp -1) + (and (eq (preceding-char) ?\<) + (looking-at "\\$?[a-zA-Z0-9_:]+>")))) ; + (search-backward "<")))) + ((and (eq (following-char) ?\$) + (eq (preceding-char) ?\<) + (looking-at "\\$?[a-zA-Z0-9_:]+>")) ; <$fh> + (forward-char -1))) + (if (looking-at cperl-have-help-regexp) + (buffer-substring (match-beginning 0) (match-end 0)))) (defun cperl-get-help () "Get one-line docs on the symbol at the point. The data for these docs is a little bit obsolete and may be in fact longer than a line. Your contribution to update/shorten it is appreciated." (interactive) - (save-excursion - ;; Get to the something meaningful - (or (eobp) (eolp) (forward-char 1)) - (re-search-backward "[-a-zA-Z0-9_:!&*+,-./<=>?\\\\^|~$%@]" - (save-excursion (beginning-of-line) (point)) - 'to-beg) - ;; (cond - ;; ((or (eobp) (looking-at "[][ \t\n{}();,]")) ; Not at a symbol - ;; (skip-chars-backward " \n\t\r({[]});,") - ;; (or (bobp) (backward-char 1)))) - ;; Try to backtrace - (cond - ((looking-at "[a-zA-Z0-9_:]") ; symbol - (skip-chars-backward "[a-zA-Z0-9_:]") - (cond - ((and (eq (preceding-char) ?^) ; $^I - (eq (char-after (- (point) 2)) ?\$)) - (forward-char -2)) - ((memq (preceding-char) (append "*$@%&\\" nil)) ; *glob - (forward-char -1))) - (if (and (eq (preceding-char) ?\<) - (looking-at "\\$?[a-zA-Z0-9_:]+>")) ; - (forward-char -1))) - ((and (looking-at "=") (eq (preceding-char) ?x)) ; x= - (forward-char -1)) - ((and (looking-at "\\^") (eq (preceding-char) ?\$)) ; $^I - (forward-char -1)) - ((looking-at "[-!&*+,-./<=>?\\\\^|~]") - (skip-chars-backward "[-!&*+,-./<=>?\\\\^|~]") - (cond - ((and (eq (preceding-char) ?\$) - (not (eq (char-after (- (point) 2)) ?\$))) ; $- - (forward-char -1)) - ((and (eq (following-char) ?\>) - (string-match "[a-zA-Z0-9_]" (char-to-string (preceding-char))) - (save-excursion - (forward-sexp -1) - (and (eq (preceding-char) ?\<) - (looking-at "\\$?[a-zA-Z0-9_:]+>")))) ; - (search-backward "<")))) - ((and (eq (following-char) ?\$) - (eq (preceding-char) ?\<) - (looking-at "\\$?[a-zA-Z0-9_:]+>")) ; <$fh> - (forward-char -1))) - ;;(or (eobp) (forward-char 1)) - (if (looking-at cperl-have-help-regexp) - (cperl-describe-perl-symbol - (buffer-substring (match-beginning 0) (match-end 0))) - (if cperl-message-on-help-error - (message "Nothing found for %s..." - (buffer-substring (point) (+ 5 (point)))))))) + (save-match-data ; May be called "inside" query-replace + (save-excursion + (let ((word (cperl-word-at-point-hard))) + (if word + (if (and cperl-help-from-timer ; Bail out if not in mainland + (not (string-match "^#!\\|\\\\\\|^=" word)) ; Show help even in comments/strings. + (or (memq (get-text-property (point) 'face) + '(font-lock-comment-face font-lock-string-face)) + (memq (get-text-property (point) 'syntax-type) + '(pod here-doc format)))) + nil + (cperl-describe-perl-symbol word)) + (if cperl-message-on-help-error + (message "Nothing found for %s..." + (buffer-substring (point) (min (+ 5 (point)) (point-max)))))))))) ;;; Stolen from perl-descr.el by Johan Vromans: @@ -4054,46 +4967,27 @@ than a line. Your contribution to update/shorten it is appreciated." (defun cperl-describe-perl-symbol (val) "Display the documentation of symbol at point, a Perl operator." - ;; We suppose that the current position is at the start of the symbol - ;; when we convert $_[5] to @_ - (let (;;(fn (perl-symbol-at-point)) - (enable-recursive-minibuffers t) - ;;val + (let ((enable-recursive-minibuffers t) args-file regexp) - ;; (interactive - ;; (let ((fn (perl-symbol-at-point)) - ;; (enable-recursive-minibuffers t) - ;; val args-file regexp) - ;; (setq val (read-from-minibuffer - ;; (if fn - ;; (format "Symbol (default %s): " fn) - ;; "Symbol: "))) - ;; (if (string= val "") - ;; (setq val fn)) (cond ((string-match "^[&*][a-zA-Z_]" val) (setq val (concat (substring val 0 1) "NAME"))) - ((looking-at "[$@][a-zA-Z_:0-9]+\\([[{]\\)") - (if (= ?\[ (char-after (match-beginning 1))) - (setq val (concat "@" (substring val 1))) - (setq val (concat "%" (substring val 1))))) - ((and (string= val "x") (looking-at "x=")) + ((string-match "^[$@]\\([a-zA-Z_:0-9]+\\)[ \t]*\\[" val) + (setq val (concat "@" (substring val 1 (match-end 1))))) + ((string-match "^[$@]\\([a-zA-Z_:0-9]+\\)[ \t]*{" val) + (setq val (concat "%" (substring val 1 (match-end 1))))) + ((and (string= val "x") (string-match "^x=" val)) (setq val "x=")) ((string-match "^\\$[\C-a-\C-z]" val) (setq val (concat "$^" (char-to-string (+ ?A -1 (aref val 1)))))) - ((and (string= "<" val) (looking-at "<\\$?[a-zA-Z0-9_:]+>")) + ((string-match "^CORE::" val) + (setq val "CORE::")) + ((string-match "^SUPER::" val) + (setq val "SUPER::")) + ((and (string= "<" val) (string-match "^<\\$?[a-zA-Z0-9_:]+>" val)) (setq val ""))) -;;; (if (string-match "^[&*][a-zA-Z_]" val) -;;; (setq val (concat (substring val 0 1) "NAME")) -;;; (if (looking-at "[$@][a-zA-Z_:0-9]+\\([[{]\\)") -;;; (if (= ?\[ (char-after (match-beginning 1))) -;;; (setq val (concat "@" (substring val 1))) -;;; (setq val (concat "%" (substring val 1)))) -;;; (if (and (string= val "x") (looking-at "x=")) -;;; (setq val "x=") -;;; (if (looking-at "[$@][a-zA-Z_:0-9]") -;;; )))) - (setq regexp (concat "^" "\\([^a-zA-Z0-9_:]+[ \t]\\)?" + (setq regexp (concat "^" + "\\([^a-zA-Z0-9_:]+[ \t]+\\)?" (regexp-quote val) "\\([ \t([/]\\|$\\)")) @@ -4114,14 +5008,15 @@ than a line. Your contribution to update/shorten it is appreciated." (message "No definition for %s" val))))))) (defvar cperl-short-docs "Ignore my value" + ;; Perl4 version was written by Johan Vromans (jvromans@squirrel.nl) "# based on '@(#)@ perl-descr.el 1.9 - describe-perl-symbol' [Perl 5] -! Logical negation. -!= Numeric inequality. -!~ Search pattern, substitution, or translation (negated). +! ... Logical negation. +... != ... Numeric inequality. +... !~ ... Search pattern, substitution, or translation (negated). $! In numeric context: errno. In a string context: error string. $\" The separator which joins elements of arrays interpolated in strings. -$# The output format for printed numbers. Initial value is %.20g. -$$ The process number of the perl running this script. Altered (in the child process) by fork(). +$# The output format for printed numbers. Initial value is %.15g or close. +$$ Process number of this script. Changes in the fork()ed child process. $% The current page number of the currently selected output channel. The following variables are always local to the current block: @@ -4147,9 +5042,9 @@ $, The output field separator for the print operator. $- The number of lines left on the page. $. The current input line number of the last filehandle that was read. $/ The input record separator, newline by default. -$0 The name of the file containing the perl script being executed. May be set -$: The set of characters after which a string may be broken to fill continuation fields (starting with ^) in a format. -$; The subscript separator for multi-dimensional array emulation. Default is \"\\034\". +$0 Name of the file containing the perl script being executed. May be set. +$: String may be broken after these characters to fill ^-lines in a format. +$; Subscript separator for multi-dim array emulation. Default \"\\034\". $< The real uid of this process. $= The page length of the current output channel. Default is 60 lines. $> The effective uid of this process. @@ -4173,28 +5068,28 @@ $^T The time the script was started. Used by -A/-M/-C file tests. $^W True if warnings are requested (perl -w flag). $^X The name under which perl was invoked (argv[0] in C-speech). $_ The default input and pattern-searching space. -$| Flag for auto-flush after write/print on the currently selected output channel. Default is 0. +$| Auto-flush after write/print on the current output channel? Default 0. $~ The name of the current report format. -% Modulo division. -%= Modulo division assignment. +... % ... Modulo division. +... %= ... Modulo division assignment. %ENV Contains the current environment. %INC List of files that have been require-d or do-ne. %SIG Used to set signal handlers for various signals. -& Bitwise and. -&& Logical and. -&&= Logical and assignment. -&= Bitwise and assignment. -* Multiplication. -** Exponentiation. -*NAME Refers to all objects represented by NAME. *NAM1 = *NAM2 makes NAM1 a reference to NAM2. +... & ... Bitwise and. +... && ... Logical and. +... &&= ... Logical and assignment. +... &= ... Bitwise and assignment. +... * ... Multiplication. +... ** ... Exponentiation. +*NAME Glob: all objects refered by NAME. *NAM1 = *NAM2 aliases NAM1 to NAM2. &NAME(arg0, ...) Subroutine call. Arguments go to @_. -+ Addition. -++ Auto-increment (magical on strings). -+= Addition assignment. +... + ... Addition. +EXPR Makes EXPR into scalar context. +++ Auto-increment (magical on strings). ++EXPR EXPR++ +... += ... Addition assignment. , Comma operator. -- Subtraction. --- Auto-decrement. --= Subtraction assignment. +... - ... Subtraction. +-- Auto-decrement (NOT magical on strings). --EXPR EXPR-- +... -= ... Subtraction assignment. -A Access time in days since script started. -B File is a non-text (binary) file. -C Inode change time in days since script started. @@ -4225,54 +5120,55 @@ $~ The name of the current report format. . Concatenate strings. .. Alternation, also range operator. .= Concatenate assignment strings -/ Division. /PATTERN/ioxsmg Pattern match -/= Division assignment. +... / ... Division. /PATTERN/ioxsmg Pattern match +... /= ... Division assignment. /PATTERN/ioxsmg Pattern match. -< Numeric less than. Glob. See , <> as well. +... < ... Numeric less than. Glob. See , <> as well. Reads line from filehandle NAME. NAME must be bareword/dollar-bareword. Glob. (Unless pattern is bareword/dollar-bareword - see ) <> Reads line from union of files in @ARGV (= command line) and STDIN. -<< Bitwise shift left. << start of HERE-DOCUMENT. -<= Numeric less than or equal to. -<=> Numeric compare. -= Assignment. -== Numeric equality. -=~ Search pattern, substitution, or translation -> Numeric greater than. ->= Numeric greater than or equal to. ->> Bitwise shift right. ->>= Bitwise shift right assignment. -? : Alternation (if-then-else) operator. ?PAT? Backwards pattern match. -?PATTERN? Backwards pattern match. +... << ... Bitwise shift left. << start of HERE-DOCUMENT. +... <= ... Numeric less than or equal to. +... <=> ... Numeric compare. +... = ... Assignment. +... == ... Numeric equality. +... =~ ... Search pattern, substitution, or translation +... > ... Numeric greater than. +... >= ... Numeric greater than or equal to. +... >> ... Bitwise shift right. +... >>= ... Bitwise shift right assignment. +... ? ... : ... Condition=if-then-else operator. ?PAT? One-time pattern match. +?PATTERN? One-time pattern match. @ARGV Command line arguments (not including the command name - see $0). @INC List of places to look for perl scripts during do/include/use. @_ Parameter array for subroutines. Also used by split unless in array context. -\\ Creates a reference to whatever follows, like \$var. +\\ Creates reference to what follows, like \$var, or quotes non-\w in strings. \\0 Octal char, e.g. \\033. \\E Case modification terminator. See \\Q, \\L, and \\U. -\\L Lowercase until \\E . -\\U Upcase until \\E . -\\Q Quote metacharacters until \\E . +\\L Lowercase until \\E . See also \l, lc. +\\U Upcase until \\E . See also \u, uc. +\\Q Quote metacharacters until \\E . See also quotemeta. \\a Alarm character (octal 007). \\b Backspace character (octal 010). \\c Control character, e.g. \\c[ . \\e Escape character (octal 033). \\f Formfeed character (octal 014). -\\l Lowercase of next character. See also \\L and \\u, -\\n Newline character (octal 012). -\\r Return character (octal 015). +\\l Lowercase the next character. See also \\L and \\u, lcfirst. +\\n Newline character (octal 012 on most systems). +\\r Return character (octal 015 on most systems). \\t Tab character (octal 011). -\\u Upcase of next character. See also \\U and \\l, +\\u Upcase the next character. See also \\U and \\l, ucfirst. \\x Hex character, e.g. \\x1b. -^ Bitwise exclusive or. -__END__ End of program source. -__DATA__ End of program source. +... ^ ... Bitwise exclusive or. +__END__ Ends program source. +__DATA__ Ends program source. __FILE__ Current (source) filename. __LINE__ Current line in current source. +__PACKAGE__ Current package. ARGV Default multi-file input filehandle. is a synonym for <>. ARGVOUT Output filehandle with -i flag. -BEGIN { block } Immediately executed (during compilation) piece of code. -END { block } Pseudo-subroutine executed after the script finishes. +BEGIN { ... } Immediately executed (during compilation) piece of code. +END { ... } Pseudo-subroutine executed after the script finishes. DATA Input filehandle for what follows after __END__ or __DATA__. accept(NEWSOCKET,GENERICSOCKET) alarm(SECONDS) @@ -4287,20 +5183,20 @@ chown(LIST) chroot(FILENAME) close(FILEHANDLE) closedir(DIRHANDLE) -cmp String compare. +... cmp ... String compare. connect(SOCKET,NAME) continue of { block } continue { block }. Is executed after `next' or at end. cos(EXPR) crypt(PLAINTEXT,SALT) -dbmclose(ASSOC_ARRAY) -dbmopen(ASSOC,DBNAME,MODE) +dbmclose(%HASH) +dbmopen(%HASH,DBNAME,MODE) defined(EXPR) -delete($ASSOC{KEY}) +delete($HASH{KEY}) die(LIST) do { ... }|SUBR while|until EXPR executes at least once -do(EXPR|SUBR([LIST])) +do(EXPR|SUBR([LIST])) (with while|until executes at least once) dump LABEL -each(ASSOC_ARRAY) +each(%HASH) endgrent endhostent endnetent @@ -4308,7 +5204,7 @@ endprotoent endpwent endservent eof[([FILEHANDLE])] -eq String equality. +... eq ... String equality. eval(EXPR) or eval { BLOCK } exec(LIST) exit(EXPR) @@ -4319,7 +5215,7 @@ flock(FILEHANDLE,OPERATION) for (EXPR;EXPR;EXPR) { ... } foreach [VAR] (@ARRAY) { ... } fork -ge String greater than or equal. +... ge ... String greater than or equal. getc[(FILEHANDLE)] getgrent getgrgid(GID) @@ -4349,17 +5245,17 @@ getsockopt(SOCKET,LEVEL,OPTNAME) gmtime(EXPR) goto LABEL grep(EXPR,LIST) -gt String greater than. +... gt ... String greater than. hex(EXPR) if (EXPR) { ... } [ elsif (EXPR) { ... } ... ] [ else { ... } ] or EXPR if EXPR index(STR,SUBSTR[,OFFSET]) int(EXPR) ioctl(FILEHANDLE,FUNCTION,SCALAR) join(EXPR,LIST) -keys(ASSOC_ARRAY) +keys(%HASH) kill(LIST) last [LABEL] -le String less than or equal. +... le ... String less than or equal. length(EXPR) link(OLDFILE,NEWFILE) listen(SOCKET,QUEUESIZE) @@ -4367,7 +5263,7 @@ local(LIST) localtime(EXPR) log(EXPR) lstat(EXPR|FILEHANDLE|VAR) -lt String less than. +... lt ... String less than. m/PATTERN/iogsmx mkdir(FILENAME,MODE) msgctl(ID,CMD,ARG) @@ -4375,15 +5271,15 @@ msgget(KEY,FLAGS) msgrcv(ID,VAR,SIZE,TYPE.FLAGS) msgsnd(ID,MSG,FLAGS) my VAR or my (VAR1,...) Introduces a lexical variable ($VAR, @ARR, or %HASH). -ne String inequality. +... ne ... String inequality. next [LABEL] oct(EXPR) open(FILEHANDLE[,EXPR]) opendir(DIRHANDLE,EXPR) -ord(EXPR) +ord(EXPR) ASCII value of the first char of the string. pack(TEMPLATE,LIST) -package Introduces package context. -pipe(READHANDLE,WRITEHANDLE) +package NAME Introduces package context. +pipe(READHANDLE,WRITEHANDLE) Create a pair of filehandles on ends of a pipe. pop(ARRAY) print [FILEHANDLE] [(LIST)] printf [FILEHANDLE] (FORMAT,LIST) @@ -4441,7 +5337,7 @@ sqrt(EXPR) srand(EXPR) stat(EXPR|FILEHANDLE|VAR) study[(SCALAR)] -sub [NAME [(format)]] { BODY } or sub [NAME [(format)]]; +sub [NAME [(format)]] { BODY } sub NAME [(format)]; sub [(format)] {...} substr(EXPR,OFFSET[,LEN]) symlink(OLDFILE,NEWFILE) syscall(LIST) @@ -4460,23 +5356,73 @@ unless (EXPR) { ... } [ else { ... } ] or EXPR unless EXPR unlink(LIST) unpack(TEMPLATE,EXPR) unshift(ARRAY,LIST) -until (EXPR) { ... } or EXPR until EXPR +until (EXPR) { ... } EXPR until EXPR utime(LIST) -values(ASSOC_ARRAY) +values(%HASH) vec(EXPR,OFFSET,BITS) wait waitpid(PID,FLAGS) -wantarray +wantarray Returns true if the sub/eval is called in list context. warn(LIST) -while (EXPR) { ... } or EXPR while EXPR +while (EXPR) { ... } EXPR while EXPR write[(EXPR|FILEHANDLE)] -x Repeat string or array. -x= Repetition assignment. +... x ... Repeat string or array. +x= ... Repetition assignment. y/SEARCHLIST/REPLACEMENTLIST/ -| Bitwise or. -|| Logical or. -~ Unary bitwise complement. +... | ... Bitwise or. +... || ... Logical or. +~ ... Unary bitwise complement. #! OS interpreter indicator. If contains `perl', used for options, and -x. +AUTOLOAD {...} Shorthand for `sub AUTOLOAD {...}'. +CORE:: Prefix to access builtin function if imported sub obscures it. +SUPER:: Prefix to lookup for a method in @ISA classes. +DESTROY Shorthand for `sub DESTROY {...}'. +... EQ ... Obsolete synonym of `eq'. +... GE ... Obsolete synonym of `ge'. +... GT ... Obsolete synonym of `gt'. +... LE ... Obsolete synonym of `le'. +... LT ... Obsolete synonym of `lt'. +... NE ... Obsolete synonym of `ne'. +abs [ EXPR ] absolute value +... and ... Low-precedence synonym for &&. +bless REFERENCE [, PACKAGE] Makes reference into an object of a package. +chomp [LIST] Strips $/ off LIST/$_. Returns count. Special if $/ eq ''! +chr Converts a number to char with the same ordinal. +else Part of if/unless {BLOCK} elsif {BLOCK} else {BLOCK}. +elsif Part of if/unless {BLOCK} elsif {BLOCK} else {BLOCK}. +exists $HASH{KEY} True if the key exists. +format [NAME] = Start of output format. Ended by a single dot (.) on a line. +formline PICTURE, LIST Backdoor into \"format\" processing. +glob EXPR Synonym of . +lc [ EXPR ] Returns lowercased EXPR. +lcfirst [ EXPR ] Returns EXPR with lower-cased first letter. +map EXPR, LIST or map {BLOCK} LIST Applies EXPR/BLOCK to elts of LIST. +no PACKAGE [SYMBOL1, ...] Partial reverse for `use'. Runs `unimport' method. +not ... Low-precedence synonym for ! - negation. +... or ... Low-precedence synonym for ||. +pos STRING Set/Get end-position of the last match over this string, see \\G. +quotemeta [ EXPR ] Quote regexp metacharacters. +qw/WORD1 .../ Synonym of split('', 'WORD1 ...') +readline FH Synonym of . +readpipe CMD Synonym of `CMD`. +ref [ EXPR ] Type of EXPR when dereferenced. +sysopen FH, FILENAME, MODE [, PERM] (MODE is numeric, see Fcntl.) +tie VAR, PACKAGE, LIST Hide an object behind a simple Perl variable. +tied Returns internal object for a tied data. +uc [ EXPR ] Returns upcased EXPR. +ucfirst [ EXPR ] Returns EXPR with upcased first letter. +untie VAR Unlink an object from a simple Perl variable. +use PACKAGE [SYMBOL1, ...] Compile-time `require' with consequent `import'. +... xor ... Low-precedence synonym for exclusive or. +prototype \&SUB Returns prototype of the function given a reference. +=head1 Top-level heading. +=head2 Second-level heading. +=head3 Third-level heading (is there such?). +=over [ NUMBER ] Start list. +=item [ TITLE ] Start new item in the list. +=back End list. +=cut Switch from POD to Perl. +=pod Switch from Perl to POD. ") (defun cperl-switch-to-doc-buffer () @@ -4492,37 +5438,285 @@ y/SEARCHLIST/REPLACEMENTLIST/ 'variable-documentation)) (setq buffer-read-only t))))) +(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 code) + (if (not embed) + (goto-char (1+ b)) + (goto-char b) + (cond ((looking-at "(\\?\\\\#") ; badly commented (?#) + (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))) + (or (looking-at "[ \t]*[\n#]") + (progn + (insert "\n"))) + (goto-char e) + (beginning-of-line) + (if (re-search-forward "[^ \t]" e t) + (progn + (goto-char e) + (insert "\n") + (indent-to-column c) + (set-marker e (point)))) + (goto-char b) + (end-of-line 2) + (while (< (point) (marker-position e)) + (beginning-of-line) + (setq s (point) + inline t) + (skip-chars-forward " \t") + (delete-region s (point)) + (indent-to-column c1) + (while (and + inline + (looking-at + (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)) + (setq spaces t) + (cond ((match-beginning 1) ; Alphanum word + junk + (forward-char -1)) + ((or (match-beginning 3) ; $ab[12] + (and (match-beginning 5) ; X* X+ X{2,3} + (eq (preceding-char) ?\{))) + (forward-char -1) + (forward-sexp 1)) + ((match-beginning 6) ; [] + (setq tmp (point)) + (if (looking-at "\\^?\\]") + (goto-char (match-end 0))) + (or (re-search-forward "\\]\\([*+{?]\\)?" e t) + (progn + (goto-char (1- tmp)) + (error "[]-group not terminated"))) + (if (not (eq (preceding-char) ?\{)) nil + (forward-char -1) + (forward-sexp 1))) + ((match-beginning 7) ; () + (goto-char (match-beginning 0)) + (or (eq (current-column) c1) + (progn + (insert "\n") + (indent-to-column c1))) + (setq tmp (point)) + (forward-sexp 1) + ;; (or (forward-sexp 1) + ;; (progn + ;; (goto-char tmp) + ;; (error "()-group not terminated"))) + (set-marker m (1- (point))) + (set-marker m1 (point)) + (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))) + ((eq (following-char) ?\{) + (forward-sexp 1) + (if (eq (following-char) ?\?) + (forward-char)))) + (skip-chars-forward " \t") + (setq spaces nil) + (if (looking-at "[#\n]") + (progn + (or (eolp) (indent-for-comment)) + (beginning-of-line 2)) + (insert "\n")) + (end-of-line) + (setq inline nil)) + ((match-beginning 9) ; | + (forward-char -1) + (setq tmp (point)) + (beginning-of-line) + (if (re-search-forward "[^ \t]" tmp t) + (progn + (goto-char tmp) + (insert "\n")) + ;; first at line + (delete-region (point) tmp)) + (indent-to-column c) + (forward-char 1) + (skip-chars-forward " \t") + (setq spaces nil) + (if (looking-at "[#\n]") + (beginning-of-line 2) + (insert "\n")) + (end-of-line) + (setq inline nil))) + (or (looking-at "[ \t\n]") + (not spaces) + (insert " ")) + (skip-chars-forward " \t")) + (or (looking-at "[#\n]") + (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 the result.) +We suppose that the regexp is scanned already." + (interactive) + (cperl-make-regexp-x) + (re-search-backward "\\s|") ; Assume it is scanned already. + ;;(forward-char 1) + (let ((b (point)) (e (make-marker))) + (forward-sexp 1) + (set-marker e (1- (point))) + (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 "Non-nil means that the help was already shown now.") - (defvar cperl-help-timer nil - "Non-nil means that the help was already shown now.") + (defvar cperl-lazy-installed nil + "Non-nil means that the lazy-help handlers are installed now.") (defun cperl-lazy-install () (interactive) (make-variable-buffer-local 'cperl-help-shown) - (if (cperl-val cperl-lazy-help-time) + (if (and (cperl-val 'cperl-lazy-help-time) + (not cperl-lazy-installed)) (progn (add-hook 'post-command-hook 'cperl-lazy-hook) - (setq cperl-help-timer - (run-with-idle-timer - (cperl-val cperl-lazy-help-time 1000000 5) - t - 'cperl-get-help-defer))))) + (run-with-idle-timer + (cperl-val 'cperl-lazy-help-time 1000000 5) + t + 'cperl-get-help-defer) + (setq cperl-lazy-installed t)))) (defun cperl-lazy-unstall () (interactive) (remove-hook 'post-command-hook 'cperl-lazy-hook) - (cancel-timer cperl-help-timer)) + (cancel-function-timers 'cperl-get-help-defer) + (setq cperl-lazy-installed nil)) (defun cperl-lazy-hook () (setq cperl-help-shown nil)) (defun cperl-get-help-defer () (if (not (eq major-mode 'perl-mode)) nil - (let ((cperl-message-on-help-error nil)) + (let ((cperl-message-on-help-error nil) (cperl-help-from-timer t)) (cperl-get-help) (setq cperl-help-shown t)))) (cperl-lazy-install))) + +(provide 'cperl-mode)