;;; 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.1 $
;;; $Source: /import/kaplan/stable/distrib/epoch-4.2/epoch-lisp/RCS/property.el,v $
;;; $Date: 91/04/26 10:03:34 $
;;; $Author: love $
;;;
;;; property.el - property event code
;;;
(require 'mini-cl)
(require 'epoch-util)
(require 'event)
(provide 'property)
;;; --------------------------------------------------------------------------
;;;
(defvar property::functions nil "List of property/handler")
(setq epoch::lazy-events t)	;get atoms back for the properties
;;; --------------------------------------------------------------------------
;;; this macro forces a string or resource to be an X atom resource. It
;;; signals an error on a bad argument. If the argument is a symbol, then
;;; it is set to the atom (so you can use this as a conversion function or
;;; a modifying macro).
;;; BUGS: If the argument is a resource but not an atom, it is accepted.
(defmacro atomize (property)
  (let
    (
      ;; can't be "property" - causes compiled version to fail
      (p (make-symbol "PrOpErTy"))
    )
    (`
      (let ( ( (, p) (, property) ) )
	(cond
	  ((resourcep (, p)) (, p) )	;nothing, it's ok
	  ((stringp (, p))
	    (if (symbolp (quote (, property)))
	      (setq (, property) (intern-atom (, p) ))
	      (intern-atom (, p))
	    )
	  )
	  (t (error "Invalid property argument"))
	)
      )
    )
  )
)
;;; --------------------------------------------------------------------------
;;;
(defun install-property (property)
  (atomize property)
  (if (null (assoc property property::functions))
    (push (cons property nil) property::functions)
  )
)
;;;
(defun remove-property (property)
  (atomize property)
  (setq property::functions (alist-delete property property::functions))
)
;;; --------------------------------------------------------------------------
;;; Unlike the event handlers, these will create the property event if it
;;; doesn't exist, since unlike events there are not a limited number of
;;; them.
;;;
(defun push-property (property handler)
  (atomize property)
  (let
    (
      (elist (assoc property property::functions))
    )
    (if (consp elist)
      (setcdr elist (cons handler (cdr elist)))
      (push (list property handler) property::functions)
    )
  )
)
;;;
(defun pop-property (property)
  (atomize property)
  (let
    (
      (elist (assoc property property::functions))
    )
    (when (consp elist)
      (prog1
	(cadr elist)
	(setcdr elist (cddr elist))
      )
    )
  )
)
;;;
(defun ignore-property (property)
  (atomize property)
  (push-property property t)	;install a non-function
)
;;;
(defun resume-property (property)
  (atomize property)
  (let
    (
      (h (pop-property property))
    )
    (when (and h (functionp h))		;not an ignore! put it back
      (push-property property h)
    )
  )
)
;;; --------------------------------------------------------------------------
(defun property::handler (type value scr)
  (when (not (resourcep value))
    (setq epoch::lazy-events t)
    (message "Missed property event %s" (car value))
  )
  (let
    (
      (property::atom value)		;save it
      (property::event-handler epoch::event-handler) ;save this too
      (callback (cadr (assoc value property::functions)))
    )
    (when (functionp callback)
      (unwind-protect
	;; BODY
	(funcall callback type property::atom scr)
	;; CLEAN-UP
	(when (null epoch::event-handler) ;something got hosed
	  (ignore-property property::atom)	;inhibit the handler
	  (setq epoch::event-handler property::event-handler)
	)
      )
    )
  )
)
;;; --------------------------------------------------------------------------
(push-event 'property-change 'property::handler)
;;; --------------------------------------------------------------------------
;;; Some standard property handlers
;;; set epoch-setup-hook to run property::init() at runtime
;;;
(epoch-add-setup-hook 'property::init)
(defun property::init()
  (push-property "EPOCH_EXECUTE"
  (function
    (lambda (type prop screen)
      (let
	(
	  (cw (selected-window))
	  (action (get-property prop screen))
	)
	(unwind-protect
	  (progn
	    (select-window (epoch::selected-window screen))
	    (and (stringp action) (eval (read action)))
	  )
	  (select-window cw)
	)
      )
    )
)))