File: ITree.tcl

package info (click to toggle)
coccinella 0.96.20-9
  • links: PTS, VCS
  • area: main
  • in suites: bullseye, buster, sid
  • size: 13,184 kB
  • sloc: tcl: 124,744; xml: 206; makefile: 66; sh: 62
file content (434 lines) | stat: -rw-r--r-- 11,575 bytes parent folder | download | duplicates (4)
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
#  ITree.tcl ---
#  
#      This file is part of The Coccinella application. 
#      It implements a simple generic treectrl interface.
#      
#  Copyright (c) 2005  Mats Bengtsson
#  
#   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 3 of the License, 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 this program.  If not, see <http://www.gnu.org/licenses/>.
#  
# $Id: ITree.tcl,v 1.26 2008-05-27 14:17:23 matben Exp $
#       
#  Each item is associated with a list reflecting the tree hierarchy:
#       
#       v = {tag tag ...}
#       
#  We MUST keep the complete tree structure for an item in order to uniquely 
#  identify it in the tree.

package provide ITree 1.0

namespace eval ::ITree {

    variable buttonPressMillis 1000
    variable tag2item
    variable options
}

proc ::ITree::New {T wxsc wysc args} {
    global  this
    variable options
    variable fillT
    variable fillB
    
    set fillT {white {selected focus} black {selected !focus}}
    set fillB [list $this(sysHighlight) {selected focus} gray {selected !focus}]

    set options($T,-backgroundimage) ""
    foreach {key value} $args {
	set options($T,$key) $value
    }

    treectrl $T -selectmode extended  \
      -showroot 0 -showrootbutton 0 -showbuttons 1 -showheader 0  \
      -xscrollcommand [list ::UI::ScrollSet $wxsc     \
      [list grid $wxsc -row 1 -column 0 -sticky ew]]  \
      -yscrollcommand [list ::UI::ScrollSet $wysc     \
      [list grid $wysc -row 0 -column 1 -sticky ns]]  \
      -backgroundimage $options($T,-backgroundimage)  \
      -borderwidth 0 -highlightthickness 0            \
      -height 0 -width 0
    
    array set style [list -foreground black -itembackground {}]
    array set style [ttk::style configure .]
    array set style [ttk::style configure TreeCtrl]

    set itemBackground $style(-itembackground)
    
    $T column create -tags cTree  \
      -itembackground $itemBackground -resize 0 -expand 1
    $T column create -tags cTag -visible 0
    $T configure -treecolumn cTree

    $T element create eImage image
    $T element create eText text -lines 1 -fill $fillT
    $T element create eBorder rect -open new -outline white -outlinewidth 1 \
      -fill $fillB -showfocus 1
 
    set S [$T style create styStd]
    $T style elements $S {eBorder eImage eText}
    $T style layout $S eText -padx 4 -squeeze x -expand ns -ipady 2 -minheight 16
    $T style layout $S eImage -expand ns -ipady 2 -minheight 16
    $T style layout $S eBorder -detach yes -iexpand xy -indent 0

    set S [$T style create styTag]
    $T style elements $S {eText}

    $T column configure cTree -itemstyle styStd
    $T column configure cTag  -itemstyle styTag

    $T notify bind $T <Selection>      { ::ITree::Selection %T }
    $T notify bind $T <Expand-after>   { ::ITree::OpenTreeCmd %T %I }
    $T notify bind $T <Collapse-after> { ::ITree::CloseTreeCmd %T %I }
    bind $T <Button-1>        { ::ITree::ButtonPress %W %x %y }        
    bind $T <ButtonRelease-1> { ::ITree::ButtonRelease %W %x %y }        
    bind $T <Double-1>        { ::ITree::DoubleClick %W %x %y }        
    bind $T <<ButtonPopup>>   { ::ITree::Popup %W %x %y }
    bind $T <Destroy>         {+::ITree::OnDestroy %W }
    
    # This automatically cleans up the tag array.
    $T notify bind RosterTreeTag <ItemDelete> {
	foreach item %i {
	    ::ITree::UnsetTags %T $item
	} 
    }
    bindtags $T [concat RosterTreeTag [bindtags $T]]

    set itemFill $style(-foreground)
    if {[info exists style(-itemfill)]} {
	set itemFill $style(-itemfill)
    }  
    set stateFill [concat $fillT [list $itemFill {}]]
    treeutil::configureelementtype $T text -fill $stateFill
}

