path: root/emacs/tedstuff

Article 4417 of comp.lang.perl:
Path: jpl-devvax!elroy.jpl.nasa.gov!decwrl!mcnc!uvaarpa!mmdf
From: ted@evi.com (Ted Stefanik)
Newsgroups: comp.lang.perl
Subject: Correction to Perl fatal error marking in GNU Emacs
Message-ID: <1991Feb27.065853.15801@uvaarpa.Virginia.EDU>
Date: 27 Feb 91 06:58:53 GMT
Sender: mmdf@uvaarpa.Virginia.EDU (Uvaarpa Mail System)
Reply-To: ted@evi.com (Ted Stefanik)
Organization: The Internet
Lines: 282

Reading my own message, it occurred to me that I didn't quite satisfy the
request of stef@zweig.sun (Stephane Payrard):

| Does anyone has extended perdb/perdb.el to position the
| point to the first syntax error? It would be cool.

What I posted is a way to use the "M-x compile" command to test perl scripts.
(Needless to say, the script cannot be not interactive; you can't provide input
to a *compilation* buffer).  When creating new Perl programs, I use "M-x
compile" until I'm sure that they are syntatically correct; if syntax errors
occur, C-x` takes me to each in sequence.  After I'm sure the syntax is
correct, I start worrying about semantics, and switch to "M-x perldb" if
necessary.

Therefore, the stuff I posted works great with "M-x compile", but not at all
with "M-x perldb".

Next, let me update what I posted.  I found that perl's die() command doesn't
print the same format error message as perl does when it dies with a syntax
error.   If you put the following in your ".emacs" file, it causes C-x` to
recognize both kinds of errors:

(load-library "compile")
(setq compilation-error-regexp
  "\\([^ :\n]+\\(: *\\|, line \\|(\\)[0-9]+\\)\\|\\([0-9]+ *of *[^ \n]+\\|[^ \n]+ \\(at \\)*line [0-9]+\\)")

Last, so I don't look like a total fool, let me propose a way to satisfy
Stephane Payrard's original request (repeated again):

| Does anyone has extended perdb/perdb.el to position the
| point to the first syntax error? It would be cool.

I'm not satisfied with just the "first syntax error".  Perl's parser is better
than most about not getting out of sync; therefore, if it reports multiple
errors, you can usually be assured they are all real errors.

So... I hacked in the "next-error" function from "compile.el" to form
"perldb-next-error".  You can apply the patches at the end of this message
to add "perldb-next-error" to your "perldb.el".

Notes:
   1) The patch binds "perldb-next-error" to C-x~ (because ~ is the shift
      of ` on my keyboard, and C-x~ is not yet taken in my version of EMACS).

   2) "next-error" is meant to work on a single *compilation* buffer; any new
      "M-x compile" or "M-x grep" command will clear the old *compilation*
      buffer and reset the compilation-error parser to start at the top of the
      *compilation* buffer.

     "perldb-next-error", on the other hand, has to deal with multiple
      *perldb-<foo>* buffers, each of which keep growing.  "perldb-next-error"
      correctly handles the constantly growing *perldb-<foo>* buffers by
      keeping track of the last reported error in the "current-perldb-buffer".

      Sadly however, when you invoke a new "M-x perldb" on a different Perl
      script, "perldb-next-error" will start parsing the new *perldb-<bar>*
      buffer at the top (even if it was previously parsed), and will completely
      lose the marker of the last reported error in *perldb-<foo>*.

   3) "perldb-next-error" still uses "compilation-error-regexp" to find
      fatal errors.  Therefore, both the "M-x compile"/C-x` scheme and
      the "M-x perldb"/C-x~ scheme can be used to find fatal errors that
      match the common "compilation-error-regexp".  You *will* want to install
      that "compilation-error-regexp" stuff into your .emacs file.

   4) The patch was developed and tested with GNU Emacs 18.55.

   5) Since the patch was ripped off from compile.el, the code is (of
      course) subject to the GNU copyleft.

*** perldb.el.orig	Wed Feb 27 00:44:27 1991
--- perldb.el	Wed Feb 27 00:44:30 1991
***************
*** 199,205 ****
  
  (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.
--- 199,211 ----
  
  (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.
***************
*** 291,297 ****
  	   ;;  process-buffer is current-buffer
  	   (unwind-protect
  	       (progn
! 		 ;; Write something in *compilation* and hack its mode line,
  		 (set-buffer (process-buffer proc))
  		 ;; Force mode line redisplay soon
  		 (set-buffer-modified-p (buffer-modified-p))
--- 297,303 ----
  	   ;;  process-buffer is current-buffer
  	   (unwind-protect
  	       (progn
! 		 ;; Write something in *perldb-<foo>* and hack its mode line,
  		 (set-buffer (process-buffer proc))
  		 ;; Force mode line redisplay soon
  		 (set-buffer-modified-p (buffer-modified-p))
***************
*** 421,423 ****
--- 427,593 ----
      (switch-to-buffer-other-window current-perldb-buffer)
      (goto-char (dot-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-parsing-end nil
+   "Position of end of buffer when last error messages parsed.")
+ 
+ (defvar perldb-error-message "No more fatal Perl errors"
+   "Message to print when no more matches for compilation-error-regexp are found")
+ 
+ (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)))))
+ 
+ (define-key ctl-x-map "~" 'perldb-next-error)