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

   1 ;;; hbut.el --- Hyperbole button constructs.
   2
   3 ;; Copyright (C) 1991-1995 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: extensions, 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 'hmoccur)
  36 (require 'hbmap)
  37 (require 'htz)
  38 (require 'hbdata)
  39 (require 'hact)
  40
  41 ;;;
  42 ;;; Public definitions
  43 ;;;
  44
  45 ;;;
  46 ;;; ebut class - Explicit Hyperbole buttons
  47 ;;;
  48
  49 (defvar   ebut:hattr-save t
  50   "*Non-nil value saves button data when button source is saved.
  51 Nil disables saving.")
  52
  53 (defconst ebut:max-len 100
  54   "Maximum length of a hyper-button label.")
  55
  56
  57 (defun    ebut:alist (&optional file)
  58   "Returns alist with each element a list containing a button label.
  59 For use as a completion table.  Gets labels from optional FILE or current
  60 buffer."
  61   (mapcar 'list (ebut:list file)))
  62
  63 (defun    ebut:at-p (&optional start-delim end-delim)
  64   "Returns explicit Hyperbole button at point or nil.
  65 Assumes point is within first line of button label, if at all.
  66 Optional START-DELIM and END-DELIM are strings that override default
  67 button delimiters."
  68   (let ((key (ebut:label-p nil start-delim end-delim)))
  69     (and key (ebut:get key))))
  70
  71 (defun    ebut:create (&optional but-sym)
  72   "Creates Hyperbole explicit button based on optional BUT-SYM.
  73 Default is 'hbut:current'.
  74 Button should hold the following attributes (see 'hattr:set'):
  75    lbl-key (normalized button label string),
  76    loc     (filename or buffer where button is located),
  77    dir     (directory name where button is located),
  78    actype  (action type that provides a default action for the button),
  79    action  (optional action that overrides the default),
  80    args    (list of arguments for action, if action takes a single
  81             argument of the button lbl-key, args may be nil).
  82
  83 If successful returns any instance number to append to button label
  84 except when instance number would be 1, then returns t.  On failure,
  85 returns nil.
  86
  87 If successful, leaves point in button data buffer, so caller should use
  88 'save-excursion'.  Does not save button data buffer."
  89   (let ((lbl-instance (hbdata:write nil but-sym)))
  90     (run-hooks 'ebut:create-hook)
  91     lbl-instance))
  92
  93 (defun    ebut:delete (&optional but-sym)
  94   "Deletes Hyperbole explicit button based on optional BUT-SYM.
  95 Default is 'hbut:current'.
  96 Returns entry deleted (a list of attribute values) or nil."
  97   (if (null but-sym) (setq but-sym 'hbut:current))
  98   (if (ebut:is-p but-sym)
  99       (let* ((but-key (hattr:get but-sym 'lbl-key))
 100              (loc     (hattr:get but-sym 'loc))
 101              (entry   (hbdata:delete-entry but-key loc)))
 102         (run-hooks 'ebut:delete-hook)
 103         entry)))
 104
 105 (defun    ebut:get (&optional lbl-key buffer key-src)
 106   "Returns explicit Hyperbole button symbol given by LBL-KEY and BUFFER.
 107 KEY-SRC is given when retrieving global buttons and is full source pathname.
 108 Retrieves button data, converts into a button object and returns a symbol
 109 which references the button.
 110
 111 All arguments are optional.  When none are given, returns symbol for
 112 button that point is within or nil.  BUFFER defaults to the current
 113 buffer."
 114   (hattr:clear 'hbut:current)
 115   (save-excursion
 116     (let ((key-file) (key-dir) (but-data) (actype))
 117       (or lbl-key (setq lbl-key (ebut:label-p)))
 118       (if buffer
 119           (if (bufferp buffer) (set-buffer buffer)
 120             (error "(ebut:get): Invalid buffer argument: %s" buffer)))
 121       (if key-src
 122           nil
 123         (if (equal lbl-key (ebut:label-p))
 124             nil
 125           (goto-char (point-min))
 126           (ebut:next-occurrence lbl-key))
 127         (if (setq key-src (ebut:key-src 'full))
 128             ;; 'ebut:key-src' sets current buffer to key-src buffer.
 129             (setq buffer (current-buffer)))
 130         )
 131       (if (and (stringp lbl-key) key-src)
 132           (progn
 133             (if (stringp key-src)
 134                 (setq key-dir (file-name-directory key-src)
 135                       key-file (file-name-nondirectory key-src)))
 136             (setq but-data (and key-src
 137                                 (hbdata:get-entry lbl-key (or key-file key-src)
 138                                                   key-dir)))
 139             (if (null but-data)
 140                 nil
 141               (hattr:set 'hbut:current 'lbl-key lbl-key)
 142               (hattr:set 'hbut:current 'loc key-src)
 143               (hattr:set 'hbut:current 'categ 'explicit)
 144               (hattr:set 'hbut:current 'action nil)
 145               (hattr:set 'hbut:current 'actype
 146                          (intern (setq actype (hbdata:actype but-data))))
 147               ;; Hyperbole V1 referent compatibility
 148               (if (= (length actype) 2)
 149                   (hattr:set 'hbut:current 'referent
 150                              (hbdata:referent but-data)))
 151               (hattr:set 'hbut:current 'args (hbdata:args but-data))
 152               (hattr:set 'hbut:current 'creator (hbdata:creator but-data))
 153               (hattr:set 'hbut:current
 154                          'create-time (hbdata:create-time but-data))
 155               (hattr:set 'hbut:current
 156                          'modifier (hbdata:modifier but-data))
 157               (hattr:set 'hbut:current
 158                          'mod-time (hbdata:mod-time but-data))
 159               'hbut:current)
 160             )))))
 161
 162 (defun    ebut:is-p (object)
 163   "Returns non-nil if OBJECT denotes an explicit Hyperbole button."
 164   (and (symbolp object)
 165        (eq (hattr:get object 'categ) 'explicit)))
 166
 167 (defun    ebut:key-of-label-p (key label)
 168   "Returns t iff KEY matches to LABEL in a case insensitive manner."
 169   (and (stringp key) (stringp label)
 170        (equal key (downcase (ebut:label-to-key label)))))
 171
 172 (defun    ebut:key-src (&optional full)
 173   "Return key source (usually unqualified) for current Hyperbole button.
 174 Also sets current buffer to key source.
 175 With optional FULL when source is a pathname, the full pathname is returned."
 176   (let ((src (cond ((hmail:mode-is-p) (current-buffer))
 177                    ((ebut:key-src-fmt))
 178                    ((save-excursion
 179                       (save-restriction
 180                         (widen)
 181                         (if (and (search-backward hbut:source-prefix nil t)
 182                                  (or (memq (preceding-char) '(?\n ?\^M))
 183                                      (= (point) (point-min))))
 184                             (hbut:source full)))))
 185                    (buffer-file-name
 186                     (if full buffer-file-name
 187                       (file-name-nondirectory buffer-file-name)))
 188                    (t (current-buffer))
 189                    )))
 190     (cond ((null src) nil)
 191           ((bufferp src)
 192            (set-buffer src)
 193            src)
 194           ((file-readable-p src)
 195            (set-buffer (find-file-noselect src))
 196            src)
 197           ((file-readable-p (setq src (hpath:symlink-referent src)))
 198            (set-buffer (find-file-noselect src))
 199            src))))
 200
 201 (defun    ebut:key-src-fmt ()
 202   "Returns unformatted filename associated with formatted current buffer.
 203 This is used to obtain the source of explicit buttons for buffers that
 204 represent the output of particular document formatters."
 205   (cond ((or (eq major-mode 'Info-mode)
 206              (string-match "\\.info\\(-[0-9]+\\)?$" (buffer-name)))
 207          (let ((src (and buffer-file-name
 208                          (substring
 209                           buffer-file-name
 210                           0 (string-match "\\.[^.]+$" buffer-file-name)))))
 211            (cond ((file-exists-p (concat src ".texi"))
 212                   (concat src ".texi"))
 213                  ((file-exists-p (concat src ".texinfo"))
 214                   (concat src ".texinfo"))
 215                  ((current-buffer)))))
 216         ))
 217
 218 (defun    ebut:key-to-label (lbl-key)
 219   "Unnormalizes LBL-KEY and returns a label string approximating actual label."
 220   (if lbl-key
 221       (let* ((pos 0) (len (length lbl-key)) (lbl) c)
 222         (while (< pos len)
 223           (setq c (aref lbl-key pos)
 224                 lbl (concat lbl
 225                             (if (= c ?_)
 226                                 (if (or (= (1+ pos) len)
 227                                         (/= (aref lbl-key (1+ pos)) ?_))
 228                                     " "
 229                                   (setq pos (1+ pos))
 230                                   "_")
 231                               (char-to-string c)))
 232                 pos (1+ pos)))
 233         lbl)))
 234
 235 (defun    ebut:label-p (&optional as-label start-delim end-delim pos-flag)
 236   "Returns key for Hyperbole button label that point is within.
 237 Returns nil if not within a label.
 238 Assumes point is within first line of button label, if at all.
 239 If optional AS-LABEL is non-nil, label is returned rather than the key
 240 derived from the label.  Optional START-DELIM and END-DELIM are strings
 241 that override default button delimiters.  With optional POS-FLAG non-nil,
 242 returns list of label-or-key, but-start-position, but-end-position.
 243 Positions include delimiters."
 244   (let ((opoint (point))
 245         (npoint (1+ (point)))
 246         (quoted "\\(^\\|[^\\{]\\)")
 247         (start)
 248         lbl-key end but-start but-end)
 249     (or start-delim (setq start-delim ebut:start))
 250     (or end-delim (setq end-delim ebut:end))
 251     (save-excursion
 252       (beginning-of-line)
 253       (while (and (progn
 254                     (while (re-search-forward
 255                             (concat quoted (regexp-quote start-delim))
 256                             npoint t)
 257                       (setq start t))
 258                     start)
 259                   (re-search-forward (concat "[^\\{]" (regexp-quote end-delim))
 260                                      npoint t))
 261         (setq start nil))
 262       (if start
 263           (progn
 264             (setq start (point)
 265                   but-start (match-end 1))
 266             (if (= ?\( (char-syntax (preceding-char)))
 267                 (condition-case ()
 268                     (progn
 269                       (forward-char -1)
 270                       (forward-list)
 271                       (forward-char -2))
 272                   (error (goto-char (1- opoint))))
 273               (goto-char (1- opoint)))
 274             (and (< (point) (+ start ebut:max-len))
 275                  (re-search-forward (concat quoted (regexp-quote end-delim))
 276                                     (+ start ebut:max-len) t)
 277                  (setq but-end (point)
 278                        end (- (point) (length end-delim))
 279                        lbl-key (ebut:label-to-key (buffer-substring start end)))
 280                  (cond (pos-flag
 281                         (if as-label
 282                             (list (ebut:key-to-label lbl-key) but-start but-end)
 283                           (list lbl-key but-start but-end)))
 284                        (t (if as-label (ebut:key-to-label lbl-key) lbl-key)))))))))
 285
 286 (defun    ebut:label-regexp (lbl-key &optional no-delim)
 287   "Unnormalizes LBL-KEY.  Returns regular expr matching delimited but label.
 288 Optional NO-DELIM leaves off delimiters and leading and trailing space."
 289   (if lbl-key
 290       (let* ((pos 0)
 291              (len (length lbl-key))
 292              (c)
 293              (sep0 "[ \t\n\^M]*")
 294              (sep "[ \t\n\^M]+")
 295              (regexp (if no-delim "" (concat (regexp-quote ebut:start) sep0)))
 296              (case-fold-search))
 297         (while (< pos len)
 298           (setq c (aref lbl-key pos)
 299                 regexp (concat regexp
 300                                (if (= c ?_)
 301                                    (if (or (= (1+ pos) len)
 302                                            (/= (aref lbl-key (1+ pos)) ?_))
 303                                        sep
 304                                      (setq pos (1+ pos))
 305                                      "_")
 306                                  (regexp-quote (char-to-string c))))
 307                 pos (1+ pos)))
 308         (if no-delim regexp
 309           (setq regexp (concat regexp sep0 (regexp-quote ebut:end)))))))
 310
 311 (defun    ebut:label-to-key (label)
 312   "Normalizes LABEL for use as a Hyperbole button key and returns key.
 313 Eliminates any fill prefix in the middle of the label, replaces '_' with
 314 '__', removes leading and trailing whitespace and replaces each other
 315 whitespace sequence with '_'."
 316   (if (null label)
 317       nil
 318     (setq label (hbut:fill-prefix-remove label)
 319           ;; Remove leading and trailing space.
 320           label (hypb:replace-match-string "\\`[ \t\n\^M]+\\|[ \t\n\^M]+\\'"
 321                                            label "" t)
 322           label (hypb:replace-match-string "_" label "__" t))
 323     (hypb:replace-match-string "[ \t\n\^M]+" label "_" t)))
 324
 325 (defun    ebut:list (&optional file loc-p)
 326   "Returns list of button labels from given FILE or current buffer.
 327 Removes duplicate labels if optional LOC-P is omitted.  With LOC-P, returns
 328 list of elements (label start end) where start and end are the buffer
 329 positions at which the starting button delimiter begins and ends."
 330   (interactive)
 331   (setq file (if file (and (file-exists-p file) (find-file-noselect file))
 332                (current-buffer)))
 333   (if file
 334       (progn
 335         (set-buffer file)
 336         (let ((buts (ebut:map (if loc-p
 337                                   (function
 338                                    (lambda (lbl start end)
 339                                      ;; Normalize label spacing
 340                                      (list (ebut:key-to-label
 341                                             (ebut:label-to-key lbl))
 342                                            start end)))
 343                                 (function
 344                                  (lambda (lbl start end)
 345                                    ;; Normalize label spacing
 346                                    (ebut:key-to-label
 347                                     (ebut:label-to-key lbl))))))))
 348           (if loc-p buts (nreverse (set:create buts)))))))
 349
 350 (fset    'map-ebut 'ebut:map)
 351 (defun    ebut:map (but-func &optional start-delim end-delim
 352                              regexp-match include-delims)
 353   "Applies BUT-FUNC to buttons delimited by optional START-DELIM and END-DELIM.
 354 If REGEXP-MATCH is non-nil, only buttons which match this argument are
 355 considered.
 356 Maps over portion of buffer visible under any current restriction.
 357 BUT-FUNC must take precisely three arguments: the button label, the
 358 start position of the delimited button label and its end position (positions
 359 include delimiters when INCLUDE-DELIMS is non-nil).
 360 If END-DELIM is a symbol, e.g. t, then START-DELIM is taken as a regular
 361 expression which matches an entire button string."
 362   (or start-delim (setq start-delim ebut:start))
 363   (or end-delim (setq end-delim ebut:end))
 364   (let* ((regexp (symbolp end-delim))
 365          (end-sym (or regexp (substring end-delim -1)))
 366          (rtn)
 367          (quoted)
 368          start end but lbl)
 369     (save-excursion
 370       (goto-char (point-min))
 371       (setq include-delims (if include-delims 0 1))
 372       (while (re-search-forward
 373               (if regexp start-delim
 374                 (concat (regexp-quote start-delim)
 375                         "\\([^" end-sym "\"][^" end-sym "]*\\)"
 376                         (regexp-quote end-delim)))
 377               nil t)
 378         (setq start (match-beginning include-delims)
 379               end (match-end include-delims)
 380               but (buffer-substring (match-beginning 0) (match-end 0))
 381               lbl (buffer-substring (match-beginning 1) (match-end 1)))
 382         (save-excursion
 383           (goto-char start)
 384           (if (or (= (preceding-char) ?\\) (= (preceding-char) ?\{))
 385               ;; Ignore matches with quoted delimiters.
 386               (setq quoted t)))
 387         (cond (quoted (setq quoted nil))
 388               ((or (not regexp-match)
 389                    (string-match regexp-match but))
 390                (setq rtn (cons (funcall but-func lbl start end) rtn))))))
 391     (nreverse rtn)))
 392
 393 (defun    ebut:modify (&optional lbl-key but-sym)
 394   "Modifies existing Hyperbole button from optional LBL-KEY and BUT-SYM.
 395 Defaults are the key for any button label at point and 'hbut:current'.
 396 If successful, returns button's instance number except when instance
 397 number is 1, then returns t.  On failure, as when button does not exist,
 398 returns nil.
 399
 400 If successful, leaves point in button data buffer, so caller should use
 401 'save-excursion'.  Does not save button data buffer."
 402   (save-excursion
 403     (let ((lbl-instance (hbdata:write lbl-key but-sym)))
 404       (run-hooks 'ebut:modify-hook)
 405       lbl-instance)))
 406
 407 (defun    ebut:next-occurrence (lbl-key &optional buffer)
 408   "Moves point to next occurrence of button with LBL-KEY in optional BUFFER.
 409 BUFFER defaults to current buffer.  It may be a buffer name.
 410 Returns non-nil iff occurrence is found.
 411
 412 Remember to use (goto-char (point-min)) before calling this in order to
 413 move to the first occurrence of the button."
 414   (if buffer
 415       (if (not (or (bufferp buffer)
 416                    (and (stringp buffer) (get-buffer buffer))))
 417           (error "(ebut:next-occurrence): Invalid buffer arg: %s" buffer)
 418         (switch-to-buffer buffer)))
 419   (if (re-search-forward (ebut:label-regexp lbl-key) nil t)
 420       (goto-char (+ (match-beginning 0) (length ebut:start)))))
 421
 422 (defun    ebut:operate (curr-label new-label)
 423   "Operates on a new or existing Hyperbole button given by CURR-LABEL.
 424 When NEW-LABEL is non-nil, this is substituted for CURR-LABEL and the
 425 associated button is modified.  Otherwise, a new button is created.
 426 Returns instance string appended to label to form unique label, nil if
 427 label is already unique.  Signals an error when no such button is found
 428 in the current buffer."
 429   (let* ((lbl-key (ebut:label-to-key curr-label))
 430          (lbl-regexp (ebut:label-regexp lbl-key))
 431          (modify new-label)
 432          (instance-flag))
 433     (or new-label (setq new-label curr-label))
 434     (hattr:set 'hbut:current 'lbl-key (ebut:label-to-key new-label))
 435     (save-excursion
 436       (if (setq instance-flag
 437                 (if modify (ebut:modify lbl-key) (ebut:create)))
 438           (if (hmail:editor-p) (hmail:msg-narrow))))
 439     (if instance-flag
 440         (progn
 441           ;; Rename all occurrences of button - those with same label.
 442           (if modify
 443               (let* ((but-key-and-pos (ebut:label-p nil nil nil 'pos))
 444                      (at-but (equal (car but-key-and-pos)
 445                                     (ebut:label-to-key new-label))))
 446                 (if at-but
 447                     (ebut:delimit (nth 1 but-key-and-pos)
 448                                   (nth 2 but-key-and-pos)
 449                                   instance-flag))
 450                 (cond ((ebut:map
 451                         (function
 452                          (lambda (lbl start end)
 453                            (delete-region start end)
 454                            (ebut:delimit
 455                             (point)
 456                             (progn (insert new-label) (point))
 457                             instance-flag)))
 458                         nil nil lbl-regexp 'include-delims))
 459                       (at-but)
 460                       ((hypb:error "(ebut:operate): No button matching: %s" curr-label))))
 461             ;; Add a new button.
 462             (let (start end buf-lbl)
 463               (cond ((and (marker-position (hypb:mark-marker t))
 464                           (setq start (region-beginning)
 465                                 end (region-end)
 466                                 buf-lbl (buffer-substring start end))
 467                           (equal buf-lbl curr-label))
 468                      nil)
 469                     ((looking-at (regexp-quote curr-label))
 470                      (setq start (point)
 471                            end (match-end 0)))
 472                     (t (setq start (point))
 473                        (insert curr-label)
 474                        (setq end (point))))
 475               (ebut:delimit start end instance-flag))
 476             )
 477           ;; Position point
 478           (let ((new-key (ebut:label-to-key new-label)))
 479             (cond ((equal (ebut:label-p) new-key)
 480                    (forward-char 1) (search-backward ebut:start nil t)
 481                    (goto-char (match-end 0)))
 482                   ((let ((regexp (ebut:label-regexp new-key)))
 483                      (or (re-search-forward  regexp nil t)
 484                          (re-search-backward regexp nil t)))
 485                    (goto-char (+ (match-beginning 0) (length ebut:start))))))
 486           ;; instance-flag might be 't which we don't want to return.
 487           (if (stringp instance-flag) instance-flag))
 488       (hypb:error
 489        "(ebut:operate): Operation failed.  Check button attribute permissions: %s"
 490        hattr:filename))))
 491
 492 (defun    ebut:search (string out-buf &optional match-part)
 493   "Writes explicit button lines matching STRING to OUT-BUF.
 494 Uses Hyperbole space into which user has written buttons for the search.
 495 By default, only matches for whole button labels are found, optional MATCH-PART
 496 enables partial matches."
 497   (let*  ((buffers (mapcar (function
 498                             (lambda (dir)
 499                               (expand-file-name hattr:filename dir)))
 500                            (hbmap:dir-list)))
 501           (total 0)
 502           (firstmatch))
 503     (save-excursion
 504       (set-buffer out-buf)
 505       (setq buffer-read-only nil)
 506       (widen)
 507       (erase-buffer)
 508       (let (currbuf currfile kill-buf src-matches dir)
 509         (while buffers
 510           (setq currbuf (car buffers)
 511                 currfile (if (stringp currbuf) currbuf)
 512                 kill-buf (and currfile (not (get-file-buffer currfile)))
 513                 buffers (cdr buffers))
 514           (if currfile
 515               (setq currbuf (and (file-readable-p currfile)
 516                                  (find-file-noselect currfile))
 517                     dir (file-name-directory currfile))
 518             (setq currfile (buffer-file-name currbuf)))
 519           (and currfile currbuf
 520                (unwind-protect
 521                    (setq src-matches
 522                          (hbdata:search currbuf string match-part))
 523                  (if kill-buf (kill-buffer currbuf))))
 524           (if src-matches
 525               (let (elt matches)
 526                 (while src-matches
 527                   (setq elt (car src-matches))
 528                   (if (null elt) nil
 529                     (setq src-matches (cdr src-matches)
 530                           currfile (expand-file-name (car elt) dir)
 531                           matches (cdr elt)
 532                           currbuf (get-file-buffer currfile)
 533                           kill-buf (not currbuf)
 534                           currbuf (or currbuf
 535                                       (and (file-readable-p currfile)
 536                                            (find-file-noselect currfile))))
 537                     (if (null currbuf)
 538                         (progn (set-buffer out-buf)
 539                                (insert "ERROR: (ebut:search): \"" currfile
 540                                        "\" is not readable.\n\n"))
 541                       (set-buffer currbuf)
 542                       (unwind-protect
 543                           (save-excursion
 544                             (widen) (goto-char 1)
 545                             (let ((case-fold-search t)
 546                                   (regexp
 547                                    (ebut:match-regexp matches match-part)))
 548                               (setq firstmatch t)
 549                               (while (re-search-forward regexp nil t)
 550                                 (setq total (1+ total))
 551                                 (let* ((linenum (count-lines (point-min)
 552                                                              (point)))
 553                                        (tag (format "\n%4d:" linenum))
 554                                        lns start end)
 555                                   (setq end (progn (end-of-line) (point))
 556                                         start (progn
 557                                                 (goto-char (match-beginning 0))
 558                                                 (beginning-of-line) (point))
 559                                         lns (buffer-substring start end))
 560                                   (goto-char end)
 561                                   (save-excursion
 562                                     (set-buffer out-buf)
 563                                     (if firstmatch
 564                                         (progn
 565                                           (insert hbut:source-prefix "\""
 566                                                   currfile "\"\n")
 567                                           (setq firstmatch nil)))
 568                                     (insert tag lns))))
 569                               (set-buffer out-buf)
 570                               (if (not firstmatch) (insert "\n\n"))))
 571                         (if kill-buf (kill-buffer currbuf)))))))))))
 572     total))
 573
 574 ;;; ----
 575 (defun    ebut:delimit (start end instance-str)
 576   "Delimits button label spanning region START to END in current buffer.
 577 If button is already delimited or delimit fails, returns nil, else t.
 578 Inserts INSTANCE-STR after END, before ending delimiter."
 579   (goto-char start)
 580   (if (looking-at (regexp-quote ebut:start))
 581       (forward-char (length ebut:start)))
 582   (if (ebut:label-p)
 583       nil
 584     (if (not (stringp instance-str)) (setq instance-str ""))
 585     (insert ebut:start)
 586     (goto-char (setq end (+ end (length ebut:start))))
 587     (insert instance-str ebut:end)
 588     (setq end (+ end (length instance-str) (length ebut:end)))
 589     (and (fboundp 'hproperty:but-add) (hproperty:but-add start end hproperty:but))
 590     (hbut:comment start end)
 591     (goto-char end)
 592     t))
 593
 594 (defun    ebut:match-regexp (match-keys match-part)
 595   "Returns regexp to match to all explicit button keys from MATCH-KEYS."
 596   (setq match-part (if match-part
 597                        (concat "[^" (substring ebut:end -1) "]*")
 598                      "[ \t\n]*"))
 599   (concat
 600    (regexp-quote ebut:start) match-part
 601    "\\(" (mapconcat (function
 602                      (lambda (key) (ebut:label-regexp key 'no-delim)))
 603                     match-keys "\\|")
 604    "\\)" match-part (regexp-quote ebut:end)))
 605
 606 (defconst ebut:start "<("
 607   "String matching the start of a hyper-button.")
 608 (defconst ebut:end   ")>"
 609   "String matching the end of a hyper-button.")
 610 (defconst ebut:instance-sep ":"
 611   "String of one character, separates an ebut label from its instance num.")
 612
 613 ;;;
 614 ;;; gbut class - Global Hyperbole buttons - activated by typing label name
 615 ;;;
 616
 617 (defvar gbut:file (expand-file-name hbmap:filename hbmap:dir-user)
 618   "File that stores Hyperbole buttons accessible by name, global buttons.")
 619
 620 (defun gbut:act (label)
 621   "Activates Hyperbole global button with LABEL."
 622   (interactive (list (hargs:read-match "Activate global button labeled: "
 623                                        (mapcar 'list (gbut:lbl-list))
 624                                        nil t nil 'ebut)))
 625   (if (null label)
 626       (error "(gbut:act): There are no global buttons defined")
 627     (let* ((lbl-key (hbut:label-to-key label))
 628            (but (ebut:get lbl-key nil gbut:file)))
 629       (if but
 630           (hbut:act but)
 631         (error "(gbut:act): No global button labeled: %s" label)))))
 632
 633 (defun gbut:help (label)
 634   "Displays help for Hyperbole global button with LABEL."
 635   (interactive (list (hargs:read-match "Report on global button labeled: "
 636                                        (mapcar 'list (gbut:lbl-list))
 637                                        nil t nil 'ebut)))
 638   (let* ((lbl-key (hbut:label-to-key label))
 639          (but (ebut:get lbl-key nil gbut:file)))
 640     (if but
 641         (hbut:report but)
 642       (error "(gbut:help): No global button labeled: %s" label))))
 643
 644 ;;; ----
 645 (defun gbut:key-list ()
 646   "Returns list of global button label keys."
 647   (save-excursion
 648     (if (hbdata:to-entry-buf gbut:file)
 649         (let ((gbuts))
 650           (save-restriction
 651             (narrow-to-region (point) (if (search-forward "\^L" nil t)
 652                                           (point) (point-max)))
 653             (goto-char (point-min))
 654             (condition-case ()
 655                 (while (setq gbuts (cons (car (read (current-buffer))) gbuts)))
 656               (error nil))
 657             gbuts)))))
 658
 659 (defun gbut:lbl-list ()
 660   "Returns list of global button labels."
 661   (mapcar 'hbut:key-to-label (gbut:key-list)))
 662
 663 ;;;
 664 ;;; hattr class
 665 ;;;
 666
 667 (defun    hattr:attributes (obj-symbol)
 668   "Returns a list of OBJ-SYMBOL's attributes as symbols."
 669   (if (symbolp obj-symbol)
 670       (let* ((attr-val-list (symbol-plist obj-symbol))
 671              (i -1))
 672         (delq nil (mapcar (function
 673                            (lambda (elt)
 674                              (setq i (1+ i))
 675                              (and (= (% i 2) 0) elt)))
 676                           attr-val-list)))))
 677
 678 (defun    hattr:clear (hbut)
 679   "Removes all of HBUT's attributes except `variable-documentation'."
 680   (let (sublist)
 681     (or (symbolp hbut)
 682         (error "(hattr:clear): Argument not a Hyperbole button: %s" hbut))
 683     (if (setq sublist (memq 'variable-documentation (symbol-plist hbut)))
 684         (progn
 685           (setcdr (cdr sublist) nil)
 686           (setplist hbut sublist))
 687       (setplist hbut nil)
 688       )))
 689
 690 (defun    hattr:copy (from-hbut to-hbut)
 691   "Copies attributes FROM-HBUT TO-HBUT, eliminating attributes TO-HBUT had.
 692 Returns TO-HBUT."
 693   (mapcar
 694    (function
 695     (lambda (hbut)
 696       (or (and hbut (symbolp hbut))
 697           (error "(hattr:clear): Argument not a Hyperbole button: %s" hbut))))
 698    (list from-hbut to-hbut))
 699   (unwind-protect
 700       nil
 701     (hattr:clear to-hbut)
 702     (setplist to-hbut (copy-sequence (symbol-plist from-hbut))))
 703   to-hbut)
 704
 705 (defun    hattr:get (obj-symbol attr-symbol)
 706   "Returns value of OBJ-SYMBOL's attribute ATTR-SYMBOL."
 707   (get obj-symbol attr-symbol))
 708
 709 (defun    hattr:list (obj-symbol)
 710   "Returns a property list of OBJ-SYMBOL's attributes.
 711 Each pair of elements is: <attrib-name> <attrib-value>."
 712   (if (symbolp obj-symbol)
 713       (symbol-plist obj-symbol)
 714     (error "(hattr:list): Argument not a symbol: %s" obj-symbol)))
 715
 716 (defun    hattr:memq (attr-symbol obj-symbol)
 717   "Returns t if ATTR-SYMBOL is in OBJ-SYMBOL's attribute list, else nil."
 718   (and (symbolp obj-symbol) (symbolp attr-symbol)
 719        (let* ((attr-val-list (symbol-plist obj-symbol))
 720               (attr-list (let ((i -1))
 721                            (delq nil (mapcar
 722                                       (function
 723                                        (lambda (elt)
 724                                          (setq i (1+ i))
 725                                          (and (= (% i 2) 0) elt)))
 726                                       attr-val-list)))))
 727          (if (memq attr-symbol attr-list) t))))
 728
 729 (defun    hattr:report (attrib-list)
 730   "Pretty prints to standard-output attribute-value pairs from ATTRIB-LIST.
 731 Ignores nil valued attributes.  Returns t unless no attributes are printed."
 732   (let ((has-attr) attr val len)
 733     (if (or (null attrib-list) (not (listp attrib-list))
 734             ;; odd number of elements?
 735             (= (% (length attrib-list) 2) 1))
 736         nil
 737       (while (setq attr (car attrib-list))
 738         (setq val (car (setq attrib-list (cdr attrib-list)))
 739               attrib-list (cdr attrib-list))
 740         (if val
 741             (progn
 742               (setq has-attr t
 743                     attr (symbol-name attr)
 744                     len (max (- 16 (length attr)) 1))
 745               (princ "   ") (princ attr) (princ ":")
 746               (princ (make-string len ? ))
 747               (let (str)
 748                 (prin1 (cond ((string-match "time" attr)
 749                               (htz:date-unix val
 750                                              (and (>= (aref val 0) ?0)
 751                                                   (<= (aref val 0) ?9)
 752                                                   "GMT") htz:local))
 753                              ((and (setq str (if (stringp val) val
 754                                                (prin1-to-string val)))
 755                                    (string-match "\\`actypes::" str))
 756                               (intern (substring str (match-end 0))))
 757                              (t val))))
 758               (terpri))))
 759       has-attr)))
 760
 761 (defun    hattr:save ()
 762   "Saves button attribute file for current directory, if modified.
 763 Suitable for use as part of 'write-file-hooks'."
 764   (let* ((bd-file (expand-file-name hattr:filename default-directory))
 765          (buf (and (stringp default-directory)
 766                    (get-file-buffer bd-file))))
 767     (if (and ebut:hattr-save buf (not (eq buf (current-buffer))))
 768         (let ((ebut:hattr-save));; Prevents 'write-file-hooks' looping.
 769           (and (buffer-modified-p buf)
 770                (save-excursion
 771                  (set-buffer buf) (save-buffer)
 772                  ;; Unlock button attribute file; kill buffer so user is
 773                  ;; never holding a buffer which is out of sync with file,
 774                  ;; due to some other user's edits.
 775                  ;; Maybe this should be user or site configurable.
 776                  (or (buffer-modified-p buf) (kill-buffer buf))
 777                  )))))
 778   ;; Must return nil, so can be used as part of write-file-hooks.
 779   nil)
 780
 781 (defun    hattr:set (obj-symbol attr-symbol attr-value)
 782   "Sets OBJ-SYMBOL's attribute ATTR-SYMBOL to ATTR-VALUE."
 783   (put obj-symbol attr-symbol attr-value))
 784
 785 (fset    'hattr:summarize 'hattr:report)
 786
 787 (defvar   hattr:filename
 788   (if (memq system-type '(ms-windows windows-nt ms-dos)) "_hypb" ".hypb")
 789   "Per directory file name in which explicit button attributes are stored.
 790 If you change its value, you will be unable to use buttons created by
 791 others who use a different value!")
 792
 793 ;;;
 794 ;;; hbut class - abstract
 795 ;;;
 796
 797 (defun    hbut:act (hbut)
 798   "Performs action for explicit or implicit Hyperbole button symbol HBUT."
 799   (and hbut (apply 'actype:act (hattr:get hbut 'actype)
 800                    (hattr:get hbut 'args))))
 801
 802 (defun    hbut:action (hbut)
 803   "Returns appropriate action for Hyperbole button symbol HBUT."
 804   (let ((categ (hattr:get hbut 'categ)) (atype) (action))
 805     (if (eq categ 'explicit)
 806         (progn (setq action (hattr:get hbut 'action)
 807                      atype  (hattr:get hbut 'actype))
 808                (if (= (length (symbol-name atype)) 2)
 809                    atype
 810                  (or action (actype:action atype))))
 811       ;; Must be an implicit button.
 812       (if (fboundp atype) atype))))
 813
 814 (defun    hbut:at-p ()
 815   "Returns symbol for explicit or implicit Hyperbole button at point or nil."
 816   (or (ebut:at-p) (ibut:at-p)))
 817
 818
 819 (defun    hbut:comment (start end)
 820   "Comment button label spanning region START to END in current buffer.
 821 Use buffer commenting grammar, if any, otherwise don't comment."
 822   (save-excursion
 823     (if comment-start
 824         (if (or (equal comment-end "")
 825                 (null comment-end))
 826             (progn
 827               (beginning-of-line)
 828               (if (search-forward comment-start start t)
 829                   nil
 830                 (goto-char start)
 831                 (insert comment-start)
 832                 (if (/= (preceding-char) ? )
 833                     (insert ? ))))
 834           ;; Comments have both start and end delimiters
 835           (if (and (re-search-backward
 836                     (concat (regexp-quote comment-start) "\\|"
 837                             (regexp-quote comment-end))
 838                     nil t)
 839                    (looking-at (regexp-quote comment-start)))
 840               nil
 841             (goto-char start)
 842             (insert comment-start)
 843             (if (/= (preceding-char) ? )
 844                 (insert ? ))
 845             (goto-char (+ (point) (- end start)))
 846             (if (/= (following-char) ? )
 847                 (insert ? ))
 848             (insert comment-end)
 849             )))))
 850
 851 ;;; Regexps derived in part from "filladapt.el" under the GPL, Copyright
 852 ;;; 1989 Kyle E. Jones.
 853 (defvar   hbut:fill-prefix-regexps
 854   '(
 855     ;; Included text in news or mail messages
 856     "\n[ \t]*\\([:|<>]+ *\\)+"
 857     ;; Included text generated by SUPERCITE.  We can't hope to match all
 858     ;; the possible variations.
 859     "\n[ \t]*[^'`\"< \t]*> *"
 860     ;; Lisp comments
 861     "\n[ \t]*\\(;+[ \t]*\\)+"
 862     ;; UNIX shell comments
 863     "\n[ \t]*\\(#+[ \t]*\\)+"
 864     ;; C++ comments
 865     "\n[ \t]*//[/ \t]+"
 866     ;; C or Pascal comments, one open and close per line, so match close
 867     ;; then open.
 868     "\\*+[/\)][ \t]*\n+[ \t]*[/\(]\\*+"
 869     "}[ \t]*\n+[ \t]*{"
 870     ;; Eiffel or Sather comments
 871     "\n[ \t]*--[ \t]+"
 872     ;; Fortran comments
 873     "\n[Cc][ \t]+"
 874     ;; Postscript comments
 875     "\n[ \t]*\\(%+[ \t]*\\)+"
 876     )
 877   "List of regexps of fill prefixes to remove from the middle of buttons.")
 878
 879 (defun    hbut:fill-prefix-remove (label)
 880   "Removes any recognized fill prefix from within LABEL.
 881 'hbut:fill-prefix-regexps' is a list of fill prefixes to recognize."
 882   (if (string-match "\n" label)
 883       (mapcar
 884        (function
 885         (lambda (fill-prefix)
 886           (and (string-match "\n" label)
 887                (setq label
 888                      (hypb:replace-match-string fill-prefix label " " t)))))
 889        hbut:fill-prefix-regexps))
 890   label)
 891
 892 (defun    hbut:is-p (object)
 893   "Returns non-nil if object denotes a Hyperbole button."
 894   (and (symbolp object) (hattr:get object 'categ)))
 895
 896 (fset    'hbut:key-src      'ebut:key-src)
 897 (fset    'hbut:key-to-label 'ebut:key-to-label)
 898
 899 (defun    hbut:label (hbut)
 900   "Returns the label for Hyperbole button symbol HBUT."
 901   (if (hbut:is-p hbut)
 902       (hbut:key-to-label (hattr:get hbut 'lbl-key))
 903     (error "(hbut:label): Argument is not a Hyperbole button symbol, '%s'"
 904            hbut)))
 905
 906 (fset    'hbut:label-p      'ebut:label-p)
 907 (fset    'hbut:label-to-key 'ebut:label-to-key)
 908
 909 (defun    hbut:report (&optional arg)
 910   "Pretty prints the attributes of a button or buttons.
 911
 912 Takes an optional ARG interpreted as follows:
 913   a button symbol - report on that button;
 914   nil             - report on button at point, if any;
 915   integer > 0     - report on all explicit buttons in buffer, alphabetize;
 916   integer < 1     - report on all explicit buttons in occurrence order;
 917
 918 Returns number of buttons reported on or nil if none."
 919   (setq arg (cond ((or (integerp arg) (symbolp arg)) arg)
 920                   ((listp arg)
 921                    (if (integerp (setq arg (car arg))) arg 1))
 922                   (t 1)))
 923   (let* ((but (if (and arg (symbolp arg)) arg (hbut:at-p)))
 924          (curr-key (and but (hattr:get but 'lbl-key)))
 925          (key-src (or (and but (hattr:get but 'loc)) (hbut:key-src)))
 926          (lbl-lst (cond ((not arg)
 927                          (if curr-key (list (ebut:key-to-label curr-key))))
 928                         ((symbolp arg) (if curr-key
 929                                            (list (hbut:key-to-label
 930                                                   (hattr:get arg 'lbl-key)))))
 931                         ((< arg 1) (ebut:list))
 932                         (t (sort (ebut:list)
 933                                  (function
 934                                   (lambda (s1 s2)
 935                                     (string< (downcase s1) (downcase s2))))))))
 936          (key-buf (current-buffer))
 937          (buf-name (hypb:help-buf-name))
 938          (attribs))
 939     (if lbl-lst
 940         (progn
 941           (with-output-to-temp-buffer buf-name
 942             (princ hbut:source-prefix)
 943             (prin1 key-src)
 944             (terpri)
 945             (terpri)
 946             (mapcar
 947              (function
 948               (lambda (lbl)
 949                 (if (setq but
 950                           (cond ((or (null arg) (symbolp arg)) but)
 951                                 (t (ebut:get (ebut:label-to-key lbl) key-buf)))
 952                           attribs (hattr:list but))
 953                     (progn
 954                       (princ (if (ibut:is-p but)
 955                                  lbl
 956                                (concat ebut:start lbl ebut:end)))
 957                       (terpri)
 958                       (let ((doc (actype:doc but (= 1 (length lbl-lst)))))
 959                         (if doc
 960                             (progn
 961                               (princ "  ")
 962                               (princ doc)
 963                               (terpri))))
 964                       (hattr:report
 965 ;;                     (if (eq (car (cdr (memq 'categ attribs))) 'explicit)
 966 ;;                         (memq 'action attribs)
 967 ;;                       (memq 'categ attribs))
 968                        attribs)
 969                       (terpri))
 970                   )))
 971              lbl-lst))
 972           (length lbl-lst)))))
 973
 974 (defun    hbut:source (&optional full)
 975   "Returns Hyperbole source buffer or file given at point.
 976 If a file, always returns a full path if optional FULL is non-nil."
 977   (goto-char (match-end 0))
 978   (cond ((looking-at "#<buffer \\([^ \n]+\\)>")
 979          (get-buffer (buffer-substring (match-beginning 1)
 980                                        (match-end 1))))
 981         ((looking-at "\".+\"")
 982          (let* ((file (buffer-substring (1+ (match-beginning 0))
 983                                         (1- (match-end 0))))
 984                 (absolute (file-name-absolute-p file)))
 985            (if (and full (not absolute))
 986                (expand-file-name file default-directory)
 987              file)))))
 988
 989 (fset    'hbut:summarize 'hbut:report)
 990
 991 (defvar   hbut:current nil
 992   "Currently selected Hyperbole button.
 993 Available to action routines.")
 994
 995 (defconst hbut:source-prefix moccur-source-prefix
 996   "String found at start of a buffer containing only a hyper-button menu.
 997    This expression should be followed immediately by a file-name indicating the
 998 source file for the buttons in the menu, if any.")
 999
1000 ;;;
1001 ;;; htype class - Hyperbole Types, e.g. action and implicit button types
1002 ;;;
1003
1004 (require 'set)
1005
1006 (defun    htype:body (htype-sym)
1007   "Return body for HTYPE-SYM.  If HTYPE-SYM is nil, return nil."
1008   (and htype-sym (hypb:indirect-function htype-sym)))
1009
1010 (defun    htype:category (type-category)
1011   "Return list of symbols in Hyperbole TYPE-CATEGORY in priority order.
1012 Symbols contain category component.
1013 TYPE-CATEGORY should be 'actypes, 'ibtypes or nil for all."
1014   (let ((types (symset:get type-category 'symbols))
1015         (categ-name (symbol-name type-category)))
1016     (mapcar (function
1017              (lambda (type)
1018                (intern (concat categ-name "::" (symbol-name type)))))
1019             types)))
1020
1021 ;; Thanks to JWZ for help on this.
1022 (defmacro htype:create (type type-category doc params body property-list)
1023   "Create a new Hyperbole TYPE within TYPE-CATEGORY (both unquoted symbols).
1024 Third arg DOC is a string describing the type.
1025 Fourth arg PARAMS is a list of parameters to send to the fifth arg BODY,
1026 which is a list of forms executed when the type is evaluated.
1027 Sixth arg PROPERTY-LIST is attached to the new type's symbol.
1028
1029 This symbol is returned."
1030   (let* ((sym (htype:symbol type type-category))
1031         (action (nconc (list 'defun sym params doc) body)))
1032     (` (progn
1033          (, action)
1034          (setplist '(, sym) (, property-list))
1035          (symset:add '(, type) '(, type-category) 'symbols)
1036          (run-hooks 'htype:create-hook)
1037          '(, sym)))))
1038
1039 (defun    htype:delete (type type-category)
1040   "Delete a Hyperbole TYPE derived from TYPE-CATEGORY (both symbols).
1041 Return the Hyperbole symbol for the TYPE if it existed, else nil."
1042   (let* ((sym (htype:symbol type type-category))
1043          (exists (fboundp 'sym)))
1044     (setplist sym nil)
1045     (symset:delete type type-category 'symbols)
1046     (fmakunbound sym)
1047     (run-hooks 'htype:delete-hook)
1048     (and exists sym)))
1049
1050 (defun    htype:doc (type)
1051   "Return documentation for Hyperbole TYPE, a symbol."
1052   (documentation type))
1053
1054 (defun    htype:names (type-category &optional sym)
1055   "Return list of current names for Hyperbole TYPE-CATEGORY in priority order.
1056 Names do not contain category component.
1057 TYPE-CATEGORY should be 'actypes, 'ibtypes or nil for all.
1058 When optional SYM is given, return the name for that symbol only, if any."
1059   (let ((types (symset:get type-category 'symbols))
1060         (sym-name (and sym (symbol-name sym))))
1061     (if sym-name
1062         ;; Strip category from sym-name before looking for a match.
1063         (progn (if (string-match "::" sym-name)
1064                    (setq sym (intern (substring sym-name (match-end 0)))))
1065                (if (memq sym types) (symbol-name sym)))
1066       (mapcar 'symbol-name types))))
1067
1068 ;;; ----
1069
1070 (defun   htype:symbol (type type-category)
1071   "Return Hyperbole type symbol composed from TYPE and TYPE-CATEGORY (both symbols)."
1072   (intern (concat (symbol-name type-category) "::"
1073                   (symbol-name type))))
1074
1075 ;;;
1076 ;;; ibut class - Implicit Hyperbole Buttons
1077 ;;;
1078
1079 (defun    ibut:at-p (&optional key-only)
1080   "Returns symbol for implicit button at point, else nil.
1081 With optional KEY-ONLY, returns only the label key for button."
1082   (let ((types (htype:category 'ibtypes))
1083         ;; Global var used in (hact) function, don't delete.
1084         (hrule:action 'actype:identity)
1085         (itype)
1086         (args)
1087         (is-type))
1088     (or key-only (hattr:clear 'hbut:current))
1089     (while (and (not is-type) types)
1090       (setq itype (car types))
1091       (if (setq args (funcall itype))
1092           (setq is-type itype)
1093         (setq types (cdr types))))
1094     (if is-type
1095         (if key-only
1096             (hattr:get 'hbut:current 'lbl-key)
1097           (hattr:set 'hbut:current 'loc (save-excursion
1098                                           (hbut:key-src 'full)))
1099           (hattr:set 'hbut:current 'categ is-type)
1100           (or (hattr:get 'hbut:current 'args)
1101               (not (listp args))
1102               (progn
1103                 (hattr:set 'hbut:current 'actype
1104                            (or
1105                              ;; Hyperbole action type
1106                              (intern-soft (concat "actypes::"
1107                                                   (symbol-name (car args))))
1108                              ;; Regular Emacs Lisp function symbol
1109                              (car args)
1110                              ))
1111                 (hattr:set 'hbut:current 'args (cdr args))))
1112           'hbut:current))))
1113
1114 (defun    ibut:is-p (object)
1115   "Returns non-nil if object denotes an implicit Hyperbole button."
1116   (if (symbolp object)
1117       (let ((categ (hattr:get object 'categ)))
1118         (and categ (string-match "^ibtypes::" (symbol-name categ))))))
1119
1120 (defun    ibut:label-p ()
1121   "Returns key for Hyperbole implicit button label that point is on or nil."
1122   (ibut:at-p 'key-only))
1123
1124 (defun    ibut:label-set (label &optional start end)
1125   "Sets current implicit button attributes from LABEL and START, END position.
1126 START and END are optional.  When given, they specify the region in the buffer
1127 to flash when this implicit button is activated or queried for its attributes.
1128 If LABEL is a list, it is assumed to contain all arguments."
1129   (cond ((stringp label)
1130          (hattr:set 'hbut:current 'lbl-key (hbut:label-to-key label))
1131          (and start (hattr:set    'hbut:current 'lbl-start start))
1132          (and end   (hattr:set    'hbut:current 'lbl-end   end)))
1133         ((and label (listp label))
1134          (hattr:set 'hbut:current 'lbl-key (hbut:label-to-key (car label)))
1135          (hattr:set    'hbut:current 'lbl-start    (nth 1 label))
1136          (hattr:set    'hbut:current 'lbl-end      (nth 2 label)))
1137         (t (error "(ibut:label-set): Invalid label arg: '%s'" label)))
1138   t)
1139
1140 ;;;
1141 ;;; ibtype class - Implicit button types
1142 ;;;
1143
1144 (fset    'defib 'ibtype:create)
1145 (put     'ibtype:create 'lisp-indent-function 'defun)
1146 (defmacro ibtype:create (type params doc at-p &optional to-p style)
1147   "Creates implicit button TYPE (unquoted sym) with PARAMS, described by DOC.
1148 PARAMS are presently ignored.
1149
1150   AT-P is a boolean form of no arguments which determines whether or not point
1151 is within a button of this type.
1152   Optional TO-P is a boolean form which moves point immediately after the next
1153 button of this type within the current buffer and returns a list of (button-
1154 label start-pos end-pos), or nil when none is found.
1155   Optional STYLE is a display style specification to use when highlighting
1156 buttons of this type; most useful when TO-P is also given.
1157
1158 Returns symbol created when successful, else nil.  Nil indicates that action
1159 type for ibtype is presently undefined."
1160   (if type
1161       (let ((to-func (if to-p (action:create nil (list to-p))))
1162             (at-func (list at-p)))
1163         (` (htype:create (, type) ibtypes (, doc) nil (, at-func)
1164                          (list 'to-p (, to-func) 'style (, style)))))))
1165
1166 (defun    ibtype:delete (type)
1167   "Deletes an implicit button TYPE (a symbol).
1168 Returns TYPE's symbol if it existed, else nil."
1169   (htype:delete type 'ibtypes))
1170
1171 ;;;
1172 ;;; symset class - Hyperbole internal symbol set maintenance
1173 ;;;
1174
1175 (require 'set)
1176
1177 (defun    symset:add (elt symbol prop)
1178   "Adds ELT to SYMBOL's PROP set.
1179 Returns nil iff ELT is already in SET.  Uses 'eq' for comparison."
1180   (let* ((set (get symbol prop))
1181          (set:equal-op 'eq)
1182          (new-set (set:add elt set)))
1183     (and new-set (put symbol prop new-set))))
1184
1185 (fset    'symset:delete 'symset:remove)
1186
1187 (defun    symset:get (symbol prop)
1188   "Returns SYMBOL's PROP set."
1189   (get symbol prop))
1190
1191 (defun    symset:remove (elt symbol prop)
1192   "Removes ELT from SYMBOL's PROP set and returns the new set.
1193 Assumes PROP is a valid set.  Uses 'eq' for comparison."
1194   (let ((set (get symbol prop))
1195         (set:equal-op 'eq))
1196     (put symbol prop (set:remove elt set))))
1197
1198
1199 (provide 'hbut)
1200
1201 ;;; hbut.el ends here