diff options
Diffstat (limited to 'emacs')
| -rw-r--r-- | emacs/cperl-mode | 710 | ||||
| -rw-r--r-- | emacs/cperl-mode.el | 2566 | ||||
| -rw-r--r-- | emacs/emacs19 | 312 | ||||
| -rw-r--r-- | emacs/perl-mode.el | 631 | ||||
| -rw-r--r-- | emacs/perldb.el | 423 | ||||
| -rw-r--r-- | emacs/perldb.pl | 531 | ||||
| -rw-r--r-- | emacs/tedstuff | 296 |
7 files changed, 2566 insertions, 2903 deletions
diff --git a/emacs/cperl-mode b/emacs/cperl-mode deleted file mode 100644 index eb4aae2ab6..0000000000 --- a/emacs/cperl-mode +++ /dev/null @@ -1,710 +0,0 @@ -Article 15212 of comp.lang.perl: -Path: netlabs!news.cerf.net!usc!howland.reston.ans.net!spool.mu.edu!umn.edu!news-feed-2.peachnet.edu!concert!duke!khera -From: khera@cs.duke.edu (Vivek Khera) -Newsgroups: comp.lang.perl -Subject: cperl-mode.el -Message-ID: <KHERA.93Oct21140851@thneed.cs.duke.edu> -Date: 21 Oct 93 18:08:51 GMT -Sender: news@duke.cs.duke.edu -Organization: Duke University CS Dept., Durham, NC -Lines: 694 -Nntp-Posting-Host: thneed.cs.duke.edu -X-Md4-Signature: 40dd9bccfb99794a9da2ee891b5bf557 -X-Md5-Signature: e4baa8cf00c94092ebf9712514e4696b - -Since I've received requests to do so, I'm posting the cperl-mode.el -file. This allows Emacs (both version 18 and 19) to do nice things -when editing Perl code. Indentation works well, and it doesn't get -confused like the perl-mode.el that comes with Emacs 19. - -Install this file as cperl-mode.el, and add the following to your -.emacs file: - -(autoload 'perl-mode "cperl-mode" "alternate mode for editing Perl programs" t) - -This cperl-mode.el is not exactly the same as when it was originally -posted here. I made the following changes: perl-mode is an alias for -cperl-mode, and the major mode name is perl-mode, not cperl-mode. -This is so it is easier to use with Emacs 19. I suppose one could -install this as perl-mode.el and then not have to put the autoload -line in (for Emacs 19). - -Anyway, I'm not maintaining this, so don't send me bugs. - ---cut here-- -;;; From: olson@mcs.anl.gov (Bob Olson) -;;; Newsgroups: comp.lang.perl -;;; Subject: cperl-mode: Another perl mode for Gnuemacs -;;; 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 part of GNU Emacs. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY. No author or distributor -;; accepts responsibility to anyone for the consequences of using it -;; or for whether it serves any particular purpose or works at all, -;; unless he says so in writing. Refer to the GNU Emacs General Public -;; License for full details. - -;; Everyone is granted permission to copy, modify and redistribute -;; GNU Emacs, but only under the conditions described in the -;; GNU Emacs General Public License. A copy of this license is -;; supposed to have been given to you along with GNU Emacs so you -;; can know your rights and responsibilities. It should be in a -;; file named COPYING. Among other things, the copyright notice -;; and this notice must be preserved on all copies. - - -(defvar cperl-mode-abbrev-table nil - "Abbrev table in use in Cperl-mode buffers.") -(define-abbrev-table 'cperl-mode-abbrev-table ()) - -(defvar cperl-mode-map () - "Keymap used in C mode.") -(if cperl-mode-map - () - (setq cperl-mode-map (make-sparse-keymap)) - (define-key cperl-mode-map "{" 'electric-cperl-brace) - (define-key cperl-mode-map "}" 'electric-cperl-brace) - (define-key cperl-mode-map ";" 'electric-cperl-semi) - (define-key cperl-mode-map ":" 'electric-cperl-terminator) - (define-key cperl-mode-map "\e\C-h" 'mark-cperl-function) - (define-key cperl-mode-map "\e\C-q" 'indent-cperl-exp) - (define-key cperl-mode-map "\177" 'backward-delete-char-untabify) - (define-key cperl-mode-map "\t" 'cperl-indent-command)) - -(autoload 'cperl-macro-expand "cmacexp" - "Display the result of expanding all C macros occurring in the region. -The expansion is entirely correct because it uses the C preprocessor." - t) - -(defvar cperl-mode-syntax-table nil - "Syntax table in use in Cperl-mode buffers.") - -(if cperl-mode-syntax-table - () - (setq cperl-mode-syntax-table (make-syntax-table)) - (modify-syntax-entry ?\\ "\\" cperl-mode-syntax-table) - (modify-syntax-entry ?/ ". 14" cperl-mode-syntax-table) - (modify-syntax-entry ?* ". 23" 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) - (modify-syntax-entry ?% "." 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) - (modify-syntax-entry ?| "." cperl-mode-syntax-table)) - - -(defvar cperl-indent-level 2 - "*Indentation of C statements with respect to containing block.") -(defvar cperl-brace-imaginary-offset 0 - "*Imagined indentation of a C open brace that actually follows a statement.") -(defvar cperl-brace-offset 0 - "*Extra indentation for braces, compared with other text in same context.") -(defvar cperl-argdecl-indent 5 - "*Indentation level of declarations of C function arguments.") -(defvar cperl-label-offset -2 - "*Offset of C label lines and case statements relative to usual indentation.") -(defvar cperl-continued-statement-offset 2 - "*Extra indent for lines not starting new statements.") -(defvar cperl-continued-brace-offset 0 - "*Extra indent for substatements that start with open-braces. -This is in addition to cperl-continued-statement-offset.") - -(defvar cperl-auto-newline nil - "*Non-nil means automatically newline before and after braces, -and after colons and semicolons, inserted in C code.") - -(defvar cperl-tab-always-indent t - "*Non-nil means TAB in C mode should always reindent the current line, -regardless of where in the line point is when the TAB command is used.") - -;; provide an alias for working with emacs 19. the perl-mode that comes -;; with it is really bad, and this lets us seamlessly replace it. -(fset 'perl-mode 'cperl-mode) -(defun cperl-mode () - "Major mode for editing C code. -Expression and list commands understand all C brackets. -Tab indents for C code. -Comments are delimited with /* ... */. -Paragraphs are separated by blank lines only. -Delete converts tabs to spaces as it moves back. -\\{cperl-mode-map} -Variables controlling indentation style: - cperl-tab-always-indent - Non-nil means TAB in C mode should always reindent the current line, - regardless of where in the line point is when the TAB command is used. - cperl-auto-newline - Non-nil means automatically newline before and after braces, - and after colons and semicolons, inserted in C code. - cperl-indent-level - Indentation of C statements within surrounding block. - The surrounding block's indentation is the indentation - of the line on which the open-brace appears. - cperl-continued-statement-offset - Extra indentation given to a substatement, such as the - then-clause of an if or body of a while. - cperl-continued-brace-offset - Extra indentation given to a brace that starts a substatement. - This is in addition to cperl-continued-statement-offset. - cperl-brace-offset - Extra indentation for line if it starts with an open brace. - cperl-brace-imaginary-offset - An open brace following other text is treated as if it were - this far to the right of the start of its line. - cperl-argdecl-indent - Indentation level of declarations of C function arguments. - cperl-label-offset - Extra indentation for line that is a label, or case or default. - -Settings for K&R and BSD indentation styles are - cperl-indent-level 5 8 - cperl-continued-statement-offset 5 8 - cperl-brace-offset -5 -8 - cperl-argdecl-indent 0 8 - cperl-label-offset -5 -8 - -Turning on C mode calls the value of the variable cperl-mode-hook with no args, -if that value is non-nil." - (interactive) - (kill-all-local-variables) - (use-local-map cperl-mode-map) - (setq major-mode 'perl-mode) - (setq mode-name "CPerl") - (setq local-abbrev-table cperl-mode-abbrev-table) - (set-syntax-table cperl-mode-syntax-table) - (make-local-variable 'paragraph-start) - (setq paragraph-start (concat "^$\\|" page-delimiter)) - (make-local-variable 'paragraph-separate) - (setq paragraph-separate paragraph-start) - (make-local-variable 'paragraph-ignore-fill-prefix) - (setq paragraph-ignore-fill-prefix t) - (make-local-variable 'indent-line-function) - (setq indent-line-function 'cperl-indent-line) - (make-local-variable 'require-final-newline) - (setq require-final-newline t) - (make-local-variable 'comment-start) - (setq comment-start "# ") - (make-local-variable 'comment-end) - (setq comment-end "") - (make-local-variable 'comment-column) - (setq comment-column 32) - (make-local-variable 'comment-start-skip) - (setq comment-start-skip "# *") - (make-local-variable 'comment-indent-hook) - (setq comment-indent-hook 'cperl-comment-indent) - (make-local-variable 'parse-sexp-ignore-comments) - (setq parse-sexp-ignore-comments t) - (run-hooks 'cperl-mode-hook)) - -;; This is used by indent-for-comment -;; to decide how much to indent a comment in C code -;; based on its context. -(defun cperl-comment-indent () - (if (looking-at "^#") - 0 ;Existing comment at bol stays there. - (save-excursion - (skip-chars-backward " \t") - (max (1+ (current-column)) ;Else indent at comment column - comment-column)))) ; except leave at least one space. - -(defun electric-cperl-brace (arg) - "Insert character and correct line's indentation." - (interactive "P") - (let (insertpos) - (if (and (not arg) - (eolp) - (or (save-excursion - (skip-chars-backward " \t") - (bolp)) - (if cperl-auto-newline (progn (cperl-indent-line) (newline) t) nil))) - (progn - (insert last-command-char) - (cperl-indent-line) - (if cperl-auto-newline - (progn - (newline) - ;; (newline) may have done auto-fill - (setq insertpos (- (point) 2)) - (cperl-indent-line))) - (save-excursion - (if insertpos (goto-char (1+ insertpos))) - (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 electric-cperl-semi (arg) - "Insert character and correct line's indentation." - (interactive "P") - (if cperl-auto-newline - (electric-cperl-terminator arg) - (self-insert-command (prefix-numeric-value arg)))) - -(defun electric-cperl-terminator (arg) - "Insert character and correct line's indentation." - (interactive "P") - (let (insertpos (end (point))) - (if (and (not arg) (eolp) - (not (save-excursion - (beginning-of-line) - (skip-chars-forward " \t") - (or (= (following-char) ?#) - ;; Colon is special only after a label, or case .... - ;; So quickly rule out most other uses of colon - ;; and do no indentation for them. - (and (eq last-command-char ?:) - (not (looking-at "case[ \t]")) - (save-excursion - (forward-word 1) - (skip-chars-forward " \t") - (< (point) end))) - (progn - (beginning-of-defun) - (let ((pps (parse-partial-sexp (point) end))) - (or (nth 3 pps) (nth 4 pps) (nth 5 pps)))))))) - (progn - (insert last-command-char) - (cperl-indent-line) - (and cperl-auto-newline - (not (cperl-inside-parens-p)) - (progn - (newline) - (setq insertpos (- (point) 2)) - (cperl-indent-line))) - (save-excursion - (if insertpos (goto-char (1+ insertpos))) - (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-inside-parens-p () - (condition-case () - (save-excursion - (save-restriction - (narrow-to-region (point) - (progn (beginning-of-defun) (point))) - (goto-char (point-max)) - (= (char-after (or (scan-lists (point) -1 1) (point-min))) ?\())) - (error nil))) - -(defun cperl-indent-command (&optional whole-exp) - (interactive "P") - "Indent current line as C 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 -or in the line's indentation; otherwise insert a tab. - -A numeric argument, regardless of its value, -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." - (if whole-exp - ;; If arg, always indent this line as C - ;; and shift remaining lines of expression the same amount. - (let ((shift-amt (cperl-indent-line)) - beg end) - (save-excursion - (if cperl-tab-always-indent - (beginning-of-line)) - (setq beg (point)) - (forward-sexp 1) - (setq end (point)) - (goto-char beg) - (forward-line 1) - (setq beg (point))) - (if (> end beg) - (indent-code-rigidly beg end shift-amt "#"))) - (if (and (not cperl-tab-always-indent) - (save-excursion - (skip-chars-backward " \t") - (not (bolp)))) - (insert-tab) - (cperl-indent-line)))) - -(defun cperl-indent-line () - "Indent current line as C code. -Return the amount the indentation changed by." - (let ((indent (calculate-cperl-indent nil)) - beg shift-amt - (case-fold-search nil) - (pos (- (point-max) (point)))) - (beginning-of-line) - (setq beg (point)) - (cond ((eq indent nil) - (setq indent (current-indentation))) - ((eq indent t) - (setq indent (calculate-cperl-indent-within-comment))) - ((looking-at "[ \t]*#") - (setq indent 0)) - (t - (skip-chars-forward " \t") - (if (listp indent) (setq indent (car indent))) - (cond ((or (looking-at "case[ \t]") - (and (looking-at "[A-Za-z]") - (save-excursion - (forward-sexp 1) - (looking-at ":")))) - (setq indent (max 1 (+ indent cperl-label-offset)))) - ((and (looking-at "else\\b") - (not (looking-at "else\\s_"))) - (setq indent (save-excursion - (cperl-backward-to-start-of-if) - (current-indentation)))) - ((= (following-char) ?}) - (setq indent (- indent cperl-indent-level))) - ((= (following-char) ?{) - (setq indent (+ indent cperl-brace-offset)))))) - (skip-chars-forward " \t") - (setq shift-amt (- indent (current-column))) - (if (zerop shift-amt) - (if (> (- (point-max) pos) (point)) - (goto-char (- (point-max) pos))) - (delete-region beg (point)) - (indent-to indent) - ;; If initial point was within line's indentation, - ;; position after the indentation. Else stay at same point in text. - (if (> (- (point-max) pos) (point)) - (goto-char (- (point-max) pos)))) - shift-amt)) - -(defun calculate-cperl-indent (&optional parse-start) - "Return appropriate indentation for current line as C 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 - (beginning-of-line) - (let ((indent-point (point)) - (case-fold-search nil) - state - containing-sexp) - (if parse-start - (goto-char parse-start) - (beginning-of-defun)) - (while (< (point) indent-point) - (setq parse-start (point)) - (setq state (parse-partial-sexp (point) indent-point 0)) - (setq containing-sexp (car (cdr state)))) - (cond ((or (nth 3 state) (nth 4 state)) - ;; return nil or t if should not change this line - (nth 4 state)) - ((null containing-sexp) - ;; Line is at top level. May be data or function definition, - ;; or may be function argument declaration. - ;; Indent like the previous top level line - ;; unless that ends in a closeparen without semicolon, - ;; in which case this line is the first argument decl. - (goto-char indent-point) - (skip-chars-forward " \t") - (if (= (following-char) ?{) - 0 ; Unless it starts a function body - (cperl-backward-to-noncomment (or parse-start (point-min))) - ;; Look at previous line that's at column 0 - ;; to determine whether we are in top-level decls - ;; or function's arg decls. Set basic-indent accordinglu. - (let ((basic-indent - (save-excursion - (re-search-backward "^[^ \^L\t\n#]" nil 'move) - (if (and (looking-at "\\sw\\|\\s_") - (looking-at ".*(") - (progn - (goto-char (1- (match-end 0))) - (forward-sexp 1) - (and (< (point) indent-point) - (not (memq (following-char) - '(?\, ?\;)))))) - cperl-argdecl-indent 0)))) - ;; Now add a little if this is a continuation line. - (+ basic-indent (if (or (bobp) - (memq (preceding-char) '(?\) ?\; ?\}))) - 0 cperl-continued-statement-offset))))) - ((/= (char-after containing-sexp) ?{) - ;; line is expression, not statement: - ;; indent to just after the surrounding open. - (goto-char (1+ containing-sexp)) - (current-column)) - (t - ;; Statement level. Is it a continuation or a new statement? - ;; Find previous non-comment character. - (goto-char indent-point) - (cperl-backward-to-noncomment containing-sexp) - ;; Back up over label lines, since they don't - ;; affect whether our line is a continuation. - (while (or (eq (preceding-char) ?\,) - (and (eq (preceding-char) ?:) - (or (eq (char-after (- (point) 2)) ?\') - (memq (char-syntax (char-after (- (point) 2))) - '(?w ?_))))) - (if (eq (preceding-char) ?\,) - (cperl-backward-to-start-of-continued-exp containing-sexp)) - (beginning-of-line) - (cperl-backward-to-noncomment containing-sexp)) - ;; Now we get the answer. - (if (not (memq (preceding-char) '(nil ?\, ?\; ?\} ?\{))) - ;; This line is continuation of preceding line's statement; - ;; indent cperl-continued-statement-offset more than the - ;; previous line of the statement. - (progn - (cperl-backward-to-start-of-continued-exp containing-sexp) - (+ cperl-continued-statement-offset (current-column) - (if (save-excursion (goto-char indent-point) - (skip-chars-forward " \t") - (eq (following-char) ?{)) - cperl-continued-brace-offset 0))) - ;; This line starts a new statement. - ;; Position following last unclosed open. - (goto-char containing-sexp) - ;; Is line first statement after an open-brace? - (or - ;; If no, find that first statement and indent like it. - (save-excursion - (forward-char 1) - (let ((colon-line-end 0)) - (while (progn (skip-chars-forward " \t\n") - (looking-at "#\\|/\\*\\|case[ \t\n].*:\\|[a-zA-Z0-9_$]*:")) - ;; Skip over comments and labels following openbrace. - (cond ((= (following-char) ?\#) - (forward-line 1)) - ((= (following-char) ?\/) - (forward-char 2) - (search-forward "*/" nil 'move)) - ;; case or label: - (t - (save-excursion (end-of-line) - (setq colon-line-end (point))) - (search-forward ":")))) - ;; The first following code counts - ;; if it is before the line we want to indent. - (and (< (point) indent-point) - (if (> colon-line-end (point)) - (- (current-indentation) cperl-label-offset) - (current-column))))) - ;; If no previous statement, - ;; indent it relative to line brace is on. - ;; For open brace in column zero, don't let statement - ;; start there too. If cperl-indent-level is zero, - ;; use cperl-brace-offset + cperl-continued-statement-offset instead. - ;; For open-braces not the first thing in a line, - ;; add in cperl-brace-imaginary-offset. - (+ (if (and (bolp) (zerop cperl-indent-level)) - (+ cperl-brace-offset cperl-continued-statement-offset) - cperl-indent-level) - ;; Move back over whitespace before the openbrace. - ;; If openbrace is not first nonwhite thing on the line, - ;; add the cperl-brace-imaginary-offset. - (progn (skip-chars-backward " \t") - (if (bolp) 0 cperl-brace-imaginary-offset)) - ;; If the openbrace is preceded by a parenthesized exp, - ;; move to the beginning of that; - ;; possibly a different line - (progn - (if (eq (preceding-char) ?\)) - (forward-sexp -1)) - ;; Get initial indentation of the line we are on. - (current-indentation)))))))))) - -(defun calculate-cperl-indent-within-comment () - "Return the indentation amount for line, assuming that -the current line is to be regarded as part of a block comment." - (let (end star-start) - (save-excursion - (beginning-of-line) - (skip-chars-forward " \t") - (setq star-start (= (following-char) ?\*)) - (skip-chars-backward " \t\n") - (setq end (point)) - (beginning-of-line) - (skip-chars-forward " \t") - (and (re-search-forward "/\\*[ \t]*" end t) - star-start - (goto-char (1+ (match-beginning 0)))) - (current-column)))) - - -(defun cperl-backward-to-noncomment (lim) - (let (opoint stop) - (while (not stop) - (skip-chars-backward " \t\n\f" lim) - (setq opoint (point)) - (if (and (>= (point) (+ 2 lim)) - (save-excursion - (forward-char -2) - (looking-at "\\*/"))) - (search-backward "/*" lim 'move) - (beginning-of-line) - (skip-chars-forward " \t") - (setq stop (or (not (looking-at "#")) (<= (point) lim))) - (if stop (goto-char opoint) - (beginning-of-line)))))) - -(defun cperl-backward-to-start-of-continued-exp (lim) - (if (= (preceding-char) ?\)) - (forward-sexp -1)) - (beginning-of-line) - (if (<= (point) lim) - (goto-char (1+ lim))) - (skip-chars-forward " \t")) - -(defun cperl-backward-to-start-of-if (&optional limit) - "Move to the start of the last ``unbalanced'' if." - (or limit (setq limit (save-excursion (beginning-of-defun) (point)))) - (let ((if-level 1) - (case-fold-search nil)) - (while (not (zerop if-level)) - (backward-sexp 1) - (cond ((looking-at "else\\b") - (setq if-level (1+ if-level))) - ((looking-at "if\\b") - (setq if-level (1- if-level))) - ((< (point) limit) - (setq if-level 0) - (goto-char limit)))))) - - -(defun mark-cperl-function () - "Put mark at end of C function, point at beginning." - (interactive) - (push-mark (point)) - (end-of-defun) - (push-mark (point)) - (beginning-of-defun) - (backward-paragraph)) - -(defun indent-cperl-exp () - "Indent each line of the C grouping following point." - (interactive) - (let ((indent-stack (list nil)) - (contain-stack (list (point))) - (case-fold-search nil) - restart outer-loop-done inner-loop-done state ostate - this-indent last-sexp - at-else at-brace - (opoint (point)) - (next-depth 0)) - (save-excursion - (forward-sexp 1)) - (save-excursion - (setq outer-loop-done nil) - (while (and (not (eobp)) (not outer-loop-done)) - (setq last-depth next-depth) - ;; Compute how depth changes over this line - ;; plus enough other lines to get to one that - ;; does not end inside a comment or string. - ;; Meanwhile, do appropriate indentation on comment lines. - (setq innerloop-done nil) - (while (and (not innerloop-done) - (not (and (eobp) (setq outer-loop-done t)))) - (setq ostate state) - (setq state (parse-partial-sexp (point) (progn (end-of-line) (point)) - nil nil state)) - (setq next-depth (car state)) - (if (and (car (cdr (cdr state))) - (>= (car (cdr (cdr state))) 0)) - (setq last-sexp (car (cdr (cdr state))))) - (if (or (nth 4 ostate)) - (cperl-indent-line)) - (if (or (nth 3 state)) - (forward-line 1) - (setq innerloop-done t))) - (if (<= next-depth 0) - (setq outer-loop-done t)) - (if outer-loop-done - nil - ;; If this line had ..))) (((.. in it, pop out of the levels - ;; that ended anywhere in this line, even if the final depth - ;; doesn't indicate that they ended. - (while (> last-depth (nth 6 state)) - (setq indent-stack (cdr indent-stack) - contain-stack (cdr contain-stack) - last-depth (1- last-depth))) - (if (/= last-depth next-depth) - (setq last-sexp nil)) - ;; Add levels for any parens that were started in this line. - (while (< last-depth next-depth) - (setq indent-stack (cons nil indent-stack) - contain-stack (cons nil contain-stack) - last-depth (1+ last-depth))) - (if (null (car contain-stack)) - (setcar contain-stack (or (car (cdr state)) - (save-excursion (forward-sexp -1) - (point))))) - (forward-line 1) - (skip-chars-forward " \t") - (if (eolp) - nil - (if (and (car indent-stack) - (>= (car indent-stack) 0)) - ;; Line is on an existing nesting level. - ;; Lines inside parens are handled specially. - (if (/= (char-after (car contain-stack)) ?{) - (setq this-indent (car indent-stack)) - ;; Line is at statement level. - ;; Is it a new statement? Is it an else? - ;; Find last non-comment character before this line - (save-excursion - (setq at-else (looking-at "else\\W")) - (setq at-brace (= (following-char) ?{)) - (cperl-backward-to-noncomment opoint) - (if (not (memq (preceding-char) '(nil ?\, ?\; ?} ?: ?{))) - ;; Preceding line did not end in comma or semi; - ;; indent this line cperl-continued-statement-offset - ;; more than previous. - (progn - (cperl-backward-to-start-of-continued-exp (car contain-stack)) - (setq this-indent - (+ cperl-continued-statement-offset (current-column) - (if at-brace cperl-continued-brace-offset 0)))) - ;; Preceding line ended in comma or semi; - ;; use the standard indent for this level. - (if at-else - (progn (cperl-backward-to-start-of-if opoint) - (setq this-indent (current-indentation))) - (setq this-indent (car indent-stack)))))) - ;; Just started a new nesting level. - ;; Compute the standard indent for this level. - (let ((val (calculate-cperl-indent - (if (car indent-stack) - (- (car indent-stack)))))) - (setcar indent-stack - (setq this-indent val)))) - ;; Adjust line indentation according to its contents - (if (or (looking-at "case[ \t]") - (and (looking-at "[A-Za-z]") - (save-excursion - (forward-sexp 1) - (looking-at ":")))) - (setq this-indent (max 1 (+ this-indent cperl-label-offset)))) - (if (= (following-char) ?}) - (setq this-indent (- this-indent cperl-indent-level))) - (if (= (following-char) ?{) - (setq this-indent (+ this-indent cperl-brace-offset))) - ;; Put chosen indentation into effect. - (or (= (current-column) this-indent) - (= (following-char) ?\#) - (progn - (delete-region (point) (progn (beginning-of-line) (point))) - (indent-to this-indent))) - ;; Indent any comment following the text. - (or (looking-at comment-start-skip) - (if (re-search-forward comment-start-skip (save-excursion (end-of-line) (point)) t) - (progn (indent-for-comment) (beginning-of-line))))))))) -; (message "Indenting C expression...done") - ) ---cut here-- --- -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= -Vivek Khera, Gradual Student/Systems Guy Department of Computer Science -Internet: khera@cs.duke.edu Box 90129 - RIPEM/PGP/MIME spoken here Durham, NC 27708-0129 (919)660-6528 - - diff --git a/emacs/cperl-mode.el b/emacs/cperl-mode.el new file mode 100644 index 0000000000..5a400ef2b7 --- /dev/null +++ b/emacs/cperl-mode.el @@ -0,0 +1,2566 @@ +;;; This code started from the following message of long time ago (IZ): + +;;; From: olson@mcs.anl.gov (Bob Olson) +;;; Newsgroups: comp.lang.perl +;;; Subject: cperl-mode: Another perl mode for Gnuemacs +;;; 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. + +;; 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 +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; 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. + +;;; 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.15 1995/10/07 22:23:37 ilya Exp ilya $ + +;;; To use this mode put the following into your .emacs file: + +;; (autoload 'perl-mode "cperl-mode" "alternate mode for editing Perl programs" t) + +;;; You can either fine-tune the bells and whistles of this mode or +;;; bulk enable them by putting + +;; (setq cperl-hairy t) + +;;; in your .emacs file. (Emacs rulers do not consider it politically +;;; correct to make whistles enabled by default.) + +;;; Additional useful commands to put into your .emacs file: + +;; (setq auto-mode-alist +;; (append '(("\\.[pP][Llm]$" . perl-mode)) auto-mode-alist )) +;; (setq interpreter-mode-alist (append interpreter-mode-alist +;; '(("miniperl" . perl-mode)))) + +;;; The mode information (on C-h m) provides customization help. +;;; 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 +;;; 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 +;;; and control flow words, one for each: comments, string, labels, +;;; functions definitions and packages, arrays, hashes, and variable +;;; definitions. If you do not see all these faces, your font-lock does +;;; 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 +;;; font-lock-display-type bound to 'grayscale, insert + +;;; (setq font-lock-display-type 'grayscale) + +;;; to your .emacs file. + +;;;; This mode supports font-lock, imenu and compile-mode. In the +;;;; hairy version font-lock is on, but you should activate imenu +;;;; yourself (note that compile-mode is not standard yet). Well, you +;;;; can use imenu from keyboard anyway (M-x imenu), but it is better +;;;; to bind it like that: + +;; (define-key global-map [M-S-down-mouse-3] 'imenu) + +;;; In fact the version of font-lock that this version supports can be +;;; much newer than the version you actually have. This means that a +;;; lot of faces can be set up, but are not visible on your screen +;;; since the coloring rules for this faces are not defined. + +;;; Tips: ======================================== + +;;; get newest version of this package from +;;; ftp://ftp.math.ohio-state.edu/pub/users/ilya/lisp +;;; 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. + +;;; Get perl5-info from +;; 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 (can do it from +;;; CPerl menu). + +;;;; Known problems: ======================================== + +;;; The very new pod +;;; features. The rules are: + +;;; /\n=/ should start comment mode, and +;;; /\n=cut\s/ should stop comment mode + +;;; Expansion of keywords tries to detect this kind of commenting, but +;;; a "=" that starts a perl row (as in multiline comment and here +;;; document) can confuse it. + +;;; The main trick (to +;;; make $ a "backslash") makes constructions like ${aaa} look like +;;; unbalanced braces. The only trick I can think out is to insert it as +;;; $ {aaa} (legal in perl5, not in perl4). + +;;;; Known non-problems: ======================================== + +;;; Perl quoting rules are too hard for CPerl. Try to help it: add +;;; comments with embedded quotes to fix CPerl misunderstandings: + +;;; $a='500$'; # '; + +;;; You won't need it too often. + +;;; Now the indentation code is pretty wise. If you still get wrong +;;; indentation in situation that you think the code should be able to +;;; parse, try: + +;;; a) Check what Emacs thinks about balance of your parentheses. +;;; b) Supply the code to me (IZ). + +;;; Updates: ======================================== + +;;; Made less hairy by default: parentheses not electric, +;;; linefeed not magic. Bug with abbrev-mode corrected. + +;;;; After 1.4: +;;; Better indentation: +;;; subs inside braces should work now, +;;; Toplevel braces obey customization. +;;; indent-for-comment knows about bad cases, cperl-indent-for-comment +;;; moves cursor to a correct place. +;;; cperl-indent-exp written from the scratch! Slow... (quadratic!) :-( +;;; (50 secs on DB::DB (sub of 430 lines), 486/66) +;;; Minor documentation fixes. +;;; Imenu understands packages as prefixes (including nested). +;;; Hairy options can be switched off one-by-one by setting to null. +;;; Names of functions and variables changed to conform to `cperl-' style. + +;;;; After 1.5: +;;; Some bugs with indentation of labels (and embedded subs) corrected. +;;; `cperl-indent-region' done (slow :-()). +;;; `cperl-fill-paragraph' done. +;;; Better package support for `imenu'. +;;; Progress indicator for indentation (with `imenu' loaded). +;;; `Cperl-set' was busted, now setting the individual hairy option +;;; should be better. + +;;;; After 1.6: +;;; `cperl-set-style' done. +;;; `cperl-check-syntax' done. +;;; Menu done. +;;; New config variables `cperl-close-paren-offset' and `cperl-comment-column'. +;;; Bugs with `cperl-auto-newline' corrected. +;;; `cperl-electric-lbrace' can work with `cperl-auto-newline' in situation +;;; like $hash{. + +;;;; 1.7 XEmacs (arius@informatik.uni-erlangen.de): +;;; - use `next-command-event', if `next-command-events' does not exist +;;; - use `find-face' as def. of `is-face' +;;; - corrected def. of `x-color-defined-p' +;;; - added const defs for font-lock-comment-face, +;;; font-lock-keyword-face and font-lock-function-name-face +;;; - added def. of font-lock-variable-name-face +;;; - added (require 'easymenu) inside an `eval-when-compile' +;;; - replaced 4-argument `substitute-key-definition' with ordinary +;;; `define-key's +;;; - replaced `mark-active' in menu definition by `cperl-use-region-p'. +;;; Todo (at least): +;;; - use emacs-vers.el (http://www.cs.utah.edu/~eeide/emacs/emacs-vers.el.gz) +;;; for portable code? +;;; - should `cperl-mode' do a +;;; (if (featurep 'easymenu) (easy-menu-add cperl-menu)) +;;; or should this be left to the user's `cperl-mode-hook'? + +;;; Some bugs introduced by the above fix corrected (IZ ;-). +;;; Some bugs under XEmacs introduced by the correction corrected. + +;;; Some more can remain since there are two many different variants. +;;; Please feedback! + +;;; We do not support fontification of arrays and hashes under +;;; obsolete font-lock any more. Upgrade. + +;;;; after 1.8 Minor bug with parentheses. +;;;; after 1.9 Improvements from Joe Marzot. +;;;; after 1.10 +;;; Does not need easymenu to compile under XEmacs. +;;; `vc-insert-headers' should work better. +;;; Should work with 19.29 and 19.12. +;;; Small improvements to fontification. +;;; Expansion of keywords does not depend on C-? being backspace. + +;;; after 1.10+ +;;; 19.29 and 19.12 supported. +;;; `cperl-font-lock-enhanced' deprecated. Use font-lock-extra.el. +;;; Support for font-lock-extra.el. + +;;;; After 1.11: +;;; Tools submenu. +;;; Support for perl5-info. +;;; `imenu-go-find-at-position' in Tools requires imenu-go.el (see hints above) +;;; Imenu entries do not work with stock imenu.el. Patch sent to maintainers. +;;; Fontifies `require a if b;', __DATA__. +;;; Arglist for auto-fill-mode was incorrect. + +;;;; After 1.12: +;;; `cperl-lineup-step' and `cperl-lineup' added: lineup constructions +;;; vertically. +;;; `cperl-do-auto-fill' updated for 19.29 style. +;;; `cperl-info-on-command' now has a default. +;;; Workaround for broken C-h on XEmacs. +;;; VC strings escaped. +;;; C-h f now may prompt for function name instead of going on, +;;; controlled by `cperl-info-on-command-no-prompt'. + +;;;; After 1.13: +;;; Msb buffer list includes perl files +;;; Indent-for-comment uses indent-to +;;; Can write tag files using etags. + +;;;; After 1.14: +;;; Recognizes (tries to ;-) {...} which are not blocks during indentation. +;;; `cperl-close-paren-offset' affects ?\] too (and ?\} if not block) + +(defvar cperl-extra-newline-before-brace nil + "*Non-nil means that if, elsif, while, until, else, for, foreach +and do constructs look like: + + if () + { + } + +instead of: + + if () { + } +") +(defvar cperl-indent-level 2 + "*Indentation of CPerl statements with respect to containing block.") +(defvar cperl-lineup-step nil + "*`cperl-lineup' will always lineup at multiple of this number. +If `nil', the value of `cperl-indent-level' will be used.") +(defvar cperl-brace-imaginary-offset 0 + "*Imagined indentation of a Perl open brace that actually follows a statement. +An open brace following other text is treated as if it were this far +to the right of the start of its line.") +(defvar cperl-brace-offset 0 + "*Extra indentation for braces, compared with other text in same context.") +(defvar cperl-label-offset -2 + "*Offset of CPerl label lines relative to usual indentation.") +(defvar cperl-min-label-indent 1 + "*Minimal offset of CPerl label lines.") +(defvar cperl-continued-statement-offset 2 + "*Extra indent for lines not starting new statements.") +(defvar cperl-continued-brace-offset 0 + "*Extra indent for substatements that start with open-braces. +This is in addition to cperl-continued-statement-offset.") +(defvar cperl-close-paren-offset -1 + "*Extra indent for substatements that start with close-parenthesis.") + +(defvar cperl-auto-newline nil + "*Non-nil means automatically newline before and after braces, +and after colons and semicolons, inserted in CPerl code.") + +(defvar cperl-tab-always-indent t + "*Non-nil means TAB in CPerl mode should always reindent the current line, +regardless of where in the line point is when the TAB command is used.") + +(defvar cperl-font-lock nil + "*Non-nil (and non-null) means CPerl buffers will use font-lock-mode. +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 ` '. +Can be overwritten by `cperl-hairy' if nil.") + +(defvar cperl-electric-parens "" + "*List of parentheses that should be electric in CPerl, or null. +Can be overwritten by `cperl-hairy' to \"({[<\" if not 'null.") + +(defvar cperl-electric-linefeed nil + "*If true, LFD should be hairy in CPerl, otherwise C-c LFD is hairy. +In any case these two mean plain and hairy linefeeds together. +Can be overwritten by `cperl-hairy' if nil.") + +(defvar cperl-electric-keywords nil + "*Not-nil (and non-null) means keywords are electric in CPerl. +Can be overwritten by `cperl-hairy' if nil.") + +(defvar cperl-hairy nil + "*Not-nil means all the bells and whistles are enabled in CPerl.") + +(defvar cperl-comment-column 32 + "*Column to put comments in CPerl (use \\[cperl-indent]' to lineup with code).") + +(defvar cperl-vc-header-alist '((SCCS "$sccs = '%W\%' ;") + (RCS "$rcs = ' $Id\$ ' ;")) + "*What to use as `vc-header-alist' in CPerl.") + +(defvar cperl-info-on-command-no-prompt nil + "*Not-nil (and non-null) means not to prompt on C-h f. +The opposite behaviour is always available if prefixed with C-c. +Can be overwritten by `cperl-hairy' if nil.") + + +;;; Portability stuff: + +(defsubst cperl-xemacs-p () + (string-match "XEmacs\\|Lucid" emacs-version)) + +(defvar del-back-ch (car (append (where-is-internal 'delete-backward-char) + (where-is-internal 'backward-delete-char-untabify))) + "Character generated by key bound to delete-backward-char.") + +(and (vectorp del-back-ch) (= (length del-back-ch) 1) + (setq del-back-ch (aref del-back-ch 0))) + +(if (cperl-xemacs-p) + ;; "Active regions" are on: use region only if active + ;; "Active regions" are off: use region unconditionally + (defun cperl-use-region-p () + (if zmacs-regions (mark) t)) + (defun cperl-use-region-p () + (if transient-mark-mode mark-active t))) + +(defsubst cperl-enable-font-lock () + (or (cperl-xemacs-p) window-system)) + +(if (boundp 'unread-command-events) + (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 + (setq unread-command-events (list c)))) + (defun cperl-putback-char (c) ; XEmacs <= 19.11 + (setq unread-command-event (character-to-event c)))) + +(or (fboundp 'uncomment-region) + (defun uncomment-region (beg end) + (interactive "r") + (comment-region beg end -1))) + +;;; Probably it is too late to set these guys already, but it can help later: + +(setq auto-mode-alist + (append '(("\\.[pP][Llm]$" . perl-mode)) auto-mode-alist )) +(and (boundp 'interpreter-mode-alist) + (setq interpreter-mode-alist (append interpreter-mode-alist + '(("miniperl" . perl-mode))))) +(if (fboundp 'eval-when-compile) + (eval-when-compile + (condition-case nil + (require 'imenu) + (error nil)) + (condition-case nil + (require 'easymenu) + (error nil)) + ;; Calling `cperl-enable-font-lock' below doesn't compile on XEmacs, + ;; macros instead of defsubsts don't work on Emacs, so we do the + ;; expansion manually. Any other suggestions? + (if (or (string-match "XEmacs\\|Lucid" emacs-version) + window-system) + (require 'font-lock)) + (require 'cl) + )) + +(defvar cperl-mode-abbrev-table nil + "Abbrev table in use in Cperl-mode buffers.") + +(add-hook 'edit-var-mode-alist '(perl-mode (regexp . "^cperl-"))) + +(defvar cperl-mode-map () "Keymap used in CPerl mode.") + +(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 "\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" 'backward-delete-char-untabify) + (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) + (<= 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)) + (substitute-key-definition + 'indent-sexp 'cperl-indent-exp + cperl-mode-map global-map) + (substitute-key-definition + 'fill-paragraph 'cperl-fill-paragraph + cperl-mode-map global-map) + (substitute-key-definition + 'indent-region 'cperl-indent-region + cperl-mode-map global-map) + (substitute-key-definition + 'indent-for-comment 'cperl-indent-for-comment + cperl-mode-map global-map))) + +(condition-case nil + (progn + (require 'easymenu) + (easy-menu-define cperl-menu cperl-mode-map "Menu for CPerl mode" + '("Perl" + ["Beginning of function" beginning-of-defun t] + ["End of function" end-of-defun t] + ["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)] + "----" + ["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)] + "----" + ["Run" mode-compile (fboundp 'mode-compile)] + ["Kill" mode-compile-kill (and (fboundp 'mode-compile-kill) + (get-buffer "*compilation*"))] + ["Next error" next-error (get-buffer "*compilation*")] + ["Check syntax" cperl-check-syntax (fboundp 'mode-compile)] + "----" + ["Debugger" perldb t] + "----" + ("Tools" + ["Imenu" imenu (fboundp 'imenu)] + ["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 Perl files in (sub)directories" + (cperl-etags nil 'recursive) t] + ["Add tags for Perl files in (sub)directories" + (cperl-etags t 'recursive) 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]) + ("Indent styles..." + ["GNU" (cperl-set-style "GNU") t] + ["C++" (cperl-set-style "C++") t] + ["FSF" (cperl-set-style "FSF") t] + ["BSD" (cperl-set-style "BSD") t] + ["Whitesmith" (cperl-set-style "Whitesmith") t])))) + (error nil)) + +(autoload 'c-macro-expand "cmacexp" + "Display the result of expanding all C macros occurring in the region. +The expansion is entirely correct because it uses the C preprocessor." + t) + +(defvar cperl-mode-syntax-table nil + "Syntax table in use in Cperl-mode buffers.") + +(if cperl-mode-syntax-table + () + (setq cperl-mode-syntax-table (make-syntax-table)) + (modify-syntax-entry ?\\ "\\" 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) + (modify-syntax-entry ?- "." 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) + (modify-syntax-entry ?> "." cperl-mode-syntax-table) + (modify-syntax-entry ?& "." cperl-mode-syntax-table) + (modify-syntax-entry ?$ "\\" cperl-mode-syntax-table) + (modify-syntax-entry ?\n ">" 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) + (modify-syntax-entry ?_ "w" cperl-mode-syntax-table) + (modify-syntax-entry ?| "." cperl-mode-syntax-table)) + + + +;; Make customization possible "in reverse" +;;(defun cperl-set (symbol to) +;; (or (eq (symbol-value symbol) 'null) (set symbol to))) +(defsubst cperl-val (symbol &optional default hairy) + (cond + ((eq (symbol-value symbol) 'null) default) + (cperl-hairy (or hairy t)) + (t (symbol-value symbol)))) + +;; provide an alias for working with emacs 19. the perl-mode that comes +;; with it is really bad, and this lets us seamlessly replace it. +(fset 'perl-mode 'cperl-mode) +(defun cperl-mode () + "Major mode for editing Perl code. +Expression and list commands understand all C brackets. +Tab indents for Perl code. +Paragraphs are separated by blank lines only. +Delete converts tabs to spaces as it moves back. + +Various characters in Perl almost always come in pairs: {}, (), [], +sometimes <>. When the user types the first, she gets the second as +well, with optional special formatting done on {}. (Disabled by +default.) You can always quote (with \\[quoted-insert]) the left +\"paren\" to avoid the expansion. The processing of < is special, +since most the time you mean \"less\". Cperl mode tries to guess +whether you want to type pair <>, and inserts is if it +appropriate. You can set `cperl-electric-parens' to the string that +contains the parenths from the above list you want to be electrical. + +CPerl mode provides expansion of the Perl control constructs: + if, else, elsif, unless, while, until, for, and foreach. +=========(Disabled by default, see `cperl-electric-keywords'.) +The user types the keyword immediately followed by a space, which causes +the construct to be expanded, and the user is positioned where she is most +likely to want to be. +eg. when the user types a space following \"if\" the following appears in +the buffer: + if () { or if () + } { + } +and the cursor is between the parentheses. The user can then type some +boolean expression within the parens. Having done that, typing +\\[cperl-linefeed] places you, appropriately indented on a new line +between the braces. If CPerl decides that you want to insert +\"English\" style construct like + bite if angry; +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 +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 +`newline-and-indent' behaviour, it is on \\[newline-and-indent], +see documentation on `cperl-electric-linefeed'. + +\\{cperl-mode-map} + +Setting the variable `cperl-font-lock' to t switches on +font-lock-mode, `cperl-electric-lbrace-space' to t switches on +electric space between $ and {, `cperl-electric-parens' is the string +that contains parentheses that should be electric in CPerl, setting +`cperl-electric-keywords' enables electric expansion of control +structures in CPerl. `cperl-electric-linefeed' governs which one of +two linefeed behavior is preferable. You can enable all these options +simultaneously (recommended mode of use) by setting `cperl-hairy' to +t. In this case you can switch separate options off by setting them +to `null'. + +If your site has perl5 documentation in info format, you can use commands +\\[cperl-info-on-current-command] and \\[cperl-info-on-command] to access it. +These keys run commands `cperl-info-on-current-command' and +`cperl-info-on-command', which one is which is controlled by variable +`cperl-info-on-command-no-prompt' (in turn affected by `cperl-hairy'). + +Variables controlling indentation style: + `cperl-tab-always-indent' + Non-nil means TAB in CPerl mode should always reindent the current line, + regardless of where in the line point is when the TAB command is used. + `cperl-auto-newline' + Non-nil means automatically newline before and after braces, + and after colons and semicolons, inserted in Perl code. + `cperl-indent-level' + Indentation of Perl statements within surrounding block. + The surrounding block's indentation is the indentation + of the line on which the open-brace appears. + `cperl-continued-statement-offset' + Extra indentation given to a substatement, such as the + then-clause of an if, or body of a while, or just a statement continuation. + `cperl-continued-brace-offset' + Extra indentation given to a brace that starts a substatement. + This is in addition to `cperl-continued-statement-offset'. + `cperl-brace-offset' + Extra indentation for line if it starts with an open brace. + `cperl-brace-imaginary-offset' + An open brace following other text is treated as if it the line started + this far to the right of the actual line indentation. + `cperl-label-offset' + Extra indentation for line that is a label. + `cperl-min-label-indent' + Minimal indentation for line that is a label. + +Settings for K&R and BSD indentation styles are + `cperl-indent-level' 5 8 + `cperl-continued-statement-offset' 5 8 + `cperl-brace-offset' -5 -8 + `cperl-label-offset' -5 -8 + +If `cperl-indent-level' is 0, the statement after opening brace in column 0 is indented on `cperl-brace-offset'+`cperl-continued-statement-offset'. + +Turning on CPerl mode calls the hooks in the variable `cperl-mode-hook' +with no args." + (interactive) + (kill-all-local-variables) + ;;(if cperl-hairy + ;; (progn + ;; (cperl-set 'cperl-font-lock cperl-hairy) + ;; (cperl-set 'cperl-electric-lbrace-space cperl-hairy) + ;; (cperl-set 'cperl-electric-parens "{[(<") + ;; (cperl-set 'cperl-electric-keywords cperl-hairy) + ;; (cperl-set 'cperl-electric-linefeed cperl-hairy))) + (use-local-map cperl-mode-map) + (if (cperl-val 'cperl-electric-linefeed) + (progn + (local-set-key "\C-J" 'cperl-linefeed) + (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)))) + (setq major-mode 'perl-mode) + (setq mode-name "CPerl") + (if (not cperl-mode-abbrev-table) + (let ((prev-a-c abbrevs-changed)) + (define-abbrev-table 'cperl-mode-abbrev-table '( + ("if" "if" cperl-electric-keyword 0) + ("elsif" "elsif" cperl-electric-keyword 0) + ("while" "while" cperl-electric-keyword 0) + ("until" "until" cperl-electric-keyword 0) + ("unless" "unless" cperl-electric-keyword 0) + ("else" "else" cperl-electric-else 0) + ("for" "for" cperl-electric-keyword 0) + ("foreach" "foreach" cperl-electric-keyword 0) + ("do" "do" cperl-electric-keyword 0))) + (setq abbrevs-changed prev-a-c))) + (setq local-abbrev-table cperl-mode-abbrev-table) + (abbrev-mode (if (cperl-val 'cperl-electric-keywords) 1 0)) + (set-syntax-table cperl-mode-syntax-table) + (make-local-variable 'paragraph-start) + (setq paragraph-start (concat "^$\\|" page-delimiter)) + (make-local-variable 'paragraph-separate) + (setq paragraph-separate paragraph-start) + (make-local-variable 'paragraph-ignore-fill-prefix) + (setq paragraph-ignore-fill-prefix t) + (make-local-variable 'indent-line-function) + (setq indent-line-function 'cperl-indent-line) + (make-local-variable 'require-final-newline) + (setq require-final-newline t) + (make-local-variable 'comment-start) + (setq comment-start "# ") + (make-local-variable 'comment-end) + (setq comment-end "") + (make-local-variable 'comment-column) + (setq comment-column cperl-comment-column) + (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 *") + (make-local-variable 'comment-indent-function) + (setq comment-indent-function 'cperl-comment-indent) + (make-local-variable 'parse-sexp-ignore-comments) + (setq parse-sexp-ignore-comments t) + (make-local-variable 'indent-region-function) + (setq indent-region-function 'cperl-indent-region) + ;;(setq auto-fill-function 'cperl-do-auto-fill) ; Need to switch on and off! + (make-local-variable 'imenu-create-index-function) + (setq imenu-create-index-function + (function imenu-example--create-perl-index)) + (make-local-variable 'vc-header-alist) + (setq vc-header-alist cperl-vc-header-alist) + (or (fboundp 'cperl-old-auto-fill-mode) + (progn + (fset 'cperl-old-auto-fill-mode (symbol-function 'auto-fill-mode)) + (defun auto-fill-mode (&optional arg) + (interactive "P") + (cperl-old-auto-fill-mode arg) + (and auto-fill-function (eq major-mode 'perl-mode) + (setq auto-fill-function 'cperl-do-auto-fill))))) + (if (cperl-enable-font-lock) + (if (cperl-val 'cperl-font-lock) (font-lock-mode 1))) + (and (boundp 'msb-menu-cond) + (not cperl-msb-fixed) + (cperl-msb-fix)) + (run-hooks 'cperl-mode-hook)) + +;; Fix for msb.el +(defvar cperl-msb-fixed nil) + +(defun cperl-msb-fix () + ;; Adds perl files to msb menu, supposes that msb is already loaded + (setq cperl-msb-fixed t) + (let* ((l (length msb-menu-cond)) + (last (nth (1- l) msb-menu-cond)) + (precdr (nthcdr (- l 2) msb-menu-cond)) ; cdr of this is last + (handle (1- (nth 1 last)))) + (setcdr precdr (list + (list + '(eq major-mode 'perl-mode) + handle + "Perl Files (%d)") + last)))) + +;; This is used by indent-for-comment +;; to decide how much to indent a comment in CPerl code +;; based on its context. Do fallback if comment is found wrong. + +(defvar cperl-wrong-comment) + +(defun cperl-comment-indent () + (let ((p (point)) (c (current-column)) was) + (if (looking-at "^#") 0 ; Existing comment at bol stays there. + ;; Wrong comment found + (save-excursion + (setq was (cperl-to-comment-or-eol)) + (if (= (point) p) + (progn + (skip-chars-backward " \t") + (max (1+ (current-column)) ; Else indent at comment column + comment-column)) + (if was nil + (insert comment-start) + (backward-char (length comment-start))) + (setq cperl-wrong-comment t) + (indent-to comment-column 1) ; Indent minimum 1 + c))))) ; except leave at least one space. + +;;;(defun cperl-comment-indent-fallback () +;;; "Is called if the standard comment-search procedure fails. +;;;Point is at start of real comment." +;;; (let ((c (current-column)) target cnt prevc) +;;; (if (= c comment-column) nil +;;; (setq cnt (skip-chars-backward "[ \t]")) +;;; (setq target (max (1+ (setq prevc +;;; (current-column))) ; Else indent at comment column +;;; comment-column)) +;;; (if (= c comment-column) nil +;;; (delete-backward-char cnt) +;;; (while (< prevc target) +;;; (insert "\t") +;;; (setq prevc (current-column))) +;;; (if (> prevc target) (progn (delete-char -1) (setq prevc (current-column)))) +;;; (while (< prevc target) +;;; (insert " ") +;;; (setq prevc (current-column))))))) + +(defun cperl-indent-for-comment () + "Substite for `indent-for-comment' in CPerl." + (interactive) + (let (cperl-wrong-comment) + (indent-for-comment) + (if cperl-wrong-comment + (progn (cperl-to-comment-or-eol) + (forward-char (length comment-start)))))) + +(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 +place (even in empty line), but not after." + (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))) + (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) + "Insert character, correct line's indentation, correct quoting by space." + (interactive "P") + (let (pos after (cperl-auto-newline cperl-auto-newline)) + (and (cperl-val 'cperl-electric-lbrace-space) + (eq (preceding-char) ?$) + (save-excursion + (skip-chars-backward "$") + (looking-at "\\(\\$\\$\\)*\\$\\([^\\$]\\|$\\)")) + (insert ? )) + (if (cperl-after-expr) nil (setq cperl-auto-newline nil)) + (cperl-electric-brace arg) + (and (eq last-command-char ?{) + (memq last-command-char + (append (cperl-val 'cperl-electric-parens "" "([{<") nil)) + (setq last-command-char ?} pos (point)) + (progn (cperl-electric-brace arg t) + (goto-char pos))))) + +(defun cperl-electric-paren (arg) + "Insert a matching pair of parentheses." + (interactive "P") + (let ((beg (save-excursion (beginning-of-line) (point)))) + (if (and (memq last-command-char + (append (cperl-val 'cperl-electric-parens "" "([{<") nil)) + (>= (save-excursion (cperl-to-comment-or-eol) (point)) (point)) + ;;(not (save-excursion (search-backward "#" beg t))) + (if (eq last-command-char ?<) + (cperl-after-expr nil "{};(,:=") + 1)) + (progn + (insert last-command-char) + (insert (cdr (assoc last-command-char '((?{ .?}) + (?[ . ?]) + (?( . ?)) + (?< . ?>))))) + (forward-char -1)) + (insert last-command-char) + ))) + +(defun cperl-electric-keyword () + "Insert a construction appropriate after a keyword." + (let ((beg (save-excursion (beginning-of-line) (point)))) + (and (save-excursion + (backward-sexp 1) + (cperl-after-expr nil "{};:")) + (save-excursion + (not + (re-search-backward + "[#\"'`]\\|\\<q\\(\\|[wqx]\\)\\>" + beg t))) + (save-excursion (or (not (re-search-backward "^=" nil t)) + (looking-at "=cut"))) + (progn + (cperl-indent-line) + ;;(insert " () {\n}") + (cond + (cperl-extra-newline-before-brace + (insert " ()\n") + (insert "{") + (cperl-indent-line) + (insert "\n") + (cperl-indent-line) + (insert "\n}")) + (t + (insert " () {\n}")) + ) + (or (looking-at "[ \t]\\|$") (insert " ")) + (cperl-indent-line) + (search-backward ")") + (cperl-putback-char del-back-ch))))) + +(defun cperl-electric-else () + "Insert a construction appropriate after a keyword." + (let ((beg (save-excursion (beginning-of-line) (point)))) + (and (save-excursion + (backward-sexp 1) + (cperl-after-expr nil "{};:")) + (save-excursion + (not + (re-search-backward + "[#\"'`]\\|\\<q\\(\\|[wqx]\\)\\>" + beg t))) + (save-excursion (or (not (re-search-backward "^=" nil t)) + (looking-at "=cut"))) + (progn + (cperl-indent-line) + ;;(insert " {\n\n}") + (cond + (cperl-extra-newline-before-brace + (insert "\n") + (insert "{") + (cperl-indent-line) + (insert "\n\n}")) + (t + (insert " {\n\n}")) + ) + (or (looking-at "[ \t]\\|$") (insert " ")) + (cperl-indent-line) + (forward-line -1) + (cperl-indent-line) + (cperl-putback-char del-back-ch))))) + +(defun cperl-linefeed () + "Go to end of line, open a new line and indent appropriately." + (interactive) + (let ((beg (save-excursion (beginning-of-line) (point))) + (end (save-excursion (end-of-line) (point))) + (pos (point)) start) + (if (and ; Check if we need to split: + ; i.e., on a boundary and inside "{...}" + ;;(not (search-backward "\\(^\\|[^$\\\\]\\)#" beg t)) + (save-excursion (cperl-to-comment-or-eol) + (>= (point) pos)) + (or (save-excursion + (skip-chars-backward " \t" beg) + (forward-char -1) + (looking-at "[;{]")) + (looking-at "[ \t]*}") + (re-search-forward "\\=[ \t]*;" end t)) + (save-excursion + (and + (eq (car (parse-partial-sexp pos end -1)) -1) + (looking-at "[ \t]*\\($\\|#\\)") + ;;(setq finish (point-marker)) + (progn + (backward-sexp 1) + (setq start (point-marker)) + (<= start pos)) + ;;(looking-at "[^{}\n]*}[ \t]*$") ; Will fail if there are intervening {}'s + ;;(search-backward "{" beg t) + ;;(looking-at "{[^{}\n]*}[ \t]*$") + ))) + ;;(or (looking-at "[ \t]*}") ; and on a boundary of statements + ;; (save-excursion + ;; (skip-chars-backward " \t") + ;; (forward-char -1) + ;; (looking-at "[{;]")))) + (progn + (skip-chars-backward " \t") + (or (memq (preceding-char) (append ";{" nil)) + (insert ";")) + (insert "\n") + (forward-line -1) + (cperl-indent-line) + ;;(end-of-line) + ;;(search-backward "{" beg) + (goto-char start) + (or (looking-at "{[ \t]*$") ; If there is a statement + ; before, move it to separate line + (progn + (forward-char 1) + (insert "\n") + (cperl-indent-line))) + (forward-line 1) ; We are on the target line + (cperl-indent-line) + (beginning-of-line) + (or (looking-at "[ \t]*}[ \t]*$") ; If there is a statement + ; after, move it to separate line + (progn + (end-of-line) + (search-backward "}" beg) + (skip-chars-backward " \t") + (or (memq (preceding-char) (append ";{" nil)) + (insert ";")) + (insert "\n") + (cperl-indent-line) + (forward-line -1))) + (forward-line -1) ; We are on the line before target + (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))))) + +(defun cperl-electric-semi (arg) + "Insert character and correct line's indentation." + (interactive "P") + (if cperl-auto-newline + (cperl-electric-terminator arg) + (self-insert-command (prefix-numeric-value arg)))) + +(defun cperl-electric-terminator (arg) + "Insert character and correct line's indentation." + (interactive "P") + (let (insertpos (end (point))) + (if (and (not arg) (eolp) + (not (save-excursion + (beginning-of-line) + (skip-chars-forward " \t") + (or (= (following-char) ?#) + ;; Colon is special only after a label, or case .... + ;; So quickly rule out most other uses of colon + ;; and do no indentation for them. + (and (eq last-command-char ?:) + (not (looking-at "case[ \t]")) + (save-excursion + (forward-word 1) + (skip-chars-forward " \t") + (and (< (point) end) + (progn (goto-char (- end 1)) + (not (looking-at ":")))))) + (progn + (beginning-of-defun) + (let ((pps (parse-partial-sexp (point) end))) + (or (nth 3 pps) (nth 4 pps) (nth 5 pps)))))))) + (progn + (if cperl-auto-newline + (setq insertpos (point))) + (insert last-command-char) + (cperl-indent-line) + (if cperl-auto-newline + (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-inside-parens-p () + (condition-case () + (save-excursion + (save-restriction + (narrow-to-region (point) + (progn (beginning-of-defun) (point))) + (goto-char (point-max)) + (= (char-after (or (scan-lists (point) -1 1) (point-min))) ?\())) + (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 +or in the line's indentation; otherwise insert a tab. + +A numeric argument, regardless of its value, +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." + (if whole-exp + ;; If arg, always indent this line as Perl + ;; and shift remaining lines of expression the same amount. + (let ((shift-amt (cperl-indent-line)) + beg end) + (save-excursion + (if cperl-tab-always-indent + (beginning-of-line)) + (setq beg (point)) + (forward-sexp 1) + (setq end (point)) + (goto-char beg) + (forward-line 1) + (setq beg (point))) + (if (> end beg) + (indent-code-rigidly beg end shift-amt "#"))) + (if (and (not cperl-tab-always-indent) + (save-excursion + (skip-chars-backward " \t") + (not (bolp)))) + (insert-tab) + (cperl-indent-line)))) + +(defun cperl-indent-line (&optional symbol) + "Indent current line as Perl code. +Return the amount the indentation changed by." + (let (indent + beg shift-amt + (case-fold-search nil) + (pos (- (point-max) (point)))) + (setq indent (cperl-calculate-indent nil symbol)) + (beginning-of-line) + (setq beg (point)) + (cond ((eq indent nil) + (setq indent (current-indentation))) + ;;((eq indent t) ; Never? + ;; (setq indent (cperl-calculate-indent-within-comment))) + ;;((looking-at "[ \t]*#") + ;; (setq indent 0)) + (t + (skip-chars-forward " \t") + (if (listp indent) (setq indent (car indent))) + (cond ((looking-at "[A-Za-z]+:[^:]") + (and (> indent 0) + (setq indent (max cperl-min-label-indent + (+ indent cperl-label-offset))))) + ;;((and (looking-at "els\\(e\\|if\\)\\b") + ;; (not (looking-at "else\\s_"))) + ;; (setq indent (save-excursion + ;; (cperl-backward-to-start-of-if) + ;; (current-indentation)))) + ((= (following-char) ?}) + (setq indent (- indent cperl-indent-level))) + ((memq (following-char) '(?\) ?\])) ; To line up with opening paren. + (setq indent (+ indent cperl-close-paren-offset))) + ((= (following-char) ?{) + (setq indent (+ indent cperl-brace-offset)))))) + (skip-chars-forward " \t") + (setq shift-amt (- indent (current-column))) + (if (zerop shift-amt) + (if (> (- (point-max) pos) (point)) + (goto-char (- (point-max) pos))) + (delete-region beg (point)) + (indent-to indent) + ;; If initial point was within line's indentation, + ;; position after the indentation. Else stay at same point in text. + (if (> (- (point-max) pos) (point)) + (goto-char (- (point-max) pos)))) + shift-amt)) + +(defsubst cperl-after-label () + ;; Returns true if the point is after label. Does not do save-excursion. + (and (eq (preceding-char) ?:) + (memq (char-syntax (char-after (- (point) 2))) + '(?w ?_)) + (progn + (backward-sexp) + (looking-at "[a-zA-Z_][a-zA-Z0-9_]*:")))) + +(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 + (beginning-of-line) + (let ((indent-point (point)) + (case-fold-search nil) + (char-after (save-excursion + (skip-chars-forward " \t") + (following-char))) + state start-indent start start-state moved + containing-sexp old-containing-sexp old-indent) + (or parse-start (null symbol) + (setq parse-start (symbol-value symbol) + start-state (cadr parse-start) + start-indent (nth 2 parse-start) + parse-start (car parse-start) + old-containing-sexp (nth 1 start-state))) + (if parse-start + (goto-char parse-start) + (beginning-of-defun)) + (if start-state nil + ;; Try to go out + (while (< (point) indent-point) + (setq start (point) parse-start start moved nil + state (parse-partial-sexp start indent-point -1)) + (if (> (car state) -1) nil + ;; The current line could start like }}}, so the indentation + ;; corresponds to a different level than what we reached + (setq moved t) + (beginning-of-line 2))) ; Go to the next line. + (if start ; Not at the start of file + (progn + (goto-char start) + (setq start-indent (current-indentation)) + (if moved ; Should correct... + (setq start-indent (- start-indent cperl-indent-level)))) + (setq start-indent 0))) + (if (< (point) indent-point) (setq parse-start (point))) + (or state (setq state (parse-partial-sexp + (point) indent-point -1 nil start-state))) + (setq containing-sexp + (or (car (cdr state)) + (and (>= (nth 6 state) 0) old-containing-sexp)) + old-containing-sexp nil start-state nil) +;; (while (< (point) indent-point) +;; (setq parse-start (point)) +;; (setq state (parse-partial-sexp (point) indent-point -1 nil start-state)) +;; (setq containing-sexp +;; (or (car (cdr state)) +;; (and (>= (nth 6 state) 0) old-containing-sexp)) +;; old-containing-sexp nil start-state nil)) + (if symbol (set symbol (list indent-point state start-indent))) + (goto-char indent-point) + (cond ((or (nth 3 state) (nth 4 state)) + ;; return nil or t if should not change this line + (nth 4 state)) + ((null containing-sexp) + ;; Line is at top level. May be data or function definition, + ;; or may be function argument declaration. + ;; Indent like the previous top level line + ;; unless that ends in a closeparen without semicolon, + ;; in which case this line is the first argument decl. + (skip-chars-forward " \t") + (+ start-indent + (if (= (following-char) ?{) cperl-continued-brace-offset 0) + (progn + (cperl-backward-to-noncomment (or parse-start (point-min))) + (skip-chars-backward " \t\f\n") + ;; Look at previous line that's at column 0 + ;; to determine whether we are in top-level decls + ;; or function's arg decls. Set basic-indent accordingly. + ;; Now add a little if this is a continuation line. + (if (or (bobp) + (memq (preceding-char) (append ");}" nil)) + (memq char-after (append ")]}" nil))) + 0 + cperl-continued-statement-offset)))) + ((/= (char-after containing-sexp) ?{) + ;; line is expression, not statement: + ;; indent to just after the surrounding open. + (goto-char (1+ containing-sexp)) + (current-column)) + ((progn + ;; Containing-expr starts with \{. Check whether it is a hash. + (goto-char containing-sexp) + (cperl-backward-to-noncomment (or parse-start (point-min))) + (skip-chars-backward " \t\n\f") + (not + (or (memq (preceding-char) (append ";)}$@&%" nil)) ; Or label! + ; Label may be mixed up with `$blah :' + (save-excursion (cperl-after-label)) + (and (eq (char-syntax (preceding-char)) ?w) + (progn + (backward-sexp) + (or (looking-at "\\sw+[ \t\n\f]*{") ; Method call syntax + (progn + (skip-chars-backward " \t\n\f") + (and (eq (char-syntax (preceding-char)) ?w) + (progn + (backward-sexp) + (looking-at + "sub[ \t]+\\sw+[ \t\n\f]*{")))))))))) + (goto-char containing-sexp) + (+ (current-column) 1 ; Correct indentation of trailing ?\} + (if (eq char-after ?\}) (+ cperl-indent-level + cperl-close-paren-offset) + 0))) + (t + ;; Statement level. Is it a continuation or a new statement? + ;; Find previous non-comment character. + (goto-char indent-point) + (cperl-backward-to-noncomment containing-sexp) + ;; Back up over label lines, since they don't + ;; affect whether our line is a continuation. + (while (or (eq (preceding-char) ?\,) + (and (eq (preceding-char) ?:) + (or ;;(eq (char-after (- (point) 2)) ?\') ; ???? + (memq (char-syntax (char-after (- (point) 2))) + '(?w ?_))))) + (if (eq (preceding-char) ?\,) + (cperl-backward-to-start-of-continued-exp containing-sexp)) + (beginning-of-line) + (cperl-backward-to-noncomment containing-sexp)) + ;; Now we get the answer. + (if (not (memq (preceding-char) (append ",;}{" '(nil)))) ; Was ?\, + ;; This line is continuation of preceding line's statement; + ;; indent `cperl-continued-statement-offset' more than the + ;; previous line of the statement. + (progn + (cperl-backward-to-start-of-continued-exp containing-sexp) + (+ (if (memq char-after (append "}])" nil)) + 0 ; Closing parenth + cperl-continued-statement-offset) + (current-column) + (if (eq char-after ?\{) + cperl-continued-brace-offset 0))) + ;; This line starts a new statement. + ;; Position following last unclosed open. + (goto-char containing-sexp) + ;; Is line first statement after an open-brace? + (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 + ;; small. + (save-excursion + (forward-char 1) + (setq old-indent (current-indentation)) + (let ((colon-line-end 0)) + (while (progn (skip-chars-forward " \t\n") + (looking-at "#\\|[a-zA-Z0-9_$]*:[^:]")) + ;; Skip over comments and labels following openbrace. + (cond ((= (following-char) ?\#) + (forward-line 1)) + ;; label: + (t + (save-excursion (end-of-line) + (setq colon-line-end (point))) + (search-forward ":")))) + ;; The first following code counts + ;; if it is before the line we want to indent. + (and (< (point) indent-point) + (if (> colon-line-end (point)) ; After label + (if (> (current-indentation) + cperl-min-label-indent) + (- (current-indentation) cperl-label-offset) + ;; Do not belive: `max' is involved + (+ old-indent cperl-indent-level)) + (current-column))))) + ;; If no previous statement, + ;; indent it relative to line brace is on. + ;; For open brace in column zero, don't let statement + ;; start there too. If cperl-indent-level is zero, + ;; use cperl-brace-offset + cperl-continued-statement-offset instead. + ;; For open-braces not the first thing in a line, + ;; add in cperl-brace-imaginary-offset. + + ;; If first thing on a line: ????? + (+ (if (and (bolp) (zerop cperl-indent-level)) + (+ cperl-brace-offset cperl-continued-statement-offset) + cperl-indent-level) + ;; Move back over whitespace before the openbrace. + ;; If openbrace is not first nonwhite thing on the line, + ;; add the cperl-brace-imaginary-offset. + (progn (skip-chars-backward " \t") + (if (bolp) 0 cperl-brace-imaginary-offset)) + ;; If the openbrace is preceded by a parenthesized exp, + ;; move to the beginning of that; + ;; possibly a different line + (progn + (if (eq (preceding-char) ?\)) + (forward-sexp -1)) + ;; Get initial indentation of the line we are on. + ;; If line starts with label, calculate label indentation + (if (save-excursion + (beginning-of-line) + (looking-at "[ \t]*[a-zA-Z_][a-zA-Z_]*:[^:]")) + (if (> (current-indentation) cperl-min-label-indent) + (- (current-indentation) cperl-label-offset) + (cperl-calculate-indent + (if (<= parse-start (point)) parse-start))) + (current-indentation))))))))))) + +(defvar cperl-indent-alist + '((string nil) + (comment nil) + (toplevel 0) + (toplevel-after-parenth 2) + (toplevel-continued 2) + (expression 1)) + "Alist of indentation rules for CPerl mode. +The values mean: + nil: do not indent; + number: add this amount of indentation.") + +(defun cperl-where-am-i (&optional parse-start start-state) + ;; Unfinished + "Return a list (TYPE POS) of the start of enclosing construction. +POS may be nil if it is hard to find, say, when TYPE is `string' or `comment'." + (save-excursion + (let ((start-point (point)) + (case-fold-search nil) + state start-indent start moved + containing-sexp old-containing-sexp old-indent) + (if parse-start + (goto-char parse-start) + (beginning-of-defun)) + (if start-state nil + ;; Try to go out, if sub is not on the outermost level + (while (< (point) start-point) + (setq start (point) parse-start start moved nil + state (parse-partial-sexp start start-point -1)) + (if (> (car state) -1) nil + ;; The current line could start like }}}, so the indentation + ;; corresponds to a different level than what we reached + (setq moved t) + (beginning-of-line 2))) ; Go to the next line. + (if start (goto-char start))) ; Not at the start of file + (skip-chars-forward " \t") + (setq start (point)) + (if (< (point) start-point) (setq parse-start (point))) + (or state (setq state (parse-partial-sexp + (point) start-point -1 nil start-state))) + (setq containing-sexp + (or (car (cdr state)) + (and (>= (nth 6 state) 0) old-containing-sexp)) + old-containing-sexp nil start-state nil) +;; (while (< (point) start-point) +;; (setq parse-start (point)) +;; (setq state (parse-partial-sexp (point) start-point -1 nil start-state)) +;; (setq containing-sexp +;; (or (car (cdr state)) +;; (and (>= (nth 6 state) 0) old-containing-sexp)) +;; old-containing-sexp nil start-state nil)) + (goto-char start-point) + (cond ((nth 3 state) ; In string + (list 'string nil (nth 3 state))) ; What started string + ((nth 4 state) ; In comment + '(comment)) + ((null containing-sexp) + ;; Line is at top level. + ;; Indent like the previous top level line + ;; unless that ends in a closeparen without semicolon, + ;; in which case this line is the first argument decl. + (cperl-backward-to-noncomment (or parse-start (point-min))) + (skip-chars-backward " \t\f\n") ; Why??? + (cond + ((or (bobp) + (memq (preceding-char) (append ";}" nil))) + (list 'toplevel start)) + ((eq (preceding-char) ?\) ) + (list 'toplevel-after-parenth start)) + (t (list 'toplevel-continued start)))) + ((/= (char-after containing-sexp) ?{) + ;; line is expression, not statement: + ;; indent to just after the surrounding open. + (list 'expression containing-sexp)) + ((progn + ;; Containing-expr starts with \{. Check whether it is a hash. + (goto-char containing-sexp) + (cperl-backward-to-noncomment (or parse-start (point-min))) + (skip-chars-backward " \t\n\f") + (not + (or (memq (preceding-char) (append ";)}$@&%" nil)) ; Or label! + ; Label may be mixed up with `$blah :' + (save-excursion (cperl-after-label)) + (and (eq (char-syntax (preceding-char)) ?w) + (progn + (backward-sexp) + (looking-at "\\sw+[ \t\n\f]*{")))))) ; Method call syntax + (list 'expression containing-sexp)) + (t + ;; Statement level. Is it a continuation or a new statement? + ;; Find previous non-comment character. + (cperl-backward-to-noncomment containing-sexp) + ;; Back up over label lines, since they don't + ;; affect whether our line is a continuation. + (while (or (eq (preceding-char) ?\,) + (cperl-after-label)) + (if (eq (preceding-char) ?\,) + (cperl-backward-to-start-of-continued-exp containing-sexp)) + (beginning-of-line) + (cperl-backward-to-noncomment containing-sexp)) + ;; Now we get the answer. + (if (not (memq (preceding-char) (append ";}{" '(nil)))) ; Was ?\, + ;; This line is continuation of preceding line's statement. + '(statement-continued containing-sexp) + ;; This line starts a new statement. + ;; Position following last unclosed open. + (goto-char containing-sexp) + ;; Is line first statement after an open-brace? + (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 + ;; small. + (save-excursion + (forward-char 1) + (setq old-indent (current-indentation)) + (let ((colon-line-end 0)) + (while (progn (skip-chars-forward " \t\n") + (looking-at "#\\|[a-zA-Z0-9_$]*:[^:]")) + ;; Skip over comments and labels following openbrace. + (cond ((= (following-char) ?\#) + (forward-line 1)) + ;; label: + (t + (save-excursion (end-of-line) + (setq colon-line-end (point))) + (search-forward ":")))) + ;; The first following code counts + ;; if it is before the line we want to indent. + (and (< (point) start-point) + (if (> colon-line-end (point)) ; After label + (if (> (current-indentation) + cperl-min-label-indent) + (- (current-indentation) cperl-label-offset) + ;; Do not belive: `max' is involved + (+ old-indent cperl-indent-level)) + (current-column))))) + ;; If no previous statement, + ;; indent it relative to line brace is on. + ;; For open brace in column zero, don't let statement + ;; start there too. If cperl-indent-level is zero, + ;; use cperl-brace-offset + cperl-continued-statement-offset instead. + ;; For open-braces not the first thing in a line, + ;; add in cperl-brace-imaginary-offset. + + ;; If first thing on a line: ????? + (+ (if (and (bolp) (zerop cperl-indent-level)) + (+ cperl-brace-offset cperl-continued-statement-offset) + cperl-indent-level) + ;; Move back over whitespace before the openbrace. + ;; If openbrace is not first nonwhite thing on the line, + ;; add the cperl-brace-imaginary-offset. + (progn (skip-chars-backward " \t") + (if (bolp) 0 cperl-brace-imaginary-offset)) + ;; If the openbrace is preceded by a parenthesized exp, + ;; move to the beginning of that; + ;; possibly a different line + (progn + (if (eq (preceding-char) ?\)) + (forward-sexp -1)) + ;; Get initial indentation of the line we are on. + ;; If line starts with label, calculate label indentation + (if (save-excursion + (beginning-of-line) + (looking-at "[ \t]*[a-zA-Z_][a-zA-Z_]*:[^:]")) + (if (> (current-indentation) cperl-min-label-indent) + (- (current-indentation) cperl-label-offset) + (cperl-calculate-indent + (if (<= parse-start (point)) parse-start))) + (current-indentation))))))))))) + +(defun cperl-calculate-indent-within-comment () + "Return the indentation amount for line, assuming that +the current line is to be regarded as part of a block comment." + (let (end star-start) + (save-excursion + (beginning-of-line) + (skip-chars-forward " \t") + (setq end (point)) + (and (= (following-char) ?#) + (forward-line -1) + (cperl-to-comment-or-eol) + (setq end (point))) + (goto-char end) + (current-column)))) + + +(defun cperl-to-comment-or-eol () + "Goes to position before comment on the current line, or to end of line. +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 (eq (preceding-char) ?\#) (progn (backward-char 1) t)) + ;; Else + (while (not stop-in) + (setq state (parse-partial-sexp (point) lim nil nil nil t)) + ; stop at comment + ;; If fails (beginning-of-line inside sexp), then contains not-comment + ;; Do simplified processing + ;;(if (re-search-forward "[^$]#" lim 1) + ;; (progn + ;; (forward-char -1) + ;; (skip-chars-backward " \t\n\f" lim)) + ;; (goto-char lim)) ; No `#' at all + ;;) + (if (nth 4 state) ; After `#'; + ; (nth 2 state) can be + ; beginning of m,s,qq and so + ; on + (if (nth 2 state) + (progn + (setq cpoint (point)) + (goto-char (nth 2 state)) + (cond + ((looking-at "\\(s\\|tr\\)\\>") + (or (re-search-forward + "\\=\\w+[ \t]*#\\([^\n\\\\#]\\|\\\\[\\\\#]\\)*#\\([^\n\\\\#]\\|\\\\[\\\\#]\\)*" + lim 'move) + (setq stop-in t))) + ((looking-at "\\(m\\|q\\([qxw]\\)?\\)\\>") + (or (re-search-forward + "\\=\\w+[ \t]*#\\([^\n\\\\#]\\|\\\\[\\\\#]\\)*#" + lim 'move) + (setq stop-in t))) + (t ; It was fair comment + (setq stop-in t) ; Finish + (goto-char (1- cpoint))))) + (setq stop-in t) ; Finish + (forward-char -1)) + (setq stop-in t)) ; Finish + ) + (nth 4 state)))) + +(defun cperl-backward-to-noncomment (lim) + (let (stop p) + (while (and (not stop) (> (point) (or lim 1))) + (skip-chars-backward " \t\n\f" lim) + (setq p (point)) + (beginning-of-line) + (if (looking-at "^[ \t]*\\(#\\|$\\)") nil ; Only comment, skip + ;; Else + (cperl-to-comment-or-eol) + (skip-chars-backward " \t") + (if (< p (point)) (goto-char p)) + (setq stop t))))) + +(defun cperl-after-expr (&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) + (save-excursion + (while (and (not stop) (> (point) (or lim 1))) + (skip-chars-backward " \t\n\f" lim) + (setq p (point)) + (beginning-of-line) + (if (looking-at "^[ \t]*\\(#\\|$\\)") nil ; Only comment, skip + ;; Else: last iteration (What to do with labels?) + (cperl-to-comment-or-eol) + (skip-chars-backward " \t") + (if (< p (point)) (goto-char p)) + (setq stop t))) + (or (bobp) + (progn + (backward-char 1) + (if test (eval test) + (memq (following-char) (append (or chars "{};") nil)))))))) + +(defun cperl-backward-to-start-of-continued-exp (lim) + (if (memq (preceding-char) (append ")]}" nil)) + (forward-sexp -1)) + (beginning-of-line) + (if (<= (point) lim) + (goto-char (1+ lim))) + (skip-chars-forward " \t")) + +(defun cperl-backward-to-start-of-if (&optional limit) + "Move to the start of the last ``unbalanced'' if." + (or limit (setq limit (save-excursion (beginning-of-defun) (point)))) + (let ((if-level 1) + (case-fold-search nil)) + (while (not (zerop if-level)) + (backward-sexp 1) + (cond ((looking-at "else\\b") + (setq if-level (1+ if-level))) + ((looking-at "if\\b") + (setq if-level (1- if-level))) + ((<= (point) limit) + (setq if-level 0) + (goto-char limit)))))) + + + +(defvar innerloop-done nil) +(defvar last-depth nil) + +(defun cperl-indent-exp () + "Simple variant of indentation of continued-sexp. +Should be slow. Will not indent comment if it starts at `comment-indent' +or looks like continuation of the comment on the previous line." + (interactive) + (save-excursion + (let ((tmp-end (progn (end-of-line) (point))) top done) + (save-excursion + (while (null done) + (beginning-of-line) + (setq top (point)) + (while (= (nth 0 (parse-partial-sexp (point) tmp-end + -1)) -1) + (setq top (point))) ; Get the outermost parenths in line + (goto-char top) + (while (< (point) tmp-end) + (parse-partial-sexp (point) tmp-end nil t) ; To start-sexp or eol + (or (eolp) (forward-sexp 1))) + (if (> (point) tmp-end) (progn (end-of-line) (setq tmp-end (point))) + (setq done t))) + (goto-char tmp-end) + (setq tmp-end (point-marker))) + (cperl-indent-region (point) tmp-end)))) + +(defun cperl-indent-region (start end) + "Simple variant of indentation of region in CPerl mode. +Should be slow. Will not indent comment if it starts at `comment-indent' +or looks like continuation of the comment on the previous line. +Indents all the lines whose first character is between START and END +inclusive." + (interactive "r") + (save-excursion + (let (st comm indent-info old-comm-indent new-comm-indent + (pm 0) (imenu-scanning-message "Indenting... (%3d%%)")) + (goto-char start) + (setq old-comm-indent (and (cperl-to-comment-or-eol) + (current-column)) + new-comm-indent old-comm-indent) + (goto-char start) + (or (bolp) (beginning-of-line 2)) + (or (fboundp 'imenu-progress-message) + (message "Indenting... For feedback load `imenu'...")) + (while (and (<= (point) end) (not (eobp))) ; bol to check start + (and (fboundp 'imenu-progress-message) + (imenu-progress-message + pm (/ (* 100 (- (point) start)) (- end start -1)))) + (setq st (point) + indent-info nil + ) ; Believe indentation of the current + (if (and (setq comm (looking-at "[ \t]*#")) + (or (eq (current-indentation) (or old-comm-indent + comment-column)) + (setq old-comm-indent nil))) + (if (and old-comm-indent + (= (current-indentation) old-comm-indent)) + (let ((comment-column new-comm-indent)) + (indent-for-comment))) + (progn + (cperl-indent-line 'indent-info) + (or comm + (progn + (if (setq old-comm-indent (and (cperl-to-comment-or-eol) + (current-column))) + (progn (indent-for-comment) + (skip-chars-backward " \t") + (skip-chars-backward "#") + (setq new-comm-indent (current-column)))))))) + (beginning-of-line 2)) + (if (fboundp 'imenu-progress-message) + (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 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 + +(defun cperl-fill-paragraph (&optional justify iteration) + "Like \\[fill-paragraph], but handle CPerl comments. +If any of the current line is a comment, fill the comment or the +block of it that point is in, preserving the comment's initial +indentation and initial hashes. Behaves usually outside of comment." + (interactive "P") + (let ( + ;; Non-nil if the current line contains a comment. + has-comment + + ;; If has-comment, the appropriate fill-prefix for the comment. + comment-fill-prefix + ;; Line that contains code and comment (or nil) + start + c spaces len dc (comment-column comment-column)) + ;; Figure out what kind of comment we are looking at. + (save-excursion + (beginning-of-line) + (cond + + ;; A line with nothing but a comment on it? + ((looking-at "[ \t]*#[# \t]*") + (setq has-comment t + comment-fill-prefix (buffer-substring (match-beginning 0) + (match-end 0)))) + + ;; A line with some code, followed by a comment? Remember that the + ;; semi which starts the comment shouldn't be part of a string or + ;; character. + ((cperl-to-comment-or-eol) + (setq has-comment t) + (looking-at "#+[ \t]*") + (setq start (point) c (current-column) + comment-fill-prefix + (concat (make-string (current-column) ?\ ) + (buffer-substring (match-beginning 0) (match-end 0))) + spaces (progn (skip-chars-backward " \t") + (buffer-substring (point) start)) + dc (- c (current-column)) len (- start (point)) + start (point-marker)) + (delete-char len) + (insert (make-string dc ?-))))) + (if (not has-comment) + (fill-paragraph justify) ; Do the usual thing outside of comment + ;; Narrow to include only the comment, and then fill the region. + (save-restriction + (narrow-to-region + ;; Find the first line we should include in the region to fill. + (if start (progn (beginning-of-line) (point)) + (save-excursion + (while (and (zerop (forward-line -1)) + (looking-at "^[ \t]*#+[ \t]*[^ \t\n]"))) + ;; We may have gone to far. Go forward again. + (or (looking-at "^[ \t]*#+[ \t]*[^ \t\n]") + (forward-line 1)) + (point))) + ;; Find the beginning of the first line past the region to fill. + (save-excursion + (while (progn (forward-line 1) + (looking-at "^[ \t]*#+[ \t]*[^ \t\n]"))) + (point))) + ;; Remove existing hashes + (goto-char (point-min)) + (while (progn (forward-line 1) (< (point) (point-max))) + (skip-chars-forward " \t") + (and (looking-at "#+") + (delete-char (- (match-end 0) (match-beginning 0))))) + + ;; Lines with only hashes on them can be paragraph boundaries. + (let ((paragraph-start (concat paragraph-start "\\|^[ \t#]*$")) + (paragraph-separate (concat paragraph-start "\\|^[ \t#]*$")) + (fill-prefix comment-fill-prefix)) + (fill-paragraph justify))) + (if (and start) + (progn + (goto-char start) + (if (> dc 0) + (progn (delete-char dc) (insert spaces))) + (if (or (= (current-column) c) iteration) nil + (setq comment-column c) + (indent-for-comment) + ;; Repeat once more, flagging as iteration + (cperl-fill-paragraph justify t))))))) + +(defun cperl-do-auto-fill () + ;; Break out if the line is short enough + (if (> (save-excursion + (end-of-line) + (current-column)) + fill-column) + (let ((c (save-excursion (beginning-of-line) + (cperl-to-comment-or-eol) (point))) + (s (memq (following-char) '(?\ ?\t))) marker) + (if (>= c (point)) nil + (setq marker (point-marker)) + (cperl-fill-paragraph) + (goto-char marker) + ;; Is not enough, sometimes marker is a start of line + (if (bolp) (progn (re-search-forward "#+[ \t]*") + (goto-char (match-end 0)))) + ;; Following space could have gone: + (if (or (not s) (memq (following-char) '(?\ ?\t))) nil + (insert " ") + (backward-char 1)) + ;; Previous space could have gone: + (or (memq (preceding-char) '(?\ ?\t)) (insert " ")))))) + +(defvar imenu-example--function-name-regexp-perl + "^[ \t]*\\(sub\\|package\\)[ \t\n]+\\([a-zA-Z_0-9:']+\\)[ \t]*") + +(defun imenu-example--create-perl-index (&optional regexp) + (require 'cl) + (let ((index-alist '()) (index-pack-alist '()) packages ends-ranges p + (prev-pos 0) char fchar index name (end-range 0) package) + (goto-char (point-min)) + (imenu-progress-message prev-pos 0) + ;; Search for the function + (save-match-data + (while (re-search-forward + (or regexp imenu-example--function-name-regexp-perl) + nil t) + (imenu-progress-message prev-pos) + ;;(backward-up-list 1) + (save-excursion + (goto-char (match-beginning 1)) + (setq fchar (following-char)) + ) + (setq char (following-char)) + (setq p (point)) + (while (and ends-ranges (>= p (car ends-ranges))) + ;; delete obsolete entries + (setq ends-ranges (cdr ends-ranges) packages (cdr packages))) + (setq package (or (car packages) "") + end-range (or (car ends-ranges) 0)) + (if (eq fchar ?p) + (progn + (setq name (buffer-substring (match-beginning 2) (match-end 2)) + 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 + (if (eq fchar ?p) nil + (setq name (buffer-substring (match-beginning 2) (match-end 2))) + (if (or (> p end-range) (string-match "[:']" name)) nil + (setq name (concat package name)))) + (setq index (imenu-example--name-and-position)) + (setcar index name) + (if (eq fchar ?p) + (push index index-pack-alist) + (push index index-alist))))) + (imenu-progress-message prev-pos 100) + (and index-pack-alist + (push (cons (imenu-create-submenu-name "Packages") index-pack-alist) + index-alist)) + (nreverse index-alist))) + +(defvar cperl-compilation-error-regexp-alist + ;; This look like a paranoiac regexp: could anybody find a better one? (which WORK). + '(("^[^\n]* \\(file\\|at\\) \\([^ \t\n]+\\) [^\n]*line \\([0-9]+\\)[\\., \n]" + 2 3)) + "Alist that specifies how to match errors in perl output.") + +(if (fboundp 'eval-after-load) + (eval-after-load + "mode-compile" + '(setq perl-compilation-error-regexp-alist + cperl-compilation-error-regexp-alist))) + + +(defvar cperl-faces-init nil) + +(defun cperl-windowed-init () + "Initialization under windowed version." + (add-hook 'font-lock-mode-hook + (function + (lambda () + (if (or + (eq major-mode 'perl-mode) + (eq major-mode 'cperl-mode)) + (progn + (or cperl-faces-init (cperl-init-faces)) + (setq font-lock-keywords perl-font-lock-keywords + cperl-faces-init t))))))) + +(defun cperl-init-faces () + (condition-case nil + (progn + (require 'font-lock) + (let (t-font-lock-keywords) + ;;(defvar cperl-font-lock-enhanced nil + ;; "Set to be non-nil if font-lock allows active highlights.") + (setq + t-font-lock-keywords + (list + (cons + (concat + "\\(^\\|[^$@%&\\]\\)\\<\\(" + (mapconcat + 'identity + '("if" "until" "while" "elsif" "else" "unless" "for" + "foreach" "continue" "exit" "die" "last" "goto" "next" + "redo" "return" "local" "exec" "sub" "do" "dump" "use" + "require" "package" "eval" "my" "BEGIN" "END") + "\\|") ; Flow control + "\\)\\>") 2) ; was "\\)[ \n\t;():,\|&]" + ; In what follows we use `type' style + ; for overwritable buildins + (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" + "a\\(bs\\|ccept\\|tan2\\|larm\\|nd\\)\\|" + "b\\(in\\(d\\|mode\\)\\|less\\)\\|" + "c\\(h\\(r\\(\\|oot\\)\\|dir\\|mod\\|own\\)\\|aller\\|rypt\\|" + "lose\\(\\|dir\\)\\|mp\\|o\\(s\\|n\\(tinue\\|nect\\)\\)\\)\\|" + "CORE\\|d\\(ie\\|bm\\(close\\|open\\)\\|ump\\)\\|" + "e\\(x\\(p\\|it\\|ec\\)\\|q\\|nd\\(p\\(rotoent\\|went\\)\\|" + "hostent\\|servent\\|netent\\|grent\\)\\|of\\)\\|" + "f\\(ileno\\|cntl\\|lock\\|or\\(k\\|mline\\)\\)\\|" + "g\\(t\\|lob\\|mtime\\|e\\(\\|t\\(p\\(pid\\|r\\(iority\\|" + "oto\\(byn\\(ame\\|umber\\)\\|ent\\)\\)\\|eername\\|w" + "\\(uid\\|ent\\|nam\\)\\|grp\\)\\|host\\(by\\(addr\\|name\\)\\|" + "ent\\)\\|s\\(erv\\(by\\(port\\|name\\)\\|ent\\)\\|" + "ock\\(name\\|opt\\)\\)\\|c\\|login\\|net\\(by\\(addr\\|name\\)\\|" + "ent\\)\\|gr\\(ent\\|nam\\|gid\\)\\)\\)\\)\\|" + "hex\\|i\\(n\\(t\\|dex\\)\\|octl\\)\\|join\\|kill\\|" + "l\\(i\\(sten\\|nk\\)\\|stat\\|c\\(\\|first\\)\\|t\\|e" + "\\(\\|ngth\\)\\|o\\(caltime\\|g\\)\\)\\|m\\(sg\\(rcv\\|snd\\|" + "ctl\\|get\\)\\|kdir\\)\\|n\\(e\\|ot\\)\\|o\\(pen\\(\\|dir\\)\\|" + "r\\(\\|d\\)\\|ct\\)\\|p\\(ipe\\|ack\\)\\|quotemeta\\|" + "r\\(index\\|and\\|mdir\\|e\\(quire\\|ad\\(pipe\\|\\|lin" + "\\(k\\|e\\)\\|dir\\)\\|set\\|cv\\|verse\\|f\\|winddir\\|name" + "\\)\\)\\|s\\(printf\\|qrt\\|rand\\|tat\\|ubstr\\|e\\(t\\(p\\(r" + "\\(iority\\|otoent\\)\\|went\\|grp\\)\\|hostent\\|s\\(ervent\\|" + "ockopt\\)\\|netent\\|grent\\)\\|ek\\(\\|dir\\)\\|lect\\|" + "m\\(ctl\\|op\\|get\\)\\|nd\\)\\|h\\(utdown\\|m\\(read\\|ctl\\|" + "write\\|get\\)\\)\\|y\\(s\\(read\\|call\\|tem\\|write\\)\\|" + "mlink\\)\\|in\\|leep\\|ocket\\(pair\\|\\)\\)\\|t\\(runcate\\|" + "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__\\)" + "\\)\\>") 2 'font-lock-type-face) + ;; In what follows we use `other' style + ;; for nonoverwritable buildins + ;; Somehow 's', 'm' are not autogenerated??? + (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\\|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\\|" + "l\\(ast\\|ocal\\)\\|m\\(ap\\|y\\)\\|n\\(ext\\|o\\)\\|" + "p\\(ackage\\|rint\\(\\|f\\)\\|ush\\|o\\(p\\|s\\)\\)\\|" + "q\\(\\|q\\|w\\|x\\)\\|re\\(turn\\|do\\)\\|s\\(pli\\(ce\\|t\\)\\|" + "calar\\|tudy\\|ub\\|hift\\|ort\\)\\|t\\(r\\|ie\\)\\|" + "u\\(se\\|n\\(shift\\|ti\\(l\\|e\\)\\|def\\|less\\)\\)\\|" + "while\\|y\\|__\\(END\\|DATA\\)__" ;__DATA__ added manually + "\\|[sm]" ; Added manually + "\\)\\>") 2 'font-lock-other-type-face) + ;; (mapconcat 'identity + ;; '("#endif" "#else" "#ifdef" "#ifndef" "#if" + ;; "#include" "#define" "#undef") + ;; "\\|") + '("-[rwxoRWXOezsfdlpSbctugkTBMAC]\\>\\([ \t]+_\\>\\)?" 0 + font-lock-function-name-face) ; Not very good, triggers at "[a-z]" + '("\\<sub[ \t]+\\([^ \t{]+\\)[ \t]*[{\n]" 1 + font-lock-function-name-face) + '("\\<\\(package\\|require\\|use\\)[ \t]+\\([a-zA-z_][a-zA-z_0-9:]*\\)[ \t;]" ; require A if B; + 2 font-lock-function-name-face) + (if (featurep 'font-lock-extra) + '("\\([]}\\\\%@>*&]\\|\\$[a-zA-Z0-9_:]*\\)[ \t]*{[ \t]*\\([a-zA-Z0-9_:]+\\)[ \t]*}" + (2 font-lock-string-face t) + (0 '(restart 2 t))) ; To highlight $a{bc}{ef} + '("\\([]}\\\\%@>*&]\\|\\$[a-zA-Z0-9_:]*\\)[ \t]*{[ \t]*\\([a-zA-Z0-9_:]+\\)[ \t]*}" + 2 font-lock-string-face t)) + '("[ \t{,(]\\([a-zA-Z0-9_:]+\\)[ \t]*=>" 1 + font-lock-string-face t) + '("^[ \t]*\\([a-zA-Z0-9_]+[ \t]*:\\)[ \t]*\\($\\|{\\|\\<\\(until\\|while\\|for\\(each\\)?\\|do\\)\\>\\)" 1 + font-lock-reference-face) ; labels + '("\\<\\(continue\\|next\\|last\\|redo\\|goto\\)\\>[ \t]+\\([a-zA-Z0-9_:]+\\)" ; labels as targets + 2 font-lock-reference-face) + (if (featurep 'font-lock-extra) + '("^[ \t]*\\(my\\|local\\)[ \t]*\\(([ \t]*\\)?\\([$@%][a-zA-Z0-9_]+\\)\\([ \t]*,\\)?" + (3 font-lock-variable-name-face) + (4 '(another 4 nil + ("[ \t]*,[ \t]*\\([$@%][a-zA-Z0-9_]+\\)\\([ \t]*,\\)?" + (1 font-lock-variable-name-face) + (2 '(restart 2 nil) nil t))) + nil t)) ; local variables, multiple + '("^[ \t]*\\(my\\|local\\)[ \t]*\\(([ \t]*\\)?\\([$@%][a-zA-Z0-9_]+\\)" + 3 font-lock-variable-name-face)) + '("\\<for\\(each\\)?[ \t]*\\(\\$[a-zA-Z_][a-zA-Z_0-9]*\\)[ \t]*(" + 2 font-lock-variable-name-face))) + (if (and (fboundp 'turn-on-font-lock) ; Check for newer font-lock + (not (cperl-xemacs-p))) ; not yet as of XEmacs 19.12 + (setq t-font-lock-keywords + (append + t-font-lock-keywords + '(("\\(\\([$@]+\\)[a-zA-Z_:][a-zA-Z0-9_:]*\\)[ \t]*\\([[{]\\)" + 1 + (if (= (- (match-end 2) (match-beginning 2)) 1) + (if (eq (char-after (match-beginning 3)) ?{) + font-lock-other-emphasized-face + 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_]\\)\\|\\(/\\)\\)" + ;;(3 font-lock-function-name-face t t) + ;;(4 + ;; (if (cperl-slash-is-regexp) + ;; font-lock-function-name-face 'default) nil t)) + )))) + (defconst perl-font-lock-keywords t-font-lock-keywords + "Additional expressions to highlight in Perl mode.")) + (if (fboundp 'ps-print-buffer) (cperl-ps-print-init)) + (if (featurep 'font-lock-extra) + (font-lock-require-faces + (list + ;; Color-light Color-dark Gray-light Gray-dark Mono + (list 'font-lock-comment-face + ["Firebrick" "OrangeRed" "DimGray" "Gray80"] + nil + [nil nil t t t] + [nil nil t t t] + nil) + (list 'font-lock-string-face + ["RosyBrown" "LightSalmon" "Gray50" "LightGray"] + nil + nil + [nil nil t t t] + nil) + (list 'font-lock-keyword-face + ["Purple" "LightSteelBlue" "DimGray" "Gray90"] + nil + [nil nil t t t] + nil + nil) + (list 'font-lock-function-name-face + (vector + "Blue" "LightSkyBlue" "Gray50" "LightGray" + (cdr (assq 'background-color ; if mono + (frame-parameters)))) + (vector + nil nil nil nil + (cdr (assq 'foreground-color ; if mono + (frame-parameters)))) + [nil nil t t t] + nil + nil) + (list 'font-lock-variable-name-face + ["DarkGoldenrod" "LightGoldenrod" "DimGray" "Gray90"] + nil + [nil nil t t t] + [nil nil t t t] + nil) + (list 'font-lock-type-face + ["DarkOliveGreen" "PaleGreen" "DimGray" "Gray80"] + nil + [nil nil t t t] + nil + [nil nil t t t] + ) + (list 'font-lock-reference-face + ["CadetBlue" "Aquamarine" "Gray50" "LightGray"] + nil + [nil nil t t t] + nil + [nil nil t t t] + ) + (list 'font-lock-other-type-face + ["chartreuse3" ("orchid1" "orange") + nil "Gray80"] + [nil nil "gray90"] + [nil nil nil t t] + [nil nil t t] + [nil nil t t t] + ) + (list 'font-lock-emphasized-face + ["blue" "yellow" nil "Gray80"] + ["lightyellow2" ("navy" "os2blue" "darkgreen") + "gray90"] + t + nil + nil) + (list 'font-lock-other-emphasized-face + ["red" "red" nil "Gray80"] + ["lightyellow2" ("navy" "os2blue" "darkgreen") + "gray90"] + t + t + nil))) + (defvar cperl-guessed-background nil + "Display characteristics as guessed by cperl.") + (or (fboundp 'x-color-defined-p) + (defalias 'x-color-defined-p + (cond ((fboundp 'color-defined-p) 'color-defined-p) + ;; XEmacs >= 19.12 + ((fboundp 'valid-color-name-p) 'valid-color-name-p) + ;; XEmacs 19.11 + (t 'x-valid-color-name-p)))) + (defvar font-lock-reference-face 'font-lock-reference-face) + (defvar font-lock-variable-name-face 'font-lock-variable-name-face) + (or (boundp 'font-lock-type-face) + (defconst font-lock-type-face + 'font-lock-type-face + "Face to use for data types.") + ) + (or (boundp 'font-lock-other-type-face) + (defconst font-lock-other-type-face + 'font-lock-other-type-face + "Face to use for data types from another group.") + ) + (if (not (cperl-xemacs-p)) nil + (or (boundp 'font-lock-comment-face) + (defconst font-lock-comment-face + 'font-lock-comment-face + "Face to use for comments.") + ) + (or (boundp 'font-lock-keyword-face) + (defconst font-lock-keyword-face + 'font-lock-keyword-face + "Face to use for keywords.") + ) + (or (boundp 'font-lock-function-name-face) + (defconst font-lock-function-name-face + 'font-lock-function-name-face + "Face to use for function names.") + ) + ) + ;;(if (featurep 'font-lock) + (if (face-equal font-lock-type-face font-lock-comment-face) + (defconst font-lock-type-face + 'font-lock-type-face + "Face to use for basic data types.") + ) +;;; (if (fboundp 'eval-after-load) +;;; (eval-after-load "font-lock" +;;; '(if (face-equal font-lock-type-face +;;; font-lock-comment-face) +;;; (defconst font-lock-type-face +;;; 'font-lock-type-face +;;; "Face to use for basic data types.") +;;; ))) ; This does not work :-( Why?! +;;; ; Workaround: added to font-lock-m-h +;;; ) + (or (boundp 'font-lock-other-emphasized-face) + (defconst font-lock-other-emphasized-face + 'font-lock-other-emphasized-face + "Face to use for another type of emphasizing.") + ) + (or (boundp 'font-lock-emphasized-face) + (defconst font-lock-emphasized-face + 'font-lock-emphasized-face + "Face to use for emphasizing.") + ) + ;; Here we try to guess background + (let ((background + (if (boundp 'font-lock-background-mode) + font-lock-background-mode + 'light)) + (face-list (and (fboundp 'face-list) (face-list))) + is-face) + (fset 'is-face + (cond ((fboundp 'find-face) + (symbol-function 'find-face)) + (face-list + (function (lambda (face) (member face face-list)))) + (t + (function (lambda (face) (boundp face)))))) + (defvar cperl-guessed-background + (if (and (boundp 'font-lock-display-type) + (eq font-lock-display-type 'grayscale)) + 'gray + background) + "Background as guessed by CPerl mode") + (if (is-face 'font-lock-type-face) nil + (copy-face 'default 'font-lock-type-face) + (cond + ((eq background 'light) + (set-face-foreground 'font-lock-type-face + (if (x-color-defined-p "seagreen") + "seagreen" + "sea green"))) + ((eq background 'dark) + (set-face-foreground 'font-lock-type-face + (if (x-color-defined-p "os2pink") + "os2pink" + "pink"))) + (t + (set-face-background 'font-lock-type-face "gray90")))) + (if (is-face 'font-lock-other-type-face) + nil + (copy-face 'font-lock-type-face 'font-lock-other-type-face) + (cond + ((eq background 'light) + (set-face-foreground 'font-lock-other-type-face + (if (x-color-defined-p "chartreuse3") + "chartreuse3" + "chartreuse"))) + ((eq background 'dark) + (set-face-foreground 'font-lock-other-type-face + (if (x-color-defined-p "orchid1") + "orchid1" + "orange"))))) + (if (is-face 'font-lock-other-emphasized-face) nil + (copy-face 'bold-italic 'font-lock-other-emphasized-face) + (cond + ((eq background 'light) + (set-face-background 'font-lock-other-emphasized-face + (if (x-color-defined-p "lightyellow2") + "lightyellow2" + (if (x-color-defined-p "lightyellow") + "lightyellow" + "light yellow")))) + ((eq background 'dark) + (set-face-background 'font-lock-other-emphasized-face + (if (x-color-defined-p "navy") + "navy" + (if (x-color-defined-p "darkgreen") + "darkgreen" + "dark green")))) + (t (set-face-background 'font-lock-other-emphasized-face "gray90")))) + (if (is-face 'font-lock-emphasized-face) nil + (copy-face 'bold 'font-lock-emphasized-face) + (cond + ((eq background 'light) + (set-face-background 'font-lock-emphasized-face + (if (x-color-defined-p "lightyellow2") + "lightyellow2" + "lightyellow"))) + ((eq background 'dark) + (set-face-background 'font-lock-emphasized-face + (if (x-color-defined-p "navy") + "navy" + (if (x-color-defined-p "darkgreen") + "darkgreen" + "dark green")))) + (t (set-face-background 'font-lock-emphasized-face "gray90")))) + (if (is-face 'font-lock-variable-name-face) nil + (copy-face 'italic 'font-lock-variable-name-face)) + (if (is-face 'font-lock-reference-face) nil + (copy-face 'italic 'font-lock-reference-face))))) + (error nil))) + + +(defun cperl-ps-print-init () + "Initialization of `ps-print' components for faces used in CPerl." + ;; Guard against old versions + (defvar ps-underlined-faces nil) + (defvar ps-bold-faces nil) + (defvar ps-italic-faces nil) + (setq ps-bold-faces + (append '(font-lock-emphasized-face + font-lock-keyword-face + font-lock-variable-name-face + font-lock-reference-face + font-lock-other-emphasized-face) + ps-bold-faces)) + (setq ps-italic-faces + (append '(font-lock-other-type-face + font-lock-reference-face + font-lock-other-emphasized-face) + ps-italic-faces)) + (setq ps-underlined-faces + (append '(font-lock-emphasized-face + font-lock-other-emphasized-face + font-lock-other-type-face font-lock-type-face) + ps-underlined-faces)) + (cons 'font-lock-type-face ps-underlined-faces)) + + +(if (cperl-enable-font-lock) (cperl-windowed-init)) + +(defun cperl-set-style (style) + "Set CPerl-mode variables to use one of several different indentation styles. +The arguments are a string representing the desired style. +Available styles are GNU, K&R, BSD and Whitesmith." + (interactive + (let ((list (mapcar (function (lambda (elt) (list (car elt)))) + c-style-alist))) + (list (completing-read "Enter style: " list nil 'insist)))) + (let ((style (cdr (assoc style c-style-alist))) setting str sym) + (while style + (setq setting (car style) style (cdr style)) + (setq str (symbol-name (car setting))) + (and (string-match "^c-" str) + (setq str (concat "cperl-" (substring str 2))) + (setq sym (intern-soft str)) + (boundp sym) + (set sym (cdr setting)))))) + +(defun cperl-check-syntax () + (interactive) + (require 'mode-compile) + (let ((perl-dbg-flags "-wc")) + (mode-compile))) + +(defun cperl-info-buffer () + ;; Returns buffer with documentation. Creats if missing + (let ((info (get-buffer "*info-perl*"))) + (if info info + (save-window-excursion + ;; Get Info running + (require 'info) + (save-window-excursion + (info)) + (Info-find-node "perl5" "perlfunc") + (set-buffer "*info*") + (rename-buffer "*info-perl*") + (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)))) + +(defun cperl-info-on-command (command) + "Shows documentation for Perl command in other window." + (interactive + (let* ((default (cperl-word-at-point)) + (read (read-string + (format "Find doc for Perl function (default %s): " + default)))) + (list (if (equal read "") + default + read)))) + + (let ((buffer (current-buffer)) + (cmd-desc (concat "^" (regexp-quote command) "[ \t\n]")) + pos) + (if (string-match "^-[a-zA-Z]$" command) + (setq cmd-desc "^-X[ \t\n]")) + (set-buffer (cperl-info-buffer)) + (beginning-of-buffer) + (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)) + (set-window-start (selected-window) pos)) + (message "No entry for %s found." command)) + (pop-to-buffer buffer))) + +(defun cperl-info-on-current-command () + "Shows documentation for Perl command at point in other window." + (interactive) + (cperl-info-on-command (cperl-word-at-point))) + +(defun cperl-imenu-info-imenu-search () + (if (looking-at "^-X[ \t\n]") nil + (re-search-backward + "^\n\\([-a-zA-Z]+\\)[ \t\n]") + (forward-line 1))) + +(defun cperl-imenu-info-imenu-name () + (buffer-substring + (match-beginning 1) (match-end 1))) + +(defun cperl-imenu-on-info () + (interactive) + (let* ((buffer (current-buffer)) + imenu-create-index-function + imenu-prev-index-position-function + imenu-extract-index-name-function + (index-item (save-restriction + (save-window-excursion + (set-buffer (cperl-info-buffer)) + (setq imenu-create-index-function + 'imenu-default-create-index-function + imenu-prev-index-position-function + 'cperl-imenu-info-imenu-search + imenu-extract-index-name-function + 'cperl-imenu-info-imenu-name) + (imenu-choose-buffer-index))))) + (and index-item + (progn + (push-mark) + (pop-to-buffer "*info-perl*") + (cond + ((markerp (cdr index-item)) + (goto-char (marker-position (cdr index-item)))) + (t + (goto-char (cdr index-item)))) + (set-window-start (selected-window) (point)) + (pop-to-buffer buffer))))) + +(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 +partially contained in the region are lined up at the same column. + +MINSHIFT is the minimal amount of space to insert before the construction. +STEP is the tabwidth to position constructions. +If STEP is `nil', `cperl-lineup-step' will be used +\(or `cperl-indent-level', if `cperl-lineup-step' is `nil'). +Will not move the position at the start to the left." + (interactive "r") + (let (search col tcol seen b e) + (save-excursion + (goto-char end) + (end-of-line) + (setq end (point-marker)) + (goto-char beg) + (skip-chars-forward " \t\f") + (setq beg (point-marker)) + (indent-region beg end nil) + (goto-char beg) + (setq col (current-column)) + (if (looking-at "\\sw") + (if (looking-at "\\<\\sw+\\>") + (setq search + (concat "\\<" + (regexp-quote + (buffer-substring (match-beginning 0) + (match-end 0))) "\\>")) + (error "Cannot line up in a middle of the word")) + (if (looking-at "$") + (error "Cannot line up end of line")) + (setq search (regexp-quote (char-to-string (following-char))))) + (setq step (or step cperl-lineup-step cperl-indent-level)) + (or minshift (setq minshift 1)) + (while (progn + (beginning-of-line 2) + (and (< (point) end) + (re-search-forward search end t) + (goto-char (match-beginning 0)))) + (setq tcol (current-column) seen t) + (if (> tcol col) (setq col tcol))) + (or seen + (error "The construction to line up occured only once")) + (goto-char beg) + (setq col (+ col minshift)) + (if (/= (% col step) 0) (setq step (* step (1+ (/ col step))))) + (while + (progn + (setq e (point)) + (skip-chars-backward " \t") + (delete-region (point) e) + (indent-to-column col); (make-string (- col (current-column)) ?\ )) + (beginning-of-line 2) + (and (< (point) end) + (re-search-forward search end t) + (goto-char (match-beginning 0)))))))) ; No body + +(defun cperl-etags (&optional add all files) + "Run etags with appropriate options for Perl files. +If optional argument ALL is `recursive', will process Perl files +in subdirectories too." + (interactive) + (let ((cmd "etags") + (args '("-l" "none" "-r" "/\\<\\(package\\|sub\\)[ \\t]+\\(\\([a-zA-Z0-9:_]*::\\)?\\([a-zA-Z0-9_]+\\)[ \\t]*\\([{#]\\|$\\)\\)/\\4/")) + res) + (if add (setq args (cons "-a" args))) + (or files (setq files (list buffer-file-name))) + (cond + ((eq all 'recursive) + ;;(error "Not implemented: recursive") + (setq args (append (list "-e" + "sub wanted {push @ARGV, $File::Find::name if /\\.[Pp][Llm]$/} + use File::Find; + find(\\&wanted, '.'); + exec @ARGV;" + cmd) args) + cmd "perl")) + (all + ;;(error "Not implemented: all") + (setq args (append (list "-e" + "push @ARGV, <*.PL *.pl *.pm>; + exec @ARGV;" + cmd) args) + cmd "perl")) + (t + (setq args (append args files)))) + (setq res (apply 'call-process cmd nil nil nil args)) + (or (eq res 0) + (message "etags returned \"%s\"" res)))) diff --git a/emacs/emacs19 b/emacs/emacs19 deleted file mode 100644 index c3bb070a64..0000000000 --- a/emacs/emacs19 +++ /dev/null @@ -1,312 +0,0 @@ -Article 15041 of comp.lang.perl: -Path: netlabs!news.cerf.net!usc!sol.ctr.columbia.edu!news.kei.com!bloom-beacon.mit.edu!paperboy.osf.org!meissner -From: meissner@osf.org (Michael Meissner) -Newsgroups: comp.lang.perl -Subject: Re: question on using perldb.el with emacs -Date: 17 Oct 1993 21:10:21 GMT -Organization: Open Software Foundation -Lines: 297 -Message-ID: <MEISSNER.93Oct17171021@pasta.osf.org> -References: <BSHAW.93Oct17143524@bobasun.spdc.ti.com> -NNTP-Posting-Host: pasta.osf.org -In-reply-to: bshaw@bobasun.spdc.ti.com's message of Sun, 17 Oct 1993 19:35:24 GMT - -In article <BSHAW.93Oct17143524@bobasun.spdc.ti.com> bshaw@bobasun.spdc.ti.com -(Bob Shaw) writes: - -| Hi folks -| -| Say, I'm trying to use perldb with emacs. I can invoke perldb -| within emacs ok and get the window *perldb-foo* but when it asks -| for "additional command line arguments" , no matter what I give it -| I get the error message Symbol's function definition is void: make- -| shell. -| -| The debugger , by itself, works fine but wanted to try out perldb in -| emacs. - -This is a symptom of using Emacs 19.xx with perldb.el which was originally made -for emacs version 18.xx. You can either install the emacs19 replacement for -perldb that hooks it in with GUD (grand unified debugger), or apply the patches -that I picked off of the net (I use the perldb replacement that uses GUD -myself): - -#!/bin/sh -# This is a shell archive (produced by shar 3.49) -# To extract the files from this archive, save it to a file, remove -# everything above the "!/bin/sh" line above, and type "sh file_name". -# -# made 10/17/1993 21:07 UTC by meissner@pasta.osf.org -# Source directory /usr/users/meissner/elisp -# -# existing files will NOT be overwritten unless -c is specified -# -# This shar contains: -# length mode name -# ------ ---------- ------------------------------------------ -# 4761 -rw-r--r-- emacs19-perldb.el -# 3845 -rw-rw-r-- emacs19-perldb.patches -# -# ============= emacs19-perldb.el ============== -if test -f 'emacs19-perldb.el' -a X"$1" != X"-c"; then - echo 'x - skipping emacs19-perldb.el (File already exists)' -else -echo 'x - extracting emacs19-perldb.el (Text)' -sed 's/^X//' << 'SHAR_EOF' > 'emacs19-perldb.el' && -X;; Author : Stephane Boucher -X;; Note : This is an add on for gud (Part of GNU Emacs 19). It is -X;; derived from the gdb section that is part of gud. -X -X;; Copyright (C) 1993 Stephane Boucher. -X -X;; Perldb is free software; you can redistribute it and/or modify -X;; it under the terms of the GNU General Public License as published by -X;; the Free Software Foundation; either version 2, or (at your option) -X;; any later version. -X -X;; Perldb Emacs is distributed in the hope that it will be useful, -X;; but WITHOUT ANY WARRANTY; without even the implied warranty of -X;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -X;; GNU General Public License for more details. -X -X;; You should have received a copy of the GNU General Public License -X;; along with GNU Emacs; see the file COPYING. If not, write to -X;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -X -X(require 'gud) -X -X;; ====================================================================== -X;; perldb functions -X -X;;; History of argument lists passed to perldb. -X(defvar gud-perldb-history nil) -X -X(defun gud-perldb-massage-args (file args) -X (cons "-d" (cons file (cons "-emacs" args)))) -X -X;; There's no guarantee that Emacs will hand the filter the entire -X;; marker at once; it could be broken up across several strings. We -X;; might even receive a big chunk with several markers in it. If we -X;; receive a chunk of text which looks like it might contain the -X;; beginning of a marker, we save it here between calls to the -X;; filter. -X(defvar gud-perldb-marker-acc "") -X -X(defun gud-perldb-marker-filter (string) -X (save-match-data -X (setq gud-perldb-marker-acc (concat gud-perldb-marker-acc string)) -X (let ((output "")) -X -X ;; Process all the complete markers in this chunk. -X (while (string-match "^\032\032\\([^:\n]*\\):\\([0-9]*\\):.*\n" -X gud-perldb-marker-acc) -X (setq -X -X ;; Extract the frame position from the marker. -X gud-last-frame -X (cons (substring gud-perldb-marker-acc (match-beginning 1) (match-end 1)) -X (string-to-int (substring gud-perldb-marker-acc -X (match-beginning 2) -X (match-end 2)))) -X -X ;; Append any text before the marker to the output we're going -X ;; to return - we don't include the marker in this text. -X output (concat output -X (substring gud-perldb-marker-acc 0 (match-beginning 0))) -X -X ;; Set the accumulator to the remaining text. -X gud-perldb-marker-acc (substring gud-perldb-marker-acc (match-end 0)))) -X -X ;; Does the remaining text look like it might end with the -X ;; beginning of another marker? If it does, then keep it in -X ;; gud-perldb-marker-acc until we receive the rest of it. Since we -X ;; know the full marker regexp above failed, it's pretty simple to -X ;; test for marker starts. -X (if (string-match "^\032.*\\'" gud-perldb-marker-acc) -X (progn -X ;; Everything before the potential marker start can be output. -X (setq output (concat output (substring gud-perldb-marker-acc -X 0 (match-beginning 0)))) -X -X ;; Everything after, we save, to combine with later input. -X (setq gud-perldb-marker-acc -X (substring gud-perldb-marker-acc (match-beginning 0)))) -X -X (setq output (concat output gud-perldb-marker-acc) -X gud-perldb-marker-acc "")) -X -X output))) -X -X(defun gud-perldb-find-file (f) -X (find-file-noselect f)) -X -X;;;###autoload -X(defun perldb (command-line) -X "Run perldb on program FILE in buffer *gud-FILE*. -XThe directory containing FILE becomes the initial working directory -Xand source-file directory for your debugger." -X (interactive -X (list (read-from-minibuffer "Run perldb (like this): " -X (if (consp gud-perldb-history) -X (car gud-perldb-history) -X "perl ") -X nil nil -X '(gud-perldb-history . 1)))) -X (gud-overload-functions '((gud-massage-args . gud-perldb-massage-args) -X (gud-marker-filter . gud-perldb-marker-filter) -X (gud-find-file . gud-perldb-find-file) -X )) -X -X (gud-common-init command-line) -X -X (gud-def gud-break "b %l" "\C-b" "Set breakpoint at current line.") -X (gud-def gud-remove "d %l" "\C-d" "Remove breakpoint at current line") -X (gud-def gud-step "s" "\C-s" "Step one source line with display.") -X (gud-def gud-next "n" "\C-n" "Step one line (skip functions).") -X (gud-def gud-cont "c" "\C-r" "Continue with display.") -X; (gud-def gud-finish "finish" "\C-f" "Finish executing current function.") -X; (gud-def gud-up "up %p" "<" "Up N stack frames (numeric arg).") -X; (gud-def gud-down "down %p" ">" "Down N stack frames (numeric arg).") -X (gud-def gud-print "%e" "\C-p" "Evaluate perl expression at point.") -X -X (setq comint-prompt-regexp "^ DB<[0-9]+> ") -X (run-hooks 'perldb-mode-hook) -X ) -SHAR_EOF -chmod 0644 emacs19-perldb.el || -echo 'restore of emacs19-perldb.el failed' -Wc_c="`wc -c < 'emacs19-perldb.el'`" -test 4761 -eq "$Wc_c" || - echo 'emacs19-perldb.el: original size 4761, current size' "$Wc_c" -fi -# ============= emacs19-perldb.patches ============== -if test -f 'emacs19-perldb.patches' -a X"$1" != X"-c"; then - echo 'x - skipping emacs19-perldb.patches (File already exists)' -else -echo 'x - extracting emacs19-perldb.patches (Text)' -sed 's/^X//' << 'SHAR_EOF' > 'emacs19-perldb.patches' && -XFrom dmm0t@rincewind.mech.virginia.edu Fri Jul 16 23:17:10 1993 -XPath: paperboy.osf.org!bloom-beacon.mit.edu!biosci!uwm.edu!ux1.cso.uiuc.edu!howland.reston.ans.net!darwin.sura.net!news-feed-2.peachnet.edu!concert!uvaarpa!murdoch!rincewind.mech.virginia.edu!dmm0t -XFrom: dmm0t@rincewind.mech.virginia.edu (David Meyer) -XNewsgroups: gnu.emacs.sources -XSubject: patches to perldb.el for emacs-19 -XMessage-ID: <CA7uq9.30J@murdoch.acc.Virginia.EDU> -XDate: 15 Jul 93 17:18:07 GMT -XSender: usenet@murdoch.acc.Virginia.EDU -XOrganization: University of Virginia -XLines: 97 -X -X -XHere are my patches to perldb.el (the perl debugger mode that comes -Xwith perl 4.0xx). Basically, all I've done is to hack perldb.el to -Xuse comint.el stuff rather than the old shell.el stuff (i.e. change -Xshell-mode-map to comint-mode-map). -X -XI've been using my patched version without problem, but if anyone sees -Xsomething I've missed, please post or send e-mail. -X -X Thanks, -X Dave -X -X -X*** /Users/dmm0t/perldb.el Thu Jul 15 13:06:59 1993 -X--- perldb.el Tue Jul 6 22:24:41 1993 -X*************** -X*** 65,71 **** -X -X (if perldb-mode-map -X nil -X! (setq perldb-mode-map (copy-keymap shell-mode-map)) -X (define-key perldb-mode-map "\C-l" 'perldb-refresh)) -X -X (define-key ctl-x-map " " 'perldb-break) -X--- 65,71 ---- -X -X (if perldb-mode-map -X nil -X! (setq perldb-mode-map (copy-keymap comint-mode-map)) -X (define-key perldb-mode-map "\C-l" 'perldb-refresh)) -X -X (define-key ctl-x-map " " 'perldb-break) -X*************** -X*** 122,131 **** -X (setq mode-name "Inferior Perl") -X (setq mode-line-process '(": %s")) -X (use-local-map perldb-mode-map) -X! (make-local-variable 'last-input-start) -X! (setq last-input-start (make-marker)) -X! (make-local-variable 'last-input-end) -X! (setq last-input-end (make-marker)) -X (make-local-variable 'perldb-last-frame) -X (setq perldb-last-frame nil) -X (make-local-variable 'perldb-last-frame-displayed-p) -X--- 122,131 ---- -X (setq mode-name "Inferior Perl") -X (setq mode-line-process '(": %s")) -X (use-local-map perldb-mode-map) -X! (make-local-variable 'comint-last-input-start) -X! (setq comint-last-input-start (make-marker)) -X! (make-local-variable 'comint-last-input-end) -X! (setq comint-last-input-end (make-marker)) -X (make-local-variable 'perldb-last-frame) -X (setq perldb-last-frame nil) -X (make-local-variable 'perldb-last-frame-displayed-p) -X*************** -X*** 134,142 **** -X (setq perldb-delete-prompt-marker nil) -X (make-local-variable 'perldb-filter-accumulator) -X (setq perldb-filter-accumulator nil) -X! (make-local-variable 'shell-prompt-pattern) -X! (setq shell-prompt-pattern perldb-prompt-pattern) -X! (run-hooks 'shell-mode-hook 'perldb-mode-hook)) -X -X (defvar current-perldb-buffer nil) -X -X--- 134,142 ---- -X (setq perldb-delete-prompt-marker nil) -X (make-local-variable 'perldb-filter-accumulator) -X (setq perldb-filter-accumulator nil) -X! (make-local-variable 'comint-prompt-regexp) -X! (setq comint-prompt-regexp perldb-prompt-pattern) -X! (run-hooks 'comint-mode-hook 'perldb-mode-hook)) -X -X (defvar current-perldb-buffer nil) -X -X*************** -X*** 189,195 **** -X (setq default-directory dir) -X (or (bolp) (newline)) -X (insert "Current directory is " default-directory "\n") -X! (apply 'make-shell -X (concat "perldb-" file) perldb-command-name nil "-d" path "-emacs" -X (parse-args args)) -X (perldb-mode) -X--- 189,195 ---- -X (setq default-directory dir) -X (or (bolp) (newline)) -X (insert "Current directory is " default-directory "\n") -X! (apply 'make-comint -X (concat "perldb-" file) perldb-command-name nil "-d" path "-emacs" -X (parse-args args)) -X (perldb-mode) -X-- -XDavid M. Meyer Mechanical & Aerospace Engineering -Xdmm0t@rincewind.mech.virginia.edu University of Virginia -XNeXTmail ok -X -SHAR_EOF -chmod 0664 emacs19-perldb.patches || -echo 'restore of emacs19-perldb.patches failed' -Wc_c="`wc -c < 'emacs19-perldb.patches'`" -test 3845 -eq "$Wc_c" || - echo 'emacs19-perldb.patches: original size 3845, current size' "$Wc_c" -fi -exit 0 - --- -Michael Meissner email: meissner@osf.org phone: 617-621-8861 -Open Software Foundation, 11 Cambridge Center, Cambridge, MA, 02142 - -Old hackers never die, their bugs just increase. - - diff --git a/emacs/perl-mode.el b/emacs/perl-mode.el deleted file mode 100644 index cb6195dec3..0000000000 --- a/emacs/perl-mode.el +++ /dev/null @@ -1,631 +0,0 @@ -;; Perl code editing commands for GNU Emacs -;; Copyright (C) 1990 William F. Mann -;; Adapted from C code editing commands 'c-mode.el', Copyright 1987 by the -;; Free Software Foundation, under terms of its General Public License. - -;; This file may be made part of GNU Emacs at the option of the FSF, or -;; of the perl distribution at the option of Larry Wall. - -;; This code is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY. No author or distributor -;; accepts responsibility to anyone for the consequences of using it -;; or for whether it serves any particular purpose or works at all, -;; unless he says so in writing. Refer to the GNU Emacs General Public -;; License for full details. - -;; Everyone is granted permission to copy, modify and redistribute -;; this code, but only under the conditions described in the -;; GNU Emacs General Public License. A copy of this license is -;; supposed to have been given to you along with GNU Emacs so you -;; can know your rights and responsibilities. It should be in a -;; file named COPYING. Among other things, the copyright notice -;; and this notice must be preserved on all copies. - -;; To enter perl-mode automatically, add (autoload 'perl-mode "perl-mode") -;; to your .emacs file and change the first line of your perl script to: -;; #!/usr/bin/perl -- # -*-Perl-*- -;; With argments to perl: -;; #!/usr/bin/perl -P- # -*-Perl-*- -;; To handle files included with do 'filename.pl';, add something like -;; (setq auto-mode-alist (append (list (cons "\\.pl$" 'perl-mode)) -;; auto-mode-alist)) -;; to your .emacs file; otherwise the .pl suffix defaults to prolog-mode. - -;; This code is based on the 18.53 version c-mode.el, with extensive -;; rewriting. Most of the features of c-mode survived intact. - -;; I added a new feature which adds functionality to TAB; it is controlled -;; by the variable perl-tab-to-comment. With it enabled, TAB does the -;; first thing it can from the following list: change the indentation; -;; move past leading white space; delete an empty comment; reindent a -;; comment; move to end of line; create an empty comment; tell you that -;; the line ends in a quoted string, or has a # which should be a \#. - -;; If your machine is slow, you may want to remove some of the bindings -;; to electric-perl-terminator. I changed the indenting defaults to be -;; what Larry Wall uses in perl/lib, but left in all the options. - -;; I also tuned a few things: comments and labels starting in column -;; zero are left there by indent-perl-exp; perl-beginning-of-function -;; goes back to the first open brace/paren in column zero, the open brace -;; in 'sub ... {', or the equal sign in 'format ... ='; indent-perl-exp -;; (meta-^q) indents from the current line through the close of the next -;; brace/paren, so you don't need to start exactly at a brace or paren. - -;; It may be good style to put a set of redundant braces around your -;; main program. This will let you reindent it with meta-^q. - -;; Known problems (these are all caused by limitations in the elisp -;; parsing routine (parse-partial-sexp), which was not designed for such -;; a rich language; writing a more suitable parser would be a big job): -;; 1) Regular expression delimitors do not act as quotes, so special -;; characters such as `'"#:;[](){} may need to be backslashed -;; in regular expressions and in both parts of s/// and tr///. -;; 2) The globbing syntax <pattern> is not recognized, so special -;; characters in the pattern string must be backslashed. -;; 3) The q, qq, and << quoting operators are not recognized; see below. -;; 4) \ (backslash) always quotes the next character, so '\' is -;; treated as the start of a string. Use "\\" as a work-around. -;; 5) To make variables such a $' and $#array work, perl-mode treats -;; $ just like backslash, so '$' is the same as problem 5. -;; 6) Unfortunately, treating $ like \ makes ${var} be treated as an -;; unmatched }. See below. -;; 7) When ' (quote) is used as a package name separator, perl-mode -;; doesn't understand, and thinks it is seeing a quoted string. - -;; Here are some ugly tricks to bypass some of these problems: the perl -;; expression /`/ (that's a back-tick) usually evaluates harmlessly, -;; but will trick perl-mode into starting a quoted string, which -;; can be ended with another /`/. Assuming you have no embedded -;; back-ticks, this can used to help solve problem 3: -;; -;; /`/; $ugly = q?"'$?; /`/; -;; -;; To solve problem 6, add a /{/; before each use of ${var}: -;; /{/; while (<${glob_me}>) ... -;; -;; Problem 7 is even worse, but this 'fix' does work :-( -;; $DB'stop#' -;; [$DB'line#' -;; ] =~ s/;9$//; - - -(defvar perl-mode-abbrev-table nil - "Abbrev table in use in perl-mode buffers.") -(define-abbrev-table 'perl-mode-abbrev-table ()) - -(defvar perl-mode-map () - "Keymap used in Perl mode.") -(if perl-mode-map - () - (setq perl-mode-map (make-sparse-keymap)) - (define-key perl-mode-map "{" 'electric-perl-terminator) - (define-key perl-mode-map "}" 'electric-perl-terminator) - (define-key perl-mode-map ";" 'electric-perl-terminator) - (define-key perl-mode-map ":" 'electric-perl-terminator) - (define-key perl-mode-map "\e\C-a" 'perl-beginning-of-function) - (define-key perl-mode-map "\e\C-e" 'perl-end-of-function) - (define-key perl-mode-map "\e\C-h" 'mark-perl-function) - (define-key perl-mode-map "\e\C-q" 'indent-perl-exp) - (define-key perl-mode-map "\177" 'backward-delete-char-untabify) - (define-key perl-mode-map "\t" 'perl-indent-command)) - -(autoload 'c-macro-expand "cmacexp" - "Display the result of expanding all C macros occurring in the region. -The expansion is entirely correct because it uses the C preprocessor." - t) - -(defvar perl-mode-syntax-table nil - "Syntax table in use in perl-mode buffers.") - -(if perl-mode-syntax-table - () - (setq perl-mode-syntax-table (make-syntax-table (standard-syntax-table))) - (modify-syntax-entry ?\n ">" perl-mode-syntax-table) - (modify-syntax-entry ?# "<" perl-mode-syntax-table) - (modify-syntax-entry ?$ "/" perl-mode-syntax-table) - (modify-syntax-entry ?% "." perl-mode-syntax-table) - (modify-syntax-entry ?& "." perl-mode-syntax-table) - (modify-syntax-entry ?\' "\"" perl-mode-syntax-table) - (modify-syntax-entry ?* "." perl-mode-syntax-table) - (modify-syntax-entry ?+ "." perl-mode-syntax-table) - (modify-syntax-entry ?- "." perl-mode-syntax-table) - (modify-syntax-entry ?/ "." perl-mode-syntax-table) - (modify-syntax-entry ?< "." perl-mode-syntax-table) - (modify-syntax-entry ?= "." perl-mode-syntax-table) - (modify-syntax-entry ?> "." perl-mode-syntax-table) - (modify-syntax-entry ?\\ "\\" perl-mode-syntax-table) - (modify-syntax-entry ?` "\"" perl-mode-syntax-table) - (modify-syntax-entry ?| "." perl-mode-syntax-table) -) - -(defconst perl-indent-level 4 - "*Indentation of Perl statements with respect to containing block.") -(defconst perl-continued-statement-offset 4 - "*Extra indent for lines not starting new statements.") -(defconst perl-continued-brace-offset -4 - "*Extra indent for substatements that start with open-braces. -This is in addition to perl-continued-statement-offset.") -(defconst perl-brace-offset 0 - "*Extra indentation for braces, compared with other text in same context.") -(defconst perl-brace-imaginary-offset 0 - "*Imagined indentation of an open brace that actually follows a statement.") -(defconst perl-label-offset -2 - "*Offset of Perl label lines relative to usual indentation.") - -(defconst perl-tab-always-indent t - "*Non-nil means TAB in Perl mode should always indent the current line, -regardless of where in the line point is when the TAB command is used.") - -(defconst perl-tab-to-comment t - "*Non-nil means that for lines which don't need indenting, TAB will -either indent an existing comment, move to end-of-line, or if at end-of-line -already, create a new comment.") - -(defconst perl-nochange ";?#\\|\f\\|\\s(\\|\\(\\w\\|\\s_\\)+:" - "*Lines starting with this regular expression will not be auto-indented.") - -(defun perl-mode () - "Major mode for editing Perl code. -Expression and list commands understand all Perl brackets. -Tab indents for Perl code. -Comments are delimited with # ... \\n. -Paragraphs are separated by blank lines only. -Delete converts tabs to spaces as it moves back. -\\{perl-mode-map} -Variables controlling indentation style: - perl-tab-always-indent - Non-nil means TAB in Perl mode should always indent the current line, - regardless of where in the line point is when the TAB command is used. - perl-tab-to-comment - Non-nil means that for lines which don't need indenting, TAB will - either delete an empty comment, indent an existing comment, move - to end-of-line, or if at end-of-line already, create a new comment. - perl-nochange - Lines starting with this regular expression will not be auto-indented. - perl-indent-level - Indentation of Perl statements within surrounding block. - The surrounding block's indentation is the indentation - of the line on which the open-brace appears. - perl-continued-statement-offset - Extra indentation given to a substatement, such as the - then-clause of an if or body of a while. - perl-continued-brace-offset - Extra indentation given to a brace that starts a substatement. - This is in addition to perl-continued-statement-offset. - perl-brace-offset - Extra indentation for line if it starts with an open brace. - perl-brace-imaginary-offset - An open brace following other text is treated as if it were - this far to the right of the start of its line. - perl-label-offset - Extra indentation for line that is a label. - -Various indentation styles: K&R BSD BLK GNU LW - perl-indent-level 5 8 0 2 4 - perl-continued-statement-offset 5 8 4 2 4 - perl-continued-brace-offset 0 0 0 0 -4 - perl-brace-offset -5 -8 0 0 0 - perl-brace-imaginary-offset 0 0 4 0 0 - perl-label-offset -5 -8 -2 -2 -2 - -Turning on Perl mode calls the value of the variable perl-mode-hook with no -args, if that value is non-nil." - (interactive) - (kill-all-local-variables) - (use-local-map perl-mode-map) - (setq major-mode 'perl-mode) - (setq mode-name "Perl") - (setq local-abbrev-table perl-mode-abbrev-table) - (set-syntax-table perl-mode-syntax-table) - (make-local-variable 'paragraph-start) - (setq paragraph-start (concat "^$\\|" page-delimiter)) - (make-local-variable 'paragraph-separate) - (setq paragraph-separate paragraph-start) - (make-local-variable 'paragraph-ignore-fill-prefix) - (setq paragraph-ignore-fill-prefix t) - (make-local-variable 'indent-line-function) - (setq indent-line-function 'perl-indent-line) - (make-local-variable 'require-final-newline) - (setq require-final-newline t) - (make-local-variable 'comment-start) - (setq comment-start "# ") - (make-local-variable 'comment-end) - (setq comment-end "") - (make-local-variable 'comment-column) - (setq comment-column 32) - (make-local-variable 'comment-start-skip) - (setq comment-start-skip "\\(^\\|\\s-\\);?#+ *") - (make-local-variable 'comment-indent-hook) - (setq comment-indent-hook 'perl-comment-indent) - (make-local-variable 'parse-sexp-ignore-comments) - (setq parse-sexp-ignore-comments nil) - (run-hooks 'perl-mode-hook)) - -;; This is used by indent-for-comment -;; to decide how much to indent a comment in Perl code -;; based on its context. -(defun perl-comment-indent () - (if (and (bolp) (not (eolp))) - 0 ;Existing comment at bol stays there. - (save-excursion - (skip-chars-backward " \t") - (max (1+ (current-column)) ;Else indent at comment column - comment-column)))) ; except leave at least one space. - -(defun electric-perl-terminator (arg) - "Insert character. If at end-of-line, and not in a comment or a quote, -correct the line's indentation." - (interactive "P") - (let ((insertpos (point))) - (and (not arg) ; decide whether to indent - (eolp) - (save-excursion - (beginning-of-line) - (and (not ; eliminate comments quickly - (re-search-forward comment-start-skip insertpos t)) - (or (/= last-command-char ?:) - ;; Colon is special only after a label .... - (looking-at "\\s-*\\(\\w\\|\\s_\\)+$")) - (let ((pps (parse-partial-sexp - (perl-beginning-of-function) insertpos))) - (not (or (nth 3 pps) (nth 4 pps) (nth 5 pps)))))) - (progn ; must insert, indent, delete - (insert-char last-command-char 1) - (perl-indent-line) - (delete-char -1)))) - (self-insert-command (prefix-numeric-value arg))) - -;; not used anymore, but may be useful someday: -;;(defun perl-inside-parens-p () -;; (condition-case () -;; (save-excursion -;; (save-restriction -;; (narrow-to-region (point) -;; (perl-beginning-of-function)) -;; (goto-char (point-max)) -;; (= (char-after (or (scan-lists (point) -1 1) (point-min))) ?\())) -;; (error nil))) - -(defun perl-indent-command (&optional arg) - "Indent current line as Perl code, or optionally, insert a tab character. - -With an argument, indent the current line, regardless of other options. - -If perl-tab-always-indent is nil and point is not in the indentation -area at the beginning of the line, simply insert a tab. - -Otherwise, indent the current line. If point was within the indentation -area it is moved to the end of the indentation area. If the line was -already indented properly and point was not within the indentation area, -and if perl-tab-to-comment is non-nil (the default), then do the first -possible action from the following list: - - 1) delete an empty comment - 2) move forward to start of comment, indenting if necessary - 3) move forward to end of line - 4) create an empty comment - 5) move backward to start of comment, indenting if necessary." - (interactive "P") - (if arg ; If arg, just indent this line - (perl-indent-line "\f") - (if (and (not perl-tab-always-indent) - (<= (current-column) (current-indentation))) - (insert-tab) - (let (bof lsexp delta (oldpnt (point))) - (beginning-of-line) - (setq lsexp (point)) - (setq bof (perl-beginning-of-function)) - (goto-char oldpnt) - (setq delta (perl-indent-line "\f\\|;?#" bof)) - (and perl-tab-to-comment - (= oldpnt (point)) ; done if point moved - (if (listp delta) ; if line starts in a quoted string - (setq lsexp (or (nth 2 delta) bof)) - (= delta 0)) ; done if indenting occurred - (let (eol state) - (end-of-line) - (setq eol (point)) - (if (= (char-after bof) ?=) - (if (= oldpnt eol) - (message "In a format statement")) - (setq state (parse-partial-sexp lsexp eol)) - (if (nth 3 state) - (if (= oldpnt eol) ; already at eol in a string - (message "In a string which starts with a %c." - (nth 3 state))) - (if (not (nth 4 state)) - (if (= oldpnt eol) ; no comment, create one? - (indent-for-comment)) - (beginning-of-line) - (if (re-search-forward comment-start-skip eol 'move) - (if (eolp) - (progn ; kill existing comment - (goto-char (match-beginning 0)) - (skip-chars-backward " \t") - (kill-region (point) eol)) - (if (or (< oldpnt (point)) (= oldpnt eol)) - (indent-for-comment) ; indent existing comment - (end-of-line))) - (if (/= oldpnt eol) - (end-of-line) - (message "Use backslash to quote # characters.") - (ding t)))))))))))) - -(defun perl-indent-line (&optional nochange parse-start) - "Indent current line as Perl code. Return the amount the indentation -changed by, or (parse-state) if line starts in a quoted string." - (let ((case-fold-search nil) - (pos (- (point-max) (point))) - (bof (or parse-start (save-excursion (perl-beginning-of-function)))) - beg indent shift-amt) - (beginning-of-line) - (setq beg (point)) - (setq shift-amt - (cond ((= (char-after bof) ?=) 0) - ((listp (setq indent (calculate-perl-indent bof))) indent) - ((looking-at (or nochange perl-nochange)) 0) - (t - (skip-chars-forward " \t\f") - (cond ((looking-at "\\(\\w\\|\\s_\\)+:") - (setq indent (max 1 (+ indent perl-label-offset)))) - ((= (following-char) ?}) - (setq indent (- indent perl-indent-level))) - ((= (following-char) ?{) - (setq indent (+ indent perl-brace-offset)))) - (- indent (current-column))))) - (skip-chars-forward " \t\f") - (if (and (numberp shift-amt) (/= 0 shift-amt)) - (progn (delete-region beg (point)) - (indent-to indent))) - ;; If initial point was within line's indentation, - ;; position after the indentation. Else stay at same point in text. - (if (> (- (point-max) pos) (point)) - (goto-char (- (point-max) pos))) - shift-amt)) - -(defun calculate-perl-indent (&optional parse-start) - "Return appropriate indentation for current line as Perl code. -In usual case returns an integer: the column to indent to. -Returns (parse-state) if line starts inside a string." - (save-excursion - (beginning-of-line) - (let ((indent-point (point)) - (case-fold-search nil) - (colon-line-end 0) - state containing-sexp) - (if parse-start ;used to avoid searching - (goto-char parse-start) - (perl-beginning-of-function)) - (while (< (point) indent-point) ;repeat until right sexp - (setq parse-start (point)) - (setq state (parse-partial-sexp (point) indent-point 0)) -; state = (depth_in_parens innermost_containing_list last_complete_sexp -; string_terminator_or_nil inside_commentp following_quotep -; minimum_paren-depth_this_scan) -; Parsing stops if depth in parentheses becomes equal to third arg. - (setq containing-sexp (nth 1 state))) - (cond ((nth 3 state) state) ; In a quoted string? - ((null containing-sexp) ; Line is at top level. - (skip-chars-forward " \t\f") - (if (= (following-char) ?{) - 0 ; move to beginning of line if it starts a function body - ;; indent a little if this is a continuation line - (perl-backward-to-noncomment) - (if (or (bobp) - (memq (preceding-char) '(?\; ?\}))) - 0 perl-continued-statement-offset))) - ((/= (char-after containing-sexp) ?{) - ;; line is expression, not statement: - ;; indent to just after the surrounding open. - (goto-char (1+ containing-sexp)) - (current-column)) - (t - ;; Statement level. Is it a continuation or a new statement? - ;; Find previous non-comment character. - (perl-backward-to-noncomment) - ;; Back up over label lines, since they don't - ;; affect whether our line is a continuation. - (while (or (eq (preceding-char) ?\,) - (and (eq (preceding-char) ?:) - (memq (char-syntax (char-after (- (point) 2))) - '(?w ?_)))) - (if (eq (preceding-char) ?\,) - (perl-backward-to-start-of-continued-exp containing-sexp)) - (beginning-of-line) - (perl-backward-to-noncomment)) - ;; Now we get the answer. - (if (not (memq (preceding-char) '(?\; ?\} ?\{))) - ;; This line is continuation of preceding line's statement; - ;; indent perl-continued-statement-offset more than the - ;; previous line of the statement. - (progn - (perl-backward-to-start-of-continued-exp containing-sexp) - (+ perl-continued-statement-offset (current-column) - (if (save-excursion (goto-char indent-point) - (looking-at "[ \t]*{")) - perl-continued-brace-offset 0))) - ;; This line starts a new statement. - ;; Position at last unclosed open. - (goto-char containing-sexp) - (or - ;; If open paren is in col 0, close brace is special - (and (bolp) - (save-excursion (goto-char indent-point) - (looking-at "[ \t]*}")) - perl-indent-level) - ;; Is line first statement after an open-brace? - ;; If no, find that first statement and indent like it. - (save-excursion - (forward-char 1) - ;; Skip over comments and labels following openbrace. - (while (progn - (skip-chars-forward " \t\f\n") - (cond ((looking-at ";?#") - (forward-line 1) t) - ((looking-at "\\(\\w\\|\\s_\\)+:") - (save-excursion - (end-of-line) - (setq colon-line-end (point))) - (search-forward ":"))))) - ;; The first following code counts - ;; if it is before the line we want to indent. - (and (< (point) indent-point) - (if (> colon-line-end (point)) - (- (current-indentation) perl-label-offset) - (current-column)))) - ;; If no previous statement, - ;; indent it relative to line brace is on. - ;; For open paren in column zero, don't let statement - ;; start there too. If perl-indent-level is zero, - ;; use perl-brace-offset + perl-continued-statement-offset - ;; For open-braces not the first thing in a line, - ;; add in perl-brace-imaginary-offset. - (+ (if (and (bolp) (zerop perl-indent-level)) - (+ perl-brace-offset perl-continued-statement-offset) - perl-indent-level) - ;; Move back over whitespace before the openbrace. - ;; If openbrace is not first nonwhite thing on the line, - ;; add the perl-brace-imaginary-offset. - (progn (skip-chars-backward " \t") - (if (bolp) 0 perl-brace-imaginary-offset)) - ;; If the openbrace is preceded by a parenthesized exp, - ;; move to the beginning of that; - ;; possibly a different line - (progn - (if (eq (preceding-char) ?\)) - (forward-sexp -1)) - ;; Get initial indentation of the line we are on. - (current-indentation)))))))))) - -(defun perl-backward-to-noncomment () - "Move point backward to after the first non-white-space, skipping comments." - (interactive) - (let (opoint stop) - (while (not stop) - (setq opoint (point)) - (beginning-of-line) - (if (re-search-forward comment-start-skip opoint 'move 1) - (progn (goto-char (match-end 1)) - (skip-chars-forward ";"))) - (skip-chars-backward " \t\f") - (setq stop (or (bobp) - (not (bolp)) - (forward-char -1)))))) - -(defun perl-backward-to-start-of-continued-exp (lim) - (if (= (preceding-char) ?\)) - (forward-sexp -1)) - (beginning-of-line) - (if (<= (point) lim) - (goto-char (1+ lim))) - (skip-chars-forward " \t\f")) - -;; note: this may be slower than the c-mode version, but I can understand it. -(defun indent-perl-exp () - "Indent each line of the Perl grouping following point." - (interactive) - (let* ((case-fold-search nil) - (oldpnt (point-marker)) - (bof-mark (save-excursion - (end-of-line 2) - (perl-beginning-of-function) - (point-marker))) - eol last-mark lsexp-mark delta) - (if (= (char-after (marker-position bof-mark)) ?=) - (message "Can't indent a format statement") - (message "Indenting Perl expression...") - (save-excursion (end-of-line) (setq eol (point))) - (save-excursion ; locate matching close paren - (while (and (not (eobp)) (<= (point) eol)) - (parse-partial-sexp (point) (point-max) 0)) - (setq last-mark (point-marker))) - (setq lsexp-mark bof-mark) - (beginning-of-line) - (while (< (point) (marker-position last-mark)) - (setq delta (perl-indent-line nil (marker-position bof-mark))) - (if (numberp delta) ; unquoted start-of-line? - (progn - (if (eolp) - (delete-horizontal-space)) - (setq lsexp-mark (point-marker)))) - (end-of-line) - (setq eol (point)) - (if (nth 4 (parse-partial-sexp (marker-position lsexp-mark) eol)) - (progn ; line ends in a comment - (beginning-of-line) - (if (or (not (looking-at "\\s-*;?#")) - (listp delta) - (and (/= 0 delta) - (= (- (current-indentation) delta) comment-column))) - (if (re-search-forward comment-start-skip eol t) - (indent-for-comment))))) ; indent existing comment - (forward-line 1)) - (goto-char (marker-position oldpnt)) - (message "Indenting Perl expression...done")))) - -(defun perl-beginning-of-function (&optional arg) - "Move backward to next beginning-of-function, or as far as possible. -With argument, repeat that many times; negative args move forward. -Returns new value of point in all cases." - (interactive "p") - (or arg (setq arg 1)) - (if (< arg 0) (forward-char 1)) - (and (/= arg 0) - (re-search-backward "^\\s(\\|^\\s-*sub\\b[^{]+{\\|^\\s-*format\\b[^=]*=\\|^\\." - nil 'move arg) - (goto-char (1- (match-end 0)))) - (point)) - -;; note: this routine is adapted directly from emacs lisp.el, end-of-defun; -;; no bugs have been removed :-) -(defun perl-end-of-function (&optional arg) - "Move forward to next end-of-function. -The end of a function is found by moving forward from the beginning of one. -With argument, repeat that many times; negative args move backward." - (interactive "p") - (or arg (setq arg 1)) - (let ((first t)) - (while (and (> arg 0) (< (point) (point-max))) - (let ((pos (point)) npos) - (while (progn - (if (and first - (progn - (forward-char 1) - (perl-beginning-of-function 1) - (not (bobp)))) - nil - (or (bobp) (forward-char -1)) - (perl-beginning-of-function -1)) - (setq first nil) - (forward-list 1) - (skip-chars-forward " \t") - (if (looking-at "[#\n]") - (forward-line 1)) - (<= (point) pos)))) - (setq arg (1- arg))) - (while (< arg 0) - (let ((pos (point))) - (perl-beginning-of-function 1) - (forward-sexp 1) - (forward-line 1) - (if (>= (point) pos) - (if (progn (perl-beginning-of-function 2) (not (bobp))) - (progn - (forward-list 1) - (skip-chars-forward " \t") - (if (looking-at "[#\n]") - (forward-line 1))) - (goto-char (point-min))))) - (setq arg (1+ arg))))) - -(defun mark-perl-function () - "Put mark at end of Perl function, point at beginning." - (interactive) - (push-mark (point)) - (perl-end-of-function) - (push-mark (point)) - (perl-beginning-of-function) - (backward-paragraph)) - -;;;;;;;; That's all, folks! ;;;;;;;;; diff --git a/emacs/perldb.el b/emacs/perldb.el deleted file mode 100644 index 66951be26d..0000000000 --- a/emacs/perldb.el +++ /dev/null @@ -1,423 +0,0 @@ -;; Run perl -d under Emacs -;; Based on gdb.el, as written by W. Schelter, and modified by rms. -;; Modified for Perl by Ray Lischner (uunet!mntgfx!lisch), Nov 1990. - -;; This file is part of GNU Emacs. -;; Copyright (C) 1988,1990 Free Software Foundation, Inc. - -;; GNU Emacs is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY. No author or distributor accepts responsibility -;; to anyone for the consequences of using it or for whether it serves -;; any particular purpose or works at all, unless he says so in writing. -;; Refer to the GNU Emacs General Public License for full details. - -;; Everyone is granted permission to copy, modify and redistribute GNU -;; Emacs, but only under the conditions described in the GNU Emacs -;; General Public License. A copy of this license is supposed to have -;; been given to you along with GNU Emacs so you can know your rights and -;; responsibilities. It should be in a file named COPYING. Among other -;; things, the copyright notice and this notice must be preserved on all -;; copies. - -;; Description of perl -d interface: - -;; A facility is provided for the simultaneous display of the source code -;; in one window, while using perldb to step through a function in the -;; other. A small arrow in the source window, indicates the current -;; line. - -;; Starting up: - -;; In order to use this facility, invoke the command PERLDB to obtain a -;; shell window with the appropriate command bindings. You will be asked -;; for the name of a file to run and additional command line arguments. -;; Perldb will be invoked on this file, in a window named *perldb-foo* -;; if the file is foo. - -;; M-s steps by one line, and redisplays the source file and line. - -;; You may easily create additional commands and bindings to interact -;; with the display. For example to put the perl debugger command n on \M-n -;; (def-perldb n "\M-n") - -;; This causes the emacs command perldb-next to be defined, and runs -;; perldb-display-frame after the command. - -;; perldb-display-frame is the basic display function. It tries to display -;; in the other window, the file and line corresponding to the current -;; position in the perldb window. For example after a perldb-step, it would -;; display the line corresponding to the position for the last step. Or -;; if you have done a backtrace in the perldb buffer, and move the cursor -;; into one of the frames, it would display the position corresponding to -;; that frame. - -;; perldb-display-frame is invoked automatically when a filename-and-line-number -;; appears in the output. - - -(require 'shell) - -(defvar perldb-prompt-pattern "^ DB<[0-9]+> " - "A regexp to recognize the prompt for perldb.") - -(defvar perldb-mode-map nil - "Keymap for perldb-mode.") - -(if perldb-mode-map - nil - (setq perldb-mode-map (copy-keymap shell-mode-map)) - (define-key perldb-mode-map "\C-l" 'perldb-refresh)) - -(define-key ctl-x-map " " 'perldb-break) -(define-key ctl-x-map "&" 'send-perldb-command) - -;;Of course you may use `def-perldb' with any other perldb command, including -;;user defined ones. - -(defmacro def-perldb (name key &optional doc) - (let* ((fun (intern (concat "perldb-" name)))) - (` (progn - (defun (, fun) (arg) - (, (or doc "")) - (interactive "p") - (perldb-call (if (not (= 1 arg)) - (concat (, name) arg) - (, name)))) - (define-key perldb-mode-map (, key) (quote (, fun))))))) - -(def-perldb "s" "\M-s" "Step one source line with display") -(def-perldb "n" "\M-n" "Step one source line (skip functions)") -(def-perldb "c" "\M-c" "Continue with display") -(def-perldb "r" "\C-c\C-r" "Return from current subroutine") -(def-perldb "A" "\C-c\C-a" "Delete all actions") - -(defun perldb-mode () - "Major mode for interacting with an inferior Perl debugger process. -The following commands are available: - -\\{perldb-mode-map} - -\\[perldb-display-frame] displays in the other window -the last line referred to in the perldb buffer. - -\\[perldb-s],\\[perldb-n], and \\[perldb-n] in the perldb window, -call perldb to step, next or continue and then update the other window -with the current file and position. - -If you are in a source file, you may select a point to break -at, by doing \\[perldb-break]. - -Commands: -Many commands are inherited from shell mode. -Additionally we have: - -\\[perldb-display-frame] display frames file in other window -\\[perldb-s] advance one line in program -\\[perldb-n] advance one line in program (skip over calls). -\\[send-perldb-command] used for special printing of an arg at the current point. -C-x SPACE sets break point at current line." - (interactive) - (kill-all-local-variables) - (setq major-mode 'perldb-mode) - (setq mode-name "Inferior Perl") - (setq mode-line-process '(": %s")) - (use-local-map perldb-mode-map) - (make-local-variable 'last-input-start) - (setq last-input-start (make-marker)) - (make-local-variable 'last-input-end) - (setq last-input-end (make-marker)) - (make-local-variable 'perldb-last-frame) - (setq perldb-last-frame nil) - (make-local-variable 'perldb-last-frame-displayed-p) - (setq perldb-last-frame-displayed-p t) - (make-local-variable 'perldb-delete-prompt-marker) - (setq perldb-delete-prompt-marker nil) - (make-local-variable 'perldb-filter-accumulator) - (setq perldb-filter-accumulator nil) - (make-local-variable 'shell-prompt-pattern) - (setq shell-prompt-pattern perldb-prompt-pattern) - (run-hooks 'shell-mode-hook 'perldb-mode-hook)) - -(defvar current-perldb-buffer nil) - -(defvar perldb-command-name "perl" - "Pathname for executing perl -d.") - -(defun end-of-quoted-arg (argstr start end) - (let* ((chr (substring argstr start (1+ start))) - (idx (string-match (concat "[^\\]" chr) argstr (1+ start)))) - (and idx (1+ idx)) - ) -) - -(defun parse-args-helper (arglist argstr start end) - (while (and (< start end) (string-match "[ \t\n\f\r\b]" - (substring argstr start (1+ start)))) - (setq start (1+ start))) - (cond - ((= start end) arglist) - ((string-match "[\"']" (substring argstr start (1+ start))) - (let ((next (end-of-quoted-arg argstr start end))) - (parse-args-helper (cons (substring argstr (1+ start) next) arglist) - argstr (1+ next) end))) - (t (let ((next (string-match "[ \t\n\f\b\r]" argstr start))) - (if next - (parse-args-helper (cons (substring argstr start next) arglist) - argstr (1+ next) end) - (cons (substring argstr start) arglist)))) - ) - ) - -(defun parse-args (args) - "Extract arguments from a string ARGS. -White space separates arguments, with single or double quotes -used to protect spaces. A list of strings is returned, e.g., -(parse-args \"foo bar 'two args'\") => (\"foo\" \"bar\" \"two args\")." - (nreverse (parse-args-helper '() args 0 (length args))) -) - -(defun perldb (path args) - "Run perldb on program FILE in buffer *perldb-FILE*. -The default directory for the current buffer becomes the initial -working directory, by analogy with gdb . If you wish to change this, use -the Perl command `chdir(DIR)'." - (interactive "FRun perl -d on file: \nsCommand line arguments: ") - (setq path (expand-file-name path)) - (let ((file (file-name-nondirectory path)) - (dir default-directory)) - (switch-to-buffer (concat "*perldb-" file "*")) - (setq default-directory dir) - (or (bolp) (newline)) - (insert "Current directory is " default-directory "\n") - (apply 'make-shell - (concat "perldb-" file) perldb-command-name nil "-d" path "-emacs" - (parse-args args)) - (perldb-mode) - (set-process-filter (get-buffer-process (current-buffer)) 'perldb-filter) - (set-process-sentinel (get-buffer-process (current-buffer)) 'perldb-sentinel) - (perldb-set-buffer))) - -(defun perldb-set-buffer () - (cond ((eq major-mode 'perldb-mode) - (setq current-perldb-buffer (current-buffer))))) - -;; This function is responsible for inserting output from Perl -;; into the buffer. -;; Aside from inserting the text, it notices and deletes -;; each filename-and-line-number; -;; that Perl prints to identify the selected frame. -;; It records the filename and line number, and maybe displays that file. -(defun perldb-filter (proc string) - (let ((inhibit-quit t)) - (if perldb-filter-accumulator - (perldb-filter-accumulate-marker proc - (concat perldb-filter-accumulator string)) - (perldb-filter-scan-input proc string)))) - -(defun perldb-filter-accumulate-marker (proc string) - (setq perldb-filter-accumulator nil) - (if (> (length string) 1) - (if (= (aref string 1) ?\032) - (let ((end (string-match "\n" string))) - (if end - (progn - (let* ((first-colon (string-match ":" string 2)) - (second-colon - (string-match ":" string (1+ first-colon)))) - (setq perldb-last-frame - (cons (substring string 2 first-colon) - (string-to-int - (substring string (1+ first-colon) - second-colon))))) - (setq perldb-last-frame-displayed-p nil) - (perldb-filter-scan-input proc - (substring string (1+ end)))) - (setq perldb-filter-accumulator string))) - (perldb-filter-insert proc "\032") - (perldb-filter-scan-input proc (substring string 1))) - (setq perldb-filter-accumulator string))) - -(defun perldb-filter-scan-input (proc string) - (if (equal string "") - (setq perldb-filter-accumulator nil) - (let ((start (string-match "\032" string))) - (if start - (progn (perldb-filter-insert proc (substring string 0 start)) - (perldb-filter-accumulate-marker proc - (substring string start))) - (perldb-filter-insert proc string))))) - -(defun perldb-filter-insert (proc string) - (let ((moving (= (point) (process-mark proc))) - (output-after-point (< (point) (process-mark proc))) - (old-buffer (current-buffer)) - start) - (set-buffer (process-buffer proc)) - (unwind-protect - (save-excursion - ;; Insert the text, moving the process-marker. - (goto-char (process-mark proc)) - (setq start (point)) - (insert string) - (set-marker (process-mark proc) (point)) - (perldb-maybe-delete-prompt) - ;; Check for a filename-and-line number. - (perldb-display-frame - ;; Don't display the specified file - ;; unless (1) point is at or after the position where output appears - ;; and (2) this buffer is on the screen. - (or output-after-point - (not (get-buffer-window (current-buffer)))) - ;; Display a file only when a new filename-and-line-number appears. - t)) - (set-buffer old-buffer)) - (if moving (goto-char (process-mark proc))))) - -(defun perldb-sentinel (proc msg) - (cond ((null (buffer-name (process-buffer proc))) - ;; buffer killed - ;; Stop displaying an arrow in a source file. - (setq overlay-arrow-position nil) - (set-process-buffer proc nil)) - ((memq (process-status proc) '(signal exit)) - ;; Stop displaying an arrow in a source file. - (setq overlay-arrow-position nil) - ;; Fix the mode line. - (setq mode-line-process - (concat ": " - (symbol-name (process-status proc)))) - (let* ((obuf (current-buffer))) - ;; save-excursion isn't the right thing if - ;; process-buffer is current-buffer - (unwind-protect - (progn - ;; Write something in *compilation* and hack its mode line, - (set-buffer (process-buffer proc)) - ;; Force mode line redisplay soon - (set-buffer-modified-p (buffer-modified-p)) - (if (eobp) - (insert ?\n mode-name " " msg) - (save-excursion - (goto-char (point-max)) - (insert ?\n mode-name " " msg))) - ;; If buffer and mode line will show that the process - ;; is dead, we can delete it now. Otherwise it - ;; will stay around until M-x list-processes. - (delete-process proc)) - ;; Restore old buffer, but don't restore old point - ;; if obuf is the perldb buffer. - (set-buffer obuf)))))) - - -(defun perldb-refresh () - "Fix up a possibly garbled display, and redraw the arrow." - (interactive) - (redraw-display) - (perldb-display-frame)) - -(defun perldb-display-frame (&optional nodisplay noauto) - "Find, obey and delete the last filename-and-line marker from PERLDB. -The marker looks like \\032\\032FILENAME:LINE:CHARPOS\\n. -Obeying it means displaying in another window the specified file and line." - (interactive) - (perldb-set-buffer) - (and perldb-last-frame (not nodisplay) - (or (not perldb-last-frame-displayed-p) (not noauto)) - (progn (perldb-display-line (car perldb-last-frame) (cdr perldb-last-frame)) - (setq perldb-last-frame-displayed-p t)))) - -;; Make sure the file named TRUE-FILE is in a buffer that appears on the screen -;; and that its line LINE is visible. -;; Put the overlay-arrow on the line LINE in that buffer. - -(defun perldb-display-line (true-file line) - (let* ((buffer (find-file-noselect true-file)) - (window (display-buffer buffer t)) - (pos)) - (save-excursion - (set-buffer buffer) - (save-restriction - (widen) - (goto-line line) - (setq pos (point)) - (setq overlay-arrow-string "=>") - (or overlay-arrow-position - (setq overlay-arrow-position (make-marker))) - (set-marker overlay-arrow-position (point) (current-buffer))) - (cond ((or (< pos (point-min)) (> pos (point-max))) - (widen) - (goto-char pos)))) - (set-window-point window overlay-arrow-position))) - -(defun perldb-call (command) - "Invoke perldb COMMAND displaying source in other window." - (interactive) - (goto-char (point-max)) - (setq perldb-delete-prompt-marker (point-marker)) - (perldb-set-buffer) - (send-string (get-buffer-process current-perldb-buffer) - (concat command "\n"))) - -(defun perldb-maybe-delete-prompt () - (if (and perldb-delete-prompt-marker - (> (point-max) (marker-position perldb-delete-prompt-marker))) - (let (start) - (goto-char perldb-delete-prompt-marker) - (setq start (point)) - (beginning-of-line) - (delete-region (point) start) - (setq perldb-delete-prompt-marker nil)))) - -(defun perldb-break () - "Set PERLDB breakpoint at this source line." - (interactive) - (let ((line (save-restriction - (widen) - (1+ (count-lines 1 (point)))))) - (send-string (get-buffer-process current-perldb-buffer) - (concat "b " line "\n")))) - -(defun perldb-read-token() - "Return a string containing the token found in the buffer at point. -A token can be a number or an identifier. If the token is a name prefaced -by `$', `@', or `%', the leading character is included in the token." - (save-excursion - (let (begin) - (or (looking-at "[$@%]") - (re-search-backward "[^a-zA-Z_0-9]" (point-min) 'move)) - (setq begin (point)) - (or (looking-at "[$@%]") (setq begin (+ begin 1))) - (forward-char 1) - (buffer-substring begin - (if (re-search-forward "[^a-zA-Z_0-9]" - (point-max) 'move) - (- (point) 1) - (point))) -))) - -(defvar perldb-commands nil - "List of strings or functions used by send-perldb-command. -It is for customization by the user.") - -(defun send-perldb-command (arg) - "Issue a Perl debugger command selected by the prefix arg. A numeric -arg selects the ARG'th member COMMAND of the list perldb-commands. -The token under the cursor is passed to the command. If COMMAND is a -string, (format COMMAND TOKEN) is inserted at the end of the perldb -buffer, otherwise (funcall COMMAND TOKEN) is inserted. If there is -no such COMMAND, then the token itself is inserted. For example, -\"p %s\" is a possible string to be a member of perldb-commands, -or \"p $ENV{%s}\"." - (interactive "P") - (let (comm token) - (if arg (setq comm (nth arg perldb-commands))) - (setq token (perldb-read-token)) - (if (eq (current-buffer) current-perldb-buffer) - (set-mark (point))) - (cond (comm - (setq comm - (if (stringp comm) (format comm token) (funcall comm token)))) - (t (setq comm token))) - (switch-to-buffer-other-window current-perldb-buffer) - (goto-char (dot-max)) - (insert-string comm))) diff --git a/emacs/perldb.pl b/emacs/perldb.pl deleted file mode 100644 index 958e58d874..0000000000 --- a/emacs/perldb.pl +++ /dev/null @@ -1,531 +0,0 @@ -package DB; - -# modified Perl debugger, to be run from Emacs in perldb-mode -# Ray Lischner (uunet!mntgfx!lisch) as of 5 Nov 1990 - -$header = '$RCSfile: perldb.pl,v $$Revision: 4.1 $$Date: 92/08/07 17:20:59 $'; -# -# This file is automatically included if you do perl -d. -# It's probably not useful to include this yourself. -# -# Perl supplies the values for @line and %sub. It effectively inserts -# a do DB'DB(<linenum>); in front of every place that can -# have a breakpoint. It also inserts a do 'perldb.pl' before the first line. -# -# $Log: perldb.pl,v $ - -open(IN, "</dev/tty") || open(IN, "<&STDIN"); # so we don't dingle stdin -open(OUT,">/dev/tty") || open(OUT, ">&STDOUT"); # so we don't dongle stdout -select(OUT); -$| = 1; # for DB'OUT -select(STDOUT); -$| = 1; # for real STDOUT -$sub = ''; - -# Is Perl being run from Emacs? -$emacs = $main'ARGV[$[] eq '-emacs'; -shift(@main'ARGV) if $emacs; - -$header =~ s/.Header: ([^,]+),v(\s+\S+\s+\S+).*$/$1$2/; -print OUT "\nLoading DB routines from $header\n\nEnter h for help.\n\n"; - -sub DB { - &save; - ($package, $filename, $line) = caller; - $usercontext = '($@, $!, $[, $,, $/, $\) = @saved;' . - "package $package;"; # this won't let them modify, alas - local(*dbline) = "_<$filename"; - $max = $#dbline; - if (($stop,$action) = split(/\0/,$dbline{$line})) { - if ($stop eq '1') { - $signal |= 1; - } - else { - $evalarg = "\$DB'signal |= do {$stop;}"; &eval; - $dbline{$line} =~ s/;9($|\0)/$1/; - } - } - if ($single || $trace || $signal) { - if ($emacs) { - print OUT "\032\032$filename:$line:0\n"; - } else { - print OUT "$package'" unless $sub =~ /'/; - print OUT "$sub($filename:$line):\t",$dbline[$line]; - for ($i = $line + 1; $i <= $max && $dbline[$i] == 0; ++$i) { - last if $dbline[$i] =~ /^\s*(}|#|\n)/; - print OUT "$sub($filename:$i):\t",$dbline[$i]; - } - } - } - $evalarg = $action, &eval if $action; - if ($single || $signal) { - $evalarg = $pre, &eval if $pre; - print OUT $#stack . " levels deep in subroutine calls!\n" - if $single & 4; - $start = $line; - while ((print OUT " DB<", $#hist+1, "> "), $cmd=&gets) { - $single = 0; - $signal = 0; - $cmd eq '' && exit 0; - chop($cmd); - $cmd =~ s/\\$// && do { - print OUT " cont: "; - $cmd .= &gets; - redo; - }; - $cmd =~ /^q$/ && exit 0; - $cmd =~ /^$/ && ($cmd = $laststep); - push(@hist,$cmd) if length($cmd) > 1; - ($i) = split(/\s+/,$cmd); - eval "\$cmd =~ $alias{$i}", print OUT $@ if $alias{$i}; - $cmd =~ /^h$/ && do { - print OUT " -T Stack trace. -s Single step. -n Next, steps over subroutine calls. -r Return from current subroutine. -c [line] Continue; optionally inserts a one-time-only breakpoint - at the specified line. -<CR> Repeat last n or s. -l min+incr List incr+1 lines starting at min. -l min-max List lines. -l line List line; -l List next window. -- List previous window. -w line List window around line. -l subname List subroutine. -f filename Switch to filename. -/pattern/ Search forwards for pattern; final / is optional. -?pattern? Search backwards for pattern. -L List breakpoints and actions. -S List subroutine names. -t Toggle trace mode. -b [line] [condition] - Set breakpoint; line defaults to the current execution line; - condition breaks if it evaluates to true, defaults to \'1\'. -b subname [condition] - Set breakpoint at first line of subroutine. -d [line] Delete breakpoint. -D Delete all breakpoints. -a [line] command - Set an action to be done before the line is executed. - Sequence is: check for breakpoint, print line if necessary, - do action, prompt user if breakpoint or step, evaluate line. -A Delete all actions. -V [pkg [vars]] List some (default all) variables in package (default current). -X [vars] Same as \"V currentpackage [vars]\". -< command Define command before prompt. -| command Define command after prompt. -! number Redo command (default previous command). -! -number Redo number\'th to last command. -H -number Display last number commands (default all). -q or ^D Quit. -p expr Same as \"print DB'OUT expr\" in current package. -= [alias value] Define a command alias, or list current aliases. -command Execute as a perl statement in current package. - -"; - next; }; - $cmd =~ /^t$/ && do { - $trace = !$trace; - print OUT "Trace = ".($trace?"on":"off")."\n"; - next; }; - $cmd =~ /^S$/ && do { - foreach $subname (sort(keys %sub)) { - print OUT $subname,"\n"; - } - next; }; - $cmd =~ s/^X\b/V $package/; - $cmd =~ /^V$/ && do { - $cmd = 'V $package'; }; - $cmd =~ /^V\s*(\S+)\s*(.*)/ && do { - $packname = $1; - @vars = split(' ',$2); - do 'dumpvar.pl' unless defined &main'dumpvar; - if (defined &main'dumpvar) { - &main'dumpvar($packname,@vars); - } - else { - print DB'OUT "dumpvar.pl not available.\n"; - } - next; }; - $cmd =~ /^f\s*(.*)/ && do { - $file = $1; - if (!$file) { - print OUT "The old f command is now the r command.\n"; - print OUT "The new f command switches filenames.\n"; - next; - } - if (!defined $_main{'_<' . $file}) { - if (($try) = grep(m#^_<.*$file#, keys %_main)) { - $file = substr($try,2); - print "\n$file:\n"; - } - } - if (!defined $_main{'_<' . $file}) { - print OUT "There's no code here anything matching $file.\n"; - next; - } - elsif ($file ne $filename) { - *dbline = "_<$file"; - $max = $#dbline; - $filename = $file; - $start = 1; - $cmd = "l"; - } }; - $cmd =~ /^l\s*(['A-Za-z_]['\w]*)/ && do { - $subname = $1; - $subname = "main'" . $subname unless $subname =~ /'/; - $subname = "main" . $subname if substr($subname,0,1) eq "'"; - ($file,$subrange) = split(/:/,$sub{$subname}); - if ($file ne $filename) { - *dbline = "_<$file"; - $max = $#dbline; - $filename = $file; - } - if ($subrange) { - if (eval($subrange) < -$window) { - $subrange =~ s/-.*/+/; - } - $cmd = "l $subrange"; - } else { - print OUT "Subroutine $1 not found.\n"; - next; - } }; - $cmd =~ /^w\s*(\d*)$/ && do { - $incr = $window - 1; - $start = $1 if $1; - $start -= $preview; - $cmd = 'l ' . $start . '-' . ($start + $incr); }; - $cmd =~ /^-$/ && do { - $incr = $window - 1; - $cmd = 'l ' . ($start-$window*2) . '+'; }; - $cmd =~ /^l$/ && do { - $incr = $window - 1; - $cmd = 'l ' . $start . '-' . ($start + $incr); }; - $cmd =~ /^l\s*(\d*)\+(\d*)$/ && do { - $start = $1 if $1; - $incr = $2; - $incr = $window - 1 unless $incr; - $cmd = 'l ' . $start . '-' . ($start + $incr); }; - $cmd =~ /^l\s*(([\d\$\.]+)([-,]([\d\$\.]+))?)?/ && do { - $end = (!$2) ? $max : ($4 ? $4 : $2); - $end = $max if $end > $max; - $i = $2; - $i = $line if $i eq '.'; - $i = 1 if $i < 1; - if ($emacs) { - print OUT "\032\032$filename:$i:0\n"; - $i = $end; - } else { - for (; $i <= $end; $i++) { - print OUT "$i:\t", $dbline[$i]; - last if $signal; - } - } - $start = $i; # remember in case they want more - $start = $max if $start > $max; - next; }; - $cmd =~ /^D$/ && do { - print OUT "Deleting all breakpoints...\n"; - for ($i = 1; $i <= $max ; $i++) { - if (defined $dbline{$i}) { - $dbline{$i} =~ s/^[^\0]+//; - if ($dbline{$i} =~ s/^\0?$//) { - delete $dbline{$i}; - } - } - } - next; }; - $cmd =~ /^L$/ && do { - for ($i = 1; $i <= $max; $i++) { - if (defined $dbline{$i}) { - print OUT "$i:\t", $dbline[$i]; - ($stop,$action) = split(/\0/, $dbline{$i}); - print OUT " break if (", $stop, ")\n" - if $stop; - print OUT " action: ", $action, "\n" - if $action; - last if $signal; - } - } - next; }; - $cmd =~ /^b\s*(['A-Za-z_]['\w]*)\s*(.*)/ && do { - $subname = $1; - $cond = $2 || '1'; - $subname = "$package'" . $subname unless $subname =~ /'/; - $subname = "main" . $subname if substr($subname,0,1) eq "'"; - ($filename,$i) = split(/[:-]/, $sub{$subname}); - if ($i) { - *dbline = "_<$filename"; - ++$i while $dbline[$i] == 0 && $i < $#dbline; - $dbline{$i} =~ s/^[^\0]*/$cond/; - } else { - print OUT "Subroutine $subname not found.\n"; - } - next; }; - $cmd =~ /^b\s*(\d*)\s*(.*)/ && do { - $i = ($1?$1:$line); - $cond = $2 || '1'; - if ($dbline[$i] == 0) { - print OUT "Line $i not breakable.\n"; - } else { - $dbline{$i} =~ s/^[^\0]*/$cond/; - } - next; }; - $cmd =~ /^d\s*(\d+)?/ && do { - $i = ($1?$1:$line); - $dbline{$i} =~ s/^[^\0]*//; - delete $dbline{$i} if $dbline{$i} eq ''; - next; }; - $cmd =~ /^A$/ && do { - for ($i = 1; $i <= $max ; $i++) { - if (defined $dbline{$i}) { - $dbline{$i} =~ s/\0[^\0]*//; - delete $dbline{$i} if $dbline{$i} eq ''; - } - } - next; }; - $cmd =~ /^<\s*(.*)/ && do { - $pre = do action($1); - next; }; - $cmd =~ /^>\s*(.*)/ && do { - $post = do action($1); - next; }; - $cmd =~ /^a\s*(\d+)(\s+(.*))?/ && do { - $i = $1; - if ($dbline[$i] == 0) { - print OUT "Line $i may not have an action.\n"; - } else { - $dbline{$i} =~ s/\0[^\0]*//; - $dbline{$i} .= "\0" . do action($3); - } - next; }; - $cmd =~ /^n$/ && do { - $single = 2; - $laststep = $cmd; - last; }; - $cmd =~ /^s$/ && do { - $single = 1; - $laststep = $cmd; - last; }; - $cmd =~ /^c\s*(\d*)\s*$/ && do { - $i = $1; - if ($i) { - if ($dbline[$i] == 0) { - print OUT "Line $i not breakable.\n"; - next; - } - $dbline{$i} =~ s/(\0|$)/;9$1/; # add one-time-only b.p. - } - for ($i=0; $i <= $#stack; ) { - $stack[$i++] &= ~1; - } - last; }; - $cmd =~ /^r$/ && do { - $stack[$#stack] |= 2; - last; }; - $cmd =~ /^T$/ && do { - local($p,$f,$l,$s,$h,$a,@a,@sub); - for ($i = 1; ($p,$f,$l,$s,$h,$w) = caller($i); $i++) { - @a = @args; - for (@a) { - if (/^StB\000/ && length($_) == length($_main{'_main'})) { - $_ = sprintf("%s",$_); - } - else { - s/'/\\'/g; - s/([^\0]*)/'$1'/ unless /^-?[\d.]+$/; - s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg; - s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg; - } - } - $w = $w ? '@ = ' : '$ = '; - $a = $h ? '(' . join(', ', @a) . ')' : ''; - push(@sub, "$w&$s$a from file $f line $l\n"); - last if $signal; - } - for ($i=0; $i <= $#sub; $i++) { - last if $signal; - print OUT $sub[$i]; - } - next; }; - $cmd =~ /^\/(.*)$/ && do { - $inpat = $1; - $inpat =~ s:([^\\])/$:$1:; - if ($inpat ne "") { - eval '$inpat =~ m'."\n$inpat\n"; - if ($@ ne "") { - print OUT "$@"; - next; - } - $pat = $inpat; - } - $end = $start; - eval ' - for (;;) { - ++$start; - $start = 1 if ($start > $max); - last if ($start == $end); - if ($dbline[$start] =~ m'."\n$pat\n".'i) { - if ($emacs) { - print OUT "\032\032$filename:$start:0\n"; - } else { - print OUT "$start:\t", $dbline[$start], "\n"; - } - last; - } - } '; - print OUT "/$pat/: not found\n" if ($start == $end); - next; }; - $cmd =~ /^\?(.*)$/ && do { - $inpat = $1; - $inpat =~ s:([^\\])\?$:$1:; - if ($inpat ne "") { - eval '$inpat =~ m'."\n$inpat\n"; - if ($@ ne "") { - print OUT "$@"; - next; - } - $pat = $inpat; - } - $end = $start; - eval ' - for (;;) { - --$start; - $start = $max if ($start <= 0); - last if ($start == $end); - if ($dbline[$start] =~ m'."\n$pat\n".'i) { - if ($emacs) { - print OUT "\032\032$filename:$start:0\n"; - } else { - print OUT "$start:\t", $dbline[$start], "\n"; - } - last; - } - } '; - print OUT "?$pat?: not found\n" if ($start == $end); - next; }; - $cmd =~ /^!+\s*(-)?(\d+)?$/ && do { - pop(@hist) if length($cmd) > 1; - $i = ($1?($#hist-($2?$2:1)):($2?$2:$#hist)); - $cmd = $hist[$i] . "\n"; - print OUT $cmd; - redo; }; - $cmd =~ /^!(.+)$/ && do { - $pat = "^$1"; - pop(@hist) if length($cmd) > 1; - for ($i = $#hist; $i; --$i) { - last if $hist[$i] =~ $pat; - } - if (!$i) { - print OUT "No such command!\n\n"; - next; - } - $cmd = $hist[$i] . "\n"; - print OUT $cmd; - redo; }; - $cmd =~ /^H\s*(-(\d+))?/ && do { - $end = $2?($#hist-$2):0; - $hist = 0 if $hist < 0; - for ($i=$#hist; $i>$end; $i--) { - print OUT "$i: ",$hist[$i],"\n" - unless $hist[$i] =~ /^.?$/; - }; - next; }; - $cmd =~ s/^p( .*)?$/print DB'OUT$1/; - $cmd =~ /^=/ && do { - if (local($k,$v) = ($cmd =~ /^=\s*(\S+)\s+(.*)/)) { - $alias{$k}="s~$k~$v~"; - print OUT "$k = $v\n"; - } elsif ($cmd =~ /^=\s*$/) { - foreach $k (sort keys(%alias)) { - if (($v = $alias{$k}) =~ s~^s\~$k\~(.*)\~$~$1~) { - print OUT "$k = $v\n"; - } else { - print OUT "$k\t$alias{$k}\n"; - }; - }; - }; - next; }; - $evalarg = $cmd; &eval; - print OUT "\n"; - } - if ($post) { - $evalarg = $post; &eval; - } - } - ($@, $!, $[, $,, $/, $\) = @saved; -} - -sub save { - @saved = ($@, $!, $[, $,, $/, $\); - $[ = 0; $, = ""; $/ = "\n"; $\ = ""; -} - -# The following takes its argument via $evalarg to preserve current @_ - -sub eval { - eval "$usercontext $evalarg; &DB'save"; - print OUT $@; -} - -sub action { - local($action) = @_; - while ($action =~ s/\\$//) { - print OUT "+ "; - $action .= &gets; - } - $action; -} - -sub gets { - local($.); - <IN>; -} - -sub catch { - $signal = 1; -} - -sub sub { - push(@stack, $single); - $single &= 1; - $single |= 4 if $#stack == $deep; - if (wantarray) { - @i = &$sub; - $single |= pop(@stack); - @i; - } - else { - $i = &$sub; - $single |= pop(@stack); - $i; - } -} - -$single = 1; # so it stops on first executable statement -@hist = ('?'); -$SIG{'INT'} = "DB'catch"; -$deep = 100; # warning if stack gets this deep -$window = 10; -$preview = 3; - -@stack = (0); -@ARGS = @ARGV; -for (@args) { - s/'/\\'/g; - s/(.*)/'$1'/ unless /^-?[\d.]+$/; -} - -if (-f '.perldb') { - do './.perldb'; -} -elsif (-f "$ENV{'LOGDIR'}/.perldb") { - do "$ENV{'LOGDIR'}/.perldb"; -} -elsif (-f "$ENV{'HOME'}/.perldb") { - do "$ENV{'HOME'}/.perldb"; -} - -1; diff --git a/emacs/tedstuff b/emacs/tedstuff deleted file mode 100644 index 257bbc8553..0000000000 --- a/emacs/tedstuff +++ /dev/null @@ -1,296 +0,0 @@ -Article 4417 of comp.lang.perl: -Path: jpl-devvax!elroy.jpl.nasa.gov!decwrl!mcnc!uvaarpa!mmdf -From: ted@evi.com (Ted Stefanik) -Newsgroups: comp.lang.perl -Subject: Correction to Perl fatal error marking in GNU Emacs -Message-ID: <1991Feb27.065853.15801@uvaarpa.Virginia.EDU> -Date: 27 Feb 91 06:58:53 GMT -Sender: mmdf@uvaarpa.Virginia.EDU (Uvaarpa Mail System) -Reply-To: ted@evi.com (Ted Stefanik) -Organization: The Internet -Lines: 282 - -Reading my own message, it occurred to me that I didn't quite satisfy the -request of stef@zweig.sun (Stephane Payrard): - -| Does anyone has extended perdb/perdb.el to position the -| point to the first syntax error? It would be cool. - -What I posted is a way to use the "M-x compile" command to test perl scripts. -(Needless to say, the script cannot be not interactive; you can't provide input -to a *compilation* buffer). When creating new Perl programs, I use "M-x -compile" until I'm sure that they are syntatically correct; if syntax errors -occur, C-x` takes me to each in sequence. After I'm sure the syntax is -correct, I start worrying about semantics, and switch to "M-x perldb" if -necessary. - -Therefore, the stuff I posted works great with "M-x compile", but not at all -with "M-x perldb". - -Next, let me update what I posted. I found that perl's die() command doesn't -print the same format error message as perl does when it dies with a syntax -error. If you put the following in your ".emacs" file, it causes C-x` to -recognize both kinds of errors: - -(load-library "compile") -(setq compilation-error-regexp - "\\([^ :\n]+\\(: *\\|, line \\|(\\)[0-9]+\\)\\|\\([0-9]+ *of *[^ \n]+\\|[^ \n]+ \\(at \\)*line [0-9]+\\)") - -Last, so I don't look like a total fool, let me propose a way to satisfy -Stephane Payrard's original request (repeated again): - -| Does anyone has extended perdb/perdb.el to position the -| point to the first syntax error? It would be cool. - -I'm not satisfied with just the "first syntax error". Perl's parser is better -than most about not getting out of sync; therefore, if it reports multiple -errors, you can usually be assured they are all real errors. - -So... I hacked in the "next-error" function from "compile.el" to form -"perldb-next-error". You can apply the patches at the end of this message -to add "perldb-next-error" to your "perldb.el". - -Notes: - 1) The patch binds "perldb-next-error" to C-x~ (because ~ is the shift - of ` on my keyboard, and C-x~ is not yet taken in my version of EMACS). - - 2) "next-error" is meant to work on a single *compilation* buffer; any new - "M-x compile" or "M-x grep" command will clear the old *compilation* - buffer and reset the compilation-error parser to start at the top of the - *compilation* buffer. - - "perldb-next-error", on the other hand, has to deal with multiple - *perldb-<foo>* buffers, each of which keep growing. "perldb-next-error" - correctly handles the constantly growing *perldb-<foo>* buffers by - keeping track of the last reported error in the "current-perldb-buffer". - - Sadly however, when you invoke a new "M-x perldb" on a different Perl - script, "perldb-next-error" will start parsing the new *perldb-<bar>* - buffer at the top (even if it was previously parsed), and will completely - lose the marker of the last reported error in *perldb-<foo>*. - - 3) "perldb-next-error" still uses "compilation-error-regexp" to find - fatal errors. Therefore, both the "M-x compile"/C-x` scheme and - the "M-x perldb"/C-x~ scheme can be used to find fatal errors that - match the common "compilation-error-regexp". You *will* want to install - that "compilation-error-regexp" stuff into your .emacs file. - - 4) The patch was developed and tested with GNU Emacs 18.55. - - 5) Since the patch was ripped off from compile.el, the code is (of - course) subject to the GNU copyleft. - -*** perldb.el.orig Wed Feb 27 00:44:27 1991 ---- perldb.el Wed Feb 27 00:44:30 1991 -*************** -*** 199,205 **** - - (defun perldb-set-buffer () - (cond ((eq major-mode 'perldb-mode) -! (setq current-perldb-buffer (current-buffer))))) - - ;; This function is responsible for inserting output from Perl - ;; into the buffer. ---- 199,211 ---- - - (defun perldb-set-buffer () - (cond ((eq major-mode 'perldb-mode) -! (cond ((not (eq current-perldb-buffer (current-buffer))) -! (perldb-forget-errors) -! (setq perldb-parsing-end 2)) ;; 2 to defeat grep defeater -! (t -! (if (> perldb-parsing-end (point-max)) -! (setq perldb-parsing-end (max (point-max) 2))))) -! (setq current-perldb-buffer (current-buffer))))) - - ;; This function is responsible for inserting output from Perl - ;; into the buffer. -*************** -*** 291,297 **** - ;; process-buffer is current-buffer - (unwind-protect - (progn -! ;; Write something in *compilation* and hack its mode line, - (set-buffer (process-buffer proc)) - ;; Force mode line redisplay soon - (set-buffer-modified-p (buffer-modified-p)) ---- 297,303 ---- - ;; process-buffer is current-buffer - (unwind-protect - (progn -! ;; Write something in *perldb-<foo>* and hack its mode line, - (set-buffer (process-buffer proc)) - ;; Force mode line redisplay soon - (set-buffer-modified-p (buffer-modified-p)) -*************** -*** 421,423 **** ---- 427,593 ---- - (switch-to-buffer-other-window current-perldb-buffer) - (goto-char (dot-max)) - (insert-string comm))) -+ -+ (defvar perldb-error-list nil -+ "List of error message descriptors for visiting erring functions. -+ Each error descriptor is a list of length two. -+ Its car is a marker pointing to an error message. -+ Its cadr is a marker pointing to the text of the line the message is about, -+ or nil if that is not interesting. -+ The value may be t instead of a list; -+ this means that the buffer of error messages should be reparsed -+ the next time the list of errors is wanted.") -+ -+ (defvar perldb-parsing-end nil -+ "Position of end of buffer when last error messages parsed.") -+ -+ (defvar perldb-error-message "No more fatal Perl errors" -+ "Message to print when no more matches for compilation-error-regexp are found") -+ -+ (defun perldb-next-error (&optional argp) -+ "Visit next perldb error message and corresponding source code. -+ This operates on the output from the \\[perldb] command. -+ If all preparsed error messages have been processed, -+ the error message buffer is checked for new ones. -+ A non-nil argument (prefix arg, if interactive) -+ means reparse the error message buffer and start at the first error." -+ (interactive "P") -+ (if (or (eq perldb-error-list t) -+ argp) -+ (progn (perldb-forget-errors) -+ (setq perldb-parsing-end 2))) ;; 2 to defeat grep defeater -+ (if perldb-error-list -+ nil -+ (save-excursion -+ (switch-to-buffer current-perldb-buffer) -+ (perldb-parse-errors))) -+ (let ((next-error (car perldb-error-list))) -+ (if (null next-error) -+ (error (concat perldb-error-message -+ (if (and (get-buffer-process current-perldb-buffer) -+ (eq (process-status -+ (get-buffer-process -+ current-perldb-buffer)) -+ 'run)) -+ " yet" "")))) -+ (setq perldb-error-list (cdr perldb-error-list)) -+ (if (null (car (cdr next-error))) -+ nil -+ (switch-to-buffer (marker-buffer (car (cdr next-error)))) -+ (goto-char (car (cdr next-error))) -+ (set-marker (car (cdr next-error)) nil)) -+ (let* ((pop-up-windows t) -+ (w (display-buffer (marker-buffer (car next-error))))) -+ (set-window-point w (car next-error)) -+ (set-window-start w (car next-error))) -+ (set-marker (car next-error) nil))) -+ -+ ;; Set perldb-error-list to nil, and -+ ;; unchain the markers that point to the error messages and their text, -+ ;; so that they no longer slow down gap motion. -+ ;; This would happen anyway at the next garbage collection, -+ ;; but it is better to do it right away. -+ (defun perldb-forget-errors () -+ (if (eq perldb-error-list t) -+ (setq perldb-error-list nil)) -+ (while perldb-error-list -+ (let ((next-error (car perldb-error-list))) -+ (set-marker (car next-error) nil) -+ (if (car (cdr next-error)) -+ (set-marker (car (cdr next-error)) nil))) -+ (setq perldb-error-list (cdr perldb-error-list)))) -+ -+ (defun perldb-parse-errors () -+ "Parse the current buffer as error messages. -+ This makes a list of error descriptors, perldb-error-list. -+ For each source-file, line-number pair in the buffer, -+ the source file is read in, and the text location is saved in perldb-error-list. -+ The function next-error, assigned to \\[next-error], takes the next error off the list -+ and visits its location." -+ (setq perldb-error-list nil) -+ (message "Parsing error messages...") -+ (let (text-buffer -+ last-filename last-linenum) -+ ;; Don't reparse messages already seen at last parse. -+ (goto-char perldb-parsing-end) -+ ;; Don't parse the first two lines as error messages. -+ ;; This matters for grep. -+ (if (bobp) -+ (forward-line 2)) -+ (while (re-search-forward compilation-error-regexp nil t) -+ (let (linenum filename -+ error-marker text-marker) -+ ;; Extract file name and line number from error message. -+ (save-restriction -+ (narrow-to-region (match-beginning 0) (match-end 0)) -+ (goto-char (point-max)) -+ (skip-chars-backward "[0-9]") -+ ;; If it's a lint message, use the last file(linenum) on the line. -+ ;; Normally we use the first on the line. -+ (if (= (preceding-char) ?\() -+ (progn -+ (narrow-to-region (point-min) (1+ (buffer-size))) -+ (end-of-line) -+ (re-search-backward compilation-error-regexp) -+ (skip-chars-backward "^ \t\n") -+ (narrow-to-region (point) (match-end 0)) -+ (goto-char (point-max)) -+ (skip-chars-backward "[0-9]"))) -+ ;; Are we looking at a "filename-first" or "line-number-first" form? -+ (if (looking-at "[0-9]") -+ (progn -+ (setq linenum (read (current-buffer))) -+ (goto-char (point-min))) -+ ;; Line number at start, file name at end. -+ (progn -+ (goto-char (point-min)) -+ (setq linenum (read (current-buffer))) -+ (goto-char (point-max)) -+ (skip-chars-backward "^ \t\n"))) -+ (setq filename (perldb-grab-filename))) -+ ;; Locate the erring file and line. -+ (if (and (equal filename last-filename) -+ (= linenum last-linenum)) -+ nil -+ (beginning-of-line 1) -+ (setq error-marker (point-marker)) -+ ;; text-buffer gets the buffer containing this error's file. -+ (if (not (equal filename last-filename)) -+ (setq text-buffer -+ (and (file-exists-p (setq last-filename filename)) -+ (find-file-noselect filename)) -+ last-linenum 0)) -+ (if text-buffer -+ ;; Go to that buffer and find the erring line. -+ (save-excursion -+ (set-buffer text-buffer) -+ (if (zerop last-linenum) -+ (progn -+ (goto-char 1) -+ (setq last-linenum 1))) -+ (forward-line (- linenum last-linenum)) -+ (setq last-linenum linenum) -+ (setq text-marker (point-marker)) -+ (setq perldb-error-list -+ (cons (list error-marker text-marker) -+ perldb-error-list))))) -+ (forward-line 1))) -+ (setq perldb-parsing-end (point-max))) -+ (message "Parsing error messages...done") -+ (setq perldb-error-list (nreverse perldb-error-list))) -+ -+ (defun perldb-grab-filename () -+ "Return a string which is a filename, starting at point. -+ Ignore quotes and parentheses around it, as well as trailing colons." -+ (if (eq (following-char) ?\") -+ (save-restriction -+ (narrow-to-region (point) -+ (progn (forward-sexp 1) (point))) -+ (goto-char (point-min)) -+ (read (current-buffer))) -+ (buffer-substring (point) -+ (progn -+ (skip-chars-forward "^ :,\n\t(") -+ (point))))) -+ -+ (define-key ctl-x-map "~" 'perldb-next-error) - - |