lisch@mentor.com (Ray Lischner) (05/03/90)
I cobbled together a perldb-mode for GNU Emacs, based on gdb-mode.
Basically, you invoke perldb (M-x perldb), and you are prompted
for a Perl file and additional command line arguments. The file
is shown with an arrow (=>) at the beginning of the first
executable line, and another window is used for interaction
with the Perl debugger. A modified form of perldb.pl is required.
You can set breakpoints in the file's window by moving point
to the line and entering C-x SPC. In the perldb window,
debugger commands can be bound to keys. By default, M-s
single steps, M-n steps over subroutines, and M-c continues.
The current line is always displayed, marked by an arrow.
I'd rather have an X-windows perldb, but this was easier.
Following are patches for perldb.pl and perldb.el. Apply
the patches in the lib/ subdirectory; put perldb.el wherever
you want it. Improvements are encouraged.
*** /dev/null Fri Dec 1 12:08:18 1989
--- perldb.el Wed May 2 16:04:49 1990
***************
*** 0 ****
--- 1,435 ----
+ ;; Run perl -d under Emacs
+ ;; Modification by Ray Lischner (uunet!mntgfx!lisch) 2 May 1990
+ ;; A modified perldb.pl is required.
+ ;;
+ ;; based on gdb.el by W. Schelter, rewritten by rms:
+ ;; Author: W. Schelter, University of Texas
+ ;; wfs@rascal.ics.utexas.edu
+ ;; Rewritten by rms.
+
+ ;; Some ideas are due to Masanobu.
+
+ ;; 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 perldb interface:
+
+ ;; A facility is provided for the simultaneous display of the source code
+ ;; in one window, while using perl -d 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. Perl will be invoked on this file, in a
+ ;; window named *perldb-foo* if the file is foo. You will then be asked
+ ;; for additional command line arguments. Arguments are interpreted
+ ;; normally, i.e., separated by white space, except for single and
+ ;; double quotes. Shell and environment variables are NOT interpolated.
+
+ ;; 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 perldb command next on \M-n
+ ;; (def-perldb next "\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-file ""
+ "The full path name of the file being debugged by 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 (format "perldb-%s" name)))
+ (cstr (list 'if '(not (= 1 arg))
+ (list 'format "%s %s" name 'arg)
+ name)))
+ (list 'progn
+ (list 'defun fun '(arg)
+ (or doc "")
+ '(interactive "p")
+ (list 'perldb-call cstr))
+ (list 'define-key 'perldb-mode-map key (list '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")
+
+
+ (defun perldb-mode ()
+ "Major mode for interacting with an inferior Perl 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-c] 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-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)
+ (make-local-variable 'perdb-file)
+ (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 directory containing FILE becomes the initial working directory."
+ (interactive "fRun perl -d on file:
+ sCommand line arguments: ")
+ (setq path (expand-file-name path))
+ (let ((file (file-name-nondirectory path)))
+ (switch-to-buffer (concat "*perldb-" file "*"))
+ (setq default-directory (file-name-directory path))
+ (or (bolp) (newline))
+ (insert "Current directory is " default-directory "\n")
+ (setq perldb-file path)
+ (apply 'make-shell
+ (concat "perldb-" file) perldb-command-name nil "-d" file "-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 perldb
+ ;; into the buffer.
+ ;; Aside from inserting the text, it notices and deletes
+ ;; each filename-and-line-number;
+ ;; that perldb 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 perldb-file
+ (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\\032LINE\\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 ((file-name (file-name-nondirectory buffer-file-name))
+ (line (save-restriction
+ (widen)
+ (1+ (count-lines 1 (point))))))
+ (send-string (get-buffer-process current-perldb-buffer)
+ (concat "b " line "\n"))))
+
+ (defun perldb-read-address()
+ "Return a string containing the core-address found in the buffer at point."
+ (save-excursion
+ (let ((pt (dot)) found begin)
+ (setq found (if (search-backward "0x" (- pt 7) t)(dot)))
+ (cond (found (forward-char 2)(setq result
+ (buffer-substring found
+ (progn (re-search-forward "[^0-9a-f]")
+ (forward-char -1)
+ (dot)))))
+ (t (setq begin (progn (re-search-backward "[^0-9]") (forward-char 1)
+ (dot)))
+ (forward-char 1)
+ (re-search-forward "[^0-9]")
+ (forward-char -1)
+ (buffer-substring begin (dot)))))))
+
+
+ (defvar perldb-commands nil
+ "List of strings or functions used by send-perldb-command.
+ It is for customization by you.")
+
+ (defun send-perldb-command (arg)
+
+ "This command reads the number where the cursor is positioned. It
+ then inserts this ADDR at the end of the perldb buffer. A numeric arg
+ selects the ARG'th member COMMAND of the list perldb-print-command. If
+ COMMAND is a string, (format COMMAND ADDR) is inserted, otherwise
+ (funcall COMMAND ADDR) is inserted. eg. \"p (rtx)%s->fld[0].rtint\"
+ is a possible string to be a member of perldb-commands. "
+
+
+ (interactive "P")
+ (let (comm addr)
+ (if arg (setq comm (nth arg perldb-commands)))
+ (setq addr (perldb-read-address))
+ (if (eq (current-buffer) current-perldb-buffer)
+ (set-mark (point)))
+ (cond (comm
+ (setq comm
+ (if (stringp comm) (format comm addr) (funcall comm addr))))
+ (t (setq comm addr)))
+ (switch-to-buffer current-perldb-buffer)
+ (goto-char (dot-max))
+ (insert-string comm)))
*** perldb.pl-dist Tue Mar 13 10:09:29 1990
--- perldb.pl Wed May 2 15:48:41 1990
***************
*** 9,14 ****
--- 9,18 ----
# 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.
#
+ # If we are running in perldb-mode from Emacs, the first command line
+ # argument is "-emacs", which we remove. In perldb-mode, we output a
+ # magic string to identify the current line, rather than printing it.
+ #
# $Log: perldb.pl,v $
# Revision 3.0.1.2 90/03/12 16:39:39 lwall
# patch13: perl -d didn't format stack traces of *foo right
***************
*** 35,40 ****
--- 39,47 ----
$header =~ s/.Header: ([^,]+),v(\s+\S+\s+\S+).*$/$1$2/;
print OUT "\nLoading DB from $header\n\n";
+ $emacs = $#main'ARGV > $[ && $main'ARGV[$[] eq '-emacs';
+ shift(@main'ARGV) if $emacs;
+
sub DB {
local($. ,$@, $!, $[, $,, $/, $\);
$[ = 0; $, = ""; $/ = "\n"; $\ = "";
***************
*** 50,59 ****
}
}
if ($single || $trace || $signal) {
! print OUT "$sub($line):\t",$line[$line];
! for ($i = $line + 1; $i <= $max && $line[$i] == 0; ++$i) {
! last if $line[$i] =~ /^\s*(}|#|\n)/;
! print OUT "$sub($i):\t",$line[$i];
}
}
if ($action[$line]) {
--- 57,70 ----
}
}
if ($single || $trace || $signal) {
! if ($emacs) {
! print OUT "\32\32:$line:1\n";
! } else {
! print OUT "$sub($line):\t",$line[$line];
! for ($i = $line + 1; $i <= $max && $line[$i] == 0; ++$i) {
! last if $line[$i] =~ /^\s*(}|#|\n)/;
! print OUT "$sub($i):\t",$line[$i];
! }
}
}
if ($action[$line]) {
***************
*** 184,192 ****
$i = $2;
$i = $line if $i eq '.';
$i = 1 if $i < 1;
! for (; $i <= $end; $i++) {
! print OUT "$i:\t", $line[$i];
! last if $signal;
}
$start = $i; # remember in case they want more
$start = $max if $start > $max;
--- 195,207 ----
$i = $2;
$i = $line if $i eq '.';
$i = 1 if $i < 1;
! if ($emacs) {
! print OUT "\32\32:$line:1\n";
! } else {
! for (; $i <= $end; $i++) {
! print OUT "$i:\t", $line[$i];
! last if $signal;
! }
}
$start = $i; # remember in case they want more
$start = $max if $start > $max;
***************
*** 299,305 ****
$start = 1 if ($start > $max);
last if ($start == $end);
if ($line[$start] =~ m'."\n$pat\n".'i) {
! print OUT "$start:\t", $line[$start], "\n";
last;
}
} ';
--- 314,324 ----
$start = 1 if ($start > $max);
last if ($start == $end);
if ($line[$start] =~ m'."\n$pat\n".'i) {
! if ($emacs) {
! print OUT "\32\32:$start:1\n";
! } else {
! print OUT "$start:\t", $line[$start], "\n";
! }
last;
}
} ';
***************
*** 323,329 ****
$start = $max if ($start <= 0);
last if ($start == $end);
if ($line[$start] =~ m'."\n$pat\n".'i) {
! print OUT "$start:\t", $line[$start], "\n";
last;
}
} ';
--- 342,352 ----
$start = $max if ($start <= 0);
last if ($start == $end);
if ($line[$start] =~ m'."\n$pat\n".'i) {
! if ($emacs) {
! print OUT "\32\32:$start:1\n";
! } else {
! print OUT "$start:\t", $line[$start], "\n";
! }
last;
}
} ';
--
Ray Lischner UUCP: {uunet,apollo,decwrl}!mntgfx!lisch