1#
2# $Id$
3#
4
5package require Tk
6package require tcltest ; namespace import -force tcltest::*
7loadTestedCommands
8
9### treeview tag invariants:
10#
11
12proc assert {expr {message ""}} {
13    if {![uplevel 1 [list expr $expr]]} {
14        error "PANIC: $message ($expr failed)"
15    }
16}
17proc in {e l} { expr {[lsearch -exact $l $e] >= 0} }
18
19proc itemConstraints {tv item} {
20    # $tag in [$tv item $item -tags] <==> [$tv tag has $tag $item]
21    foreach tag [$tv item $item -tags] {
22	assert {[in $item [$tv tag has $tag]]}
23    }
24    foreach child [$tv children $item] {
25	itemConstraints $tv $child
26    }
27}
28
29proc treeConstraints {tv} {
30    # $item in [$tv tag has $tag] <==> [$tv tag has $tag $item]
31    #
32    foreach tag [$tv tag names] {
33	foreach item [$tv tag has $tag] {
34	    assert {[in $tag [$tv item $item -tags]]}
35	}
36    }
37
38    itemConstraints $tv {}
39}
40#
41###
42
43test treetags-1.0 "Setup" -body {
44    set tv [ttk::treeview .tv]
45    .tv insert {} end -id item1 -text "Item 1"
46    pack .tv
47} -cleanup {
48    treeConstraints $tv
49}
50
51test treetags-1.1 "Bad tag list" -body {
52    $tv item item1 -tags {bad {list}here bad}
53    $tv item item1 -tags
54} -returnCodes error -result "list element in braces *" -match glob
55
56test treetags-1.2 "Good tag list" -body {
57    $tv item item1 -tags tag1
58    $tv item item1 -tags
59} -cleanup {
60    assert {[$tv tag has tag1 item1]}
61    treeConstraints $tv
62} -result [list tag1]
63
64test treetags-1.3 "tag has - test" -body {
65    $tv insert {} end -id item2 -text "Item 2" -tags tag2
66    set result [list]
67    foreach item {item1 item2} {
68    	foreach tag {tag1 tag2 tag3} {
69	    lappend result $item $tag [$tv tag has $tag $item]
70	}
71    }
72    set result
73} -cleanup {
74    treeConstraints $tv
75} -result [list \
76	item1 tag1 1 item1 tag2 0 item1 tag3 0 \
77	item2 tag1 0 item2 tag2 1 item2 tag3 0 ]
78
79test treetags-1.4 "tag has - query" -body {
80    list [$tv tag has tag1] [$tv tag has tag2] [$tv tag has tag3]
81} -cleanup {
82    treeConstraints $tv
83} -result [list [list item1] [list item2] [list]]
84
85test treetags-1.5 "tag add" -body {
86    $tv tag add tag3 {item1 item2}
87    list [$tv tag has tag1] [$tv tag has tag2] [$tv tag has tag3]
88} -cleanup {
89    treeConstraints $tv
90} -result [list [list item1] [list item2] [list item1 item2]]
91
92test treetags-1.6 "tag remove - list" -body {
93    $tv tag remove tag3 {item1 item2}
94    list [$tv tag has tag1] [$tv tag has tag2] [$tv tag has tag3]
95} -cleanup {
96    treeConstraints $tv
97} -result [list [list item1] [list item2] [list]]
98
99test treetags-1.7 "tag remove - all items" -body {
100    $tv tag remove tag1
101    list [$tv tag has tag1] [$tv tag has tag2] [$tv tag has tag3]
102} -cleanup {
103    treeConstraints $tv
104} -result [list [list] [list item2] [list]]
105
106test treetags-1.8 "tag names" -body {
107    lsort [$tv tag names]
108} -result [list tag1 tag2 tag3]
109
110test treetags-1.9 "tag names - tag added to item" -body {
111    $tv item item1 -tags tag4 
112    lsort [$tv tag names]
113} -result [list tag1 tag2 tag3 tag4]
114
115test treetags-1.10 "tag names - tag configured" -body {
116    $tv tag configure tag5
117    lsort [$tv tag names]
118} -result [list tag1 tag2 tag3 tag4 tag5]
119
120test treetags-1.end "cleanup" -body {
121    $tv item item1 -tags tag1
122    $tv item item2 -tags tag2
123    list [$tv tag has tag1] [$tv tag has tag2] [$tv tag has tag3]
124} -cleanup {
125    treeConstraints $tv
126} -result [list [list item1] [list item2] [list]]
127
128test treetags-2.0 "tag bind" -body {
129    $tv tag bind tag1 <KeyPress> {set ::KEY %A}
130    $tv tag bind tag1 <KeyPress>
131} -cleanup {
132    treeConstraints $tv
133} -result {set ::KEY %A}
134
135test treetags-2.1 "Events delivered to tags" -body {
136    focus -force $tv ; update	;# needed so [event generate] delivers KeyPress
137    $tv focus item1
138    event generate $tv <KeyPress-a>
139    set ::KEY
140} -cleanup {
141    treeConstraints $tv
142} -result a
143
144test treetags-2.2 "Events delivered to correct tags" -body {
145    $tv tag bind tag2 <KeyPress> [list set ::KEY2 %A]
146
147    $tv focus item1
148    event generate $tv <KeyPress-b>
149    $tv focus item2
150    event generate $tv <KeyPress-c>
151
152    list $::KEY $::KEY2
153} -cleanup {
154    treeConstraints $tv
155} -result [list b c]
156
157test treetags-2.3 "Virtual events delivered to focus item" -body {
158    set ::bong 0
159    $tv tag bind tag2 <<Bing>> { incr bong }
160    $tv focus item2
161    event generate $tv <<Bing>>
162    $tv focus item1
163    event generate $tv <<Bing>>
164    set bong
165} -cleanup {
166    treeConstraints $tv
167} -result 1
168
169test treetags-2.4 "Bad events" -body {
170    $tv tag bind bad <Enter> { puts "Entered!" }
171} -returnCodes 1 -result "unsupported event <Enter>*" -match glob
172
173test treetags-3.0 "tag configure - set" -body {
174    $tv tag configure tag1 -foreground blue -background red
175} -cleanup {
176    treeConstraints $tv
177} -result {}
178
179test treetags-3.1 "tag configure - get" -body {
180    $tv tag configure tag1 -foreground
181} -cleanup {
182    treeConstraints $tv
183} -result blue
184
185# @@@ fragile test
186test treetags-3.2 "tag configure - enumerate" -body {
187    $tv tag configure tag1
188} -cleanup {
189    treeConstraints $tv
190} -result [list \
191    -text {} -image {} -anchor {} -background red -foreground blue -font {} \
192]
193
194# The next test exercises tag resource management.
195# If options are not properly freed, the message:
196# Test file error: "Font times 20 still in cache."
197# will show up on stderr at program exit.
198#
199test treetags-3.3 "tag configure - set font" -body {
200    $tv tag configure tag2 -font {times 20}
201}
202
203test treetags-3.4 "stomp tags in tag binding procedure" -body {
204    set result [list]
205    $tv tag bind rm1 <<Remove>> { lappend ::result rm1 [%W focus] <<Remove>> }
206    $tv tag bind rm2 <<Remove>> {
207    	lappend ::result rm2 [%W focus] <<Remove>> 
208	%W item [%W focus] -tags {tag1}
209    }
210    $tv tag bind rm3 <<Remove>> { lappend ::result rm3 [%W focus] <<Remove>> }
211
212    $tv item item1 -tags {rm1 rm2 rm3} 
213    $tv focus item1
214    event generate $tv <<Remove>>
215    set result
216} -cleanup {
217    treeConstraints $tv
218} -result [list rm1 item1 <<Remove>> rm2 item1 <<Remove>> rm3 item1 <<Remove>>]
219
220#
221
222test treetags-end "Cleanup" -body { destroy $tv }
223
224tcltest::cleanupTests
225