Mercurial > hg > xemacs-beta
diff lisp/modes/cperl-mode.el @ 4:b82b59fe008d r19-15b3
Import from CVS: tag r19-15b3
| author | cvs |
|---|---|
| date | Mon, 13 Aug 2007 08:46:56 +0200 |
| parents | ac2d302a0011 |
| children | 859a2309aef8 |
line wrap: on
line diff
--- a/lisp/modes/cperl-mode.el Mon Aug 13 08:46:35 2007 +0200 +++ b/lisp/modes/cperl-mode.el Mon Aug 13 08:46:56 2007 +0200 @@ -6,9 +6,12 @@ ;;; Date: 14 Aug 91 15:20:01 GMT ;; Perl code editing commands for Emacs -;; Copyright (C) 1985, 1986, 1987 Free Software Foundation, Inc. - -;; This file is not (yet) part of GNU Emacs. +;; Copyright (C) 1985-1996 Bob Olson, Ilya Zakharevich + +;; This file is not (yet) part of GNU Emacs. It may be distributed +;; either under the same terms as GNU Emacs, or under the same terms +;; as Perl. You should have received a copy of Perl Artistic license +;; along with the Perl distribution. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by @@ -21,15 +24,15 @@ ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to -;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - -;;; Synched up with: Not in FSF. +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + ;;; 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.1.1.2 1996/12/18 03:44:44 steve Exp $ +;; $Id: cperl-mode.el,v 1.1.1.3 1996/12/18 03:53:13 steve Exp $ ;;; To use this mode put the following into your .emacs file: @@ -52,7 +55,7 @@ ;;; The mode information (on C-h m) provides customization help. ;;; If you use font-lock feature of this mode, it is advisable to use -;;; eather lazy-lock-mode or fast-lock-mode (available on ELisp +;;; 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. ;;; Faces used now: three faces for first-class and second-class keywords @@ -62,12 +65,12 @@ ;;; not define them, so you need to define them manually. Maybe you have ;;; an obsolete font-lock from 19.28 or earlier. Upgrade. -;;; If you have grayscale monitor, and do not have the variable +;;; If you have a grayscale monitor, and do not have the variable ;;; font-lock-display-type bound to 'grayscale, insert ;;; (setq font-lock-display-type 'grayscale) -;;; to your .emacs file. +;;; into your .emacs file. ;;;; This mode supports font-lock, imenu and mode-compile. In the ;;;; hairy version font-lock is on, but you should activate imenu @@ -266,7 +269,64 @@ ;;; Auto-newline grants `cperl-extra-newline-before-brace' if "{" is typed ;;; after ")". ;;; {} is recognized as expression after `tr' and friends. -;;; Works with XEmacs again. + +;;;; After 1.22 +;;; Entry Hierarchy added to imenu. Very primitive so far. +;;; One needs newer `imenu-go'.el. A patch to `imenu' is needed as well. +;;; Writes its own TAGS files. +;;; Class viewer based on TAGS files. Does not trace @ISA so far. +;;; 19.31: Problems with scan for PODs corrected. +;;; First POD header correctly fontified. +;;; I needed (setq imenu-use-keymap-menu t) to get good imenu in 19.31. +;;; Apparently it makes a lot of hierarchy code obsolete... + +;;;; After 1.23 +;;; Tags filler now scans *.xs as well. +;;; The info from *.xs scan is used by the hierarchy viewer. +;;; Hierarchy viewer documented. +;;; Bug in 19.31 imenu documented. + +;;;; After 1.24 +;;; New location for info-files mentioned, +;;; Electric-; should work better. +;;; Minor bugs with POD marking. + +;;;; After 1.25 (probably not...) +;;; `cperl-info-page' introduced. +;;; To make `uncomment-region' working, `comment-region' would +;;; not insert extra space. +;;; Here documents delimiters better recognized +;;; (empty one, and non-alphanums in quotes handled). May be wrong with 1<<14? +;;; `cperl-db' added, used in menu. +;;; imenu scan removes text-properties, for better debugging +;;; - but the bug is in 19.31 imenu. +;;; formats highlighted by font-lock and prescan, embedded comments +;;; are not treated. +;;; POD/friends scan merged in one pass. +;;; Syntax class is not used for analyzing the code, only char-syntax +;;; may be checked against _ or'ed with w. +;;; Syntax class of `:' changed to be _. +;;; `cperl-find-bad-style' added. + +;;;; After 1.25 +;;; When search for here-documents, we ignore commented << in simplest cases. +;;; `cperl-get-help' added, available on C-h v and from menu. +;;; Auto-help added. Default with `cperl-hairy', switchable on/off +;;; with startup variable `cperl-lazy-help-time' and from +;;; menu. Requires `run-with-idle-timer'. +;;; Highlighting of @abc{@efg} was wrong - interchanged two regexps. + +;;;; After 1.27 +;;; Indentation: At toplevel after a label - fixed. +;;; 1.27 was put to archives in binary mode ===> DOSish :-( + +;;;; After 1.28 +;;; Thanks to Martin Buchholz <mrb@Eng.Sun.COM>: misprints in +;;; comments and docstrings corrected, XEmacs support cleaned up. +;;; The closing parenths would enclose the region into matching +;;; parens under the same conditions as the opening ones. +;;; Minor updates to `cperl-short-docs'. +;;; Will not consider <<= as start of here-doc. (defvar cperl-extra-newline-before-brace nil "*Non-nil means that if, elsif, while, until, else, for, foreach @@ -334,14 +394,16 @@ (defvar cperl-electric-parens nil "*Non-nil (and non-null) means parentheses should be electric in CPerl. Can be overwritten by `cperl-hairy' if nil.") - -(defvar cperl-electric-parens-mark (and window-system - (or (and ; Emacs - (boundp 'transient-mark-mode) - transient-mark-mode) - (and ; XEmacs - (boundp 'zmacs-regions) - zmacs-regions))) +(defvar cperl-electric-parens-mark + (and window-system + (or (and (boundp 'transient-mark-mode) ; For Emacs + transient-mark-mode) + (and (boundp 'zmacs-regions) ; For XEmacs + zmacs-regions))) + "*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.") @@ -369,6 +431,9 @@ The opposite behaviour is always available if prefixed with C-c. Can be overwritten by `cperl-hairy' if nil.") +(defvar cperl-lazy-help-time nil + "*Not-nil (and non-null) means to show lazy help after given idle time.") + (defvar cperl-pod-face 'font-lock-comment-face "*The result of evaluation of this expression is used for pod highlighting.") @@ -386,6 +451,14 @@ "*Not-nil means look for pod and here-docs sections during startup. You can always make lookup from menu or using \\[cperl-find-pods-heres].") +(defvar cperl-imenu-addback nil + "*Not-nil means add backreferences to generated `imenu's. +May require patched `imenu' and `imenu-go'.") + +(defvar cperl-info-page "perl" + "Name of the info page containing perl docs. +Older version of this page was called `perl5', newer `perl'.") + ;;; Short extra-docs. @@ -396,20 +469,32 @@ and/or ftp://ftp.math.ohio-state.edu/pub/users/ilya/perl -Get support packages font-lock-extra.el, imenu-go.el from the same place. -\(Look for other files there too... ;-) Get a patch for imenu.el in 19.29. -Note that for 19.30 you should use choose-color.el *instead* of -font-lock-extra.el (and you will not get smart highlighting in C :-(). +Get support packages choose-color.el (or font-lock-extra.el before +19.30), imenu-go.el from the same place. \(Look for other files there +too... ;-) Get a patch for imenu.el in 19.29. Note that for 19.30 and +later you should use choose-color.el *instead* of font-lock-extra.el +\(and you will not get smart highlighting in C :-(). Note that to enable Compile choices in the menu you need to install mode-compile.el. Get perl5-info from + $CPAN/doc/manual/info/perl-info.tar.gz +older version was on http://www.metronet.com:70/9/perlinfo/perl5/manual/perl5-info.tar.gz -\(may be quite obsolete, but still useful). - -If you use imenu-go, run imenu on perl5-info buffer (you can do it from -CPerl menu). + +If you use imenu-go, run imenu on perl5-info buffer (you can do it +from CPerl menu). If many files are related, generate TAGS files from +Tools/Tags submenu in CPerl menu. + +If some class structure is too complicated, use Tools/Hierarchy-view +from CPerl menu, or hierarchic view of imenu. The second one uses the +current buffer only, the first one requires generation of TAGS from +CPerl/Tools/Tags menu beforehand. + +Run CPerl/Tools/Insert-spaces-if-needed to fix your lazy typing. + +Switch auto-help on/off with CPerl/Tools/Auto-help. Before reporting (non-)problems look in the problem section on what I know about them.") @@ -421,26 +506,26 @@ `non-problems' section if you want to volunteer. CPerl mode tries to corrects some Emacs misunderstandings, however, -for effeciency reasons the degree of correction is different for +for efficiency reasons the degree of correction is different for different operations. The partially corrected problems are: POD sections, here-documents, regexps. The operations are: highlighting, indentation, electric keywords, electric braces. This may be confusing, since the regexp s#//#/#\; may be highlighted -as a comment, but it will recognized as a regexp by the indentation +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. The main trick (to make $ a \"backslash\") makes constructions like -${aaa} look like unbalanced braces. The only trick I can think out is +${aaa} look like unbalanced braces. The only trick I can think of is to insert it as $ {aaa} (legal in perl5, not in perl4). Similar problems arise in regexps, when /(\\s|$)/ should be rewritten -as /($|\\s)/. Note that such a transpositinon is not always possible +as /($|\\s)/. Note that such a transposition is not always possible :-(. " ) (defvar cperl-non-problems 'please-ignore-this-line -"As you know from `problems' section, Perl syntax too hard for CPerl. +"As you know from `problems' section, Perl syntax is too hard for CPerl. Most the time, if you write your own code, you may find an equivalent \(and almost as readable) expression. @@ -472,20 +557,29 @@ Pods are treated _very_ rudimentally. Here-documents are not treated at all (except highlighting and inhibiting indentation). (This may change some time. RMS approved making syntax lookup recognize text -attributes, but volonteers are needed to change Emacs C code.) +attributes, but volunteers are needed to change Emacs C code.) To speed up coloring the following compromises exist: a) sub in $mypackage::sub may be highlighted. b) -z in [a-z] may be highlighted. c) if your regexp contains a keyword (like \"s\"), it may be highlighted. + + +Imenu in 19.31 is broken. Set `imenu-use-keymap-menu' to t, and remove +`car' before `imenu-choose-buffer-index' in `imenu'. ") ;;; Portability stuff: -(defsubst cperl-xemacs-p () - (string-match "XEmacs\\|Lucid" emacs-version)) +(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)) (defvar del-back-ch (car (append (where-is-internal 'delete-backward-char) (where-is-internal 'backward-delete-char-untabify))) @@ -494,7 +588,7 @@ (and (vectorp del-back-ch) (= (length del-back-ch) 1) (setq del-back-ch (aref del-back-ch 0))) -(if (cperl-xemacs-p) +(if cperl-xemacs-p (progn ;; "Active regions" are on: use region only if active ;; "Active regions" are off: use region unconditionally @@ -506,10 +600,10 @@ (defun cperl-mark-active () mark-active)) (defsubst cperl-enable-font-lock () - (or (cperl-xemacs-p) window-system)) + (or cperl-xemacs-p window-system)) (if (boundp 'unread-command-events) - (if (cperl-xemacs-p) + (if cperl-xemacs-p (defun cperl-putback-char (c) ; XEmacs >= 19.12 (setq unread-command-events (list (character-to-event c)))) (defun cperl-putback-char (c) ; Emacs 19 @@ -528,6 +622,10 @@ 'lazy-lock) "Text property which inhibits refontification.") +(defsubst cperl-put-do-not-fontify (from to) + (put-text-property (max (point-min) (1- from)) + to cperl-do-not-fontify t)) + ;;; Probably it is too late to set these guys already, but it can help later: @@ -562,39 +660,37 @@ (if cperl-mode-map nil (setq cperl-mode-map (make-sparse-keymap)) - (define-key cperl-mode-map "{" 'cperl-electric-lbrace) - (define-key cperl-mode-map "[" 'cperl-electric-paren) - (define-key cperl-mode-map "(" 'cperl-electric-paren) - (define-key cperl-mode-map "<" 'cperl-electric-paren) - (define-key cperl-mode-map "}" 'cperl-electric-brace) - (define-key cperl-mode-map ";" 'cperl-electric-semi) - (define-key cperl-mode-map ":" 'cperl-electric-terminator) - (define-key cperl-mode-map "\C-j" 'newline-and-indent) - (define-key cperl-mode-map "\C-c\C-j" 'cperl-linefeed) - (define-key cperl-mode-map "\C-c\C-a" 'cperl-toggle-auto-newline) - (define-key cperl-mode-map "\C-c\C-k" 'cperl-toggle-abbrev) - (define-key cperl-mode-map "\C-c\C-e" 'cperl-toggle-electric) - (define-key cperl-mode-map "\e\C-q" 'cperl-indent-exp) ; Usually not bound - ;;(define-key cperl-mode-map "\M-q" 'cperl-fill-paragraph) - ;;(define-key cperl-mode-map "\e;" 'cperl-indent-for-comment) - (define-key cperl-mode-map "\177" 'cperl-electric-backspace) - (define-key cperl-mode-map "\t" 'cperl-indent-command) - (if (cperl-xemacs-p) - ;; don't clobber the backspace binding: - (define-key cperl-mode-map [(control h) f] 'cperl-info-on-command) - (define-key cperl-mode-map "\C-hf" 'cperl-info-on-command)) - (if (cperl-xemacs-p) - ;; don't clobber the backspace binding: - (define-key cperl-mode-map [(control c) (control h) f] - 'cperl-info-on-current-command) - (define-key cperl-mode-map "\C-c\C-hf" 'cperl-info-on-current-command)) - (if (and (cperl-xemacs-p) + (cperl-define-key "{" 'cperl-electric-lbrace) + (cperl-define-key "[" 'cperl-electric-paren) + (cperl-define-key "(" 'cperl-electric-paren) + (cperl-define-key "<" 'cperl-electric-paren) + (cperl-define-key "}" 'cperl-electric-brace) + (cperl-define-key "]" 'cperl-electric-rparen) + (cperl-define-key ")" 'cperl-electric-rparen) + (cperl-define-key ";" 'cperl-electric-semi) + (cperl-define-key ":" 'cperl-electric-terminator) + (cperl-define-key "\C-j" 'newline-and-indent) + (cperl-define-key "\C-c\C-j" 'cperl-linefeed) + (cperl-define-key "\C-c\C-a" 'cperl-toggle-auto-newline) + (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 "\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]) + (if (and cperl-xemacs-p (<= emacs-minor-version 11) (<= emacs-major-version 19)) (progn ;; substitute-key-definition is usefulness-deenhanced... - (define-key cperl-mode-map "\M-q" 'cperl-fill-paragraph) - (define-key cperl-mode-map "\e;" 'cperl-indent-for-comment) - (define-key cperl-mode-map "\e\C-\\" 'cperl-indent-region)) + (cperl-define-key "\M-q" 'cperl-fill-paragraph) + (cperl-define-key "\e;" 'cperl-indent-for-comment) + (cperl-define-key "\e\C-\\" 'cperl-indent-region)) (substitute-key-definition 'indent-sexp 'cperl-indent-exp cperl-mode-map global-map) @@ -621,8 +717,8 @@ ["Line up a construction" cperl-lineup (cperl-use-region-p)] "----" ["Indent region" cperl-indent-region (cperl-use-region-p)] - ["Comment region" comment-region (cperl-use-region-p)] - ["Uncomment region" uncomment-region (cperl-use-region-p)] + ["Comment region" cperl-comment-region (cperl-use-region-p)] + ["Uncomment region" cperl-uncomment-region (cperl-use-region-p)] "----" ["Run" mode-compile (fboundp 'mode-compile)] ["Kill" mode-compile-kill (and (fboundp 'mode-compile-kill) @@ -630,25 +726,43 @@ ["Next error" next-error (get-buffer "*compilation*")] ["Check syntax" cperl-check-syntax (fboundp 'mode-compile)] "----" - ["Debugger" perldb t] + ["Debugger" cperl-db t] "----" ("Tools" ["Imenu" imenu (fboundp 'imenu)] + ["Insert spaces if needed" cperl-find-bad-style t] + ["Class Hierarchy from TAGS" cperl-tags-hier-init t] + ;;["Update classes" (cperl-tags-hier-init t) tags-table-list] ["Imenu on info" cperl-imenu-on-info (featurep 'imenu)] ("Tags" - ["Create tags for current file" cperl-etags t] - ["Add tags for current file" (cperl-etags t) t] - ["Create tags for Perl files in directory" (cperl-etags nil t) t] - ["Add tags for Perl files in directory" (cperl-etags t t) t] +;;; ["Create tags for current file" cperl-etags t] +;;; ["Add tags for current file" (cperl-etags t) t] +;;; ["Create tags for Perl files in directory" (cperl-etags nil t) t] +;;; ["Add tags for Perl files in directory" (cperl-etags t t) t] +;;; ["Create tags for Perl files in (sub)directories" +;;; (cperl-etags nil 'recursive) t] +;;; ["Add tags for Perl files in (sub)directories" +;;; (cperl-etags t 'recursive) t]) +;;;; cperl-write-tags (&optional file erase recurse dir inbuffer) + ["Create tags for current file" (cperl-write-tags nil t) t] + ["Add tags for current file" (cperl-write-tags) t] + ["Create tags for Perl files in directory" + (cperl-write-tags nil t nil t) t] + ["Add tags for Perl files in directory" + (cperl-write-tags nil nil nil t) t] ["Create tags for Perl files in (sub)directories" - (cperl-etags nil 'recursive) t] + (cperl-write-tags nil t t t) t] ["Add tags for Perl files in (sub)directories" - (cperl-etags t 'recursive) t]) - ["Recalculate PODs" cperl-find-pods-heres t] + (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] - ["Help on function at point" cperl-info-on-current-command t]) + ["Help on function at point" cperl-info-on-current-command t] + ["Help on symbol at point" cperl-get-help t] + ["Auto-help on" cperl-lazy-install (fboundp 'run-with-idle-timer)] + ["Auto-help off" cperl-lazy-unstall + (fboundp 'run-with-idle-timer)]) ("Toggle..." ["Auto newline" cperl-toggle-auto-newline t] ["Electric parens" cperl-toggle-electric t] @@ -693,6 +807,7 @@ (modify-syntax-entry ?' "\"" cperl-mode-syntax-table) (modify-syntax-entry ?` "\"" cperl-mode-syntax-table) (modify-syntax-entry ?_ "w" cperl-mode-syntax-table) + (modify-syntax-entry ?: "_" cperl-mode-syntax-table) (modify-syntax-entry ?| "." cperl-mode-syntax-table)) @@ -749,13 +864,13 @@ it will not do any expansion. See also help on variable `cperl-extra-newline-before-brace'. -\\[cperl-linefeed] is a convinience replacement for typing carriage +\\[cperl-linefeed] is a convenience replacement for typing carriage return. It places you in the next line with proper indentation, or if you type it inside the inline block of control construct, like foreach (@lines) {print; print} and you are on a boundary of a statement inside braces, it will transform the construct into a multiline and will place you into an -apporpriately indented blank line. If you need a usual +appropriately indented blank line. If you need a usual `newline-and-indent' behaviour, it is on \\[newline-and-indent], see documentation on `cperl-electric-linefeed'. @@ -781,6 +896,15 @@ `cperl-info-on-command', which one is which is controlled by variable `cperl-info-on-command-no-prompt' (in turn affected by `cperl-hairy'). +Even if you have no info-format documentation, short one-liner-style +help is available on \\[cperl-get-help]. + +It is possible to show this help automatically after some idle +time. This is regulated by variable `cperl-lazy-help-time'. Default +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'. + 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 @@ -845,15 +969,10 @@ (local-set-key "\C-C\C-J" 'newline-and-indent))) (if (cperl-val 'cperl-info-on-command-no-prompt) (progn - (if (cperl-xemacs-p) - ;; don't clobber the backspace binding: - (local-set-key [(control h) f] 'cperl-info-on-current-command) - (local-set-key "\C-hf" 'cperl-info-on-current-command)) - (if (cperl-xemacs-p) - ;; don't clobber the backspace binding: - (local-set-key [(control c) (control h) f] - 'cperl-info-on-command) - (local-set-key "\C-c\C-hf" 'cperl-info-on-command)))) + ;; don't clobber the backspace binding: + (cperl-define-key "\C-hf" 'cperl-info-on-current-command [(control h) f]) + (cperl-define-key "\C-c\C-hf" 'cperl-info-on-command + [(control c) (control h) f]))) (setq major-mode 'perl-mode) (setq mode-name "CPerl") (if (not cperl-mode-abbrev-table) @@ -891,7 +1010,7 @@ (make-local-variable 'comment-start-skip) (setq comment-start-skip "#+ *") (make-local-variable 'defun-prompt-regexp) - (setq defun-prompt-regexp "^[ \t]*sub\\s +\\([^ \t\n{;]+\\)\\s *") + (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) @@ -928,10 +1047,27 @@ (and (boundp 'msb-menu-cond) (not cperl-msb-fixed) (cperl-msb-fix)) + (if (featurep 'easymenu) + (easy-menu-add cperl-menu)) ; A NOP under FSF Emacs. (run-hooks 'cperl-mode-hook) ;; After hooks since fontification will break this (if cperl-pod-here-scan (cperl-find-pods-heres))) +;; Fix for perldb - make default reasonable +(defun cperl-db () + (interactive) + (require 'gud) + (perldb (read-from-minibuffer "Run perldb (like this): " + (if (consp gud-perldb-history) + (car gud-perldb-history) + (concat "perl " ;;(file-name-nondirectory + ;; I have problems + ;; in OS/2 + ;; otherwise + (buffer-file-name))) + nil nil + '(gud-perldb-history . 1)))) + ;; Fix for msb.el (defvar cperl-msb-fixed nil) @@ -993,7 +1129,7 @@ ;;; (setq prevc (current-column))))))) (defun cperl-indent-for-comment () - "Substite for `indent-for-comment' in CPerl." + "Substitute for `indent-for-comment' in CPerl." (interactive) (let (cperl-wrong-comment) (indent-for-comment) @@ -1001,6 +1137,22 @@ (progn (cperl-to-comment-or-eol) (forward-char (length comment-start)))))) +(defun cperl-comment-region (b e arg) + "Comment or uncomment each line in the region in CPerl mode. +See `comment-region'." + (interactive "r\np") + (let ((comment-start "#")) + (comment-region b e arg))) + +(defun cperl-uncomment-region (b e arg) + "Uncomment or comment each line in the region in CPerl mode. +See `comment-region'." + (interactive "r\np") + (let ((comment-start "#")) + (comment-region b e (- arg)))) + +(defvar cperl-brace-recursing nil) + (defun cperl-electric-brace (arg &optional only-before) "Insert character and correct line's indentation. If ONLY-BEFORE and `cperl-auto-newline', will insert newline before the @@ -1008,55 +1160,74 @@ char is \"{\", insert extra newline before only if `cperl-extra-newline-before-brace'." (interactive "P") - (let (insertpos) - (if (and (not arg) ; No args, end (of empty line or auto) - (eolp) - (or (and (null only-before) - (save-excursion - (skip-chars-backward " \t") - (bolp))) - (and (eq last-command-char ?\{) ; Do not insert newline - ;; if after ")" and `cperl-extra-newline-before-brace' - ;; is nil, do not insert extra newline. - (not cperl-extra-newline-before-brace) - (save-excursion - (skip-chars-backward " \t") - (eq (preceding-char) ?\)))) - (if cperl-auto-newline - (progn (cperl-indent-line) (newline) t) nil))) + (let (insertpos + (other-end (if (and cperl-electric-parens-mark + (cperl-mark-active) + (< (mark) (point))) + (mark) + nil))) + (if (and other-end + (not cperl-brace-recursing) + (cperl-val 'cperl-electric-parens) + (>= (save-excursion (cperl-to-comment-or-eol) (point)) (point))) + ;; Need to insert a matching pair (progn - (if cperl-auto-newline - (setq insertpos (point))) - (insert last-command-char) - (cperl-indent-line) - (if (and cperl-auto-newline (null only-before)) - (progn - (newline) - (cperl-indent-line))) (save-excursion - (if insertpos (progn (goto-char insertpos) - (search-forward (make-string - 1 last-command-char)) - (setq insertpos (1- (point))))) - (delete-char -1)))) - (if insertpos - (save-excursion - (goto-char insertpos) - (self-insert-command (prefix-numeric-value arg))) - (self-insert-command (prefix-numeric-value arg))))) - -(defun cperl-electric-lbrace (arg) + (setq insertpos (point-marker)) + (goto-char other-end) + (setq last-command-char ?\{) + (cperl-electric-lbrace arg insertpos)) + (forward-char 1)) + (if (and (not arg) ; No args, end (of empty line or auto) + (eolp) + (or (and (null only-before) + (save-excursion + (skip-chars-backward " \t") + (bolp))) + (and (eq last-command-char ?\{) ; Do not insert newline + ;; if after ")" and `cperl-extra-newline-before-brace' + ;; is nil, do not insert extra newline. + (not cperl-extra-newline-before-brace) + (save-excursion + (skip-chars-backward " \t") + (eq (preceding-char) ?\)))) + (if cperl-auto-newline + (progn (cperl-indent-line) (newline) t) nil))) + (progn + (if cperl-auto-newline + (setq insertpos (point))) + (insert last-command-char) + (cperl-indent-line) + (if (and cperl-auto-newline (null only-before)) + (progn + (newline) + (cperl-indent-line))) + (save-excursion + (if insertpos (progn (goto-char insertpos) + (search-forward (make-string + 1 last-command-char)) + (setq insertpos (1- (point))))) + (delete-char -1)))) + (if insertpos + (save-excursion + (goto-char insertpos) + (self-insert-command (prefix-numeric-value arg))) + (self-insert-command (prefix-numeric-value arg)))))) + +(defun cperl-electric-lbrace (arg &optional end) "Insert character, correct line's indentation, correct quoting by space." (interactive "P") (let (pos after + (cperl-brace-recursing t) (cperl-auto-newline cperl-auto-newline) - (other-end (if (and cperl-electric-parens-mark - (cperl-mark-active) - (> (mark) (point))) - (save-excursion - (goto-char (mark)) - (point-marker)) - nil))) + (other-end (or end + (if (and cperl-electric-parens-mark + (cperl-mark-active) + (> (mark) (point))) + (save-excursion + (goto-char (mark)) + (point-marker)) + nil)))) (and (cperl-val 'cperl-electric-lbrace-space) (eq (preceding-char) ?$) (save-excursion @@ -1105,10 +1276,39 @@ (insert last-command-char) ))) +(defun cperl-electric-rparen (arg) + "Insert a matching pair of parentheses if marking is active. +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-mark-active) + (< (mark) (point))) + (mark) + nil)) + p) + (if (and other-end + (cperl-val 'cperl-electric-parens) + (memq last-command-char '( ?\) ?\] ?\} ?\> )) + (>= (save-excursion (cperl-to-comment-or-eol) (point)) (point)) + ;;(not (save-excursion (search-backward "#" beg t))) + ) + (progn + (insert last-command-char) + (setq p (point)) + (if other-end (goto-char other-end)) + (insert (cdr (assoc last-command-char '((?\} . ?\{) + (?\] . ?\[) + (?\) . ?\() + (?\> . ?\<))))) + (goto-char (1+ p))) + (call-interactively 'self-insert-command) + ))) + (defun cperl-electric-keyword () "Insert a construction appropriate after a keyword." (let ((beg (save-excursion (beginning-of-line) (point))) - (dollar (eq (preceding-char) ?$))) + (dollar (eq last-command-char ?$))) (and (save-excursion (backward-sexp 1) (cperl-after-expr-p nil "{};:")) @@ -1181,21 +1381,24 @@ (if (and ; Check if we need to split: ; i.e., on a boundary and inside "{...}" (save-excursion (cperl-to-comment-or-eol) - (>= (point) pos)) + (>= (point) pos)) ; Not in a comment (or (save-excursion (skip-chars-backward " \t" beg) (forward-char -1) - (looking-at "[;{]")) - (looking-at "[ \t]*}") - (re-search-forward "\\=[ \t]*;" end t)) + (looking-at "[;{]")) ; After { or ; + spaces + (looking-at "[ \t]*}") ; Before } + (re-search-forward "\\=[ \t]*;" end t)) ; Before spaces + ; (save-excursion (and - (eq (car (parse-partial-sexp pos end -1)) -1) + (eq (car (parse-partial-sexp pos end -1)) -1) + ; Leave the level of parens (looking-at "[,; \t]*\\($\\|#\\)") ; Comma to allow anon subr + ; Are at end (progn (backward-sexp 1) (setq start (point-marker)) - (<= start pos))))) + (<= start pos))))) ; Redundant? Are after the + ; start of parens group. (progn (skip-chars-backward " \t") (or (memq (preceding-char) (append ";{" nil)) @@ -1228,10 +1431,19 @@ (end-of-line) (newline-and-indent)) (end-of-line) ; else - (if (not (looking-at "\n[ \t]*$")) - (newline-and-indent) - (forward-line 1) - (cperl-indent-line))))) + (cond + ((and (looking-at "\n[ \t]*{$") + (save-excursion + (skip-chars-backward " \t") + (eq (preceding-char) ?\)))) ; Probably if () {} group + ; with an extra newline. + (forward-line 2) + (cperl-indent-line)) + ((looking-at "\n[ \t]*$") ; Next line is empty - use it. + (forward-line 1) + (cperl-indent-line)) + (t + (newline-and-indent)))))) (defun cperl-electric-semi (arg) "Insert character and correct line's indentation." @@ -1247,7 +1459,8 @@ (auto (and cperl-auto-newline (or (not (eq last-command-char ?:)) cperl-auto-newline-after-colon)))) - (if (and (not arg) (eolp) + (if (and ;;(not arg) + (eolp) (not (save-excursion (beginning-of-line) (skip-chars-forward " \t") @@ -1270,9 +1483,9 @@ (or (nth 3 pps) (nth 4 pps) (nth 5 pps)))))))) (progn (insert last-command-char) - (forward-char -1) + ;;(forward-char -1) (if auto (setq insertpos (point-marker))) - (forward-char 1) + ;;(forward-char 1) (cperl-indent-line) (if auto (progn @@ -1285,7 +1498,7 @@ ;; (setq insertpos (1- (point))))) ;; (delete-char -1)))) (save-excursion - (if insertpos (goto-char (marker-position insertpos)) + (if insertpos (goto-char (1- (marker-position insertpos))) (forward-char -1)) (delete-char 1)))) (if insertpos @@ -1321,7 +1534,6 @@ (error nil))) (defun cperl-indent-command (&optional whole-exp) - (interactive "P") "Indent current line as Perl code, or in some cases insert a tab character. If `cperl-tab-always-indent' is non-nil (the default), always indent current line. Otherwise, indent the current line only if point is at the left margin @@ -1331,6 +1543,7 @@ means indent rigidly all the lines of the expression starting after point so that this line becomes properly indented. The relative indentation among the lines of the expression are preserved." + (interactive "P") (if whole-exp ;; If arg, always indent this line as Perl ;; and shift remaining lines of expression the same amount. @@ -1403,7 +1616,7 @@ '(?w ?_)) (progn (backward-sexp) - (looking-at "[a-zA-Z_][a-zA-Z0-9_]*:")))) + (looking-at "[a-zA-Z_][a-zA-Z0-9_]*:[^:]")))) (defun cperl-get-state (&optional parse-start start-state) ;; returns list (START STATE DEPTH PRESTART), START is a good place @@ -1441,19 +1654,19 @@ (or (memq (preceding-char) (append ";){}$@&%\C-@" nil)) ; Or label! \C-@ at bobp ; Label may be mixed up with `$blah :' (save-excursion (cperl-after-label)) - (and (eq (char-syntax (preceding-char)) ?w) + (and (memq (char-syntax (preceding-char)) '(?w ?_)) (progn (backward-sexp) ;; Need take into account `bless', `return', `tr',... - (or (and (looking-at "\\sw+[ \t\n\f]*[{#]") ; Method call syntax + (or (and (looking-at "[a-zA-Z0-9_:]+[ \t\n\f]*[{#]") ; Method call syntax (not (looking-at "\\(bless\\|return\\|qw\\|tr\\|[smy]\\)\\>"))) (progn (skip-chars-backward " \t\n\f") - (and (eq (char-syntax (preceding-char)) ?w) + (and (memq (char-syntax (preceding-char)) '(?w ?_)) (progn (backward-sexp) (looking-at - "sub[ \t]+\\sw+[ \t\n\f]*[#{]"))))))))) + "sub[ \t]+[a-zA-Z0-9_:]+[ \t\n\f]*[#{]"))))))))) (defun cperl-calculate-indent (&optional parse-start symbol) "Return appropriate indentation for current line as Perl code. @@ -1536,7 +1749,12 @@ ;; Now add a little if this is a continuation line. (if (or (bobp) (memq (preceding-char) (append " ;}" nil)) ; Was ?\) - (memq char-after (append ")]}" nil))) + (memq char-after (append ")]}" nil)) + (and (eq (preceding-char) ?\:) ; label + (progn + (forward-sexp -1) + (skip-chars-backward " \t") + (looking-at "[ \t]*[a-zA-Z_][a-zA-Z_0-9]*[ \t]*:")))) 0 cperl-continued-statement-offset)))) ((/= (char-after containing-sexp) ?{) @@ -1598,7 +1816,7 @@ (or ;; If no, find that first statement and indent like ;; it. If the first statement begins with label, do - ;; not belive when the indentation of the label is too + ;; not believe when the indentation of the label is too ;; small. (save-excursion (forward-char 1) @@ -1621,7 +1839,7 @@ (if (> (current-indentation) cperl-min-label-indent) (- (current-indentation) cperl-label-offset) - ;; Do not belive: `max' is involved + ;; Do not believe: `max' is involved (+ old-indent cperl-indent-level)) (current-column))))) ;; If no previous statement, @@ -1648,7 +1866,7 @@ (if (eq (preceding-char) ?\)) (forward-sexp -1)) ;; In the case it starts a subroutine, indent with - ;; respect to `sub', not with respect to the + ;; respect to `sub', not with respect to the the ;; first thing on the line, say in the case of ;; anonymous sub in a hash. ;; @@ -1771,7 +1989,7 @@ (or ;; If no, find that first statement and indent like ;; it. If the first statement begins with label, do - ;; not belive when the indentation of the label is too + ;; not believe when the indentation of the label is too ;; small. (save-excursion (forward-char 1) @@ -1797,7 +2015,7 @@ (if (> (current-indentation) cperl-min-label-indent) (list (list 'label-in-block (point))) - ;; Do not belive: `max' is involved + ;; Do not believe: `max' is involved (list (list 'label-in-block-min-indent (point)))) ;; Before statement @@ -1909,84 +2127,263 @@ (interactive) (or min (setq min (point-min))) (or max (setq max (point-max))) - (let (face head-face here-face b e bb tag err + (let (face head-face here-face b e bb tag qtag err b1 e1 argument (cperl-pod-here-fontify (eval cperl-pod-here-fontify)) (case-fold-search nil) (inhibit-read-only t) (buffer-undo-list t) - (modified (buffer-modified-p))) + (modified (buffer-modified-p)) + (after-change-functions nil) + (search + (concat + "\\(\\`\n?\\|\n\n\\)=" + "\\|" + ;; One extra () before this: + "<<\\(\\([\"'`]\\)\\([^\"'`\n]*\\)\\3\\|\\(\\([a-zA-Z_][a-zA-Z_0-9]*\\)?\\)[^=]\\)" ; [^=] to avoid <<=. + "\\|" + ;; 1+5 extra () before this: + "^[ \t]*format[ \t]*\\([a-zA-Z0-9_]+\\)?[ \t]*=[ \t]*$"))) (unwind-protect (progn (save-excursion - (message "Scanning for pods and here-docs...") + (message "Scanning for pods, formats and here-docs...") (if cperl-pod-here-fontify - (setq face (eval cperl-pod-face) - head-face (eval cperl-pod-head-face) - here-face (eval cperl-here-face))) + ;; We had evals here, do not know why... + (setq face cperl-pod-face + head-face cperl-pod-head-face + here-face cperl-here-face)) (remove-text-properties min max '(syntax-type t)) ;; Need to remove face as well... (goto-char min) - (while (re-search-forward "\\(\\`\n?\\|\n\n\\)=" max t) - (if (looking-at "\n*cut\\>") - (progn - (message "=cut is not preceeded by a pod section") - (setq err (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 4) - (setq e (point)) - (put-text-property b e 'in-pod t) - (goto-char b) - (while (re-search-forward "\n\n[ \t]" e t) + (while (re-search-forward search max t) + (cond + ((match-beginning 1) ; POD section + ;; "\\(\\`\n?\\|\n\n\\)=" + (if (looking-at "\n*cut\\>") + (progn + (message "=cut is not preceeded by a pod section") + (setq err (point))) (beginning-of-line) - (put-text-property b (point) 'syntax-type 'pod) - (put-text-property (max (point-min) (1- b)) - (point) cperl-do-not-fontify t) - (if cperl-pod-here-fontify (put-text-property b (point) 'face face)) - (re-search-forward "\n\n[^ \t\f]" e 'toend) - (beginning-of-line) - (setq b (point))) - (put-text-property (point) e 'syntax-type 'pod) - (put-text-property (max (point-min) (1- (point))) - e cperl-do-not-fontify t) + + (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) + (setq e (point)) + (put-text-property b e 'in-pod t) + (goto-char b) + (while (re-search-forward "\n\n[ \t]" e t) + (beginning-of-line) + (put-text-property 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) + (if cperl-pod-here-fontify (put-text-property b (point) 'face 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) + (cperl-put-do-not-fontify (point) e) + ;;(put-text-property (max (point-min) (1- (point))) + ;; e cperl-do-not-fontify t) + (if cperl-pod-here-fontify + (progn (put-text-property (point) e 'face face) + (goto-char bb) + (if (looking-at + "=[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]\\)+\\)$" + e 'toend) + (put-text-property + (match-beginning 1) (match-end 1) + 'face head-face)))) + (goto-char e))) + ;; Here document + ;; 1 () ahead + ;; "<<\\(\\([\"'`]\\)\\([^\"'`\n]*\\)\\3\\|\\(\\([a-zA-Z_][a-zA-Z_0-9]*\\)?\\)\\)" + ((match-beginning 2) ; 1 + 1 + ;; Abort in comment (_extremely_ simplified): + (setq b (point)) + (if (save-excursion + (beginning-of-line) + (search-forward "#" b t)) + nil + (if (match-beginning 5) ;4 + 1 + (setq b1 (match-beginning 5) ; 4 + 1 + e1 (match-end 5)) ; 4 + 1 + (setq b1 (match-beginning 4) ; 3 + 1 + e1 (match-end 4))) ; 3 + 1 + (setq tag (buffer-substring b1 e1) + qtag (regexp-quote tag)) + (cond (cperl-pod-here-fontify + (put-text-property b1 e1 'face font-lock-reference-face) + (cperl-put-do-not-fontify b1 e1))) + (forward-line) + (setq b (point)) + (cond ((re-search-forward (concat "^" qtag "$") max 'toend) + (if cperl-pod-here-fontify + (progn + (put-text-property (match-beginning 0) (match-end 0) + 'face font-lock-reference-face) + (cperl-put-do-not-fontify b (match-end 0)) + ;;(put-text-property (max (point-min) (1- b)) + ;; (min (point-max) + ;; (1+ (match-end 0))) + ;; cperl-do-not-fontify t) + (put-text-property b (match-beginning 0) + 'face here-face))) + (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))))) + ;; format + (t + ;; 1+5=6 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 + "")) + (setq argument nil) (if cperl-pod-here-fontify - (progn (put-text-property (point) e 'face face) - (goto-char bb) - (while (re-search-forward - ;; One paragraph - "\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))) - (goto-char min) - (while (re-search-forward - "<<\\(\\([\"'`]\\)?\\)\\([a-zA-Z_][a-zA-Z_0-9]*\\)\\1" - max t) - (setq tag (buffer-substring (match-beginning 3) - (match-end 3))) - (if cperl-pod-here-fontify - (put-text-property (match-beginning 3) (match-end 3) - 'face font-lock-reference-face)) - (forward-line) - (setq b (point)) - (and (re-search-forward (concat "^" tag "$") max 'toend) - (progn - (if cperl-pod-here-fontify - (progn - (put-text-property (match-beginning 0) (match-end 0) - 'face font-lock-reference-face) - (put-text-property (max (point-min) (1- b)) - (min (point-max) - (1+ (match-end 0))) - cperl-do-not-fontify t) - (put-text-property b (match-beginning 0) - 'face here-face))) - (put-text-property b (match-beginning 0) - 'syntax-type 'here-doc))))) + (while (and (eq (forward-line) 0) + (not (looking-at "^[.;]$"))) + (cond + ((looking-at "^#")) ; Skip comments + ((and argument ; Skip argument multi-lines + (looking-at "^[ \t]*{")) + (forward-sexp 1) + (setq argument nil)) + (argument ; Skip argument lines + (setq argument nil)) + (t ; Format line + (setq b1 (point)) + (setq argument (looking-at "^[^\n]*[@^]")) + (end-of-line) + (put-text-property b1 (point) + 'face font-lock-string-face) + (cperl-put-do-not-fontify b1 (point))))) + (re-search-forward (concat "^[.;]$") max 'toend)) + (beginning-of-line) + (if (looking-at "^[.;]$") + (progn + (put-text-property (point) (+ (point) 2) + 'face font-lock-string-face) + (cperl-put-do-not-fontify (point) (+ (point) 2))) + (message "End of format `%s' not found." name)) + (forward-line) + (put-text-property b (point) 'syntax-type 'format) +;;; (cond ((re-search-forward (concat "^[.;]$") max 'toend) +;;; (if cperl-pod-here-fontify +;;; (progn +;;; (put-text-property b (match-end 0) +;;; 'face font-lock-string-face) +;;; (cperl-put-do-not-fontify b (match-end 0)))) +;;; (put-text-property b (match-end 0) +;;; 'syntax-type 'format) +;;; (cperl-put-do-not-fontify b (match-beginning 0))) +;;; (t (message "End of format `%s' not found." name))) + ))) +;;; (while (re-search-forward "\\(\\`\n?\\|\n\n\\)=" max t) +;;; (if (looking-at "\n*cut\\>") +;;; (progn +;;; (message "=cut is not preceeded by a pod section") +;;; (setq err (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) +;;; (setq e (point)) +;;; (put-text-property b e 'in-pod t) +;;; (goto-char b) +;;; (while (re-search-forward "\n\n[ \t]" e t) +;;; (beginning-of-line) +;;; (put-text-property 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) +;;; (if cperl-pod-here-fontify (put-text-property b (point) 'face 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) +;;; (cperl-put-do-not-fontify (point) e) +;;; ;;(put-text-property (max (point-min) (1- (point))) +;;; ;; e cperl-do-not-fontify t) +;;; (if cperl-pod-here-fontify +;;; (progn (put-text-property (point) e 'face face) +;;; (goto-char bb) +;;; (if (looking-at +;;; "=[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]\\)+\\)$" +;;; e 'toend) +;;; (put-text-property +;;; (match-beginning 1) (match-end 1) +;;; 'face head-face)))) +;;; (goto-char e))) +;;; (goto-char min) +;;; (while (re-search-forward +;;; ;; We exclude \n to avoid misrecognition inside quotes. +;;; "<<\\(\\([\"'`]\\)\\([^\"'`\n]*\\)\\2\\|\\(\\([a-zA-Z_][a-zA-Z_0-9]*\\)?\\)\\)" +;;; max t) +;;; (if (match-beginning 4) +;;; (setq b1 (match-beginning 4) +;;; e1 (match-end 4)) +;;; (setq b1 (match-beginning 3) +;;; e1 (match-end 3))) +;;; (setq tag (buffer-substring b1 e1) +;;; qtag (regexp-quote tag)) +;;; (cond (cperl-pod-here-fontify +;;; (put-text-property b1 e1 'face font-lock-reference-face) +;;; (cperl-put-do-not-fontify b1 e1))) +;;; (forward-line) +;;; (setq b (point)) +;;; (cond ((re-search-forward (concat "^" qtag "$") max 'toend) +;;; (if cperl-pod-here-fontify +;;; (progn +;;; (put-text-property (match-beginning 0) (match-end 0) +;;; 'face font-lock-reference-face) +;;; (cperl-put-do-not-fontify b (match-end 0)) +;;; ;;(put-text-property (max (point-min) (1- b)) +;;; ;; (min (point-max) +;;; ;; (1+ (match-end 0))) +;;; ;; cperl-do-not-fontify t) +;;; (put-text-property b (match-beginning 0) +;;; 'face here-face))) +;;; (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)))) +;;; (goto-char min) +;;; (while (re-search-forward +;;; "^[ \t]*format[ \t]*\\(\\([a-zA-Z0-9_]+[ \t]*\\)?\\)=[ \t]*$" +;;; max t) +;;; (setq b (point) +;;; name (buffer-substring (match-beginning 1) +;;; (match-end 1))) +;;; (cond ((re-search-forward (concat "^[.;]$") max 'toend) +;;; (if cperl-pod-here-fontify +;;; (progn +;;; (put-text-property b (match-end 0) +;;; 'face font-lock-string-face) +;;; (cperl-put-do-not-fontify b (match-end 0)))) +;;; (put-text-property b (match-end 0) +;;; '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 and here-docs completed."))) + (message "Scan for pods, formats and here-docs completed."))) (and (buffer-modified-p) (not modified) (set-buffer-modified-p nil))))) @@ -2234,16 +2631,37 @@ (defvar imenu-example--function-name-regexp-perl "^\\([ \t]*\\(sub\\|package\\)[ \t\n]+\\([a-zA-Z_0-9:']+\\)[ \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 + ;; loops back, and ISBACK is set. Thus this function cannot be + ;; applied twice without ISBACK set. + (cond ((not cperl-imenu-addback) lst) + (t + (or name + (setq name "+++BACK+++")) + (mapcar (function (lambda (elt) + (if (and (listp elt) (listp (cdr elt))) + (progn + ;; In the other order it goes up + ;; one level only ;-( + (setcdr elt (cons (cons name lst) + (cdr elt))) + (cperl-imenu-addback (cdr elt) t name) + )))) + (if isback (cdr lst) lst)) + lst))) + (defun imenu-example--create-perl-index (&optional regexp) (require 'cl) (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) ;; Search for the function - (save-match-data + (progn ;;save-match-data (while (re-search-forward (or regexp imenu-example--function-name-regexp-perl) nil t) @@ -2255,7 +2673,7 @@ (goto-char (match-beginning 2)) (setq fchar (following-char)) ) - (setq char (following-char)) + (setq char (following-char) meth nil) (setq p (point)) (while (and ends-ranges (>= p (car ends-ranges))) ;; delete obsolete entries @@ -2263,32 +2681,40 @@ (setq package (or (car packages) "") end-range (or (car ends-ranges) 0)) (if (eq fchar ?p) - (progn - (setq name (buffer-substring (match-beginning 3) (match-end 3)) - package (concat name "::") - name (concat "package " name) - end-range - (save-excursion - (parse-partial-sexp (point) (point-max) -1) (point)) - ends-ranges (cons end-range ends-ranges) - packages (cons package packages)))) + (setq name (buffer-substring (match-beginning 3) (match-end 3)) + name (progn + (set-text-properties 0 (length name) nil name) + name) + package (concat name "::") + name (concat "package " name) + end-range + (save-excursion + (parse-partial-sexp (point) (point-max) -1) (point)) + ends-ranges (cons end-range ends-ranges) + packages (cons package packages))) ;; ) ;; Skip this function name if it is a prototype declaration. (if (and (eq fchar ?s) (eq char ?\;)) nil + (setq index (imenu-example--name-and-position)) (if (eq fchar ?p) nil (setq name (buffer-substring (match-beginning 3) (match-end 3))) - (if (or (> p end-range) (string-match "[:']" name)) nil - (setq name (concat package name)))) - (setq index (imenu-example--name-and-position)) + (set-text-properties 0 (length name) nil name) + (cond ((string-match "[:']" name) + (setq meth t)) + ((> p end-range) nil) + (t + (setq name (concat package name) meth t)))) (setcar index name) (if (eq fchar ?p) (push index index-pack-alist) (push index index-alist)) + (if meth (push index index-meth-alist)) (push index index-unsorted-alist))) (t ; Pod section ;; (beginning-of-line) (setq index (imenu-example--name-and-position) name (buffer-substring (match-beginning 5) (match-end 5))) + (set-text-properties 0 (length name) nil name) (if (eq (char-after (match-beginning 4)) ?2) (setq name (concat " " name))) (setcar index name) @@ -2301,20 +2727,55 @@ (sort index-alist (default-value 'imenu-sort-function)) (nreverse index-alist))) (and index-pod-alist - (push (cons (imenu-create-submenu-name "+POD headers+") + (push (cons "+POD headers+..." (nreverse index-pod-alist)) index-alist)) + (and (or index-pack-alist index-meth-alist) + (let ((lst index-pack-alist) hier-list pack elt group name) + ;; Remove "package ", reverse and uniquify. + (while lst + (setq elt (car lst) lst (cdr lst) name (substring (car elt) 8)) + (if (assoc name hier-list) nil + (setq hier-list (cons (cons name (cdr elt)) hier-list)))) + (setq lst index-meth-alist) + (while lst + (setq elt (car lst) lst (cdr lst)) + (cond ((string-match "\\(::\\|'\\)[_a-zA-Z0-9]+$" (car elt)) + (setq pack (substring (car elt) 0 (match-beginning 0))) + (if (setq group (assoc pack hier-list)) + (if (listp (cdr group)) + ;; Have some functions already + (setcdr group + (cons (cons (substring + (car elt) + (+ 2 (match-beginning 0))) + (cdr elt)) + (cdr group))) + (setcdr group (list (cons (substring + (car elt) + (+ 2 (match-beginning 0))) + (cdr elt))))) + (setq hier-list + (cons (cons pack + (list (cons (substring + (car elt) + (+ 2 (match-beginning 0))) + (cdr elt)))) + hier-list)))))) + (push (cons "+Hierarchy+..." + hier-list) + index-alist))) (and index-pack-alist - (push (cons (imenu-create-submenu-name "+Packages+") + (push (cons "+Packages+..." (nreverse index-pack-alist)) index-alist)) (and (or index-pack-alist index-pod-alist (default-value 'imenu-sort-function)) index-unsorted-alist - (push (cons (imenu-create-submenu-name "+Unsorted List+") + (push (cons "+Unsorted List+..." (nreverse index-unsorted-alist)) index-alist)) - index-alist)) + (cperl-imenu-addback index-alist))) (defvar cperl-compilation-error-regexp-alist ;; This look like a paranoiac regexp: could anybody find a better one? (which WORK). @@ -2376,36 +2837,43 @@ "\\|") ; Flow control "\\)\\>") 2) ; was "\\)[ \n\t;():,\|&]" ; In what follows we use `type' style - ; for overwritable buildins + ; for overwritable builtins (list (concat "\\(^\\|[^$@%&\\]\\)\\<\\(" - ;; "CORE" "__FILE__" "__LINE__" "abs" "accept" "alarm" "and" "atan2" - ;; "bind" "binmode" "bless" "caller" "chdir" "chmod" "chown" "chr" - ;; "chroot" "close" "closedir" "cmp" "connect" "continue" "cos" - ;; "crypt" "dbmclose" "dbmopen" "die" "dump" "endgrent" "endhostent" - ;; "endnetent" "endprotoent" "endpwent" "endservent" "eof" "eq" "exec" - ;; "exit" "exp" "fcntl" "fileno" "flock" "fork" "formline" "ge" "getc" - ;; "getgrent" "getgrgid" "getgrnam" "gethostbyaddr" "gethostbyname" - ;; "gethostent" "getlogin" "getnetbyaddr" "getnetbyname" "getnetent" - ;; "getpeername" "getpgrp" "getppid" "getpriority" "getprotobyname" - ;; "getprotobynumber" "getprotoent" "getpwent" "getpwnam" "getpwuid" - ;; "getservbyname" "getservbyport" "getservent" "getsockname" - ;; "getsockopt" "glob" "gmtime" "gt" "hex" "index" "int" "ioctl" - ;; "join" "kill" "lc" "lcfirst" "le" "length" "link" "listen" - ;; "localtime" "log" "lstat" "lt" "mkdir" "msgctl" "msgget" "msgrcv" - ;; "msgsnd" "ne" "not" "oct" "open" "opendir" "or" "ord" "pack" "pipe" - ;; "quotemeta" "rand" "read" "readdir" "readline" "readlink" - ;; "readpipe" "recv" "ref" "rename" "require" "reset" "reverse" - ;; "rewinddir" "rindex" "rmdir" "seek" "seekdir" "select" "semctl" - ;; "semget" "semop" "send" "setgrent" "sethostent" "setnetent" - ;; "setpgrp" "setpriority" "setprotoent" "setpwent" "setservent" - ;; "setsockopt" "shmctl" "shmget" "shmread" "shmwrite" "shutdown" - ;; "sin" "sleep" "socket" "socketpair" "sprintf" "sqrt" "srand" "stat" - ;; "substr" "symlink" "syscall" "sysread" "system" "syswrite" "tell" - ;; "telldir" "time" "times" "truncate" "uc" "ucfirst" "umask" "unlink" - ;; "unpack" "utime" "values" "vec" "wait" "waitpid" "wantarray" "warn" - ;; "write" "x" "xor" + ;; "CORE" "__FILE__" "__LINE__" "abs" "accept" "alarm" + ;; "and" "atan2" "bind" "binmode" "bless" "caller" + ;; "chdir" "chmod" "chown" "chr" "chroot" "close" + ;; "closedir" "cmp" "connect" "continue" "cos" "crypt" + ;; "dbmclose" "dbmopen" "die" "dump" "endgrent" + ;; "endhostent" "endnetent" "endprotoent" "endpwent" + ;; "endservent" "eof" "eq" "exec" "exit" "exp" "fcntl" + ;; "fileno" "flock" "fork" "formline" "ge" "getc" + ;; "getgrent" "getgrgid" "getgrnam" "gethostbyaddr" + ;; "gethostbyname" "gethostent" "getlogin" + ;; "getnetbyaddr" "getnetbyname" "getnetent" + ;; "getpeername" "getpgrp" "getppid" "getpriority" + ;; "getprotobyname" "getprotobynumber" "getprotoent" + ;; "getpwent" "getpwnam" "getpwuid" "getservbyname" + ;; "getservbyport" "getservent" "getsockname" + ;; "getsockopt" "glob" "gmtime" "gt" "hex" "index" "int" + ;; "ioctl" "join" "kill" "lc" "lcfirst" "le" "length" + ;; "link" "listen" "localtime" "log" "lstat" "lt" + ;; "mkdir" "msgctl" "msgget" "msgrcv" "msgsnd" "ne" + ;; "not" "oct" "open" "opendir" "or" "ord" "pack" "pipe" + ;; "quotemeta" "rand" "read" "readdir" "readline" + ;; "readlink" "readpipe" "recv" "ref" "rename" "require" + ;; "reset" "reverse" "rewinddir" "rindex" "rmdir" "seek" + ;; "seekdir" "select" "semctl" "semget" "semop" "send" + ;; "setgrent" "sethostent" "setnetent" "setpgrp" + ;; "setpriority" "setprotoent" "setpwent" "setservent" + ;; "setsockopt" "shmctl" "shmget" "shmread" "shmwrite" + ;; "shutdown" "sin" "sleep" "socket" "socketpair" + ;; "sprintf" "sqrt" "srand" "stat" "substr" "symlink" + ;; "syscall" "sysread" "system" "syswrite" "tell" + ;; "telldir" "time" "times" "truncate" "uc" "ucfirst" + ;; "umask" "unlink" "unpack" "utime" "values" "vec" + ;; "wait" "waitpid" "wantarray" "warn" "write" "x" "xor" "a\\(bs\\|ccept\\|tan2\\|larm\\|nd\\)\\|" "b\\(in\\(d\\|mode\\)\\|less\\)\\|" "c\\(h\\(r\\(\\|oot\\)\\|dir\\|mod\\|own\\)\\|aller\\|rypt\\|" @@ -2439,18 +2907,20 @@ "x\\(\\|or\\)\\|__\\(FILE__\\|LINE__\\)" "\\)\\>") 2 'font-lock-type-face) ;; In what follows we use `other' style - ;; for nonoverwritable buildins - ;; Somehow 's', 'm' are not autogenerated??? + ;; for nonoverwritable builtins + ;; Somehow 's', 'm' are not auto-generated??? (list (concat "\\(^\\|[^$@%&\\]\\)\\<\\(" - ;; "AUTOLOAD" "BEGIN" "DESTROY" "END" "__END__" "chomp" "chop" - ;; "defined" "delete" "do" "each" "else" "elsif" "eval" "exists" "for" - ;; "foreach" "format" "goto" "grep" "if" "keys" "last" "local" "map" - ;; "my" "next" "no" "package" "pop" "pos" "print" "printf" "push" "q" - ;; "qq" "qw" "qx" "redo" "return" "scalar" "shift" "sort" "splice" - ;; "split" "study" "sub" "tie" "tr" "undef" "unless" "unshift" "untie" - ;; "until" "use" "while" "y" + ;; "AUTOLOAD" "BEGIN" "DESTROY" "END" "__END__" "chomp" + ;; "chop" "defined" "delete" "do" "each" "else" "elsif" + ;; "eval" "exists" "for" "foreach" "format" "goto" + ;; "grep" "if" "keys" "last" "local" "map" "my" "next" + ;; "no" "package" "pop" "pos" "print" "printf" "push" + ;; "q" "qq" "qw" "qx" "redo" "return" "scalar" "shift" + ;; "sort" "splice" "split" "study" "sub" "tie" "tr" + ;; "undef" "unless" "unshift" "untie" "until" "use" + ;; "while" "y" "AUTOLOAD\\|BEGIN\\|cho\\(p\\|mp\\)\\|d\\(e\\(fined\\|lete\\)\\|" "o\\)\\|DESTROY\\|e\\(ach\\|val\\|xists\\|ls\\(e\\|if\\)\\)\\|" "END\\|for\\(\\|each\\|mat\\)\\|g\\(rep\\|oto\\)\\|if\\|keys\\|" @@ -2467,11 +2937,13 @@ ;; "#include" "#define" "#undef") ;; "\\|") '("-[rwxoRWXOezsfdlpSbctugkTBMAC]\\>\\([ \t]+_\\>\\)?" 0 - font-lock-function-name-face) ; Not very good, triggers at "[a-z]" + font-lock-function-name-face keep) ; Not very good, triggers at "[a-z]" '("\\<sub[ \t]+\\([^ \t{;]+\\)[ \t]*[{\n]" 1 font-lock-function-name-face) '("\\<\\(package\\|require\\|use\\|import\\|no\\|bootstrap\\)[ \t]+\\([a-zA-z_][a-zA-z_0-9:]*\\)[ \t;]" ; require A if B; 2 font-lock-function-name-face) + '("^[ \t]*format[ \t]+\\([a-zA-z_][a-zA-z_0-9:]*\\)[ \t]*=[ \t]*$" + 1 font-lock-function-name-face) (cond ((featurep 'font-lock-extra) '("\\([]}\\\\%@>*&]\\|\\$[a-zA-Z0-9_:]*\\)[ \t]*{[ \t]*\\(-?[a-zA-Z0-9_:]+\\)[ \t]*}" (2 font-lock-string-face t) @@ -2511,8 +2983,14 @@ (setq t-font-lock-keywords-1 (and (fboundp 'turn-on-font-lock) ; Check for newer font-lock - (not (cperl-xemacs-p)) ; not yet as of XEmacs 19.12 - '(("\\(\\([$@]+\\)[a-zA-Z_:][a-zA-Z0-9_:]*\\)[ \t]*\\([[{]\\)" + (not cperl-xemacs-p) ; not yet as of XEmacs 19.12 + '( + ("\\(\\([@%]\\|\$#\\)[a-zA-Z_:][a-zA-Z0-9_:]*\\)" 1 + (if (eq (char-after (match-beginning 2)) ?%) + font-lock-other-emphasized-face + font-lock-emphasized-face) + t) ; arrays and hashes + ("\\(\\([$@]+\\)[a-zA-Z_:][a-zA-Z0-9_:]*\\)[ \t]*\\([[{]\\)" 1 (if (= (- (match-end 2) (match-beginning 2)) 1) (if (eq (char-after (match-beginning 3)) ?{) @@ -2520,11 +2998,6 @@ font-lock-emphasized-face) ; arrays and hashes font-lock-variable-name-face) ; Just to put something t) - ("\\(\\([@%]\\|\$#\\)[a-zA-Z_:][a-zA-Z0-9_:]*\\)" 1 - (if (eq (char-after (match-beginning 2)) ?%) - font-lock-other-emphasized-face - font-lock-emphasized-face) - t) ; arrays and hashes ;;("\\([smy]\\|tr\\)\\([^a-z_A-Z0-9]\\)\\(\\([^\n\\]*||\\)\\)\\2") ;;; Too much noise from \s* @s[ and friends ;;("\\(\\<\\([msy]\\|tr\\)[ \t]*\\([^ \t\na-zA-Z0-9_]\\)\\|\\(/\\)\\)" @@ -2636,7 +3109,7 @@ 'font-lock-other-type-face "Face to use for data types from another group.") ) - (if (not (cperl-xemacs-p)) nil + (if (not cperl-xemacs-p) nil (or (boundp 'font-lock-comment-face) (defconst font-lock-comment-face 'font-lock-comment-face @@ -2823,7 +3296,7 @@ (mode-compile))) (defun cperl-info-buffer () - ;; Returns buffer with documentation. Creats if missing + ;; Returns buffer with documentation. Creates if missing (let ((info (get-buffer "*info-perl*"))) (if info info (save-window-excursion @@ -2831,7 +3304,7 @@ (require 'info) (save-window-excursion (info)) - (Info-find-node "perl5" "perlfunc") + (Info-find-node cperl-info-page "perlfunc") (set-buffer "*info*") (rename-buffer "*info-perl*") (current-buffer))))) @@ -2923,7 +3396,7 @@ (defun cperl-lineup (beg end &optional step minshift) "Lineup construction in a region. Beginning of region should be at the start of a construction. -All first occurences of this construction in the lines that are +All first occurrences of this construction in the lines that are partially contained in the region are lined up at the same column. MINSHIFT is the minimal amount of space to insert before the construction. @@ -2943,8 +3416,8 @@ (indent-region beg end nil) (goto-char beg) (setq col (current-column)) - (if (looking-at "\\sw") - (if (looking-at "\\<\\sw+\\>") + (if (looking-at "[a-zA-Z0-9_]") + (if (looking-at "\\<[a-zA-Z0-9_]+\\>") (setq search (concat "\\<" (regexp-quote @@ -2964,7 +3437,7 @@ (setq tcol (current-column) seen t) (if (> tcol col) (setq col tcol))) (or seen - (error "The construction to line up occured only once")) + (error "The construction to line up occurred only once")) (goto-char beg) (setq col (+ col minshift)) (if (/= (% col step) 0) (setq step (* step (1+ (/ col step))))) @@ -3034,3 +3507,1022 @@ (message "Parentheses will %sbe auto-doubled now." (if (cperl-val 'cperl-electric-parens) "" "not "))) +;;;; Tags file creation. + +(defvar cperl-tmp-buffer " *cperl-tmp*") + +(defun cperl-setup-tmp-buf () + (set-buffer (get-buffer-create cperl-tmp-buffer)) + (set-syntax-table cperl-mode-syntax-table) + (buffer-disable-undo) + (auto-fill-mode 0)) + +(defun cperl-xsub-scan () + (require 'cl) + (require 'imenu) + (let ((index-alist '()) + (prev-pos 0) index index1 name package prefix) + (goto-char (point-min)) + (imenu-progress-message prev-pos 0) + ;; Search for the function + (progn ;;save-match-data + (while (re-search-forward + "^\\([ \t]*MODULE\\>[^\n]*\\<PACKAGE[ \t]*=[ \t]*\\([a-zA-Z_][a-zA-Z_0-9:]*\\)\\>\\|\\([a-zA-Z_][a-zA-Z_0-9]*\\)(\\|[ \t]*BOOT:\\)" + nil t) + (imenu-progress-message prev-pos) + (cond + ((match-beginning 2) ; SECTION + (setq package (buffer-substring (match-beginning 2) (match-end 2))) + (goto-char (match-beginning 0)) + (skip-chars-forward " \t") + (forward-char 1) + (if (looking-at "[^\n]*\\<PREFIX[ \t]*=[ \t]*\\([a-zA-Z_][a-zA-Z_0-9]*\\)\\>") + (setq prefix (buffer-substring (match-beginning 1) (match-end 1))) + (setq prefix nil))) + ((not package) nil) ; C language section + ((match-beginning 3) ; XSUB + (goto-char (1+ (match-beginning 3))) + (setq index (imenu-example--name-and-position)) + (setq name (buffer-substring (match-beginning 3) (match-end 3))) + (if (and prefix (string-match (concat "^" prefix) name)) + (setq name (substring name (length prefix)))) + (cond ((string-match "::" name) nil) + (t + (setq index1 (cons (concat package "::" name) (cdr index))) + (push index1 index-alist))) + (setcar index name) + (push index index-alist)) + (t ; BOOT: section + ;; (beginning-of-line) + (setq index (imenu-example--name-and-position)) + (setcar index (concat package "::BOOT:")) + (push index index-alist))))) + (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) + (save-excursion + (if b (set-buffer b) + (cperl-setup-tmp-buf)) + (erase-buffer) + (setq file (car (insert-file-contents file))) + (message "Scanning file %s..." file) + (if xs + (setq lst (cperl-xsub-scan)) + (setq ind (imenu-example--create-perl-index)) + (setq lst (cdr (assoc "+Unsorted List+..." ind)))) + (setq lst + (mapcar + (function + (lambda (elt) + (cond ((string-match "^[_a-zA-Z]" (car elt)) + (goto-char (cdr elt)) + (list (car elt) + (point) (count-lines 1 (point)) + (buffer-substring (progn + (skip-chars-forward + ":_a-zA-Z0-9") + (or (eolp) (forward-char 1)) + (point)) + (progn + (beginning-of-line) + (point)))))))) + lst)) + (erase-buffer) + (while lst + (setq elt (car lst) lst (cdr lst)) + (if elt + (progn + (insert (elt elt 3) + 127 + (if (string-match "^package " (car elt)) + (substring (car elt) 8) + (car elt) ) + 1 + (number-to-string (elt elt 1)) + "," + (number-to-string (elt elt 2)) + "\n") + (if (and (string-match "^[_a-zA-Z]+::" (car elt)) + (string-match "^sub[ \t]+\\([_a-zA-Z]+\\)[^:_a-zA-Z]" + (elt elt 3))) + ;; Need to insert the name without package as well + (setq lst (cons (cons (substring (elt elt 3) + (match-beginning 1) + (match-end 1)) + (cdr elt)) + lst)))))) + (setq pos (point)) + (goto-char 1) + (insert "\f\n" file "," (number-to-string (1- pos)) "\n") + (setq ret (buffer-substring 1 (point-max))) + (erase-buffer) + (message "Scanning file %s finished" file) + ret))) + +(defun cperl-write-tags (&optional file erase recurse dir inbuffer) + ;; 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!"))) + (let ((tags-file-name "TAGS") + (case-fold-search (eq system-type 'emx)) + xs) + (save-excursion + (cond (inbuffer nil) ; Already there + ((file-exists-p tags-file-name) + (visit-tags-table-buffer tags-file-name)) + (t (set-buffer (find-file-noselect tags-file-name)))) + (cond + (dir + (cond ((eq erase 'ignore)) + (erase + (erase-buffer) + (setq erase 'ignore))) + (let ((files + (directory-files file t (if recurse nil "\\.[Pp][Llm]$") t))) + (mapcar (function (lambda (file) + (cond + ((string-match "/\\.\\.?$" file) nil) + ((not (file-directory-p file)) + (if (string-match "\\.\\([Pp][Llm]\\|xs\\)$" file) + (cperl-write-tags file erase recurse nil t))) + ((not recurse) nil) + (t (cperl-write-tags file erase recurse t t))))) + 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 inbuffer nil ; Delegate to the caller + (save-buffer 0) ; No backup + (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]+::\\)") + +(defvar cperl-hierarchy '(() ()) + "Global hierarchy of classes") + +(defun cperl-tags-hier-fill () + ;; Suppose we are in a tag table cooked by cperl. + (goto-char 1) + (let (type pack name pos line chunk ord cons1 file str info fileind) + (while (re-search-forward cperl-tags-hier-regexp-list nil t) + (setq pos (match-beginning 0) + pack (match-beginning 2)) + (beginning-of-line) + (if (looking-at "\\([^\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)) + ;;pos (buffer-substring (match-beginning 3) (match-end 3)) + line (buffer-substring (match-beginning 4) (match-end 4)) + ord (if pack 1 0) + info (etags-snarf-tag) ; Moves to beginning of the next line + file (file-of-tag) + fileind (format "%s:%s" file line)) + ;; Move back + (forward-char -1) + ;; Make new member of hierarchy name ==> file ==> pos if needed + (if (setq cons1 (assoc name (nth ord cperl-hierarchy))) + ;; Name known + (setcdr cons1 (cons (cons fileind (vector file info)) + (cdr cons1))) + ;; First occurrence of the name, start alist + (setq cons1 (cons name (list (cons fileind (vector file info))))) + (if pack + (setcar (cdr cperl-hierarchy) + (cons cons1 (nth 1 cperl-hierarchy))) + (setcar cperl-hierarchy + (cons cons1 (car cperl-hierarchy))))))) + (end-of-line)))) + +(defun cperl-tags-hier-init (&optional update) + "Show hierarchical menu of classes and methods. +Finds info about classes by a scan of loaded TAGS files. +Supposes that the TAGS files contain fully qualified function names. +One may build such TAGS files from CPerl mode menu." + (interactive) + (require 'etags) + (require 'imenu) + (if (or update (null (nth 2 cperl-hierarchy))) + (let (pack name cons1 to l1 l2 l3 l4 + (remover (function (lambda (elt) ; (name (file1...) (file2..)) + (or (nthcdr 2 elt) + ;; Only in one file + (setcdr elt (cdr (nth 1 elt)))))))) + ;; (setq cperl-hierarchy '(() () ())) ; Would write into '() later! + (setq cperl-hierarchy (list l1 l2 l3)) + (or tags-table-list + (call-interactively 'visit-tags-table)) + (message "Updating list of classes...") + (mapcar + (function + (lambda (tagsfile) + (set-buffer (get-file-buffer tagsfile)) + (cperl-tags-hier-fill))) + tags-table-list) + (mapcar remover (car cperl-hierarchy)) + (mapcar remover (nth 1 cperl-hierarchy)) + (setq to (list nil (cons "Packages: " (nth 1 cperl-hierarchy)) + (cons "Methods: " (car cperl-hierarchy)))) + (cperl-tags-treeify to 1) + (setcar (nthcdr 2 cperl-hierarchy) + (cperl-menu-to-keymap (cons '("+++UPDATE+++" . -999) (cdr to)))) + (message "Updating list of classes: done, requesting display...") + ;;(cperl-imenu-addback (nth 2 cperl-hierarchy)) + )) + (or (nth 2 cperl-hierarchy) + (error "No items found")) + (setq update +;;; (imenu-choose-buffer-index "Packages: " (nth 2 cperl-hierarchy)) + (if window-system + (x-popup-menu t (nth 2 cperl-hierarchy)) + (require 'tmm) + (tmm-prompt t (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 + (if (vectorp update) + (progn + (find-file (elt update 0)) + (etags-goto-tag-location (elt update 1)))) + (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 + (let* ((regexp (concat "^\\(" (mapconcat + 'identity + (make-list level "[_a-zA-Z0-9]+") + "::") + "\\)\\(::\\)?")) + (packages (cdr (nth 1 to))) + (methods (cdr (nth 2 to))) + l1 head tail cons1 cons2 ord writeto packs recurse + root-packages root-functions ms many_ms same_name ps + (move-deeper + (function + (lambda (elt) + (cond ((and (string-match regexp (car elt)) + (or (eq ord 1) (match-end 2))) + (setq head (substring (car elt) 0 (match-end 1)) + tail (if (match-end 2) (substring (car elt) + (match-end 2))) + recurse t) + (if (setq cons1 (assoc head writeto)) nil + ;; Need to init new head + (setcdr writeto (cons (list head (list "Packages: ") + (list "Methods: ")) + (cdr writeto))) + (setq cons1 (nth 1 writeto))) + (setq cons2 (nth ord cons1)) ; Either packs or meths + (setcdr cons2 (cons elt (cdr cons2)))) + ((eq ord 2) + (setq root-functions (cons elt root-functions))) + (t + (setq root-packages (cons elt root-packages)))))))) + (setcdr to l1) ; Init to dynamic space + (setq writeto to) + (setq ord 1) + (mapcar move-deeper packages) + (setq ord 2) + (mapcar move-deeper methods) + (if recurse + (mapcar (function (lambda (elt) + (cperl-tags-treeify elt (1+ level)))) + (cdr to))) + ;; Now add back functions removed from display + (mapcar (function (lambda (elt) + (setcdr to (cons elt (cdr to))))) + 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)) + )) + +;;;(x-popup-menu t +;;; '(keymap "Name1" +;;; ("Ret1" "aa") +;;; ("Head1" "ab" +;;; keymap "Name2" +;;; ("Tail1" "x") ("Tail2" "y")))) + +(defun cperl-list-fold (list name limit) + (let (list1 list2 elt1 (num 0)) + (if (<= (length list) limit) list + (setq list1 nil list2 nil) + (while list + (setq num (1+ num) + elt1 (car list) + list (cdr list)) + (if (<= num imenu-max-items) + (setq list2 (cons elt1 list2)) + (setq list1 (cons (cons name + (nreverse list2)) + list1) + list2 (list elt1) + num 1))) + (nreverse (cons (cons name + (nreverse list2)) + list1))))) + +(defun cperl-menu-to-keymap (menu &optional name) + (let (list) + (cons 'keymap + (mapcar + (function + (lambda (elt) + (cond ((listp (cdr elt)) + (setq list (cperl-list-fold + (cdr elt) (car elt) imenu-max-items)) + (cons nil + (cons (car elt) + (cperl-menu-to-keymap list)))) + (t + (list (cdr elt) (car elt)))))) + (cperl-list-fold menu "Root" imenu-max-items))))) + + +(defvar cperl-bad-style-regexp + (mapconcat 'identity + '("[^-\n\t <>=+!.&|(*/'`\"#^][-=+<>!|&^]" ; char sign + "[-<>=+^&|]+[^- \t\n=+<>~]" ; sign+ char + ) + "\\|") + "Finds places such that insertion of a whitespace may help a lot.") + +(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) + "<\\$?\\sw+\\(\\.\\sw+\\)?>" ; <IN> <stdin.h> + "-[a-zA-Z][ \t]+[_$\"'`]" ; -f file + "-[0-9]" ; -5 + "\\+\\+" ; ++var + "--" ; --var + ".->" ; a->b + "->" ; a SPACE ->b + "\\[-" ; a[-1] + "^=" ; =head + "||" + "&&" + "[CBIXSLFZ]<\\(\\sw\\|\\s \\|\\s_\\|[\n]\\)*>" ; C<code like text> + "-[a-zA-Z0-9]+[ \t]*=>" ; -option => value + ;; Unaddressed trouble spots: = -abc, f(56, -abc) --- specialcased below + ;;"[*/+-|&<.]+=" + ) + "\\|") + "If matches at the start of match found by `my-bad-c-style-regexp', +insertion of a whitespace will not help.") + +(defvar found-bad) + +(defun cperl-find-bad-style () + "Find places in the buffer where insertion of a whitespace may help. +Prompts user for insertion of spaces. +Currently it is tuned to C and Perl syntax." + (interactive) + (let (found-bad (p (point))) + (setq last-nonmenu-event 13) ; To disable popup + (beginning-of-buffer) + (map-y-or-n-p "Insert space here? " + (function (lambda (arg) (insert " "))) + 'cperl-next-bad-style + '("location" "locations" "insert a space into") + '((?\C-r (lambda (arg) + (let ((buffer-quit-function + 'exit-recursive-edit)) + (message "Exit with Esc Esc") + (recursive-edit) + t)) ; Consider acted upon + "edit, exit with Esc Esc") + (?e (lambda (arg) + (let ((buffer-quit-function + 'exit-recursive-edit)) + (message "Exit with Esc Esc") + (recursive-edit) + t)) ; Consider acted upon + "edit, exit with Esc Esc")) + t) + (if found-bad (goto-char found-bad) + (goto-char p) + (message "No appropriate place found")))) + +(defun cperl-next-bad-style () + (let (p (not-found t) (point (point)) found) + (while (and not-found + (re-search-forward cperl-bad-style-regexp nil 'to-end)) + (setq p (point)) + (goto-char (match-beginning 0)) + (if (or + (looking-at cperl-not-bad-style-regexp) + ;; Check for a < -b and friends + (and (eq (following-char) ?\-) + (save-excursion + (skip-chars-backward " \t\n") + (memq (preceding-char) '(?\= ?\> ?\< ?\, ?\(, ?\[, ?\{)))) + ;; Now check for syntax type + (save-match-data + (setq found (point)) + (beginning-of-defun) + (let ((pps (parse-partial-sexp (point) found))) + (or (nth 3 pps) (nth 4 pps) (nth 5 pps))))) + (goto-char (match-end 0)) + (goto-char (1- p)) + (setq not-found nil + found-bad found))) + (not not-found))) + + +;;; Getting help +(defvar cperl-have-help-regexp + ;;(concat "\\(" + (mapconcat + 'identity + '("[$@%*&][0-9a-zA-Z_:]+" ; Usual variable + "[$@]\\^[a-zA-Z]" ; Special variable + "[$@][^ \n\t]" ; Special variable + "-[a-zA-Z]" ; File test + "\\\\[a-zA-Z0]" ; Special chars + "[-!&*+,-./<=>?\\\\^|~]+" ; Operator + "[a-zA-Z_0-9:]+" ; symbol or number + "x=" + "#!" + ) + ;;"\\)\\|\\(" + "\\|" + ) + ;;"\\)" + ;;) + "Matches places in the buffer we can find help for.") + +(defvar cperl-message-on-help-error t) + +(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_:]+>")) ; <FH> + (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_:]+>")))) ; <FH> + (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)))))))) + +;;; Stolen from perl-descr.el by Johan Vromans: + +(defvar cperl-doc-buffer " *perl-doc*" + "Where the documentation can be found.") + +(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 + 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=")) + (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_:]+>")) + (setq val "<NAME>"))) +;;; (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]\\)?" + (regexp-quote val) + "\\([ \t([/]\\|$\\)")) + + ;; get the buffer with the documentation text + (cperl-switch-to-doc-buffer) + + ;; lookup in the doc + (goto-char (point-min)) + (let ((case-fold-search nil)) + (list + (if (re-search-forward regexp (point-max) t) + (save-excursion + (beginning-of-line 1) + (let ((lnstart (point))) + (end-of-line) + (message "%s" (buffer-substring lnstart (point))))) + (if cperl-message-on-help-error + (message "No definition for %s" val))))))) + +(defvar cperl-short-docs "Ignore my value" + "# based on '@(#)@ perl-descr.el 1.9 - describe-perl-symbol' [Perl 5] +! 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 current page number of the currently selected output channel. + + The following variables are always local to the current block: + +$1 Match of the 1st set of parentheses in the last match (auto-local). +$2 Match of the 2nd set of parentheses in the last match (auto-local). +$3 Match of the 3rd set of parentheses in the last match (auto-local). +$4 Match of the 4th set of parentheses in the last match (auto-local). +$5 Match of the 5th set of parentheses in the last match (auto-local). +$6 Match of the 6th set of parentheses in the last match (auto-local). +$7 Match of the 7th set of parentheses in the last match (auto-local). +$8 Match of the 8th set of parentheses in the last match (auto-local). +$9 Match of the 9th set of parentheses in the last match (auto-local). +$& The string matched by the last pattern match (auto-local). +$' The string after what was matched by the last match (auto-local). +$` The string before what was matched by the last match (auto-local). + +$( The real gid of this process. +$) The effective gid of this process. +$* Deprecated: Set to 1 to do multiline matching within a string. +$+ The last bracket matched by the last search pattern. +$, 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\". +$< The real uid of this process. +$= The page length of the current output channel. Default is 60 lines. +$> The effective uid of this process. +$? The status returned by the last ``, pipe close or `system'. +$@ The perl error message from the last eval or do @var{EXPR} command. +$ARGV The name of the current file used with <> . +$[ Deprecated: The index of the first element/char in an array/string. +$\\ The output record separator for the print operator. +$] The perl version string as displayed with perl -v. +$^ The name of the current top-of-page format. +$^A The current value of the write() accumulator for format() lines. +$^D The value of the perl debug (-D) flags. +$^E Information about the last system error other than that provided by $!. +$^F The highest system file descriptor, ordinarily 2. +$^H The current set of syntax checks enabled by `use strict'. +$^I The value of the in-place edit extension (perl -i option). +$^L What formats output to perform a formfeed. Default is \f. +$^O The operating system name under which this copy of Perl was built. +$^P Internal debugging flag. +$^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. +$~ The name of the current report format. +% 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. +&NAME(arg0, ...) Subroutine call. Arguments go to @_. ++ Addition. +++ Auto-increment (magical on strings). ++= Addition assignment. +, Comma operator. +- Subtraction. +-- Auto-decrement. +-= 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. +-M Age in days since script started. +-O File is owned by real uid. +-R File is readable by real uid. +-S File is a socket . +-T File is a text file. +-W File is writable by real uid. +-X File is executable by real uid. +-b File is a block special file. +-c File is a character special file. +-d File is a directory. +-e File exists . +-f File is a plain file. +-g File has setgid bit set. +-k File has sticky bit set. +-l File is a symbolic link. +-o File is owned by effective uid. +-p File is a named pipe (FIFO). +-r File is readable by effective uid. +-s File has non-zero size. +-t Tests if filehandle (STDIN by default) is opened to a tty. +-u File has setuid bit set. +-w File is writable by effective uid. +-x File is executable by effective uid. +-z File has zero size. +. Concatenate strings. +.. Alternation, also range operator. +.= Concatenate assignment strings +/ Division. /PATTERN/ioxsmg Pattern match +/= Division assignment. +/PATTERN/ioxsmg Pattern match. +< Numeric less than. <pattern> Glob. See <NAME>, <> as well. +<NAME> Reads line from filehandle NAME. NAME must be bareword/dollar-bareword. +<pattern> Glob. (Unless pattern is bareword/dollar-bareword - see <NAME>) +<> 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. +@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. +\\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 . +\\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). +\\t Tab character (octal 011). +\\u Upcase of next character. See also \\U and \\l, +\\x Hex character, e.g. \\x1b. +^ Bitwise exclusive or. +__END__ End of program source. +__DATA__ End of program source. +__FILE__ Current (source) filename. +__LINE__ Current line in current source. +ARGV Default multi-file input filehandle. <ARGV> 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. +DATA Input filehandle for what follows after __END__ or __DATA__. +accept(NEWSOCKET,GENERICSOCKET) +alarm(SECONDS) +atan2(X,Y) +bind(SOCKET,NAME) +binmode(FILEHANDLE) +caller[(LEVEL)] +chdir(EXPR) +chmod(LIST) +chop[(LIST|VAR)] +chown(LIST) +chroot(FILENAME) +close(FILEHANDLE) +closedir(DIRHANDLE) +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) +defined(EXPR) +delete($ASSOC{KEY}) +die(LIST) +do { ... }|SUBR while|until EXPR executes at least once +do(EXPR|SUBR([LIST])) +dump LABEL +each(ASSOC_ARRAY) +endgrent +endhostent +endnetent +endprotoent +endpwent +endservent +eof[([FILEHANDLE])] +eq String equality. +eval(EXPR) or eval { BLOCK } +exec(LIST) +exit(EXPR) +exp(EXPR) +fcntl(FILEHANDLE,FUNCTION,SCALAR) +fileno(FILEHANDLE) +flock(FILEHANDLE,OPERATION) +for (EXPR;EXPR;EXPR) { ... } +foreach [VAR] (@ARRAY) { ... } +fork +ge String greater than or equal. +getc[(FILEHANDLE)] +getgrent +getgrgid(GID) +getgrnam(NAME) +gethostbyaddr(ADDR,ADDRTYPE) +gethostbyname(NAME) +gethostent +getlogin +getnetbyaddr(ADDR,ADDRTYPE) +getnetbyname(NAME) +getnetent +getpeername(SOCKET) +getpgrp(PID) +getppid +getpriority(WHICH,WHO) +getprotobyname(NAME) +getprotobynumber(NUMBER) +getprotoent +getpwent +getpwnam(NAME) +getpwuid(UID) +getservbyname(NAME,PROTO) +getservbyport(PORT,PROTO) +getservent +getsockname(SOCKET) +getsockopt(SOCKET,LEVEL,OPTNAME) +gmtime(EXPR) +goto LABEL +grep(EXPR,LIST) +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) +kill(LIST) +last [LABEL] +le String less than or equal. +length(EXPR) +link(OLDFILE,NEWFILE) +listen(SOCKET,QUEUESIZE) +local(LIST) +localtime(EXPR) +log(EXPR) +lstat(EXPR|FILEHANDLE|VAR) +lt String less than. +m/PATTERN/iogsmx +mkdir(FILENAME,MODE) +msgctl(ID,CMD,ARG) +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. +next [LABEL] +oct(EXPR) +open(FILEHANDLE[,EXPR]) +opendir(DIRHANDLE,EXPR) +ord(EXPR) +pack(TEMPLATE,LIST) +package Introduces package context. +pipe(READHANDLE,WRITEHANDLE) +pop(ARRAY) +print [FILEHANDLE] [(LIST)] +printf [FILEHANDLE] (FORMAT,LIST) +push(ARRAY,LIST) +q/STRING/ Synonym for 'STRING' +qq/STRING/ Synonym for \"STRING\" +qx/STRING/ Synonym for `STRING` +rand[(EXPR)] +read(FILEHANDLE,SCALAR,LENGTH[,OFFSET]) +readdir(DIRHANDLE) +readlink(EXPR) +recv(SOCKET,SCALAR,LEN,FLAGS) +redo [LABEL] +rename(OLDNAME,NEWNAME) +require [FILENAME | PERL_VERSION] +reset[(EXPR)] +return(LIST) +reverse(LIST) +rewinddir(DIRHANDLE) +rindex(STR,SUBSTR[,OFFSET]) +rmdir(FILENAME) +s/PATTERN/REPLACEMENT/gieoxsm +scalar(EXPR) +seek(FILEHANDLE,POSITION,WHENCE) +seekdir(DIRHANDLE,POS) +select(FILEHANDLE | RBITS,WBITS,EBITS,TIMEOUT) +semctl(ID,SEMNUM,CMD,ARG) +semget(KEY,NSEMS,SIZE,FLAGS) +semop(KEY,...) +send(SOCKET,MSG,FLAGS[,TO]) +setgrent +sethostent(STAYOPEN) +setnetent(STAYOPEN) +setpgrp(PID,PGRP) +setpriority(WHICH,WHO,PRIORITY) +setprotoent(STAYOPEN) +setpwent +setservent(STAYOPEN) +setsockopt(SOCKET,LEVEL,OPTNAME,OPTVAL) +shift[(ARRAY)] +shmctl(ID,CMD,ARG) +shmget(KEY,SIZE,FLAGS) +shmread(ID,VAR,POS,SIZE) +shmwrite(ID,STRING,POS,SIZE) +shutdown(SOCKET,HOW) +sin(EXPR) +sleep[(EXPR)] +socket(SOCKET,DOMAIN,TYPE,PROTOCOL) +socketpair(SOCKET1,SOCKET2,DOMAIN,TYPE,PROTOCOL) +sort [SUBROUTINE] (LIST) +splice(ARRAY,OFFSET[,LENGTH[,LIST]]) +split[(/PATTERN/[,EXPR[,LIMIT]])] +sprintf(FORMAT,LIST) +sqrt(EXPR) +srand(EXPR) +stat(EXPR|FILEHANDLE|VAR) +study[(SCALAR)] +sub [NAME [(format)]] { BODY } or sub [NAME [(format)]]; +substr(EXPR,OFFSET[,LEN]) +symlink(OLDFILE,NEWFILE) +syscall(LIST) +sysread(FILEHANDLE,SCALAR,LENGTH[,OFFSET]) +system(LIST) +syswrite(FILEHANDLE,SCALAR,LENGTH[,OFFSET]) +tell[(FILEHANDLE)] +telldir(DIRHANDLE) +time +times +tr/SEARCHLIST/REPLACEMENTLIST/cds +truncate(FILE|EXPR,LENGTH) +umask[(EXPR)] +undef[(EXPR)] +unless (EXPR) { ... } [ else { ... } ] or EXPR unless EXPR +unlink(LIST) +unpack(TEMPLATE,EXPR) +unshift(ARRAY,LIST) +until (EXPR) { ... } or EXPR until EXPR +utime(LIST) +values(ASSOC_ARRAY) +vec(EXPR,OFFSET,BITS) +wait +waitpid(PID,FLAGS) +wantarray +warn(LIST) +while (EXPR) { ... } or EXPR while EXPR +write[(EXPR|FILEHANDLE)] +x Repeat string or array. +x= Repetition assignment. +y/SEARCHLIST/REPLACEMENTLIST/ +| Bitwise or. +|| Logical or. +~ Unary bitwise complement. +#! OS interpreter indicator. If contains `perl', used for options, and -x. +") + +(defun cperl-switch-to-doc-buffer () + "Go to the perl documentation buffer and insert the documentation." + (interactive) + (let ((buf (get-buffer-create cperl-doc-buffer))) + (if (interactive-p) + (switch-to-buffer-other-window buf) + (set-buffer buf)) + (if (= (buffer-size) 0) + (progn + (insert (documentation-property 'cperl-short-docs + 'variable-documentation)) + (setq buffer-read-only t))))) + +(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.") + + (defun cperl-lazy-install () + (interactive) + (make-variable-buffer-local 'cperl-help-shown) + (if (cperl-val cperl-lazy-help-time) + (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))))) + + (defun cperl-lazy-unstall () + (interactive) + (remove-hook 'post-command-hook 'cperl-lazy-hook) + (cancel-timer cperl-help-timer)) + + (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)) + (cperl-get-help) + (setq cperl-help-shown t)))) + (cperl-lazy-install)))