forked from ecb-home/ecb
-
-
Notifications
You must be signed in to change notification settings - Fork 0
/
tree-buffer.el
3525 lines (3209 loc) · 165 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 - 2005 Jesper Nordenberg,
;; Klaus Berndl,
;; Kevin A. Burton,
;; Free Software Foundation, Inc.
;; Author: Jesper Nordenberg <mayhem@home.se>
;; Klaus Berndl <klaus.berndl@sdm.de>
;; Maintainer: Klaus Berndl <klaus.berndl@sdm.de>
;; Keywords: browser, code, programming, tools, tree
;; Created: 2000
;; 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.
;; $Id$
;;; 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.
;;; Code:
(eval-when-compile
(require 'silentcomp))
(eval-when-compile
;; to avoid compiler grips
(require 'cl))
;; XEmacs stuff
(silentcomp-defun button-release-event-p)
(silentcomp-defun button-press-event-p)
(silentcomp-defun event-key)
(silentcomp-defun extent-end-position)
(silentcomp-defun event-glyph-extent)
(silentcomp-defun event-over-glyph-p)
(silentcomp-defun display-message)
(silentcomp-defun clear-message)
(silentcomp-defun locate-data-directory)
(silentcomp-defun make-image-specifier)
(silentcomp-defun make-glyph)
(silentcomp-defun popup-menu-and-execute-in-window)
(silentcomp-defun valid-image-instantiator-format-p)
(silentcomp-defvar modeline-map)
;; Emacs
(silentcomp-defvar header-line-format)
(silentcomp-defvar message-log-max)
(silentcomp-defvar message-truncate-lines)
(silentcomp-defun posn-window)
(silentcomp-defun window-fringes)
(silentcomp-defun frame-parameter)
(silentcomp-defun frame-char-width)
(silentcomp-defun event-start)
(silentcomp-defun posn-point)
(silentcomp-defun event-basic-type)
(silentcomp-defun display-images-p)
(silentcomp-defun image-type-available-p)
(silentcomp-defun count-screen-lines)
(silentcomp-defun tmm-prompt)
(silentcomp-defun font-lock-add-keywords)
(silentcomp-defvar cursor-in-non-selected-windows)
;; timer stuff for XEmacs
(silentcomp-defun delete-itimer)
(silentcomp-defun start-itimer)
(defconst tree-buffer-running-xemacs (featurep 'xemacs))
;; miscellaneous differences
(if tree-buffer-running-xemacs
;; XEmacs
(progn
(defun tree-buffer-facep (face)
(memq face (face-list)))
(defalias 'tree-buffer-line-beginning-pos 'point-at-bol)
(defalias 'tree-buffer-line-end-pos 'point-at-eol)
(defun tree-buffer-frame-char-width (&optional frame)
(/ (frame-pixel-width frame) (frame-width frame)))
(defalias 'tree-buffer-window-display-height 'window-displayed-height)
(defun tree-buffer-event-to-key (event)
(typecase event
(button-release-event 'mouse-release)
(button-press-event 'mouse-press)
(otherwise
;; the ignore-errors is a little hack because i don't know 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)
(defun tree-buffer-event-buffer (event)
(window-buffer (tree-buffer-event-window event)))
(defalias 'tree-buffer-event-point 'event-point)
;; stolen from dframe.el of the speedbar-library.
(defun tree-buffer-mouse-set-point (e)
"Set POINT based on event E. Handles clicking on images in XEmacs."
(mouse-set-point e)
(if (and (fboundp 'event-over-glyph-p) (event-over-glyph-p e))
;; We are in XEmacs, and clicked on a picture
(let ((ext (event-glyph-extent e)))
;; This position is back inside the extent where the
;; junk we pushed into the property list lives.
(if (extent-end-position ext)
(goto-char (1- (extent-end-position ext))))))))
;; GNU Emacs
(defalias 'tree-buffer-facep 'facep)
(defalias 'tree-buffer-line-beginning-pos 'line-beginning-position)
(defalias 'tree-buffer-line-end-pos 'line-end-position)
;; Klaus Berndl <klaus.berndl@sdm.de>: Is not really the same as
;; `window-displayed-height' of XEmacs, because if the buffer-end is before
;; the window-end (i.e. there are "empty" lines between window-end and last
;; char of the buffer) then these empty-lines are not counted. But in the
;; situations this function is used (only in tree-buffer-recenter) this
;; doesn't matter.
(defalias 'tree-buffer-frame-char-width 'frame-char-width)
(defalias 'tree-buffer-window-display-height 'window-text-height)
(defun tree-buffer-event-window (event)
(posn-window (event-start event)))
(defun tree-buffer-event-buffer (event)
(window-buffer (tree-buffer-event-window event)))
(defun tree-buffer-event-point (event)
(posn-point (event-start event)))
(defalias 'tree-buffer-mouse-set-point 'mouse-set-point)
(defun tree-buffer-event-to-key (event)
(let ((type (event-basic-type event)))
(case type
((mouse-1 mouse-2 mouse-3) 'mouse-release)
((down-mouse-1 down-mouse-2 down-mouse-3) 'mouse-press)
(otherwise (event-basic-type event)))))
)
;; overlay/extend stuff
(if (not tree-buffer-running-xemacs)
(progn
(defalias 'tree-buffer-make-overlay 'make-overlay)
(defalias 'tree-buffer-overlay-put 'overlay-put)
(defalias 'tree-buffer-overlay-move 'move-overlay)
(defalias 'tree-buffer-overlay-delete 'delete-overlay)
(defalias 'tree-buffer-overlay-kill 'delete-overlay))
;; XEmacs
(defalias 'tree-buffer-make-overlay 'make-extent)
(defalias 'tree-buffer-overlay-put 'set-extent-property)
(defalias 'tree-buffer-overlay-move 'set-extent-endpoints)
(defalias 'tree-buffer-overlay-delete 'detach-extent)
(defalias 'tree-buffer-overlay-kill 'delete-extent))
;; timer stuff
(if (not tree-buffer-running-xemacs)
(progn
(defalias 'tree-buffer-run-with-idle-timer 'run-with-idle-timer)
(defalias 'tree-buffer-cancel-timer 'cancel-timer))
;; XEmacs
(if (fboundp 'run-with-idle-timer)
(defalias 'tree-buffer-run-with-idle-timer 'run-with-idle-timer)
(defun tree-buffer-run-with-idle-timer (secs repeat function &rest args)
"Perform an action the next time Emacs is idle for SECS seconds.
If REPEAT is non-nil, do this each time Emacs is idle for SECS seconds.
SECS may be an integer or a floating point number.
The action is to call FUNCTION with arguments ARGS.
This function returns a timer object which you can use in
`tree-buffer-cancel-timer'."
(start-itimer "tree-buffer-idle-timer"
function secs (if repeat secs nil)
t (if args t nil) args)))
(if (fboundp 'cancel-timer)
(defalias 'tree-buffer-cancel-timer 'cancel-timer)
(defun tree-buffer-cancel-timer (timer)
"Remove TIMER from the list of active timers."
(delete-itimer timer))))
;; basic utilities
(defun tree-buffer-copy-list (list)
"Return a copy of a LIST, which may be a dotted list.
The elements of the list are not copied, just the list structure itself."
(if (fboundp 'copy-sequence)
(copy-sequence list)
(if (consp list)
(let ((res nil))
(while (consp list) (push (pop list) res))
(prog1 (nreverse res) (setcdr res list)))
(car list))))
(defun tree-buffer-member (item list &optional test-fcn)
"Find the first occurrence of ITEM in LIST.
Return the sublist of LIST whose car is ITEM. Comparison is done with `equal'
unless TEST-FCN is not nil: In this case TEST-FCN will be used to compare ITEM
with the elements of LIST. If TEST-FCN is `eq' then `memq' is called for
optimization."
(if test-fcn
(if (eq test-fcn 'eq)
;; some optimization
(memq item list)
(progn
(while (and list (not (funcall test-fcn item (car list))))
(setq list (cdr list)))
list))
(member item list)))
(defun tree-buffer-position (seq elem &optional test-fcn)
"Return the position of ELEM within SEQ counting from 0. Comparison is done
with `equal' unless TEST-FCN is not nil: In this case TEST-FCN will be used to
compare ITEM with the elements of SEQ."
(if (listp seq)
(let ((pos (- (length seq) (length (tree-buffer-member elem seq test-fcn)))))
(if (= pos (length seq))
nil
pos))
(catch 'found
(dotimes (i (length seq))
(if (funcall (or test-fcn 'equal) elem (aref seq i))
(throw 'found i)))
nil)))
(defun tree-buffer-last (seq)
"Return the last elem of the sequence SEQ."
(if (listp seq)
(car (last seq))
(if (> (length seq) 0)
(aref seq (1- (length seq)))
nil)))
(defun tree-buffer-first (seq)
"Return the first elem of the sequence SEQ."
(if (listp seq)
(car seq)
(if (> (length seq) 0)
(aref seq 0)
nil)))
(defun tree-buffer-set-elt (seq n val)
"Set VAL as new N-th element of SEQ. SEQ can be any sequence. SEQ will be
changed because this is desctructive function. SEQ is returned."
(if (listp seq)
(setcar (nthcdr n seq) val)
(aset seq n val))
seq)
(defun tree-buffer-remove-elt (seq n)
"Remove N-th element from SEQ. SEQ can be any sequence. SEQ will be
changed because this is desctructive function. SEQ is returned."
(delq 'tree-buffer-remove-marker
(tree-buffer-set-elt seq n 'tree-buffer-remove-marker)))
(defsubst tree-buffer-aset (array idx newelt)
"Same as `aset' but returns changed ARRAY."
(aset array idx newelt)
array)
(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))
(defsubst tree-buffer-current-line ()
"Return the current line-number - the first line in a buffer has number 1."
(+ (count-lines 1 (point)) (if (= (current-column) 0) 1 0)))
(defun tree-buffer-goto-line (line)
"Goto LINE, counting from line 1 at beginning of buffer.
This function doesn't set the mark."
;; Move to the specified line number in that buffer.
(save-restriction
(widen)
(goto-char 1)
(if (eq selective-display t)
(re-search-forward "[\n\C-m]" nil 'end (1- line))
(forward-line (1- line)))))
;; debugging
(defvar tree-buffer-debug-mode nil
"If not nil then all functions of tree-buffer which are debug-able write
debug-messages to the message-log of Emacs. Ensure that this variable is opnlx
not nil if you want find or report an error!")
(defun tree-buffer-debug-error (&rest args)
"Run ARGS through `format' and write it to the *Messages*-buffer.
Do nothing if `tree-buffer-debug-mode' is nil!"
(when tree-buffer-debug-mode
(message (concat (format "Tree-buffer-debug: [%s] "
(format-time-string "%H:%M:%S"))
(apply 'format args)))))
;; tree-node
;; Klaus Berndl <klaus.berndl@sdm.de>: hmmm, we can not uses this in
;; tree-node-new if we want an own id-gen for each tree-buffer (reason: not
;; all tree-node-new are called with the tree-buffer the current buffer, e.g.
;; ecb-add-tags runs not with method-buffer as current tree-buffer)...we can
;; it use if we use one id-gen for all tree-buffers....
(defvar tree-node-id nil)
(defconst tree-node-id-init-value -268435456)
(defun tree-node-id-init ()
(setq tree-node-id tree-node-id-init-value))
(tree-node-id-init)
(defsubst tree-node-id-next ()
(setq tree-node-id (1+ tree-node-id)))
(defstruct (tree-node
(:constructor -tree-node-new)
(:copier nil)
(:conc-name tree-node->))
name
type
data
children
parent
shrink-name
shrink-name-spec
expandable
expanded
displayed-name
indentstr
id)
(defun tree-node-new (name type data &optional not-expandable parent
shrink-name shrink-name-spec)
"Create a new tree-node which can be displayed in a tree-buffer.
A tree-node can have the following slots:
NAME: The name of the node. Regardless how the node is displayed; see
SHRINK-NAME and DISPLAYED-NAME.
TYPE: The type of the node; must currently be an interger!
DATA: The data of the node; can be arbitrary lisp-structures.
EXPANDED: If not nil then the node is currently expanded, means its children
are visible.
PARENT: The parent tree-node.
SHRINK-NAME: Decides if the NAME can be shortened when displayed in a
narrow tree buffer window. The following values are valid:
- beginning: The NAME is truncated at the beginning so the end is always
visible. The shrinking can be specified in more detail with
SHRINK-NAME-SPEC \(s.b.)
- end: The NAME is truncated at the end. If the tree-node is EXPANDABLE the
name is truncated so that the expand symbol is visible.
- nil: The NAME is never truncated. In this case DISPLAYED-NAME is equal to
NAME.
SHRINK-NAME-SPEC: nil or a 3 element-list which defines exactly
how to shrink the node-name from beginning. The first element
is a 0-based starting position in the NAME where shrinking
should start if the name has to be shrinked from beginning
\(see SHRINK-NAME) - if nil then 0 is used, i.e. shrinking
starts at beginning of NAME. The second element is a string
which is used as token to indicate the shrinking \(e.g.
\"-->\") - if nil then \"...\" is used. The third element is
the number of chars of the node-name which should remain as
visible \(counted from the end of node-name) - if nil then 5 is
used. This slot is ignored if SHRINK-NAME is 'end or nil.
CHILDREN: List of children tree-nodes.
EXPANDABLE: If not nil then the node is expandable means has children.
INDENTSTR: Containes the full indentation-string for the node. So a single
node can easily be redrawn.
DISPLAYED-NAME: Contains the current displayed name of the node. The
displayed name can be different from the NAME according to the value of
SHRINK-NAME.
For all parameters except NOT-EXPANDABLE the description is available in the
slot-list above. If the first optional argument NOT-EXPANDABLE is set to not
nil then the slot EXPANDABLE will be set to nil; otherwise to t.
See Info node `(ecb)tree-buffer' for all details of using tree-nodes."
(let* ((new-id (tree-node-id-next))
(n (-tree-node-new :id new-id
:name name
:type type
:data data
:expandable (not not-expandable)
:parent parent
:shrink-name shrink-name
:shrink-name-spec (or shrink-name-spec
'(0 "..." 5))
:children nil
:expanded nil
:displayed-name nil
:indentstr nil)))
(when (and parent (tree-node-p parent))
(tree-node-add-children parent n))
n))
(defsubst tree-node-indentlength (node)
"Return the length of slot INDENTSTR."
(length (tree-node->indentstr node)))
(defsubst tree-node-linelength (node)
"Return the length of the full node display in current tree-buffer.
This is the length of the indentation \(slot INDENTSTR) plus the length of the
slot DISPLAYED-NAME of NODE."
(+ (length (tree-node->displayed-name node))
(tree-node-indentlength node)))
(defsubst tree-node-toggle-expanded (node)
"Toggle the value of slot EXPANDED."
(setf (tree-node->expanded node) (not (tree-node->expanded node))))
(defun tree-node-indent-level (node)
"Return indentation-level of NODE.
Top-level nodes \(children of the root-node) have level 0."
(let ((parent (tree-node->parent node)))
(if (eq parent (tree-buffer-get-root))
0
(1+ (tree-node-indent-level parent)))))
(defun tree-node-new-root ()
"Creates a new root node.
The root node has always NAME=\"root\", TYPE=-1 and DATA=nil. The root node
will not be displayed. Only the root-node is allowed to have as TYPE -1!"
(tree-node-new "root" -1 nil))
(defun tree-node-update (node name type data expandable shrink-name)
"Update NODE with setable datas.
Each of the arguments NAME, SHRINK-NAME, TYPE, DATA and EXPANDABLE can have
the special value 'use-old-value\; this means that this attribute/slot of NODE
will not be updated."
(unless (eq name 'use-old-value)
(setf (tree-node->name node) name))
(unless (eq shrink-name 'use-old-value)
(setf (tree-node->shrink-name node) shrink-name))
(unless (eq type 'use-old-value)
(setf (tree-node->type node) type))
(unless (eq data 'use-old-value)
(setf (tree-node->data node) data))
(unless (eq expandable 'use-old-value)
(setf (tree-node->expandable node) expandable)))
(defun tree-node-add-children (node children &optional at-beginning)
"Add new CHILDREN to the already existing children of NODE.
If the optional arg AT_BEGINNING is not nil then the new CHILDREN will be
added to the beginning of the existing children of NODE otherwise to the end
\(default). CHILDREN must be either a single tree-node object or a list of
tree-nodes."
(let ((c-list (typecase children
(tree-node (list children))
(list children)
(otherwise
(error "Children must be either a single tree-node or a list of tree-nodes.")))))
;; set NODE as parent of all new CHILDREN
(dolist (c c-list)
(setf (tree-node->parent c) node))
;; add the new CHILDREN to the existing ones
(setf (tree-node->children node)
(if at-beginning
(append c-list (tree-node->children node))
(append (tree-node->children node) c-list)))))
(defsubst tree-node-sort-children (node sortfn)
"Run `sort' for the children of NODE with SORTFN as sorting-function.
SORTFN must be a function acceptable by `sort'. The sorted children-list
become the new children of NODE."
(setf (tree-node->children node)
(sort (tree-node->children node) sortfn)))
(defsubst tree-node-remove-child (node child)
"Removes the CHILD from the childrens of NODE."
(setf (tree-node->parent child) nil)
(setf (tree-node->children node)
(delq child (tree-node->children node))))
(defun tree-node-find-child-by-data/name (node child-data &optional child-name)
"Finds the first child with the given CHILD-DATA.
CHILD-DATA will be compared with the data of each children of NODE by calling
`tree-buffer-node-data-equal-p'.
If CHILD-NAME is set then also the name of the child will be compared with
CHILD-NAME and must match."
(catch 'exit
(dolist (child (tree-node->children node))
(when (and (tree-buffer-node-data-equal-p (tree-node->data child)
child-data)
(or (null child-name)
(string= child-name (tree-node->name child))))
(throw 'exit child)))))
(defun tree-node-remove-child-by-data/name (node child-data &optional child-name)
"Removes the first child with the given CHILD-DATA.
Returns the removed child. CHILD-DATA will be compared with the data of each
children of NODE by calling `tree-buffer-node-data-equal-p'.
If CHILD-NAME is set then also the name of the child will be compared with
CHILD-NAME and must match."
(catch 'exit
(let ((last-cell nil)
(cell (tree-node->children node)))
(while cell
(when (and (tree-buffer-node-data-equal-p (tree-node->data (car cell))
child-data)
(or (null child-name)
(string= child-name (tree-node->name (car cell)))))
(if last-cell
(setcdr last-cell (cdr cell))
(setf (tree-node->children node) (cdr cell)))
(setcdr cell nil)
(setf (tree-node->parent (car cell)) nil)
(throw 'exit cell))
(setq last-cell cell)
(setq cell (cdr cell))))))
(defun tree-node-find-child-by-name (node child-name)
"Return the first child of NODE with name CHILD-NAME."
(catch 'exit
(dolist (child (tree-node->children node))
(when (equal (tree-node->name child) child-name)
(throw 'exit child)))))
;; TODO: Klaus Berndl <klaus.berndl@sdm.de>: if the version with map-subtree
;; is too slow reuse the following code
;; (defun tree-node-search-subtree-by-data (start-node data)
;; "Search the full subtree of START-NODE for the first \(sub-)node with DATA.
;; The \"full subtree\" means the START-NODE itself, its children, their grandchildren
;; etc. The search is done by a depth-first-search. Data-comparison is performed
;; with `tree-buffer-node-data-equal-p'."
;; (if (tree-buffer-node-data-equal-p data (tree-node->data start-node))
;; start-node
;; (catch 'exit
;; (dolist (child (tree-node->children start-node))
;; (let ((n (tree-node-search-subtree-by-data child data)))
;; (when n
;; (throw 'exit n)))))))
(defun tree-node-search-subtree-by-data (start-node data)
"Search the full subtree of START-NODE for the first \(sub-)node with DATA.
The \"full subtree\" means the START-NODE itself, its children, their grandchildren
etc. The search is done by a depth-first-search. Data-comparison is performed
with `tree-buffer-node-data-equal-p'."
(car (delq nil
(tree-node-map-subtree start-node
(function
(lambda (n)
(if (tree-buffer-node-data-equal-p
data
(tree-node->data n))
n)))))))
;; TODO: Klaus Berndl <klaus.berndl@sdm.de>: if the version with map-subtree
;; is too slow reuse the following code
;; (defun tree-node-search-subtree-by-id (start-node node-id)
;; "Search the full subtree of START-NODE for the first \(sub-)node with NODE-ID.
;; The \"full subtree\" means the START-NODE itself, its children, their grandchildren
;; etc. The search is done by a depth-first-search."
;; (if (= node-id (tree-node->id start-node))
;; start-node
;; (catch 'exit
;; (dolist (child (tree-node->children start-node))
;; (let ((n (tree-node-search-subtree-by-id child node-id)))
;; (when n
;; (throw 'exit n)))))))
(defun tree-node-search-subtree-by-id (start-node node-id)
"Search the full subtree of START-NODE for the first \(sub-)node with NODE-ID.
The \"full subtree\" means the START-NODE itself, its children, their grandchildren
etc. The search is done by a depth-first-search."
(car (delq nil
(tree-node-map-subtree start-node
(function (lambda (n)
(if (= node-id (tree-node->id n))
n)))))))
;; (defun tree-buffer-map-test ()
;; (let ((id (ecb-overlay-get
;; (ecb--semantic-tag-overlay
;; (ecb--semantic-current-tag)) 'ECB-tree-node-id)))
;; (ecb-exec-in-window ecb-methods-buffer-name
;; (message (tree-node->name (tree-node-search-subtree-by-id
;; (tree-buffer-get-root)
;; id))))))
(defun tree-node-map-subtree (start-node map-fcn)
"Apply MAP-FCN to full subtree of START-NODE and make a list of the results.
MAP-FCN is a function which gets a node of this subtree as argument.
Full subtree means the START-NODE itself and all its children and
all the grandchildren and so on; to each of these nodes MAP-FCN
is applied. If START-NODE is the root-node of current tree-buffer
then the START-NODE itself is not passed to MAP-FCN.
Often it is recommendable to apply a `delq' nil to the result
when the MAP-FCN does only perform for certain nodes, i.e. return
not nil only for certain nodes.
The subtree is walked by a depth-first-walk."
(let ((result (unless (equal start-node (tree-buffer-get-root))
(mapcar map-fcn (list start-node)))))
(dolist (child (tree-node->children start-node))
(setq result
(append result (tree-node-map-subtree child map-fcn))))
result))
;; (defun tree-node-map-subtree-test ()
;; (save-excursion
;; (set-buffer ecb-methods-buffer-name)
;; (let ((reslist (tree-node-map-subtree
;; (tree-buffer-get-root)
;; (function
;; (lambda (node)
;; (when (= (tree-node->type node)
;; ecb-methods-nodetype-tag)
;; (ecb--semantic-tag-name (tree-node->data node))))))))
;; reslist)))
;; ------- tree-buffer local variables ----------------------------------
(defvar tree-buffer-root nil
"The \(not displayed) root-node of each tree-buffer.
The value is buffer-local in each tree-buffer.")
(defvar tree-buffer-displayed-nodes nil
"Contains all the current visible nodes of current tree-buffer in
top-to-bottom order. This variable is buffer-local in each tree-buffer!")
(defsubst tree-buffer-initialize-displayed-nodes ()
"Initialize the `tree-buffer-displayed-nodes' with nil."
(setq tree-buffer-displayed-nodes nil))
(defsubst tree-buffer-number-of-displayed-nodes ()
"Return the number of current displayed nodes."
(length tree-buffer-displayed-nodes))
(defsubst tree-buffer-nth-displayed-node (n)
"Return the N-th displayed node of current tree-buffer.
Counts from 0 whereas the 0-th node is the topmost displayed node."
(nth n tree-buffer-displayed-nodes))
(defun tree-buffer-find-displayed-node-by-data/name (node-data &optional
node-name start-node)
"Find the first displayed node in current tree-buffer having data NODA-DATA.
When START-NODE is nil then all currently visible nodes are searched beginning
with the first one otherwise START-NODE is the startpoint for the search.
If NODE-NAME is not nil then it must be A STRING and only a node
is found which has the same node-NAME.
If the search has success then the found node is returend."
(catch 'exit
(let ((node-list (if (or (null start-node)
(eq start-node (tree-buffer-get-root)))
tree-buffer-displayed-nodes
;; we need that sub-list of tree-buffer-displayed-nodes
;; which has the start-node as first elem. But we can
;; not calling `member' for this search because this
;; can result in a stack-overflow in equal for large
;; node-lists especially with complex-data (e.g.
;; semantic tags). Therefore we use `memq'.
(or (tree-buffer-member start-node
tree-buffer-displayed-nodes
'eq)
tree-buffer-displayed-nodes))))
(dolist (node node-list)
(when (and (tree-buffer-node-data-equal-p (tree-node->data node)
node-data)
(or (null node-name)
(and (stringp node-name)
(string= (tree-node->name node) node-name))))
(throw 'exit node))))))
(defun tree-buffer-search-displayed-node-list (search-fcn)
"Call SEARCH-FCN for each currently visible node in current tree-buffer.
Return the first node for which SEARCH-FCN returns not nil."
(catch 'exit
(dolist (node tree-buffer-displayed-nodes)
(when (funcall search-fcn node)
(throw 'exit node)))))
(defun tree-buffer-displayed-node-nr (node)
"Return the number of NODE in the node-sequence of current tree-buffer.
Nodes are compared by `eq'! Number is counted from 0 whereas the topmost
displayed node ha number 0."
(tree-buffer-position tree-buffer-displayed-nodes node 'eq))
(defun tree-buffer-displayed-node-linenr (node)
"Return the line-number of NODE in current tree-buffer.
Nodes are compared by `eq'."
(1+ (tree-buffer-displayed-node-nr node)))
(defsubst tree-buffer-add-to-displayed-nodes (node)
"Add NODE at the end of the displayed nodes `tree-buffer-displayed-nodes'."
(setq tree-buffer-displayed-nodes
(append tree-buffer-displayed-nodes (list node))))
(defsubst tree-buffer-displayed-nodes-remove-nth (n)
"Remove the N-th node from the displayed nodes `tree-buffer-displayed-nodes'."
(tree-buffer-remove-elt tree-buffer-displayed-nodes n))
(defsubst tree-buffer-displayed-nodes-remove-node (node)
"Remove NODE from the displayed nodes `tree-buffer-displayed-nodes'."
(setq tree-buffer-displayed-nodes
(delq node tree-buffer-displayed-nodes)))
(defsubst tree-buffer-displayed-nodes-replace-nth (n new-node)
"Replace the N-th node with NEW-NODE in `tree-buffer-displayed-nodes'.
Return the updated list."
(tree-buffer-set-elt tree-buffer-displayed-nodes n new-node))
(defun tree-buffer-displayed-nodes-replace-node (node new-node)
"Replace NODE with NEW-NODE in `tree-buffer-displayed-nodes'.
Return the updated list."
(let ((memq-list (tree-buffer-member node tree-buffer-displayed-nodes 'eq)))
(if memq-list
(setcar memq-list new-node)))
tree-buffer-displayed-nodes)
(defsubst tree-buffer-set-displayed-nodes (displayed-nodes)
"Set `tree-buffer-displayed-nodes' to DISPLAYED-NODES.
DISPLAYED-NODES which has to be a list of node-objects. Replaces the old list
of displayed-nodes."
(setq tree-buffer-displayed-nodes displayed-nodes))
(defsubst tree-buffer-displayed-nodes-copy ()
"Return a copy of the displayed-nodes-list `tree-buffer-displayed-nodes'.
Only the list-structure is copied not the elements itself."
(tree-buffer-copy-list tree-buffer-displayed-nodes))
(defsubst tree-buffer-map-displayed-nodes (function)
"Apply function to each node of `tree-buffer-displayed-nodes'.
Make a list of the results. The result is a list just as long as
`tree-buffer-displayed-nodes'."
(mapcar (function (lambda (n)
(funcall function n)))
tree-buffer-displayed-nodes))
;; rest of tree-buffer local variables
(defvar tree-buffer-frame nil
"The frame the tree-buffer lives in.
The value is buffer-local in current tree-buffer.")
(defvar tree-buffer-key-map nil
"The local keymap of current tree-buffer.
The value is buffer-local in current tree-buffer.")
(defvar tree-buffer-highlighted-node nil
"The data of that node which is currently highlighted.
It's a list with three elements: The first element is the data-slot of the
node, the second one is the name-slot and the third one is the node object
itself.
This variable is only set by `tree-buffer-highlight-node-by-data/name'.
The value is buffer-local in current tree-buffer.")
(defun tree-buffer-highlighted-node-matches-data/name-p (data name)
"return not nil iff currently highlighted node matches passed data and name.
Currently highlighted node is stored in `tree-buffer-highlighted-node'."
(and (tree-buffer-node-data-equal-p data (nth 0 tree-buffer-highlighted-node))
;; if stored name is nil then it has not been set by
;; `tree-buffer-highlight-node-by-data/name' and is therefore not
;; valid to compare. If set it must match the passed name.
(or (null (nth 1 tree-buffer-highlighted-node))
(and (stringp name)
(string= name (nth 1 tree-buffer-highlighted-node))))))
(defvar tree-buffer-highlight-overlay nil
"Overlay \(rsp. extent for XEmacs) used for highlighting current node.
The value is buffer-local in current tree-buffer.")
(defvar tree-buffer-general-overlay nil
"Overlay \(rsp. extent for XEmacs) used for displaying the whole content.
The value is buffer-local in current tree-buffer.")
(defvar tree-buffer-spec nil
"A Buffer local object of type tree-buffer-spec.")
(defvar tree-buffer-hscroll-number 0
"Current value of horizontal tree-buffer-scrolling'.
The value is buffer-local in current tree-buffer.")
(defvar tree-buffer-sticky-parent-node-function nil
"Function used to get that parent node which should be sticky.
This function gets as argument a node and should either return nil \(if there
is not suitable parent node) or node. This node will be display as sticky in
the header-line of the tree-buffer.")
;; tree-buffer specification
(defstruct (tree-buffer-spec
(:constructor -tree-buffer-spec-new)
(:copier nil)
(:conc-name tree-buffer-spec->))
(tree-indent nil :read-only t)
(menu-creator nil :read-only t)
(menu-titles nil :read-only t)
(modeline-menu-creator :read-only t)
(sticky-parent-p :read-only t)
(sticky-indent-string :read-only t)
(sticky-parent-fn :read-only t)
(type-facer nil :read-only t)
(expand-symbol-before-p nil :read-only t)
(mouse-action-trigger nil :read-only t)
(is-click-valid-fn nil :read-only t)
(node-selected-fn nil :read-only t)
(node-expanded-fn nil :read-only t)
(node-collapsed-fn nil :read-only t)
(node-mouse-over-fn nil :read-only t)
(mouse-highlight-fn nil :read-only t)
(node-data-equal-fn nil :read-only t)
(after-update-hook nil :read-only t)
(maybe-empty-node-types nil :read-only t)
(leaf-node-types nil :read-only t)
(general-face nil :read-only t)
(incr-search-additional-pattern nil :read-only t)
(incr-search-p nil :read-only t)
(reduce-tree-for-incr-search-fn :read-only t)
(hor-scroll-step nil :read-only t)
(default-images-dir nil :read-only t)
(additional-images-dir nil :read-only t)
(image-file-prefix nil :read-only t)
(style nil :read-only t)
(ascii-guide-face nil :read-only t))
(defun* tree-buffer-spec-new (&key
tree-indent
menu-creator
menu-titles
modeline-menu-creator
sticky-parent-p
sticky-indent-string
sticky-parent-fn
type-facer
expand-symbol-before-p
mouse-action-trigger
is-click-valid-fn
node-selected-fn
node-expanded-fn
node-collapsed-fn
node-mouse-over-fn
mouse-highlight-fn
node-data-equal-fn
after-update-hook
maybe-empty-node-types
leaf-node-types
general-face
incr-search-additional-pattern
incr-search-p
reduce-tree-for-incr-search-fn
hor-scroll-step
default-images-dir
additional-images-dir
image-file-prefix
style
ascii-guide-face)
"Creates and returns a new specification object for current tree-buffer.
The arguments are key-arguments of the form :arg-name arg-value, so for
example a call looks like \(tree-buffer-spec-new :menu-creator 'creator...)
The key-arguments can be arranged in any arbitrary order but all of them are
not-optional! The key-arg-name is always a : followed by the lowercase version
of the mentioned argument \(e.g. MENU-CREATOR --> :menu-creator)
See `tree-buffer-create' for a description of the arguments."
(let ((my-style (tree-buffer-real-style style)))
(-tree-buffer-spec-new :menu-creator menu-creator
:menu-titles menu-titles
:modeline-menu-creator modeline-menu-creator
:sticky-parent-p sticky-parent-p
:sticky-indent-string sticky-indent-string
:sticky-parent-fn sticky-parent-fn
:type-facer type-facer
:mouse-action-trigger mouse-action-trigger
:is-click-valid-fn is-click-valid-fn
:node-selected-fn node-selected-fn
:node-expanded-fn node-expanded-fn
:node-collapsed-fn node-collapsed-fn
:node-mouse-over-fn node-mouse-over-fn
:mouse-highlight-fn mouse-highlight-fn
:node-data-equal-fn node-data-equal-fn
:after-update-hook
(if (functionp after-update-hook)
(list after-update-hook)
after-update-hook)
:maybe-empty-node-types maybe-empty-node-types
:leaf-node-types leaf-node-types
:general-face general-face
:incr-search-additional-pattern incr-search-additional-pattern
:incr-search-p incr-search-p
:reduce-tree-for-incr-search-fn
(or (and (functionp reduce-tree-for-incr-search-fn)
reduce-tree-for-incr-search-fn)
'ignore)
:hor-scroll-step hor-scroll-step
:default-images-dir default-images-dir
:additional-images-dir additional-images-dir
:image-file-prefix image-file-prefix
:style my-style
:expand-symbol-before-p (if (equal 'image my-style)
t
expand-symbol-before-p)
:tree-indent
(cond ((equal 'image my-style)
tree-buffer-indent-with-images)
(expand-symbol-before-p
(if (< tree-indent
tree-buffer-indent-w/o-images-before-min)
tree-buffer-indent-w/o-images-before-min
tree-indent))
(t ;; after
(if (< tree-indent
tree-buffer-indent-w/o-images-after-min)
tree-buffer-indent-w/o-images-after-min
tree-indent)))
:ascii-guide-face ascii-guide-face)))
;; incremental search in a tree-buffer
(defconst tree-buffer-incr-searchpattern-expand-prefix
"\\(\\[[^][]+\\] ?\\)?\\[?"
"The prefix ignores all expand/collapse-buttons: \[+], \[x], rsp. \[-]")
(defvar tree-buffer-incr-searchpattern nil
"Current search pattern when a inremental search is active.
The value is buffer-local in current tree-buffer.")
(defvar tree-buffer-last-incr-searchpattern nil
"Most recent used search-pattern for incremental search.
Used to compared with the value of `tree-buffer-incr-searchpattern'.
The value is buffer-local in current tree-buffer.")
;; This can not be part of `tree-buffer-spec' because then a call to
;; `tree-buffer-gen-searchpattern-indent-prefix' would be necessary *before*
;; the tree-buffer-spec object is created and this would cause a cyclic
;; dependency in `tree-buffer-real-style'.
(defvar tree-buffer-incr-searchpattern-indent-prefix nil
"Prefix-pattern which ignores all not interesting basic stuff of a displayed
tag at incr. search. The following contents of a displayed tag are ignored
by this pattern:
- beginning spaces and guide characters \(|`-)
This prefix is computed by `tree-buffer-gen-searchpattern-indent-prefix'!
The value is buffer-local in current tree-buffer.")
;; --- tree-buffer-local data-storage with get- and set-function --------
(defvar tree-buffer-data-store nil
"Arbitrary data-storage which is buffer-local for each tree-buffer.
Use `tree-buffer-set-data-store' and `tree-buffer-get-data-store' to set and
get the data.")
(defsubst tree-buffer-set-data-store (data)
"Set `tree-buffer-data-store' to DATA."
(setq tree-buffer-data-store data))
(defsubst tree-buffer-get-data-store ()
"Return the current value of `tree-buffer-data-store'."