;;; Corrections made by Ilya Zakharevich ilya@math.mps.ohio-state.edu
;;; XEmacs changes by Peter Arius arius@informatik.uni-erlangen.de
-;; $Id: cperl-mode.el,v 1.29 1996/11/18 23:10:26 ilya Exp ilya $
+;; $Id: cperl-mode.el,v 1.33 1997/03/14 06:45:51 ilya Exp ilya $
;;; To use this mode put the following into your .emacs file:
;;; in your .emacs file. (Emacs rulers do not consider it politically
;;; correct to make whistles enabled by default.)
+;;; DO NOT FORGET to read micro-docs. (available from `Perl' menu). <<<<<<
+;;; or as help on variables `cperl-tips', `cperl-problems', <<<<<<
+;;; `cperl-non-problems', `cperl-praise'. <<<<<<
+
;;; Additional useful commands to put into your .emacs file:
;; (setq auto-mode-alist
;; (setq interpreter-mode-alist (append interpreter-mode-alist
;; '(("miniperl" . perl-mode))))
-;;; The mode information (on C-h m) provides customization help.
+;;; The mode information (on C-h m) provides some customization help.
;;; If you use font-lock feature of this mode, it is advisable to use
;;; either lazy-lock-mode or fast-lock-mode (available on ELisp
;;; archive in files lazy-lock.el and fast-lock.el). I prefer lazy-lock.
;;; Minor updates to `cperl-short-docs'.
;;; Will not consider <<= as start of here-doc.
+;;;; After 1.29
+;;; Added an extra advice to look into Micro-docs. ;-).
+;;; Enclosing of region when you press a closing parenth is regulated by
+;;; `cperl-electric-parens-string'.
+;;; Minor updates to `cperl-short-docs'.
+;;; `initialize-new-tags-table' called only if present (Does this help
+;;; with generation of tags under XEmacs?).
+;;; When creating/updating tag files, new info is written at the old place,
+;;; or at the end (is this a wanted behaviour? I need this in perl build directory).
+
+;;;; After 1.30
+;;; All the keywords from keywords.pl included (maybe with dummy explanation).
+;;; No auto-help inside strings, comment, here-docs, formats, and pods.
+;;; Shrinkwrapping of info, regulated by `cperl-max-help-size',
+;;; `cperl-shrink-wrap-info-frame'.
+;;; Info on variables as well.
+;;; Recognision of HERE-DOCS improved yet more.
+;;; Autonewline works on `}' without warnings.
+;;; Autohelp works again on $_[0].
+
+;;;; After 1.31
+;;; perl-descr.el found its author - hi, Johan!
+;;; Some support for correct indent after here-docs and friends (may
+;;; be superseeded by eminent change to Emacs internals).
+;;; Should work with older Emaxen as well ( `-style stuff removed).
+
+;;;; After 1.32
+
+;;; Started to add support for `syntax-table' property (should work
+;;; with patched Emaxen), controlled by
+;;; `cperl-use-syntax-table-text-property'. Currently recognized:
+;;; All quote-like operators: m, s, y, tr, qq, qw, qx, q,
+;;; // in most frequent context:
+;;; after block or
+;;; ~ { ( = | & + - * ! , ;
+;;; or
+;;; while if unless until and or not xor split grep map
+;;; Here-documents, formats, PODs,
+;;; ${...}
+;;; 'abc$'
+;;; sub a ($); sub a ($) {}
+;;; (provide 'cperl-mode) was missing!
+;;; `cperl-after-expr-p' is now much smarter after `}'.
+;;; `cperl-praise' added to mini-docs.
+;;; Utilities try to support subs-with-prototypes.
+
+;;;; After 1.32.1
+;;; `cperl-after-expr-p' is now much smarter after "() {}" and "word {}":
+;;; if word is "else, map, grep".
+;;; Updated for new values of syntax-table constants.
+;;; Uses `help-char' (at last!) (disabled, does not work?!)
+;;; A couple of regexps where missing _ in character classes.
+;;; -s could be considered as start of regexp, 1../blah/ was not,
+;;; as was not /blah/ at start of file.
+
+;;;; After 1.32.2
+;;; "\C-hv" was wrongly "\C-hf"
+;;; C-hv was not working on `[index()]' because of [] in skip-chars-*.
+;;; `__PACKAGE__' supported.
+;;; Thanks for Greg Badros: `cperl-lazy-unstall' is more complete,
+;;; `cperl-get-help' is made compatible with `query-replace'.
+
+;;;; As of Apr 15, development version of 19.34 supports
+;;;; `syntax-table' text properties. Try setting
+;;;; `cperl-use-syntax-table-text-property'.
+
+;;;; After 1.32.3
+;;; We scan for s{}[] as well.
+;;; We scan for $blah'foo as well.
+;;; The default is to use `syntax-table' text property if Emacs is good enough.
+;;; `cperl-lineup' is put on C-M-| (=C-M-S-\\).
+;;; Start of `cperl-beautify-regexp'.
+
+;;;; After 1.32.4
+;;; `cperl-tags-hier-init' did not work in text-mode.
+;;; `cperl-noscan-files-regexp' had a misprint.
+;;; Generation of Class Hierarchy was broken due to a bug in `x-popup-menu'
+;;; in 19.34.
+
+(defconst cperl-xemacs-p (string-match "XEmacs\\|Lucid" emacs-version))
+\f
(defvar cperl-extra-newline-before-brace nil
"*Non-nil means that if, elsif, while, until, else, for, foreach
and do constructs look like:
Can be overwritten by `cperl-hairy' if nil.")
(defvar cperl-electric-lbrace-space nil
- "*Non-nil (and non-null) means { after $ in CPerl buffers should be preceeded by ` '.
+ "*Non-nil (and non-null) means { after $ in CPerl buffers should be preceded by ` '.
Can be overwritten by `cperl-hairy' if nil.")
-(defvar cperl-electric-parens-string "({[<"
+(defvar cperl-electric-parens-string "({[]})<"
"*String of parentheses that should be electric in CPerl.")
(defvar cperl-electric-parens nil
"*Not-nil means add backreferences to generated `imenu's.
May require patched `imenu' and `imenu-go'.")
+(defvar cperl-max-help-size 66
+ "*Non-nil means shrink-wrapping of info-buffer allowed up to these percents.")
+
+(defvar cperl-shrink-wrap-info-frame t
+ "*Non-nil means shrink-wrapping of info-buffer-frame allowed.")
+
(defvar cperl-info-page "perl"
- "Name of the info page containing perl docs.
+ "*Name of the info page containing perl docs.
Older version of this page was called `perl5', newer `perl'.")
+(defvar cperl-use-syntax-table-text-property
+ (and (not cperl-xemacs-p)
+ (string< "19.34.94" emacs-version)) ; Not all .94 are good, but anyway
+ "*Non-nil means CPerl sets up and uses `syntax-table' text property.")
+
+(defvar cperl-scan-files-regexp "\\.\\([Pp][Llm]\\|xs\\)$"
+ "*Regexp to match files to scan when generating TAGS.")
+
+(defvar cperl-noscan-files-regexp "/\\(\\.\\.?\\|SCCS\\|RCS\\|blib\\)$"
+ "*Regexp to match files/dirs to skip when generating TAGS.")
+
+(defvar cperl-regexp-indent-step nil
+ "*indentation used when beautifying regexps.
+If `nil', the value of `cperl-indent-level' will be used.")
+
\f
;;; Short extra-docs.
This may be confusing, since the regexp s#//#/#\; may be highlighted
as a comment, but it will be recognized as a regexp by the indentation
code. Or the opposite case, when a pod section is highlighted, but
-breaks the indentation of the following code.
+may break the indentation of the following code (though indentation
+should work if the balance of delimiters is not broken by POD).
The main trick (to make $ a \"backslash\") makes constructions like
${aaa} look like unbalanced braces. The only trick I can think of is
Most the time, if you write your own code, you may find an equivalent
\(and almost as readable) expression.
-Try to help it: add comments with embedded quotes to fix CPerl
+Try to help CPerl: add comments with embedded quotes to fix CPerl
misunderstandings about the end of quotation:
$a='500$'; # ';
You won't need it too often. The reason: $ \"quotes\" the following
character (this saves a life a lot of times in CPerl), thus due to
-Emacs parsing rules it does not consider tick after the dollar as a
-closing one, but as a usual character.
+Emacs parsing rules it does not consider tick (i.e., ' ) after a
+dollar as a closing one, but as a usual character.
Now the indentation code is pretty wise. The only drawback is that it
relies on Emacs parsing to find matching parentheses. And Emacs
1 if ( s#//#/# );
will.
+By similar reasons
+ s\"abc\"def\";
+will confuse CPerl a lot.
+
If you still get wrong indentation in situation that you think the
code should be able to parse, try:
`car' before `imenu-choose-buffer-index' in `imenu'.
")
+(defvar cperl-praise 'please-ignore-this-line
+ "RMS asked me to list good things about CPerl. Here they go:
+
+0) It uses the newest `syntax-table' property ;-);
+
+1) It does 99% of Perl syntax correct (as opposed to 80-90% in Perl
+mode - but the latter number may have improved too in last years) even
+without `syntax-table' property; When using this property, it should
+handle 99.995% of lines correct - or somesuch.
+
+2) It is generally belived to be \"the most user-friendly Emacs
+package\" whatever it may mean (I doubt that the people who say similar
+things tried _all_ the rest of Emacs ;-), but this was not a lonely
+voice);
+
+3) Everything is customizable, one-by-one or in a big sweep;
+
+4) It has many easily-accessable \"tools\":
+ a) Can run program, check syntax, start debugger;
+ b) Can lineup vertically \"middles\" of rows, like `=' in
+ a = b;
+ cc = d;
+ c) Can insert spaces where this impoves readability (in one
+ interactive sweep over the buffer);
+ d) Has support for imenu, including:
+ 1) Separate unordered list of \"interesting places\";
+ 2) Separate TOC of POD sections;
+ 3) Separate list of packages;
+ 4) Hierarchical view of methods in (sub)packages;
+ 5) and functions (by the full name - with package);
+ e) Has an interface to INFO docs for Perl; The interface is
+ very flexible, including shrink-wrapping of
+ documentation buffer/frame;
+ f) Has a builtin list of one-line explanations for perl constructs.
+ g) Can show these explanations if you stay long enough at the
+ corresponding place (or on demand);
+ h) Has an enhanced fontification (using 3 or 4 additional faces
+ comparing to font-lock - basically, different
+ namespaces in Perl have different colors);
+ i) Can construct TAGS basing on its knowledge of Perl syntax,
+ the standard menu has 6 different way to generate
+ TAGS (if by directory, .xs files - with C-language
+ bindings - are included in the scan);
+ j) Can build a hierarchical view of classes (via imenu) basing
+ on generated TAGS file;
+ k) Has electric parentheses, electric newlines, uses Abbrev
+ for electric logical constructs
+ while () {}
+ with different styles of expansion (context sensitive
+ to be not so bothering). Electric parentheses behave
+ \"as they should\" in a presence of a visible region.
+ l) Changes msb.el \"on the fly\" to insert a group \"Perl files\";
+
+5) The indentation engine was very smart, but most of tricks may be
+not needed anymore with the support for `syntax-table' property. Has
+progress indicator for indentation (with `imenu' loaded).
+
+6) Indent-region improves inline-comments as well;
+
+7) Fill-paragraph correctly handles multi-line comments;
+")
+
\f
;;; Portability stuff:
-(defconst cperl-xemacs-p (string-match "XEmacs\\|Lucid" emacs-version))
(defmacro cperl-define-key (fsf-key definition &optional xemacs-key)
- `(define-key cperl-mode-map
- ,(if xemacs-key
- `(if cperl-xemacs-p ,xemacs-key ,fsf-key)
- fsf-key)
- ,definition))
+ (` (define-key cperl-mode-map
+ (, (if xemacs-key
+ (` (if cperl-xemacs-p (, xemacs-key) (, fsf-key)))
+ fsf-key))
+ (, definition))))
(defvar del-back-ch (car (append (where-is-internal 'delete-backward-char)
(where-is-internal 'backward-delete-char-untabify)))
(cperl-define-key "\C-c\C-k" 'cperl-toggle-abbrev)
(cperl-define-key "\C-c\C-e" 'cperl-toggle-electric)
(cperl-define-key "\e\C-q" 'cperl-indent-exp) ; Usually not bound
+ (cperl-define-key [?\C-\M-\|] 'cperl-lineup)
;;(cperl-define-key "\M-q" 'cperl-fill-paragraph)
;;(cperl-define-key "\e;" 'cperl-indent-for-comment)
(cperl-define-key "\177" 'cperl-electric-backspace)
(cperl-define-key "\t" 'cperl-indent-command)
;; don't clobber the backspace binding:
- (cperl-define-key "\C-hf" 'cperl-info-on-command [(control h) f])
(cperl-define-key "\C-c\C-hf" 'cperl-info-on-current-command
[(control c) (control h) f])
- (cperl-define-key "\C-hv" 'cperl-get-help [(control h) v])
+ (cperl-define-key "\C-hf"
+ ;;(concat (char-to-string help-char) "f") ; does not work
+ 'cperl-info-on-command
+ [(control h) f])
+ (cperl-define-key "\C-hv"
+ ;;(concat (char-to-string help-char) "v") ; does not work
+ 'cperl-get-help
+ [(control h) v])
(if (and cperl-xemacs-p
(<= emacs-minor-version 11) (<= emacs-major-version 19))
(progn
["Mark function" mark-defun t]
["Indent expression" cperl-indent-exp t]
["Fill paragraph/comment" cperl-fill-paragraph t]
+ "----"
["Line up a construction" cperl-lineup (cperl-use-region-p)]
+ ["Beautify a regexp" cperl-beautify-regexp
+ cperl-use-syntax-table-text-property]
"----"
["Indent region" cperl-indent-region (cperl-use-region-p)]
["Comment region" cperl-comment-region (cperl-use-region-p)]
("Micro-docs"
["Tips" (describe-variable 'cperl-tips) t]
["Problems" (describe-variable 'cperl-problems) t]
- ["Non-problems" (describe-variable 'cperl-non-problems) t]))))
+ ["Non-problems" (describe-variable 'cperl-non-problems) t]
+ ["Praise" (describe-variable 'cperl-praise) t]))))
(error nil))
(autoload 'c-macro-expand "cmacexp"
(defvar cperl-mode-syntax-table nil
"Syntax table in use in Cperl-mode buffers.")
+(defvar cperl-string-syntax-table nil
+ "Syntax table in use in Cperl-mode string-like chunks.")
+
(if cperl-mode-syntax-table
()
(setq cperl-mode-syntax-table (make-syntax-table))
(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))
+ (modify-syntax-entry ?| "." cperl-mode-syntax-table)
+ (setq cperl-string-syntax-table (copy-syntax-table cperl-mode-syntax-table))
+ (modify-syntax-entry ?$ "." cperl-string-syntax-table)
+ (modify-syntax-entry ?# "." cperl-string-syntax-table) ; (?# comment )
+)
\f
is nil. It is also possible to switch this on/off from the
menu. Requires `run-with-idle-timer'.
+Use \\[cperl-lineup] to vertically lineup some construction - put the
+beginning of the region at the start of construction, and make region
+span the needed amount of lines.
+
Variables `cperl-pod-here-scan', `cperl-pod-here-fontify',
`cperl-pod-face', `cperl-pod-head-face' control processing of pod and
here-docs sections. In a future version results of scan may be used
(make-local-variable 'comment-start-skip)
(setq comment-start-skip "#+ *")
(make-local-variable 'defun-prompt-regexp)
- (setq defun-prompt-regexp "^[ \t]*sub[ \t]+\\([^ \t\n{;]+\\)[ \t]*")
+ (setq defun-prompt-regexp "^[ \t]*sub[ \t]+\\([^ \t\n{(;]+\\)[ \t]*")
(make-local-variable 'comment-indent-function)
(setq comment-indent-function 'cperl-comment-indent)
(make-local-variable 'parse-sexp-ignore-comments)
'((perl-font-lock-keywords
perl-font-lock-keywords-1
perl-font-lock-keywords-2))))
+ (if cperl-use-syntax-table-text-property
+ (progn
+ (make-variable-buffer-local 'parse-sexp-lookup-properties)
+ (setq parse-sexp-lookup-properties t)))
(or (fboundp 'cperl-old-auto-fill-mode)
(progn
(fset 'cperl-old-auto-fill-mode (symbol-function 'auto-fill-mode))
(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 cperl-auto-newline
+ (setq insertpos (1- (point))))
(if (and cperl-auto-newline (null only-before))
(progn
(newline)
(skip-chars-backward "$")
(looking-at "\\(\\$\\$\\)*\\$\\([^\\$]\\|$\\)"))
(insert ? ))
- (if (cperl-after-expr-p nil "{};)") nil (setq cperl-auto-newline nil))
+ (if (cperl-after-expr-p nil "{;)") nil (setq cperl-auto-newline nil))
(cperl-electric-brace arg)
(and (cperl-val 'cperl-electric-parens)
(eq last-command-char ?{)
(>= (save-excursion (cperl-to-comment-or-eol) (point)) (point))
;;(not (save-excursion (search-backward "#" beg t)))
(if (eq last-command-char ?<)
- (cperl-after-expr-p nil "{};(,:=")
+ (cperl-after-expr-p nil "{;(,:=")
1))
(progn
(insert last-command-char)
(interactive "P")
(let ((beg (save-excursion (beginning-of-line) (point)))
(other-end (if (and cperl-electric-parens-mark
+ (cperl-val 'cperl-electric-parens)
+ (memq last-command-char
+ (append cperl-electric-parens-string nil))
(cperl-mark-active)
(< (mark) (point)))
(mark)
(dollar (eq last-command-char ?$)))
(and (save-excursion
(backward-sexp 1)
- (cperl-after-expr-p nil "{};:"))
+ (cperl-after-expr-p nil "{;:"))
(save-excursion
(not
(re-search-backward
(let ((beg (save-excursion (beginning-of-line) (point))))
(and (save-excursion
(backward-sexp 1)
- (cperl-after-expr-p nil "{};:"))
+ (cperl-after-expr-p nil "{;:"))
(save-excursion
(not
(re-search-backward
(setq indent (cperl-calculate-indent nil symbol))
(beginning-of-line)
(setq beg (point))
- (cond ((eq indent nil)
+ (cond ((or (eq indent nil) (eq indent t))
(setq indent (current-indentation)))
;;((eq indent t) ; Never?
;; (setq indent (cperl-calculate-indent-within-comment)))
(t
(skip-chars-forward " \t")
(if (listp indent) (setq indent (car indent)))
- (cond ((looking-at "[A-Za-z]+:[^:]")
+ (cond ((looking-at "[A-Za-z_][A-Za-z_0-9]*:[^:]")
(and (> indent 0)
(setq indent (max cperl-min-label-indent
(+ indent cperl-label-offset)))))
(progn
(backward-sexp)
(looking-at
- "sub[ \t]+[a-zA-Z0-9_:]+[ \t\n\f]*[#{]")))))))))
+ "sub[ \t]+[a-zA-Z0-9_:]+[ \t\n\f]*\\(([^()]*)[ \t\n\f]*\\)?[#{]")))))))))
+
+(defvar cperl-look-for-prop '((pod in-pod) (here-doc-delim here-doc-group)))
(defun cperl-calculate-indent (&optional parse-start symbol)
"Return appropriate indentation for current line as Perl code.
In usual case returns an integer: the column to indent to.
Returns nil if line starts inside a string, t if in a comment."
(save-excursion
- (if (memq (get-text-property (point) 'syntax-type) '(pod here-doc)) nil
- (beginning-of-line)
- (let* ((indent-point (point))
- (case-fold-search nil)
+ (if (or
+ (memq (get-text-property (point) 'syntax-type)
+ '(pod here-doc here-doc-delim format))
+ ;; before start of POD - whitespace found since do not have 'pod!
+ (and (looking-at "[ \t]*\n=")
+ (error "Spaces before pod section!")))
+ nil
+ (beginning-of-line)
+ (let ((indent-point (point))
+ (char-after (save-excursion
+ (skip-chars-forward " \t")
+ (following-char)))
+ (in-pod (get-text-property (point) 'in-pod))
+ (pre-indent-point (point))
+ p prop look-prop)
+ (cond
+ (in-pod
+ ;; In the verbatim part, probably code example. What to do???
+ )
+ (t
+ (save-excursion
+ ;; Not in pod
+ (cperl-backward-to-noncomment nil)
+ (setq p (max (point-min) (1- (point)))
+ prop (get-text-property p 'syntax-type)
+ look-prop (or (nth 1 (assoc prop cperl-look-for-prop))
+ 'syntax-type))
+ (if (memq prop '(pod here-doc format here-doc-delim))
+ (progn
+ (goto-char (or (previous-single-property-change p look-prop)
+ (point-min)))
+ (beginning-of-line)
+ (setq pre-indent-point (point)))))))
+ (goto-char pre-indent-point)
+ (let* ((case-fold-search nil)
(s-s (cperl-get-state))
(start (nth 0 s-s))
(state (nth 1 s-s))
(containing-sexp (car (cdr state)))
- (char-after (save-excursion
- (skip-chars-forward " \t")
- (following-char)))
(start-indent (save-excursion
(goto-char start)
(- (current-indentation)
(t
;; Statement level. Is it a continuation or a new statement?
;; Find previous non-comment character.
- (goto-char indent-point)
+ (goto-char pre-indent-point)
(cperl-backward-to-noncomment containing-sexp)
;; Back up over label lines, since they don't
;; affect whether our line is a continuation.
(skip-chars-backward " \t")
(if (and (eq (preceding-char) ?b)
(progn
- (forward-word -1)
+ (forward-sexp -1)
(looking-at "sub\\>"))
(setq old-indent
(nth 1
;; If line starts with label, calculate label indentation
(if (save-excursion
(beginning-of-line)
- (looking-at "[ \t]*[a-zA-Z_][a-zA-Z_]*:[^:]"))
+ (looking-at "[ \t]*[a-zA-Z_][a-zA-Z_0-9]*:[^:]"))
(if (> (current-indentation) cperl-min-label-indent)
(- (current-indentation) cperl-label-offset)
(cperl-calculate-indent
(if (and parse-start (<= parse-start (point)))
parse-start)))
- (current-indentation)))))))))))))
+ (current-indentation))))))))))))))
(defvar cperl-indent-alist
'((string nil)
;; If line starts with label, calculate label indentation
(if (save-excursion
(beginning-of-line)
- (looking-at "[ \t]*[a-zA-Z_][a-zA-Z_]*:[^:]"))
+ (looking-at "[ \t]*[a-zA-Z_][a-zA-Z_0-9]*:[^:]"))
(if (> (current-indentation) cperl-min-label-indent)
(- (current-indentation) cperl-label-offset)
(cperl-calculate-indent
Returns true if comment is found."
(let (state stop-in cpoint (lim (progn (end-of-line) (point))))
(beginning-of-line)
- (if (re-search-forward "\\=[ \t]*\\(#\\|$\\)" lim t)
+ (if (or
+ (eq (get-text-property (point) 'syntax-type) 'pod)
+ (re-search-forward "\\=[ \t]*\\(#\\|$\\)" lim t))
(if (eq (preceding-char) ?\#) (progn (backward-char 1) t))
;; Else
(while (not stop-in)
)
(nth 4 state))))
+(defsubst cperl-1- (p)
+ (max (point-min) (1- p)))
+
+(defsubst cperl-1+ (p)
+ (min (point-max) (1+ p)))
+
+(defvar cperl-st-cfence '(14)) ; Comment-fence
+(defvar cperl-st-sfence '(15)) ; String-fence
+(defvar cperl-st-punct '(1))
+(defvar cperl-st-word '(2))
+
+(defun cperl-protect-defun-start (s e)
+ ;; C code looks for "^\\s(" to skip comment backward in "hard" situations
+ (save-excursion
+ (goto-char s)
+ (while (re-search-forward "^\\s(" e 'to-end)
+ (put-text-property (1- (point)) (point) 'syntax-table cperl-st-punct))))
+
+(defun cperl-commentify (bb e string)
+ (if cperl-use-syntax-table-text-property
+ (progn
+ ;; We suppose that e is _after_ the end of construction, as after eol.
+ (setq string (if string cperl-st-sfence cperl-st-cfence))
+ (put-text-property bb (1+ bb) 'syntax-table string)
+ (put-text-property bb (1+ bb) 'rear-nonsticky t)
+ (put-text-property (1- e) e 'syntax-table string)
+ (put-text-property (1- e) e 'rear-nonsticky t)
+ (if (and (eq string cperl-st-sfence) (> (- e 2) bb))
+ (put-text-property (1+ bb) (1- e)
+ 'syntax-table cperl-string-syntax-table))
+ (cperl-protect-defun-start bb e))))
+
(defun cperl-find-pods-heres (&optional min max)
"Scans the buffer for POD sections and here-documents.
If `cperl-pod-here-fontify' is not-nil after evaluation, will fontify
(interactive)
(or min (setq min (point-min)))
(or max (setq max (point-max)))
- (let (face head-face here-face b e bb tag qtag err b1 e1 argument
+ (let (face head-face here-face b e bb tag qtag err b1 e1 argument st i c
(cperl-pod-here-fontify (eval cperl-pod-here-fontify))
(case-fold-search nil) (inhibit-read-only t) (buffer-undo-list t)
(modified (buffer-modified-p))
(after-change-functions nil)
+ (state-point (point-min)) state
(search
(concat
"\\(\\`\n?\\|\n\n\\)="
"\\|"
;; One extra () before this:
- "<<\\(\\([\"'`]\\)\\([^\"'`\n]*\\)\\3\\|\\(\\([a-zA-Z_][a-zA-Z_0-9]*\\)?\\)[^=]\\)" ; [^=] to avoid <<=.
+ "<<"
+ "\\("
+ ;; First variant "BLAH" or just ``.
+ "\\([\"'`]\\)"
+ "\\([^\"'`\n]*\\)"
+ "\\3"
+ "\\|"
+ ;; Second variant: Identifier or empty
+ "\\(\\([a-zA-Z_][a-zA-Z_0-9]*\\)?\\)"
+ ;; Check that we do not have <<= or << 30 or << $blah.
+ "\\([^= \t$@%&]\\|[ \t]+[^ \t\n0-9$@%&]\\)"
+ "\\)"
"\\|"
- ;; 1+5 extra () before this:
- "^[ \t]*format[ \t]*\\([a-zA-Z0-9_]+\\)?[ \t]*=[ \t]*$")))
+ ;; 1+6 extra () before this:
+ "^[ \t]*\\(format\\)[ \t]*\\([a-zA-Z0-9_]+\\)?[ \t]*=[ \t]*$"
+ (if cperl-use-syntax-table-text-property
+ (concat
+ "\\|"
+ ;; 1+6+2=9 extra () before this:
+ "\\<\\(q[wxq]?\\|[msy]\\|tr\\)\\>"
+ "\\|"
+ ;; 1+6+2+1=10 extra () before this:
+ "\\([?/]\\)" ; /blah/ or ?blah?
+ "\\|"
+ ;; 1+6+2+1+1=11 extra () before this:
+ "\\<sub\\>[ \t]*\\([a-zA-Z_:'0-9]+[ \t]*\\)?\\(([^()]*)\\)"
+ "\\|"
+ ;; 1+6+2+1+1+2=13 extra () before this:
+ "\\$\\(['{]\\)"
+ "\\|"
+ ;; 1+6+2+1+1+2+1=14 extra () before this:
+ "\\(\\<sub[ \t\n\f]+\\|[&*$@%]\\)[a-zA-Z0-9_]*'")
+ ""))))
(unwind-protect
(progn
(save-excursion
(setq face cperl-pod-face
head-face cperl-pod-head-face
here-face cperl-here-face))
- (remove-text-properties min max '(syntax-type t))
+ (remove-text-properties min max
+ '(syntax-type t in-pod t syntax-table t))
;; Need to remove face as well...
(goto-char min)
(while (re-search-forward search max t)
;; "\\(\\`\n?\\|\n\n\\)="
(if (looking-at "\n*cut\\>")
(progn
- (message "=cut is not preceeded by a pod section")
- (setq err (point)))
+ (message "=cut is not preceded by a pod section")
+ (or err (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)
+ (progn
+ (message "Cannot find the end of a pod section")
+ (or err (setq err b))))
+ (beginning-of-line 2) ; An empty line after =cut is not POD!
(setq e (point))
(put-text-property b e 'in-pod t)
(goto-char b)
(while (re-search-forward "\n\n[ \t]" e t)
+ ;; We start 'pod 1 char earlier to include the preceding line
(beginning-of-line)
- (put-text-property b (point) 'syntax-type 'pod)
+ (put-text-property (cperl-1- b) (point) 'syntax-type 'pod)
(cperl-put-do-not-fontify b (point))
;;(put-text-property (max (point-min) (1- b))
;; (point) cperl-do-not-fontify t)
(re-search-forward "\n\n[^ \t\f\n]" e 'toend)
(beginning-of-line)
(setq b (point)))
- (put-text-property (point) e 'syntax-type 'pod)
+ (put-text-property (cperl-1- (point)) e 'syntax-type 'pod)
(cperl-put-do-not-fontify (point) e)
;;(put-text-property (max (point-min) (1- (point)))
;; e cperl-do-not-fontify t)
(progn (put-text-property (point) e 'face face)
(goto-char bb)
(if (looking-at
- "=[a-zA-Z0-9]+\\>[ \t]*\\(\\(\n?[^\n]\\)+\\)$")
+ "=[a-zA-Z0-9_]+\\>[ \t]*\\(\\(\n?[^\n]\\)+\\)$")
(put-text-property
(match-beginning 1) (match-end 1)
'face head-face))
(while (re-search-forward
;; One paragraph
- "\n\n=[a-zA-Z0-9]+\\>[ \t]*\\(\\(\n?[^\n]\\)+\\)$"
+ "\n\n=[a-zA-Z0-9_]+\\>[ \t]*\\(\\(\n?[^\n]\\)+\\)$"
e 'toend)
(put-text-property
(match-beginning 1) (match-end 1)
'face head-face))))
+ (cperl-commentify bb e nil)
(goto-char e)))
;; Here document
+ ;; We do only one here-per-line
;; 1 () ahead
;; "<<\\(\\([\"'`]\\)\\([^\"'`\n]*\\)\\3\\|\\(\\([a-zA-Z_][a-zA-Z_0-9]*\\)?\\)\\)"
((match-beginning 2) ; 1 + 1
- ;; Abort in comment (_extremely_ simplified):
+ ;; Abort in comment:
(setq b (point))
- (if (save-excursion
- (beginning-of-line)
- (search-forward "#" b t))
- nil
+ (setq state (parse-partial-sexp state-point b nil nil state)
+ state-point b)
+ (if ;;(save-excursion
+ ;; (beginning-of-line)
+ ;; (search-forward "#" b t))
+ (or (nth 3 state) (nth 4 state))
+ (goto-char (match-end 2))
(if (match-beginning 5) ;4 + 1
(setq b1 (match-beginning 5) ; 4 + 1
e1 (match-end 5)) ; 4 + 1
;; cperl-do-not-fontify t)
(put-text-property b (match-beginning 0)
'face here-face)))
+ (setq e1 (cperl-1+ (match-end 0)))
(put-text-property b (match-beginning 0)
'syntax-type 'here-doc)
- (cperl-put-do-not-fontify b (match-beginning 0)))
- (t (message "End of here-document `%s' not found." tag)))))
+ (put-text-property (match-beginning 0) e1
+ 'syntax-type 'here-doc-delim)
+ (put-text-property b e1
+ 'here-doc-group t)
+ (cperl-commentify b e1 nil)
+ (cperl-put-do-not-fontify b (match-end 0)))
+ (t (message "End of here-document `%s' not found." tag)
+ (or err (setq err b))))))
;; format
- (t
- ;; 1+5=6 extra () before this:
- ;; "^[ \t]*format[ \t]*\\([a-zA-Z0-9_]+\\)?[ \t]*=[ \t]*$")))
+ ((match-beginning 8)
+ ;; 1+6=7 extra () before this:
+ ;;"^[ \t]*\\(format\\)[ \t]*\\([a-zA-Z0-9_]+\\)?[ \t]*=[ \t]*$"
(setq b (point)
- name (if (match-beginning 7) ; 6 + 1
- (buffer-substring (match-beginning 7) ; 6 + 1
- (match-end 7)) ; 6 + 1
+ name (if (match-beginning 8) ; 7 + 1
+ (buffer-substring (match-beginning 8) ; 7 + 1
+ (match-end 8)) ; 7 + 1
""))
(setq argument nil)
(if cperl-pod-here-fontify
(end-of-line)
(put-text-property b1 (point)
'face font-lock-string-face)
+ (cperl-commentify b1 (point) nil)
(cperl-put-do-not-fontify b1 (point)))))
(re-search-forward (concat "^[.;]$") max 'toend))
(beginning-of-line)
(progn
(put-text-property (point) (+ (point) 2)
'face font-lock-string-face)
+ (cperl-commentify (point) (+ (point) 2) nil)
(cperl-put-do-not-fontify (point) (+ (point) 2)))
- (message "End of format `%s' not found." name))
+ (message "End of format `%s' not found." name)
+ (or err (setq err b)))
(forward-line)
(put-text-property b (point) 'syntax-type 'format)
;;; (cond ((re-search-forward (concat "^[.;]$") max 'toend)
;;; 'syntax-type 'format)
;;; (cperl-put-do-not-fontify b (match-beginning 0)))
;;; (t (message "End of format `%s' not found." name)))
- )))
+ )
+ ;; Regexp:
+ ((or (match-beginning 10) (match-beginning 11))
+ ;; 1+6+2=9 extra () before this:
+ ;; "\\<\\(qx?\\|[my]\\)\\>"
+ (setq b1 (if (match-beginning 10) 10 11)
+ argument (buffer-substring
+ (match-beginning b1) (match-end b1))
+ b (point)
+ i b
+ c (char-after (match-beginning b1))
+ bb (or
+ (memq (char-after (1- (match-beginning b1)))
+ '(?\$ ?\@ ?\% ?\& ?\*))
+ (and
+ (eq (char-after (1- (match-beginning b1))) ?-)
+ (eq (char-after (match-beginning b1)) ?s))))
+ (or bb
+ (if (eq b1 11) ; bare /blah/ or ?blah?
+ (setq argument ""
+ bb
+ (progn
+ (goto-char (match-beginning b1))
+ (cperl-backward-to-noncomment (point-min))
+ (not (or (memq (preceding-char)
+ (append (if (eq c ?\?)
+ ;; $a++ ? 1 : 2
+ "~{(=|&*!,;"
+ "~{(=|&+-*!,;") nil))
+ (and (eq (preceding-char) ?\})
+ (cperl-after-block-p (point-min)))
+ (and (eq (char-syntax (preceding-char)) ?w)
+ (progn
+ (forward-sexp -1)
+ (looking-at
+ "\\(while\\|if\\|unless\\|until\\|and\\|or\\|not\\|xor\\|split\\|grep\\|map\\)\\>")))
+ (and (eq (preceding-char) ?.)
+ (eq (char-after (- (point) 2)) ?.))
+ (bobp))))
+ b (1- b))))
+ (or bb (setq state (parse-partial-sexp
+ state-point b nil nil state)
+ state-point b))
+ (goto-char b)
+ (if (or bb (nth 3 state) (nth 4 state))
+ (goto-char i)
+ (skip-chars-forward " \t")
+ ;; qtag means two-argument matcher, may be reset to
+ ;; 2 or 3 later if some special quoting is needed.
+ (setq b (point)
+ tag (char-after b)
+ qtag (if (string-match "^\\([sy]\\|tr\\)$" argument) t)
+ e1 (cdr (assoc tag '(( ?\( . ?\) )
+ ( ?\[ . ?\] )
+ ( ?\{ . ?\} )
+ ( ?\< . ?\> )
+ ))))
+ ;; What if tag == ?\\ ????
+ (or st
+ (progn
+ (setq st (make-syntax-table) i 0)
+ (while (< i 256)
+ (modify-syntax-entry i "." st)
+ (setq i (1+ i)))
+ (modify-syntax-entry ?\\ "\\" st)))
+ ;; Whether we have an intermediate point
+ (setq i nil)
+ ;; Prepare the syntax table:
+ (cond
+ ;; $ has TeXish matching rules, so $$ equiv $...
+ ((and qtag
+ (not e1)
+ (eq tag (char-after (cperl-1+ b)))
+ (eq tag (char-after (+ 2 b))))
+ (setq qtag 3)) ; s///
+ ((and qtag
+ (not e1)
+ (eq tag (char-after (cperl-1+ b))))
+ (setq qtag nil)) ; s//blah/, will work anyway
+ ((and (not e1)
+ (eq tag (char-after (cperl-1+ b))))
+ (setq qtag 2)) ; m//
+ ((not e1)
+ (modify-syntax-entry tag "$" st)) ; m/blah/, s/x//, s/x/y/
+ (t ; s{}(), m[]
+ (modify-syntax-entry tag (concat "(" (list e1)) st)
+ (modify-syntax-entry e1 (concat ")" (list tag)) st)))
+ (if (numberp qtag)
+ (forward-char qtag)
+ (condition-case bb
+ (progn
+ (set-syntax-table st)
+ (forward-sexp 1) ; Wrong if m// - taken care of...
+ (if qtag
+ (if e1
+ (progn
+ (setq i (point))
+ (set-syntax-table cperl-mode-syntax-table)
+ (forward-sexp 1)) ; Should be smarter?
+ ;; "$" has funny matching rules
+ (if (/= (char-after (- (point) 2))
+ (preceding-char))
+ (progn
+ ;; Commenting \\ is dangerous, what about ( ?
+ (if (eq (following-char) ?\\) nil
+ (setq i (point)))
+ (forward-char -1)
+ (forward-sexp 1)))
+ )))
+ (error (goto-char (point-max))
+ (message
+ "End of `%s%c ... %c' string not found: %s"
+ argument tag (or e1 tag) bb)
+ (or err (setq err b)))))
+ (set-syntax-table cperl-mode-syntax-table)
+ (if (null i)
+ (cperl-commentify b (point) t)
+ (cperl-commentify b i t)
+ (if (looking-at "\\sw*e") nil ; s///e
+ (cperl-commentify i (point) t)))
+ (if (eq (char-syntax (following-char)) ?w)
+ (forward-word 1)) ; skip modifiers s///s
+ (modify-syntax-entry tag "." st)
+ (if e1 (modify-syntax-entry e1 "." st))))
+ ((match-beginning 13) ; sub with prototypes
+ (setq b (match-beginning 0))
+ (if (memq (char-after (1- b))
+ '(?\$ ?\@ ?\% ?\& ?\*))
+ nil
+ (setq state (parse-partial-sexp
+ state-point (1- b) nil nil state)
+ state-point (1- b))
+ (if (or (nth 3 state) (nth 4 state))
+ nil
+ ;; Mark as string
+ (cperl-commentify (match-beginning 13) (match-end 13) t))
+ (goto-char (match-end 0))))
+ ((and (match-beginning 14)
+ (eq (preceding-char) ?\')) ; $'
+ (setq b (1- (point))
+ state (parse-partial-sexp
+ state-point (1- b) nil nil state)
+ state-point (1- b))
+ (if (nth 3 state) ; in string
+ (progn
+ (put-text-property (1- b) b 'syntax-table cperl-st-punct)
+ (put-text-property (1- b) b 'rear-nonsticky t)))
+ (goto-char (1+ b)))
+ ((match-beginning 14) ; ${
+ (setq bb (match-beginning 0))
+ (put-text-property bb (1+ bb) 'syntax-table cperl-st-punct)
+ (put-text-property bb (1+ bb) 'rear-nonsticky t))
+ (t ; old $abc'efg syntax
+ (setq bb (match-end 0))
+ (put-text-property (1- bb) bb 'syntax-table cperl-st-word))))
;;; (while (re-search-forward "\\(\\`\n?\\|\n\n\\)=" max t)
;;; (if (looking-at "\n*cut\\>")
;;; (progn
-;;; (message "=cut is not preceeded by a pod section")
+;;; (message "=cut is not preceded by a pod section")
;;; (setq err (point)))
;;; (beginning-of-line)
(message "Scan for pods, formats and here-docs completed.")))
(and (buffer-modified-p)
(not modified)
- (set-buffer-modified-p nil)))))
+ (set-buffer-modified-p nil))
+ (set-syntax-table cperl-mode-syntax-table))))
(defun cperl-backward-to-noncomment (lim)
;; Stops at lim or after non-whitespace that is not in comment
(if (< p (point)) (goto-char p))
(setq stop t)))))
+(defun cperl-after-block-p (lim)
+ ;; We suppose that the preceding char is }.
+ (save-excursion
+ (condition-case nil
+ (progn
+ (forward-sexp -1)
+ (cperl-backward-to-noncomment lim)
+ (or (eq (preceding-char) ?\) ) ; if () {}
+ (and (eq (char-syntax (preceding-char)) ?w) ; else {}
+ (progn
+ (forward-sexp -1)
+ (looking-at "\\(else\\|grep\\|map\\)\\>")))
+ (cperl-after-expr-p lim)))
+ (error nil))))
+
(defun cperl-after-expr-p (&optional lim chars test)
"Returns true if the position is good for start of expression.
TEST is the expression to evaluate at the found position. If absent,
-CHARS is a string that contains good characters to have before us."
- (let (stop p)
+CHARS is a string that contains good characters to have before us (however,
+`}' is treated \"smartly\" if it is not in the list)."
+ (let (stop p
+ (lim (or lim (point-min))))
(save-excursion
- (while (and (not stop) (> (point) (or lim 1)))
+ (while (and (not stop) (> (point) lim))
(skip-chars-backward " \t\n\f" lim)
(setq p (point))
(beginning-of-line)
(setq stop t)))
(or (bobp)
(progn
- (backward-char 1)
(if test (eval test)
- (memq (following-char) (append (or chars "{};") nil))))))))
+ (or (memq (preceding-char) (append (or chars "{;") nil))
+ (and (eq (preceding-char) ?\})
+ (cperl-after-block-p lim)))))))))
(defun cperl-backward-to-start-of-continued-exp (lim)
(if (memq (preceding-char) (append ")]}\"'`" nil))
comment-column))
(setq old-comm-indent nil)))
(if (and old-comm-indent
- (= (current-indentation) old-comm-indent))
+ (= (current-indentation) old-comm-indent)
+ (not (eq (get-text-property (point) 'syntax-type) 'pod)))
(let ((comment-column new-comm-indent))
(indent-for-comment)))
(progn
(or comm
(progn
(if (setq old-comm-indent (and (cperl-to-comment-or-eol)
+ (not (eq (get-text-property (point) 'syntax-type) 'pod))
(current-column)))
(progn (indent-for-comment)
(skip-chars-backward " \t")
(imenu-progress-message pm 100)
(message nil)))))
-(defun cperl-slash-is-regexp (&optional pos)
- (save-excursion
- (goto-char (if pos pos (1- (point))))
- (and
- (not (memq (get-text-property (point) 'face)
- '(font-lock-string-face font-lock-comment-face)))
- (cperl-after-expr-p nil nil '
- (or (looking-at "[^]a-zA-Z0-9_)}]")
- (eq (get-text-property (point) 'face)
- 'font-lock-keyword-face))))))
+;;(defun cperl-slash-is-regexp (&optional pos)
+;; (save-excursion
+;; (goto-char (if pos pos (1- (point))))
+;; (and
+;; (not (memq (get-text-property (point) 'face)
+;; '(font-lock-string-face font-lock-comment-face)))
+;; (cperl-after-expr-p nil nil '
+;; (or (looking-at "[^]a-zA-Z0-9_)}]")
+;; (eq (get-text-property (point) 'face)
+;; 'font-lock-keyword-face))))))
;; Stolen from lisp-mode with a lot of improvements
(or (memq (preceding-char) '(?\ ?\t)) (insert " "))))))
(defvar imenu-example--function-name-regexp-perl
- "^\\([ \t]*\\(sub\\|package\\)[ \t\n]+\\([a-zA-Z_0-9:']+\\)[ \t]*\\|=head\\([12]\\)[ \t]+\\([^\n]+\\)$\\)")
+ (concat
+ "^\\("
+ "[ \t]*\\(sub\\|package\\)[ \t\n]+\\([a-zA-Z_0-9:']+\\)[ \t]*\\(([^()]*)[ \t]*\\)?"
+ "\\|"
+ "=head\\([12]\\)[ \t]+\\([^\n]+\\)$"
+ "\\)"))
(defun cperl-imenu-addback (lst &optional isback name)
;; We suppose that the lst is a DAG, unless the first element only
(imenu-progress-message prev-pos)
;;(backward-up-list 1)
(cond
- ((match-beginning 2) ; package or sub
+ ((and
+ (match-beginning 2) ; package or sub
+ ;; Skip if quoted (will not skip multi-line ''-comments :-():
+ (null (get-text-property (match-beginning 1) 'syntax-table))
+ (null (get-text-property (match-beginning 1) 'syntax-type))
+ (null (get-text-property (match-beginning 1) 'in-pod)))
(save-excursion
(goto-char (match-beginning 2))
(setq fchar (following-char))
)
- (setq char (following-char) meth nil)
- (setq p (point))
+ ;; (if (looking-at "([^()]*)[ \t\n\f]*")
+ ;; (goto-char (match-end 0))) ; Messes what follows
+ (setq char (following-char)
+ meth nil
+ p (point))
(while (and ends-ranges (>= p (car ends-ranges)))
;; delete obsolete entries
(setq ends-ranges (cdr ends-ranges) packages (cdr packages)))
(push index index-alist))
(if meth (push index index-meth-alist))
(push index index-unsorted-alist)))
- (t ; Pod section
+ ((match-beginning 5) ; Pod section
;; (beginning-of-line)
(setq index (imenu-example--name-and-position)
- name (buffer-substring (match-beginning 5) (match-end 5)))
+ name (buffer-substring (match-beginning 6) (match-end 6)))
(set-text-properties 0 (length name) nil name)
- (if (eq (char-after (match-beginning 4)) ?2)
+ (if (eq (char-after (match-beginning 5)) ?2)
(setq name (concat " " name)))
(setcar index name)
(setq index1 (cons (concat "=" name) (cdr index)))
"ell\\(\\|dir\\)\\|ime\\(\\|s\\)\\)\\|u\\(c\\(\\|first\\)\\|"
"time\\|mask\\|n\\(pack\\|link\\)\\)\\|v\\(alues\\|ec\\)\\|"
"w\\(a\\(rn\\|it\\(pid\\|\\)\\|ntarray\\)\\|rite\\)\\|"
- "x\\(\\|or\\)\\|__\\(FILE__\\|LINE__\\)"
+ "x\\(\\|or\\)\\|__\\(FILE__\\|LINE__\\|PACKAGE__\\)"
"\\)\\>") 2 'font-lock-type-face)
;; In what follows we use `other' style
;; for nonoverwritable builtins
;; "\\|")
'("-[rwxoRWXOezsfdlpSbctugkTBMAC]\\>\\([ \t]+_\\>\\)?" 0
font-lock-function-name-face keep) ; Not very good, triggers at "[a-z]"
- '("\\<sub[ \t]+\\([^ \t{;]+\\)[ \t]*[{\n]" 1
+ '("\\<sub[ \t]+\\([^ \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)
(let ((perl-dbg-flags "-wc"))
(mode-compile)))
-(defun cperl-info-buffer ()
- ;; Returns buffer with documentation. Creates if missing
- (let ((info (get-buffer "*info-perl*")))
+(defun cperl-info-buffer (type)
+ ;; Returns buffer with documentation. Creates if missing.
+ ;; If TYPE, this vars buffer.
+ ;; Special care is taken to not stomp over an existing info buffer
+ (let* ((bname (if type "*info-perl-var*" "*info-perl*"))
+ (info (get-buffer bname))
+ (oldbuf (get-buffer "*info*")))
(if info info
(save-window-excursion
;; Get Info running
(require 'info)
+ (cond (oldbuf
+ (set-buffer oldbuf)
+ (rename-buffer "*info-perl-tmp*")))
(save-window-excursion
(info))
- (Info-find-node cperl-info-page "perlfunc")
+ (Info-find-node cperl-info-page (if type "perlvar" "perlfunc"))
(set-buffer "*info*")
- (rename-buffer "*info-perl*")
+ (rename-buffer bname)
+ (cond (oldbuf
+ (set-buffer "*info-perl-tmp*")
+ (rename-buffer "*info*")
+ (set-buffer bname)))
+ (make-variable-buffer-local 'window-min-height)
+ (setq window-min-height 2)
(current-buffer)))))
(defun cperl-word-at-point (&optional p)
;; Returns the word at point or at P.
(save-excursion
(if p (goto-char p))
- (require 'etags)
- (funcall (or (and (boundp 'find-tag-default-function)
- find-tag-default-function)
- (get major-mode 'find-tag-default-function)
- ;; XEmacs 19.12 has `find-tag-default-hook'; it is
- ;; automatically used within `find-tag-default':
- 'find-tag-default))))
+ (or (cperl-word-at-point-hard)
+ (progn
+ (require 'etags)
+ (funcall (or (and (boundp 'find-tag-default-function)
+ find-tag-default-function)
+ (get major-mode 'find-tag-default-function)
+ ;; XEmacs 19.12 has `find-tag-default-hook'; it is
+ ;; automatically used within `find-tag-default':
+ 'find-tag-default))))))
(defun cperl-info-on-command (command)
- "Shows documentation for Perl command in other window."
+ "Shows documentation for Perl command in other window.
+If perl-info buffer is shown in some frame, uses this frame.
+Customized by setting variables `cperl-shrink-wrap-info-frame',
+`cperl-max-help-size'."
(interactive
(let* ((default (cperl-word-at-point))
(read (read-string
(let ((buffer (current-buffer))
(cmd-desc (concat "^" (regexp-quote command) "[^a-zA-Z_0-9]")) ; "tr///"
- pos)
+ pos isvar height iniheight frheight buf win fr1 fr2 iniwin not-loner
+ max-height char-height buf-list)
(if (string-match "^-[a-zA-Z]$" command)
(setq cmd-desc "^-X[ \t\n]"))
- (set-buffer (cperl-info-buffer))
+ (setq isvar (string-match "^[$@%]" command)
+ buf (cperl-info-buffer isvar)
+ iniwin (selected-window)
+ fr1 (window-frame iniwin))
+ (set-buffer buf)
(beginning-of-buffer)
- (re-search-forward "^-X[ \t\n]")
- (forward-line -1)
+ (or isvar
+ (progn (re-search-forward "^-X[ \t\n]")
+ (forward-line -1)))
(if (re-search-forward cmd-desc nil t)
(progn
- (setq pos (progn (beginning-of-line)
- (point)))
- (pop-to-buffer (cperl-info-buffer))
+ ;; Go back to beginning of the group (ex, for qq)
+ (if (re-search-backward "^[ \t\n\f]")
+ (forward-line 1))
+ (beginning-of-line)
+ ;; Get some of
+ (setq pos (point)
+ buf-list (list buf "*info-perl-var*" "*info-perl*"))
+ (while (and (not win) buf-list)
+ (setq win (get-buffer-window (car buf-list) t))
+ (setq buf-list (cdr buf-list)))
+ (or (not win)
+ (eq (window-buffer win) buf)
+ (set-window-buffer win buf))
+ (and win (setq fr2 (window-frame win)))
+ (if (or (not fr2) (eq fr1 fr2))
+ (pop-to-buffer buf)
+ (special-display-popup-frame buf) ; Make it visible
+ (select-window win))
+ (goto-char pos) ; Needed (?!).
+ ;; Resize
+ (setq iniheight (window-height)
+ frheight (frame-height)
+ not-loner (< iniheight (1- frheight))) ; Are not alone
+ (cond ((if not-loner cperl-max-help-size
+ cperl-shrink-wrap-info-frame)
+ (setq height
+ (+ 2
+ (count-lines
+ pos
+ (save-excursion
+ (if (re-search-forward
+ "^[ \t][^\n]*\n+\\([^ \t\n\f]\\|\\'\\)" nil t)
+ (match-beginning 0) (point-max)))))
+ max-height
+ (if not-loner
+ (/ (* (- frheight 3) cperl-max-help-size) 100)
+ (setq char-height (frame-char-height))
+ ;; Non-functioning under OS/2:
+ (if (eq char-height 1) (setq char-height 18))
+ ;; Title, menubar, + 2 for slack
+ (- (/ (x-display-pixel-height) char-height) 4)
+ ))
+ (if (> height max-height) (setq height max-height))
+ ;;(message "was %s doing %s" iniheight height)
+ (if not-loner
+ (enlarge-window (- height iniheight))
+ (set-frame-height (window-frame win) (1+ height)))))
(set-window-start (selected-window) pos))
(message "No entry for %s found." command))
- (pop-to-buffer buffer)))
+ ;;(pop-to-buffer buffer)
+ (select-window iniwin)))
(defun cperl-info-on-current-command ()
"Shows documentation for Perl command at point in other window."
(defun cperl-imenu-info-imenu-search ()
(if (looking-at "^-X[ \t\n]") nil
(re-search-backward
- "^\n\\([-a-zA-Z]+\\)[ \t\n]")
+ "^\n\\([-a-zA-Z_]+\\)[ \t\n]")
(forward-line 1)))
(defun cperl-imenu-info-imenu-name ()
imenu-extract-index-name-function
(index-item (save-restriction
(save-window-excursion
- (set-buffer (cperl-info-buffer))
+ (set-buffer (cperl-info-buffer nil))
(setq imenu-create-index-function
'imenu-default-create-index-function
imenu-prev-index-position-function
in subdirectories too."
(interactive)
(let ((cmd "etags")
- (args '("-l" "none" "-r" "/\\<\\(package\\|sub\\)[ \\t]+\\(\\([a-zA-Z0-9:_]*::\\)?\\([a-zA-Z0-9_]+\\)[ \\t]*\\([{#]\\|$\\)\\)/\\4/"))
+ (args '("-l" "none" "-r" "/\\<\\(package\\|sub\\)[ \\t]+\\(\\([a-zA-Z0-9:_]*::\\)?\\([a-zA-Z0-9_]+\\)[ \\t]*\\(([^()]*)[ \t]*\\)?\\([{#]\\|$\\)\\)/\\4/"))
res)
(if add (setq args (cons "-a" args)))
(or files (setq files (list buffer-file-name)))
(erase-buffer)
(setq erase 'ignore)))
(let ((files
- (directory-files file t (if recurse nil "\\.[Pp][Llm]$") t)))
+ (directory-files file t
+ (if recurse nil cperl-scan-files-regexp)
+ t)))
(mapcar (function (lambda (file)
(cond
- ((string-match "/\\.\\.?$" file) nil)
+ ((string-match cperl-noscan-files-regexp file)
+ nil)
((not (file-directory-p file))
- (if (string-match "\\.\\([Pp][Llm]\\|xs\\)$" file)
+ (if (string-match cperl-scan-files-regexp file)
(cperl-write-tags file erase recurse nil t)))
((not recurse) nil)
(t (cperl-write-tags file erase recurse t t)))))
)
(t
(setq xs (string-match "\\.xs$" file))
- (cond ((eq erase 'ignore) nil)
+ (cond ((eq erase 'ignore) (goto-char (point-max)))
(erase (erase-buffer))
(t
(goto-char 1)
(progn
(forward-char 1)
(search-forward "\f\n" nil 'toend)
- (point)))
- (goto-char 1)))))
+ (point))))
+ (goto-char (point-max)))))
(insert (cperl-find-tags file xs))))
(if inbuffer nil ; Delegate to the caller
(save-buffer 0) ; No backup
- (initialize-new-tags-table)))))
+ (if (fboundp 'initialize-new-tags-table) ; Do we need something special in XEmacs?
+ (initialize-new-tags-table))))))
(defvar cperl-tags-hier-regexp-list
- "^\\(\\(package\\)\\>\\|sub\\>[^\n]+::\\|[a-zA-Z_][a-zA-Z_0-9:]*(\C-?[^\n]+::\\|[ \t]*BOOT:\C-?[^\n]+::\\)")
+ (concat
+ "^\\("
+ "\\(package\\)\\>"
+ "\\|"
+ "sub\\>[^\n]+::"
+ "\\|"
+ "[a-zA-Z_][a-zA-Z_0-9:]*(\C-?[^\n]+::" ; XSUB?
+ "\\|"
+ "[ \t]*BOOT:\C-?[^\n]+::" ; BOOT section
+ "\\)"))
(defvar cperl-hierarchy '(() ())
"Global hierarchy of classes")
(setq pos (match-beginning 0)
pack (match-beginning 2))
(beginning-of-line)
- (if (looking-at "\\([^\n]+\\)\C-?\\([^\n]+\\)\C-a\\([0-9]+\\),\\([0-9]+\\)")
+ (if (looking-at (concat
+ "\\([^\n]+\\)"
+ "\C-?"
+ "\\([^\n]+\\)"
+ "\C-a"
+ "\\([0-9]+\\)"
+ ","
+ "\\([0-9]+\\)"))
(progn
(setq ;;str (buffer-substring (match-beginning 1) (match-end 1))
name (buffer-substring (match-beginning 2) (match-end 2))
(if window-system
(x-popup-menu t (nth 2 cperl-hierarchy))
(require 'tmm)
- (tmm-prompt t (nth 2 cperl-hierarchy))))
+ (tmm-prompt (nth 2 cperl-hierarchy))))
(if (and update (listp update))
(progn (while (cdr update) (setq update (cdr update)))
(setq update (car update)))) ; Get the last from the list
(cons (car elt)
(cperl-menu-to-keymap list))))
(t
- (list (cdr elt) (car elt))))))
+ (list (cdr elt) (car elt) t))))) ; t is needed in 19.34
(cperl-list-fold menu "Root" imenu-max-items)))))
\f
(defvar cperl-not-bad-style-regexp
(mapconcat 'identity
'("[^-\t <>=+]\\(--\\|\\+\\+\\)" ; var-- var++
- "[a-zA-Z0-9][|&][a-zA-Z0-9$]" ; abc|def abc&def are often used.
- "&[(a-zA-Z0-9$]" ; &subroutine &(var->field)
+ "[a-zA-Z0-9_][|&][a-zA-Z0-9_$]" ; abc|def abc&def are often used.
+ "&[(a-zA-Z0-9_$]" ; &subroutine &(var->field)
"<\\$?\\sw+\\(\\.\\sw+\\)?>" ; <IN> <stdin.h>
"-[a-zA-Z][ \t]+[_$\"'`]" ; -f file
"-[0-9]" ; -5
"||"
"&&"
"[CBIXSLFZ]<\\(\\sw\\|\\s \\|\\s_\\|[\n]\\)*>" ; C<code like text>
- "-[a-zA-Z0-9]+[ \t]*=>" ; -option => value
+ "-[a-zA-Z_0-9]+[ \t]*=>" ; -option => value
;; Unaddressed trouble spots: = -abc, f(56, -abc) --- specialcased below
;;"[*/+-|&<.]+="
)
;;(concat "\\("
(mapconcat
'identity
- '("[$@%*&][0-9a-zA-Z_:]+" ; Usual variable
+ '("[$@%*&][0-9a-zA-Z_:]+\\([ \t]*[[{]\\)?" ; Usual variable
"[$@]\\^[a-zA-Z]" ; Special variable
"[$@][^ \n\t]" ; Special variable
"-[a-zA-Z]" ; File test
"\\\\[a-zA-Z0]" ; Special chars
+ "^=[a-z][a-zA-Z0-9_]*" ; Pod sections
"[-!&*+,-./<=>?\\\\^|~]+" ; Operator
"[a-zA-Z_0-9:]+" ; symbol or number
"x="
"Matches places in the buffer we can find help for.")
(defvar cperl-message-on-help-error t)
+(defvar cperl-help-from-timer nil)
+
+(defun cperl-word-at-point-hard ()
+ ;; Does not save-excursion
+ ;; Get to the something meaningful
+ (or (eobp) (eolp) (forward-char 1))
+ (re-search-backward "[-a-zA-Z0-9_:!&*+,-./<=>?\\\\^|~$%@]"
+ (save-excursion (beginning-of-line) (point))
+ 'to-beg)
+ ;; (cond
+ ;; ((or (eobp) (looking-at "[][ \t\n{}();,]")) ; Not at a symbol
+ ;; (skip-chars-backward " \n\t\r({[]});,")
+ ;; (or (bobp) (backward-char 1))))
+ ;; Try to backtrace
+ (cond
+ ((looking-at "[a-zA-Z0-9_:]") ; symbol
+ (skip-chars-backward "a-zA-Z0-9_:")
+ (cond
+ ((and (eq (preceding-char) ?^) ; $^I
+ (eq (char-after (- (point) 2)) ?\$))
+ (forward-char -2))
+ ((memq (preceding-char) (append "*$@%&\\" nil)) ; *glob
+ (forward-char -1))
+ ((and (eq (preceding-char) ?\=)
+ (eq (current-column) 1))
+ (forward-char -1))) ; =head1
+ (if (and (eq (preceding-char) ?\<)
+ (looking-at "\\$?[a-zA-Z0-9_:]+>")) ; <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)))
+ (if (looking-at cperl-have-help-regexp)
+ (buffer-substring (match-beginning 0) (match-end 0))))
(defun cperl-get-help ()
"Get one-line docs on the symbol at the point.
The data for these docs is a little bit obsolete and may be in fact longer
than a line. Your contribution to update/shorten it is appreciated."
(interactive)
- (save-excursion
- ;; Get to the something meaningful
- (or (eobp) (eolp) (forward-char 1))
- (re-search-backward "[-a-zA-Z0-9_:!&*+,-./<=>?\\\\^|~$%@]"
- (save-excursion (beginning-of-line) (point))
- 'to-beg)
- ;; (cond
- ;; ((or (eobp) (looking-at "[][ \t\n{}();,]")) ; Not at a symbol
- ;; (skip-chars-backward " \n\t\r({[]});,")
- ;; (or (bobp) (backward-char 1))))
- ;; Try to backtrace
- (cond
- ((looking-at "[a-zA-Z0-9_:]") ; symbol
- (skip-chars-backward "[a-zA-Z0-9_:]")
- (cond
- ((and (eq (preceding-char) ?^) ; $^I
- (eq (char-after (- (point) 2)) ?\$))
- (forward-char -2))
- ((memq (preceding-char) (append "*$@%&\\" nil)) ; *glob
- (forward-char -1)))
- (if (and (eq (preceding-char) ?\<)
- (looking-at "\\$?[a-zA-Z0-9_:]+>")) ; <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))))))))
+ (save-match-data ; May be called "inside" query-replace
+ (save-excursion
+ (let ((word (cperl-word-at-point-hard)))
+ (if word
+ (if (and cperl-help-from-timer ; Bail out if not in mainland
+ (not (string-match "^#!\\|\\\\\\|^=" word)) ; Show help even in comments/strings.
+ (or (memq (get-text-property (point) 'face)
+ '(font-lock-comment-face font-lock-string-face))
+ (memq (get-text-property (point) 'syntax-type)
+ '(pod here-doc format))))
+ nil
+ (cperl-describe-perl-symbol word))
+ (if cperl-message-on-help-error
+ (message "Nothing found for %s..."
+ (buffer-substring (point) (min (+ 5 (point)) (point-max))))))))))
;;; Stolen from perl-descr.el by Johan Vromans:
(defun cperl-describe-perl-symbol (val)
"Display the documentation of symbol at point, a Perl operator."
- ;; We suppose that the current position is at the start of the symbol
- ;; when we convert $_[5] to @_
- (let (;;(fn (perl-symbol-at-point))
- (enable-recursive-minibuffers t)
- ;;val
+ (let ((enable-recursive-minibuffers t)
args-file regexp)
- ;; (interactive
- ;; (let ((fn (perl-symbol-at-point))
- ;; (enable-recursive-minibuffers t)
- ;; val args-file regexp)
- ;; (setq val (read-from-minibuffer
- ;; (if fn
- ;; (format "Symbol (default %s): " fn)
- ;; "Symbol: ")))
- ;; (if (string= val "")
- ;; (setq val fn))
(cond
((string-match "^[&*][a-zA-Z_]" val)
(setq val (concat (substring val 0 1) "NAME")))
- ((looking-at "[$@][a-zA-Z_:0-9]+\\([[{]\\)")
- (if (= ?\[ (char-after (match-beginning 1)))
- (setq val (concat "@" (substring val 1)))
- (setq val (concat "%" (substring val 1)))))
- ((and (string= val "x") (looking-at "x="))
+ ((string-match "^[$@]\\([a-zA-Z_:0-9]+\\)[ \t]*\\[" val)
+ (setq val (concat "@" (substring val 1 (match-end 1)))))
+ ((string-match "^[$@]\\([a-zA-Z_:0-9]+\\)[ \t]*{" val)
+ (setq val (concat "%" (substring val 1 (match-end 1)))))
+ ((and (string= val "x") (string-match "^x=" val))
(setq val "x="))
((string-match "^\\$[\C-a-\C-z]" val)
(setq val (concat "$^" (char-to-string (+ ?A -1 (aref val 1))))))
- ((and (string= "<" val) (looking-at "<\\$?[a-zA-Z0-9_:]+>"))
+ ((string-match "^CORE::" val)
+ (setq val "CORE::"))
+ ((string-match "^SUPER::" val)
+ (setq val "SUPER::"))
+ ((and (string= "<" val) (string-match "^<\\$?[a-zA-Z0-9_:]+>" val))
(setq val "<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]\\)?"
+ (setq regexp (concat "^"
+ "\\([^a-zA-Z0-9_:]+[ \t]+\\)?"
(regexp-quote val)
"\\([ \t([/]\\|$\\)"))
(message "No definition for %s" val)))))))
(defvar cperl-short-docs "Ignore my value"
+ ;; Perl4 version was written by Johan Vromans (jvromans@squirrel.nl)
"# based on '@(#)@ perl-descr.el 1.9 - describe-perl-symbol' [Perl 5]
-! Logical negation.
-!= Numeric inequality.
-!~ Search pattern, substitution, or translation (negated).
+! ... Logical negation.
+... != ... Numeric inequality.
+... !~ ... Search pattern, substitution, or translation (negated).
$! In numeric context: errno. In a string context: error string.
$\" The separator which joins elements of arrays interpolated in strings.
$# The output format for printed numbers. Initial value is %.20g.
-$$ The process number of the perl running this script. Altered (in the child process) by fork().
+$$ Process number of this script. Changes in the fork()ed child process.
$% The current page number of the currently selected output channel.
The following variables are always local to the current block:
$- The number of lines left on the page.
$. The current input line number of the last filehandle that was read.
$/ The input record separator, newline by default.
-$0 The name of the file containing the perl script being executed. May be set
-$: The set of characters after which a string may be broken to fill continuation fields (starting with ^) in a format.
-$; The subscript separator for multi-dimensional array emulation. Default is \"\\034\".
+$0 Name of the file containing the perl script being executed. May be set.
+$: String may be broken after these characters to fill ^-lines in a format.
+$; Subscript separator for multi-dim array emulation. Default \"\\034\".
$< The real uid of this process.
$= The page length of the current output channel. Default is 60 lines.
$> The effective uid of this process.
$^W True if warnings are requested (perl -w flag).
$^X The name under which perl was invoked (argv[0] in C-speech).
$_ The default input and pattern-searching space.
-$| Flag for auto-flush after write/print on the currently selected output channel. Default is 0.
+$| Auto-flush after write/print on the current output channel? Default 0.
$~ The name of the current report format.
-% Modulo division.
-%= Modulo division assignment.
+... % ... Modulo division.
+... %= ... Modulo division assignment.
%ENV Contains the current environment.
%INC List of files that have been require-d or do-ne.
%SIG Used to set signal handlers for various signals.
-& Bitwise and.
-&& Logical and.
-&&= Logical and assignment.
-&= Bitwise and assignment.
-* Multiplication.
-** Exponentiation.
-*NAME Refers to all objects represented by NAME. *NAM1 = *NAM2 makes NAM1 a reference to NAM2.
+... & ... Bitwise and.
+... && ... Logical and.
+... &&= ... Logical and assignment.
+... &= ... Bitwise and assignment.
+... * ... Multiplication.
+... ** ... Exponentiation.
+*NAME Glob: all objects refered by NAME. *NAM1 = *NAM2 aliases NAM1 to NAM2.
&NAME(arg0, ...) Subroutine call. Arguments go to @_.
-+ Addition.
-++ Auto-increment (magical on strings).
-+= Addition assignment.
+... + ... Addition. +EXPR Makes EXPR into scalar context.
+++ Auto-increment (magical on strings). ++EXPR EXPR++
+... += ... Addition assignment.
, Comma operator.
-- Subtraction.
--- Auto-decrement.
--= Subtraction assignment.
+... - ... Subtraction.
+-- Auto-decrement (NOT magical on strings). --EXPR EXPR--
+... -= ... Subtraction assignment.
-A Access time in days since script started.
-B File is a non-text (binary) file.
-C Inode change time in days since script started.
. Concatenate strings.
.. Alternation, also range operator.
.= Concatenate assignment strings
-/ Division. /PATTERN/ioxsmg Pattern match
-/= Division assignment.
+... / ... Division. /PATTERN/ioxsmg Pattern match
+... /= ... Division assignment.
/PATTERN/ioxsmg Pattern match.
-< Numeric less than. <pattern> Glob. See <NAME>, <> as well.
+... < ... 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.
+... << ... Bitwise shift left. << start of HERE-DOCUMENT.
+... <= ... Numeric less than or equal to.
+... <=> ... Numeric compare.
+... = ... Assignment.
+... == ... Numeric equality.
+... =~ ... Search pattern, substitution, or translation
+... > ... Numeric greater than.
+... >= ... Numeric greater than or equal to.
+... >> ... Bitwise shift right.
+... >>= ... Bitwise shift right assignment.
+... ? ... : ... Condition=if-then-else operator. ?PAT? One-time pattern match.
+?PATTERN? One-time pattern match.
@ARGV Command line arguments (not including the command name - see $0).
@INC List of places to look for perl scripts during do/include/use.
@_ Parameter array for subroutines. Also used by split unless in array context.
-\\ Creates a reference to whatever follows, like \$var.
+\\ Creates reference to what follows, like \$var, or quotes non-\w in strings.
\\0 Octal char, e.g. \\033.
\\E Case modification terminator. See \\Q, \\L, and \\U.
-\\L Lowercase until \\E .
-\\U Upcase until \\E .
-\\Q Quote metacharacters until \\E .
+\\L Lowercase until \\E . See also \l, lc.
+\\U Upcase until \\E . See also \u, uc.
+\\Q Quote metacharacters until \\E . See also quotemeta.
\\a Alarm character (octal 007).
\\b Backspace character (octal 010).
\\c Control character, e.g. \\c[ .
\\e Escape character (octal 033).
\\f Formfeed character (octal 014).
-\\l Lowercase of next character. See also \\L and \\u,
-\\n Newline character (octal 012).
-\\r Return character (octal 015).
+\\l Lowercase the next character. See also \\L and \\u, lcfirst.
+\\n Newline character (octal 012 on most systems).
+\\r Return character (octal 015 on most systems).
\\t Tab character (octal 011).
-\\u Upcase of next character. See also \\U and \\l,
+\\u Upcase the next character. See also \\U and \\l, ucfirst.
\\x Hex character, e.g. \\x1b.
-^ Bitwise exclusive or.
-__END__ End of program source.
-__DATA__ End of program source.
+... ^ ... Bitwise exclusive or.
+__END__ Ends program source.
+__DATA__ Ends program source.
__FILE__ Current (source) filename.
__LINE__ Current line in current source.
+__PACKAGE__ Current package.
ARGV Default multi-file input filehandle. <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.
+BEGIN { ... } Immediately executed (during compilation) piece of code.
+END { ... } Pseudo-subroutine executed after the script finishes.
DATA Input filehandle for what follows after __END__ or __DATA__.
accept(NEWSOCKET,GENERICSOCKET)
alarm(SECONDS)
chroot(FILENAME)
close(FILEHANDLE)
closedir(DIRHANDLE)
-cmp String compare.
+... cmp ... String compare.
connect(SOCKET,NAME)
continue of { block } continue { block }. Is executed after `next' or at end.
cos(EXPR)
crypt(PLAINTEXT,SALT)
-dbmclose(ASSOC_ARRAY)
-dbmopen(ASSOC,DBNAME,MODE)
+dbmclose(%HASH)
+dbmopen(%HASH,DBNAME,MODE)
defined(EXPR)
-delete($ASSOC{KEY})
+delete($HASH{KEY})
die(LIST)
do { ... }|SUBR while|until EXPR executes at least once
-do(EXPR|SUBR([LIST]))
+do(EXPR|SUBR([LIST])) (with while|until executes at least once)
dump LABEL
-each(ASSOC_ARRAY)
+each(%HASH)
endgrent
endhostent
endnetent
endpwent
endservent
eof[([FILEHANDLE])]
-eq String equality.
+... eq ... String equality.
eval(EXPR) or eval { BLOCK }
exec(LIST)
exit(EXPR)
for (EXPR;EXPR;EXPR) { ... }
foreach [VAR] (@ARRAY) { ... }
fork
-ge String greater than or equal.
+... ge ... String greater than or equal.
getc[(FILEHANDLE)]
getgrent
getgrgid(GID)
gmtime(EXPR)
goto LABEL
grep(EXPR,LIST)
-gt String greater than.
+... gt ... String greater than.
hex(EXPR)
if (EXPR) { ... } [ elsif (EXPR) { ... } ... ] [ else { ... } ] or EXPR if EXPR
index(STR,SUBSTR[,OFFSET])
int(EXPR)
ioctl(FILEHANDLE,FUNCTION,SCALAR)
join(EXPR,LIST)
-keys(ASSOC_ARRAY)
+keys(%HASH)
kill(LIST)
last [LABEL]
-le String less than or equal.
+... le ... String less than or equal.
length(EXPR)
link(OLDFILE,NEWFILE)
listen(SOCKET,QUEUESIZE)
localtime(EXPR)
log(EXPR)
lstat(EXPR|FILEHANDLE|VAR)
-lt String less than.
+... lt ... String less than.
m/PATTERN/iogsmx
mkdir(FILENAME,MODE)
msgctl(ID,CMD,ARG)
msgrcv(ID,VAR,SIZE,TYPE.FLAGS)
msgsnd(ID,MSG,FLAGS)
my VAR or my (VAR1,...) Introduces a lexical variable ($VAR, @ARR, or %HASH).
-ne String inequality.
+... ne ... String inequality.
next [LABEL]
oct(EXPR)
open(FILEHANDLE[,EXPR])
opendir(DIRHANDLE,EXPR)
-ord(EXPR)
+ord(EXPR) ASCII value of the first char of the string.
pack(TEMPLATE,LIST)
-package Introduces package context.
-pipe(READHANDLE,WRITEHANDLE)
+package NAME Introduces package context.
+pipe(READHANDLE,WRITEHANDLE) Create a pair of filehandles on ends of a pipe.
pop(ARRAY)
print [FILEHANDLE] [(LIST)]
printf [FILEHANDLE] (FORMAT,LIST)
srand(EXPR)
stat(EXPR|FILEHANDLE|VAR)
study[(SCALAR)]
-sub [NAME [(format)]] { BODY } or sub [NAME [(format)]];
+sub [NAME [(format)]] { BODY } sub NAME [(format)]; sub [(format)] {...}
substr(EXPR,OFFSET[,LEN])
symlink(OLDFILE,NEWFILE)
syscall(LIST)
unlink(LIST)
unpack(TEMPLATE,EXPR)
unshift(ARRAY,LIST)
-until (EXPR) { ... } or EXPR until EXPR
+until (EXPR) { ... } EXPR until EXPR
utime(LIST)
-values(ASSOC_ARRAY)
+values(%HASH)
vec(EXPR,OFFSET,BITS)
wait
waitpid(PID,FLAGS)
-wantarray
+wantarray Returns true if the sub/eval is called in list context.
warn(LIST)
-while (EXPR) { ... } or EXPR while EXPR
+while (EXPR) { ... } EXPR while EXPR
write[(EXPR|FILEHANDLE)]
-x Repeat string or array.
-x= Repetition assignment.
+... x ... Repeat string or array.
+x= ... Repetition assignment.
y/SEARCHLIST/REPLACEMENTLIST/
-| Bitwise or.
-|| Logical or.
-~ Unary bitwise complement.
+... | ... Bitwise or.
+... || ... Logical or.
+~ ... Unary bitwise complement.
#! OS interpreter indicator. If contains `perl', used for options, and -x.
+AUTOLOAD {...} Shorthand for `sub AUTOLOAD {...}'.
+CORE:: Prefix to access builtin function if imported sub obscures it.
+SUPER:: Prefix to lookup for a method in @ISA classes.
+DESTROY Shorthand for `sub DESTROY {...}'.
+... EQ ... Obsolete synonym of `eq'.
+... GE ... Obsolete synonym of `ge'.
+... GT ... Obsolete synonym of `gt'.
+... LE ... Obsolete synonym of `le'.
+... LT ... Obsolete synonym of `lt'.
+... NE ... Obsolete synonym of `ne'.
+abs [ EXPR ] absolute value
+... and ... Low-precedence synonym for &&.
+bless REFERENCE [, PACKAGE] Makes reference into an object of a package.
+chomp [LIST] Strips $/ off LIST/$_. Returns count. Special if $/ eq ''!
+chr Converts a number to char with the same ordinal.
+else Part of if/unless {BLOCK} elsif {BLOCK} else {BLOCK}.
+elsif Part of if/unless {BLOCK} elsif {BLOCK} else {BLOCK}.
+exists $HASH{KEY} True if the key exists.
+format [NAME] = Start of output format. Ended by a single dot (.) on a line.
+formline PICTURE, LIST Backdoor into \"format\" processing.
+glob EXPR Synonym of <EXPR>.
+lc [ EXPR ] Returns lowercased EXPR.
+lcfirst [ EXPR ] Returns EXPR with lower-cased first letter.
+map EXPR, LIST or map {BLOCK} LIST Applies EXPR/BLOCK to elts of LIST.
+no PACKAGE [SYMBOL1, ...] Partial reverse for `use'. Runs `unimport' method.
+not ... Low-precedence synonym for ! - negation.
+... or ... Low-precedence synonym for ||.
+pos STRING Set/Get end-position of the last match over this string, see \\G.
+quotemeta [ EXPR ] Quote regexp metacharacters.
+qw/WORD1 .../ Synonym of split('', 'WORD1 ...')
+readline FH Synonym of <FH>.
+readpipe CMD Synonym of `CMD`.
+ref [ EXPR ] Type of EXPR when dereferenced.
+sysopen FH, FILENAME, MODE [, PERM] (MODE is numeric, see Fcntl.)
+tie VAR, PACKAGE, LIST Hide an object behind a simple Perl variable.
+tied Returns internal object for a tied data.
+uc [ EXPR ] Returns upcased EXPR.
+ucfirst [ EXPR ] Returns EXPR with upcased first letter.
+untie VAR Unlink an object from a simple Perl variable.
+use PACKAGE [SYMBOL1, ...] Compile-time `require' with consequent `import'.
+... xor ... Low-precedence synonym for exclusive or.
+prototype \&SUB Returns prototype of the function given a reference.
+=head1 Top-level heading.
+=head2 Second-level heading.
+=head3 Third-level heading (is there such?).
+=over [ NUMBER ] Start list.
+=item [ TITLE ] Start new item in the list.
+=back End list.
+=cut Switch from POD to Perl.
+=pod Switch from Perl to POD.
")
(defun cperl-switch-to-doc-buffer ()
'variable-documentation))
(setq buffer-read-only t)))))
+(defun cperl-beautify-regexp-piece (b e embed)
+ ;; b is before the starting delimiter, e before the ending
+ ;; e should be a marker, may be changed, but remains "correct".
+ (let (s c tmp (m (make-marker)) (m1 (make-marker)) c1 spaces inline)
+ (if (not embed)
+ (goto-char (1+ b))
+ (goto-char b)
+ (cond ((looking-at "(\\?\\\\#") ; badly commented (?#)
+ (forward-char 2)
+ (delete-char 1)
+ (forward-char 1))
+ ((looking-at "(\\?[^a-zA-Z]")
+ (forward-char 3))
+ ((looking-at "(\\?") ; (?i)
+ (forward-char 2))
+ (t
+ (forward-char 1))))
+ (setq c (1- (current-column))
+ c1 (+ c (or cperl-regexp-indent-step cperl-indent-level)))
+ (or (looking-at "[ \t]*[\n#]")
+ (progn
+ (insert "\n")))
+ (goto-char e)
+ (beginning-of-line)
+ (if (re-search-forward "[^ \t]" e t)
+ (progn
+ (goto-char e)
+ (insert "\n")
+ (indent-to-column c)
+ (set-marker e (point))))
+ (goto-char b)
+ (end-of-line 2)
+ (while (< (point) (marker-position e))
+ (beginning-of-line)
+ (setq s (point)
+ inline t)
+ (skip-chars-forward " \t")
+ (delete-region s (point))
+ (indent-to-column c1)
+ (while (and
+ inline
+ (looking-at
+ (concat "\\([a-zA-Z0-9]+[^*+{?]\\)" ; 1
+ "\\|"
+ "\\$\\([a-zA-Z0-9_]+\\([[{]\\)?\\|[^\n \t)|]\\)" ; 2 3
+ "\\|"
+ "[$^]"
+ "\\|"
+ "\\(\\\\.\\|[^][()#|*+?\n]\\)\\([*+{?]\\??\\)?" ; 4 5
+ "\\|"
+ "\\(\\[\\)" ; 6
+ "\\|"
+ "\\((\\(\\?\\)?\\)" ; 7 8
+ "\\|"
+ "\\(|\\)" ; 9
+ )))
+ (goto-char (match-end 0))
+ (setq spaces t)
+ (cond ((match-beginning 1) ; Alphanum word + junk
+ (forward-char -1))
+ ((or (match-beginning 3) ; $ab[12]
+ (and (match-beginning 5) ; X* X+ X{2,3}
+ (eq (preceding-char) ?\{)))
+ (forward-char -1)
+ (forward-sexp 1))
+ ((match-beginning 6) ; []
+ (setq tmp (point))
+ (if (looking-at "\\^?\\]")
+ (goto-char (match-end 0)))
+ (or (re-search-forward "\\]\\([*+{?]\\)?" e t)
+ (progn
+ (goto-char (1- tmp))
+ (error "[]-group not terminated")))
+ (if (not (eq (preceding-char) ?\{)) nil
+ (forward-char -1)
+ (forward-sexp 1)))
+ ((match-beginning 7) ; ()
+ (goto-char (match-beginning 0))
+ (or (eq (current-column) c1)
+ (progn
+ (insert "\n")
+ (indent-to-column c1)))
+ (setq tmp (point))
+ (forward-sexp 1)
+ ;; (or (forward-sexp 1)
+ ;; (progn
+ ;; (goto-char tmp)
+ ;; (error "()-group not terminated")))
+ (set-marker m (1- (point)))
+ (set-marker m1 (point))
+ (cperl-beautify-regexp-piece tmp m t)
+ (goto-char m1)
+ (cond ((looking-at "[*+?]\\??")
+ (goto-char (match-end 0)))
+ ((eq (following-char) ?\{)
+ (forward-sexp 1)
+ (if (eq (following-char) ?\?)
+ (forward-char))))
+ (skip-chars-forward " \t")
+ (setq spaces nil)
+ (if (looking-at "[#\n]")
+ (beginning-of-line 2)
+ (insert "\n"))
+ (end-of-line)
+ (setq inline nil))
+ ((match-beginning 9) ; |
+ (forward-char -1)
+ (setq tmp (point))
+ (beginning-of-line)
+ (if (re-search-forward "[^ \t]" tmp t)
+ (progn
+ (goto-char tmp)
+ (insert "\n"))
+ ;; first at line
+ (delete-region (point) tmp))
+ (indent-to-column c)
+ (forward-char 1)
+ (skip-chars-forward " \t")
+ (setq spaces nil)
+ (if (looking-at "[#\n]")
+ (beginning-of-line 2)
+ (insert "\n"))
+ (end-of-line)
+ (setq inline nil)))
+ (or (looking-at "[ \t\n]")
+ (not spaces)
+ (insert " "))
+ (skip-chars-forward " \t"))
+ (or (looking-at "[#\n]")
+ (error "unknown code in a regexp"))
+ (and inline (end-of-line 2)))
+ ))
+
+(defun cperl-beautify-regexp ()
+ "do it. (Experimental, may change semantics, recheck afterwards.)
+We suppose that the regexp is scanned already."
+ (interactive)
+ (or cperl-use-syntax-table-text-property
+ (error "I need to have regex marked!"))
+ ;; Find the start
+ (re-search-backward "\\s|") ; Assume it is scanned already.
+ ;;(forward-char 1)
+ (let ((b (point)) (e (make-marker)) have-x delim (c (current-column))
+ (sub-p (eq (preceding-char) ?s)) s)
+ (forward-sexp 1)
+ (set-marker e (1- (point)))
+ (setq delim (preceding-char))
+ (if (and sub-p (eq delim (char-after (- (point) 2))))
+ (error "Possible s/blah// - do not know how to deal with"))
+ (if sub-p (forward-sexp 1))
+ (if (looking-at "\\sw*x")
+ (setq have-x t)
+ (insert "x"))
+ ;; Protect fragile " ", "#"
+ (if have-x nil
+ (goto-char (1+ b))
+ (while (re-search-forward "\\(\\=\\|[^\\\\]\\)\\(\\\\\\\\\\)*[ \t\n#]" e t) ; Need to include (?#) too?
+ (forward-char -1)
+ (insert "\\")
+ (forward-char 1)))
+ (cperl-beautify-regexp-piece b e nil)))
+
(if (fboundp 'run-with-idle-timer)
(progn
(defvar cperl-help-shown nil
"Non-nil means that the help was already shown now.")
- (defvar cperl-help-timer nil
- "Non-nil means that the help was already shown now.")
+ (defvar cperl-lazy-installed nil
+ "Non-nil means that the lazy-help handlers are installed now.")
(defun cperl-lazy-install ()
(interactive)
(make-variable-buffer-local 'cperl-help-shown)
- (if (cperl-val cperl-lazy-help-time)
+ (if (and (cperl-val 'cperl-lazy-help-time)
+ (not cperl-lazy-installed))
(progn
(add-hook 'post-command-hook 'cperl-lazy-hook)
- (setq cperl-help-timer
- (run-with-idle-timer
- (cperl-val cperl-lazy-help-time 1000000 5)
- t
- 'cperl-get-help-defer)))))
+ (run-with-idle-timer
+ (cperl-val 'cperl-lazy-help-time 1000000 5)
+ t
+ 'cperl-get-help-defer)
+ (setq cperl-lazy-installed t))))
(defun cperl-lazy-unstall ()
(interactive)
(remove-hook 'post-command-hook 'cperl-lazy-hook)
- (cancel-timer cperl-help-timer))
+ (cancel-function-timers 'cperl-get-help-defer)
+ (setq cperl-lazy-installed nil))
(defun cperl-lazy-hook ()
(setq cperl-help-shown nil))
(defun cperl-get-help-defer ()
(if (not (eq major-mode 'perl-mode)) nil
- (let ((cperl-message-on-help-error nil))
+ (let ((cperl-message-on-help-error nil) (cperl-help-from-timer t))
(cperl-get-help)
(setq cperl-help-shown t))))
(cperl-lazy-install)))
+
+(provide 'cperl-mode)
projects / p5sagit/p5-mst-13.2.git / blobdiff