1# 2# $Id$ 3# 4 5package require Tk 8.5 6package require tcltest ; namespace import -force tcltest::* 7loadTestedCommands 8 9proc propagate-geometry {} { update idletasks } 10 11# Basic sanity checks: 12# 13test panedwindow-1.0 "Setup" -body { 14 ttk::panedwindow .pw 15} -result .pw 16 17test panedwindow-1.1 "Make sure empty panedwindow doesn't crash" -body { 18 pack .pw -expand true -fill both 19 update 20} 21 22test panedwindow-1.2 "Add a pane" -body { 23 .pw add [ttk::frame .pw.f1] 24 winfo manager .pw.f1 25} -result "panedwindow" 26 27test panedwindow-1.3 "Steal pane" -body { 28 pack .pw.f1 -side bottom 29 winfo manager .pw.f1 30} -result "pack" 31 32test panedwindow-1.4 "Make sure empty panedwindow still doesn't crash" -body { 33 update 34} 35 36test panedwindow-1.5 "Remanage pane" -body { 37 #XXX .pw insert 0 .pw.f1 38 .pw add .pw.f1 39 winfo manager .pw.f1 40} -result "panedwindow" 41 42test panedwindow-1.6 "Forget pane" -body { 43 .pw forget .pw.f1 44 winfo manager .pw.f1 45} -result "" 46 47test panedwindow-1.7 "Make sure empty panedwindow still still doesn't crash" -body { 48 update 49} 50 51test panedwindow-1.8 "Re-forget pane" -body { 52 .pw forget .pw.f1 53} -returnCodes 1 -result ".pw.f1 is not managed by .pw" 54 55test panedwindow-1.end "Cleanup" -body { 56 destroy .pw 57} 58 59# Resize behavior: 60# 61test panedwindow-2.1 "..." -body { 62 ttk::panedwindow .pw -orient horizontal 63 64 .pw add [listbox .pw.l1] 65 .pw add [listbox .pw.l2] 66 .pw add [listbox .pw.l3] 67 .pw add [listbox .pw.l4] 68 69 pack .pw -expand true -fill both 70 update 71 set w1 [winfo width .] 72 73 # This should make the window shrink: 74 destroy .pw.l2 75 76 update 77 set w2 [winfo width .] 78 79 expr {$w2 < $w1} 80} -result 1 81 82test panedwindow-2.2 "..., cont'd" -body { 83 84 # This should keep the window from shrinking: 85 wm geometry . [wm geometry .] 86 87 set rw2 [winfo reqwidth .pw] 88 89 destroy .pw.l1 90 update 91 92 set w3 [winfo width .] 93 set rw3 [winfo reqwidth .pw] 94 95 expr {$w3 == $w2 && $rw3 < $rw2} 96 # problem: [winfo reqwidth] shrinks, but sashes haven't moved 97 # since we haven't gotten a ConfigureNotify. 98 # How to (a) check for this, and (b) fix it? 99} -result 1 100 101test panedwindow-2.3 "..., cont'd" -body { 102 103 .pw add [listbox .pw.l5] 104 update 105 set rw4 [winfo reqwidth .pw] 106 107 expr {$rw4 > $rw3} 108} -result 1 109 110test panedwindow-2.end "Cleanup" -body { destroy .pw } 111 112# 113# ... 114# 115test panedwindow-3.0 "configure pane" -body { 116 ttk::panedwindow .pw 117 .pw add [listbox .pw.lb1] 118 .pw add [listbox .pw.lb2] 119 .pw pane 1 -weight 2 120 .pw pane 1 -weight 121} -result 2 122 123test panedwindow-3.1 "configure pane -- errors" -body { 124 .pw pane 1 -weight -4 125} -returnCodes 1 -match glob -result "-weight must be nonnegative" 126 127test panedwindow-3.2 "add pane -- errors" -body { 128 .pw add [ttk::label .pw.l] -weight -1 129} -returnCodes 1 -match glob -result "-weight must be nonnegative" 130 131 132test panedwindow-3.end "cleanup" -body { destroy .pw } 133 134 135test panedwindow-4.1 "forget" -body { 136 pack [ttk::panedwindow .pw -orient vertical] -expand true -fill both 137 .pw add [label .pw.l1 -text "L1"] 138 .pw add [label .pw.l2 -text "L2"] 139 .pw add [label .pw.l3 -text "L3"] 140 .pw add [label .pw.l4 -text "L4"] 141 142 update 143 144 .pw forget .pw.l1 145 .pw forget .pw.l2 146 .pw forget .pw.l3 147 .pw forget .pw.l4 148 update 149} 150 151test panedwindow-4.2 "forget forgotten" -body { 152 .pw forget .pw.l1 153} -returnCodes 1 -result ".pw.l1 is not managed by .pw" 154 155# checkorder $winlist -- 156# Ensure that Y coordinates windows in $winlist are strictly increasing. 157# 158proc checkorder {winlist} { 159 set pos -1 160 set positions [list] 161 foreach win $winlist { 162 lappend positions [set nextpos [winfo y $win]] 163 if {$nextpos <= $pos} { 164 error "window $win out of order ($positions)" 165 } 166 set pos $nextpos 167 } 168} 169 170test panedwindow-4.3 "insert command" -body { 171 .pw insert end .pw.l1 172 .pw insert end .pw.l3 173 .pw insert 1 .pw.l2 174 .pw insert end .pw.l4 175 176 update; 177 checkorder {.pw.l1 .pw.l2 .pw.l3 .pw.l4} 178} 179 180test panedwindow-4.END "cleanup" -body { 181 destroy .pw 182} 183 184# See #1292219 185 186test panedwindow-5.1 "Propagate Map/Unmap state to children" -body { 187 set result [list] 188 pack [ttk::panedwindow .pw] 189 .pw add [ttk::button .pw.b] 190 update 191 192 lappend result [winfo ismapped .pw] [winfo ismapped .pw.b] 193 194 pack forget .pw 195 update 196 lappend result [winfo ismapped .pw] [winfo ismapped .pw.b] 197 198 set result 199} -result [list 1 1 0 0] -cleanup { 200 destroy .pw 201} 202 203### sashpos tests. 204# 205proc sashpositions {pw} { 206 set positions [list] 207 set npanes [llength [winfo children $pw]] 208 for {set i 0} {$i < $npanes - 1} {incr i} { 209 lappend positions [$pw sashpos $i] 210 } 211 return $positions 212} 213 214test paned-sashpos-setup "Setup for sash position test" -body { 215 ttk::style theme use default 216 ttk::style configure -sashthickness 5 217 218 ttk::panedwindow .pw 219 .pw add [frame .pw.f1 -width 20 -height 20] 220 .pw add [frame .pw.f2 -width 20 -height 20] 221 .pw add [frame .pw.f3 -width 20 -height 20] 222 .pw add [frame .pw.f4 -width 20 -height 20] 223 224 propagate-geometry 225 list [winfo reqwidth .pw] [winfo reqheight .pw] 226} -result [list 20 [expr {20*4 + 5*3}]] 227 228test paned-sashpos-attempt-restore "Attempt to set sash positions" -body { 229 # This is not expected to succeed, since .pw isn't large enough yet. 230 # 231 .pw sashpos 0 30 232 .pw sashpos 1 60 233 .pw sashpos 2 90 234 235 list [winfo reqwidth .pw] [winfo reqheight .pw] [sashpositions .pw] 236} -result [list 20 95 [list 0 5 10]] 237 238test paned-sashpos-restore "Set height then sash positions" -body { 239 # Setting sash positions after setting -height _should_ succeed. 240 # 241 .pw configure -height 120 242 .pw sashpos 0 30 243 .pw sashpos 1 60 244 .pw sashpos 2 90 245 list [winfo reqwidth .pw] [winfo reqheight .pw] [sashpositions .pw] 246} -result [list 20 120 [list 30 60 90]] 247 248test paned-sashpos-cleanup "Clean up" -body { destroy .pw } 249 250test paned-propagation-setup "Setup." -body { 251 ttk::style theme use default 252 ttk::style configure -sashthickness 5 253 wm geometry . {} 254 ttk::panedwindow .pw -orient vertical 255 256 frame .pw.f1 -width 100 -height 50 257 frame .pw.f2 -width 100 -height 50 258 259 list [winfo reqwidth .pw.f1] [winfo reqheight .pw.f1] 260} -result [list 100 50] 261 262test paned-propagation-1 "Initial request size" -body { 263 .pw add .pw.f1 264 .pw add .pw.f2 265 propagate-geometry 266 list [winfo reqwidth .pw] [winfo reqheight .pw] 267} -result [list 100 105] 268 269test paned-propagation-2 "Slave change before map" -body { 270 .pw.f1 configure -width 200 -height 100 271 propagate-geometry 272 list [winfo reqwidth .pw] [winfo reqheight .pw] 273} -result [list 200 155] 274 275test paned-propagation-3 "Map window" -body { 276 pack .pw -expand true -fill both 277 update 278 list [winfo width .pw] [winfo height .pw] [.pw sashpos 0] 279} -result [list 200 155 100] 280 281test paned-propagation-4 "Slave change after map, off-axis" -body { 282 .pw.f1 configure -width 100 ;# should be granted 283 propagate-geometry 284 list [winfo reqwidth .pw] [winfo reqheight .pw] [.pw sashpos 0] 285} -result [list 100 155 100] 286 287test paned-propagation-5 "Slave change after map, on-axis" -body { 288 .pw.f1 configure -height 50 ;# should be denied 289 propagate-geometry 290 list [winfo reqwidth .pw] [winfo reqheight .pw] [.pw sashpos 0] 291} -result [list 100 155 100] 292 293test paned-propagation-cleanup "Clean up." -body { destroy .pw } 294 295tcltest::cleanupTests 296