;;; perldb+.el --- an enhanced perl debugging mode ;; Copyright (C) 1988,1990,1997,2000 Free Software Foundation, Inc. ;; Author: W. Schelter, Ray Lischner ;; Maintainer: Jay Rogers ;; Keywords: debugger, perl ;; Version: 1.03 ;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2 of the License, or ;; (at your option) any later version. ;; ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with this program; if not, write to the Free Software ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ;;; Commentary: ;; Description ;; =========== ;; Perldb+ provides an interface to Perl's debugger (perl -dw) within ;; emacs. This implementation of perldb is an alternative to the one ;; that comes with emacs as part of the GUD library (Grand Unified ;; Debugger). It contains a feature to position to where syntax ;; errors or warnings occur in the source. It also provides ;; minibuffer filename completion when entering the perl source to ;; debug. It is known to work with Emacs versions 19-20, XEmacs ;; versions 19-20, and Emacs 19.34 for NT/95. ;; ;; ;; Installation ;; ============ ;; Copy or move this file to a file called perldb+.el in a lisp ;; directory known to emacs (see emacs variable `load-path'). ;; Optionally byte compile it (you can ignore warnings about "free ;; variables"). Put the following in a startup file such as your ;; ~/.emacs ;; ;; (autoload 'perldb "perldb+" "Major mode for running the Perl debugger." t) ;; (eval-after-load "gud" '(load "perldb+" t t)) ;; ;; ;; Usage ;; ===== ;; Use M-x perldb to invoke. You are prompted for the Perl source to ;; debug and its command line arguments. When invoked with a prefix ;; argument then the current buffer is the default source to debug. ;; The perl interpreter is started in debug mode and displayed in its ;; own buffer using `perldb-command-name' and `perldb-command-args'. ;; Change these variables to use a different perl interpreter with ;; different command line switches. Their defaults are "perl" and ;; "-dw". ;; ;; The source is displayed in another buffer with an arrow (`=>') ;; indicating the next line of execution. If there are compilation ;; errors then iteratively use the command `C-x `' to visit the ;; location of each error in the source. ;; ;; ;; Special Notes for MS-Win32 ;; ========================== ;; For MS-Windows NT/95 and perl version 5.004_01 or version 5.001 and ;; less, the debugger doesn't work with emacs. To fix, the perl ;; debugger itself must be patched. Locate and change the code ;; similar to the following for the perl file lib/perl5db.pl. ;; ;; if (-e "/dev/tty") { ;; $console = "/dev/tty"; ;; $rcfile=".perldb"; ;; } ;; elsif (-e "con") { ;; $console = ""; <---- change "con" to "" ;; $rcfile="perldb.ini"; ;; } ;; else { ;; $console = "sys\$command"; ;; $rcfile="perldb.ini"; ;; } ;; ;; ;; History ;; ======= ;; Perldb is based on gdb.el, as written by W. Schelter, and modified by rms. ;; It was modified for perl by Ray Lischner (uunet!mntgfx!lisch), Nov 1990. ;; Support for next compilation error comes from Ted Stefanik . ;; Further enhancements and bug fixes by Jay Rogers . ;; ;; ;; Revisions ;; ========= ;; ;; 1.03 jr: ;; When prompting for a program and arguments to debug, minibuffer ;; defaults are supplied and a perldb specific minibuffer history ;; is used. ;; ;; Added "customization" support for the perldb+ user options. ;; ;; Squelched backtrace on warnings nonsense from perl debugger by ;; appending env PERLDB_OPTS with "warnLevel=0". ;; ;; Fixed bug exposed by new version of comint.el in Emacs 20.3. ;; ;; 1.02 jr: ;; Renamed to perldb+.el to distinguish from the one that comes ;; with an emacs distribution. ;; ;; 1.01 jr: ;; Baselined version. ;;; Code: (require 'comint) (cond ((and (fboundp 'defgroup) (fboundp 'defcustom)) (defgroup perldb+ nil "Major mode for interacting with an inferior Perl debugger process." :group 'unix :group 'tools) (defcustom perldb-command-name "perl" "Pathname of Perl interpreter." :type 'string :group 'perldb+) (defcustom perldb-command-args "-dw" "Switches to run perl as debugger." :type 'string :group 'perldb+)) (t (defvar perldb-command-name "perl" "*Pathname of Perl interpreter.") (defvar perldb-command-args "-dw" "*Switches to run perl as debugger."))) ;; Turn-off perl debugger's silly backtrace on warnings. (setenv "PERLDB_OPTS" (if (> (length (getenv "PERLDB_OPTS")) 0) (concat (getenv "PERLDB_OPTS") " warnLevel=0") "warnLevel=0")) (defvar perldb-dos-binmode (and (string= system-type "windows-nt") (boundp 'emacs-major-version) (= emacs-major-version 19) (<= emacs-minor-version 34)) "*This flag turns on a work around for a problem on MS-Win32 machines where emacs hangs before displaying a debugger prompt. This problem is caused by the MS-Win32 I/O routines interpreting ^Z as end-of-file. This problem is fixed in versions of emacs after 19.34.") (defvar perldb-prompt-pattern "^ DB<+[0-9]+>+ " "A regexp to recognize the prompt for perldb.") (defvar perldb-prg-name-history nil) (defvar perldb-prg-name-alist nil) (defvar perldb-prg-args-history nil) (defvar perldb-last-frame nil) (defvar perldb-last-frame-displayed-p nil) (defvar perldb-delete-prompt-marker nil) (defvar perldb-filter-accumulator nil) (defvar perldb-mode-map nil "Keymap for perldb-mode.") (if perldb-mode-map nil (setq perldb-mode-map (copy-keymap comint-mode-map)) (define-key perldb-mode-map "\C-c\C-l" 'perldb-refresh)) (define-key ctl-x-map " " 'perldb-break) (define-key ctl-x-map "&" 'send-perldb-command) (define-key ctl-x-map "~" 'perldb-next-error) (define-key perldb-mode-map "\M-n" 'comint-next-matching-input-from-input) (define-key perldb-mode-map "\M-p" 'comint-previous-matching-input-from-input) (define-key perldb-mode-map "\C-x`" 'perldb-next-error) (if (boundp 'perl-mode-map) (define-key perl-mode-map "\C-x`" 'perldb-next-error) (add-hook 'perl-mode-hook '(lambda () (define-key perl-mode-map "\C-x`" 'perldb-next-error)))) (if (boundp 'cperl-mode-map) (define-key cperl-mode-map "\C-x`" 'perldb-next-error) (add-hook 'cperl-mode-hook '(lambda () (define-key cperl-mode-map "\C-x`" 'perldb-next-error)))) ;;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} You can then use the command \\[perldb-next-error] to find the next error or warning message and move to the source code that caused it. \\[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. Variable `perldb-command-name' specifies which perl to run. Variable `perldb-command-args' specifies perl command line args. It should at least contain -d " (interactive) (kill-all-local-variables) (setq major-mode 'perldb-mode) (setq mode-name "Inferior Perl") (setq mode-line-process '(": %s")) (setq comint-last-output-start (make-marker)) (use-local-map perldb-mode-map) (make-local-variable 'comint-last-input-start) (setq comint-last-input-start (make-marker)) (make-local-variable 'comint-last-input-end) (setq comint-last-input-end (make-marker)) (make-local-variable 'comint-accum-marker) (setq comint-accum-marker (make-marker)) (set-marker comint-accum-marker nil) (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 'comint-prompt-regexp) (setq comint-prompt-regexp perldb-prompt-pattern) (setq paragraph-start comint-prompt-regexp) (run-hooks 'comint-mode-hook 'perldb-mode-hook)) (defvar current-perldb-buffer nil) (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-read-args (prefix) (let* ( args dir file file-name-history history initial-contents initial-path path ) ;; Determine default program name for minibuffer and associated history. (setq file-name-history (copy-sequence (cdr perldb-prg-name-history))) (if prefix (setq initial-path (cond ((buffer-file-name) buffer-file-name) (t default-directory))) (setq initial-path (cond ((consp perldb-prg-name-history) (car perldb-prg-name-history)) ((buffer-file-name) buffer-file-name) (t default-directory)))) (setq dir (file-name-directory initial-path)) (setq file (file-name-nondirectory initial-path)) ;; Prompt user for program name. (setq path (read-file-name (format "Run %s %s on file: " perldb-command-name perldb-command-args) dir initial-path t file)) ;; Determine default program args for minibuffer and associated history. (setq initial-contents (or (cdr (assoc path perldb-prg-name-alist)) "")) (setq history (copy-sequence perldb-prg-args-history)) (if (not (string= initial-contents (car history))) ; diff than last (setq history (if (consp history) (cons initial-contents history) (list initial-contents)))) ;; Prompt user for program args. (setq args (read-from-minibuffer "Command line arguments: " initial-contents nil nil '(history . 1))) ;; Save user's responses to history. (if (not (string= path (car perldb-prg-name-history))) ; diff than last (setq perldb-prg-name-history (if (consp perldb-prg-name-history) (cons path perldb-prg-name-history) (list path)))) (if (not (string= args (car perldb-prg-args-history))) ; diff than last (setq perldb-prg-args-history (if (consp perldb-prg-args-history) (cons args perldb-prg-args-history) (list args)))) (setq perldb-prg-name-alist (cons (cons path args) perldb-prg-name-alist)) ;; Return (setq path (expand-file-name path)) (list path args))) (defun perldb (path args) "Run perl -dw on program PATH, using command line ARGS, in buffer *perldb-PATH*. To change perl -dw see the variables perldb-command-name' and `perldb-command-args'. When called interactively with a prefix argument then the current buffer is the default PATH. 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 `M-x cd'." (interactive (perldb-read-args current-prefix-arg)) (let ((file (file-name-nondirectory path)) (dir default-directory) (binary-process-output perldb-dos-binmode)) (switch-to-buffer (concat "*perldb-" file "*")) (setq default-directory dir) (or (bolp) (newline)) (insert "Current directory is " default-directory "\n" "Use C-x ` to visit locus of compilation errors\n") (apply 'make-comint (concat "perldb-" file) perldb-command-name nil perldb-command-args 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))) (defvar perldb-parsing-end nil "Position of end of buffer when last error messages parsed.") (defun perldb-set-buffer () (cond ((eq major-mode 'perldb-mode) (cond ((not (eq current-perldb-buffer (current-buffer))) (perldb-forget-errors) (setq perldb-parsing-end 2));; 2 to defeat grep defeater (t (if (> perldb-parsing-end (point-max)) (setq perldb-parsing-end (max (point-max) 2))))) (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-dos-binmode (while (string-match "\r\n" string) (setq string (replace-match "\n" t t string)))) (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) (cond ((string-match "\\([^\032\n]+\\):\\([0-9]+\\):[0-9]+\n" string) (setq perldb-last-frame (cons (substring string (match-beginning 1)(match-end 1)) (string-to-int (substring string (match-beginning 2) (match-end 2))))) (setq perldb-last-frame-displayed-p nil) (perldb-filter-scan-input proc (substring string (match-end 0)))) (t (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 *perldb-* 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\\032FILENAME:LINE:CHARPOS\\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 ((line (save-restriction (widen) (1+ (count-lines 1 (point)))))) (process-send-string (get-buffer-process current-perldb-buffer) (concat "b " line "\n")))) (defun perldb-read-token () "Return a string containing the token found in the buffer at point. A token can be a number or an identifier. If the token is a name prefaced by `$', `@', or `%', the leading character is included in the token." (save-excursion (let (begin) (or (looking-at "[$@%]") (re-search-backward "[^a-zA-Z_0-9]" (point-min) 'move)) (setq begin (point)) (or (looking-at "[$@%]") (setq begin (+ begin 1))) (forward-char 1) (buffer-substring begin (if (re-search-forward "[^a-zA-Z_0-9]" (point-max) 'move) (- (point) 1) (point))) ))) (defvar perldb-commands nil "List of strings or functions used by send-perldb-command. It is for customization by the user.") (defun send-perldb-command (arg) "Issue a Perl debugger command selected by the prefix arg. A numeric arg selects the ARG'th member COMMAND of the list perldb-commands. The token under the cursor is passed to the command. If COMMAND is a string, (format COMMAND TOKEN) is inserted at the end of the perldb buffer, otherwise (funcall COMMAND TOKEN) is inserted. If there is no such COMMAND, then the token itself is inserted. For example, \"p %s\" is a possible string to be a member of perldb-commands, or \"p $ENV{%s}\"." (interactive "P") (let (comm token) (if arg (setq comm (nth arg perldb-commands))) (setq token (perldb-read-token)) (if (eq (current-buffer) current-perldb-buffer) (set-mark (point))) (cond (comm (setq comm (if (stringp comm) (format comm token) (funcall comm token)))) (t (setq comm token))) (switch-to-buffer-other-window current-perldb-buffer) (goto-char (point-max)) (insert-string comm))) (defvar perldb-error-list nil "List of error message descriptors for visiting erring functions. Each error descriptor is a list of length two. Its car is a marker pointing to an error message. Its cadr is a marker pointing to the text of the line the message is about, or nil if that is not interesting. The value may be t instead of a list; this means that the buffer of error messages should be reparsed the next time the list of errors is wanted.") (defvar perldb-error-message "No more fatal Perl errors" "Message to print when no more matches for compilation-error-regexp are found") (make-local-variable 'compilation-error-regexp) (defvar compilation-error-regexp "\\([^ :\n]+\\(: *\\|, line \\|(\\)[0-9]+\\)\\|\\([0-9]+ *of *[^ \n]+\\|[^ \n]+ \\(at \\)*line [0-9]+\\)" "Regular expression to recognize perl compilation errors") (defun perldb-next-error (&optional argp) "Visit next perldb error message and corresponding source code. This operates on the output from the \\[perldb] command. If all preparsed error messages have been processed, the error message buffer is checked for new ones. A non-nil argument (prefix arg, if interactive) means reparse the error message buffer and start at the first error." (interactive "P") (if (or (eq perldb-error-list t) argp) (progn (perldb-forget-errors) (setq perldb-parsing-end 2)));; 2 to defeat grep defeater (if perldb-error-list nil (save-excursion (switch-to-buffer current-perldb-buffer) (perldb-parse-errors))) (let ((next-error (car perldb-error-list))) (if (null next-error) (error (concat perldb-error-message (if (and (get-buffer-process current-perldb-buffer) (eq (process-status (get-buffer-process current-perldb-buffer)) 'run)) " yet" "")))) (setq perldb-error-list (cdr perldb-error-list)) (if (null (car (cdr next-error))) nil (switch-to-buffer (marker-buffer (car (cdr next-error)))) (goto-char (car (cdr next-error))) (set-marker (car (cdr next-error)) nil)) (let* ((pop-up-windows t) (w (display-buffer (marker-buffer (car next-error))))) (set-window-point w (car next-error)) (set-window-start w (car next-error))) (set-marker (car next-error) nil))) ;; Set perldb-error-list to nil, and ;; unchain the markers that point to the error messages and their text, ;; so that they no longer slow down gap motion. ;; This would happen anyway at the next garbage collection, ;; but it is better to do it right away. (defun perldb-forget-errors () (if (eq perldb-error-list t) (setq perldb-error-list nil)) (while perldb-error-list (let ((next-error (car perldb-error-list))) (set-marker (car next-error) nil) (if (car (cdr next-error)) (set-marker (car (cdr next-error)) nil))) (setq perldb-error-list (cdr perldb-error-list)))) (defun perldb-parse-errors () "Parse the current buffer as error messages. This makes a list of error descriptors, perldb-error-list. For each source-file, line-number pair in the buffer, the source file is read in, and the text location is saved in perldb-error-list. The function next-error, assigned to \\[next-error], takes the next error off the list and visits its location." (setq perldb-error-list nil) (message "Parsing error messages...") (let (text-buffer last-filename last-linenum) ;; Don't reparse messages already seen at last parse. (goto-char perldb-parsing-end) ;; Don't parse the first two lines as error messages. ;; This matters for grep. (if (bobp) (forward-line 2)) (while (re-search-forward compilation-error-regexp nil t) (let (linenum filename error-marker text-marker) ;; Extract file name and line number from error message. (save-restriction (narrow-to-region (match-beginning 0) (match-end 0)) (goto-char (point-max)) (skip-chars-backward "[0-9]") ;; If it's a lint message, use the last file(linenum) on the line. ;; Normally we use the first on the line. (if (= (preceding-char) ?\() (progn (narrow-to-region (point-min) (1+ (buffer-size))) (end-of-line) (re-search-backward compilation-error-regexp) (skip-chars-backward "^ \t\n") (narrow-to-region (point) (match-end 0)) (goto-char (point-max)) (skip-chars-backward "[0-9]"))) ;; Are we looking at a "filename-first" or "line-number-first" form? (if (looking-at "[0-9]") (progn (setq linenum (read (current-buffer))) (goto-char (point-min))) ;; Line number at start, file name at end. (progn (goto-char (point-min)) (setq linenum (read (current-buffer))) (goto-char (point-max)) (skip-chars-backward "^ \t\n"))) (setq filename (perldb-grab-filename))) ;; Locate the erring file and line. (if (and (equal filename last-filename) (= linenum last-linenum)) nil (beginning-of-line 1) (setq error-marker (point-marker)) ;; text-buffer gets the buffer containing this error's file. (if (not (equal filename last-filename)) (setq text-buffer (and (file-exists-p (setq last-filename filename)) (find-file-noselect filename)) last-linenum 0)) (if text-buffer ;; Go to that buffer and find the erring line. (save-excursion (set-buffer text-buffer) (if (zerop last-linenum) (progn (goto-char 1) (setq last-linenum 1))) (forward-line (- linenum last-linenum)) (setq last-linenum linenum) (setq text-marker (point-marker)) (setq perldb-error-list (cons (list error-marker text-marker) perldb-error-list))))) (forward-line 1))) (setq perldb-parsing-end (point-max))) (message "Parsing error messages...done") (setq perldb-error-list (nreverse perldb-error-list))) (defun perldb-grab-filename () "Return a string which is a filename, starting at point. Ignore quotes and parentheses around it, as well as trailing colons." (if (eq (following-char) ?\") (save-restriction (narrow-to-region (point) (progn (forward-sexp 1) (point))) (goto-char (point-min)) (read (current-buffer))) (buffer-substring (point) (progn (skip-chars-forward "^ ,\n\t(") (point))))) (provide 'perldb) ;;; perldb.el ends here