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