bug#57883: compilation-get-file-structure mishandles buffers

[JD Smith <jdtsmith@gmail.com>]

[-- Attachment #1: Type: text/plain, Size: 14101 bytes --]

Thanks for the query.  This is still an issue in Emacs 29 with emacs -Q.  

Short summary: `compilation-error-regexp-alist’ explicitly allows returning *buffers* from a specified file-name function .  But parsing errors using such a buffer-returning function fails, since `compilation-get-file-structure’ explicitly assumes that a file name is returned, checking it with `file-name-absolute-p’.  In my code I’ve worked around this bug by cl-letf’ing the `file-name-absolute-p’ function like:

(defun my/traceback--file-name-absolute-p (file-or-buffer)
  "A patch for `file-name-absolute-p' to handle buffer names.
`compilation-get-file-structure' has a bug in which it calls
`file-name-absolute-p' on a file parsed from an error, which
explicitly allows FILE-OR-BUFFER to be a buffer."
  (and (not (bufferp file-or-buffer))
       (funcall #’my/traceback--orig-file-name-absolute-p file-or-buffer)))

Reproducer: The reproduction recipe was in the linked emacs-devel <https://lists.gnu.org/archive/html/emacs-devel/2022-02/msg00496.html> thread.  Here it is again (with Emacs 29 updates in [brackets]):

++++

Reproducing is fairly straightforward.  First, evaluate this simple “error line” pattern:

(defun my/filename-function () (list (get-buffer (match-string 1))))
(defvar my/compilation-error-regexp
  `((,(rx line-start 
	  "Buffer \"" (group (+ (not "\""))) "\", " ; 1: buffer name
	  "line" (+ space) (group (+ digit))	    ; 2: line
	  (* nonl) ?\n)
     my/filename-function
     2
     nil nil 1)))

Then, in a buffer like *compile* put the following fake error for it to match (including a final newline):

Buffer "*scratch*", line 2

In that buffer, evaluate (e.g. via M-:):

(progn (compilation-setup)
       (setq compilation-error-regexp-alist my/compilation-error-regexp)
       (compilation-parse-errors (point-min) (point-max)))

You should see error 1.) pertaining to searching the (nil) filename for /bin/sh (which may have been fixed in Emacs 28 already). [Emacs 29 update: it has]

[Update: This step is unnecessary in emacs 29] Now, let’s eliminate that error by evaluating (again in *compile*):

(setq compilation-transform-file-match-alist nil)

To stop the transform check.  Now evaluate again:

(compilation-parse-errors (point-min) (point-max))

and you will see a different error (2.) from `compilation-get-file-structure', which does not appreciate being handed a buffer instead of a file, despite the documented validity of this input:

Debugger entered--Lisp error: (wrong-type-argument stringp #<buffer *scratch*>)
  #<subr file-name-absolute-p>(#<buffer *scratch*>)
  apply(#<subr file-name-absolute-p> #<buffer *scratch*>)
  #f(compiled-function (body &rest args) #<bytecode 0x1a0bc3925a352795>)(#<subr file-name-absolute-p> #<buffer *scratch*>)
  apply(#f(compiled-function (body &rest args) #<bytecode 0x1a0bc3925a352795>) #<subr file-name-absolute-p> #<buffer *scratch*>)
  file-name-absolute-p(#<buffer *scratch*>)
  compilation-get-file-structure((#<buffer *scratch*>) nil)
  compilation-internal-error-properties((#<buffer *scratch*>) 2 nil nil nil 2 nil nil)
  compilation-error-properties(my/filename-function 2 nil nil nil 2 nil nil)
  (setq props (compilation-error-properties file line end-line col end-col (or type 2) fmt rule))
  (if (setq props (compilation-error-properties file line end-line col end-col (or type 2) fmt rule)) (progn (if file (progn (let ((this-type (if ... ... ...))) (compilation--note-type this-type) (compilation--put-prop file 'font-lock-face (symbol-value (aref ... this-type)))))) (compilation--put-prop line 'font-lock-face compilation-line-face) (compilation--put-prop end-line 'font-lock-face compilation-line-face) (compilation--put-prop col 'font-lock-face compilation-column-face) (compilation--put-prop end-col 'font-lock-face compilation-column-face) (let ((tail (nthcdr 6 item))) (while tail (let ((extra-item (car tail))) (let ((mn ...)) (if (match-beginning mn) (progn ...))) (setq tail (cdr tail))))) (let ((mn (or (nth 5 item) 0))) (if compilation-debug (progn (font-lock-append-text-property (match-beginning 0) (match-end 0) 'compilation-debug (vector 'std item props)))) (add-text-properties (match-beginning mn) (match-end mn) (cdr (cdr props))) (font-lock-append-text-property (match-beginning mn) (match-end mn) 'font-lock-face (car (cdr props))))))
  (while (and pat (re-search-forward pat end t)) (if (setq props (compilation-error-properties file line end-line col end-col (or type 2) fmt rule)) (progn (if file (progn (let ((this-type ...)) (compilation--note-type this-type) (compilation--put-prop file 'font-lock-face (symbol-value ...))))) (compilation--put-prop line 'font-lock-face compilation-line-face) (compilation--put-prop end-line 'font-lock-face compilation-line-face) (compilation--put-prop col 'font-lock-face compilation-column-face) (compilation--put-prop end-col 'font-lock-face compilation-column-face) (let ((tail (nthcdr 6 item))) (while tail (let ((extra-item ...)) (let (...) (if ... ...)) (setq tail (cdr tail))))) (let ((mn (or (nth 5 item) 0))) (if compilation-debug (progn (font-lock-append-text-property (match-beginning 0) (match-end 0) 'compilation-debug (vector ... item props)))) (add-text-properties (match-beginning mn) (match-end mn) (cdr (cdr props))) (font-lock-append-text-property (match-beginning mn) (match-end mn) 'font-lock-face (car (cdr props)))))))
  (let* ((item (if (symbolp rule-item) (cdr (assq rule-item compilation-error-regexp-alist-alist)) rule-item)) (pat (car item)) (file (nth 1 item)) (line (nth 2 item)) (col (nth 3 item)) (type (nth 4 item)) (rule (and (symbolp rule-item) rule-item)) end-line end-col fmt props) (cond ((or (not omake-included) (not pat)) nil) ((string-match "\\`\\([^^]\\|\\^\\( \\*\\|\\[\\)\\)" pat) nil) (t (setq pat (concat "^\\(?:      \\)?" (substring pat 1))))) (if (and (consp file) (not (functionp file))) (progn (setq fmt (cdr file)) (setq file (car file)))) (if (and (consp line) (not (functionp line))) (progn (setq end-line (cdr line)) (setq line (car line)))) (if (and (consp col) (not (functionp col))) (progn (setq end-col (cdr col)) (setq col (car col)))) (if (or (null (nth 5 item)) (integerp (nth 5 item))) nil (error "HYPERLINK should be an integer: %s" (nth 5 item))) (goto-char start) (while (and pat (re-search-forward pat end t)) (if (setq props (compilation-error-properties file line end-line col end-col (or type 2) fmt rule)) (progn (if file (progn (let (...) (compilation--note-type this-type) (compilation--put-prop file ... ...)))) (compilation--put-prop line 'font-lock-face compilation-line-face) (compilation--put-prop end-line 'font-lock-face compilation-line-face) (compilation--put-prop col 'font-lock-face compilation-column-face) (compilation--put-prop end-col 'font-lock-face compilation-column-face) (let ((tail (nthcdr 6 item))) (while tail (let (...) (let ... ...) (setq tail ...)))) (let ((mn (or ... 0))) (if compilation-debug (progn (font-lock-append-text-property ... ... ... ...))) (add-text-properties (match-beginning mn) (match-end mn) (cdr (cdr props))) (font-lock-append-text-property (match-beginning mn) (match-end mn) 'font-lock-face (car (cdr props))))))))
  (let ((rule-item (car tail))) (let* ((item (if (symbolp rule-item) (cdr (assq rule-item compilation-error-regexp-alist-alist)) rule-item)) (pat (car item)) (file (nth 1 item)) (line (nth 2 item)) (col (nth 3 item)) (type (nth 4 item)) (rule (and (symbolp rule-item) rule-item)) end-line end-col fmt props) (cond ((or (not omake-included) (not pat)) nil) ((string-match "\\`\\([^^]\\|\\^\\( \\*\\|\\[\\)\\)" pat) nil) (t (setq pat (concat "^\\(?:      \\)?" (substring pat 1))))) (if (and (consp file) (not (functionp file))) (progn (setq fmt (cdr file)) (setq file (car file)))) (if (and (consp line) (not (functionp line))) (progn (setq end-line (cdr line)) (setq line (car line)))) (if (and (consp col) (not (functionp col))) (progn (setq end-col (cdr col)) (setq col (car col)))) (if (or (null (nth 5 item)) (integerp (nth 5 item))) nil (error "HYPERLINK should be an integer: %s" (nth 5 item))) (goto-char start) (while (and pat (re-search-forward pat end t)) (if (setq props (compilation-error-properties file line end-line col end-col (or type 2) fmt rule)) (progn (if file (progn (let ... ... ...))) (compilation--put-prop line 'font-lock-face compilation-line-face) (compilation--put-prop end-line 'font-lock-face compilation-line-face) (compilation--put-prop col 'font-lock-face compilation-column-face) (compilation--put-prop end-col 'font-lock-face compilation-column-face) (let ((tail ...)) (while tail (let ... ... ...))) (let ((mn ...)) (if compilation-debug (progn ...)) (add-text-properties (match-beginning mn) (match-end mn) (cdr ...)) (font-lock-append-text-property (match-beginning mn) (match-end mn) 'font-lock-face (car ...))))))) (setq tail (cdr tail)))
  (while tail (let ((rule-item (car tail))) (let* ((item (if (symbolp rule-item) (cdr (assq rule-item compilation-error-regexp-alist-alist)) rule-item)) (pat (car item)) (file (nth 1 item)) (line (nth 2 item)) (col (nth 3 item)) (type (nth 4 item)) (rule (and (symbolp rule-item) rule-item)) end-line end-col fmt props) (cond ((or (not omake-included) (not pat)) nil) ((string-match "\\`\\([^^]\\|\\^\\( \\*\\|\\[\\)\\)" pat) nil) (t (setq pat (concat "^\\(?:      \\)?" (substring pat 1))))) (if (and (consp file) (not (functionp file))) (progn (setq fmt (cdr file)) (setq file (car file)))) (if (and (consp line) (not (functionp line))) (progn (setq end-line (cdr line)) (setq line (car line)))) (if (and (consp col) (not (functionp col))) (progn (setq end-col (cdr col)) (setq col (car col)))) (if (or (null (nth 5 item)) (integerp (nth 5 item))) nil (error "HYPERLINK should be an integer: %s" (nth 5 item))) (goto-char start) (while (and pat (re-search-forward pat end t)) (if (setq props (compilation-error-properties file line end-line col end-col (or type 2) fmt rule)) (progn (if file (progn ...)) (compilation--put-prop line 'font-lock-face compilation-line-face) (compilation--put-prop end-line 'font-lock-face compilation-line-face) (compilation--put-prop col 'font-lock-face compilation-column-face) (compilation--put-prop end-col 'font-lock-face compilation-column-face) (let (...) (while tail ...)) (let (...) (if compilation-debug ...) (add-text-properties ... ... ...) (font-lock-append-text-property ... ... ... ...)))))) (setq tail (cdr tail))))
  (let ((tail (or rules compilation-error-regexp-alist))) (while tail (let ((rule-item (car tail))) (let* ((item (if (symbolp rule-item) (cdr ...) rule-item)) (pat (car item)) (file (nth 1 item)) (line (nth 2 item)) (col (nth 3 item)) (type (nth 4 item)) (rule (and (symbolp rule-item) rule-item)) end-line end-col fmt props) (cond ((or (not omake-included) (not pat)) nil) ((string-match "\\`\\([^^]\\|\\^\\( \\*\\|\\[\\)\\)" pat) nil) (t (setq pat (concat "^\\(?:      \\)?" ...)))) (if (and (consp file) (not (functionp file))) (progn (setq fmt (cdr file)) (setq file (car file)))) (if (and (consp line) (not (functionp line))) (progn (setq end-line (cdr line)) (setq line (car line)))) (if (and (consp col) (not (functionp col))) (progn (setq end-col (cdr col)) (setq col (car col)))) (if (or (null (nth 5 item)) (integerp (nth 5 item))) nil (error "HYPERLINK should be an integer: %s" (nth 5 item))) (goto-char start) (while (and pat (re-search-forward pat end t)) (if (setq props (compilation-error-properties file line end-line col end-col ... fmt rule)) (progn (if file ...) (compilation--put-prop line ... compilation-line-face) (compilation--put-prop end-line ... compilation-line-face) (compilation--put-prop col ... compilation-column-face) (compilation--put-prop end-col ... compilation-column-face) (let ... ...) (let ... ... ... ...))))) (setq tail (cdr tail)))))
  (let ((case-fold-search compilation-error-case-fold-search) (omake-included (memq 'omake compilation-error-regexp-alist))) (let ((tail (or rules compilation-error-regexp-alist))) (while tail (let ((rule-item (car tail))) (let* ((item (if ... ... rule-item)) (pat (car item)) (file (nth 1 item)) (line (nth 2 item)) (col (nth 3 item)) (type (nth 4 item)) (rule (and ... rule-item)) end-line end-col fmt props) (cond ((or ... ...) nil) ((string-match "\\`\\([^^]\\|\\^\\( \\*\\|\\[\\)\\)" pat) nil) (t (setq pat ...))) (if (and (consp file) (not ...)) (progn (setq fmt ...) (setq file ...))) (if (and (consp line) (not ...)) (progn (setq end-line ...) (setq line ...))) (if (and (consp col) (not ...)) (progn (setq end-col ...) (setq col ...))) (if (or (null ...) (integerp ...)) nil (error "HYPERLINK should be an integer: %s" (nth 5 item))) (goto-char start) (while (and pat (re-search-forward pat end t)) (if (setq props ...) (progn ... ... ... ... ... ... ...)))) (setq tail (cdr tail))))))
  compilation-parse-errors(1 28)
  eval-expression((compilation-parse-errors (point-min) (point-max)) nil nil 127)
  funcall-interactively(eval-expression (compilation-parse-errors (point-min) (point-max)) nil nil 127)
  command-execute(eval-expression)

+++

> On Sep 3, 2023, at 5:18 AM, Stefan Kangas <stefankangas@gmail.com> wrote:
> 
> Lars Ingebrigtsen <larsi@gnus.org> writes:
> 
>> JD Smith <jdtsmith@gmail.com> writes:
>> 
>>> Note that this is useful for modes which report errors in text from open buffers, which
>>> may have no associated file.   The issue is this line in `compilation-get-file-structure’:
>>> 
>>> (if (file-name-absolute-p filename)
>>>   (setq filename (concat comint-file-name-prefix filename)))
>>> which signals an
>> 
>> This is how your email ended, so I think your message may have been cut
>> off?
>> 
>> In any case, do you have a recipe to reproduce the problem, starting
>> from "emacs -Q"?
> 
> More information was requested, but none was given within 12 months, so
> I'm closing this bug.
> 
> If this is still an issue, please reply to this email (use "Reply to
> all" in your email client) and we can reopen the bug report.


[-- Attachment #2: Type: text/html, Size: 18528 bytes --]