Source

hyperbole / hbut.el

Full commit
   1
   2
   3
   4
   5
   6
   7
   8
   9
  10
  11
  12
  13
  14
  15
  16
  17
  18
  19
  20
  21
  22
  23
  24
  25
  26
  27
  28
  29
  30
  31
  32
  33
  34
  35
  36
  37
  38
  39
  40
  41
  42
  43
  44
  45
  46
  47
  48
  49
  50
  51
  52
  53
  54
  55
  56
  57
  58
  59
  60
  61
  62
  63
  64
  65
  66
  67
  68
  69
  70
  71
  72
  73
  74
  75
  76
  77
  78
  79
  80
  81
  82
  83
  84
  85
  86
  87
  88
  89
  90
  91
  92
  93
  94
  95
  96
  97
  98
  99
 100
 101
 102
 103
 104
 105
 106
 107
 108
 109
 110
 111
 112
 113
 114
 115
 116
 117
 118
 119
 120
 121
 122
 123
 124
 125
 126
 127
 128
 129
 130
 131
 132
 133
 134
 135
 136
 137
 138
 139
 140
 141
 142
 143
 144
 145
 146
 147
 148
 149
 150
 151
 152
 153
 154
 155
 156
 157
 158
 159
 160
 161
 162
 163
 164
 165
 166
 167
 168
 169
 170
 171
 172
 173
 174
 175
 176
 177
 178
 179
 180
 181
 182
 183
 184
 185
 186
 187
 188
 189
 190
 191
 192
 193
 194
 195
 196
 197
 198
 199
 200
 201
 202
 203
 204
 205
 206
 207
 208
 209
 210
 211
 212
 213
 214
 215
 216
 217
 218
 219
 220
 221
 222
 223
 224
 225
 226
 227
 228
 229
 230
 231
 232
 233
 234
 235
 236
 237
 238
 239
 240
 241
 242
 243
 244
 245
 246
 247
 248
 249
 250
 251
 252
 253
 254
 255
 256
 257
 258
 259
 260
 261
 262
 263
 264
 265
 266
 267
 268
 269
 270
 271
 272
 273
 274
 275
 276
 277
 278
 279
 280
 281
 282
 283
 284
 285
 286
 287
 288
 289
 290
 291
 292
 293
 294
 295
 296
 297
 298
 299
 300
 301
 302
 303
 304
 305
 306
 307
 308
 309
 310
 311
 312
 313
 314
 315
 316
 317
 318
 319
 320
 321
 322
 323
 324
 325
 326
 327
 328
 329
 330
 331
 332
 333
 334
 335
 336
 337
 338
 339
 340
 341
 342
 343
 344
 345
 346
 347
 348
 349
 350
 351
 352
 353
 354
 355
 356
 357
 358
 359
 360
 361
 362
 363
 364
 365
 366
 367
 368
 369
 370
 371
 372
 373
 374
 375
 376
 377
 378
 379
 380
 381
 382
 383
 384
 385
 386
 387
 388
 389
 390
 391
 392
 393
 394
 395
 396
 397
 398
 399
 400
 401
 402
 403
 404
 405
 406
 407
 408
 409
 410
 411
 412
 413
 414
 415
 416
 417
 418
 419
 420
 421
 422
 423
 424
 425
 426
 427
 428
 429
 430
 431
 432
 433
 434
 435
 436
 437
 438
 439
 440
 441
 442
 443
 444
 445
 446
 447
 448
 449
 450
 451
 452
 453
 454
 455
 456
 457
 458
 459
 460
 461
 462
 463
 464
 465
 466
 467
 468
 469
 470
 471
 472
 473
 474
 475
 476
 477
 478
 479
 480
 481
 482
 483
 484
 485
 486
 487
 488
 489
 490
 491
 492
 493
 494
 495
 496
 497
 498
 499
 500
 501
 502
 503
 504
 505
 506
 507
 508
 509
 510
 511
 512
 513
 514
 515
 516
 517
 518
 519
 520
 521
 522
 523
 524
 525
 526
 527
 528
 529
 530
 531
 532
 533
 534
 535
 536
 537
 538
 539
 540
 541
 542
 543
 544
 545
 546
 547
 548
 549
 550
 551
 552
 553
 554
 555
 556
 557
 558
 559
 560
 561
 562
 563
 564
 565
 566
 567
 568
 569
 570
 571
 572
 573
 574
 575
 576
 577
 578
 579
 580
 581
 582
 583
 584
 585
 586
 587
 588
 589
 590
 591
 592
 593
 594
 595
 596
 597
 598
 599
 600
 601
 602
 603
 604
 605
 606
 607
 608
 609
 610
 611
 612
 613
 614
 615
 616
 617
 618
 619
 620
 621
 622
 623
 624
 625
 626
 627
 628
 629
 630
 631
 632
 633
 634
 635
 636
 637
 638
 639
 640
 641
 642
 643
 644
 645
 646
 647
 648
 649
 650
 651
 652
 653
 654
 655
 656
 657
 658
 659
 660
 661
 662
 663
 664
 665
 666
 667
 668
 669
 670
 671
 672
 673
 674
 675
 676
 677
 678
 679
 680
 681
 682
 683
 684
 685
 686
 687
 688
 689
 690
 691
 692
 693
 694
 695
 696
 697
 698
 699
 700
 701
 702
 703
 704
 705
 706
 707
 708
 709
 710
 711
 712
 713
 714
 715
 716
 717
 718
 719
 720
 721
 722
 723
 724
 725
 726
 727
 728
 729
 730
 731
 732
 733
 734
 735
 736
 737
 738
 739
 740
 741
 742
 743
 744
 745
 746
 747
 748
 749
 750
 751
 752
 753
 754
 755
 756
 757
 758
 759
 760
 761
 762
 763
 764
 765
 766
 767
 768
 769
 770
 771
 772
 773
 774
 775
 776
 777
 778
 779
 780
 781
 782
 783
 784
 785
 786
 787
 788
 789
 790
 791
 792
 793
 794
 795
 796
 797
 798
 799
 800
 801
 802
 803
 804
 805
 806
 807
 808
 809
 810
 811
 812
 813
 814
 815
 816
 817
 818
 819
 820
 821
 822
 823
 824
 825
 826
 827
 828
 829
 830
 831
 832
 833
 834
 835
 836
 837
 838
 839
 840
 841
 842
 843
 844
 845
 846
 847
 848
 849
 850
 851
 852
 853
 854
 855
 856
 857
 858
 859
 860
 861
 862
 863
 864
 865
 866
 867
 868
 869
 870
 871
 872
 873
 874
 875
 876
 877
 878
 879
 880
 881
 882
 883
 884
 885
 886
 887
 888
 889
 890
 891
 892
 893
 894
 895
 896
 897
 898
 899
 900
 901
 902
 903
 904
 905
 906
 907
 908
 909
 910
 911
 912
 913
 914
 915
 916
 917
 918
 919
 920
 921
 922
 923
 924
 925
 926
 927
 928
 929
 930
 931
 932
 933
 934
 935
 936
 937
 938
 939
 940
 941
 942
 943
 944
 945
 946
 947
 948
 949
 950
 951
 952
 953
 954
 955
 956
 957
 958
 959
 960
 961
 962
 963
 964
 965
 966
 967
 968
 969
 970
 971
 972
 973
 974
 975
 976
 977
 978
 979
 980
 981
 982
 983
 984
 985
 986
 987
 988
 989
 990
 991
 992
 993
 994
 995
 996
 997
 998
 999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
