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

;; Copyright (C) 2002-2007, 2015, 2016, 2023 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 of the License, 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.  If not, see <http://www.gnu.org/licenses/>.

;;; 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 . 32)
			 ;;(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 . 32)
	      ;;(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 . 32)
	      ;;(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 . 32)
		       ;;(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.")

;; 2015-10-02
(advice-add
 'gnus-configure-windows :around
 ;; Always run `gnus-configure-windows-hook' at the end.
 ;; The original function doesn't necessarily run the hook at least for
 ;; `mml-preview', it voids adding a thing to `kill-buffer-hook' locally.
 (lambda (oldfun &rest args)
   (let ((gnus-configure-windows-hook nil))
     (apply oldfun args))
   (run-hooks 'gnus-configure-windows-hook))
 '((name . always-run-hook)))

;; 2007-05-28
(advice-add
 'message-pop-to-buffer :before
 ;; Make sure the Message frame or the Gnus frame exists and is selected.
 (lambda (&rest args)
   (let ((buffer (get-buffer (car args)))
	 window windows)
     (cond
      (;; Raise the frame visiting the Message buffer if any.
       (and buffer
	    (buffer-name buffer)
	    (setq window (get-buffer-window buffer t)))
       ;; 2016-09-30
       (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)
	   (advice-add
	    'gnus-configure-windows :override
	    ;; Don't configure windows.
	    (lambda (&rest _)
	      (advice-remove 'gnus-configure-windows	;; 2015-10-02
			     'dont-config)
	      (run-hooks 'gnus-configure-windows-hook))
	    '((name . dont-config)))))
      (;; 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)
       ;; 2016-09-30
       (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
	`(advice-add
	  'gnus-configure-windows :around
	  ;; Raise only the Message frame.
	  (lambda (oldfun &rest args)
	    (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 (car args) 1.0
						   'point 'frame-focus)))))
			 elem))
		     gnus-buffer-configuration))
	    (unwind-protect
		(apply oldfun args)
	      (advice-remove 'gnus-configure-windows	;; 2015-10-02
			     'pop-to-gnus-frame)
	      (setq gnus-buffer-configuration ',gnus-buffer-configuration)
	      ;; Make a dummy frame and delete it.
	      (delete-frame
	       ,(let ((frame (make-frame '((visibility . nil)))))
		  (select-frame frame)
		  frame))))))))))
 '((name . pop-to-gnus-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
   ;; 2015-10-02  Make sure we are in the target buffer.
   (set-buffer (window-buffer (selected-window)))
   (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.

       ;; 2016-09-30
       ;;(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))
     ;; 2016-09-30
     ;;(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
