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