diff options
Diffstat (limited to 'emacs')
| -rw-r--r-- | emacs/perl-mode.el | 631 | ||||
| -rw-r--r-- | emacs/perldb.el | 423 | ||||
| -rw-r--r-- | emacs/perldb.pl | 565 | ||||
| -rw-r--r-- | emacs/tedstuff | 296 |
4 files changed, 1915 insertions, 0 deletions
diff --git a/emacs/perl-mode.el b/emacs/perl-mode.el new file mode 100644 index 0000000000..5d7078cf3c --- /dev/null +++ b/emacs/perl-mode.el @@ -0,0 +1,631 @@ +;; 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 new file mode 100644 index 0000000000..66951be26d --- /dev/null +++ b/emacs/perldb.el @@ -0,0 +1,423 @@ +;; 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 new file mode 100644 index 0000000000..9d07da32c6 --- /dev/null +++ b/emacs/perldb.pl @@ -0,0 +1,565 @@ +package DB; + +# modified Perl debugger, to be run from Emacs in perldb-mode +# Ray Lischner (uunet!mntgfx!lisch) as of 5 Nov 1990 + +$header = '$Header: perldb.pl,v 4.0 91/03/20 01:18:58 lwall Locked $'; +# +# 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 $ +# Revision 4.0 91/03/20 01:18:58 lwall +# 4.0 baseline. +# +# Revision 3.0.1.6 91/01/11 18:08:58 lwall +# patch42: @_ couldn't be accessed from debugger +# +# Revision 3.0.1.5 90/11/10 01:40:26 lwall +# patch38: the debugger wouldn't stop correctly or do action routines +# +# Revision 3.0.1.4 90/10/15 17:40:38 lwall +# patch29: added caller +# patch29: the debugger now understands packages and evals +# patch29: scripts now run at almost full speed under the debugger +# patch29: more variables are settable from debugger +# +# Revision 3.0.1.3 90/08/09 04:00:58 lwall +# patch19: debugger now allows continuation lines +# patch19: debugger can now dump lists of variables +# patch19: debugger can now add aliases easily from prompt +# +# Revision 3.0.1.2 90/03/12 16:39:39 lwall +# patch13: perl -d didn't format stack traces of *foo right +# patch13: perl -d wiped out scalar return values of subroutines +# +# Revision 3.0.1.1 89/10/26 23:14:02 lwall +# patch1: RCS expanded an unintended $Header in lib/perldb.pl +# +# Revision 3.0 89/10/18 15:19:46 lwall +# 3.0 baseline +# +# Revision 2.0 88/06/05 00:09:45 root +# Baseline version 2.0. +# +# + +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 new file mode 100644 index 0000000000..257bbc8553 --- /dev/null +++ b/emacs/tedstuff @@ -0,0 +1,296 @@ +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) + + |