home *** CD-ROM | disk | FTP | other *** search
/ The World of Computer Software / World_Of_Computer_Software-02-387-Vol-3of3.iso / p / perl4036.zip / emacs / perldb.el < prev    next >
Lisp/Scheme  |  1993-02-08  |  16KB  |  424 lines
  1. ;; Run perl -d under Emacs
  2. ;; Based on gdb.el, as written by W. Schelter, and modified by rms.
  3. ;; Modified for Perl by Ray Lischner (uunet!mntgfx!lisch), Nov 1990.
  4.  
  5. ;; This file is part of GNU Emacs.
  6. ;; Copyright (C) 1988,1990 Free Software Foundation, Inc.
  7.  
  8. ;; GNU Emacs is distributed in the hope that it will be useful, but
  9. ;; WITHOUT ANY WARRANTY.  No author or distributor accepts responsibility
  10. ;; to anyone for the consequences of using it or for whether it serves
  11. ;; any particular purpose or works at all, unless he says so in writing.
  12. ;; Refer to the GNU Emacs General Public License for full details.
  13.  
  14. ;; Everyone is granted permission to copy, modify and redistribute GNU
  15. ;; Emacs, but only under the conditions described in the GNU Emacs
  16. ;; General Public License.  A copy of this license is supposed to have
  17. ;; been given to you along with GNU Emacs so you can know your rights and
  18. ;; responsibilities.  It should be in a file named COPYING.  Among other
  19. ;; things, the copyright notice and this notice must be preserved on all
  20. ;; copies.
  21.  
  22. ;; Description of perl -d interface:
  23.  
  24. ;; A facility is provided for the simultaneous display of the source code
  25. ;; in one window, while using perldb to step through a function in the
  26. ;; other.  A small arrow in the source window, indicates the current
  27. ;; line.
  28.  
  29. ;; Starting up:
  30.  
  31. ;; In order to use this facility, invoke the command PERLDB to obtain a
  32. ;; shell window with the appropriate command bindings.  You will be asked
  33. ;; for the name of a file to run and additional command line arguments.
  34. ;; Perldb will be invoked on this file, in a window named *perldb-foo*
  35. ;; if the file is foo.
  36.  
  37. ;; M-s steps by one line, and redisplays the source file and line.
  38.  
  39. ;; You may easily create additional commands and bindings to interact
  40. ;; with the display.  For example to put the perl debugger command n on \M-n
  41. ;; (def-perldb n "\M-n")
  42.  
  43. ;; This causes the emacs command perldb-next to be defined, and runs
  44. ;; perldb-display-frame after the command.
  45.  
  46. ;; perldb-display-frame is the basic display function.  It tries to display
  47. ;; in the other window, the file and line corresponding to the current
  48. ;; position in the perldb window.  For example after a perldb-step, it would
  49. ;; display the line corresponding to the position for the last step.  Or
  50. ;; if you have done a backtrace in the perldb buffer, and move the cursor
  51. ;; into one of the frames, it would display the position corresponding to
  52. ;; that frame.
  53.  
  54. ;; perldb-display-frame is invoked automatically when a filename-and-line-number
  55. ;; appears in the output.
  56.  
  57.  
  58. (require 'shell)
  59.  
  60. (defvar perldb-prompt-pattern "^  DB<[0-9]+> "
  61.   "A regexp to recognize the prompt for perldb.") 
  62.  
  63. (defvar perldb-mode-map nil
  64.   "Keymap for perldb-mode.")
  65.  
  66. (if perldb-mode-map
  67.    nil
  68.   (setq perldb-mode-map (copy-keymap shell-mode-map))
  69.   (define-key perldb-mode-map "\C-l" 'perldb-refresh))
  70.  
  71. (define-key ctl-x-map " " 'perldb-break)
  72. (define-key ctl-x-map "&" 'send-perldb-command)
  73.  
  74. ;;Of course you may use `def-perldb' with any other perldb command, including
  75. ;;user defined ones.   
  76.  
  77. (defmacro def-perldb (name key &optional doc)
  78.   (let* ((fun (intern (concat "perldb-" name))))
  79.     (` (progn
  80.      (defun (, fun) (arg)
  81.        (, (or doc ""))
  82.        (interactive "p")
  83.        (perldb-call (if (not (= 1 arg))
  84.                 (concat (, name) arg)
  85.               (, name))))
  86.      (define-key perldb-mode-map (, key) (quote (, fun)))))))
  87.  
  88. (def-perldb "s"   "\M-s" "Step one source line with display")
  89. (def-perldb "n"   "\M-n" "Step one source line (skip functions)")
  90. (def-perldb "c"   "\M-c" "Continue with display")
  91. (def-perldb "r"   "\C-c\C-r" "Return from current subroutine")
  92. (def-perldb "A"   "\C-c\C-a" "Delete all actions")
  93.  
  94. (defun perldb-mode ()
  95.   "Major mode for interacting with an inferior Perl debugger process.
  96. The following commands are available:
  97.  
  98. \\{perldb-mode-map}
  99.  
  100. \\[perldb-display-frame] displays in the other window
  101. the last line referred to in the perldb buffer.
  102.  
  103. \\[perldb-s],\\[perldb-n], and \\[perldb-n] in the perldb window,
  104. call perldb to step, next or continue and then update the other window
  105. with the current file and position.
  106.  
  107. If you are in a source file, you may select a point to break
  108. at, by doing \\[perldb-break].
  109.  
  110. Commands:
  111. Many commands are inherited from shell mode. 
  112. Additionally we have:
  113.  
  114. \\[perldb-display-frame] display frames file in other window
  115. \\[perldb-s] advance one line in program
  116. \\[perldb-n] advance one line in program (skip over calls).
  117. \\[send-perldb-command] used for special printing of an arg at the current point.
  118. C-x SPACE sets break point at current line."
  119.   (interactive)
  120.   (kill-all-local-variables)
  121.   (setq major-mode 'perldb-mode)
  122.   (setq mode-name "Inferior Perl")
  123.   (setq mode-line-process '(": %s"))
  124.   (use-local-map perldb-mode-map)
  125.   (make-local-variable 'last-input-start)
  126.   (setq last-input-start (make-marker))
  127.   (make-local-variable 'last-input-end)
  128.   (setq last-input-end (make-marker))
  129.   (make-local-variable 'perldb-last-frame)
  130.   (setq perldb-last-frame nil)
  131.   (make-local-variable 'perldb-last-frame-displayed-p)
  132.   (setq perldb-last-frame-displayed-p t)
  133.   (make-local-variable 'perldb-delete-prompt-marker)
  134.   (setq perldb-delete-prompt-marker nil)
  135.   (make-local-variable 'perldb-filter-accumulator)
  136.   (setq perldb-filter-accumulator nil)
  137.   (make-local-variable 'shell-prompt-pattern)
  138.   (setq shell-prompt-pattern perldb-prompt-pattern)
  139.   (run-hooks 'shell-mode-hook 'perldb-mode-hook))
  140.  
  141. (defvar current-perldb-buffer nil)
  142.  
  143. (defvar perldb-command-name "perl"
  144.   "Pathname for executing perl -d.")
  145.  
  146. (defun end-of-quoted-arg (argstr start end)
  147.   (let* ((chr (substring argstr start (1+ start)))
  148.      (idx (string-match (concat "[^\\]" chr) argstr (1+ start))))
  149.     (and idx (1+ idx))
  150.     )
  151. )
  152.  
  153. (defun parse-args-helper (arglist argstr start end)
  154.   (while (and (< start end) (string-match "[ \t\n\f\r\b]"
  155.                       (substring argstr start (1+ start))))
  156.     (setq start (1+ start)))
  157.   (cond
  158.     ((= start end) arglist)
  159.     ((string-match "[\"']" (substring argstr start (1+ start)))
  160.      (let ((next (end-of-quoted-arg argstr start end)))
  161.        (parse-args-helper (cons (substring argstr (1+ start) next) arglist)
  162.               argstr (1+ next) end)))
  163.     (t (let ((next (string-match "[ \t\n\f\b\r]" argstr start)))
  164.      (if next
  165.          (parse-args-helper (cons (substring argstr start next) arglist)
  166.                 argstr (1+ next) end)
  167.        (cons (substring argstr start) arglist))))
  168.     )
  169.   )
  170.     
  171. (defun parse-args (args)
  172.   "Extract arguments from a string ARGS.
  173. White space separates arguments, with single or double quotes
  174. used to protect spaces.  A list of strings is returned, e.g.,
  175. (parse-args \"foo bar 'two args'\") => (\"foo\" \"bar\" \"two args\")."
  176.   (nreverse (parse-args-helper '() args 0 (length args)))
  177. )
  178.  
  179. (defun perldb (path args)
  180.   "Run perldb on program FILE in buffer *perldb-FILE*.
  181. The default directory for the current buffer becomes the initial
  182. working directory, by analogy with  gdb .  If you wish to change this, use
  183. the Perl command `chdir(DIR)'."
  184.   (interactive "FRun perl -d on file: \nsCommand line arguments: ")
  185.   (setq path (expand-file-name path))
  186.   (let ((file (file-name-nondirectory path))
  187.     (dir default-directory))
  188.     (switch-to-buffer (concat "*perldb-" file "*"))
  189.     (setq default-directory dir)
  190.     (or (bolp) (newline))
  191.     (insert "Current directory is " default-directory "\n")
  192.     (apply 'make-shell
  193.        (concat "perldb-" file) perldb-command-name nil "-d" path "-emacs"
  194.        (parse-args args))
  195.     (perldb-mode)
  196.     (set-process-filter (get-buffer-process (current-buffer)) 'perldb-filter)
  197.     (set-process-sentinel (get-buffer-process (current-buffer)) 'perldb-sentinel)
  198.     (perldb-set-buffer)))
  199.  
  200. (defun perldb-set-buffer ()
  201.   (cond ((eq major-mode 'perldb-mode)
  202.     (setq current-perldb-buffer (current-buffer)))))
  203.  
  204. ;; This function is responsible for inserting output from Perl
  205. ;; into the buffer.
  206. ;; Aside from inserting the text, it notices and deletes
  207. ;; each filename-and-line-number;
  208. ;; that Perl prints to identify the selected frame.
  209. ;; It records the filename and line number, and maybe displays that file.
  210. (defun perldb-filter (proc string)
  211.   (let ((inhibit-quit t))
  212.     (if perldb-filter-accumulator
  213.     (perldb-filter-accumulate-marker proc
  214.                       (concat perldb-filter-accumulator string))
  215.     (perldb-filter-scan-input proc string))))
  216.  
  217. (defun perldb-filter-accumulate-marker (proc string)
  218.   (setq perldb-filter-accumulator nil)
  219.   (if (> (length string) 1)
  220.       (if (= (aref string 1) ?\032)
  221.       (let ((end (string-match "\n" string)))
  222.         (if end
  223.         (progn
  224.           (let* ((first-colon (string-match ":" string 2))
  225.              (second-colon
  226.               (string-match ":" string (1+ first-colon))))
  227.             (setq perldb-last-frame
  228.               (cons (substring string 2 first-colon)
  229.                 (string-to-int
  230.                  (substring string (1+ first-colon)
  231.                         second-colon)))))
  232.           (setq perldb-last-frame-displayed-p nil)
  233.           (perldb-filter-scan-input proc
  234.                      (substring string (1+ end))))
  235.           (setq perldb-filter-accumulator string)))
  236.     (perldb-filter-insert proc "\032")
  237.     (perldb-filter-scan-input proc (substring string 1)))
  238.     (setq perldb-filter-accumulator string)))
  239.  
  240. (defun perldb-filter-scan-input (proc string)
  241.   (if (equal string "")
  242.       (setq perldb-filter-accumulator nil)
  243.       (let ((start (string-match "\032" string)))
  244.     (if start
  245.         (progn (perldb-filter-insert proc (substring string 0 start))
  246.            (perldb-filter-accumulate-marker proc
  247.                          (substring string start)))
  248.         (perldb-filter-insert proc string)))))
  249.  
  250. (defun perldb-filter-insert (proc string)
  251.   (let ((moving (= (point) (process-mark proc)))
  252.     (output-after-point (< (point) (process-mark proc)))
  253.     (old-buffer (current-buffer))
  254.     start)
  255.     (set-buffer (process-buffer proc))
  256.     (unwind-protect
  257.     (save-excursion
  258.       ;; Insert the text, moving the process-marker.
  259.       (goto-char (process-mark proc))
  260.       (setq start (point))
  261.       (insert string)
  262.       (set-marker (process-mark proc) (point))
  263.       (perldb-maybe-delete-prompt)
  264.       ;; Check for a filename-and-line number.
  265.       (perldb-display-frame
  266.        ;; Don't display the specified file
  267.        ;; unless (1) point is at or after the position where output appears
  268.        ;; and (2) this buffer is on the screen.
  269.        (or output-after-point
  270.            (not (get-buffer-window (current-buffer))))
  271.        ;; Display a file only when a new filename-and-line-number appears.
  272.        t))
  273.       (set-buffer old-buffer))
  274.     (if moving (goto-char (process-mark proc)))))
  275.  
  276. (defun perldb-sentinel (proc msg)
  277.   (cond ((null (buffer-name (process-buffer proc)))
  278.      ;; buffer killed
  279.      ;; Stop displaying an arrow in a source file.
  280.      (setq overlay-arrow-position nil)
  281.      (set-process-buffer proc nil))
  282.     ((memq (process-status proc) '(signal exit))
  283.      ;; Stop displaying an arrow in a source file.
  284.      (setq overlay-arrow-position nil)
  285.      ;; Fix the mode line.
  286.      (setq mode-line-process
  287.            (concat ": "
  288.                (symbol-name (process-status proc))))
  289.      (let* ((obuf (current-buffer)))
  290.        ;; save-excursion isn't the right thing if
  291.        ;;  process-buffer is current-buffer
  292.        (unwind-protect
  293.            (progn
  294.          ;; Write something in *compilation* and hack its mode line,
  295.          (set-buffer (process-buffer proc))
  296.          ;; Force mode line redisplay soon
  297.          (set-buffer-modified-p (buffer-modified-p))
  298.          (if (eobp)
  299.              (insert ?\n mode-name " " msg)
  300.            (save-excursion
  301.              (goto-char (point-max))
  302.              (insert ?\n mode-name " " msg)))
  303.          ;; If buffer and mode line will show that the process
  304.          ;; is dead, we can delete it now.  Otherwise it
  305.          ;; will stay around until M-x list-processes.
  306.          (delete-process proc))
  307.          ;; Restore old buffer, but don't restore old point
  308.          ;; if obuf is the perldb buffer.
  309.          (set-buffer obuf))))))
  310.  
  311.  
  312. (defun perldb-refresh ()
  313.   "Fix up a possibly garbled display, and redraw the arrow."
  314.   (interactive)
  315.   (redraw-display)
  316.   (perldb-display-frame))
  317.  
  318. (defun perldb-display-frame (&optional nodisplay noauto)
  319.   "Find, obey and delete the last filename-and-line marker from PERLDB.
  320. The marker looks like \\032\\032FILENAME:LINE:CHARPOS\\n.
  321. Obeying it means displaying in another window the specified file and line."
  322.   (interactive)
  323.   (perldb-set-buffer)
  324.   (and perldb-last-frame (not nodisplay)
  325.        (or (not perldb-last-frame-displayed-p) (not noauto))
  326.        (progn (perldb-display-line (car perldb-last-frame) (cdr perldb-last-frame))
  327.           (setq perldb-last-frame-displayed-p t))))
  328.  
  329. ;; Make sure the file named TRUE-FILE is in a buffer that appears on the screen
  330. ;; and that its line LINE is visible.
  331. ;; Put the overlay-arrow on the line LINE in that buffer.
  332.  
  333. (defun perldb-display-line (true-file line)
  334.   (let* ((buffer (find-file-noselect true-file))
  335.      (window (display-buffer buffer t))
  336.      (pos))
  337.     (save-excursion
  338.       (set-buffer buffer)
  339.       (save-restriction
  340.     (widen)
  341.     (goto-line line)
  342.     (setq pos (point))
  343.     (setq overlay-arrow-string "=>")
  344.     (or overlay-arrow-position
  345.         (setq overlay-arrow-position (make-marker)))
  346.     (set-marker overlay-arrow-position (point) (current-buffer)))
  347.       (cond ((or (< pos (point-min)) (> pos (point-max)))
  348.          (widen)
  349.          (goto-char pos))))
  350.     (set-window-point window overlay-arrow-position)))
  351.  
  352. (defun perldb-call (command)
  353.   "Invoke perldb COMMAND displaying source in other window."
  354.   (interactive)
  355.   (goto-char (point-max))
  356.   (setq perldb-delete-prompt-marker (point-marker))
  357.   (perldb-set-buffer)
  358.   (send-string (get-buffer-process current-perldb-buffer)
  359.            (concat command "\n")))
  360.  
  361. (defun perldb-maybe-delete-prompt ()
  362.   (if (and perldb-delete-prompt-marker
  363.        (> (point-max) (marker-position perldb-delete-prompt-marker)))
  364.       (let (start)
  365.     (goto-char perldb-delete-prompt-marker)
  366.     (setq start (point))
  367.     (beginning-of-line)
  368.     (delete-region (point) start)
  369.     (setq perldb-delete-prompt-marker nil))))
  370.  
  371. (defun perldb-break ()
  372.   "Set PERLDB breakpoint at this source line."
  373.   (interactive)
  374.   (let ((line (save-restriction
  375.         (widen)
  376.         (1+ (count-lines 1 (point))))))
  377.     (send-string (get-buffer-process current-perldb-buffer)
  378.          (concat "b " line "\n"))))
  379.  
  380. (defun perldb-read-token()
  381.   "Return a string containing the token found in the buffer at point.
  382. A token can be a number or an identifier.  If the token is a name prefaced
  383. by `$', `@', or `%', the leading character is included in the token."
  384.   (save-excursion
  385.     (let (begin)
  386.       (or (looking-at "[$@%]")
  387.       (re-search-backward "[^a-zA-Z_0-9]" (point-min) 'move))
  388.       (setq begin (point))
  389.       (or (looking-at "[$@%]") (setq begin (+ begin 1)))
  390.       (forward-char 1)
  391.       (buffer-substring begin
  392.             (if (re-search-forward "[^a-zA-Z_0-9]"
  393.                            (point-max) 'move)
  394.                    (- (point) 1)
  395.               (point)))
  396. )))
  397.  
  398. (defvar perldb-commands nil
  399.   "List of strings or functions used by send-perldb-command.
  400. It is for customization by the user.")
  401.  
  402. (defun send-perldb-command (arg)
  403.   "Issue a Perl debugger command selected by the prefix arg.  A numeric
  404. arg selects the ARG'th member COMMAND of the list perldb-commands.
  405. The token under the cursor is passed to the command.  If COMMAND is a
  406. string, (format COMMAND TOKEN) is inserted at the end of the perldb
  407. buffer, otherwise (funcall COMMAND TOKEN) is inserted.  If there is
  408. no such COMMAND, then the token itself is inserted.  For example,
  409. \"p %s\" is a possible string to be a member of perldb-commands,
  410. or \"p $ENV{%s}\"."
  411.   (interactive "P")
  412.   (let (comm token)
  413.     (if arg (setq comm (nth arg perldb-commands)))
  414.     (setq token (perldb-read-token))
  415.     (if (eq (current-buffer) current-perldb-buffer)
  416.     (set-mark (point)))
  417.     (cond (comm
  418.        (setq comm
  419.          (if (stringp comm) (format comm token) (funcall comm token))))
  420.       (t (setq comm token)))
  421.     (switch-to-buffer-other-window current-perldb-buffer)
  422.     (goto-char (dot-max))
  423.     (insert-string comm)))
  424.