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