proc ::ITree::GetStyle {T} {
    return styStd
}

proc ::ITree::ElementLayout {T type args} {
    array set type2elem {
	image eImage
	text  eText
    }
    return [eval {$T style layout styStd $type2elem($type)} $args]
}

proc ::ITree::Selection {T} {
    variable options

    if {[info exists options($T,-selection)]} {
	set n [$T selection count]
	if {$n == 1} {
	    set item [$T selection get]
	    set v [$T item element cget $item cTag eText -text]
	    $options($T,-selection) $T $v
	}
    }
}

proc ::ITree::OpenTreeCmd {T item} {
    variable options

    if {[info exists options($T,-open)]} {
	set v [$T item element cget $item cTag eText -text]
	$options($T,-open) $T $v
    }
}

proc ::ITree::CloseTreeCmd {T item} {
    variable options

    if {[info exists options($T,-close)]} {
	set v [$T item element cget $item cTag eText -text]
	$options($T,-close) $T $v
    }
}

proc ::ITree::ButtonPress {T x y} {
    variable buttonAfterId
    variable buttonPressMillis
    variable options

    if {[info exists options($T,-buttonpress)]} {    
	if {[tk windowingsystem] eq "aqua"} {
	    if {[info exists buttonAfterId]} {
		catch {after cancel $buttonAfterId}
	    }
	    set cmd [list ::ITree::ButtonPressCmd $T $x $y]
	    set buttonAfterId [after $buttonPressMillis $cmd]
	}
    }
    set id [$T identify $x $y]
    if {$id eq ""} {
	$T selection clear all
    }
}

proc ::ITree::ButtonRelease {T x y} {
    variable buttonAfterId
    
    if {[info exists buttonAfterId]} {
	catch {after cancel $buttonAfterId}
	unset buttonAfterId
    }
}

proc ::ITree::ButtonPressCmd {T x y} {
    variable options
    
    # Perhaps we should check that mouse is still in widget before posting?
    if {[info exists options($T,-buttonpress)]} {
	DoPopup $T $x $y $options($T,-buttonpress)
    }
}

proc ::ITree::DoubleClick {T x y} {
    variable options

    if {[info exists options($T,-doublebutton)]} {
	set id [$T identify $x $y]
	if {[lindex $id 0] eq "item"} {
	    set item [lindex $id 1]
	    set v [$T item element cget $item cTag eText -text]
	} elseif {$id eq ""} {
	    set v {}
	}
	$options($T,-doublebutton) $T $v
    }
}

proc ::ITree::Popup {T x y} {    
    variable options

    if {[info exists options($T,-buttonpopup)]} {
	DoPopup $T $x $y $options($T,-buttonpopup)
    }
}

proc ::ITree::DoPopup {T x y command} {
    variable options

    if {[info exists options($T,-buttonpopup)]} {    
	set id [$T identify $x $y]
	if {[lindex $id 0] eq "item"} {
	    set item [lindex $id 1]
	    set v [$T item element cget $item cTag eText -text]
	} elseif {$id eq ""} {
	    set v [list]
	}
	$command $T $v $x $y
    }
}

proc ::ITree::Item {T v args} {
    variable tag2item
        
    set isopen 0
    if {[set idx [lsearch -exact $args -open]] >= 0} {
	set isopen [lindex $args [incr idx]]
    }
    set parent root
    if {[llength $v] > 1} {
	set parentv [lrange $v 0 end-1]
	set parent $tag2item($T,$parentv)
	
    }
    set item [$T item create -open $isopen -parent $parent]
    # @@@ treectrl2.2.3   
    # Can the order of the tags list be trusted???
    # set item [$T item create -open $isopen -parent $parent \
    #     -tags [list [treeutil::protect $v]]]
    set tag2item($T,$v) $item

    $T item element configure $item cTag eText -text $v
    eval {ItemConfigure $T $v} $args
            
    return $item
}

proc ::ITree::IsItem {T v} {
    variable tag2item

    # @@@ treectrl2.2.3   
    # return [llength [$T item id "tag [list [treeutil::protect $v]]"]]
    set ans 0
    if {[info exists tag2item($T,$v)]} {
	if {[$T item id $tag2item($T,$v)] ne ""} {
	    set ans 1
	}
    }
    return $ans
}

