;;; Copyright (C) 1991 Christopher J. Love
;;;
;;; 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.6 $
;;; $Source: /import/kaplan/stable/distrib/epoch-4.2/epoch-lisp/RCS/event.el,v $
;;; $Date: 92/08/01 22:34:39 $
;;; $Author: marca $
;;;
;;; event.el - provide general event handling.  Originally written by
;;;	       Susan Hinrich, modified by Alan Carroll and Chris Love
;;;

;; Changed from mini-cl (due to mdb@NSD.3Com.COM).
(require 'cl)

(require 'epoch-util)
(provide 'event)
;;;
;;; New event handler code
;;;
;;; --------------------------------------------------------------------------
;;;
(defvar event::functions nil "List of event/handler")
(setq epoch::event-handler-abort t)	;we'll do the clean up, so abort
					;on bogus handlers
;;; --------------------------------------------------------------------------
;;;
(defun install-event (event)
  (if (null (assq event event::functions))
    (push (cons event nil) event::functions)
  )
)
;;;
(defun remove-event (event)
  (setq event::functions (alist-delete event event::functions))
)
;;; --------------------------------------------------------------------------
;;;
(defun push-event (event handler)
  (let
    (
      (elist (assq event event::functions))
    )
    (when (consp elist)
      (setcdr elist (cons handler (cdr elist)))
    )
  )
)
;;;
(defun pop-event (event)
  (let
    (
      (elist (assq event event::functions))
    )
    (when (consp elist)
      (prog1
	(cadr elist)
	(setcdr elist (cddr elist))
      )
    )
  )
)
;;;
(defun ignore-event (event)
  (push-event event t)	;install a non-function
)
;;;
(defun resume-event (event)
  (let
    (
      (h (pop-event event))
    )
    (when (and h (functionp h))		;not an ignore! put it back
      (push-event event h)
    )
  )
)
;;; --------------------------------------------------------------------------
(defun event::handler ()
  (let*
    (
      (event::type (aref epoch::event 0))
      (event::screen (aref epoch::event 2))
      (event::value (aref epoch::event 1))
      (callback (cadr (assq event::type event::functions)))
    )
    (when (and callback (functionp callback))
      (unwind-protect
	;; BODY
	(funcall callback event::type event::value event::screen)
	;; CLEAN-UP
	(when (null epoch::event-handler) ;something got hosed
	  (setq epoch::event-handler 'event::handler) ;reinstall me
	  (ignore-event event::type)	;inhibit the handler
	)
      )
    )
  )
  (setq *last-event* epoch::event)
)
;;;
(setq epoch::event-handler 'event::handler)
;;;
;;; --------------------------------------------------------------------------
(defvar *event-status-buffer* nil "Buffer for displaying event status")
;;;
(defun event-handler-name (event-stack)
  (let ( (depth 0) )
    (while (and event-stack (not (functionp (car event-stack))))
      (setq event-stack (cdr event-stack))
      (incf depth)
    )
    (let ( (handler (car event-stack)) )
      (cons
	(cond
	  ((null handler) "-None-")
	  ((symbolp handler) (symbol-name handler))
	  ((listp handler) "+Anonymous+")
	  (t "? Unknown ?")
	)
	depth
      )
    )
  )
)
;;;
(defun update-event-status-buffer ()
  (when
    (or
      (null *event-status-buffer*)
      (null (buffer-name *event-status-buffer*))
    )
    (setq *event-status-buffer* (get-buffer-create " *Event Status*"))
  )
  (save-excursion
    (set-buffer *event-status-buffer*)
    (setq buffer-read-only nil)
    (erase-buffer)
    (epoch::clear-zones)
    (insert "State  " (flush-left "Event" 20) "Handler\n")
    (epoch::add-zone 1 6 motion::style)
    (epoch::add-zone 8 14 motion::style)
    (epoch::add-zone 28 35 motion::style)
    ;;
    (dolist (ev event::functions)
      (let
	(
	  (handler (cadr ev))
	  state
	  (depth (length (cdr ev)))
	  (handler-state (event-handler-name (cdr ev)))
	)
	(cond
	  ((null (cdr ev))  (setq state "U"))
	  ((functionp handler)
	    (setq state (if (< depth 2) "H" (format "H %2d" depth) ) )
	  )
	  (t
	    (setq state
	      (if (< (cdr handler-state) 2)
		"I"
		(format "I %2d" (cdr handler-state))
	      )
	    )
	  )
	)
	(insert
	  (flush-left state 7)
	  (flush-left (symbol-name (car ev)) 20)
	  (car handler-state)
	  "\n"
	)
      )
    )
    (insert
      "\nEvent dispatcher: " (prin1-to-string epoch::event-handler) "\n"
    )
    (set-buffer-modified-p nil)
    (setq buffer-read-only t)
  )
)
;;;
(defun display-event-status ()
  (interactive)
  (update-event-status-buffer)
  (display-buffer *event-status-buffer*)
)
;;; --------------------------------------------------------------------------
;;; install now so 
(install-event 'map)
(install-event 'resize)
(install-event 'move)
(install-event 'client-message)
(install-event 'focus)
(install-event 'property-change)
(install-event 'button)
(install-event 'motion)

;;; --------------------------------------------------------------------------
;;; Handler that maintains on-event-do lists
(defvar on-event::do-list (list '(map) '(unmap) '(move) '(resize))
"Alist of event, screen/action lists"
)
;;;
(defun on-event::handler (type value screen)
"Handle events that have one-shot actions. Types are controlled by the
variable on-event::do-list, which is an alist of event types, with the
value an alist of screens and actions."
  (if (and (eq 'map type) (not value)) (setq type 'unmap))
  (let*
    (
      (epoch::event-handler-abort nil)	;no aborting!
      (the-list (assq type on-event::do-list))
      (info (assq screen (cdr the-list)))
      (action (cdr info))
    )
    (when info
      (setcdr the-list (alist-delete screen (cdr the-list)))
      (when (functionp action)
	(cond
	  ((or (eq type 'map) (eq type 'unmap))
	    (funcall action screen)
	  )
	  (t (funcall action screen value))
	)
      )
    )
  )
)
;; Install on-event handlers for move, map, resize
(push-event 'map 'on-event::handler)
(push-event 'move 'on-event::handler)
(push-event 'resize 'on-event::handler)
;; Handle focus events
(push-event 'focus
  (function
    (lambda (type new-focus-state scr)
      (and new-focus-state (select-screen scr))
    )
  )
)
;;;
(defun on-map-do (screen action)
"On the next map event for SCREEN, call ACTION (a function of 1 argument,
the screen)"
  (let ( (mlist (assq 'map on-event::do-list)) )
    (push (cons (get-screen screen) action) (cdr mlist))
  )
)
(defun on-unmap-do (screen action)
"On the next unmap event for SCREEN, call ACTION (a function of 1 argument,
the screen)"
  (let ( (mlist (assq 'unmap on-event::do-list)) )
    (push (cons (get-screen screen) action) (cdr mlist))
  )
)
;;;
(defun on-resize-do (screen action)
"On the next resize event for SCREEN, call ACTION (a function of 2 arguments,
screen and event value)"
  (let ( (rlist (assq 'resize on-event::do-list)) )
    (push (cons (get-screen screen) action) (cdr rlist))
  )
)
;;;
(defun on-move-do (screen action)
"On the next move event for SCREEN, call ACTION (a function of 2 arguments,
screen and event value)"
  (let ( (mlist (assq 'move on-event::do-list)) )
    (push (cons (get-screen screen) action) (cdr mlist))
  )
)
;;;
;;; --------------------------------------------------------------------------
;;; Following code provides the 'wait-for-event' functionality:
(defvar epoch::events-pending nil
  "List of events pending while waiting for some specific event"
)
(defvar epoch::wait-event nil
  "Event type epoch is waiting for"
)
(defvar epoch::wait-function nil
  "Function to call when desired event occurs"
)
(defvar epoch::old-handler nil
  "Original event handler"
)

;;
;; epoch::dispatch-events-pending - while waiting for specific events, all
;;				other events are stashed in an elisp queue;
;;				deal with them now.
;;
(defun epoch::dispatch-events-pending ()
  (dolist (s epoch::events-pending)
    (let*
      (
	(event::type (aref epoch::event 0))
	(event::screen (aref epoch::event 2))
	(event::value (aref epoch::event 1))
	(callback (cadr (assq event::type event::functions)))
      )
      (when (and callback (functionp callback))
	(unwind-protect
	  (funcall callback event::type event::value event::screen)
	  (when (null epoch::event-handler)
	    (setq epoch::event-handler 'event::handler)
	    (ignore-event event::type)
	  )
	)
      )
    )
  )
  (setq epoch::events-pending nil)
  (setq epoch::wait-event nil)
)

;;
;; epoch::wait-handler - special event-handler which will wait for specified
;;			 event, stashing all other events till later.
;;
(defun epoch::wait-handler ()
  (let*
    (
      (event::type (aref epoch::event 0))
      (event::screen (aref epoch::event 2))
      (event::value (aref epoch::event 1))
    )
    (if (eq event::type epoch::wait-event)
      ;; it happend!  Call desired function, and do cleanup.
      (unwind-protect
	(if (functionp epoch::wait-function)
	  (funcall epoch::wait-function event::type event::value event::screen)
	)
	(setq epoch::wait-event nil)
	(epoch::dispatch-events-pending)
      )
      ;; it didn't happen yet, so stash this event for later
      (setq epoch::events-pending
	(reverse (cons epoch::event epoch::events-pending))
      )
    )
  )
)

;;
;; epoch::wait-for-event - given an epoch event-type and a function/handler
;;			   for that event (or nil), wait until specified
;;			   event happens.  Then call specified handler, and
;;			   return.
;;
(defun epoch::wait-for-event (event-type function)
  "Wait for EVENT, calling FUNCTION as handler when it occurs, then return."
  (setq epoch::old-handler epoch::event-handler) 	; save old handler
  (setq epoch::wait-event event-type)
  (setq epoch::wait-function function)
  (setq epoch::event-handler 'epoch::wait-handler)
  (while epoch::wait-event
    (epoch::dispatch-events)
    (sit-for 1)
  )
  (setq epoch::event-handler epoch::old-handler)
)