;;!emacs
;;
;; FILE:         hbdata.el
;; SUMMARY:      Hyperbole button attribute accessor methods.
;; USAGE:        GNU Emacs Lisp Library
;;
;; AUTHOR:       Bob Weiner
;; ORG:          Brown U.
;;
;; ORIG-DATE:     2-Apr-91
;; LAST-MOD:     13-Dec-91 at 14:45:02 by Bob Weiner
;;
;; This file is part of Hyperbole.
;; 
;; Copyright (C) 1991, Brown University, Providence, RI
;; Developed with support from Motorola Inc.
;; 
;; Permission to use, modify and redistribute this software and its
;; documentation for any purpose other than its incorporation into a
;; commercial product is hereby granted without fee.  A distribution fee
;; may be charged with any redistribution.  Any distribution requires
;; that the above copyright notice appear in all copies, that both that
;; copyright notice and this permission notice appear in supporting
;; documentation, and that neither the name of Brown University nor the
;; author's name be used in advertising or publicity pertaining to
;; distribution of the software without specific, written prior permission.
;; 
;; Brown University makes no representations about the suitability of this
;; software for any purpose.  It is provided "as is" without express or
;; implied warranty.
;;
;;
;; DESCRIPTION:  
;;
;;  This module handles Hyperbole button data/attribute storage.  In general,
;;  it should not be extended by anyone other Hyperbole developers.  If you
;;  alter the formats or accessors herein, you are likely to make your buttons
;;  incompatible with future releases.  System developers should instead work
;;  with and extend the hbut.el module which provides much of the Hyperbole
;;  application programming interface and which hides the low level details
;;  handled by this module.
;;
;;
;;  Here is an example Hyperbole V2 button data format.  It is a list of
;;  fields:
;;
;;    
;;    "TO-DO"
;;    (Key            Placehoders  LinkType      <arg-list>             creator and modifier with times)
;;    ("alt.mouse.el" nil nil      link-to-file  ("./ell/alt-mouse.el") "zzz@cs.brown.edu" "19911027:09:19:26" "zzz" "19911027:09:31:36")
;;
;;  which means:  button \<(alt.mouse.el)> found in file "TO-DO" in the current
;;  directory provides a link to the local file "./ell/alt-mouse.el".  It was
;;  created and last modified by zzz@cs.brown.edu.
;;
;;  All link entries that originate from the same source file are stored
;;  contiguously, one per line, in reverse order of creation.
;;  Preceding all such entries is the source name (in the case of a file
;;  used as a source, no directory information since only sources in the same
;;  directory as the button data file are used as Key-Files within it.
;;
;; DESCRIP-END.

;;; ************************************************************************
;;; Other required Elisp libraries
;;; ************************************************************************

(require 'hbmap)

;;; ************************************************************************
;;; Public functions
;;; ************************************************************************

;;; ------------------------------------------------------------------------
;;; Button data accessor functions
;;; ------------------------------------------------------------------------
(defun hbdata:action (hbdata)
  "[Hyp V2] Returns action overriding button's action type or nil."
  (nth 1 hbdata))

(defun hbdata:actype (hbdata)
  "Returns the action type in HBDATA as a string."
  (let ((nm (symbol-name (nth 3 hbdata))))
    (and nm (if (or (= (length nm) 2) (string-match "::" nm))
		nm (concat "actypes::" nm)))))

(defun hbdata:args (hbdata)
  "Returns the list of any arguments given in HBDATA."
  (nth 4 hbdata))

(defun hbdata:categ (hbdata)
  "Returns the category of HBDATA's button."
  'explicit)

(defun hbdata:creator (hbdata)
  "Returns the user-id of the original creator of HBDATA's button."
  (nth 5 hbdata))

(defun hbdata:create-time (hbdata)
  "Returns the original creation time given for HBDATA's button."
  (nth 6 hbdata))

(defun hbdata:key (hbdata)
  "Returns the indexing key in HBDATA as a string."
  (car hbdata))

(defun hbdata:loc-p (hbdata)
  "[Hyp V1] Returns 'L iff HBDATA referent is within a local file system.
Returns 'R if remote and nil if irrelevant for button action type."
  (nth 1 hbdata))

(defun hbdata:modifier (hbdata)
  "Returns the user-id of the most recent modifier of HBDATA's button.
Nil is returned when button has not been modified."
  (nth 7 hbdata))

(defun hbdata:mod-time (hbdata)
  "Returns the time of the most recent change to HBDATA's button.
Nil is returned when button has not beened modified."
  (nth 8 hbdata))

(defun hbdata:referent (hbdata)
  "Returns the referent name in HBDATA."
  (nth 2 hbdata))

(defun hbdata:search (buf label partial)
  "Go to Hyperbole hbdata BUF and find LABEL whole or PARTIAL matches.
 Search is case-insensitive.  Returns list with elements:
 (<button-src> <label-key1> ... <label-keyN>)."
  (set-buffer buf)
  (let ((case-fold-search t) (src-matches) (src) (matches) (end))
    (goto-char (point-min))
    (while (re-search-forward "^\^L\n\"\\([^\"]+\\)\"" nil t)
      (setq src (buffer-substring (match-beginning 1)
				  (match-end 1))
	    matches nil)
      (save-excursion
	(setq end (if (re-search-forward "^\^L" nil t)
		      (1- (point)) (point-max))))
      (while (re-search-forward
	      (concat "^(\"\\(" (if partial "[^\"]*")
		      (regexp-quote (ebut:label-to-key label))
		      (if partial "[^\"]*") "\\)\"") nil t)
	(setq matches (cons
		       (buffer-substring (match-beginning 1)
					 (match-end 1))
		       matches)))
      (if matches
	  (setq src-matches (cons (cons src matches) src-matches)))
      (goto-char end))
    src-matches))

;;; ------------------------------------------------------------------------
;;; Button data operators
;;; ------------------------------------------------------------------------

(defun hbdata:build (&optional mod-lbl-key but-sym)
  "Tries to construct button data from optional MOD-LBL-KEY and BUT-SYM.
MOD-LBL-KEY nil means create a new entry, otherwise modify existing one.
BUT-SYM nil means use 'hbut:current'.  If successful, returns a cons of
 (button-data . button-instance-str), else nil."
  (let* ((but) 
	 (b (hattr:copy (or but-sym 'hbut:current) 'but))
	 (l (hattr:get b 'loc))
	 (key (or mod-lbl-key (hattr:get b 'lbl-key)))
	 (new-key (if mod-lbl-key (hattr:get b 'lbl-key) key))
	 (lbl-instance) (creator) (create-time) (modifier) (mod-time)
	 (entry) loc dir)
    (if (null l)
	nil
      (setq loc (if (bufferp l) l (file-name-nondirectory l))
	    dir (if (bufferp l) nil (file-name-directory l)))
      (if (setq entry (hbdata:to-entry key loc dir (not mod-lbl-key)))
	  (if mod-lbl-key
	      (progn
		(setq creator     (hbdata:creator entry)
		      create-time (hbdata:create-time entry)
		      modifier    (let* ((user (user-login-name))
					 (addr (concat user
						       hyperb:host-domain)))
				    (if (equal creator addr)
					user addr))
		      mod-time    (htz:date-sortable-gmt)
		      entry       (cons new-key (cdr entry)))
		(hbdata:delete-entry-at-point)
		(if (setq lbl-instance (hbdata:instance-last new-key loc dir))
		    (progn
		      (setq lbl-instance (concat ebut:instance-sep
						 (1+ lbl-instance)))
		      ;; This line is needed to ensure that the highest
		      ;; numbered instance of a label appears before
		      ;; other instances, so 'hbdata:instance-last' will work.
		      (if (hbdata:to-entry-buf loc dir) (forward-line 1))))
		)
	    (setq lbl-instance (hbdata:instance-next new-key))
	    ))
      (if (or entry (not mod-lbl-key))
	  (cons
	   (list (concat new-key lbl-instance)
		 (hattr:get b 'action)
		 ;; Hyperbole V1 referent compatibility, always nil in V2
		 (hattr:get b 'referent)
		 ;; Save actype without class prefix
		 (let ((actype (hattr:get b 'actype)))
		   (and actype (symbolp actype)
			(setq actype (symbol-name actype))
			(intern
			 (substring actype (if (string-match "::" actype)
					       (match-end 0) 0)))))
		 (hattr:get b 'args)
		 (or creator (concat (user-login-name) hyperb:host-domain))
		 (or create-time (htz:date-sortable-gmt))
		 modifier
		 mod-time)
	   lbl-instance)
	))))

(defun hbdata:get-entry (lbl-key key-src &optional directory)
  "Returns button data entry given by LBL-KEY, KEY-SRC and optional DIRECTORY.
Returns nil if no matching entry is found.
A button data entry is a list of attribute values.  Use methods from
class 'hbdata' to operate on the entry."
  (hbdata:apply-entry '(read (current-buffer)) lbl-key key-src directory))

(defun hbdata:instance-next (lbl-key)
  "Returns string for button instance number following LBL-KEY's.
nil if LBL-KEY is nil."
  (and lbl-key
       (if (string-match
	    (concat (regexp-quote ebut:instance-sep) "[0-9]+$") lbl-key)
	   (concat ebut:instance-sep
		   (int-to-string
		    (1+ (string-to-int
			 (substring lbl-key (1+ (match-beginning 0)))))))
	 ":2")))

(defun hbdata:instance-last (lbl-key key-src &optional directory)
  "Returns highest instance number for repeated button label.
1 if not repeated, nil if no instance.
Takes arguments LBL-KEY, KEY-SRC and optional DIRECTORY."
  (hbdata:apply-entry
   '(if (looking-at "[0-9]+")
	(string-to-int (buffer-substring (match-beginning 0)
					 (match-end 0)))
      1)
   lbl-key key-src directory nil 'instance))

(defun hbdata:delete-entry (lbl-key key-src &optional directory)
  "Deletes button data entry given by LBL-KEY, KEY-SRC and optional DIRECTORY.
Returns entry deleted (a list of attribute values) or nil.
Use methods from class 'hbdata' to operate on the entry."
  (hbdata:apply-entry
   '(prog1 (read (current-buffer))
      (let ((empty-file-entry "[ \t\n]*\\(\^L\\|\\'\\)")
	    (kill))
	(beginning-of-line)
	(hbdata:delete-entry-at-point)
	(if (looking-at empty-file-entry)
	    (let ((end (point))
		  (empty-hbdata-file "[ \t\n]*\\'"))
	      (forward-line -1)
	      (if (= (following-char) ?\")
		  ;; Last button entry for filename, so del filename.
		  (progn (forward-line -1) (delete-region (point) end)))
	      (save-excursion
		(goto-char (point-min))
		(if (looking-at empty-hbdata-file)
		    (setq kill t)))
	      (if kill
		  (let ((fname buffer-file-name))
		    (erase-buffer) (save-buffer) (kill-buffer nil)
		    (hbmap:dir-remove (file-name-directory fname))
		    (call-process "rm" nil 0 nil "-f" fname))
		)))))
   lbl-key key-src directory))

(defun hbdata:delete-entry-at-point ()
  (delete-region (point) (progn (forward-line 1) (point))))

(defun hbdata:to-entry (but-key key-src &optional directory instance)
  "Returns button data entry indexed by BUT-KEY, KEY-SRC, optional DIRECTORY.
Returns nil if entry is not found.  Leaves point at start of entry when
successful or where entry should be inserted if unsuccessful.
A button entry is a list.  Use methods from class 'hbdata' to operate on the
entry.  Optional INSTANCE non-nil means search for any button instance matching
but-key."
  (let ((pos-entry-cons (hbdata:apply-entry '(progn
					      (beginning-of-line)
					      (cons (point)
						    (read (current-buffer))))
					   but-key key-src directory
					   'create instance)))
    (hbdata:to-entry-buf key-src directory)
    (forward-line 1)
    (if pos-entry-cons
	(progn
	  (goto-char (car pos-entry-cons))
	  (cdr pos-entry-cons)))))

;;; ************************************************************************
;;; Private functions
;;; ************************************************************************

(defun hbdata:apply-entry (expr lbl-key key-src &optional directory
			       create instance)
  "Evals EXPR at hbdata entry given by LBL-KEY, KEY-SRC, optional DIRECTORY.
With optional CREATE, if no such line exists, inserts a new file entry at the
beginning of the hbdata file (which is created if necessary).
INSTANCE non-nil means search for any button instance matching LBL-KEY and
evaluate EXPR with point right after any 'ebut:instance-sep' in match.
Returns value of evaluation when a matching entry is found or nil."
  (let ((found)
	(rtn)
	(opoint)
	(end-form))
    (save-restriction
      (save-excursion
	(unwind-protect
	    (progn
	      (if (bufferp key-src) (set-buffer key-src))
	      (if (and (hmail:lister-p)
		       (progn (rmail:summ-msg-to) (rmail:to)))
		  (progn (setq opoint (point)
			       key-src (current-buffer)
			       end-form '(progn (hmail:msg-narrow)
						(goto-char opoint)
						(lmail:to)))))
	      (setq found (hbdata:to-entry-buf key-src directory create)))
	  (if found
	      (let ((case-fold-search t)
		    (qkey (regexp-quote lbl-key))
		    (end (save-excursion (if (search-forward "\^L" nil t)
					     (point) (point-max)))))
		(if (eval
		     (if instance
			 '(re-search-forward
			   (concat "\n(\"" qkey "["
				   ebut:instance-sep "\"]") end t)
		       '(search-forward (concat "\n(\"" lbl-key "\"") end t)))
		    (progn
		      (or instance (beginning-of-line))
		      (let (buffer-read-only)
			(setq rtn (eval expr)))))))
	  (eval end-form))))
    rtn))

(defun hbdata:to-hbdata-buffer (dir &optional create)
  "Read in the file containing DIR's hyper-data, if any.
If it does not exist and optional CREATE is non-nil, create a new
one, otherwise return nil."
  (let* ((file (concat (file-name-as-directory (or dir default-directory))
		       hattr:filename))
	 (existing-file (or (file-exists-p file) (get-file-buffer file)))
	 (buf (or (get-file-buffer file)
		  (and (or create existing-file)
		       (find-file-noselect file)))))
    (if buf
	(progn (set-buffer buf)
	       (or (verify-visited-file-modtime (get-file-buffer file))
		   (cond ((yes-or-no-p
			   "Hyper-button data file has changed, read new contents? ") 
			  (revert-buffer t t)
			  )))
	       (or (= (point-max) 1) (eq (char-after 1) ?\^L)
		   (error "File %s is not a valid hyper-data table." file))
	       (or (equal (buffer-name) file) (rename-buffer file))
	       (setq buffer-read-only nil)
	       (or existing-file (hbmap:dir-add (file-name-directory file)))
	       t))))


(defun hbdata:to-entry-buf (key-src &optional directory create)
  "Moves point to end of line in but data buffer matching KEY-SRC.
Uses hbdata file in KEY-SRC's directory, or optional DIRECTORY or if nil, uses
default-directory.
With optional CREATE, if no such line exists, inserts a new file entry at the
beginning of the hbdata file (which is created if necessary).
Returns non-nil if KEY-SRC is found or created, else nil."
  (let ((rtn))
    (if (bufferp key-src)
	;; Button buffer has no file attached
	(progn (setq rtn (set-buffer key-src)
		     buffer-read-only nil)
	       (if (not (hmail:hbdata-to-p))
		   (insert hmail:hbdata-sep "\n"))
	       (backward-char 1)
	       )
      (setq directory (or (file-name-directory key-src) directory)
	    key-src (file-name-nondirectory key-src))
      (if (hbdata:to-hbdata-buffer directory create)
	  (progn
	    (goto-char 1)
	    (cond ((search-forward (concat "\^L\n\"" key-src "\"")
				   nil t)
		   (setq rtn t))
		  (create
		   (setq rtn t)
		   (insert "\^L\n\"" key-src "\"\n")
		   (backward-char 1))
		  ))))
    rtn
    ))

(defun hbdata:write (&optional orig-lbl-key but-sym)
  "Tries to write Hyperbole button data from optional ORIG-LBL-KEY and BUT-SYM.
ORIG-LBL-KEY nil means create a new entry, otherwise modify existing one.
BUT-SYM nil means use 'hbut:current'.  If successful, returns 
a button instance string to append to button label or t when first instance.
On failure, returns nil."
  (let ((cns (hbdata:build orig-lbl-key but-sym))
	entry lbl-instance)
    (if (or (and buffer-file-name
		 (not (file-writable-p buffer-file-name)))
	    (null cns))
	nil
      (setq entry (car cns) lbl-instance (cdr cns))
      (prin1 entry (current-buffer))
      (terpri (current-buffer))
      (or lbl-instance t)
      )))


;;; ************************************************************************
;;; Private variables
;;; ************************************************************************

(provide 'hbdata)