;;; hui.el --- GNU Emacs User Interface to Hyperbole

;; Copyright (C) 1991-1995, 2008 Free Software Foundation, Inc.
;; Developed with support from Motorola Inc.

;; Author: Bob Weiner, Brown U.
;; Maintainer: Mats Lidell <matsl@contactor.se>
;; Keywords: hypermedia

;; This file is part of GNU Hyperbole.

;; GNU Hyperbole is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation; either version 3, or (at
;; your option) any later version.

;; GNU Hyperbole is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.

;;; Commentary:

;;; Code:

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

(require 'hargs) (require 'set) (require 'hmail)

;;;
;;; Public variables
;;;

(defvar hui:ebut-delete-confirm-p t
  "*Non-nil means prompt before interactively deleting explicit buttons.")

;;;
;;; Public functions
;;;

(defun hui:ebut-create (&optional start end)
  "Creates an explicit but starting from label between optional START and END.
Indicates by delimiting and adding any necessary instance number of the button
label."
  (interactive (list (and (marker-position (hypb:mark-marker t))
			  (region-beginning))
		     (and (marker-position (hypb:mark-marker t))
			  (region-end))))
  (let ((default-lbl) lbl but-buf actype)
    (save-excursion
      (setq default-lbl
	    (hui:hbut-label-default start end (not (interactive-p)))
	    lbl (hui:hbut-label default-lbl "ebut-create"))
      (if (not (equal lbl default-lbl)) (setq default-lbl nil))
      
      (setq but-buf (if default-lbl (current-buffer) (hui:ebut-buf)))
      (hui:buf-writable-err but-buf "ebut-create")
      
      (hattr:set 'hbut:current 'loc (hui:key-src but-buf))
      (hattr:set 'hbut:current 'dir (hui:key-dir but-buf))
      (setq actype (hui:actype))
      (hattr:set 'hbut:current 'actype actype)
      (hattr:set 'hbut:current 'args (hargs:actype-get actype))
      (hattr:set 'hbut:current 'action
		 (and (boundp 'hui:ebut-prompt-for-action)
		      hui:ebut-prompt-for-action (hui:action actype)))
      )
    (ebut:operate lbl nil)))

(defun hui:ebut-delete (but-key &optional key-src)
  "Deletes explicit Hyperbole button given by BUT-KEY in optional KEY-SRC.
KEY-SRC may be a buffer or a pathname, when nil the current buffer is used.
Returns t if button is deleted, nil if user chooses not to delete or signals
an error otherwise.  If called interactively, prompts user whether to delete
and derives BUT-KEY from the button that point is within.
Signals an error if point is not within a button."
  (interactive (list (if (ebut:at-p)
			 (hattr:get 'hbut:current 'lbl-key)
		       nil)))
  (cond ((null but-key)
	 (hypb:error
	  "(ebut-delete): Point is not over the label of an existing button."))
	((not (stringp but-key))
	 (hypb:error
	  "(ebut-delete): Invalid label key argument: '%s'." but-key)))
  (let ((interactive (interactive-p)))
    (if (and hui:ebut-delete-confirm-p interactive)
	(if (y-or-n-p (format "Delete button %s%s%s? "
			      ebut:start
			      (hbut:key-to-label but-key) ebut:end))
	    (hui:ebut-delete-op interactive but-key key-src)
	  (message ""))
      (hui:ebut-delete-op interactive but-key key-src))))
      
(defun hui:ebut-edit ()
  "Creates or modifies an explicit Hyperbole button when conditions are met.
A region must have been delimited with the action-key and point must now be
within it before this function is called or it will do nothing.  The region
must be no larger than the size given by 'ebut:max-len'.  It must be entirely
within or entirely outside of an existing explicit button.  When region is
within the button, the button is interactively modified.  Otherwise, a new
button is created interactively with the region as the default label."
  (interactive)
  (let ((m (marker-position (hypb:mark-marker t)))
	(op action-key-depress-prev-point) (p (point)) (lbl-key))
    (if (and m (eq (marker-buffer m) (marker-buffer op))
	     (< op m) (<= (- m op) ebut:max-len)
	     (<= p m) (<= op p))
	(progn
	  (if (setq lbl-key (ebut:label-p))
	      (hui:ebut-modify lbl-key)
	    (hui:ebut-create op m))
	  t))))

(defun hui:ebut-modify (lbl-key)
  "Modifies an explicit Hyperbole button given by LBL-KEY.
Signals an error when no such button is found in the current buffer."
  (interactive (list (save-excursion
		       (hui:buf-writable-err (current-buffer) "ebut-modify")
		       (or (ebut:label-p)
			   (ebut:label-to-key
			    (hargs:read-match "Button to modify: "
					      (ebut:alist) nil t
					      nil 'ebut))))))
  (let ((lbl (ebut:key-to-label lbl-key))
	(but-buf (current-buffer))
	actype but new-lbl)
    (save-excursion
      (or (interactive-p)
	  (hui:buf-writable-err but-buf "ebut-modify"))
      
      (or (setq but (ebut:get lbl-key but-buf))
	  (progn (pop-to-buffer but-buf)
		 (hypb:error "(ebut-modify): Invalid button, no data for '%s'." lbl)))
      
      (setq new-lbl
	    (hargs:read
	     "Change button label to: "
	     (function
	       (lambda (lbl)
		(and (not (string= lbl "")) (<= (length lbl) ebut:max-len))))
	     lbl
	     (format "(ebut-modify): Enter a string of at most %s chars."
		     ebut:max-len)
	     'string))
      
      (hattr:set 'hbut:current 'loc (hui:key-src but-buf))
      (hattr:set 'hbut:current 'dir (hui:key-dir but-buf))
      (setq actype (hui:actype (hattr:get but 'actype)))
      (hattr:set 'hbut:current 'actype actype)
      (hattr:set 'hbut:current 'args (hargs:actype-get actype 'modifying))
      (hattr:set 'hbut:current 'action
		 (and (boundp 'hui:ebut-prompt-for-action)
		      hui:ebut-prompt-for-action (hui:action actype)))
      )
    (ebut:operate lbl new-lbl)))

(defun hui:ebut-rename (curr-label new-label)
  "Renames explicit Hyperbole button given by CURR-LABEL to NEW-LABEL.
If called interactively when point is not within an explicit button:
   prompts for old and new button label values and performs rename.
If called interactively when point is within an explicit button:
   saves button label and tells user to edit label, then call again.
   second call changes the button's name from the stored value to the
   edited value.
Signals an error if any problem occurs."
  (interactive
   (save-excursion
     (let (curr-label new-label)
       (hui:buf-writable-err (current-buffer) "ebut-rename")
       (if hui:ebut-label-prev
	   (setq curr-label hui:ebut-label-prev
		 new-label (ebut:label-p 'as-label))
	 (setq new-label nil
	       curr-label 
	       (or (ebut:label-p 'as-label)
		   (let ((buts (ebut:alist)))
		     (if (null buts)
			 (hypb:error "(ebut-rename): No explicit buttons in buffer.")
		       (prog1 (hargs:read-match
			       "Button label to rename: "
			       buts nil t nil 'ebut)
			 (setq new-label
			       (hargs:read
				"Rename button label to: "
				(function
				  (lambda (lbl)
				   (and (not (string= lbl ""))
					(<= (length lbl) ebut:max-len))))
				curr-label
				(format
				 "(ebut-rename): Use a quoted string of at most %s chars."
				 ebut:max-len)
				'string))))))))
       (list curr-label new-label))))

  (save-excursion
    (if (interactive-p)
	nil
      (hui:buf-writable-err (current-buffer) "ebut-rename")
      (if (or (not (stringp curr-label)) (string= curr-label ""))
	  (hypb:error "(ebut-rename): 'curr-label' must be a non-empty string: %s"
		 curr-label))
      (and (stringp new-label) (string= new-label "")
	   (hypb:error "(ebut-rename): 'new-label' must be a non-empty string: %s"
		  new-label)))
    (or (ebut:get (ebut:label-to-key curr-label))
	(hypb:error "(ebut-rename): Can't rename %s since no button data."
	       curr-label))
    )
  (cond (new-label
	 (ebut:operate curr-label new-label)
	 (setq hui:ebut-label-prev nil)
	 (message "Renamed from '%s' to '%s'." curr-label new-label))
	(curr-label
	 (setq hui:ebut-label-prev curr-label)
	 (message "Edit button label and use same command to finish rename."))
	(t (hypb:error "(ebut-rename): Move point to within a button label."))))

(defun hui:ebut-search (string &optional match-part)
  "Shows lines of files/buffers containing an explicit but match for STRING.
Returns number of buttons matched and displayed.
By default, only matches for whole button labels are found, optional MATCH-PART
enables partial matches.  The match lines are shown in a buffer which serves as
a menu to find any of the occurrences."
  (interactive (list (read-string "Search for button string: ")
		     (y-or-n-p "Enable partial matches? ")))
  (if (not (stringp string))
      (hypb:error "(ebut-search): String to search for is required."))
  (let*  ((prefix (if (> (length string) 14)
		      (substring string 0 13) string))
	  (out-buf (get-buffer-create (concat "*" prefix " Hypb Search*")))
	  (total (ebut:search string out-buf match-part)))
    (if (> total 0)
	(progn
	  (set-buffer out-buf)
	  (moccur-mode)
	  (if (fboundp 'outline-minor-mode)
	      (and (progn (goto-char 1)
			  (search-forward "\C-m" nil t))
		   (outline-minor-mode 1)))
	  (if (fboundp 'hproperty:but-create)
	      (hproperty:but-create nil nil (regexp-quote
				      (if match-part string
					(concat ebut:start string ebut:end)))))
	  (goto-char (point-min))
	  (pop-to-buffer out-buf)
	  (if (interactive-p) (message "%d match%s." total
				       (if (> total 1) "es" ""))
	    total))
      (if (interactive-p) (message "No matches.")
	total))))

(defun hui:error (&rest args)
  (hypb:error "(hui:error): Obsolete, use hypb:error instead."))

(defun hui:gbut-create (lbl)
  "Creates Hyperbole global button with LBL."
  (interactive "sCreate global button labeled: ")
  (let (but-buf actype)
    (save-excursion
      (setq actype (hui:actype))
      (setq but-buf (set-buffer (find-file-noselect gbut:file)))
      (hui:buf-writable-err but-buf "ebut-create")
      ;; This prevents movement of point which might be useful to user.
      (save-excursion
	(goto-char (point-max))
	(hattr:set 'hbut:current 'loc (hui:key-src but-buf))
	(hattr:set 'hbut:current 'dir (hui:key-dir but-buf))
	(hattr:set 'hbut:current 'actype actype)
	(hattr:set 'hbut:current 'args (hargs:actype-get actype))
	(hattr:set 'hbut:current 'action
		   (and (boundp 'hui:ebut-prompt-for-action)
			hui:ebut-prompt-for-action (hui:action actype)))
	(setq lbl (concat lbl (ebut:operate lbl nil)))
	(goto-char (point-max))
	(insert "\n")
	(save-buffer)
	)
      (message "%s created." lbl)
      )))

(defun hui:gbut-modify (lbl-key)
  "Modifies a global Hyperbole button given by LBL-KEY.
Signals an error when no such button is found."
  (interactive (list (save-excursion
		       (hui:buf-writable-err
			(find-file-noselect gbut:file) "gbut-modify")
		       (hbut:label-to-key
			(hargs:read-match "Global button to modify: "
					  (mapcar 'list (gbut:lbl-list))
					  nil t nil 'ebut)))))
  (let ((lbl (hbut:key-to-label lbl-key))
	(but-buf (find-file-noselect gbut:file))
	actype but new-lbl)
    (save-excursion
      (or (interactive-p)
	  (hui:buf-writable-err but-buf "gbut-modify"))
      
      (or (setq but (ebut:get lbl-key but-buf))
	  (progn (pop-to-buffer but-buf)
		 (hypb:error
		  "(gbut-modify): Invalid button, no data for '%s'." lbl)))
      
      (setq new-lbl
	    (hargs:read
	     "Change global button label to: "
	     (function
	       (lambda (lbl)
		(and (not (string= lbl "")) (<= (length lbl) ebut:max-len))))
	     lbl
	     (format "(gbut-modify): Enter a string of at most %s chars."
		     ebut:max-len)
	     'string))
      
      (hattr:set 'hbut:current 'loc (hui:key-src but-buf))
      (hattr:set 'hbut:current 'dir (hui:key-dir but-buf))
      (setq actype (hui:actype (hattr:get but 'actype)))
      (hattr:set 'hbut:current 'actype actype)
      (hattr:set 'hbut:current 'args (hargs:actype-get actype 'modifying))
      (hattr:set 'hbut:current 'action
		 (and (boundp 'hui:ebut-prompt-for-action)
		      hui:ebut-prompt-for-action (hui:action actype)))
      (set-buffer but-buf)
      (ebut:operate lbl new-lbl))))

(defun hui:hbut-act (&optional but)
  "Executes action for optional Hyperbole button symbol BUT in current buffer.
Default is the current button."
  (interactive
   (let ((but (hbut:at-p)) (lst))
     (list
      (cond (but)
	    ((setq lst (ebut:alist))
	     (ebut:get (ebut:label-to-key
			(hargs:read-match "Button to execute: " lst nil t
					  (ebut:label-p 'as-label) 'ebut))))
	    (t (hypb:error "(hbut-act): No explicit buttons in buffer."))))))
  (cond ((and (interactive-p) (null but))
	 (hypb:error "(hbut-act): No current button to activate."))
	((not (hbut:is-p but))
	 (hypb:error "(hbut-act): Button is invalid; it has no attributes."))
	(t (or but (setq but 'hbut:current))
	   (hui:but-flash) (hyperb:act but))))

(defun hui:hbut-help (&optional but)
  "Checks for and explains an optional button given by symbol, BUT.
BUT defaults to the button whose label point is within."
  (interactive)
  (setq but (or but (hbut:at-p)
		(ebut:get (ebut:label-to-key
			   (hargs:read-match "Help for button: "
					     (ebut:alist) nil t nil 'ebut)))))
  (or but
      (hypb:error "(hbut-help):  Move point to a valid Hyperbole button."))
  (if (not (hbut:is-p but))
      (cond (but (hypb:error "(hbut-help): Invalid button."))
	    (t   (hypb:error
		  "(hbut-help): Not on an implicit button and no buffer explicit buttons."))))
  (let* ((sym-name (htype:names 'ibtypes (hattr:get but 'categ)))
	 (type-help-func (if sym-name (intern-soft (concat sym-name ":help")))))
    (or (equal (hypb:indirect-function 'hui:but-flash)
	       (function (lambda nil)))
	;; Only flash button if point is on it.
	(let ((lbl-key (hattr:get but 'lbl-key)))
	  (and lbl-key
	       (or (equal lbl-key (ebut:label-p))
		   (equal lbl-key (ibut:label-p)))
	       (hui:but-flash))))
    (if type-help-func
	(funcall type-help-func but)
      (let ((total (hbut:report but)))
	(if total (hui:help-ebut-highlight))))))

(defun hui:hbut-label (default-label func-name)
  "Reads button label from user using DEFAULT-LABEL and caller's FUNC-NAME."
  (hargs:read "Button label: "
	      (function
		(lambda (lbl)
		  (and (not (string= lbl "")) (<= (length lbl) ebut:max-len))))
	      default-label
	      (format "(%s): Enter a string of at most %s chars."
		      func-name ebut:max-len)
	      'string))

(defun hui:hbut-label-default (start end &optional skip-len-test)
  "Returns default label based on START and END region markers or points.
Optional SKIP-LEN-TEST means don't limit label to 'ebut:max-len' length.
Returns nil if START or END are invalid or if region fails length test. 

Also has side effect of moving point to start of default label, if any."
  (if (markerp start) (setq start (marker-position start)))
  (if (markerp end) (setq end (marker-position end)))
  ;; Test whether to use region as default button label.
  (if (and (integerp start) (integerp end) 
	   (or skip-len-test
	       (<= (max (- end start) (- start end)) ebut:max-len)))
      (progn (goto-char start)
	     (buffer-substring start end))))

(defun hui:hbut-report (&optional arg)
  "Pretty prints attributes of current button, using optional prefix ARG.
See 'hbut:report'."
  (interactive "P")
  (if (and arg (symbolp arg))
      (hui:hbut-help arg)
    (let ((total (hbut:report arg)))
      (if total
	  (progn (hui:help-ebut-highlight)
		 (message "%d button%s." total (if (/= total 1) "s" "")))))))

(fset 'hui:hbut-summarize 'hui:hbut-report)

(defun hui:link-directly ()
  "Creates a Hyperbole link button at depress point, linked to release point.
See also documentation for 'hui:link-possible-types'."
  (let* ((link-types (hui:link-possible-types))
	 (but-window action-key-depress-window)
	 (num-types (length link-types))
	 (release-window (selected-window))
	 (but-modify nil)
	 type-and-args lbl-key but-loc but-dir)
    (select-window action-key-depress-window)
    (hui:buf-writable-err (current-buffer) "link-directly")
    (if (ebut:at-p)
	(progn
	  (setq but-modify t
		but-loc (hattr:get 'hbut:current 'loc)
		but-dir (hattr:get 'hbut:current 'dir)
		lbl-key (hattr:get 'hbut:current 'lbl-key)))
      (setq but-loc (hui:key-src (current-buffer))
	    but-dir (hui:key-dir (current-buffer))
	    lbl-key (hbut:label-to-key
		      (hui:hbut-label
			(if (marker-position (hypb:mark-marker t))
			    (hui:hbut-label-default
			      (region-beginning) (region-end)))
			"link-directly"))))

    ;; XEmacs 21.5 thinks windows isn't live. Bug!?
    (if (window-live-p release-window)
	(select-window release-window))

    (cond ((= num-types 0)
	   (error "(link-directly): No possible link type to create."))
	  ((= num-types 1)
	   (hui:link-create but-modify
			    but-window lbl-key but-loc but-dir
			    (setq type-and-args (car link-types))))
	  (t;; more than 1
	    (let ((item)
		  type)
	      (hui:link-create
		but-modify but-window
		lbl-key but-loc but-dir
		(setq type-and-args
		      (hui:menu-select
			(cons '("Link to>")
			      (mapcar
				(function
				  (lambda (type-and-args)
				    (setq type (car type-and-args))
				    (list 
				      (capitalize
					(if (string-match
					      "^\\(link-to\\|eval\\)-"
					      (setq item (symbol-name type)))
					    (setq item (substring
							 item (match-end 0)))
					  item))
				      type-and-args
				      (documentation
				       (intern (concat "actypes::"
						       (symbol-name type)))))))
				link-types))))))))
    (message "`%s' button %s type `%s'."
	     (hbut:key-to-label lbl-key)
	     (if but-modify "set to" "created with")
	     (car type-and-args))))

;;;
;;; Private functions
;;;

(defun hui:action (actype &optional prompt)
  "Prompts for and returns an action to override action from ACTYPE."
  (and actype
       (let* ((act) (act-str)
	      (params (actype:params actype))
	      (params-str (and params (concat " " (prin1-to-string params))))
	      )
	 (while (progn
		 (while (and (setq act-str
				   (hargs:read
				    (or prompt (concat "Action" params-str
						       ": ")) nil nil
						       nil 'string))
			     (not (string= act-str ""))
			     (condition-case ()
				 (progn (setq act (read act-str)) nil)
			       (error
				(beep) (message "Invalid action syntax.")
				(sit-for 3) t))))
		 (and (not (symbolp act))
		      params
		      ;; Use the weak condition that action must
		      ;; involve at least one of actype's parameters
		      ;; or else we assume the action is invalid, tell
		      ;; the user and provide another chance for entry.
		      (not (memq t
				 (mapcar
				  (function
				    (lambda (param)
				     (setq param (symbol-name param))
				     (and (string-match
					   (concat "[\( \t\n,']"
						   (regexp-quote param)
						   "[\(\) \t\n\"]")
					   act-str)
					  t)))
				  params)))
		      ))
	   (beep) (message "Action must use at least one parameter.")
	   (sit-for 3))
	 (let (head)
	   (while (cond ((listp act)
			 (and act (setq head (car act))
			      (not (or (eq head 'lambda)
				       (eq head 'defun)
				       (eq head 'defmacro)))
			      (setq act (list 'lambda params act))
			      nil  ;; terminate loop
			      ))
			((symbolp act)
			 (setq act (cons act params)))
			((stringp act)
			 (setq act (action:kbd-macro act 1)))
			;; Unrecognized form
			(t (setq act nil))
			)))
	 act)))

(defun hui:actype (&optional default-actype prompt)
  "Using optional DEFAULT-ACTYPE, PROMPTs for a button action type.
DEFAULT-ACTYPE may be a valid symbol or symbol-name."
  (and default-actype (symbolp default-actype)
       (progn
	 (setq default-actype (symbol-name default-actype))
	 (if (string-match "actypes::" default-actype)
	     (setq default-actype (substring default-actype (match-end 0))))))
  (if (or (null default-actype) (stringp default-actype))
      (intern-soft
       (concat "actypes::"
	       (hargs:read-match (or prompt "Button's action type: ")
				(mapcar 'list (htype:names 'actypes))
				nil t default-actype 'actype)))
    (hypb:error "(actype): Invalid default action type received.")
    ))

(defun hui:buf-writable-err (but-buf func-name)
  "If BUT-BUF is read-only or is unwritable, signal an error from FUNC-NAME."
  (let ((obuf (prog1 (current-buffer) (set-buffer but-buf)))
	;; (unwritable (and buffer-file-name
	;;		 (not (file-writable-p buffer-file-name))))
	(err))
    ;; (if unwritable
    ;;     Commented error out since some people want to be able to create
    ;;     buttons within files which they have purposely marked read-only.
    ;;     (setq err 
    ;;	     (format "(ebut-modify): You are not allowed to modify '%s'."
    ;;		     (file-name-nondirectory buffer-file-name))))
    (if buffer-read-only
	(setq err
	      (format
	       "Button buffer '%s' is read-only.  Use %s to change it."
	       (buffer-name but-buf)
	       (hypb:cmd-key-string
		(if (where-is-internal 'vc-toggle-read-only)
		    'vc-toggle-read-only 'toggle-read-only))
	       )))
    (set-buffer obuf)
    (if err (progn (pop-to-buffer but-buf) (hypb:error err)))))

(defun hui:ebut-buf (&optional prompt)
  "Prompt for and return a buffer in which to place a button."
  (let ((buf-name))
    (while
	(progn
	  (setq buf-name
		(hargs:read-match
		 (or prompt "Button's buffer: ")
		 (delq nil
		       (mapcar
			(function
			  (lambda (buf)
			   (let ((b (buffer-name buf)))
			     (if (and (not (string-match "mail\\*" b))
				      (not (string-match "\\*post-news\\*" b))
				      (string-match "\\`[* ]" b))
				 nil 
			       (cons b nil)))))
			(buffer-list)))
		 nil t (buffer-name) 'buffer))
	  (or (null buf-name) (equal buf-name "")))
      (beep))
  (get-buffer buf-name)))

(defun hui:ebut-delete-op (interactive but-key key-src)
  "INTERACTIVEly or not deletes explicit Hyperbole button given by BUT-KEY in KEY-SRC.
KEY-SRC may be a buffer or a pathname, when nil the current buffer is used.
Returns t if button is deleted, signals error otherwise.  If called
with INTERACTIVE non-nil, derives BUT-KEY from the button that point is
within."
  (let ((buf (current-buffer)) (ebut))
    (if (if interactive
	    (ebut:delete)
	  (cond ((or (null key-src) (and (bufferp key-src) (setq buf key-src)))
		 (setq ebut (ebut:get but-key key-src)))
		((and (stringp key-src)
		      (setq buf (find-file-noselect key-src)))
		 (setq ebut (ebut:get but-key buf)))
		(t (hypb:error "(ebut-delete): Invalid key-src: '%s'." key-src)))
	  (if ebut
	      (ebut:delete ebut)
	    (hypb:error "(ebut-delete): No valid %s button in %s."
		   (ebut:key-to-label but-key) buf))
	  )
	(progn (set-buffer buf)
	       (if interactive
		   (progn
		     (call-interactively 'hui:ebut-unmark)
		     (message "Button deleted."))
		 (hui:ebut-unmark but-key key-src))
	       (if (hmail:reader-p) (hmail:msg-narrow))
	       )
      (hypb:error "(ebut-delete): You may not delete buttons from this buffer."))))

(defun hui:ebut-delimit (start end instance-str)
  (hypb:error "(hui:ebut-delimit): Obsolete, use ebut:delimit instead."))

(defun hui:ebut-operate (curr-label new-label)
  (hypb:error "(hui:ebut-operate): Obsolete, use ebut:operate instead."))

(defun hui:ebut-unmark (&optional but-key key-src directory)
  "Remove delimiters from button given by BUT-KEY in KEY-SRC of DIRECTORY.
All args are optional, the current button and buffer file are the defaults."
  (interactive)
  (let ((form (function
	       (lambda ()
		 (let ((buffer-read-only) start end)
		   (setq start (match-beginning 0)
			 end (match-end 0))
		   (and (fboundp 'hproperty:but-delete)
			(hproperty:but-delete start))
		   (skip-chars-backward " \t\n")
		   (skip-chars-backward "0-9")
		   (if (= (preceding-char) (string-to-char ebut:instance-sep))
		       (setq start (1- (point))))
		   (if (search-backward ebut:start (- (point) ebut:max-len) t)
		       (if current-prefix-arg
			   ;; Remove button label, delimiters and preceding
			   ;; space, if any.
			   (delete-region (max (point-min)
					       (1- (match-beginning 0)))
					  end)
			 ;;
			 ;; Remove button delimiters only.
			 ;;
			 ;; Remove button ending delimiter
			 (delete-region start end)
			 ;; Remove button starting delimiter
			 (delete-region (match-beginning 0)
					(match-end 0)))))))))
    (if (interactive-p)
	(save-excursion
	  (if (search-forward ebut:end nil t) (funcall form)))
      ;; Non-interactive invocation.
      (let ((cur-p))
	(if (and (or (null key-src) (eq key-src buffer-file-name))
		 (or (null directory) (eq directory default-directory)))
	    (setq cur-p t)
	  (set-buffer (find-file-noselect
			(expand-file-name key-src directory))))
	(save-excursion
	  (goto-char (point-min))
	  (if (re-search-forward (ebut:label-regexp but-key) nil t)
	      (progn (funcall form)
		     ;; If modified a buffer other than the current one,
		     ;; save it.
		     (or cur-p (save-buffer)))))))))

(defun hui:file-find (file-name)
  "If FILE-NAME is readable, finds it, else signals an error."
  (if (and (stringp file-name) (file-readable-p file-name))
      (find-file file-name)
    (hypb:error "(file-find): \"%s\" does not exist or is not readable."
	   file-name)))

(defun hui:hbut-term-highlight (start end)
  "For terminals only: Emphasize a button spanning from START to END."
  (save-restriction
    (save-excursion
      (goto-char start)
      (narrow-to-region (point-min) start)
      (sit-for 0)
      (setq inverse-video t)
      (goto-char (point-min))
      (widen)
      (narrow-to-region (point) end)
      (sit-for 0)
      (setq inverse-video nil)
      )))

(defun hui:hbut-term-unhighlight (start end)
  "For terminals only: Remove any emphasis from hyper-button at START to END."
  (save-restriction
    (save-excursion
      (goto-char start)
      (narrow-to-region (point-min) start)
      (sit-for 0)
      (setq inverse-video nil))))

(defun hui:help-ebut-highlight ()
  "Highlight any explicit buttons in help buffer associated with current buffer."
  (if (fboundp 'hproperty:but-create)
      (save-excursion
	(set-buffer
	 (get-buffer (hypb:help-buf-name)))
	(hproperty:but-create))))

(defun hui:htype-delete (htype-sym)
  "Deletes HTYPE-SYM from use in current Hyperbole session.
HTYPE-SYM must be redefined for use again."
  (and htype-sym (symbolp htype-sym)
       (let ((type
	      (intern (hargs:read-match
		       (concat "Delete from " (symbol-name htype-sym) ": ")
		       (mapcar 'list (htype:names htype-sym))
		       nil t nil htype-sym))))
	 (htype:delete type htype-sym))))

(defun hui:htype-help (htype-sym &optional no-sort)
  "Displays documentation for types from HTYPE-SYM which match to a regexp.
Optional NO-SORT means display in decreasing priority order (natural order)."
  (and htype-sym (symbolp htype-sym)
       (let* ((tstr (symbol-name htype-sym))
	      (tprefix (concat tstr "::"))
	      (buf-name (hypb:help-buf-name (capitalize tstr)))
	      (temp-buffer-show-hook
	       (function
		 (lambda (buf)
		  (set-buffer buf) (goto-char (point-min))
		  (replace-regexp "^" "  ") (goto-char (point-min))
		  (replace-string (concat "  " tprefix) "") 
		  (goto-char (point-min)) (set-buffer-modified-p nil)
		  (display-buffer buf nil))))
	      (temp-buffer-show-function temp-buffer-show-hook)
	      (names (htype:names htype-sym))
	      (term (hargs:read-match
		     (concat (capitalize tstr)
			     " to describe (RTN for all): ")
		     (mapcar 'list (cons "" names))
		     nil t nil htype-sym))
	      nm-list
	      doc-list)
	 (setq nm-list
	       (if (string= term "")
		   (let ((type-names
			   (mapcar (function (lambda (nm) (concat tprefix nm)))
				   names)))
		     (if no-sort type-names
		       (sort type-names 'string<)))
		 (cons (concat tprefix term) nil))
	       doc-list (delq nil (mapcar
				    (function
				      (lambda (name)
					(let ((doc (documentation
						     (intern-soft name))))
					  (if doc (cons name doc)))))
				    nm-list)))
	 (with-output-to-temp-buffer buf-name
	   (mapcar (function (lambda (nm-doc-cons)
			       (princ (car nm-doc-cons)) (terpri)
			       (princ (cdr nm-doc-cons)) (terpri)))
		   doc-list)))))

(defun hui:key-dir (but-buf)
  "Returns button key src directory based on BUT-BUF, a buffer."
  (if (bufferp but-buf)
      (let ((file (buffer-file-name but-buf)))
	(if file
	    (file-name-directory (hpath:symlink-referent file))
	  (cdr (assq 'default-directory (buffer-local-variables but-buf)))))
    (hypb:error "(hui:key-dir): '%s' is not a valid buffer.")))

(defun hui:key-src (but-buf)
  "Returns button key src location based on BUT-BUF, a buffer.
This is BUT-BUF when button data is stored in the buffer and the
button's source file name when the button data is stored externally."
  (save-excursion
    (set-buffer but-buf)
    (cond ((hmail:mode-is-p) but-buf)
	  ((hpath:symlink-referent (buffer-file-name but-buf)))
	  (t but-buf))))

(defun hui:link-create (modify but-window lbl-key but-loc but-dir type-and-args)
  "Creates or modifies a new Hyperbole button.
If MODIFY is non-nil, modifies button at point in BUT-WINDOW,
otherwise, prompts for button label and creates a button.
LBL-KEY is internal form of button label.  BUT-LOC is file or buffer
in which to create button.  BUT-DIR is directory of BUT-LOC.
TYPE-AND-ARGS is the action type for the button followed by any arguments it requires."
  (hattr:set 'hbut:current 'loc but-loc)
  (hattr:set 'hbut:current 'dir but-dir)
  (hattr:set 'hbut:current 'actype (intern-soft
				     (concat "actypes::"
					     (symbol-name
					       (car type-and-args)))))
  (hattr:set 'hbut:current 'args (cdr type-and-args))

  (select-window but-window)
  (let ((label (ebut:key-to-label lbl-key)))
    (ebut:operate label (if modify label)))
  )

(defun hui:link-possible-types ()
  "Returns list of possible link types for a Hyperbole button link to point.
Each list element is a list of the link type and any arguments it requires.

The link types considered are fixed.  Defining new link types will not alter
the possible types.  The code must be changed to do that.

Referent Context         Possible Link Type Returned
----------------------------------------------------
Explicit Button          link-to-ebut
  or
Info Node                link-to-Info-node
  or
Mail Reader Msg          link-to-mail

Outline Regexp Prefix    link-to-string-match
  or
Directory Name           link-to-directory
  or
File Name                link-to-file
  or
Koutline Cell            link-to-kcell
  or
Buffer attached to File  link-to-file
  or
Buffer without File      link-to-buffer-tmp

Elisp Buffer at Start
or End of Sexpression    eval-elisp
"
  (let (val)
    (delq nil
	  (list (if (ebut:at-p)
		    (list 'link-to-ebut buffer-file-name (ebut:label-p)))
		(cond ((eq major-mode 'Info-mode)
		       (let ((hargs:reading-p 'Info-node))
			 (list 'link-to-Info-node (hargs:at-p))))
		      ((hmail:reader-p)
		       (list 'link-to-mail
			     (list (rmail:msg-id-get) buffer-file-name)))
		      )
		(cond
		 ;; If link is within an outline-regexp prefix, use
		 ;; a link-to-string-match.
		 ((and (boundp 'outline-regexp)
		       (stringp outline-regexp)
		       (save-excursion
			 (<= (point)
			     (progn
			       (beginning-of-line)
			       (if (looking-at outline-regexp)
				   (match-end 0)
				 0)))))
		  (save-excursion
		    (end-of-line)
		    (let ((heading (buffer-substring
				    (point)
				    (progn (beginning-of-line) (point))))
			  (occur 1))
		      (while (search-backward heading nil t)
			(setq occur (1+ occur)))
		      (list 'link-to-string-match
			    heading occur buffer-file-name))))
		 ((let ((hargs:reading-p 'directory))
		    (setq val (hargs:at-p t)))
		  (list 'link-to-directory val))
		 ((let ((hargs:reading-p 'file))
		    (setq val (hargs:at-p t)))
		  (list 'link-to-file val (point)))
		 ((eq major-mode 'kotl-mode)
		  (list 'link-to-kcell buffer-file-name (kcell-view:idstamp)))
		 (buffer-file-name
		  (list 'link-to-file buffer-file-name (point)))
		 (t (list 'link-to-buffer-tmp (buffer-name)))
		 )
		(and (fboundp 'smart-emacs-lisp-mode-p)
		     (smart-emacs-lisp-mode-p)
		     (or (= (char-syntax (following-char)) ?\()
			 (= (char-syntax (preceding-char)) ?\)))
		     (setq val (hargs:sexpression-p))
		     (list 'eval-elisp val))
		))))


;;;
;;; Private variables
;;;


(defvar hui:ebut-label-prev nil
  "String value of previous button name during an explicit button rename.
At other times, values must be nil.")

(provide 'hui)

;;; hui.el ends here