perldb.el

早期freebsd实现

;; 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