forked from rswgnu/hyperbole
-
Notifications
You must be signed in to change notification settings - Fork 0
/
hbut.el
2317 lines (2084 loc) · 88.7 KB
/
hbut.el
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
;;; hbut.el --- GNU Hyperbole button constructs -*- lexical-binding: t; -*-
;;
;; Author: Bob Weiner
;;
;; Orig-Date: 18-Sep-91 at 02:57:09
;; Last-Mod: 26-Nov-22 at 17:21:53 by Bob Weiner
;;
;; Copyright (C) 1991-2022 Free Software Foundation, Inc.
;; See the "HY-COPY" file for license information.
;;
;; This file is part of GNU Hyperbole.
;;; Commentary:
;;; Code:
;;; ************************************************************************
;;; Other required Elisp libraries
;;; ************************************************************************
(eval-and-compile (mapc #'require '(cl-lib elisp-mode help-mode hversion
hmoccur hbmap htz hbdata hact view)))
;;; ************************************************************************
;;; Public declarations
;;; ************************************************************************
(declare-function www-url "hsys-www" (url))
(defvar hproperty:but-face)
;;; ************************************************************************
;;; 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.")
(defun ebut:act (label)
"Activate Hyperbole explicit button with LABEL from the current buffer."
(interactive (list (hargs:read-match "Activate explicit button labeled: "
(ebut:alist)
nil t nil 'ebut)))
(let* ((lbl-key (hbut:label-to-key label))
(but (ebut:get lbl-key)))
(if but
(hbut:act but)
(error "(ebut:act): No explicit button labeled: %s" label))))
(defun ebut:alist (&optional file)
"Return alist of ebuts in FILE or the current buffer.
Each element is a list of just an explicit button label. For use
as a completion table."
(mapcar #'list (ebut:list file)))
(defun ebut:at-p (&optional start-delim end-delim)
"Return explicit Hyperbole button at point or nil.
Assume point is within first line of button label, if at all.
Optional START-DELIM and END-DELIM are strings that override default
button delimiters."
(ebut:get nil nil nil start-delim end-delim))
(defun ebut:create (&optional but-sym)
"Create 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, return any instance number to append to button label
except when instance number would be 1, then return t. On failure,
return nil.
If successful, leave 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)
"Delete Hyperbole explicit button based on optional BUT-SYM.
Default is `hbut:current'.
Return entry deleted (a list of attribute values) or nil."
(unless but-sym
(setq but-sym (ebut:at-p)))
(when (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:edit (&optional lbl-key but-sym)
"Edit 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, return button's instance number, except when instance
number is 1, then return t. On failure, as when button does not exist,
return nil.
Do not save button data buffer."
(save-excursion
(let ((lbl-instance (hbdata:write lbl-key but-sym)))
(run-hooks 'ebut-edit-hook)
lbl-instance)))
(defun ebut:get (&optional lbl-key buffer key-src start-delim end-delim)
"Return explicit Hyperbole button symbol given by LBL-KEY and BUFFER.
KEY-SRC is given when retrieving global buttons and is the full source pathname.
Retrieve button data, convert into a button object and return a symbol
which references the button.
All arguments are optional. When none are given, return a symbol for
the button that point is within. BUFFER defaults to the current
buffer.
Return nil if no matching button is found."
(hattr:clear 'hbut:current)
(save-excursion
(let (actype
but-data
key-dir
key-file
lbl-end
lbl-key-and-pos
lbl-start)
(unless lbl-key
(setq lbl-key-and-pos (ebut:label-p nil start-delim end-delim t)
lbl-key (nth 0 lbl-key-and-pos)
lbl-start (nth 1 lbl-key-and-pos)
lbl-end (nth 2 lbl-key-and-pos)))
(when buffer
(if (bufferp buffer)
(set-buffer buffer)
(error "(ebut:get): Invalid buffer argument: %s" buffer)))
(when (not key-src)
(when (not (equal lbl-key (ebut:label-p nil start-delim end-delim)))
(goto-char (point-min))
(ebut:next-occurrence lbl-key))
(when (setq key-src (ebut:to-key-src 'full))
;; `ebut:to-key-src' sets current buffer to key-src buffer.
(setq buffer (current-buffer))))
(when (and (stringp lbl-key) key-src)
(when (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)))
(when but-data
(hattr:set 'hbut:current 'lbl-key lbl-key)
(when lbl-start
(hattr:set 'hbut:current 'lbl-start lbl-start))
(when lbl-end
(hattr:set 'hbut:current 'lbl-end lbl-end))
(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
(when (= (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)
"Return non-nil if OBJECT is a symbol representing an explicit Hyperbole button."
(and (symbolp object)
(eq (hattr:get object 'categ) 'explicit)))
(defun ebut:key (ebut)
"Return the key for Hyperbole explicit button symbol EBUT."
(if (ebut:is-p ebut)
(hattr:get ebut 'lbl-key)
(error "(ebut:key): Argument is not a Hyperbole explicit button symbol, `%s'"
ebut)))
(defun ebut:key-of-label-p (key label)
"Return t iff KEY matches to LABEL in a case insensitive manner."
(and (stringp key) (stringp label)
(equal key (downcase (ebut:label-to-key label)))))
(defalias 'ebut:to-key-src #'hbut:to-key-src)
(defalias 'ebut:key-src-set-buffer #'hbut:key-src-set-buffer)
(defalias 'ebut:key-src-fmt #'hbut:key-src-fmt)
(defalias 'ebut:key-to-label #'hbut:key-to-label)
(defun ebut:label-p (&optional as-label start-delim end-delim pos-flag two-lines-flag)
"Return key for the explicit button label that point is within, else nil.
This is the normalized key form of the explicit button's label.
Assume point is within the first line of any button label. All
following arguments are optional. If AS-LABEL is non-nil, return
label rather than the key derived from the label. START-DELIM
and END-DELIM are strings that override default button
delimiters. With POS-FLAG non-nil, return the list of label-or-key,
but-start-position, but-end-position. Positions include
delimiters. With TWO-LINES-FLAG non-nil, constrain label search
to two lines."
(let ((opoint (point))
(quoted "\\(^\\|[^\\{$]\\)")
(hbut:max-len hbut:max-len)
npoint start lbl-key end but-start but-end start-regexp end-regexp)
(unless start-delim (setq start-delim ebut:start))
(unless end-delim (setq end-delim ebut:end))
(setq npoint (+ opoint (length start-delim))
start-regexp (regexp-quote start-delim)
end-regexp (regexp-quote end-delim))
;; Ensure label is not blank and point is within matching delimiters
(save-excursion
(forward-line 0)
(while (and (progn
(while (and (< (point) npoint)
(re-search-forward (concat quoted start-regexp) npoint t))
(setq start t))
start)
;; Handle expressions like:
;; { M-x shell RET M-> (cd ${hyperb:dir}) RET }
(save-excursion
(when (eq ?\( (char-syntax (preceding-char)))
(condition-case ()
(progn
(forward-char -1)
(forward-list))
(error nil)))
(< (point) opoint))
(re-search-forward (concat "[^\\{]" end-regexp) opoint t))
(setq start nil))
(when start
(setq start (point)
but-start (match-end 1))
(if (eq ?\( (char-syntax (preceding-char)))
(condition-case ()
(progn
(forward-char -1)
(forward-list)
(forward-char -2))
(error (goto-char (max (1- opoint) start))))
(goto-char (max (1- opoint) start)))
(when two-lines-flag
(save-excursion
(forward-line 2)
(setq hbut:max-len (- (point) start))))
(and (< (point) (+ start (hbut:max-len)))
(re-search-forward (concat quoted end-regexp) (+ start (hbut:max-len)) t)
(setq but-end (point)
end (- (point) (length end-delim))
lbl-key (ebut:label-to-key (buffer-substring-no-properties 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))))))))
(defalias 'ebut:label-regexp #'hbut:label-regexp)
(defalias 'ebut:label-to-key #'hbut:label-to-key)
(defun ebut:list (&optional file loc-p)
"Return list of button labels from in FILE or the current buffer.
Remove duplicate labels if optional LOC-P is omitted. With LOC-P, return
list of elements (label start end) where start and end are the buffer
positions at which the button delimiter begins and ends."
(interactive)
(setq file (if file (and (file-exists-p file) (find-file-noselect file))
(current-buffer)))
(when file
(set-buffer file)
(let ((buts (ebut:map (if loc-p
(lambda (lbl start end)
;; Normalize label spacing
(list (ebut:key-to-label (ebut:label-to-key lbl))
start end))
(lambda (lbl _start _end)
;; Normalize label spacing
(ebut:key-to-label (ebut:label-to-key lbl)))))))
(if loc-p buts (when buts (apply #'set:create buts))))))
(defalias 'map-ebut #'ebut:map)
(defun ebut:map (but-func &optional regexp-match include-delims)
"Apply BUT-FUNC to the explicit buttons in the visible part of current buffer.
If REGEXP-MATCH is non-nil, only buttons which match this argument are
considered.
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)."
(hbut:map but-func ebut:start ebut:end regexp-match include-delims))
(defun ebut:next-occurrence (lbl-key &optional buffer)
"Move point to next occurrence of button with LBL-KEY in optional BUFFER.
BUFFER defaults to current buffer. It may be a buffer name.
Return 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)
"Operate on and modify properties of an explicit 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.
If CURR-LABEL is nil, the text in the active region is used as the
button label, if any, otherwise, an error is signaled.
Return instance string appended to label to form a per-buffer unique
label; nil if label is already unique. Signal 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))
(unless new-label
(setq new-label curr-label))
(hattr:set 'hbut:current 'lbl-key (ebut:label-to-key new-label))
(save-excursion
(when (setq instance-flag
(if modify (ebut:edit lbl-key) (ebut:create)))
(when (hmail:editor-p)
(hmail:msg-narrow))))
(cond (modify
;; Rename all occurrences of button - those with same label
(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))))
(when at-but
(ebut:delimit (nth 1 but-key-and-pos)
(nth 2 but-key-and-pos)
instance-flag))
(cond ((ebut:map
(lambda (_lbl start end)
(delete-region start end)
(ebut:delimit
(point)
(progn (insert new-label) (point))
instance-flag))
lbl-regexp 'include-delims))
(at-but)
((hypb:error "(ebut:operate): No button matching: %s" curr-label)))))
(instance-flag
;; Add a new button recording its start and end positions
(let (start end mark prev-point buf-lbl)
(cond ((not curr-label)
(setq start (point))
(insert new-label)
(setq end (point)))
((and (hmouse-use-region-p)
(if (hyperb:stack-frame
'(hui:ebut-create hui:ebut-edit hui:ebut-edit-region hui:gbut-create
hui:gbut-edit hui:link-create ebut:program))
;; Ignore action-key-depress-prev-point
(progn (setq mark (marker-position (mark-marker))
start (region-beginning)
end (region-end)
buf-lbl (buffer-substring-no-properties start end))
(equal buf-lbl curr-label))
;; Utilize any action-key-depress-prev-point
(setq mark (marker-position (mark-marker)))
(setq prev-point (and action-key-depress-prev-point
(marker-position action-key-depress-prev-point)))
(setq start (if (and prev-point mark (<= prev-point mark))
prev-point
(region-beginning))
end (if (and prev-point mark (> prev-point mark))
prev-point
(region-end))
buf-lbl (buffer-substring-no-properties start end))
(equal buf-lbl curr-label)))
nil)
((progn (when start (goto-char start))
(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)
(goto-char start)))
(t (hypb:error
"(ebut:operate): Operation failed. Check button attribute permissions: %s"
hattr:filename)))
;; Append any instance-flag string to the button label
(when (stringp instance-flag)
(setq new-label (concat new-label instance-flag))
(hattr:set 'hbut:current 'lbl-key (ebut:label-to-key new-label)))
;; Position point
(let ((new-key (ebut:label-to-key new-label)))
(cond ((equal (ebut:label-p) new-key)
;; In case right before the start of the desired
;; button's delimiters.
(forward-char 2) (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.
(when (stringp instance-flag) instance-flag)))
(defun ebut:program (label actype &rest args)
"Programmatically create an explicit Hyperbole button at point.
Create button from LABEL, ACTYPE (action type), and optional actype ARGS.
Insert LABEL text at point surrounded by <( )> delimiters, adding any
necessary instance number of the button after the LABEL. ACTYPE may
be a Hyperbole action type name (from defact) or an Emacs Lisp
function, followed by a list of arguments for the actype, aside from
the button LABEL which is automatically provided as the first argument.
For interactive creation, use `hui:ebut-create' instead."
(save-excursion
(let ((but-buf (current-buffer))
(actype-sym (actype:action actype)))
(hui:buf-writable-err but-buf "ebut-create")
(condition-case err
(progn
(hattr:clear 'hbut:current)
(hattr:set 'hbut:current 'loc (hui:key-src but-buf))
(hattr:set 'hbut:current 'dir (hui:key-dir but-buf))
(if (or (and actype-sym (fboundp actype-sym))
(functionp actype))
(hattr:set 'hbut:current 'actype actype)
(error (format "(%s)" actype)))
(hattr:set 'hbut:current 'args args)
(ebut:operate label nil))
(error (hattr:clear 'hbut:current)
(if (and (listp (cdr err)) (= (length (cdr err)) 1))
(error (format "(ebut:program): actype arg must be a bound symbol (not a string): %s" actype))
(error "(ebut:program): %s" err)))))))
(defun ebut:search (string out-buf &optional match-part)
"Write explicit button lines matching STRING to OUT-BUF.
Search across all files into which the user has previously saved
explicit buttons. By default, find matches for whole button
labels only; optional MATCH-PART enables partial matches."
(let* ((buffers (mapcar (lambda (dir)
(expand-file-name hattr:filename dir))
(hbmap:dir-list)))
(total 0)
(firstmatch))
(with-current-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)
(with-current-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:to (lbl-key)
"Find the nearest explicit button with LBL-KEY (a label or label key).
Search within the visible portion of the current buffer. Leave
point inside the button label. Return the symbol for the button,
else nil."
(unless lbl-key
(setq lbl-key (ebut:label-p nil nil nil nil t)))
(hbut:funcall (lambda (lbl-key _buffer _key-src)
;; Handle a label given rather than a label key
(if (string-match-p "\\s-" lbl-key)
(setq lbl-key (ebut:label-to-key lbl-key)))
(let ((regexp (hbut:label-regexp lbl-key t))
pos
found)
(save-excursion
;; Since point might be in the middle of the matching button,
;; move to the start of line to ensure don't miss it when
;; searching forward.
(forward-line 0)
;; re-search forward
(while (and (not found) (re-search-forward regexp nil t))
(setq pos (match-beginning 0)
found (equal (ebut:label-p nil nil nil nil t) lbl-key)))
;; re-search backward
(while (and (not found) (re-search-backward regexp nil t))
(setq pos (match-beginning 0)
found (equal (ebut:label-p nil nil nil nil t) lbl-key))))
(when found
(goto-char pos)
(ebut:at-p))))
lbl-key))
;;; ------------------------------------------------------------------------
(defun ebut:delimit (start end instance-flag)
"Delimit button label spanning region START to END in current buffer.
If button is already delimited or delimit fails, return nil, else t.
Insert INSTANCE-FLAG after END, before ending delimiter."
(goto-char start)
(when (looking-at (regexp-quote ebut:start))
(forward-char (length ebut:start)))
(unless (ebut:label-p)
(setq start (move-marker (make-marker) start)
end (move-marker (make-marker) end))
(set-marker-insertion-type end t)
;; instance-flag may be 't to indicate don't add an instance number
(unless (stringp instance-flag)
(setq instance-flag ""))
(insert ebut:start)
(goto-char end)
(insert instance-flag ebut:end)
;; Insert any comment delimiter before the start marker.
(set-marker-insertion-type start t)
(hbut:comment start end)
(when (fboundp 'hproperty:but-add)
(hproperty:but-add start end hproperty:but-face))
(goto-char end)
(move-marker start nil)
(move-marker end nil)
t))
(defun ebut:match-regexp (match-keys match-part)
"Return regexp to match to all explicit button keys from MATCH-KEYS."
(setq match-part (if match-part
(concat "[^" (substring ebut:end -1) "]*")
"[ \t\n\r]*"))
(concat
(regexp-quote ebut:start) match-part
"\\(" (mapconcat (lambda (key) (ebut:label-regexp key 'no-delim))
match-keys "\\|")
"\\)" match-part (regexp-quote ebut:end)))
(defconst ebut:start "<("
"String matching the start of a Hyperbole explicit hyper-button.")
(defconst ebut:end ")>"
"String matching the end of a Hyperbole explicit 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
;;; ========================================================================
(defun gbut:act (label)
"Activate Hyperbole global button with LABEL."
(interactive (list (hargs:read-match "Activate global button labeled: "
(mapcar #'list (gbut:label-list))
nil t nil 'gbut)))
(cond ((null label)
(error "(gbut:act): You have not created any global buttons"))
((equal label "")
(error "(gbut:act): Please try again and type ? for a list of existing global button names"))
(t (let* ((lbl-key (hbut:label-to-key label))
(but (gbut:get lbl-key)))
(if but
(hbut:act but)
(error "(gbut:act): No global button found for label: %s" label))))))
(defun gbut:delete (&optional lbl-key)
"Delete Hyperbole global button based on optional LBL-KEY or button at point.
Return entry deleted (a list of attribute values) or nil."
(hbut:delete lbl-key nil (gbut:file)))
(defun gbut:ebut-program (label actype &rest args)
"Programmatically create a global explicit Hyperbole button at point.
Create button from LABEL, ACTYPE (action type), and optional actype ARGS.
Insert LABEL text at the end of the personal/global button file
surrounded by <( )> delimiters, adding any necessary instance
number of the button after the LABEL. ACTYPE may be a Hyperbole
action type name (from defact) or an Emacs Lisp function,
followed by a list of arguments for the actype, aside from the
button LABEL which is automatically provided as the first
argument.
For interactive creation, use `hui:gbut-create' instead."
(save-excursion
(with-current-buffer (hpath:find-noselect (expand-file-name hbmap:filename hbmap:dir-user))
(save-excursion
(goto-char (point-max))
(when (not (bolp))
(insert "\n"))
(eval `(ebut:program ',label ',actype ,@args))))))
(defun gbut:file ()
"Return the absolute path for the global button (those accessed by name) file."
(expand-file-name hbmap:filename hbmap:dir-user))
(defun gbut:get (&optional lbl-key)
"Return global button symbol given by optional LBL-KEY if found in (gbut:file).
Retrieve any button data, convert into a button object and return a symbol
which references the button.
All arguments are optional. When none are given, return a symbol for
the button that point is within.
Return nil if no matching button is found."
(hbut:get lbl-key nil (gbut:file)))
(defun gbut:help (label)
"Display help for Hyperbole global button with LABEL."
(interactive (list (hargs:read-match "Report on global button labeled: "
(mapcar 'list (gbut:label-list))
nil t nil 'hbut)))
(let* ((lbl-key (hbut:label-to-key label))
(but (hbut:get lbl-key nil (gbut:file))))
(if but
(hbut:report but)
(error "(gbut:help): No global button labeled: %s" label))))
(defun gbut:label-list ()
"Return list of global button labels."
(mapcar #'hbut:key-to-label (gbut:key-list)))
(defun gbut:label-p (&optional as-label start-delim end-delim pos-flag two-lines-flag)
"Return key for the Hyperbole global button label that point is within, else nil.
This is the normalized key form of the explicit button's label.
Assume point is within the first line of any button label. All
following arguments are optional. If AS-LABEL is non-nil, return
label rather than the key derived from the label. START-DELIM
and END-DELIM are strings that override default button
delimiters. With POS-FLAG non-nil, return the list of label-or-key,
but-start-position, but-end-position. Positions include
delimiters. With TWO-LINES-FLAG non-nil, constrain label search
to two lines."
(when (equal buffer-file-name (gbut:file))
(hbut:label-p as-label start-delim end-delim pos-flag two-lines-flag)))
(defun gbut:to (lbl-key)
"Find the global button with LBL-KEY (a label or label key).
Find it within the visible portion of the global button file.
Leave point inside the button label, if it has one.
Return the symbol for the button when found, else nil."
(when (file-readable-p (gbut:file))
(let ((obuf (current-buffer))
(opoint (point))
found)
(set-buffer (find-file-noselect (gbut:file)))
(setq found (hbut:to lbl-key))
(if found
(hpath:display-buffer (current-buffer) 'this-window)
(set-buffer obuf)
(goto-char opoint))
found)))
;;; ------------------------------------------------------------------------
(defun gbut:key-list ()
"Return list of global button label keys."
(nconc (gbut:ebut-key-list) (gbut:ibut-key-list)))
(defun gbut:ebut-key-list ()
"Return a list of explicit button label keys from the global button file."
(save-excursion
(when (hbdata:to-entry-buf (gbut:file))
(let (gbuts)
(save-restriction
(narrow-to-region (point) (if (search-forward "\f" 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:ibut-key-list ()
"Return a list of implicit button label keys from the global button file."
(when (file-readable-p (gbut:file))
(save-excursion
(with-current-buffer (find-file-noselect (gbut:file))
(save-restriction
(widen)
(ibut:label-map #'(lambda (label _start _end) (ibut:label-to-key label))))))))
;;; ========================================================================
;;; hattr class
;;; ========================================================================
(defun hattr:attributes (obj-symbol)
"Return a list of OBJ-SYMBOL's attributes as symbols."
(when (symbolp obj-symbol)
(let* ((attr-val-list (symbol-plist obj-symbol))
(i -1))
(delq nil (mapcar (lambda (elt)
(setq i (1+ i))
(and (zerop (% i 2)) elt))
attr-val-list)))))
(defun hattr:clear (hbut)
"Remove 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)
"Copy attributes FROM-HBUT TO-HBUT, overwriting TO-HBUT attribute values.
Return TO-HBUT."
(mapc (lambda (hbut)
(or (and hbut (symbolp hbut))
(error "(hattr:clear): Argument not a Hyperbole button: %s" hbut)))
(list from-hbut to-hbut))
(hattr:clear to-hbut)
(setplist to-hbut (copy-sequence (symbol-plist from-hbut)))
to-hbut)
(defun hattr:get (obj-symbol attr-symbol)
"Return value of OBJ-SYMBOL's attribute ATTR-SYMBOL."
(get obj-symbol attr-symbol))
(defun hattr:list (obj-symbol)
"Return 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)
"Return t if ATTR-SYMBOL is in OBJ-SYMBOL's attribute list, else nil."
(and (symbolp obj-symbol) (symbolp attr-symbol)
(let* ((attr-val-list (symbol-plist obj-symbol))
(attr-list (let ((i -1))
(delq nil (mapcar
(lambda (elt)
(setq i (1+ i))
(and (zerop (% i 2)) elt))
attr-val-list)))))
(when (memq attr-symbol attr-list) t))))
(defun hattr:report (attrib-list)
"Pretty print to `standard-output' attribute-value pairs from ATTRIB-LIST.
Ignore nil valued attributes. Return t unless no attributes are printed."
(let ((has-attr) attr val len)
(unless (or (null attrib-list) (not (listp attrib-list))
;; odd number of elements?
(= (% (length attrib-list) 2) 1))
(while (setq attr (car attrib-list))
(setq val (car (cdr attrib-list))
attrib-list (cdr (cdr attrib-list)))
(when val
(setq has-attr t
attr (symbol-name attr)
len (number-to-string (max (- 16 (length attr)) 1)))
(princ (format (concat " %s:%" len "s%S\n") attr " "
(let (str)
(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))
(make-symbol (substring str (match-end 0))))
(t val)))))))
has-attr)))
(defun hattr:save ()
"Save button attribute file for current directory, if modified.
Suitable for use as part of `write-file-functions'."
(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-functions' from looping.
(and (buffer-modified-p buf)
(with-current-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-functions.
nil)
(defun hattr:set (obj-symbol attr-symbol attr-value)
"Set OBJ-SYMBOL's attribute ATTR-SYMBOL to ATTR-VALUE and return ATR-VALUE."
(put obj-symbol attr-symbol attr-value))
(defalias 'hattr:summarize #'hattr:report)
(defvar hattr:filename
(if hyperb:microsoft-os-p "_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
;;; ========================================================================
(defconst hbut:max-len 200
"Maximum length of a Hyperbole button label.
If 0, there is no limit and searches for button end delimiters can go
as far as the end of the buffer.
Use the function, (hbut:max-len), to read the proper value.")
(defsubst hbut:max-len ()
"Return the value of `hbut:max-len' if non-zero else (point-max)."
(if (zerop hbut:max-len) (point-max) hbut:max-len))
(defun hbut:act (&optional hbut)
"Perform action for optional explicit or implicit Hyperbole button symbol HBUT.
Default is `hbut:current'."
(interactive (list (hbut:get (hargs:read-match "Activate labeled Hyperbole button: "
(nconc (ebut:alist) (ibut:alist))
nil t nil 'hbut))))
(unless hbut
(setq hbut 'hbut:current))
(cond ((hbut:is-p hbut)
(let ((orig-point (point-marker))
(action (hattr:get hbut 'action))
text-point)
(when (ibut:is-p hbut)
;; Determine whether point is already within hbut; if
;; not, it is moved there.
;;
;; The next line returns the lbl-key of the current
;; button only if point is within the optional name,
;; otherwise, nil.
(let* ((lbl-key-start-end (ibut:label-p nil nil nil t t))
(lbl-key (nth 0 lbl-key-start-end))
(delim-text-start (or (nth 1 lbl-key-start-end)
(hattr:get hbut 'lbl-start)))
(delim-text-end (or (nth 2 lbl-key-start-end)
(hattr:get hbut 'lbl-end))))
(if (and lbl-key
(or (equal (hattr:get hbut 'loc) (current-buffer))
(equal (hattr:get hbut 'loc) buffer-file-name))
(equal lbl-key (hattr:get hbut 'lbl-key)))
(unless (and delim-text-start delim-text-end
(< delim-text-start (point))
(>= delim-text-end (point)))
(goto-char delim-text-start)
(skip-chars-forward "^-_a-zA-Z0-9"))
;; Here handle when there is no name preceding the
;; implicit button.
(unless (and (or (equal (hattr:get hbut 'loc) (current-buffer))
(equal (hattr:get hbut 'loc) buffer-file-name))
delim-text-start delim-text-end
(< delim-text-start (point))
(>= delim-text-end (point)))
(ibut:to-text (hattr:get hbut 'lbl-key))))))
(setq text-point (point-marker))
(prog1 (if action
(apply hrule:action action)
(apply hrule:action (hattr:get hbut 'actype) (hattr:get hbut 'args)))
;; Restore point as it was prior to `ibut:to-text' call
;; if the action switched buffers or did not move point
;; within the current buffer.
(when (or (equal text-point (point-marker))
(not (eq (current-buffer) (marker-buffer orig-point))))
(with-current-buffer (marker-buffer orig-point)
(let ((owind (get-buffer-window nil t)))
(if owind
(set-window-point owind orig-point)
(goto-char orig-point)))))
(set-marker orig-point nil)
(set-marker text-point nil))))
((and hbut (symbolp hbut))
(hypb:error "(hbut:act): Symbol, %s, has invalid Hyperbole button attributes:\n %S" hbut (hattr:list hbut)))
(t
(hypb:error "(hbut:act): Invalid Hyperbole button: %s" hbut))))
(defun hbut:action (hbut)
"Return appropriate action name/function for Hyperbole button symbol HBUT."
(let ((categ (hattr:get hbut 'categ)) (atype) (action))
(if (eq categ 'explicit)
(progn (setq action (car (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.
(when (functionp atype) atype))))
(defun hbut:at-p ()
"Return symbol for explicit or implicit Hyperbole button at point or nil.
Then use (hbut:act) to activate the button."
(interactive)
(if (called-interactively-p 'interactive)
(let ((hbut (or (ebut:at-p) (ibut:at-p))))
(when hbut
(if (fboundp #'hkey-help)
(hkey-help)
(message "%S" (symbol-plist hbut)))
hbut))
(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.
Ignore email-related buffers."
(save-excursion
(if (and comment-start (not (hmail:mode-is-p))
(not (memq major-mode '(mail-mode message-mode))))
(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 (not (eq (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)