Problem with compilation-start resetting default-directory

[Alex Bennée]

Hi,

For a while I've been trying to track down an annoying bug where the
default-directory of my code/magit buffers was getting reset. Thanks to
the power of add-variable-watcher I've finally managed to track the
culprit down to compilation-start however I'm unsure what is going on.

I've instrumented compilation-start to illustrate the problem:

(defun compilation-start (command &optional mode name-function highlight-regexp)
  "Run compilation command COMMAND (low level interface).
If COMMAND starts with a cd command, that becomes the `default-directory'.
The rest of the arguments are optional; for them, nil means use the default.

MODE is the major mode to set in the compilation buffer.  Mode
may also be t meaning use `compilation-shell-minor-mode' under `comint-mode'.

If NAME-FUNCTION is non-nil, call it with one argument (the mode name)
to determine the buffer name.  Otherwise, the default is to
reuses the current buffer if it has the proper major mode,
else use or create a buffer with name based on the major mode.

If HIGHLIGHT-REGEXP is non-nil, `next-error' will temporarily highlight
the matching section of the visited source line; the default is to use the
global value of `compilation-highlight-regexp'.

Returns the compilation buffer created."
  (or mode (setq mode 'compilation-mode))
  (let* ((name-of-mode
          (if (eq mode t)
              "compilation"
            (replace-regexp-in-string "-mode\\'" "" (symbol-name mode))))
         (thisdir default-directory)
         (thisenv compilation-environment)
         outwin outbuf)
    (with-current-buffer
        (setq outbuf
              (get-buffer-create
               (compilation-buffer-name name-of-mode mode
                                        name-function)))
        (message "outbuf is %s" outbuf)
      (let ((comp-proc (get-buffer-process (current-buffer))))
      (if comp-proc
          (if (or (not (eq (process-status comp-proc) 'run))
                  (eq (process-query-on-exit-flag comp-proc) nil)
                  (yes-or-no-p
                   (format "A %s process is running; kill it? "
                           name-of-mode)))
              (condition-case ()
                  (progn
                    (interrupt-process comp-proc)
                    (sit-for 1)
                    (delete-process comp-proc))
                (error nil))
            (error "Cannot have two processes in `%s' at once"
                   (buffer-name)))))
      ;; first transfer directory from where M-x compile was called
      (message "set dd1 in %s" (current-buffer))
      (setq default-directory thisdir)
      ;; Make compilation buffer read-only.  The filter can still write it.
      ;; Clear out the compilation buffer.
      (let ((inhibit-read-only t)
            (default-directory thisdir))
        ;; Then evaluate a cd command if any, but don't perform it yet, else
        ;; start-command would do it again through the shell: (cd "..") AND
        ;; sh -c "cd ..; make"
        (cd (cond
             ((not (string-match "\\`\\s *cd\\(?:\\s +\\(\\S 
+?\\|'[^']*'\\|\"\\(?:[^\"`$\\]\\|\\\\.\\)*\"\\)\\)?\\s *[;&\n]"
                                 command))
              default-directory)
             ((not (match-end 1)) "~")
             ((eq (aref command (match-beginning 1)) ?\')
              (substring command (1+ (match-beginning 1))
                         (1- (match-end 1))))
             ((eq (aref command (match-beginning 1)) ?\")
              (replace-regexp-in-string
               "\\\\\\(.\\)" "\\1"
               (substring command (1+ (match-beginning 1))
                          (1- (match-end 1)))))
             ;; Try globbing as well (bug#15417).
             (t (let* ((substituted-dir
                        (substitute-env-vars (match-string 1 command)))
                       ;; FIXME: This also tries to expand `*' that were
                       ;; introduced by the envvar expansion!
                       (expanded-dir
                        (file-expand-wildcards substituted-dir)))
                  (if (= (length expanded-dir) 1)
                      (car expanded-dir)
                    substituted-dir)))))
        (erase-buffer)
        ;; Select the desired mode.
        (if (not (eq mode t))
            (progn
              (buffer-disable-undo)
              (funcall mode))
          (setq buffer-read-only nil)
          (with-no-warnings (comint-mode))
          (compilation-shell-minor-mode))
        ;; Remember the original dir, so we can use it when we recompile.
        ;; default-directory' can't be used reliably for that because it may be
        ;; affected by the special handling of "cd ...;".
        ;; NB: must be done after (funcall mode) as that resets local variables
        (set (make-local-variable 'compilation-directory) thisdir)
        (set (make-local-variable 'compilation-environment) thisenv)
        (if highlight-regexp
            (set (make-local-variable 'compilation-highlight-regexp)
                 highlight-regexp))
        (if (or compilation-auto-jump-to-first-error
                (eq compilation-scroll-output 'first-error))
            (set (make-local-variable 'compilation-auto-jump-to-next) t))
        ;; Output a mode setter, for saving and later reloading this buffer.
        (insert "-*- mode: " name-of-mode
                "; default-directory: "
                (prin1-to-string (abbreviate-file-name default-directory))
                " -*-\n"
                (format "%s started at %s\n\n"
                        mode-name
                        (substring (current-time-string) 0 19))
                command "\n")
        (message "set dd2 in %s" (current-buffer))
        (setq thisdir default-directory))
      (set-buffer-modified-p nil))
    ;; Pop up the compilation buffer.
    ;; https://lists.gnu.org/r/emacs-devel/2007-11/msg01638.html
    (setq outwin (display-buffer outbuf '(nil (allow-no-window . t))))
    (with-current-buffer outbuf
      (message "wcb @ %s" outbuf)
      (let ((process-environment
             (append
              compilation-environment
              (comint-term-environment)
              (list (format "INSIDE_EMACS=%s,compile" emacs-version))
              (copy-sequence process-environment))))
        (set (make-local-variable 'compilation-arguments)
             (list command mode name-function highlight-regexp))
        (set (make-local-variable 'revert-buffer-function)
             'compilation-revert-buffer)
        (and outwin
             ;; Forcing the window-start overrides the usual redisplay
             ;; feature of bringing point into view, so setting the
             ;; window-start to top of the buffer risks losing the
             ;; effect of moving point to EOB below, per
             ;; compilation-scroll-output, if the command is long
             ;; enough to push point outside of the window.  This
             ;; could happen, e.g., in `rgrep'.
             (not compilation-scroll-output)
             (set-window-start outwin (point-min)))

        ;; Position point as the user will see it.
        (let ((desired-visible-point
               ;; Put it at the end if `compilation-scroll-output' is set.
               (if compilation-scroll-output
                   (point-max)
                 ;; Normally put it at the top.
                 (point-min))))
          (goto-char desired-visible-point)
          (when (and outwin (not (eq outwin (selected-window))))
            (set-window-point outwin desired-visible-point)))

        ;; The setup function is called before compilation-set-window-height
        ;; so it can set the compilation-window-height buffer locally.
        (if compilation-process-setup-function
            (funcall compilation-process-setup-function))
        (and outwin (compilation-set-window-height outwin))
        ;; Start the compilation.
        (if (fboundp 'make-process)
            (let ((proc
                   (if (eq mode t)
                       ;; On remote hosts, the local `shell-file-name'
                       ;; might be useless.
                       (with-connection-local-variables
                        ;; comint uses `start-file-process'.
                        (get-buffer-process
                         (with-no-warnings
                           (comint-exec
                            outbuf (downcase mode-name)
                            shell-file-name
                            nil `(,shell-command-switch ,command)))))
                     (start-file-process-shell-command (downcase mode-name)
                                                       outbuf command))))
              ;; Make the buffer's mode line show process state.
              (setq mode-line-process
                    '((:propertize ":%s" face compilation-mode-line-run)
                      compilation-mode-line-errors))

              ;; Set the process as killable without query by default.
              ;; This allows us to start a new compilation without
              ;; getting prompted.
              (when compilation-always-kill
                (set-process-query-on-exit-flag proc nil))

              (set-process-sentinel proc #'compilation-sentinel)
              (unless (eq mode t)
                ;; Keep the comint filter, since it's needed for proper
                ;; handling of the prompts.
                (set-process-filter proc #'compilation-filter))
              ;; Use (point-max) here so that output comes in
              ;; after the initial text,
              ;; regardless of where the user sees point.
              (set-marker (process-mark proc) (point-max) outbuf)
              (when compilation-disable-input
                (condition-case nil
                    (process-send-eof proc)
                  ;; The process may have exited already.
                  (error nil)))
              (run-hook-with-args 'compilation-start-hook proc)
              (compilation--update-in-progress-mode-line)
              (push proc compilation-in-progress))
          ;; No asynchronous processes available.
          (message "Executing `%s'..." command)
          ;; Fake mode line display as if `start-process' were run.
          (setq mode-line-process
                '((:propertize ":run" face compilation-mode-line-run)
                  compilation-mode-line-errors))
          (force-mode-line-update)
          (sit-for 0)                   ; Force redisplay
          (save-excursion
            ;; Insert the output at the end, after the initial text,
            ;; regardless of where the user sees point.
            (goto-char (point-max))
            (let* ((inhibit-read-only t) ; call-process needs to modify outbuf
                   (compilation-filter-start (point))
                   (status (call-process shell-file-name nil outbuf nil "-c"
                                         command)))
              (run-hooks 'compilation-filter-hook)
              (cond ((numberp status)
                     (compilation-handle-exit
                      'exit status
                      (if (zerop status)
                          "finished\n"
                        (format "exited abnormally with code %d\n" status))))
                    ((stringp status)
                     (compilation-handle-exit 'signal status
                                              (concat status "\n")))
                    (t
                     (compilation-handle-exit 'bizarre status status)))))
          (set-buffer-modified-p nil)
          (message "Executing `%s'...done" command)))
      ;; Now finally cd to where the shell started make/grep/...
      (message "set dd3 to %s in %s" thisdir (current-buffer))
      (setq default-directory thisdir)
      ;; The following form selected outwin ever since revision 1.183,
      ;; so possibly messing up point in some other window (bug#1073).
      ;; Moved into the scope of with-current-buffer, though still with
      ;; complete disregard for the case when compilation-scroll-output
      ;; equals 'first-error (martin 2008-10-04).
      (when compilation-scroll-output
        (goto-char (point-max))))

    ;; Make it so the next C-x ` will use this buffer.
    (setq next-error-last-buffer outbuf)))

And an example output is:

  outbuf is *compilation*
  set dd1 in *compilation*
  set dd2 in *compilation*
  wcb @ *compilation*
  set dd3 to /home/alex/lsrc/qemu.git/builds/all/ in backtrace.el.gz

This is confusing as the final setq default-directory is wrapped inside
a with-current-buffer form which is correct at according to the log. Any
ideas what could be happening? I guess there is nothing to stop
something inside the form changing the current active buffer?

Any tips on how to track this down would be appreciated.

Currently running Emacs HEAD @ 0415ad210c8c99e771b6273b6f683fe3f3614c6f
but this problem has been occurring for a while.

--
Alex Bennée