;;; hbut.el --- Hyperbole button constructs.

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

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

;; This file is part of GNU Hyperbole.

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

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

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

;;; Commentary:

;;; Code:

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

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

;;;
;;; Public definitions
;;;

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

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

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


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

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

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

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

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

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

(defun    ebut:get (&optional lbl-key buffer key-src)
  "Returns explicit Hyperbole button symbol given by LBL-KEY and BUFFER.
KEY-SRC is given when retrieving global buttons and is full source pathname.
Retrieves button data, converts into a button object and returns a symbol
which references the button.

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

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

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

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

(defun    ebut:key-src-fmt ()
  "Returns unformatted filename associated with formatted current buffer.
This is used to obtain the source of explicit buttons for buffers that
represent the output of particular document formatters."
  (cond ((or (eq major-mode 'Info-mode)
	     (string-match "\\.info\\(-[0-9]+\\)?$" (buffer-name)))
	 (let ((src (and buffer-file-name
			 (substring
			  buffer-file-name
			  0 (string-match "\\.[^.]+$" buffer-file-name)))))
	   (cond ((file-exists-p (concat src ".texi"))
		  (concat src ".texi"))
		 ((file-exists-p (concat src ".texinfo"))
		  (concat src ".texinfo"))
		 ((current-buffer)))))
	))

(defun    ebut:key-to-label (lbl-key)
  "Unnormalizes LBL-KEY and returns a label string approximating actual label."
  (if lbl-key
      (let* ((pos 0) (len (length lbl-key)) (lbl) c)
	(while (< pos len)
	  (setq c (aref lbl-key pos)
		lbl (concat lbl 
			    (if (= c ?_)
				(if (or (= (1+ pos) len)
					(/= (aref lbl-key (1+ pos)) ?_))
				    " "
				  (setq pos (1+ pos))
				  "_")
			      (char-to-string c)))
		pos (1+ pos)))
	lbl)))

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

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

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

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

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

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

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

(defun    ebut:next-occurrence (lbl-key &optional buffer)
  "Moves point to next occurrence of button with LBL-KEY in optional BUFFER.
BUFFER defaults to current buffer.  It may be a buffer name.
Returns non-nil iff occurrence is found.

Remember to use (goto-char (point-min)) before calling this in order to
move to the first occurrence of the button."
  (if buffer
      (if (not (or (bufferp buffer)
		   (and (stringp buffer) (get-buffer buffer))))
	  (error "(ebut:next-occurrence): Invalid buffer arg: %s" buffer)
	(switch-to-buffer buffer)))
  (if (re-search-forward (ebut:label-regexp lbl-key) nil t)
      (goto-char (+ (match-beginning 0) (length ebut:start)))))

(defun    ebut:operate (curr-label new-label)
  "Operates on a new or existing Hyperbole button given by CURR-LABEL.
When NEW-LABEL is non-nil, this is substituted for CURR-LABEL and the
associated button is modified.  Otherwise, a new button is created.
Returns instance string appended to label to form unique label, nil if
label is already unique.  Signals an error when no such button is found
in the current buffer."
  (let* ((lbl-key (ebut:label-to-key curr-label))
	 (lbl-regexp (ebut:label-regexp lbl-key))
	 (modify new-label)
	 (instance-flag))
    (or new-label (setq new-label curr-label))
    (hattr:set 'hbut:current 'lbl-key (ebut:label-to-key new-label))
    (save-excursion
      (if (setq instance-flag
		(if modify (ebut:modify lbl-key) (ebut:create)))
	  (if (hmail:editor-p) (hmail:msg-narrow))))
    (if instance-flag
	(progn
	  ;; Rename all occurrences of button - those with same label.
	  (if modify
	      (let* ((but-key-and-pos (ebut:label-p nil nil nil 'pos))
		     (at-but (equal (car but-key-and-pos)
				    (ebut:label-to-key new-label))))
		(if at-but
		    (ebut:delimit (nth 1 but-key-and-pos)
				  (nth 2 but-key-and-pos)
				  instance-flag))
		(cond ((ebut:map
			(function
			 (lambda (lbl start end)
			   (delete-region start end)
			   (ebut:delimit
			    (point)
			    (progn (insert new-label) (point))
			    instance-flag)))
			nil nil lbl-regexp 'include-delims))
		      (at-but)
		      ((hypb:error "(ebut:operate): No button matching: %s" curr-label))))
	    ;; Add a new button.
	    (let (start end buf-lbl)
	      (cond ((and (marker-position (hypb:mark-marker t))
			  (setq start (region-beginning)
				end (region-end)
				buf-lbl (buffer-substring start end))
			  (equal buf-lbl curr-label))
		     nil)
		    ((looking-at (regexp-quote curr-label))
		     (setq start (point)
			   end (match-end 0)))
		    (t (setq start (point))
		       (insert curr-label)
		       (setq end (point))))
	      (ebut:delimit start end instance-flag))
	    )
	  ;; Position point
	  (let ((new-key (ebut:label-to-key new-label)))
	    (cond ((equal (ebut:label-p) new-key)
		   (forward-char 1) (search-backward ebut:start nil t)
		   (goto-char (match-end 0)))
		  ((let ((regexp (ebut:label-regexp new-key)))
		     (or (re-search-forward  regexp nil t)
			 (re-search-backward regexp nil t)))
		   (goto-char (+ (match-beginning 0) (length ebut:start))))))
	  ;; instance-flag might be 't which we don't want to return.
	  (if (stringp instance-flag) instance-flag))
      (hypb:error
       "(ebut:operate): Operation failed.  Check button attribute permissions: %s"
       hattr:filename))))

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

;;; ----
(defun    ebut:delimit (start end instance-str)
  "Delimits button label spanning region START to END in current buffer.
If button is already delimited or delimit fails, returns nil, else t.
Inserts INSTANCE-STR after END, before ending delimiter."
  (goto-char start)
  (if (looking-at (regexp-quote ebut:start))
      (forward-char (length ebut:start)))
  (if (ebut:label-p)
      nil
    (if (not (stringp instance-str)) (setq instance-str ""))
    (insert ebut:start)
    (goto-char (setq end (+ end (length ebut:start))))
    (insert instance-str ebut:end)
    (setq end (+ end (length instance-str) (length ebut:end)))
    (and (fboundp 'hproperty:but-add) (hproperty:but-add start end hproperty:but))
    (hbut:comment start end)
    (goto-char end)
    t))

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

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

;;;
;;; gbut class - Global Hyperbole buttons - activated by typing label name
;;;

(defvar gbut:file (expand-file-name hbmap:filename hbmap:dir-user)
  "File that stores Hyperbole buttons accessible by name, global buttons.")

(defun gbut:act (label)
  "Activates Hyperbole global button with LABEL."
  (interactive (list (hargs:read-match "Activate global button labeled: "
				       (mapcar 'list (gbut:lbl-list))
				       nil t nil 'ebut)))
  (let* ((lbl-key (hbut:label-to-key label))
	 (but (ebut:get lbl-key nil gbut:file)))
    (if but
	(hbut:act but)
      (error "(gbut:act): No global button labeled: %s" label))))

(defun gbut:help (label)
  "Displays help for Hyperbole global button with LABEL."
  (interactive (list (hargs:read-match "Report on global button labeled: "
				       (mapcar 'list (gbut:lbl-list))
				       nil t nil 'ebut)))
  (let* ((lbl-key (hbut:label-to-key label))
	 (but (ebut:get lbl-key nil gbut:file)))
    (if but
	(hbut:report but)
      (error "(gbut:help): No global button labeled: %s" label))))

;;; ----
(defun gbut:key-list ()
  "Returns list of global button label keys."
  (save-excursion
    (if (hbdata:to-entry-buf gbut:file)
	(let ((gbuts))
	  (save-restriction
	    (narrow-to-region (point) (if (search-forward "\^L" nil t)
					  (point) (point-max)))
	    (goto-char (point-min))
	    (condition-case ()
		(while (setq gbuts (cons (car (read (current-buffer))) gbuts)))
	      (error nil))
	    gbuts)))))

(defun gbut:lbl-list ()
  "Returns list of global button labels."
  (mapcar 'hbut:key-to-label (gbut:key-list)))

;;;
;;; hattr class
;;;

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

(defun    hattr:clear (hbut)
  "Removes all of HBUT's attributes except `variable-documentation'."
  (let (sublist)
    (or (symbolp hbut)
	(error "(hattr:clear): Argument not a Hyperbole button: %s" hbut))
    (if (setq sublist (memq 'variable-documentation (symbol-plist hbut)))
	(progn
	  (setcdr (cdr sublist) nil)
	  (setplist hbut sublist))
      (setplist hbut nil)
      )))

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

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

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

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

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

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

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

(fset    'hattr:summarize 'hattr:report)

(defvar   hattr:filename
  (if (memq system-type '(ms-windows windows-nt ms-dos)) "_hypb" ".hypb")
  "Per directory file name in which explicit button attributes are stored.
If you change its value, you will be unable to use buttons created by
others who use a different value!")

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

(defun    hbut:act (hbut)
  "Performs action for explicit or implicit Hyperbole button symbol HBUT."
  (and hbut (apply 'actype:act (hattr:get hbut 'actype)
		   (hattr:get hbut 'args))))

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

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


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

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

(defun    hbut:fill-prefix-remove (label)
  "Removes any recognized fill prefix from within LABEL.
'hbut:fill-prefix-regexps' is a list of fill prefixes to recognize."
  (if (string-match "\n" label)
      (mapcar
       (function
	(lambda (fill-prefix)
	  (and (string-match "\n" label)
	       (setq label
		     (hypb:replace-match-string fill-prefix label " " t)))))
       hbut:fill-prefix-regexps))
  label)

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

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

(defun    hbut:label (hbut)
  "Returns the label for Hyperbole button symbol HBUT."
  (if (hbut:is-p hbut)
      (hbut:key-to-label (hattr:get hbut 'lbl-key))
    (error "(hbut:label): Argument is not a Hyperbole button symbol, '%s'"
	   hbut)))

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

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

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

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

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

(fset    'hbut:summarize 'hbut:report)

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

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

;;;
;;; htype class - Hyperbole Types, e.g. action and implicit button types
;;;

(require 'set)

(defun    htype:body (htype-sym)
  "Return body for HTYPE-SYM.  If HTYPE-SYM is nil, return nil."
  (and htype-sym (hypb:indirect-function htype-sym)))

(defun    htype:category (type-category)
  "Return list of symbols in Hyperbole TYPE-CATEGORY in priority order.
Symbols contain category component.
TYPE-CATEGORY should be 'actypes, 'ibtypes or nil for all."
  (let ((types (symset:get type-category 'symbols))
	(categ-name (symbol-name type-category)))
    (mapcar (function
	     (lambda (type)
	       (intern (concat categ-name "::" (symbol-name type)))))
	    types)))

;; Thanks to JWZ for help on this.
(defmacro htype:create (type type-category doc params body property-list)
  "Create a new Hyperbole TYPE within TYPE-CATEGORY (both unquoted symbols).
Third arg DOC is a string describing the type.
Fourth arg PARAMS is a list of parameters to send to the fifth arg BODY,
which is a list of forms executed when the type is evaluated.
Sixth arg PROPERTY-LIST is attached to the new type's symbol.

This symbol is returned."
  (let* ((sym (htype:symbol type type-category))
	(action (nconc (list 'defun sym params doc) body)))
    (` (progn
	 (, action)
	 (setplist '(, sym) (, property-list))
	 (symset:add '(, type) '(, type-category) 'symbols)
	 (run-hooks 'htype:create-hook)
	 '(, sym)))))

(defun    htype:delete (type type-category)
  "Delete a Hyperbole TYPE derived from TYPE-CATEGORY (both symbols).
Return the Hyperbole symbol for the TYPE if it existed, else nil."
  (let* ((sym (htype:symbol type type-category))
	 (exists (fboundp 'sym)))
    (setplist sym nil)
    (symset:delete type type-category 'symbols)
    (fmakunbound sym)
    (run-hooks 'htype:delete-hook)
    (and exists sym)))

(defun    htype:doc (type)
  "Return documentation for Hyperbole TYPE, a symbol."
  (documentation type))

(defun    htype:names (type-category &optional sym)
  "Return list of current names for Hyperbole TYPE-CATEGORY in priority order.
Names do not contain category component.
TYPE-CATEGORY should be 'actypes, 'ibtypes or nil for all.
When optional SYM is given, return the name for that symbol only, if any."
  (let ((types (symset:get type-category 'symbols))
	(sym-name (and sym (symbol-name sym))))
    (if sym-name
	;; Strip category from sym-name before looking for a match.
	(progn (if (string-match "::" sym-name)
		   (setq sym (intern (substring sym-name (match-end 0)))))
	       (if (memq sym types) (symbol-name sym)))
      (mapcar 'symbol-name types))))

;;; ----

(defun   htype:symbol (type type-category)
  "Return Hyperbole type symbol composed from TYPE and TYPE-CATEGORY (both symbols)."
  (intern (concat (symbol-name type-category) "::"
		  (symbol-name type))))

;;;
;;; ibut class - Implicit Hyperbole Buttons
;;;

(defun    ibut:at-p (&optional key-only)
  "Returns symbol for implicit button at point, else nil.
With optional KEY-ONLY, returns only the label key for button."
  (let ((types (htype:category 'ibtypes))
	;; Global var used in (hact) function, don't delete.
	(hrule:action 'actype:identity)
	(itype)
	(args)
	(is-type))
    (or key-only (hattr:clear 'hbut:current))
    (while (and (not is-type) types)
      (setq itype (car types))
      (if (setq args (funcall itype))
	  (setq is-type itype)
	(setq types (cdr types))))
    (if is-type
	(if key-only
	    (hattr:get 'hbut:current 'lbl-key)
	  (hattr:set 'hbut:current 'loc (save-excursion
					  (hbut:key-src 'full)))
	  (hattr:set 'hbut:current 'categ is-type)
	  (or (hattr:get 'hbut:current 'args)
	      (not (listp args))
	      (progn
		(hattr:set 'hbut:current 'actype
			   (or
			     ;; Hyperbole action type
			     (intern-soft (concat "actypes::"
						  (symbol-name (car args))))
			     ;; Regular Emacs Lisp function symbol
			     (car args)
			     ))
		(hattr:set 'hbut:current 'args (cdr args))))
	  'hbut:current))))

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

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

(defun    ibut:label-set (label &optional start end)
  "Sets current implicit button attributes from LABEL and START, END position.
START and END are optional.  When given, they specify the region in the buffer
to flash when this implicit button is activated or queried for its attributes.
If LABEL is a list, it is assumed to contain all arguments."
  (cond ((stringp label)
	 (hattr:set 'hbut:current 'lbl-key (hbut:label-to-key label))
	 (and start (hattr:set    'hbut:current 'lbl-start start))
	 (and end   (hattr:set    'hbut:current 'lbl-end   end)))
	((and label (listp label))
	 (hattr:set 'hbut:current 'lbl-key (hbut:label-to-key (car label)))
	 (hattr:set    'hbut:current 'lbl-start    (nth 1 label))
	 (hattr:set    'hbut:current 'lbl-end      (nth 2 label)))
	(t (error "(ibut:label-set): Invalid label arg: '%s'" label)))
  t)

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

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

  AT-P is a boolean form of no arguments which determines whether or not point
is within a button of this type.
  Optional TO-P is a boolean form which moves point immediately after the next
button of this type within the current buffer and returns a list of (button-
label start-pos end-pos), or nil when none is found.
  Optional STYLE is a display style specification to use when highlighting
buttons of this type; most useful when TO-P is also given.

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

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

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

(require 'set)

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

(fset    'symset:delete 'symset:remove)

(defun    symset:get (symbol prop)
  "Returns SYMBOL's PROP set."
  (get symbol prop))

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


(provide 'hbut)

;;; hbut.el ends here