cgit.sxemacs.org Git - packages/blob - xemacs-packages/hyperbole/hui.el

   1 ;;; hui.el --- GNU Emacs User Interface to Hyperbole
   2
   3 ;; Copyright (C) 1991-1995, 2008 Free Software Foundation, Inc.
   4 ;; Developed with support from Motorola Inc.
   5
   6 ;; Author: Bob Weiner, Brown U.
   7 ;; Maintainer: Mats Lidell <matsl@contactor.se>
   8 ;; Keywords: hypermedia
   9
  10 ;; This file is part of GNU Hyperbole.
  11
  12 ;; GNU Hyperbole is free software; you can redistribute it and/or
  13 ;; modify it under the terms of the GNU General Public License as
  14 ;; published by the Free Software Foundation; either version 3, or (at
  15 ;; your option) any later version.
  16
  17 ;; GNU Hyperbole is distributed in the hope that it will be useful,
  18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  20 ;; General Public License for more details.
  21
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  24 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  25 ;; Boston, MA 02110-1301, USA.
  26
  27 ;;; Commentary:
  28
  29 ;;; Code:
  30
  31 ;;;
  32 ;;; Other required Elisp libraries
  33 ;;;
  34
  35 (require 'hargs) (require 'set) (require 'hmail)
  36
  37 ;;;
  38 ;;; Public variables
  39 ;;;
  40
  41 (defvar hui:ebut-delete-confirm-p t
  42   "*Non-nil means prompt before interactively deleting explicit buttons.")
  43
  44 ;;;
  45 ;;; Public functions
  46 ;;;
  47
  48 (defun hui:ebut-create (&optional start end)
  49   "Creates an explicit but starting from label between optional START and END.
  50 Indicates by delimiting and adding any necessary instance number of the button
  51 label."
  52   (interactive (list (and (marker-position (hypb:mark-marker t))
  53                           (region-beginning))
  54                      (and (marker-position (hypb:mark-marker t))
  55                           (region-end))))
  56   (let ((default-lbl) lbl but-buf actype)
  57     (save-excursion
  58       (setq default-lbl
  59             (hui:hbut-label-default start end (not (interactive-p)))
  60             lbl (hui:hbut-label default-lbl "ebut-create"))
  61       (if (not (equal lbl default-lbl)) (setq default-lbl nil))
  62
  63       (setq but-buf (if default-lbl (current-buffer) (hui:ebut-buf)))
  64       (hui:buf-writable-err but-buf "ebut-create")
  65
  66       (hattr:set 'hbut:current 'loc (hui:key-src but-buf))
  67       (hattr:set 'hbut:current 'dir (hui:key-dir but-buf))
  68       (setq actype (hui:actype))
  69       (hattr:set 'hbut:current 'actype actype)
  70       (hattr:set 'hbut:current 'args (hargs:actype-get actype))
  71       (hattr:set 'hbut:current 'action
  72                  (and (boundp 'hui:ebut-prompt-for-action)
  73                       hui:ebut-prompt-for-action (hui:action actype)))
  74       )
  75     (ebut:operate lbl nil)))
  76
  77 (defun hui:ebut-delete (but-key &optional key-src)
  78   "Deletes explicit Hyperbole button given by BUT-KEY in optional KEY-SRC.
  79 KEY-SRC may be a buffer or a pathname, when nil the current buffer is used.
  80 Returns t if button is deleted, nil if user chooses not to delete or signals
  81 an error otherwise.  If called interactively, prompts user whether to delete
  82 and derives BUT-KEY from the button that point is within.
  83 Signals an error if point is not within a button."
  84   (interactive (list (if (ebut:at-p)
  85                          (hattr:get 'hbut:current 'lbl-key)
  86                        nil)))
  87   (cond ((null but-key)
  88          (hypb:error
  89           "(ebut-delete): Point is not over the label of an existing button."))
  90         ((not (stringp but-key))
  91          (hypb:error
  92           "(ebut-delete): Invalid label key argument: '%s'." but-key)))
  93   (let ((interactive (interactive-p)))
  94     (if (and hui:ebut-delete-confirm-p interactive)
  95         (if (y-or-n-p (format "Delete button %s%s%s? "
  96                               ebut:start
  97                               (hbut:key-to-label but-key) ebut:end))
  98             (hui:ebut-delete-op interactive but-key key-src)
  99           (message ""))
 100       (hui:ebut-delete-op interactive but-key key-src))))
 101
 102 (defun hui:ebut-edit ()
 103   "Creates or modifies an explicit Hyperbole button when conditions are met.
 104 A region must have been delimited with the action-key and point must now be
 105 within it before this function is called or it will do nothing.  The region
 106 must be no larger than the size given by 'ebut:max-len'.  It must be entirely
 107 within or entirely outside of an existing explicit button.  When region is
 108 within the button, the button is interactively modified.  Otherwise, a new
 109 button is created interactively with the region as the default label."
 110   (interactive)
 111   (let ((m (marker-position (hypb:mark-marker t)))
 112         (op action-key-depress-prev-point) (p (point)) (lbl-key))
 113     (if (and m (eq (marker-buffer m) (marker-buffer op))
 114              (< op m) (<= (- m op) ebut:max-len)
 115              (<= p m) (<= op p))
 116         (progn
 117           (if (setq lbl-key (ebut:label-p))
 118               (hui:ebut-modify lbl-key)
 119             (hui:ebut-create op m))
 120           t))))
 121
 122 (defun hui:ebut-modify (lbl-key)
 123   "Modifies an explicit Hyperbole button given by LBL-KEY.
 124 Signals an error when no such button is found in the current buffer."
 125   (interactive (list (save-excursion
 126                        (hui:buf-writable-err (current-buffer) "ebut-modify")
 127                        (or (ebut:label-p)
 128                            (ebut:label-to-key
 129                             (hargs:read-match "Button to modify: "
 130                                               (ebut:alist) nil t
 131                                               nil 'ebut))))))
 132   (let ((lbl (ebut:key-to-label lbl-key))
 133         (but-buf (current-buffer))
 134         actype but new-lbl)
 135     (save-excursion
 136       (or (interactive-p)
 137           (hui:buf-writable-err but-buf "ebut-modify"))
 138
 139       (or (setq but (ebut:get lbl-key but-buf))
 140           (progn (pop-to-buffer but-buf)
 141                  (hypb:error "(ebut-modify): Invalid button, no data for '%s'." lbl)))
 142
 143       (setq new-lbl
 144             (hargs:read
 145              "Change button label to: "
 146              (function
 147                (lambda (lbl)
 148                 (and (not (string= lbl "")) (<= (length lbl) ebut:max-len))))
 149              lbl
 150              (format "(ebut-modify): Enter a string of at most %s chars."
 151                      ebut:max-len)
 152              'string))
 153
 154       (hattr:set 'hbut:current 'loc (hui:key-src but-buf))
 155       (hattr:set 'hbut:current 'dir (hui:key-dir but-buf))
 156       (setq actype (hui:actype (hattr:get but 'actype)))
 157       (hattr:set 'hbut:current 'actype actype)
 158       (hattr:set 'hbut:current 'args (hargs:actype-get actype 'modifying))
 159       (hattr:set 'hbut:current 'action
 160                  (and (boundp 'hui:ebut-prompt-for-action)
 161                       hui:ebut-prompt-for-action (hui:action actype)))
 162       )
 163     (ebut:operate lbl new-lbl)))
 164
 165 (defun hui:ebut-rename (curr-label new-label)
 166   "Renames explicit Hyperbole button given by CURR-LABEL to NEW-LABEL.
 167 If called interactively when point is not within an explicit button:
 168    prompts for old and new button label values and performs rename.
 169 If called interactively when point is within an explicit button:
 170    saves button label and tells user to edit label, then call again.
 171    second call changes the button's name from the stored value to the
 172    edited value.
 173 Signals an error if any problem occurs."
 174   (interactive
 175    (save-excursion
 176      (let (curr-label new-label)
 177        (hui:buf-writable-err (current-buffer) "ebut-rename")
 178        (if hui:ebut-label-prev
 179            (setq curr-label hui:ebut-label-prev
 180                  new-label (ebut:label-p 'as-label))
 181          (setq new-label nil
 182                curr-label
 183                (or (ebut:label-p 'as-label)
 184                    (let ((buts (ebut:alist)))
 185                      (if (null buts)
 186                          (hypb:error "(ebut-rename): No explicit buttons in buffer.")
 187                        (prog1 (hargs:read-match
 188                                "Button label to rename: "
 189                                buts nil t nil 'ebut)
 190                          (setq new-label
 191                                (hargs:read
 192                                 "Rename button label to: "
 193                                 (function
 194                                   (lambda (lbl)
 195                                    (and (not (string= lbl ""))
 196                                         (<= (length lbl) ebut:max-len))))
 197                                 curr-label
 198                                 (format
 199                                  "(ebut-rename): Use a quoted string of at most %s chars."
 200                                  ebut:max-len)
 201                                 'string))))))))
 202        (list curr-label new-label))))
 203
 204   (save-excursion
 205     (if (interactive-p)
 206         nil
 207       (hui:buf-writable-err (current-buffer) "ebut-rename")
 208       (if (or (not (stringp curr-label)) (string= curr-label ""))
 209           (hypb:error "(ebut-rename): 'curr-label' must be a non-empty string: %s"
 210                  curr-label))
 211       (and (stringp new-label) (string= new-label "")
 212            (hypb:error "(ebut-rename): 'new-label' must be a non-empty string: %s"
 213                   new-label)))
 214     (or (ebut:get (ebut:label-to-key curr-label))
 215         (hypb:error "(ebut-rename): Can't rename %s since no button data."
 216                curr-label))
 217     )
 218   (cond (new-label
 219          (ebut:operate curr-label new-label)
 220          (setq hui:ebut-label-prev nil)
 221          (message "Renamed from '%s' to '%s'." curr-label new-label))
 222         (curr-label
 223          (setq hui:ebut-label-prev curr-label)
 224          (message "Edit button label and use same command to finish rename."))
 225         (t (hypb:error "(ebut-rename): Move point to within a button label."))))
 226
 227 (defun hui:ebut-search (string &optional match-part)
 228   "Shows lines of files/buffers containing an explicit but match for STRING.
 229 Returns number of buttons matched and displayed.
 230 By default, only matches for whole button labels are found, optional MATCH-PART
 231 enables partial matches.  The match lines are shown in a buffer which serves as
 232 a menu to find any of the occurrences."
 233   (interactive (list (read-string "Search for button string: ")
 234                      (y-or-n-p "Enable partial matches? ")))
 235   (if (not (stringp string))
 236       (hypb:error "(ebut-search): String to search for is required."))
 237   (let*  ((prefix (if (> (length string) 14)
 238                       (substring string 0 13) string))
 239           (out-buf (get-buffer-create (concat "*" prefix " Hypb Search*")))
 240           (total (ebut:search string out-buf match-part)))
 241     (if (> total 0)
 242         (progn
 243           (set-buffer out-buf)
 244           (moccur-mode)
 245           (if (fboundp 'outline-minor-mode)
 246               (and (progn (goto-char 1)
 247                           (search-forward "\C-m" nil t))
 248                    (outline-minor-mode 1)))
 249           (if (fboundp 'hproperty:but-create)
 250               (hproperty:but-create nil nil (regexp-quote
 251                                       (if match-part string
 252                                         (concat ebut:start string ebut:end)))))
 253           (goto-char (point-min))
 254           (pop-to-buffer out-buf)
 255           (if (interactive-p) (message "%d match%s." total
 256                                        (if (> total 1) "es" ""))
 257             total))
 258       (if (interactive-p) (message "No matches.")
 259         total))))
 260
 261 (defun hui:error (&rest args)
 262   (hypb:error "(hui:error): Obsolete, use hypb:error instead."))
 263
 264 (defun hui:gbut-create (lbl)
 265   "Creates Hyperbole global button with LBL."
 266   (interactive "sCreate global button labeled: ")
 267   (let (but-buf actype)
 268     (save-excursion
 269       (setq actype (hui:actype))
 270       (setq but-buf (set-buffer (find-file-noselect gbut:file)))
 271       (hui:buf-writable-err but-buf "ebut-create")
 272       ;; This prevents movement of point which might be useful to user.
 273       (save-excursion
 274         (goto-char (point-max))
 275         (hattr:set 'hbut:current 'loc (hui:key-src but-buf))
 276         (hattr:set 'hbut:current 'dir (hui:key-dir but-buf))
 277         (hattr:set 'hbut:current 'actype actype)
 278         (hattr:set 'hbut:current 'args (hargs:actype-get actype))
 279         (hattr:set 'hbut:current 'action
 280                    (and (boundp 'hui:ebut-prompt-for-action)
 281                         hui:ebut-prompt-for-action (hui:action actype)))
 282         (setq lbl (concat lbl (ebut:operate lbl nil)))
 283         (goto-char (point-max))
 284         (insert "\n")
 285         (save-buffer)
 286         )
 287       (message "%s created." lbl)
 288       )))
 289
 290 (defun hui:gbut-modify (lbl-key)
 291   "Modifies a global Hyperbole button given by LBL-KEY.
 292 Signals an error when no such button is found."
 293   (interactive (list (save-excursion
 294                        (hui:buf-writable-err
 295                         (find-file-noselect gbut:file) "gbut-modify")
 296                        (hbut:label-to-key
 297                         (hargs:read-match "Global button to modify: "
 298                                           (mapcar 'list (gbut:lbl-list))
 299                                           nil t nil 'ebut)))))
 300   (let ((lbl (hbut:key-to-label lbl-key))
 301         (but-buf (find-file-noselect gbut:file))
 302         actype but new-lbl)
 303     (save-excursion
 304       (or (interactive-p)
 305           (hui:buf-writable-err but-buf "gbut-modify"))
 306
 307       (or (setq but (ebut:get lbl-key but-buf))
 308           (progn (pop-to-buffer but-buf)
 309                  (hypb:error
 310                   "(gbut-modify): Invalid button, no data for '%s'." lbl)))
 311
 312       (setq new-lbl
 313             (hargs:read
 314              "Change global button label to: "
 315              (function
 316                (lambda (lbl)
 317                 (and (not (string= lbl "")) (<= (length lbl) ebut:max-len))))
 318              lbl
 319              (format "(gbut-modify): Enter a string of at most %s chars."
 320                      ebut:max-len)
 321              'string))
 322
 323       (hattr:set 'hbut:current 'loc (hui:key-src but-buf))
 324       (hattr:set 'hbut:current 'dir (hui:key-dir but-buf))
 325       (setq actype (hui:actype (hattr:get but 'actype)))
 326       (hattr:set 'hbut:current 'actype actype)
 327       (hattr:set 'hbut:current 'args (hargs:actype-get actype 'modifying))
 328       (hattr:set 'hbut:current 'action
 329                  (and (boundp 'hui:ebut-prompt-for-action)
 330                       hui:ebut-prompt-for-action (hui:action actype)))
 331       (set-buffer but-buf)
 332       (ebut:operate lbl new-lbl))))
 333
 334 (defun hui:hbut-act (&optional but)
 335   "Executes action for optional Hyperbole button symbol BUT in current buffer.
 336 Default is the current button."
 337   (interactive
 338    (let ((but (hbut:at-p)) (lst))
 339      (list
 340       (cond (but)
 341             ((setq lst (ebut:alist))
 342              (ebut:get (ebut:label-to-key
 343                         (hargs:read-match "Button to execute: " lst nil t
 344                                           (ebut:label-p 'as-label) 'ebut))))
 345             (t (hypb:error "(hbut-act): No explicit buttons in buffer."))))))
 346   (cond ((and (interactive-p) (null but))
 347          (hypb:error "(hbut-act): No current button to activate."))
 348         ((not (hbut:is-p but))
 349          (hypb:error "(hbut-act): Button is invalid; it has no attributes."))
 350         (t (or but (setq but 'hbut:current))
 351            (hui:but-flash) (hyperb:act but))))
 352
 353 (defun hui:hbut-help (&optional but)
 354   "Checks for and explains an optional button given by symbol, BUT.
 355 BUT defaults to the button whose label point is within."
 356   (interactive)
 357   (setq but (or but (hbut:at-p)
 358                 (ebut:get (ebut:label-to-key
 359                            (hargs:read-match "Help for button: "
 360                                              (ebut:alist) nil t nil 'ebut)))))
 361   (or but
 362       (hypb:error "(hbut-help):  Move point to a valid Hyperbole button."))
 363   (if (not (hbut:is-p but))
 364       (cond (but (hypb:error "(hbut-help): Invalid button."))
 365             (t   (hypb:error
 366                   "(hbut-help): Not on an implicit button and no buffer explicit buttons."))))
 367   (let* ((sym-name (htype:names 'ibtypes (hattr:get but 'categ)))
 368          (type-help-func (if sym-name (intern-soft (concat sym-name ":help")))))
 369     (or (equal (hypb:indirect-function 'hui:but-flash)
 370                (function (lambda nil)))
 371         ;; Only flash button if point is on it.
 372         (let ((lbl-key (hattr:get but 'lbl-key)))
 373           (and lbl-key
 374                (or (equal lbl-key (ebut:label-p))
 375                    (equal lbl-key (ibut:label-p)))
 376                (hui:but-flash))))
 377     (if type-help-func
 378         (funcall type-help-func but)
 379       (let ((total (hbut:report but)))
 380         (if total (hui:help-ebut-highlight))))))
 381
 382 (defun hui:hbut-label (default-label func-name)
 383   "Reads button label from user using DEFAULT-LABEL and caller's FUNC-NAME."
 384   (hargs:read "Button label: "
 385               (function
 386                 (lambda (lbl)
 387                   (and (not (string= lbl "")) (<= (length lbl) ebut:max-len))))
 388               default-label
 389               (format "(%s): Enter a string of at most %s chars."
 390                       func-name ebut:max-len)
 391               'string))
 392
 393 (defun hui:hbut-label-default (start end &optional skip-len-test)
 394   "Returns default label based on START and END region markers or points.
 395 Optional SKIP-LEN-TEST means don't limit label to 'ebut:max-len' length.
 396 Returns nil if START or END are invalid or if region fails length test.
 397
 398 Also has side effect of moving point to start of default label, if any."
 399   (if (markerp start) (setq start (marker-position start)))
 400   (if (markerp end) (setq end (marker-position end)))
 401   ;; Test whether to use region as default button label.
 402   (if (and (integerp start) (integerp end)
 403            (or skip-len-test
 404                (<= (max (- end start) (- start end)) ebut:max-len)))
 405       (progn (goto-char start)
 406              (buffer-substring start end))))
 407
 408 (defun hui:hbut-report (&optional arg)
 409   "Pretty prints attributes of current button, using optional prefix ARG.
 410 See 'hbut:report'."
 411   (interactive "P")
 412   (if (and arg (symbolp arg))
 413       (hui:hbut-help arg)
 414     (let ((total (hbut:report arg)))
 415       (if total
 416           (progn (hui:help-ebut-highlight)
 417                  (message "%d button%s." total (if (/= total 1) "s" "")))))))
 418
 419 (fset 'hui:hbut-summarize 'hui:hbut-report)
 420
 421 (defun hui:link-directly ()
 422   "Creates a Hyperbole link button at depress point, linked to release point.
 423 See also documentation for 'hui:link-possible-types'."
 424   (let* ((link-types (hui:link-possible-types))
 425          (but-window action-key-depress-window)
 426          (num-types (length link-types))
 427          (release-window (selected-window))
 428          (but-modify nil)
 429          type-and-args lbl-key but-loc but-dir)
 430     (select-window action-key-depress-window)
 431     (hui:buf-writable-err (current-buffer) "link-directly")
 432     (if (ebut:at-p)
 433         (progn
 434           (setq but-modify t
 435                 but-loc (hattr:get 'hbut:current 'loc)
 436                 but-dir (hattr:get 'hbut:current 'dir)
 437                 lbl-key (hattr:get 'hbut:current 'lbl-key)))
 438       (setq but-loc (hui:key-src (current-buffer))
 439             but-dir (hui:key-dir (current-buffer))
 440             lbl-key (hbut:label-to-key
 441                       (hui:hbut-label
 442                         (if (marker-position (hypb:mark-marker t))
 443                             (hui:hbut-label-default
 444                               (region-beginning) (region-end)))
 445                         "link-directly"))))
 446
 447     ;; XEmacs 21.5 thinks windows isn't live. Bug!?
 448     (if (window-live-p release-window)
 449         (select-window release-window))
 450
 451     (cond ((= num-types 0)
 452            (error "(link-directly): No possible link type to create."))
 453           ((= num-types 1)
 454            (hui:link-create but-modify
 455                             but-window lbl-key but-loc but-dir
 456                             (setq type-and-args (car link-types))))
 457           (t;; more than 1
 458             (let ((item)
 459                   type)
 460               (hui:link-create
 461                 but-modify but-window
 462                 lbl-key but-loc but-dir
 463                 (setq type-and-args
 464                       (hui:menu-select
 465                         (cons '("Link to>")
 466                               (mapcar
 467                                 (function
 468                                   (lambda (type-and-args)
 469                                     (setq type (car type-and-args))
 470                                     (list
 471                                       (capitalize
 472                                         (if (string-match
 473                                               "^\\(link-to\\|eval\\)-"
 474                                               (setq item (symbol-name type)))
 475                                             (setq item (substring
 476                                                          item (match-end 0)))
 477                                           item))
 478                                       type-and-args
 479                                       (documentation
 480                                        (intern (concat "actypes::"
 481                                                        (symbol-name type)))))))
 482                                 link-types))))))))
 483     (message "`%s' button %s type `%s'."
 484              (hbut:key-to-label lbl-key)
 485              (if but-modify "set to" "created with")
 486              (car type-and-args))))
 487
 488 ;;;
 489 ;;; Private functions
 490 ;;;
 491
 492 (defun hui:action (actype &optional prompt)
 493   "Prompts for and returns an action to override action from ACTYPE."
 494   (and actype
 495        (let* ((act) (act-str)
 496               (params (actype:params actype))
 497               (params-str (and params (concat " " (prin1-to-string params))))
 498               )
 499          (while (progn
 500                  (while (and (setq act-str
 501                                    (hargs:read
 502                                     (or prompt (concat "Action" params-str
 503                                                        ": ")) nil nil
 504                                                        nil 'string))
 505                              (not (string= act-str ""))
 506                              (condition-case ()
 507                                  (progn (setq act (read act-str)) nil)
 508                                (error
 509                                 (beep) (message "Invalid action syntax.")
 510                                 (sit-for 3) t))))
 511                  (and (not (symbolp act))
 512                       params
 513                       ;; Use the weak condition that action must
 514                       ;; involve at least one of actype's parameters
 515                       ;; or else we assume the action is invalid, tell
 516                       ;; the user and provide another chance for entry.
 517                       (not (memq t
 518                                  (mapcar
 519                                   (function
 520                                     (lambda (param)
 521                                      (setq param (symbol-name param))
 522                                      (and (string-match
 523                                            (concat "[\( \t\n,']"
 524                                                    (regexp-quote param)
 525                                                    "[\(\) \t\n\"]")
 526                                            act-str)
 527                                           t)))
 528                                   params)))
 529                       ))
 530            (beep) (message "Action must use at least one parameter.")
 531            (sit-for 3))
 532          (let (head)
 533            (while (cond ((listp act)
 534                          (and act (setq head (car act))
 535                               (not (or (eq head 'lambda)
 536                                        (eq head 'defun)
 537                                        (eq head 'defmacro)))
 538                               (setq act (list 'lambda params act))
 539                               nil  ;; terminate loop
 540                               ))
 541                         ((symbolp act)
 542                          (setq act (cons act params)))
 543                         ((stringp act)
 544                          (setq act (action:kbd-macro act 1)))
 545                         ;; Unrecognized form
 546                         (t (setq act nil))
 547                         )))
 548          act)))
 549
 550 (defun hui:actype (&optional default-actype prompt)
 551   "Using optional DEFAULT-ACTYPE, PROMPTs for a button action type.
 552 DEFAULT-ACTYPE may be a valid symbol or symbol-name."
 553   (and default-actype (symbolp default-actype)
 554        (progn
 555          (setq default-actype (symbol-name default-actype))
 556          (if (string-match "actypes::" default-actype)
 557              (setq default-actype (substring default-actype (match-end 0))))))
 558   (if (or (null default-actype) (stringp default-actype))
 559       (intern-soft
 560        (concat "actypes::"
 561                (hargs:read-match (or prompt "Button's action type: ")
 562                                 (mapcar 'list (htype:names 'actypes))
 563                                 nil t default-actype 'actype)))
 564     (hypb:error "(actype): Invalid default action type received.")
 565     ))
 566
 567 (defun hui:buf-writable-err (but-buf func-name)
 568   "If BUT-BUF is read-only or is unwritable, signal an error from FUNC-NAME."
 569   (let ((obuf (prog1 (current-buffer) (set-buffer but-buf)))
 570         ;; (unwritable (and buffer-file-name
 571         ;;               (not (file-writable-p buffer-file-name))))
 572         (err))
 573     ;; (if unwritable
 574     ;;     Commented error out since some people want to be able to create
 575     ;;     buttons within files which they have purposely marked read-only.
 576     ;;     (setq err
 577     ;;       (format "(ebut-modify): You are not allowed to modify '%s'."
 578     ;;               (file-name-nondirectory buffer-file-name))))
 579     (if buffer-read-only
 580         (setq err
 581               (format
 582                "Button buffer '%s' is read-only.  Use %s to change it."
 583                (buffer-name but-buf)
 584                (hypb:cmd-key-string
 585                 (if (where-is-internal 'vc-toggle-read-only)
 586                     'vc-toggle-read-only 'toggle-read-only))
 587                )))
 588     (set-buffer obuf)
 589     (if err (progn (pop-to-buffer but-buf) (hypb:error err)))))
 590
 591 (defun hui:ebut-buf (&optional prompt)
 592   "Prompt for and return a buffer in which to place a button."
 593   (let ((buf-name))
 594     (while
 595         (progn
 596           (setq buf-name
 597                 (hargs:read-match
 598                  (or prompt "Button's buffer: ")
 599                  (delq nil
 600                        (mapcar
 601                         (function
 602                           (lambda (buf)
 603                            (let ((b (buffer-name buf)))
 604                              (if (and (not (string-match "mail\\*" b))
 605                                       (not (string-match "\\*post-news\\*" b))
 606                                       (string-match "\\`[* ]" b))
 607                                  nil
 608                                (cons b nil)))))
 609                         (buffer-list)))
 610                  nil t (buffer-name) 'buffer))
 611           (or (null buf-name) (equal buf-name "")))
 612       (beep))
 613   (get-buffer buf-name)))
 614
 615 (defun hui:ebut-delete-op (interactive but-key key-src)
 616   "INTERACTIVEly or not deletes explicit Hyperbole button given by BUT-KEY in KEY-SRC.
 617 KEY-SRC may be a buffer or a pathname, when nil the current buffer is used.
 618 Returns t if button is deleted, signals error otherwise.  If called
 619 with INTERACTIVE non-nil, derives BUT-KEY from the button that point is
 620 within."
 621   (let ((buf (current-buffer)) (ebut))
 622     (if (if interactive
 623             (ebut:delete)
 624           (cond ((or (null key-src) (and (bufferp key-src) (setq buf key-src)))
 625                  (setq ebut (ebut:get but-key key-src)))
 626                 ((and (stringp key-src)
 627                       (setq buf (find-file-noselect key-src)))
 628                  (setq ebut (ebut:get but-key buf)))
 629                 (t (hypb:error "(ebut-delete): Invalid key-src: '%s'." key-src)))
 630           (if ebut
 631               (ebut:delete ebut)
 632             (hypb:error "(ebut-delete): No valid %s button in %s."
 633                    (ebut:key-to-label but-key) buf))
 634           )
 635         (progn (set-buffer buf)
 636                (if interactive
 637                    (progn
 638                      (call-interactively 'hui:ebut-unmark)
 639                      (message "Button deleted."))
 640                  (hui:ebut-unmark but-key key-src))
 641                (if (hmail:reader-p) (hmail:msg-narrow))
 642                )
 643       (hypb:error "(ebut-delete): You may not delete buttons from this buffer."))))
 644
 645 (defun hui:ebut-delimit (start end instance-str)
 646   (hypb:error "(hui:ebut-delimit): Obsolete, use ebut:delimit instead."))
 647
 648 (defun hui:ebut-operate (curr-label new-label)
 649   (hypb:error "(hui:ebut-operate): Obsolete, use ebut:operate instead."))
 650
 651 (defun hui:ebut-unmark (&optional but-key key-src directory)
 652   "Remove delimiters from button given by BUT-KEY in KEY-SRC of DIRECTORY.
 653 All args are optional, the current button and buffer file are the defaults."
 654   (interactive)
 655   (let ((form (function
 656                (lambda ()
 657                  (let ((buffer-read-only) start end)
 658                    (setq start (match-beginning 0)
 659                          end (match-end 0))
 660                    (and (fboundp 'hproperty:but-delete)
 661                         (hproperty:but-delete start))
 662                    (skip-chars-backward " \t\n")
 663                    (skip-chars-backward "0-9")
 664                    (if (= (preceding-char) (string-to-char ebut:instance-sep))
 665                        (setq start (1- (point))))
 666                    (if (search-backward ebut:start (- (point) ebut:max-len) t)
 667                        (if current-prefix-arg
 668                            ;; Remove button label, delimiters and preceding
 669                            ;; space, if any.
 670                            (delete-region (max (point-min)
 671                                                (1- (match-beginning 0)))
 672                                           end)
 673                          ;;
 674                          ;; Remove button delimiters only.
 675                          ;;
 676                          ;; Remove button ending delimiter
 677                          (delete-region start end)
 678                          ;; Remove button starting delimiter
 679                          (delete-region (match-beginning 0)
 680                                         (match-end 0)))))))))
 681     (if (interactive-p)
 682         (save-excursion
 683           (if (search-forward ebut:end nil t) (funcall form)))
 684       ;; Non-interactive invocation.
 685       (let ((cur-p))
 686         (if (and (or (null key-src) (eq key-src buffer-file-name))
 687                  (or (null directory) (eq directory default-directory)))
 688             (setq cur-p t)
 689           (set-buffer (find-file-noselect
 690                         (expand-file-name key-src directory))))
 691         (save-excursion
 692           (goto-char (point-min))
 693           (if (re-search-forward (ebut:label-regexp but-key) nil t)
 694               (progn (funcall form)
 695                      ;; If modified a buffer other than the current one,
 696                      ;; save it.
 697                      (or cur-p (save-buffer)))))))))
 698
 699 (defun hui:file-find (file-name)
 700   "If FILE-NAME is readable, finds it, else signals an error."
 701   (if (and (stringp file-name) (file-readable-p file-name))
 702       (find-file file-name)
 703     (hypb:error "(file-find): \"%s\" does not exist or is not readable."
 704            file-name)))
 705
 706 (defun hui:hbut-term-highlight (start end)
 707   "For terminals only: Emphasize a button spanning from START to END."
 708   (save-restriction
 709     (save-excursion
 710       (goto-char start)
 711       (narrow-to-region (point-min) start)
 712       (sit-for 0)
 713       (setq inverse-video t)
 714       (goto-char (point-min))
 715       (widen)
 716       (narrow-to-region (point) end)
 717       (sit-for 0)
 718       (setq inverse-video nil)
 719       )))
 720
 721 (defun hui:hbut-term-unhighlight (start end)
 722   "For terminals only: Remove any emphasis from hyper-button at START to END."
 723   (save-restriction
 724     (save-excursion
 725       (goto-char start)
 726       (narrow-to-region (point-min) start)
 727       (sit-for 0)
 728       (setq inverse-video nil))))
 729
 730 (defun hui:help-ebut-highlight ()
 731   "Highlight any explicit buttons in help buffer associated with current buffer."
 732   (if (fboundp 'hproperty:but-create)
 733       (save-excursion
 734         (set-buffer
 735          (get-buffer (hypb:help-buf-name)))
 736         (hproperty:but-create))))
 737
 738 (defun hui:htype-delete (htype-sym)
 739   "Deletes HTYPE-SYM from use in current Hyperbole session.
 740 HTYPE-SYM must be redefined for use again."
 741   (and htype-sym (symbolp htype-sym)
 742        (let ((type
 743               (intern (hargs:read-match
 744                        (concat "Delete from " (symbol-name htype-sym) ": ")
 745                        (mapcar 'list (htype:names htype-sym))
 746                        nil t nil htype-sym))))
 747          (htype:delete type htype-sym))))
 748
 749 (defun hui:htype-help (htype-sym &optional no-sort)
 750   "Displays documentation for types from HTYPE-SYM which match to a regexp.
 751 Optional NO-SORT means display in decreasing priority order (natural order)."
 752   (and htype-sym (symbolp htype-sym)
 753        (let* ((tstr (symbol-name htype-sym))
 754               (tprefix (concat tstr "::"))
 755               (buf-name (hypb:help-buf-name (capitalize tstr)))
 756               (temp-buffer-show-hook
 757                (function
 758                  (lambda (buf)
 759                   (set-buffer buf) (goto-char (point-min))
 760                   (replace-regexp "^" "  ") (goto-char (point-min))
 761                   (replace-string (concat "  " tprefix) "")
 762                   (goto-char (point-min)) (set-buffer-modified-p nil)
 763                   (display-buffer buf nil))))
 764               (temp-buffer-show-function temp-buffer-show-hook)
 765               (names (htype:names htype-sym))
 766               (term (hargs:read-match
 767                      (concat (capitalize tstr)
 768                              " to describe (RTN for all): ")
 769                      (mapcar 'list (cons "" names))
 770                      nil t nil htype-sym))
 771               nm-list
 772               doc-list)
 773          (setq nm-list
 774                (if (string= term "")
 775                    (let ((type-names
 776                            (mapcar (function (lambda (nm) (concat tprefix nm)))
 777                                    names)))
 778                      (if no-sort type-names
 779                        (sort type-names 'string<)))
 780                  (cons (concat tprefix term) nil))
 781                doc-list (delq nil (mapcar
 782                                     (function
 783                                       (lambda (name)
 784                                         (let ((doc (documentation
 785                                                      (intern-soft name))))
 786                                           (if doc (cons name doc)))))
 787                                     nm-list)))
 788          (with-output-to-temp-buffer buf-name
 789            (mapcar (function (lambda (nm-doc-cons)
 790                                (princ (car nm-doc-cons)) (terpri)
 791                                (princ (cdr nm-doc-cons)) (terpri)))
 792                    doc-list)))))
 793
 794 (defun hui:key-dir (but-buf)
 795   "Returns button key src directory based on BUT-BUF, a buffer."
 796   (if (bufferp but-buf)
 797       (let ((file (buffer-file-name but-buf)))
 798         (if file
 799             (file-name-directory (hpath:symlink-referent file))
 800           (cdr (assq 'default-directory (buffer-local-variables but-buf)))))
 801     (hypb:error "(hui:key-dir): '%s' is not a valid buffer.")))
 802
 803 (defun hui:key-src (but-buf)
 804   "Returns button key src location based on BUT-BUF, a buffer.
 805 This is BUT-BUF when button data is stored in the buffer and the
 806 button's source file name when the button data is stored externally."
 807   (save-excursion
 808     (set-buffer but-buf)
 809     (cond ((hmail:mode-is-p) but-buf)
 810           ((hpath:symlink-referent (buffer-file-name but-buf)))
 811           (t but-buf))))
 812
 813 (defun hui:link-create (modify but-window lbl-key but-loc but-dir type-and-args)
 814   "Creates or modifies a new Hyperbole button.
 815 If MODIFY is non-nil, modifies button at point in BUT-WINDOW,
 816 otherwise, prompts for button label and creates a button.
 817 LBL-KEY is internal form of button label.  BUT-LOC is file or buffer
 818 in which to create button.  BUT-DIR is directory of BUT-LOC.
 819 TYPE-AND-ARGS is the action type for the button followed by any arguments it requires."
 820   (hattr:set 'hbut:current 'loc but-loc)
 821   (hattr:set 'hbut:current 'dir but-dir)
 822   (hattr:set 'hbut:current 'actype (intern-soft
 823                                      (concat "actypes::"
 824                                              (symbol-name
 825                                                (car type-and-args)))))
 826   (hattr:set 'hbut:current 'args (cdr type-and-args))
 827
 828   (select-window but-window)
 829   (let ((label (ebut:key-to-label lbl-key)))
 830     (ebut:operate label (if modify label)))
 831   )
 832
 833 (defun hui:link-possible-types ()
 834   "Returns list of possible link types for a Hyperbole button link to point.
 835 Each list element is a list of the link type and any arguments it requires.
 836
 837 The link types considered are fixed.  Defining new link types will not alter
 838 the possible types.  The code must be changed to do that.
 839
 840 Referent Context         Possible Link Type Returned
 841 ----------------------------------------------------
 842 Explicit Button          link-to-ebut
 843   or
 844 Info Node                link-to-Info-node
 845   or
 846 Mail Reader Msg          link-to-mail
 847
 848 Outline Regexp Prefix    link-to-string-match
 849   or
 850 Directory Name           link-to-directory
 851   or
 852 File Name                link-to-file
 853   or
 854 Koutline Cell            link-to-kcell
 855   or
 856 Buffer attached to File  link-to-file
 857   or
 858 Buffer without File      link-to-buffer-tmp
 859
 860 Elisp Buffer at Start
 861 or End of Sexpression    eval-elisp
 862 "
 863   (let (val)
 864     (delq nil
 865           (list (if (ebut:at-p)
 866                     (list 'link-to-ebut buffer-file-name (ebut:label-p)))
 867                 (cond ((eq major-mode 'Info-mode)
 868                        (let ((hargs:reading-p 'Info-node))
 869                          (list 'link-to-Info-node (hargs:at-p))))
 870                       ((hmail:reader-p)
 871                        (list 'link-to-mail
 872                              (list (rmail:msg-id-get) buffer-file-name)))
 873                       )
 874                 (cond
 875                  ;; If link is within an outline-regexp prefix, use
 876                  ;; a link-to-string-match.
 877                  ((and (boundp 'outline-regexp)
 878                        (stringp outline-regexp)
 879                        (save-excursion
 880                          (<= (point)
 881                              (progn
 882                                (beginning-of-line)
 883                                (if (looking-at outline-regexp)
 884                                    (match-end 0)
 885                                  0)))))
 886                   (save-excursion
 887                     (end-of-line)
 888                     (let ((heading (buffer-substring
 889                                     (point)
 890                                     (progn (beginning-of-line) (point))))
 891                           (occur 1))
 892                       (while (search-backward heading nil t)
 893                         (setq occur (1+ occur)))
 894                       (list 'link-to-string-match
 895                             heading occur buffer-file-name))))
 896                  ((let ((hargs:reading-p 'directory))
 897                     (setq val (hargs:at-p t)))
 898                   (list 'link-to-directory val))
 899                  ((let ((hargs:reading-p 'file))
 900                     (setq val (hargs:at-p t)))
 901                   (list 'link-to-file val (point)))
 902                  ((eq major-mode 'kotl-mode)
 903                   (list 'link-to-kcell buffer-file-name (kcell-view:idstamp)))
 904                  (buffer-file-name
 905                   (list 'link-to-file buffer-file-name (point)))
 906                  (t (list 'link-to-buffer-tmp (buffer-name)))
 907                  )
 908                 (and (fboundp 'smart-emacs-lisp-mode-p)
 909                      (smart-emacs-lisp-mode-p)
 910                      (or (= (char-syntax (following-char)) ?\()
 911                          (= (char-syntax (preceding-char)) ?\)))
 912                      (setq val (hargs:sexpression-p))
 913                      (list 'eval-elisp val))
 914                 ))))
 915
 916
 917 ;;;
 918 ;;; Private variables
 919 ;;;
 920
 921
 922 (defvar hui:ebut-label-prev nil
 923   "String value of previous button name during an explicit button rename.
 924 At other times, values must be nil.")
 925
 926 (provide 'hui)
 927
 928 ;;; hui.el ends here