Re: Display compilation buffer only if compilation failed

[Aurélien Aptel]

Ok, here's what I have so far.

I've added a hook to compilation-finish-function to display the buffer
and redefined compilation-start which is kind of ugly...
I've basically copy-pasted compilation-start and removed the
display-buffer call and everything dealing with the new window.

; called at end of compilation
(defun my-compile-switch (buf s)
  (when (not (string= s "finished\n"))
    (display-buffer buf)))

(add-to-list 'compilation-finish-functions 'my-compile-switch)

; kill current process yes-or-no-p => t (always kill process)
; commented display-buffer call & sexp using outwin var
(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)
         outwin outbuf)
    (with-current-buffer
        (setq outbuf
              (get-buffer-create
               (compilation-buffer-name name-of-mode mode name-function)))
      (let ((comp-proc (get-buffer-process (current-buffer))))
        (if comp-proc
            (if (or (not (eq (process-status comp-proc) 'run))
                    t)
                (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
      (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 (if (string-match "^\\s *cd\\(?:\\s +\\(\\S +?\\)\\)?\\s *[;&\n]" 
command)
                (if (match-end 1)
                    (substitute-env-vars (match-string 1 command))
                  "~")
              default-directory))
        (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 fone after (funcall mode) as that resets local variables
        (set (make-local-variable 'compilation-directory) thisdir)
        (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 default-directory)
                " -*-\n"
                (format "%s started at %s\n\n"
                        mode-name
                        (substring (current-time-string) 0 19))
                command "\n")
        (setq thisdir default-directory))
      (set-buffer-modified-p nil))
    ;; Pop up the compilation buffer.
    ;; http://lists.gnu.org/archive/html/emacs-devel/2007-11/msg01638.html
 ;   (setq outwin (display-buffer outbuf))
    (with-current-buffer outbuf
      (let ((process-environment
             (append
              compilation-environment
              (if (if (boundp 'system-uses-terminfo) ; `if' for compiler warning
                      system-uses-terminfo)
                  (list "TERM=dumb" "TERMCAP="
                        (format "COLUMNS=%d" (window-width)))
                (list "TERM=emacs"
                      (format "TERMCAP=emacs:co#%d:tc=unknown:"
                              (window-width))))
              ;; Set the EMACS variable, but
              ;; don't override users' setting of $EMACS.
              (unless (getenv "EMACS")
                (list "EMACS=t"))
              (list "INSIDE_EMACS=t")
              (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)
;       (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))))
;         (if (eq outwin (selected-window))
;             (goto-char desired-visible-point)
;           (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))
;       (compilation-set-window-height outwin)
        ;; Start the compilation.
        (if (fboundp 'start-process)
            (let ((proc
                   (if (eq mode t)
                       ;; comint uses `start-file-process'.
                       (get-buffer-process
                        (with-no-warnings
                          (comint-exec
                           outbuf (downcase mode-name)
                           (if (file-remote-p default-directory)
                               "/bin/sh"
                             shell-file-name)
                           nil `("-c" ,command))))
                     (start-file-process-shell-command (downcase mode-name)
                                                       outbuf command))))
              ;; Make the buffer's mode line show process state.
              (setq mode-line-process
                    (list (propertize ":%s" 'face 'compilation-warning)))
              (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)
              (setq compilation-in-progress
                    (cons proc compilation-in-progress)))
          ;; No asynchronous processes available.
          (message "Executing `%s'..." command)
          ;; Fake modeline display as if `start-process' were run.
          (setq mode-line-process
                (list (propertize ":run" 'face 'compilation-warning)))
          (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* ((buffer-read-only nil) ; call-process needs to modify outbuf
                   (status (call-process shell-file-name nil outbuf nil "-c"
                                         command)))
              (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)))))
          ;; Without async subprocesses, the buffer is not yet
          ;; fontified, so fontify it now.
          (let ((font-lock-verbose nil)) ; shut up font-lock messages
            (font-lock-fontify-buffer))
          (set-buffer-modified-p nil)
          (message "Executing `%s'...done" command)))
      ;; Now finally cd to where the shell started make/grep/...
      (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)))