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