;;!emacs
;;
;; FILE:         hbut.el
;; SUMMARY:      Hyperbole button constructs.
;; USAGE:        GNU Emacs Lisp Library
;;
;; AUTHOR:       Bob Weiner
;; ORG:          Brown U.
;;
;; ORIG-DATE:    18-Sep-91 at 02:57:09
;; LAST-MOD:      4-Jan-92 at 17:47:27 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:  
;; DESCRIP-END.

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

(require 'hmoccur)
(require 'hbmap)
(require 'htz)
(require 'hbdata)
(require 'hact)

;;; ************************************************************************
;;; Public definitions
;;; ************************************************************************

;;; ========================================================================
;;; ebut class - Explicit Hyperbole buttons
;;; ========================================================================

(defvar   ebut:hattr-save t
  "*Non-nil value saves button data when button source is saved.
Nil disables saving.")

(defconst ebut:max-len 100
  "Maximum length of a hyper-button label.")


(defun    ebut:alist (&optional file)
  "Returns alist with each element a list containing a button label.
For use as a completion table.  Gets labels from optional FILE or current
buffer."
  (mapcar 'list (ebut:list file)))

(defun    ebut:at-p (&optional start-delim end-delim)
  "Returns explicit Hyperbole button at point or nil.
Assumes point is within first line of button label, if at all.
Optional START-DELIM and END-DELIM are strings that override default
button delimiters."
  (let ((key (ebut:label-p nil start-delim end-delim)))
    (and key (ebut:get key))))

(defun    ebut:create (&optional but-sym)
  "Creates Hyperbole explicit button based on optional BUT-SYM.
Default is 'hbut:current'.
Button should hold the following attributes (see 'hattr:set'): 
   lbl-key (normalized button label string),
   loc     (filename or buffer where button is located),
   actype  (action type that provides a default action for the button),
   action  (optional action that overrides the default),
   args    (list of arguments for action, if action takes a single
            argument of the button lbl-key, args may be nil).

If successful returns any instance number to append to button label
except when instance number would be 1, then returns t.  On failure,
returns nil.

If successful, leaves point in button data buffer, so caller should use
'save-excursion'.  Does not save button data buffer."
  (let ((lbl-instance (hbdata:write nil but-sym)))
    (run-hooks 'ebut:create-hook)
    lbl-instance))

(defun    ebut:delete (&optional but-sym)
  "Deletes Hyperbole explicit button based on optional BUT-SYM.
Default is 'hbut:current'.
Returns entry deleted (a list of attribute values) or nil."
  (if (null but-sym) (setq but-sym 'hbut:current))
  (if (ebut:is-p but-sym)
      (let* ((but-key (hattr:get but-sym 'lbl-key)) 
	     (loc     (hattr:get but-sym 'loc))
	     (entry   (hbdata:delete-entry but-key loc)))
	(run-hooks 'ebut:delete-hook)
	entry)))

(defun    ebut:get (&optional lbl-key buffer)
  "Returns explicit Hyperbole button symbol given by LBL-KEY and BUFFER.
Retrieves button data, converts into a button object and returns a symbol
which references the button.

Both arguments are optional.  When neither is given, returns symbol for
button that point is within or nil.  BUFFER defaults to the current
buffer."
  (hattr:clear 'hbut:current)
  (save-excursion
    (let ((key-src) (key-file) (key-dir) (but-data) (actype))
      (or lbl-key (setq lbl-key (ebut:label-p)))
      (if buffer
	  (if (bufferp buffer) (set-buffer buffer)
	    (error "(ebut:get): Invalid buffer argument: %s" buffer)))
      (if (setq key-src (ebut:key-src 'full))
	  ;; 'ebut:key-src' sets current buffer to key-src buffer.
	  (setq buffer (current-buffer)))
      (if (and (stringp lbl-key) key-src)
	  (progn
	    (if (stringp key-src)
		(setq key-dir (file-name-directory key-src)
		      key-file (file-name-nondirectory key-src)))
	    (setq but-data (and key-src
				(hbdata:get-entry lbl-key (or key-file key-src)
						 key-dir)))
	    (if (null but-data)
		nil
	      (hattr:set 'hbut:current 'lbl-key lbl-key)
	      (hattr:set 'hbut:current 'loc key-src)
	      (hattr:set 'hbut:current 'categ 'explicit)
	      (hattr:set 'hbut:current 'action nil)
	      (hattr:set 'hbut:current 'actype
			 (intern (setq actype (hbdata:actype but-data))))
	      ;; Hyperbole V1 referent compatibility
	      (if (= (length actype) 2)
		  (hattr:set 'hbut:current 'referent
			     (hbdata:referent but-data)))
	      (hattr:set 'hbut:current 'args (hbdata:args but-data))
	      (hattr:set 'hbut:current 'creator (hbdata:creator but-data))
	      (hattr:set 'hbut:current
			 'create-time (hbdata:create-time but-data))
	      (hattr:set 'hbut:current
			 'modifier (hbdata:modifier but-data))
	      (hattr:set 'hbut:current
			 'mod-time (hbdata:mod-time but-data))
	      'hbut:current)
	    )))))

(defun    ebut:is-p (object)
  "Returns non-nil if OBJECT denotes an explicit Hyperbole button."
  (and (symbolp object)
       (eq (hattr:get object 'categ) 'explicit)))

(defun    ebut:key-of-label-p (key label)
  "Returns t iff KEY matches to LABEL in a case insensitive manner."
  (and (stringp key) (stringp label)
       (equal key (downcase (ebut:label-to-key label)))))

(defun    ebut:key-src (&optional full)
  "Return key source (usually unqualified) for current Hyperbole button.
Also sets current buffer to key source.
With optional FULL when source is a pathname, the full pathname is returned."
  (let ((src (cond ((hmail:mode-is-p) (current-buffer))
		   ((ebut:key-src-fmt))
		   ((save-excursion
		      (save-restriction
			(widen)
			(if (and (search-backward hbut:source-prefix nil t)
				 (or (= (preceding-char) ?\n) (= (point)
								 (point-min))))
			    (hbut:source full)))))
		   (buffer-file-name
		    (if full buffer-file-name
		      (file-name-nondirectory buffer-file-name)))
		   (t (current-buffer))
		   ))
	(buf))
    (if src (progn (if (bufferp src) 
		       (set-buffer src)
		     (if (file-readable-p src)
			 (set-buffer (find-file-noselect src))))
		   src))))

(defun    ebut:key-src-fmt ()
   "Returns unformatted filename associated with formatted current buffer.
This is used to obtain the source of explicit buttons for buffers that
represent the output of particular document formatters."
   (cond ((or (eq major-mode 'Info-mode)
	      (string-match "\\.info\\(-[0-9]+\\)?$" (buffer-name)))
	  (let ((src (and buffer-file-name
			  (substring
			   buffer-file-name
			   0 (string-match "\\.[^.]+$" buffer-file-name)))))
	    (cond ((file-exists-p (concat src ".texinfo"))
		   (concat src ".texinfo"))
		  ((file-exists-p (concat src ".texi"))
		   (concat src ".texi"))
		  ((current-buffer)))))
	 ))
(defun    ebut:key-to-label (lbl-key)
  "Unnormalizes LBL-KEY and returns a label string approximating actual label."
  (if lbl-key
      (let* ((pos 0) (len (length lbl-key)) (lbl) c)
	(while (< pos len)
	  (setq c (aref lbl-key pos)
		lbl (concat lbl 
			    (if (= c ?_)
				(if (or (= (1+ pos) len)
					(/= (aref lbl-key (1+ pos)) ?_))
				    " "
				  (setq pos (1+ pos))
				  "_")
			      (char-to-string c)))
		pos (1+ pos)))
	lbl)))

(defun    ebut:label-p (&optional as-label start-delim end-delim pos-flag)
  "Returns key for Hyperbole button label that point is within.
Returns nil if not within a label.
Assumes point is within first line of button label, if at all.
If optional AS-LABEL is non-nil, label is returned rather than the key
derived from the label.  Optional START-DELIM and END-DELIM are strings
that override default button delimiters.  With optional POS-FLAG non-nil,
returns list of label-or-key, but-start-position, but-end-position.
Positions include delimiters."
  (let ((opoint (point))
	(npoint (1+ (point)))
	(quoted "\\(^\\|[^\\{]\\)")
	label start end but-start but-end)
    (or start-delim (setq start-delim ebut:start))
    (or end-delim (setq end-delim ebut:end))
    (save-excursion
      (beginning-of-line)
      (while (and (progn
		    (while (re-search-forward
			    (concat quoted (regexp-quote start-delim))
			    npoint t)
		       (setq start t))
		    start)
		  (re-search-forward (concat "[^\\{]" (regexp-quote end-delim))
				     npoint t))
	(setq start nil))
      (if start
	  (progn
	    (setq start (point)
		  but-start (match-end 1))
	    (goto-char opoint)
	    (and (re-search-forward (concat quoted (regexp-quote end-delim))
				    (+ start ebut:max-len) t)
		 (setq but-end (point)
		       end (- (point) (length end-delim))
		       label (buffer-substring start end))
		 (cond (pos-flag
			(if as-label
			    (list label but-start but-end)
			  (list (ebut:label-to-key label) but-start but-end)))
		       (t (if as-label label (ebut:label-to-key label))))
		 ))))))

(defun    ebut:label-regexp (lbl-key &optional no-delim)
  "Unnormalizes LBL-KEY.  Returns regular expr matching delimited but label.
Optional NO-DELIM leaves off delimiters and leading and trailing space."
  (if lbl-key
      (let* ((pos 0)
	     (len (length lbl-key))
	     (c)
	     (sep0 "[ \t\n\^M]*")
	     (sep "[ \t\n\^M]+")
	     (regexp (if no-delim "" (concat (regexp-quote ebut:start) sep0)))
	     (case-fold-search))
	(while (< pos len)
	  (setq c (aref lbl-key pos)
		regexp (concat regexp 
			       (if (= c ?_)
				 (if (or (= (1+ pos) len)
					 (/= (aref lbl-key (1+ pos)) ?_))
				     sep
				   (setq pos (1+ pos))
				   "_")
				 (regexp-quote (char-to-string c))))
		pos (1+ pos)))
	(if no-delim regexp 
	  (setq regexp (concat regexp sep0 (regexp-quote ebut:end)))))))

(defun    ebut:label-to-key (label)
  "Normalizes LABEL for use as a Hyperbole button key and returns key.
Eliminates any fill prefix in the middle of the label, replaces '_' with
'__', removes leading and trailing whitespace and replaces each other
whitespace sequence with '_'."
  (if (null label)
      nil
    (setq label (hbut:fill-prefix-remove label)
	  ;; Remove leading and trailing space.
	  label (hypb:replace-match-string "\\`[ \t\n\^M]+\\|[ \t\n\^M]+\\'"
					   label "")
	  label (hypb:replace-match-string "_" label "__" t))
    (hypb:replace-match-string "[ \t\n\^M]+" label "_" t)))

(defun    ebut:list (&optional file loc-p)
  "Returns list of button labels from given FILE or current buffer.
With optional LOC-P, returns list of elements (label start end) where
start and end are the buffer positions at which the starting button delimiter
begins and ends."
  (interactive)
  (setq file (if file (and (file-exists-p file) (find-file-noselect file))
	       (current-buffer)))
  (if file
      (progn
	(set-buffer file)
	(ebut:map (if loc-p
		      '(lambda (lbl start end)
			 ;; Normalize label spacing
			 (list (ebut:key-to-label (ebut:label-to-key lbl))
				start end))
		    '(lambda (lbl start end)
		       ;; Normalize label spacing
		       (ebut:key-to-label (ebut:label-to-key lbl))))))))

(fset    'map-ebut 'ebut:map)
(defun    ebut:map (but-func &optional start-delim end-delim
			     regexp-match include-delims)
  "Applies BUT-FUNC to buttons delimited by optional START-DELIM and END-DELIM.
If REGEXP-MATCH is non-nil, only buttons which matching this argument are
operated upon.
Maps over portion of buffer visible under any current restriction.
BUT-FUNC must take precisely three arguments: the button label, the
start position of the delimited button label and its end position (positions
include delimiters when INCLUDE-DELIMS is non-nil).
If END-DELIM is a symbol, e.g. t, then START-DELIM is taken as a regular
expression which matches an entire button string."
  (or start-delim (setq start-delim ebut:start))
  (or end-delim (setq end-delim ebut:end))
  (let* ((regexp (symbolp end-delim))
	 (end-sym (or regexp (substring end-delim -1)))
	 (rtn)
	 (quoted)
	 start end but lbl)
    (save-excursion
      (goto-char (point-min))
      (setq include-delims (if include-delims 0 1))
      (while (re-search-forward
	      (if regexp start-delim
		(concat (regexp-quote start-delim)
			"\\([^" end-sym "]+\\)" (regexp-quote end-delim)))
	      nil t)
	(setq start (match-beginning include-delims)
	      end (match-end include-delims)
	      but (buffer-substring (match-beginning 0) (match-end 0))
	      lbl (buffer-substring (match-beginning 1) (match-end 1)))
	(save-excursion
	  (goto-char start)
	  (if (or (= (preceding-char) ?\\) (= (preceding-char) ?\{))
	      ;; Ignore matches with quoted delimiters.
	      (setq quoted t)))
	(cond (quoted (setq quoted nil))
	      ((or (not regexp-match)
		   (string-match regexp-match but))
	       (setq rtn (cons (funcall but-func lbl start end) rtn))))))
    (nreverse rtn)))

(defun    ebut:modify (&optional lbl-key but-sym)
  "Modifies existing Hyperbole button from optional LBL-KEY and BUT-SYM.
Defaults are the key for any button label at point and 'hbut:current'.
If successful, returns button's instance number except when instance
number is 1, then returns t.  On failure, as when button does not exist,
returns nil.

If successful, leaves point in button data buffer, so caller should use
'save-excursion'.  Does not save button data buffer."
  (save-excursion
    (let ((lbl-instance (hbdata:write lbl-key but-sym)))
      (run-hooks 'ebut:modify-hook)
      lbl-instance)))

(defun    ebut:search (string out-buf &optional match-part)
  "Writes explicit button lines matching STRING to OUT-BUF.
Uses Hyperbole space into which user has written buttons for the search.
By default, only matches for whole button labels are found, optional MATCH-PART
enables partial matches."
  (let*  ((buffers (mapcar '(lambda (dir) (concat dir hattr:filename))
			   (hbmap:dir-list)))
	  (total 0)
	  (firstmatch))
    (save-excursion
      (set-buffer out-buf)
      (setq buffer-read-only nil)
      (widen)
      (erase-buffer)
      (let (currbuf currfile kill-buf src-matches dir)
	(while buffers
	  (setq currbuf (car buffers)
		currfile (if (stringp currbuf) currbuf)
		kill-buf (and currfile (not (get-file-buffer currfile)))
		buffers (cdr buffers))
	  (if currfile
	      (setq currbuf (and (file-readable-p currfile)
				 (find-file-noselect currfile))
		    dir (file-name-directory currfile))
	    (setq currfile (buffer-file-name currbuf)))
	  (and currfile currbuf
	       (unwind-protect
		   (setq src-matches
			 (hbdata:search currbuf string match-part))
		 (if kill-buf (kill-buffer currbuf))))
	  (if src-matches
	      (let (elt match)
		(while src-matches
		  (setq elt (car src-matches))
		  (if (null elt) nil
		    (setq src-matches (cdr src-matches)
			  currfile (concat dir (car elt))
			  matches (cdr elt)
			  currbuf (get-file-buffer currfile)
			  kill-buf (not currbuf)
			  currbuf (or currbuf
				      (and (file-readable-p currfile)
					   (find-file-noselect currfile))))
		    (if (null currbuf)
			(progn (set-buffer out-buf)
			       (insert "ERROR: (ebut:search): \"" currfile
				       \"" is not readable.\n\n"))
		      (set-buffer currbuf)
		      (unwind-protect
			  (save-excursion
			    (widen) (goto-char 1)
			    (let ((case-fold-search t)
				  (regexp
				   (ebut:match-regexp matches match-part)))
			      (setq firstmatch t)
			      (while (re-search-forward regexp nil t)
				(setq total (1+ total))
				(let* ((linenum (count-lines (point-min)
							     (point)))
				       (tag (format "\n%4d:" linenum))
				       lns start end)
				  (setq end (progn (end-of-line) (point))
					start (progn
						(goto-char (match-beginning 0))
						(beginning-of-line) (point))
					lns (buffer-substring start end))
				  (goto-char end)
				  (save-excursion
				    (set-buffer out-buf)
				    (if firstmatch
					(progn
					  (insert hbut:source-prefix "\"" 
						  currfile "\"\n")
					  (setq firstmatch nil)))
				    (insert tag lns))))
			      (set-buffer out-buf)
			      (if (not firstmatch) (insert "\n\n"))))
			(if kill-buf (kill-buffer currbuf)))))))))))
    total))

;;; ------------------------------------------------------------------------
(defun    ebut:match-regexp (match-keys match-part)
  "Returns regexp to match to all explicit button keys from MATCH-KEYS."
  (setq match-part (if match-part
		       (concat "[^" (substring ebut:end -1) "]*")
		     "[ \t\n]*"))
  (concat
   (regexp-quote ebut:start) match-part
   "\\(" (mapconcat '(lambda (key) (ebut:label-regexp key 'no-delim))
		    match-keys "\\|")
   "\\)" match-part (regexp-quote ebut:end)))

(defconst ebut:end   ")>"
  "String matching the end of a hyper-button.")
(defconst ebut:instance-sep ":"
  "String of one character, separates an ebut label from its instance num.")

(defconst ebut:start "<("
  "String matching the start of a hyper-button.")
;;; ========================================================================
;;; hattr class
;;; ========================================================================

(defun    hattr:attributes (obj-symbol)
  "Returns a list of OBJ-SYMBOL's attributes as symbols."
  (if (symbolp obj-symbol)
      (let* ((attr-val-list (symbol-plist obj-symbol))
	     (i -1))
	(delq nil (mapcar '(lambda (elt)
			     (setq i (1+ i))
			     (and (= (mod i 2) 0) elt))
			  attr-val-list)))))

(defun    hattr:clear (hbut)
  "Removes all of HBUT's attributes."
  (let (plist)
    (or (symbolp hbut)
	(error "(hattr:clear): Argument not a Hyperbole button: %s" hbut))
    (if (consp (setq plist (cdr (symbol-plist hbut))))
	(setcdr plist nil))))

(defun    hattr:copy (from-hbut to-hbut)
  "Copies attributes FROM-HBUT TO-HBUT, eliminating attributes TO-HBUT had.
Returns TO-HBUT."
  (mapcar
   '(lambda (hbut)
      (or (and hbut (symbolp hbut))
	  (error "(hattr:clear): Argument not a Hyperbole button: %s" hbut)))
   (list from-hbut to-hbut))
  (unwind-protect
      nil
    (hattr:clear to-hbut)
    (setplist to-hbut (mapcar 'identity (symbol-plist from-hbut))))
  to-hbut)

(defun    hattr:get (obj-symbol attr-symbol)
  "Returns value of OBJ-SYMBOL's attribute ATTR-SYMBOL."
  (get obj-symbol attr-symbol))

(defun    hattr:list (obj-symbol)
  "Returns a property list of OBJ-SYMBOL's attributes.
Each pair of elements is: <attrib-name> <attrib-value>."
  (if (symbolp obj-symbol)
      (symbol-plist obj-symbol)
    (error "(hattr:list): Argument not a symbol: %s" obj-symbol)))

(defun    hattr:memq (attr-symbol obj-symbol)
  "Returns t if ATTR-SYMBOL is in OBJ-SYMBOL's attribute list, else nil."
  (and (symbolp obj-symbol) (symbolp attr-symbol)
       (let* ((attr-val-list (symbol-plist obj-symbol))
	      (attr-list (let ((i -1))
			   (delq nil (mapcar '(lambda (elt)
						(setq i (1+ i))
						(and (= (mod i 2) 0) elt))
					     attr-val-list)))))
	 (if (memq attr-symbol attr-list) t))))

(defun    hattr:report (attrib-list)
  "Pretty prints to standard-output attribute-value pairs from ATTRIB-LIST.
Ignores nil valued attributes.  Returns t unless no attributes are printed."
  (let ((has-attr) attr val len)
    (if (or (null attrib-list) (not (listp attrib-list))
	    ;; odd number of elements?
	    (= (% (length attrib-list) 2) 1))
	nil
      (while (setq attr (car attrib-list))
	(setq val (car (setq attrib-list (cdr attrib-list)))
	      attrib-list (cdr attrib-list))
	(if val
	    (progn
	      (setq has-attr t
		    attr (symbol-name attr)
		    len (- 16 (length attr)))
	      (princ "   ") (princ attr) (princ ":")
	      (princ (make-string len ? ))
	      (prin1 (if (string-match "time" attr)
			 (htz:date-unix val
				       (and (>= (aref val 0) ?0)
					    (<= (aref val 0) ?9)
					    "GMT") htz:local)
		       val))
	      (terpri))))
      has-attr)))

(defun    hattr:save ()
  "Saves button attribute file for current directory, if modified.
Suitable for use as part of 'write-file-hooks'."
  (let* ((bd-file (concat default-directory hattr:filename))
	 (buf (and (stringp default-directory)
		   (get-file-buffer bd-file))))
    (if (and ebut:hattr-save buf (not (eq buf (current-buffer))))
	(let ((ebut:hattr-save))  ;; Prevents 'write-file-hooks' looping.
	  (and (buffer-modified-p buf) 
	       (save-excursion
		 (set-buffer buf) (save-buffer)
		 ;; Unlock button attribute file; kill buffer so user is
		 ;; never holding a buffer which is out of sync with file,
		 ;; due to some other user's edits.
		 ;; Maybe this should be user or site configurable.
		 (or (buffer-modified-p buf) (kill-buffer nil))
		 )))))
  ;; Must return nil, so can be used as part of write-file-hooks.
  nil)

(defun    hattr:set (obj-symbol attr-symbol attr-value)
  "Sets OBJ-SYMBOL's attribute ATTR-SYMBOL to ATTR-VALUE."
  (put obj-symbol attr-symbol attr-value))

(fset    'hattr:summarize 'hattr:report)

(defvar   hattr:filename ".hypb"
  "Per directory file name in which explicit button attributes are stored.
If you change its value, you will be unable to use buttons created by
others who use a different value!")

;;; ========================================================================
;;; hbut class - abstract
;;; ========================================================================

(defun    hbut:act (hbut)
  "Performs action for explicit or implicit Hyperbole button symbol HBUT."
  (and hbut (action:act hbut (hbut:action hbut))))

(defun    hbut:action (hbut)
  "Returns appropriate action for Hyperbole button symbol HBUT."
  (let ((categ (hattr:get hbut 'categ)) (atype) (action))
    (if (eq categ 'explicit)
	(setq action (hattr:get hbut 'action)
	      atype  (hattr:get hbut 'actype))
      ;; Must be an implicit button.
      (setq atype (hattr:get categ 'actype)))
    (if (= (length (symbol-name atype)) 2)
	atype
      (or action (actype:action atype)))))

(defun    hbut:at-p ()
  "Returns symbol for explicit or implicit Hyperbole button at point or nil."
  (or (ebut:at-p) (ibut:at-p)))


(defun    hbut:comment (start end)
  "Comment button label spanning region START to END in current buffer.
Use buffer commenting grammar, if any, otherwise don't comment."
  (save-excursion
    (if comment-start
	(if (or (equal comment-end "")
		(null comment-end))
	    (progn
	      (beginning-of-line)
	      (if (search-forward comment-start start t)
		  nil
		(goto-char start)
		(insert comment-start)
		(if (/= (preceding-char) ? )
		    (insert ? ))))
	  ;; Comments have both start and end delimiters
  	  (if (and (re-search-backward
		    (concat (regexp-quote comment-start) "\\|"
			    (regexp-quote comment-end))
		    nil t)
		   (looking-at (regexp-quote comment-start)))
	      nil
	    (goto-char start)
	    (insert comment-start)
	    (if (/= (preceding-char) ? )
		(insert ? ))
	    (goto-char (+ (point) (- end start)))
	    (if (/= (following-char) ? )
		(insert ? ))
	    (insert comment-end)
	    )))))

;;; Regexps derived in part from "filladapt.el" under the GPL, Copyright
;;; 1989 Kyle E. Jones.
(defvar   hbut:fill-prefix-regexps
  '(
    ;; Included text in news or mail messages
    "[\n][ \t]*\\([|<>]+ *\\)+"
    ;; Included text generated by SUPERCITE.  We can't hope to match all
    ;; the possible variations.
    "[\n][ \t]*[^'`\"< \t]*> *"
    ;; Lisp comments
    "[\n][ \t]*\\(;+[ \t]*\\)+"
    ;; UNIX shell comments
    "[\n][ \t]*\\(#+[ \t]*\\)+"
    ;; C++ comments
    "[\n][ \t]*//[/ \t]+"
    ;; C or Pascal comments, one open and close per line, so match close
    ;; then open.
    "\\*+[/\)][ \t]*[\n]+[ \t]*[/\(]\\*+"
    "}[ \t]*[\n]+[ \t]*{"
    ;; Eiffel or Sather comments
    "[\n][ \t]*--[ \t]+"
    ;; Fortran comments
    "[\n][Cc][ \t]+"
    ;; Postscript comments
    "[\n][ \t]*\\(%+[ \t]*\\)+"
    )
"List of regexps of fill prefixes to remove from the middle of buttons.")

(defun    hbut:fill-prefix-remove (label)
  "Removes any recognized fill prefix from within LABEL.
'hbut:fill-prefix-regexps' is a list of fill prefixes to recognize."
  (if (string-match "[\n]" label)
      (mapcar
       '(lambda (fill-prefix)
	  (and (string-match "[\n]" label)
	       (setq label
		     (hypb:replace-match-string fill-prefix label " " t))))
       hbut:fill-prefix-regexps))
  label)
(defun    hbut:help (hbut)
  "Describes attributes and behavior of Hyperbole button symbol HBUT."
  (and hbut (action:act hbut (hbut:action hbut))))

(defun    hbut:is-p (object)
  "Returns non-nil if object denotes a Hyperbole button."
  (and (symbolp object) (hattr:get object 'categ)))

(fset    'hbut:key-src      'ebut:key-src)
(fset    'hbut:key-to-label 'ebut:key-to-label)
(fset    'hbut:label-p      'ebut:label-p)
(fset    'hbut:label-to-key 'ebut:label-to-key)

(defun    hbut:report (&optional arg)
  "Pretty prints the attributes of a button or buttons.

Takes an optional ARG interpreted as follows:
  a button symbol - report on that button;
  nil             - report on button at point, if any;
  integer > 0     - report on all explicit buttons in buffer, alphabetize;
  integer < 1     - report on all explicit buttons in occurrence order;

Returns number of buttons reported on or nil if none."
  (setq arg (cond ((or (integerp arg) (symbolp arg)) arg)
		  ((listp arg)
		   (if (integerp (setq arg (car arg))) arg 1))
		  (t 1)))
  (let* ((but (if (and arg (symbolp arg)) arg (hbut:at-p)))
	 (curr-key (and but (hattr:get but 'lbl-key)))
	 (key-src (or (and but (hattr:get but 'loc)) (hbut:key-src)))
	 (lbl-lst (cond ((not arg)
			 (if curr-key (list (ebut:key-to-label curr-key))))
			((symbolp arg) (if (hbut:is-p arg)
					   (list (ebut:key-to-label
						  (hattr:get arg 'lbl-key)))))
			((< arg 1) (ebut:list))
			(t (sort (ebut:list)
				 '(lambda (s1 s2)
				    (string< (downcase s1) (downcase s2)))))))
	 (total (length lbl-lst))
	 (key-buf (current-buffer))
	 (buf-name (hypb:help-buf-name))
	 (attribs))
    (if lbl-lst
	(progn
	  (with-output-to-temp-buffer buf-name
	    (princ hbut:source-prefix)
	    (prin1 key-src)
	    (terpri)
	    (terpri)
	    (mapcar
	     '(lambda (lbl)
		(if (setq but
			  (cond ((or (null arg) (symbolp arg)) but)
				(t (ebut:get (ebut:label-to-key lbl) key-buf)))
			  attribs (hattr:list but))
		    (progn
		      (princ (if (ibut:is-p but)
				 lbl
			       (concat ebut:start lbl ebut:end)))
		      (terpri)
		      (let ((doc (actype:doc but (= 1 (length lbl-lst)))))
			(if doc
			    (progn
			      (princ "  ")
			      (princ doc)
			      (terpri))))
		      (hattr:report
		       (if (eq (car (cdr (memq 'categ attribs))) 'explicit)
			   (memq 'action attribs)
			 (memq 'categ attribs)))
		      (terpri))
		  ))
	     lbl-lst))
	  (length lbl-lst)))))

(defun    hbut:source (&optional full)
  "Returns Hyperbole source buffer or file given at point.
If a file, always returns a full path if optional FULL is non-nil."
  (goto-char (match-end 0))
  (cond ((looking-at "#<buffer \\([^ \n]+\\)>")
	 (get-buffer (buffer-substring (match-beginning 1)
				       (match-end 1))))
	((looking-at "\".+\"")
	 (let* ((file (buffer-substring (1+ (match-beginning 0))
					(1- (match-end 0))))
		(absolute (file-name-absolute-p file)))
	   (if (and full (not absolute))
	       (concat default-directory file)
	     file)))))

(fset    'hbut:summarize 'hbut:report)

(defvar   hbut:current nil
  "Currently selected Hyperbole button.
Available to action routines.")

(defconst hbut:source-prefix moccur-source-prefix
  "String found at start of a buffer containing only a hyper-button menu.
   This expression should be followed immediately by a file-name indicating the
source file for the buttons in the menu, if any.")

;;; ========================================================================
;;; htype class
;;; ========================================================================

(require 'set)

(defmacro htype:create (type parent doc property-list)
  "Creates a new Hyperbole TYPE (an unquoted symbol)
TYPE is derived from PARENT (an unquoted symbol).
DOC is a string describing the type.
Attaches PROPERTY-LIST to the new type and returns the symbol for the type."
  (let ((sym (intern (concat (symbol-name parent) "::"
			     (symbol-name type)))))
    (setplist sym (cons 'variable-documentation (cons doc property-list)))
    (symset:add sym parent 'types)
    (run-hooks 'htype:create-hook)
    (list 'quote sym)))

(defun    htype:doc (htype-sym)
  "Return documentation for HTYPE-SYM."
  (documentation-property htype-sym 'variable-documentation))

(defun    htype:delete (type parent)
  "Deletes a Hyperbole TYPE (a symbol) derived from PARENT (a symbol).
Returns the Hyperbole symbol for the TYPE if it existed, else nil."
  (let* ((sym (intern (concat (symbol-name parent) "::"
			      (symbol-name type))))
	 (exists (memq sym (get parent 'types))))
    (setplist sym nil)
    (symset:delete sym parent 'types)
    (run-hooks 'htype:delete-hook)
    (and exists sym)))

(defun    htype:names (htype-sym &optional sym)
  "Returns list of current names for Hyperbole HTYPE-SYM.
HTYPE-SYM is either 'actypes or 'ibtypes.
When optional SYM is given, return the name for that symbol only, if any."
  (let* ((nm-func '(lambda (sym)
		    (setq nm (symbol-name sym)
			  pos (if (string-match "::" nm) (match-end 0)))
		    (if pos (substring nm pos) nm)))
	 (nm) (pos)
	 (names (delq nil (mapcar nm-func (hattr:get htype-sym 'types)))))
    (if sym
	(if (symbolp sym) (and (setq nm (funcall nm-func sym))
			       (set:member nm names) nm))
      names)))

;;; ========================================================================
;;; ibut class - Implicit Hyperbole buttons
;;; ========================================================================

(defun    ibut:at-p (&optional key-only)
  "Returns symbol for implicit button at point, else nil.
With optional KEY-ONLY, returns only the label key for button."
  (let ((types (get 'ibtypes 'types))
	(itype)
	(idata) ;; (label-key &optional pos-start pos-end)
	(is-type))
    (hattr:clear 'hbut:current)
    (while (and (not is-type) types)
      (setq itype (car types))
      (if (setq idata (eval (hattr:get itype 'at-p)))
	  (setq is-type itype)
	(setq types (cdr types))))
    (if (and idata (listp idata))
	(if key-only (hbut:label-to-key (car idata))
	  (progn
	    (hattr:set   'hbut:current 'lbl-key
			 (hbut:label-to-key (car idata)))
	    (hattr:set   'hbut:current 'loc (save-excursion
					      (hbut:key-src 'full)))
	    (hattr:set   'hbut:current 'categ is-type)
	    (hattr:set   'hbut:current 'actype (hattr:get is-type 'actype))
	    (hattr:set   'hbut:current 'lbl-start (nth 1 idata))
	    (hattr:set   'hbut:current 'lbl-end   (nth 2 idata))
	    (or (hattr:get   'hbut:current 'args)
		(hattr:set   'hbut:current 'args      (nthcdr 3 idata)))
	    'hbut:current)))))

(defun    ibut:is-p (object)
  "Returns non-nil if object denotes an implicit Hyperbole button."
  (if (symbolp object)
      (let ((categ (hattr:get object 'categ)))
	(and categ (eq 0 (string-match "ibtypes::" (symbol-name categ)))))))

(defun    ibut:label-p ()
  "Returns key for Hyperbole implicit button label that point is on or nil."
  (ibut:at-p 'key-only))

;;; ========================================================================
;;; ibtype class - Implicit button types
;;; ========================================================================

(fset    'defib 'ibtype:create)
(defmacro ibtype:create (type params doc at-p &optional actype to-p style)
  "Creates implicit button TYPE (unquoted sym) with PARAMS, described by DOC.
PARAMS are presently ignored.

  AT-P is a boolean form of no arguments which determines whether or not point
is within a button of this type.
  A button of this type performs an action of optional ACTYPE (an unquoted
symbol used as the first argument to a 'defact' call), which defaults to
ibtypes::TYPE.
  Optional TO-P is a boolean form which moves point immediately after the next
button of this type within the current buffer and returns a list of (button-
label start-pos end-pos), or nil when none is found.
  Optional STYLE is a display style specification to use when highlighting
buttons of this type; most useful when TO-P is also given.

Returns symbol created when successful, else nil.  Nil indicates that action
type for ibtype is presently undefined."
  (if (null (or actype type))
      nil
    (let ((action-type (intern (concat "actypes::"
				       (symbol-name (or actype type))))))
      (list 'htype:create type 'ibtypes doc
	    (list 'at-p at-p 'actype action-type
		  'to-p to-p 'style style)
	    ))))

(defun    ibtype:delete (type)
  "Deletes an implicit button TYPE (a symbol).
Returns TYPE's symbol if it existed, else nil."
  (htype:delete type 'ibtypes))

;;; ========================================================================
;;; symset class - Hyperbole internal symbol set maintenance
;;; ========================================================================

(require 'set)

(defun    symset:add (elt symbol prop)
  "Adds ELT to SYMBOL's PROP set.
Returns nil iff ELT is already in SET.  Uses 'eq' for comparison."
  (let* ((set (get symbol prop))
	 (set:equal-op 'eq)
	 (new-set (set:add elt set)))
    (and new-set (put symbol prop new-set))))

(fset    'symset:delete 'symset:remove)
(defun    symset:remove (elt symbol prop)
  "Removes ELT from SYMBOL's PROP set and returns the new set.
Assumes PROP is a valid set.  Uses 'eq' for comparison."
  (let ((set (get symbol prop))
	(set:equal-op 'eq))
    (put symbol prop (set:remove elt set))))


(provide 'hbut)