;;; Copyright (C) 1992 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/save-zones.el,v $
;;; $Date: 92/01/28 16:03:04 $
;;; $Author: love $
;;;
;;; save-zones.el - this package will enable zone information in a
;;;			buffer to be saved as it is written to file, then
;;;			restored when the buffer is again loaded.
;;;			Zone information is stored at the end of the buffer,
;;;			commented out appropriately according to the buffer's
;;;			major mode.  If the major mode does not support
;;;			comments, no information will be stored.
;;;			Zone information being saved includes the zone's
;;;			start and end positions, a tag for that zone's
;;;			style, and the zone's data field.  If the style tag
;;;			is non-nil, the function indicated by the
;;;			find-style-hook variable will be called with the
;;;			tag in order to determine the zone's style.  This
;;;			hook function should return a style object, or nil.
;;;			Transient zones in the buffer are ignored.
;;;
(require 'zone)
(provide 'save-zone)

(defun save-zones ()
  "Install hooks so zone information is saved and restored appropriately"
  (interactive)
  (or (memq 'save-zone-info write-file-hooks)
    (setq write-file-hooks (cons 'save-zone-info write-file-hooks))
  )
  (or (memq 'restore-zones find-file-hooks)
    (setq find-file-hooks (cons 'restore-zones find-file-hooks))
  )
)

(defvar find-style-hook 'find-style
  "Function called to find style corresponding to style hook."
)

;;
;; Possible definition for find-style-hook - assume that the style-tag
;; corresponds to symbol whose value is a style
(defun find-style (style-tag)
  "Find style according to TAG.  Assume that TAG is a symbol whose value is a style object."
  (if (stylep (symbol-value style-tag))
    (symbol-value style-tag)
    nil
  )
)

;;
;; Save zone list in this buffer.
(defun save-zone-info ()
  (let
    (( blist (zone-list))
    )
    (when (and comment-start blist)
      (purge-zone-info)		; clear zone info from buffer end
      (save-excursion
	(goto-char (point-max))
	(insert "\n" comment-start " *-* Zone Info Start *-*" comment-end)
	(dolist (b blist)
	  (let
	    (
	      (start (zone-start b))
	      (end (zone-end b))
	      (style (zone-style b))
	      (data (zone-data b))
	      style-tag
	    )
	    (when (not (zone-transient-p b))
	      (progn
		(when (stylep style) (setq style-tag (style-tag style)))
		(insert "\n" comment-start
		  (prin1-to-string (list start end style-tag data))
		  comment-end
	)))))
	(insert "\n" comment-start " *-* Zone Info End *-*" comment-end)
    ))
))

;;
;; Retore zones to current buffer based on zone information at
;; end of file.
(defun restore-zones ()
  (let
    (
      (start (concat "\n" comment-start " *-* Zone Info Start *-*" comment-end))
    )
    (when comment-start
      (save-excursion
	(goto-char (point-min))
	(if (search-forward start nil t)
	  (while (search-forward "(" nil t)
	    (let*
	      (
		zone-data
		start end style-tag data
		zone
	      )
	      (backward-char 1)
	      (setq zone-data (read (current-buffer)))
	      (when (listp zone-data)
		(progn
		  (setq zone (make-zone))
		  (setq start (nth 0 zone-data))
		  (setq end (nth 1 zone-data))
		  (setq style-tag (nth 2 zone-data))
		  (setq data (nth 3 zone-data))
		  (move-zone zone start end (current-buffer))
		  (set-zone-data zone data)
		  (if (and style-tag (functionp find-style-hook))
		    (set-zone-style zone (funcall find-style-hook style-tag))
	      )))
	    )
	  )
	)
      )
    )
  )
  (purge-zone-info t)
)

;;
;; Removed zone information from end of buffer.  If no-mod is t,
;; mark the buffer as unmodified.
(defun purge-zone-info (&optional no-mod)
  (let
    (
      (start (concat "\n" comment-start " *-* Zone Info Start *-*" comment-end))
      (finish (concat "\n" comment-start " *-* Zone Info End *-*" comment-end))
      beg end
    )
    (when comment-start
      (save-excursion
	(goto-char (point-min))
	(if (search-forward start nil t)
	  (progn
	    (beginning-of-line)
	    (setq beg (- (point) 1)
	    (if (search-forward finish nil t)
	      (progn
		(setq end (point))
		(delete-region beg end)
      )))))
      (if no-mod (set-buffer-modified-p nil))
    )
))