;;; message-multiple-frames.el --- enable to use multiple message frames

;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007 Katsumi Yamaoka

;; Author: Katsumi Yamaoka <yamaoka@jpl.org>
;; Keywords: gnus, message, frame

;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 3, or (at your option)
;; any later version.

;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with this program; see the file COPYING.  If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth
;; Floor, Boston, MA 02110-1301, USA.

;;; Commentary:

;; For instance, install this file in the directory somewhere which is
;; listed in `load-path', put the following line in your ~/.gnus.el file:
;;
;;(require 'message-multiple-frames)
;;
;; and you will be able to use multiple message frames.  If you use
;; gnuclient to launch the message frame, set the `gnuserv-frame'
;; variable to t or use the "-batch" option to the gnuclient command.
;; Nothing special is needed for using emacsclient.

;;; Code:

(require 'gnus-win)
(require 'message)

(eval-when-compile
  (defvar gnus-delay-header)
  (defvar mml-preview-buffer))

;; 2007-10-15 add `frame-focus' to each message frame configuration.
(let* ((gnus '(progn
		(setq gnus-frame-list nil) ;; 2004-03-23
		(if (buffer-live-p gnus-summary-buffer)
		    (if (get-buffer gnus-article-buffer)
			(car (cdr (assq 'article gnus-buffer-configuration)))
		      (car (cdr (assq 'summary gnus-buffer-configuration))))
		  (car (cdr (assq 'group gnus-buffer-configuration))))))
       (config `(frame 1.0
		       ,gnus
		       (vertical
			((width . 80) (height . 40)
			 ;;(left . -1) (top . 1)
			 (user-position . t))
			(message 1.0 point frame-focus))))
       (settings '(forward mail-bounce message post reply reply-yank)))
  (while settings
    (gnus-add-configuration (list (car settings) config))
    (setq settings (cdr settings)))
  ;; Window layout for a gnus-bug frame.
  ;; Note that multiple gnus-bug frames are not supported.
  (gnus-add-configuration
   `(bug
     (frame 1.0
	    ,gnus
	    (vertical
	     ((width . 80) (height . 40)
	      ;;(left . -1) (top . 1)
	      (user-position . t))
	     (if gnus-bug-create-help-buffer '("*Gnus Help Bug*" 0.5))
	     ("*Gnus Bug*" 1.0 point frame-focus)))))
  ;; 2007-04-23
  ;; Window layout for a compose-bounce frame.
  ;; Note that multiple compose-bounce frames are not supported.
  (gnus-add-configuration
   `(compose-bounce
     (frame 1.0
	    ,gnus
	    (vertical
	     ((width . 80) (height . 40)
	      ;;(left . -1) (top . 1)
	      (user-position . t))
	     (article 0.5)
	     (message 1.0 point frame-focus)))))
  ;; 2005-02-08
  ;; Window layout for a mml-preview frame.
  (gnus-add-configuration
   '(mml-preview
     (frame 1.0
	    (progn
	      (setq gnus-frame-list nil) ;; 2005-04-19
	      '(vertical 1.0 (message 1.0)))
	    (vertical ((width . 80) (height . 40)
		       ;;(left . -1) (top . 1)
		       (user-position . t))
		      (mml-preview 1.0 point frame-focus))))))

(defvar message-delete-frame-anyway t
  "*Non-nil means frame deletion is done even if there are other windows.")

;; 2007-05-28
(defadvice message-pop-to-buffer (before pop-to-gnus-frame activate)
  "Make sure the Message frame or the Gnus frame exists and is selected."
  (let ((buffer (get-buffer (ad-get-arg 0)))
	window windows)
    (cond
     (;; Raise the frame visiting the Message buffer if any.
      (and buffer
	   (buffer-name buffer)
	   (setq window (get-buffer-window buffer t)))
      (gnus-select-frame-set-input-focus (window-frame window))
      (select-window window)
      ;; Make `gnus-configure-windows' run only `gnus-configure-windows-hook'
      ;; if this function is called through `gnus-setup-message'.
      (if (memq 'gnus-inews-insert-gcc message-header-setup-hook)
	  (defadvice gnus-configure-windows (around dont-config activate)
	    "Don't configure windows."
	    (ad-unadvise 'gnus-configure-windows)
	    (run-hooks 'gnus-configure-windows-hook))))
     (;; Do nothing with this advice.
      (or (memq major-mode '(gnus-group-mode
			     gnus-summary-mode
			     gnus-article-mode))
	  ;; 2006-06-15
	  (string-equal (buffer-name) "*Gnus Help Bug*")))
     (;; Raise the frame in which a Gnus buffer is already displayed.
      (save-excursion
	(walk-windows
	 (lambda (w)
	   (set-buffer (window-buffer w))
	   (cond ((eq major-mode 'gnus-summary-mode)
		  (push (cons 0 w) windows))
		 ((eq major-mode 'gnus-article-mode)
		  (push (cons 1 w) windows))
		 ((eq major-mode 'gnus-group-mode)
		  (push (cons 2 w) windows))))
	 'ignore-minibuf 'visible)
	windows)
      (gnus-select-frame-set-input-focus
       (window-frame (cdar (sort windows 'car-less-than-car)))))
     (;; Create the Message buffer and raise only its frame.
      t
      (eval
       `(defadvice gnus-configure-windows (around only-message activate)
	  "Raise only the Message frame."
	  (setq gnus-buffer-configuration
		',(mapcar
		   (lambda (elem)
		     (if (memq (car elem) '(bug
					    compose-bounce forward mail-bounce
					    message post reply reply-yank))
			 `(,(car elem)
			   (frame
			    1.0
			    (progn
			      (setq gnus-frame-list nil)
			      '(vertical 1.0 (,(buffer-name) 1.0)))
			    ,(append (butlast
				      (assq 'vertical (assq 'frame elem)))
				     (list (list (ad-get-arg 0) 1.0
						 'point 'frame-focus)))))
		       elem))
		   gnus-buffer-configuration))
	  (unwind-protect
	      ad-do-it
	    (ad-unadvise 'gnus-configure-windows)
	    (setq gnus-buffer-configuration
		  ',gnus-buffer-configuration)
	    ;; Make a dummy frame and delete it.
	    (delete-frame
	     ,(let ((frame (make-frame
			    (if (featurep 'xemacs)
				'(width 1 height 1 minibuffer nil modeline nil)
			      '((visibility . nil))))))
		(select-frame frame)
		frame)))))))))

(defun message-kill-buffer-and-frame ()
  "Kill the current message buffer and the dedicated frame."
  (interactive)
  (let ((actions
	 (cons
	  `(with-current-buffer ,(current-buffer)
	     (setq buffer-file-name nil)
	     (kill-buffer (current-buffer))
	     ,(if (or message-delete-frame-anyway
		      (eq (selected-window) (next-window)))
		  (list 'delete-frame (selected-frame))))
	  message-kill-actions))
	(draft-article message-draft-article)
	(auto-save-file-name buffer-auto-save-file-name)
	(file-name buffer-file-name)
	(modified (buffer-modified-p)))
    (with-temp-buffer
      (let ((message-kill-actions actions)
	    (message-draft-article draft-article)
	    (buffer-auto-save-file-name auto-save-file-name)
	    (buffer-file-name file-name))
	(set-buffer-modified-p modified)
	(message-kill-buffer)))))

(substitute-key-definition 'message-kill-buffer
			   'message-kill-buffer-and-frame
			   message-mode-map)

(add-hook
 'gnus-configure-windows-hook
 (lambda nil
   (cond
    ((eq major-mode 'message-mode)
     (let* ((frame (selected-frame))
	    (action
	     `(if (and (eq (selected-frame) ,frame)
		       (or message-delete-frame-anyway
			   (eq (selected-window) (next-window))))
		  (delete-frame ,frame))))
       (setq gnus-frame-list (delq frame gnus-frame-list))
       (setq message-exit-actions (cons action message-exit-actions))
       (setq message-postpone-actions
	     (cons action message-postpone-actions))
       ;; The following hook will be used when the buffer deletion
       ;; is invoked by `kill-buffer' or from the buffer menu.
       (gnus-make-local-hook 'kill-buffer-hook)
       (add-hook
	'kill-buffer-hook
	`(lambda nil
	   (let ((auto-save (and buffer-auto-save-file-name
				 (file-exists-p
				  buffer-auto-save-file-name)))
		 (actions message-exit-actions))
	     (when (and (or auto-save
			    (and buffer-file-name
				 (file-exists-p buffer-file-name)))
			(yes-or-no-p (concat "Remove the backup file"
					     (if (buffer-modified-p)
						 " too")
					     "? ")))
	       (when (and buffer-auto-save-file-name
			  (file-exists-p buffer-auto-save-file-name))
		 (condition-case nil
		     (delete-file buffer-auto-save-file-name)
		   (error)))
	       (message-disassociate-draft))
	     (message-do-actions actions))
	   (let* ((frame ,frame)
		  window)
	     (when (and (frame-live-p frame)
			(setq window
			      (get-buffer-window (current-buffer)
						 frame))
			(or message-delete-frame-anyway
			    (eq window (next-window window))))
	       (delete-frame frame))))
	t t)))
    ;; 2005-02-08
    ((and (boundp 'mml-preview-buffer)
	  (eq (current-buffer) mml-preview-buffer))
     (setq gnus-frame-list (delq (selected-frame) gnus-frame-list))
     (gnus-make-local-hook 'kill-buffer-hook)
     (add-hook 'kill-buffer-hook
	       `(lambda nil
		  (let ((frame ,(selected-frame))
			window)
		    (when (and (frame-live-p frame)
			       (setq window (get-buffer-window
					     ,mml-preview-buffer
					     frame))
			       (or message-delete-frame-anyway
				   (eq window (next-window window))))
		      (delete-frame frame))))
	       t t)))
   (set-window-start (selected-window) (point-min))
   ;; 2007-04-23
   (unless (pos-visible-in-window-p)
     ;; The case where `gnus-summary-resend-message-edit' is invoked.
     (recenter))))

;; Don't popup a message frame when sending a queued message.
(add-hook
 'gnus-message-setup-hook
 (lambda nil
   (if (or (memq this-command '(gnus-draft-send-message
				gnus-draft-send-all-messages
				gnus-group-send-queue))
	   (and (featurep 'gnus-delay)
		(save-excursion
		  (save-restriction
		    (widen)
		    (message-narrow-to-headers)
		    (re-search-forward
		     (concat "^" (regexp-quote gnus-delay-header)
			     ":\\s-+")
		     nil t)))))
       (let ((config (copy-sequence gnus-buffer-configuration)))
	 (set (make-local-variable 'gnus-buffer-configuration)
	      (cons '(forward (vertical 1.0 (message 1.0 point frame-focus)))
		    (delq (assq 'forward config) config)))
	 (set (make-local-variable 'gnus-configure-windows-hook)
	      nil)))))

(provide 'message-multiple-frames)

;;; message-multiple-frames.el ends here