emacs/perldb.el

   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 \f
  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 \f
 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 \f
 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)))