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

[JD Smith]

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 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.