Commit | Line | Data |
fe14fcc3 |
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))) |