proc ::ITree::GetItem {T v} {
    variable tag2item
    
    # @@@ treectrl2.2.3
    # return [$T item id "tag [list [treeutil::protect $v]]"]
    set item ""
    if {[info exists tag2item($T,$v)]} {
	if {[$T item id $tag2item($T,$v)] ne ""} {
	    set item $tag2item($T,$v)
	}
    }
    return $item
}

proc ::ITree::ItemConfigure {T v args} {
    variable tag2item
    
    # @@@ treectrl2.2.3
    # set item [$T item id "tag [treeutil::protect $v]"]
    if {[info exists tag2item($T,$v)]} {
	set item $tag2item($T,$v)
	
	# Dispatch to the right element.
	foreach {key value} $args {
	    switch -- $key {
		-text - -font - -lines - -justify - -textvariable {
		    $T item element configure $item cTree eText $key $value
		}
		-image {
		    $T item element configure $item cTree eImage $key $value
		}
		-button {
		    $T item configure $item $key $value
		}
	    }
	}
    }
    return $item
}

proc ::ITree::Children {T v} {
    variable tag2item
    
    set vchilds [list]
    # @@@ treectrl2.2.3
    # set item [$T item id "tag [treeutil::protect $v]"]
    # set citems [$T item children $item]
    # foreach item $citems {
    #     lappend vchilds [$T item cget $item -tags]
    # }
    if {[info exists tag2item($T,$v)]} {
	set citems [$T item children $tag2item($T,$v)]
	foreach item $citems {
	    lappend vchilds [$T item element cget $item cTag eText -text]
	}
    }
    return $vchilds
}

proc ::ITree::Sort {T v args} {
    variable tag2item
    
    # @@@ treectrl2.2.3
    # eval {$T item sort "tag [treeutil::protect $v]" -column cTree} $args
    if {[info exists tag2item($T,$v)]} {
	set item $tag2item($T,$v)
	eval {$T item sort $item -column cTree} $args
    }    
}

# ITree::FindAllTagMatches --
# 
#       This assumes that the tags are a list of sub tags and where
#       we try to find all theat matches this particular sub tag.
#
# Arguments:
#       T       tree widget
#       tag     an element of the tag list
#       
# Results:
#       a list of complete matching tags

proc ::ITree::FindAllTagMatches {T tag} {
    variable tag2item
    
    # @@@ treectrl2.2.3
    # set vlist [list]
    # set items [$T item id "tag [treeutil::protect $tag]"]
    # foreach item $items {
    #     lappend vlist [$T item cget $item -tags]
    # }
    set vlist [list]
    foreach {key item} [array get tag2item "$T,*{$tag}*"] {
	lappend vlist [string map [list "$T," ""] $key]
    }
    return $vlist
}

# ITree::FindEndItems--
# 
#       This is equivalent of getting all parents of this item.

proc ::ITree::FindEndItems {T tagend} {
    variable tag2item

    # @@@ treectrl2.2.3
    # set vlist [list]
    # set items [$T item id "tag [treeutil::protect $tag]"]
    # Find another method!
    set vlist {}
    foreach {key item} [array get tag2item "$T,*{$tagend}"] {
	lappend vlist [string map [list "$T," ""] $key]
    }
    return $vlist
}

proc ::ITree::DeleteItem {T v} {
    variable tag2item
    
    if {[info exists tag2item($T,$v)]} {
	set item $tag2item($T,$v)
	$T item delete $item
	# @@@ treectrl2.2.3
	# $T item delete "tag [treeutil::protect $v]"
    }    
}

proc ::ITree::GetSelection {T} {
   
    set vL [list]
    foreach item [$T selection get] {
	lappend vL [$T item element cget $item cTag eText -text]
    }
    return $vL
}

proc ::ITree::UnsetTags {T item} {
    variable tag2item

    set v [$T item element cget $item cTag eText -text]
    unset -nocomplain tag2item($T,$v)    
}

proc ::ITree::DeleteChildren {T v} {
    
    # @@@ treectrl2.2.3
    # $T item delete "tag [treeutil::protect $v] children"
    foreach vchild [Children $T $v] {
	DeleteItem $T $vchild
    }
}

proc ::ITree::OnDestroy {T} {
    variable options
    variable tag2item
    
    array unset options $T,*
    array unset tag2item $T,*
}