;;; Copyright (C) 1991 Alan Carroll
;;;
;;; This file is for use with Epoch, a modified version of GNU Emacs.
;;; Requires Epoch 4.0 or later.
;;;
;;; This code is distributed in the hope that it will be useful,
;;; bute WITHOUT ANY WARRANTY. No author or distributor accepts
;;; responsibility to anyone for the consequences of using this code
;;; or for whether it serves any particular purpose or works at all,
;;; unless explicitly stated in a written agreement.
;;;
;;; Everyone is granted permission to copy, modify and redistribute
;;; this code, but only under the conditions described in the
;;; GNU Emacs General Public License, except the original author nor his
;;; agents are bound by the License in their use of this code.
;;; (These special rights for the author in no way restrict the rights of
;;;  others given in the License or this prologue)
;;; A copy of this license is supposed to have been given to you along
;;; with Epoch so you can know your rights and responsibilities. 
;;; It should be in a file named COPYING.  Among other things, the
;;; copyright notice and this notice must be preserved on all copies. 
;;;
;;; $Revision: 1.2 $
;;; $Source: /import/kaplan/stable/distrib/epoch-4.2/epoch-lisp/RCS/message.el,v $
;;; $Date: 91/05/07 23:13:47 $
;;; $Author: love $
;;;
(require 'mini-cl)
(require 'epoch-util)
(require 'property)
(provide 'message)
;;;
;;; --------------------------------------------------------------------------
(defvar message::functions nil "List of message/handler")
;;; --------------------------------------------------------------------------
;;;
(defun install-message (message)
  (atomize message)
  (if (null (assoc message message::functions))
    (push (cons message nil) message::functions)
  )
)
;;;
(defun remove-message (message)
  (atomize message)
  (setq message::functions (alist-delete message message::functions))
)
;;; --------------------------------------------------------------------------
;;; Unlike the event handlers, these will create the message event if it
;;; doesn't exist, since unlike events there are not a limited number of
;;; them.
;;;
(defun push-message (message handler)
  (atomize message)
  (let
    (
      (elist (assoc message message::functions))
    )
    (if (consp elist)
      (setcdr elist (cons handler (cdr elist)))
      (push (list message handler) message::functions)
    )
  )
)
;;;
(defun pop-message (message)
  (atomize message)
  (let
    (
      (elist (assoc message message::functions))
    )
    (when (consp elist)
      (prog1
	(cadr elist)
	(setcdr elist (cddr elist))
      )
    )
  )
)
;;;
(defun ignore-message (message)
  (atomize message)
  (push-message message t)	;install a non-function
)
;;;
(defun resume-message (message)
  (atomize message)
  (let
    (
      (h (pop-message message))
    )
    (when (and h (functionp h))		;not an ignore! put it back
      (push-message message h)
    )
  )
)
;;; --------------------------------------------------------------------------
(defun message::handler (type value scr)
  (let*
    (
      (message::atom (car value))		;save it
      (message::event-handler epoch::event-handler) ;save this too
      (callback (cadr (assoc message::atom message::functions)))
    )
    (when (functionp callback)
      (unwind-protect
	;; BODY
	(funcall callback type value scr)
	;; CLEAN-UP
	(when (null epoch::event-handler) ;something got hosed
	  (ignore-message message::atom)	;inhibit the handler
	  (setq epoch::event-handler message::event-handler)
	)
      )
    )
  )
)
;;; --------------------------------------------------------------------------
(push-event 'client-message 'message::handler)
;;; --------------------------------------------------------------------------
;;; These protocal/message related things will be setup at runtime when
;;; message::init is run.  Right now, just declare them.

(defvar xa-wm-delete-window '())
(defvar xa-wm-protocols '())
(defvar wm-protocol-list '() "List of protocol atoms that epoch recognizes")

(defun handle-wm-protocols (type value screen)
  (let
    (
      (type (cddr value))
      (epoch::event-handler-abort nil)
    )
    (if (listp type) (setq type (car type)))
    (cond
      ((equal type xa-wm-delete-window)
	(if (equal (minibuf-screen) screen)
	  (funcall (global-key-binding "\C-x\C-c"))
	  (delete-screen screen)
	)
      )
    )
  )
)

;;;
;;; set epoch-setup-hook to run message::init()
;;;
(epoch-add-setup-hook 'message::init)
(defun message::init()
  (setq xa-wm-delete-window (epoch::intern-atom "WM_DELETE_WINDOW"))
  (setq xa-wm-protocols (epoch::intern-atom "WM_PROTOCOLS"))
  (setq wm-protocol-list (list xa-wm-delete-window))
  ;; set up handler
  (push-message xa-wm-protocols 'handle-wm-protocols)
  ;; fix up all screens
  (dolist (s (screen-list t))
   (set-property xa-wm-protocols wm-protocol-list s)
    (when (screen-mapped-p s)
      (on-unmap-do s 'map-screen)
      (unmap-screen s)
    )
  )
  ;; set the minibuffer to have right protocols
;  (set-property xa-wm-protocols wm-protocol-list (minibuf-screen))
;  (when (screen-mapped-p (minibuf-screen))
;    (on-unmap-do 0 'map-screen)
;    (map-screen 0)		;try for an immediate mapping
;  )
)