forked from ChasManRors/ecb
/
tree-buffer.el
1485 lines (1332 loc) · 63.6 KB
/
tree-buffer.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
;;; tree-buffer.el --- functions for tree buffers
;; Copyright (C) 2000, 2001 Jesper Nordenberg
;; Author: Jesper Nordenberg <mayhem@home.se>
;; Maintainer: Klaus Berndl <klaus.berndl@sdm.de>
;; Keywords: java, class, browser
;; This program 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.
;; This program 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., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
;;; Commentary:
;;
;; Functions for tree buffers.
;;
;; This file is part of the ECB package which can be found at:
;; http://ecb.sourceforge.net
;;; History
;;
;; For the ChangeLog of this file see the CVS-repository. For a complete
;; history of the ECB-package see the file NEWS.
;; $Id$
;;; Code:
(eval-when-compile
(require 'silentcomp))
(eval-when-compile
;; to avoid compiler grips
(require 'cl))
(defconst tree-buffer-running-xemacs
(string-match "XEmacs\\|Lucid" emacs-version))
(defconst tree-buffer-running-emacs-21
(and (not tree-buffer-running-xemacs)
(> emacs-major-version 20)))
;; XEmacs stuff
(silentcomp-defun button-release-event-p)
(silentcomp-defun button-press-event-p)
(silentcomp-defun event-key)
(silentcomp-defun display-message)
(silentcomp-defun clear-message)
;; Emacs
(silentcomp-defvar message-log-max)
(silentcomp-defvar message-truncate-lines)
(silentcomp-defvar track-mouse)
(silentcomp-defvar special-event-map)
(silentcomp-defun posn-window)
(silentcomp-defun event-start)
(silentcomp-defun posn-point)
(silentcomp-defun event-basic-type)
(if tree-buffer-running-xemacs
;; XEmacs
(progn
(defalias 'tree-buffer-line-beginning-pos 'point-at-bol)
(defalias 'tree-buffer-line-end-pos 'point-at-eol)
(defalias 'tree-buffer-window-display-height 'window-displayed-height)
(defun tree-buffer-event-to-key (event)
(cond ((button-release-event-p event)
'mouse-release)
((button-press-event-p event)
'mouse-press)
(t
;; the ignore-errors is a little hack because i don't no all
;; events of XEmacs so sometimes event-key produces a
;; wrong-type-argument error.
(ignore-errors (event-key event)))))
(defalias 'tree-buffer-event-window 'event-window)
(defalias 'tree-buffer-event-point 'event-point)
(require 'overlay)
)
;; GNU Emacs
;; needed to handle correct mouse avoidance
(require 'avoid)
(defalias 'tree-buffer-line-beginning-pos 'line-beginning-position)
(defalias 'tree-buffer-line-end-pos 'line-end-position)
(defun tree-buffer-window-display-height (&optional window)
(1- (window-height window)))
(defun tree-buffer-event-window (event)
(posn-window (event-start event)))
(defun tree-buffer-event-point (event)
(posn-point (event-start event)))
(defun tree-buffer-event-to-key (event)
(let ((type (event-basic-type event)))
(cond ((or (equal type 'mouse-1)
(equal type 'mouse-2)
(equal type 'mouse-3))
'mouse-release)
((or (equal type 'down-mouse-1)
(equal type 'down-mouse-2)
(equal type 'down-mouse-3))
'mouse-press)
(t
(event-basic-type event))))))
;; tree-buffer local variables
(defvar tree-buffer-root nil)
(defvar tree-buffer-nodes nil
"Contains all the visible nodes in the buffer in top-to-bottom order. Each
item in this list is a cons pair of the displayed node name and the node. Note
that the displayed node name can be truncated and therefore different from the
node name.")
(defvar tree-buffer-frame nil)
(defvar tree-buffer-key-map nil)
(defvar tree-buffer-indent nil)
(defvar tree-buffer-highlighted-node-data nil)
(defvar tree-buffer-menus nil)
(defvar tree-buffer-menu-titles nil)
(defvar tree-buffer-type-facer nil)
(defvar tree-buffer-expand-symbol-before nil)
(defvar tree-buffer-is-click-valid-fn nil)
(defvar tree-node-selected-fn nil)
(defvar tree-node-expanded-fn nil)
(defvar tree-node-mouse-over-fn nil)
(defvar tree-node-data-equal-fn nil)
(defvar tree-buffer-highlight-overlay nil)
(defvar tree-buffer-general-face nil)
(defvar tree-buffer-general-overlay nil)
(defvar tree-buffer-incr-searchpattern nil)
(defvar tree-buffer-last-incr-searchpattern nil)
(defvar tree-buffer-incr-search nil)
(defvar tree-buffer-hor-scroll-step nil)
;; tree-buffer-local data-storage with get- and set-function
(defvar tree-buffer-data-store nil)
(defun tree-buffer-set-data-store (data)
(setq tree-buffer-data-store data))
(defun tree-buffer-get-data-store ()
tree-buffer-data-store)
;; tree-buffer global variables
(defvar tree-buffers nil)
(defvar tree-buffer-saved-mouse-movement-fn nil)
(defvar tree-buffer-saved-track-mouse nil)
(defvar tree-buffer-track-mouse-timer nil)
(defvar tree-buffer-track-mouse-idle-delay 0.2
"After this idle-time of Emacs `tree-buffer-do-mouse-tracking' is called if
mouse-tracking is activated by `tree-buffer-activate-mouse-tracking'")
(defvar tree-buffer-old-mouse-avoidance-mode
(if (null mouse-avoidance-mode) 'none mouse-avoidance-mode))
(defvar tree-buffer-syntax-table nil
"Syntax-table used in a tree-buffer.")
(if tree-buffer-syntax-table
nil
(setq tree-buffer-syntax-table (make-syntax-table))
;; turn off paren matching around here.
(modify-syntax-entry ?\' " " tree-buffer-syntax-table)
(modify-syntax-entry ?\" " " tree-buffer-syntax-table)
(modify-syntax-entry ?\( " " tree-buffer-syntax-table)
(modify-syntax-entry ?\) " " tree-buffer-syntax-table)
(modify-syntax-entry ?\{ " " tree-buffer-syntax-table)
(modify-syntax-entry ?\} " " tree-buffer-syntax-table)
(modify-syntax-entry ?\[ " " tree-buffer-syntax-table)
(modify-syntax-entry ?\] " " tree-buffer-syntax-table))
(defun tree-buffer-nolog-message (&rest args)
"Works exactly like `message' but does not log the message"
(let ((msg (cond ((or (null args)
(null (car args)))
nil)
((null (cdr args))
(car args))
(t
(apply 'format args)))))
;; Now message is either nil or the formated string.
(if tree-buffer-running-xemacs
;; XEmacs way of preventing log messages.
(if msg
(display-message 'no-log msg)
(clear-message 'no-log))
;; Emacs way of preventing log messages.
(let ((message-log-max nil)
(message-truncate-lines nil))
(if msg
(message "%s" msg)
(message nil))))
msg))
(defun tree-buffer-get-node-name-start-column (node)
"Returns the buffer column where the name of the node starts."
(+ (tree-buffer-get-node-indent node)
(if (and tree-buffer-expand-symbol-before
(tree-node-is-expandable node))
4 0)))
(defun tree-buffer-get-node-name-start-point (name node)
"Returns the buffer point where the name of the node starts."
(let ((linenr (tree-buffer-find-node node)))
(when linenr
(goto-line linenr)
(beginning-of-line)
(+ (point) (tree-buffer-get-node-name-start-column node)))))
(defun tree-buffer-get-node-name-end-point (name node)
"Returns the buffer point where the name of the node ends."
(+ (tree-buffer-get-node-name-start-point name node)
(length name)))
(defun tree-buffer-at-expand-symbol (name node p)
(if tree-buffer-expand-symbol-before
(< p (1- (tree-buffer-get-node-name-start-point name node)))
(> p (tree-buffer-get-node-name-end-point name node))))
(defun tree-buffer-select (mouse-button shift-pressed control-pressed)
"If the callback-function in `tree-buffer-is-click-valid-fn' returns nil
then nothing is done. Otherwise: If the node is expandable and the node is not
expanded then the callback-function in `tree-node-expanded-fn' is called with
the node, the clicked MOUSE-BUTTON \(1 for mouse-1, 2 for mouse-2, 0 for no
mouse-button but a key like RET or TAB), SHIFT-PRESSED and CONTROL-PRESSED
informations and the name of the tree-buffer as arguments. If the node is not
expandable then the callback-function in `tree-node-selected-fn' is called
with the same arguments as `tree-node-expanded-fn'."
(unless (not (equal (selected-frame) tree-buffer-frame))
(when (and tree-buffer-is-click-valid-fn
(funcall tree-buffer-is-click-valid-fn mouse-button
shift-pressed control-pressed (buffer-name)))
(let* ((p (point))
(name-node (tree-buffer-get-name-node-at-point))
(name (car name-node))
(node (cdr name-node)))
(when node
(if (and (tree-node-is-expandable node)
(tree-buffer-at-expand-symbol name node p)
;; if the expand-symbol is displayed before and mouse-button
;; = 0, means RET is pressed, we do not toggle-expand but work
;; as if point would not be at expand-symbol. This is for
;; conveniance.
(not (and (= mouse-button 0)
tree-buffer-expand-symbol-before)))
(progn
(when (and (not (tree-node-is-expanded node))
tree-node-expanded-fn)
(funcall tree-node-expanded-fn node mouse-button
shift-pressed control-pressed (buffer-name)))
(when (tree-node-is-expandable node)
(tree-node-toggle-expanded node))
;; Update the tree-buffer with optimized display of NODE
(tree-buffer-update node))
(setq tree-buffer-incr-searchpattern "")
(when tree-node-selected-fn
(funcall tree-node-selected-fn node mouse-button
shift-pressed control-pressed (buffer-name))))))
)))
(defun tree-buffer-get-node-at-point (&optional p)
(save-excursion
(if p (goto-char p))
(let ((linenr (+ (count-lines 1 (point)) (if (= (current-column) 0) 0 -1))))
(cdr (nth linenr tree-buffer-nodes)))))
(defun tree-buffer-get-name-node-at-point (&optional p)
(save-excursion
(if p (goto-char p))
(let ((linenr (+ (count-lines 1 (point)) (if (= (current-column) 0) 0 -1))))
(nth linenr tree-buffer-nodes))))
(defun tree-buffer-get-node-indent (node)
(* tree-buffer-indent (1- (tree-node-get-depth node))))
(defun tree-buffer-node-data-equal-p (node-data-1 node-data-2)
(and node-data-1 node-data-2
;; if this comparison-function runs into an error we handle this as
;; non-equality!
(ignore-errors
(funcall tree-node-data-equal-fn node-data-1 node-data-2))))
(defun tree-buffer-find-node-data (node-data)
(catch 'exit
(dolist (node tree-buffer-nodes)
(when (tree-buffer-node-data-equal-p (tree-node-get-data (cdr node))
node-data)
(throw 'exit (cdr node))))))
(defun tree-buffer-find-name-node-data (node-data &optional start-node)
(catch 'exit
(let ((node-list (if (or (not start-node)
(eq start-node (tree-buffer-get-root)))
tree-buffer-nodes
;; because tree-buffer-nodes is a list of conses with
;; car is the node-name and cdr is the node itself we
;; must first create such a cons for START-NODE!
(or (member (cons (tree-node-get-name start-node)
start-node)
tree-buffer-nodes)
tree-buffer-nodes))))
(dolist (node node-list)
(when (tree-buffer-node-data-equal-p (tree-node-get-data (cdr node))
node-data)
(throw 'exit node))))))
(defun tree-buffer-find-node (node)
(catch 'exit
(let ((linenr 1))
(dolist (node2 tree-buffer-nodes)
(when (eq node (cdr node2))
(throw 'exit linenr))
(setq linenr (1+ linenr))))))
(defun tree-buffer-get-node-facer (node)
(let ((facer (cdr (assoc (tree-node-get-type node) tree-buffer-type-facer))))
(if facer
facer
nil)))
(defun tree-buffer-pos-hor-visible-p (pos window)
"Returns non nil if POS is horizontal visible otherwise nil."
(save-excursion
(goto-char pos)
(and (>= (- (current-column) (window-hscroll window)) 0)
(< (- (current-column) (window-hscroll window))
(window-width window)))))
(defun tree-buffer-scroll-hor (amount)
(ignore-errors
(let ((current-prefix-arg amount))
(call-interactively 'scroll-left))))
(defun tree-buffer-recenter (node window)
"If NODE is not visible then first recenter the window WINDOW so NODE is
best visible, means NODE is displayed in the middle of the window if possible.
If NODE is expanded then recenter the WINDOW so as much as possible subnodes
of NODE will be visible. If NODE is not expandable then WINDOW is always
displayed without empty-lines at the end, means WINDOW is always best filled."
(let* ((node-point (save-excursion
(goto-line (tree-buffer-find-node node))
(tree-buffer-line-beginning-pos)))
(point-lines-before (count-lines (point-min) node-point))
(point-lines-after (1- (count-lines node-point (point-max)))))
(if (not tree-buffer-running-xemacs)
(ignore-errors (tree-buffer-scroll-hor -1000)))
;; first make point best visible, means display node in the middle of the
;; window if possible (if there are enough lines before/after the node).
(when (not (pos-visible-in-window-p node-point window))
(if (< node-point (window-start window))
(set-window-start
window
(save-excursion
(goto-char node-point)
(forward-line
(* -1 (min point-lines-before
(/ (tree-buffer-window-display-height window) 2))))
(tree-buffer-line-beginning-pos)))
(set-window-start window
(save-excursion
(goto-char (window-start window))
(forward-line
(- (+ 1
(count-lines (window-start window) node-point)
(min point-lines-after
(/ (tree-buffer-window-display-height window) 2)))
(tree-buffer-window-display-height window)))
(tree-buffer-line-beginning-pos)))))
;; now optimize the window display for displaying as much possible
;; subnodes of node.
(if (tree-node-is-expanded node)
(let ((exp-node-children-count (tree-node-count-subnodes-to-display node))
(point-window-line (count-lines (window-start window) node-point)))
;; if the current node is not already displayed in the first line of
;; the window (= condition 1) and if not all of it´s children are
;; visible in the window then we can do some optimization.
(if (and (save-excursion
(goto-char node-point)
(forward-line -1)
(pos-visible-in-window-p (point) window))
(not (save-excursion
(goto-char node-point)
(forward-line exp-node-children-count)
(pos-visible-in-window-p (point) window))))
;; optimize the display of NODE and it´s children so as much as
;; possible are visible.
(set-window-start window
(save-excursion
(goto-char (window-start window))
(forward-line
(min point-window-line
(- (+ 1 point-window-line
exp-node-children-count)
(tree-buffer-window-display-height window))))
(tree-buffer-line-beginning-pos)))))
;; maybe there are empty lines in the window after the last non-empty
;; line. If they are we scroll until the whole window is filled with
;; non-empty lines.
(if (not (tree-node-is-expandable node))
(let ((w-height (tree-buffer-window-display-height window))
(full-lines-in-window (count-lines (window-start window)
(window-end window t))))
(if (< full-lines-in-window
w-height)
(set-window-start window
(save-excursion
(goto-char (window-start window))
(forward-line (- full-lines-in-window w-height))
(tree-buffer-line-beginning-pos)))))))
))
;; Klaus: Now we use overlays to highlight current node in a tree-buffer. This
;; makes it easier to do some facing with the nodes itself and above all this
;; the faces of the node are always visible even if the node is highlighted
;; (useful e.g. if you show the sources in the ECB directory buffer, and if
;; you do some syntax highlighting in the method-buffer).
(defun tree-buffer-remove-highlight ()
(when tree-buffer-highlighted-node-data
(let ((node (tree-buffer-find-node-data tree-buffer-highlighted-node-data)))
(when node
(delete-overlay tree-buffer-highlight-overlay))))
(setq tree-buffer-highlighted-node-data nil))
(defun tree-buffer-highlight-node-data (node-data &optional start-node
dont-make-visible)
"Highlights in current tree-buffer the node which has as data NODE-DATA. If
START-NODE is nil or equal to the root-node then all nodes of current
tree-buffer are searched from beginning until the node with data NODE-DATA has
been found otherwise the search starts with START-NODE. If DONT-MAKE-VISIBLE
is true then no tree-buffer recentering has been done to make this node
visible.
If either NODE-DATA is nil or if the node belonging to NODE-DATA can not be
found because it is invisible \(probably because its parent-node is not
expanded) then no highlighting takes place but the existing highlighting is
removed and nil is returned. Otherwise the node is highlighted and not nil is
returned."
(if node-data
(let* ((name-node (tree-buffer-find-name-node-data node-data start-node))
(name (car name-node))
(node (cdr name-node))
(w (get-buffer-window (current-buffer))))
(if (null node)
(progn
;; node can not be found because maybe the node is a subnode and
;; it´s parent is not expanded --> then there is no node for
;; NODE-DATA; therefore we must remove the highlighting
(tree-buffer-remove-highlight)
nil)
(setq tree-buffer-highlighted-node-data node-data)
(save-excursion
(move-overlay tree-buffer-highlight-overlay
(tree-buffer-get-node-name-start-point name node)
(tree-buffer-get-node-name-end-point name node)))
(when (not dont-make-visible)
;; make node visible if not and optimize the windows display for
;; the node.
(tree-buffer-recenter node w))
;; we have highlighted the node wo we return not nil.
t))
(tree-buffer-remove-highlight)
nil))
(defun tree-buffer-help-echo-fn (win obj pos)
"This function is the value of the `help-echo' property of each
tree-node. This is only used with GNU Emacs 21!"
(let* ((window win)
(position pos)
(buffer (window-buffer window))
node)
(save-excursion
(set-buffer buffer)
(setq node (tree-buffer-get-node-at-point position))
(and tree-node-mouse-over-fn
node
(funcall tree-node-mouse-over-fn node window 'no-print)))))
(defun tree-buffer-insert-text (text &optional facer help-echo)
"Insert TEXT at point and faces it with FACER. FACER can be a face then the
text gets this face or it can be a function-symbol which is called to face the
inserted TEXT. Such a function gets two arguments: Point where TEXT has been
inserted and the TEXT itself"
(let ((p (point)))
(insert text)
(put-text-property p (+ p (length text)) 'mouse-face 'highlight)
(if (and help-echo (not tree-buffer-running-xemacs))
(put-text-property p (+ p (length text)) 'help-echo
'tree-buffer-help-echo-fn))
(if facer
(if (functionp facer)
(funcall facer p text)
(put-text-property p (+ p (length text)) 'face facer)))))
(defun tree-buffer-add-node (node depth)
(let* ((ww (window-width))
(name (tree-node-get-name node))
(width (+ (* depth tree-buffer-indent)
(length name)
(if (tree-node-is-expandable node) 4 0))))
;; Truncate name if necessary
(when (>= width ww)
(if (eq 'beginning (tree-node-get-shorten-name node))
(setq name (concat "..." (substring name (+ (if tree-buffer-running-xemacs 5 4)
(- width ww)))))
(if (and (not tree-buffer-expand-symbol-before)
(tree-node-is-expandable node)
(eq 'end (tree-node-get-shorten-name node)))
(setq name (concat (substring name 0 (- (+ (if tree-buffer-running-xemacs 5 4)
(- width ww))))
"...")))))
(insert (make-string (* depth tree-buffer-indent) ? ))
(when (and tree-buffer-expand-symbol-before
(tree-node-is-expandable node))
(tree-buffer-insert-text (if (tree-node-is-expanded node) "[-]" "[+]"))
(insert " "))
(tree-buffer-insert-text name (tree-buffer-get-node-facer node) t)
(when (and (not tree-buffer-expand-symbol-before)
(tree-node-is-expandable node))
(insert " ")
(tree-buffer-insert-text (if (tree-node-is-expanded node) "[-]" "[+]")))
(insert "\n")
(setq tree-buffer-nodes (append tree-buffer-nodes (list (cons name node))))
(if (tree-node-is-expanded node)
(dolist (node (tree-node-get-children node))
(tree-buffer-add-node node (1+ depth))))))
(defun tree-node-count-subnodes-to-display (node)
"Returns the number of ALL subnodes of NODE which will currently be displayed
if NODE is expanded, means the number of all the children of NODE \(if NODE is
expanded) plus recursive the number of the children of each expanded child.
Example:
\[-] NODE
\[+] child 1
\[-] child 2
\[+] child 2.1
\[-] child 2.2
\[+] child 2.2.1
\[+] child 2.2.2
\[+] child 2.3
\[-] child 3
\[+] child 3.1
\[+] child 4
The result for NODE here is 10"
(let ((result 0))
(when (and (tree-node-is-expandable node)
(tree-node-is-expanded node))
(setq result (+ result (length (tree-node-get-children node))))
(dolist (child (tree-node-get-children node))
(setq result (+ result (tree-node-count-subnodes-to-display child)))))
result))
(defun tree-buffer-build-tree-buffer-nodes ()
"Rebuild the variable `tree-buffer-nodes' from the current children of
`tree-buffer-root'."
(setq tree-buffer-nodes nil)
(dolist (node (tree-node-get-children tree-buffer-root))
(tree-buffer-add-node node 0)))
(defun tree-buffer-update (&optional node)
"Updates the current tree-buffer. The buffer will be completely rebuild with
it´s current nodes. window-start and point will be preserved.
If NODE is not nil and a valid and expanded node with at least one child then
the display of this node is optimized so the node itself and as much as
possible of it´s children \(and also recursive the children of a child if it´s
aleady expanded, see `tree-node-count-subnodes-to-display') are visible in
current tree-buffer."
(let* ((w (get-buffer-window (current-buffer)))
(ws (window-start w))
(p (point))
(buffer-read-only nil)
(next-line-add-newlines nil))
(erase-buffer)
(tree-buffer-build-tree-buffer-nodes)
(when tree-buffer-general-face
(move-overlay tree-buffer-general-overlay (point-min) (point-max)))
(tree-buffer-highlight-node-data tree-buffer-highlighted-node-data)
(goto-char p)
(set-window-start w ws)
;; let´s optimize the display of the expanded node NODE and it´s children.
(when node
(tree-buffer-recenter node w))))
(defun tree-buffer-scroll (point window-start)
"Scrolls current tree-buffer. The window will start at WINDOW-START and
point will stay on POINT."
(goto-char point)
(set-window-start (get-buffer-window (current-buffer)) window-start))
(defun tree-buffer-expand-nodes (level
&optional expand-pred-fn collapse-pred-fn)
"Set the expand level of the nodes in current tree-buffer.
LEVEL specifies precisely which level of nodes should be expanded. LEVEL
means the indentation-level of the nodes.
A LEVEL value X means that all nodes with an indentation-level <= X are
expanded and all other are collapsed. A negative LEVEL value means all visible
nodes are collapsed.
Nodes which are not indented have indentation-level 0!
This function expands all nodes with level <= LEVEL, so the subnodes of these
nodes get visible and collapses all their \(recursive) subnodes with
indentation-level > LEVEL.
If a node has to be expanded then first the `tree-node-expanded-fn' of current
tree-buffer \(see `tree-buffer-create') is called with the argument-values
\[node 0 nil nil \(buffer-name)\].
This function gets two optional function-arguments which are called to test if
a node should be excluded from expanding or collapsing; both functions are
called with two arguments, where the first one is the expandable/collapsable
node and the second one is the current level of indentation of this node:
EXPAND-PRED-FN is called if a node has to be expanded and must return nil if
this node should not be expanded even if its indentation level is <= LEVEL and
COLLAPSE-PRED-FN is called analogous for a node which has to be collapsed and
must return nil if the node should not be collapsed even if its indentation
level is > then LEVEL.
Examples:
- LEVEL = 0 expands only nodes which have no indentation itself.
- LEVEL = 2 expands nodess which are either not indented or indented once or
twice."
(dolist (node (tree-node-get-children tree-buffer-root))
(tree-buffer-expand-node node 0 level
expand-pred-fn collapse-pred-fn))
(tree-buffer-update))
(defun tree-buffer-expand-node (node current-level level
expand-pred-fn collapse-pred-fn)
"Expand NODE if CURRENT-LEVEL \(the indentation-level of NODE) <= LEVEL or
collapses NODE if CURRENT-LEVEL > LEVEL. Do this recursive for subnodes of
NODE with incremented CURRENT-LEVEL. For EXPAND-PRED-FN and COLLAPSE-PRED-FN
see `tree-buffer-expand-nodes'."
(when (tree-node-is-expandable node)
(when (and tree-node-expanded-fn
(not (tree-node-is-expanded node)))
(funcall tree-node-expanded-fn node 0 nil nil (buffer-name)))
(when (or (and (not (tree-node-is-expanded node))
(or (not (functionp expand-pred-fn))
(funcall expand-pred-fn node current-level))
(<= current-level level))
(and (tree-node-is-expanded node)
(or (not (functionp collapse-pred-fn))
(funcall collapse-pred-fn node current-level))
(> current-level level)))
(tree-node-toggle-expanded node))
(dolist (child (tree-node-get-children node))
(tree-buffer-expand-node child (1+ current-level) level
expand-pred-fn collapse-pred-fn))))
(defun tree-buffer-set-root (root)
(setq tree-buffer-root root)
(tree-node-set-expanded tree-buffer-root t))
(defun tree-buffer-get-root ()
tree-buffer-root)
(defun tree-buffer-show-menu (event)
(interactive "e")
(mouse-set-point event)
(unless (not (equal (selected-frame) tree-buffer-frame))
(when tree-buffer-menus
(let ((node (tree-buffer-get-node-at-point)))
(when node
(let* ((menu (cdr (assoc (tree-node-get-type node) tree-buffer-menus)))
(menu-title-creator
(cdr (assoc (tree-node-get-type node) tree-buffer-menu-titles)))
(menu-title (cond ((stringp menu-title-creator)
menu-title-creator)
((functionp menu-title-creator)
(funcall menu-title-creator node))
(t "ECB-tree-buffer-menu"))))
(when menu
(if tree-buffer-running-xemacs
(popup-menu (cons menu-title menu))
(let ((fn (x-popup-menu
event (cons 'keymap (cons menu-title menu)))))
(when fn
(funcall (car fn) node)))))))))))
(defconst tree-buffer-incr-searchpattern-basic-prefix
"^[ \t]*\\(\\[[+-]\\] \\)?"
"Prefix-pattern which ignores all not interesting basic stuff of a displayed
token at incr. search. The following contents of a displayed token are ignored
by this pattern:
- beginning spaces
- The expand/collapse-button: \[+] resp. \[-]")
(defconst tree-buffer-incr-searchpattern-node-prefix "\\([^ ]+ \\|[-+#]\\)?"
"Prefix-pattern which ignores all not interesting stuff of a node-name at
incr. search. The following contents of a node-name are ignored by this
pattern:
- types of a variable or returntypes of a method
- const specifier of variables
- protection sign of a variable/method: +, - or #")
;; idea is stolen from ido.el, written by Kim F. Storm <stormware@get2net.dk>
(defun tree-buffer-find-common-substring (lis subs &optional only-prefix)
"Return common substring beginning with SUBS in each element of LIS. If
ONLY-PREFIX is not nil then only common prefix is returned."
(let ((change-word-sub (concat (if only-prefix
(concat "^" tree-buffer-incr-searchpattern-node-prefix)
"")
"\\(" (regexp-quote subs) "\\)"))
res alist)
(setq res (mapcar (function (lambda (word)
(if (string-match change-word-sub word)
(substring word
(match-beginning (if only-prefix 2 1)))
;; else no match
nil)))
lis))
(setq res (delq nil res)) ;; remove any nil elements (shouldn't happen)
(setq alist (mapcar (function (lambda (r)
(cons r 1)))
res)) ;; could use an OBARRAY
;; try-completion returns t if there is an exact match.
(let ((completion-ignore-case t))
(try-completion subs alist))))
(defun tree-node-get-all-visible-node-names (start-node)
(let ((result (if (not (equal tree-buffer-root start-node))
(list (tree-node-get-name start-node)))))
(when (or (equal tree-buffer-root start-node)
(tree-node-is-expanded start-node))
(dolist (child (tree-node-get-children start-node))
(setq result (append result (tree-node-get-all-visible-node-names child)))))
result))
(defun tree-buffer-incremental-node-search ()
"Incremental search for a node in current tree-buffer. Each displayable
key \(e.g. all keys normally bound to `self-insert-command') is appended to
the current seach-pattern. The tree-buffer tries to jump to the current
search-pattern. If no match is found then nothing is done. Some special keys:
- \[backspace] and \[delete]: Delete the last character from the search-pattern.
- \[home]: Delete the complete search-pattern
- \[end]: Expand either to a complete node if current search-pattern is
already unique or expands to the greates common prefix of the nodes.
If there are at least two nodes with the same greatest common-prefix
than every hit of \[end] jumps to the next node with this common
prefix.
The current search-pattern is shown in the echo area.
After selecting a node with RET the search-pattern is cleared out.
Do NOT call this function directly. It works only if called from the binding
mentioned above!"
(interactive)
(unless (not (equal (selected-frame) tree-buffer-frame))
(let ((last-comm (tree-buffer-event-to-key last-command-event)))
(cond ((or (equal last-comm 'delete)
(equal last-comm 'backspace))
;; reduce by one from the end
(setq tree-buffer-incr-searchpattern
(substring tree-buffer-incr-searchpattern
0
(max 0 (1- (length tree-buffer-incr-searchpattern))))))
;; delete the complete search-pattern
((equal last-comm 'home)
(setq tree-buffer-incr-searchpattern ""))
;; expand to the max. common prefix
((equal last-comm 'end)
(let* ((node-name-list (tree-node-get-all-visible-node-names
tree-buffer-root))
(common-prefix (tree-buffer-find-common-substring
node-name-list tree-buffer-incr-searchpattern
(if (equal tree-buffer-incr-search 'prefix) t))))
(if (stringp common-prefix)
(setq tree-buffer-incr-searchpattern common-prefix))))
((null last-comm)
nil) ;; do nothing
(t
;; add the last command to the end
(setq tree-buffer-incr-searchpattern
(concat tree-buffer-incr-searchpattern
(char-to-string last-comm)))))
(tree-buffer-nolog-message
"%s node search: [%s]%s"
(buffer-name (current-buffer))
tree-buffer-incr-searchpattern
(if (save-excursion
(if (or (not (equal last-comm 'end))
(not (string= tree-buffer-incr-searchpattern
tree-buffer-last-incr-searchpattern)))
(goto-char (point-min)))
(re-search-forward
(concat tree-buffer-incr-searchpattern-basic-prefix
tree-buffer-incr-searchpattern-node-prefix
(if (equal tree-buffer-incr-search 'substring)
"[^()\n]*"
"")
(regexp-quote tree-buffer-incr-searchpattern)) nil t))
;; we have found a matching ==> jump to it
(progn
(goto-char (match-end 0))
"")
" - no match"))
;; lets save the search-pattern so we can compare it with the next one.
(setq tree-buffer-last-incr-searchpattern tree-buffer-incr-searchpattern))))
(defun tree-buffer-create-menu (menu-items)
"Creates a popup menu from a list with menu items."
(when menu-items
(cons
(if tree-buffer-running-xemacs
(if (null (cdar menu-items))
(caar menu-items)
(let ((v (make-vector 3 t)))
(aset v 0 (caar menu-items))
(aset v 1 (list (cadar menu-items)
'(tree-buffer-get-node-at-point)))
v))
(cons (cadar menu-items)
(cons (caar menu-items) t)))
(tree-buffer-create-menu (cdr menu-items)))))
(defun tree-buffer-create-menus (menus)
"Creates a popup menus from an assoc list with menus."
(when menus
(cons (cons (caar menus)
(tree-buffer-create-menu (cdar menus)))
(tree-buffer-create-menus (cdr menus)))))
;; mouse tracking stuff
(defun tree-buffer-follow-mouse (event)
(interactive "e")
(let ((window (tree-buffer-event-window event))
(current-window (get-buffer-window (current-buffer))))
(if (and (or (not (window-minibuffer-p current-window))
(not (minibuffer-window-active-p current-window)))
(windowp window)
(member (window-buffer window) tree-buffers))
(tree-buffer-mouse-movement event)))
(if (not tree-buffer-running-xemacs)
(if tree-buffer-saved-mouse-movement-fn
(funcall tree-buffer-saved-mouse-movement-fn event)
;; Enable dragging
(setq unread-command-events
(nconc unread-command-events (list event))))))
(defun tree-buffer-mouse-movement (event)
(interactive "e")
(set-buffer (window-buffer (tree-buffer-event-window event)))
(let ((p (tree-buffer-event-point event)))
(when (integer-or-marker-p p)
;; (unless (not (equal (selected-frame) tree-buffer-frame))
(let ((node (tree-buffer-get-node-at-point p)))
(when (and tree-node-mouse-over-fn node)
(funcall tree-node-mouse-over-fn node
(get-buffer-window (current-buffer))))))))
(defvar tree-buffer-uncompleted-keyseq nil
"Not nil only if there is at evaluation-time of this variable an uncompleted
keysequence, e.g. the \"C-h\" of the keysequence \"C-h v\".")
(defun tree-buffer-do-mouse-tracking ()
"This function is called every time Emacs is idle for seconds defined in
`tree-buffer-track-mouse-idle-delay'. It enables mouse-tracking but only if
isearch is not active and if no uncompleted keysequence is open, means if this
function is called by the idle timer during a keysequence is inserted by the
user \(e.g. between the \"C-h\" and the \"v\" of the keysequence \"C-h v\"),
then mouse-tracking is always not enabled, because otherwise all very slighly
\(invisible) and unintended mouse-movements \(can occur for example only by
the convulsion cause of hitting keys onto the keyboard!) would break the
keysequence!"
(setq track-mouse nil)
(if (not (equal (tree-buffer-event-to-key last-input-event)
'mouse-movement))
(setq tree-buffer-uncompleted-keyseq
(not (equal last-input-event last-command-event))))
(unless (or tree-buffer-uncompleted-keyseq
;; maybe there are even more similar modes where we should not
;; activate mouse-tracking?!
isearch-mode)
(setq track-mouse t))
(add-hook 'post-command-hook 'tree-buffer-stop-mouse-tracking))
(defun tree-buffer-stop-mouse-tracking ()
(remove-hook 'post-command-hook 'tree-buffer-stop-mouse-tracking)
(setq track-mouse nil))
(defun tree-buffer-activate-mouse-tracking ()
"Activates GNU Emacs < version 21 mouse tracking for all tree-buffers.
With GNU Emacs 21 this functionality is done with the `help-echo'-property and
the function `tree-buffer-help-echo-fn'!"
(unless (or tree-buffer-running-xemacs tree-buffer-running-emacs-21)
(unless tree-buffer-track-mouse-timer
;; disable mouse avoidance because this can be very annoying with
;; key-sequences: If a key is pressed during mouse is over point then
;; the mouse goes away and therefore the key-sequence is broken because
;; the mouse move generates a mouse-movement event.
(setq tree-buffer-old-mouse-avoidance-mode
(if (null mouse-avoidance-mode) 'none mouse-avoidance-mode))
(mouse-avoidance-mode 'none)
(setq tree-buffer-saved-track-mouse track-mouse)
(setq tree-buffer-track-mouse-timer
(run-with-idle-timer tree-buffer-track-mouse-idle-delay
t 'tree-buffer-do-mouse-tracking)))))
(defun tree-buffer-deactivate-mouse-tracking ()
"Deactivates GNU Emacs < version 21 mouse tracking for all tree-buffers.
With GNU Emacs 21 this functionality is done with the `help-echo'-property and
the function `tree-buffer-help-echo-fn'!"
(unless (or tree-buffer-running-xemacs tree-buffer-running-emacs-21)
(unless (not tree-buffer-track-mouse-timer)
;; restore the old value
(mouse-avoidance-mode tree-buffer-old-mouse-avoidance-mode)
(setq track-mouse tree-buffer-saved-track-mouse)
(cancel-timer tree-buffer-track-mouse-timer)
(setq tree-buffer-track-mouse-timer nil))))
(defun tree-buffer-activate-follow-mouse ()
"Activates that in all tree-buffer-windows - regardless if the active window
or not - a mouse-over-node-function is called if mouse moves over a node. See
also the NODE-MOUSE-OVER-FN argument of `tree-buffer-create'.
This function does nothing for GNU Emacs 21; with this version this
functionality is done with the `help-echo'-property and the function
`tree-buffer-help-echo-fn'!"
(tree-buffer-activate-mouse-tracking)
(if tree-buffer-running-xemacs
(dolist (buf tree-buffers)
(save-excursion
(set-buffer buf)
(add-hook 'mode-motion-hook 'tree-buffer-follow-mouse)))
(unless tree-buffer-running-emacs-21
(let ((saved-fn (lookup-key special-event-map [mouse-movement])))
(unless (equal saved-fn 'tree-buffer-follow-mouse)
(setq tree-buffer-saved-mouse-movement-fn saved-fn)
(define-key special-event-map [mouse-movement] 'tree-buffer-follow-mouse))))))
(defun tree-buffer-deactivate-follow-mouse ()
(if tree-buffer-running-xemacs
(dolist (buf tree-buffers)
(save-excursion
(set-buffer buf)
(remove-hook 'mode-motion-hook 'tree-buffer-follow-mouse)))
(unless tree-buffer-running-emacs-21
(define-key special-event-map [mouse-movement] tree-buffer-saved-mouse-movement-fn))))
;; pressed keys
(defun tree-buffer-tab-pressed ()
(interactive)
(unless (not (equal (selected-frame) tree-buffer-frame))
(let ((node (tree-buffer-get-node-at-point)))
(when (tree-node-is-expandable node)
(when (and tree-node-expanded-fn
(not (tree-node-is-expanded node)))
(funcall tree-node-expanded-fn node 0 nil nil (buffer-name)))
(when (tree-node-is-expandable node)
(tree-node-toggle-expanded node))
;; Update the tree-buffer with optimized display of NODE
(tree-buffer-update node)))))
(defun tree-buffer-return-pressed (&optional shift-pressed control-pressed)
(unless (not (equal (selected-frame) tree-buffer-frame))
;; reinitialize the select pattern after selecting a node
(setq tree-buffer-incr-searchpattern "")
(tree-buffer-select 0 shift-pressed control-pressed)))
(defun tree-buffer-arrow-pressed ()
(interactive)
(unless (not (equal (selected-frame) tree-buffer-frame))
(let ((node (tree-buffer-get-node-at-point))
(arrow-key (tree-buffer-event-to-key last-command-event))
node-expanded-p)
(if (tree-node-is-expandable node)
(progn
(setq node-expanded-p (tree-node-is-expanded node))
(cond ((equal arrow-key 'right)
(if (not node-expanded-p)
(tree-buffer-tab-pressed)))
((equal arrow-key 'left)
(if node-expanded-p
(tree-buffer-tab-pressed)
;; jump to next higher node
(let* ((indent (tree-buffer-get-node-indent node))
(new-indent (max 0 (- indent tree-buffer-indent)))
(search-string
(concat "^"
(buffer-substring
(tree-buffer-line-beginning-pos)
(+ (tree-buffer-line-beginning-pos)
new-indent))
"[^ \t]")))
(re-search-backward search-string nil t))))))
(cond ((equal arrow-key 'left)