292 lines
7.2 KiB
Plaintext
292 lines
7.2 KiB
Plaintext
package require Tk 8.5
|
|
package require tcltest ; namespace import -force tcltest::*
|
|
loadTestedCommands
|
|
|
|
proc propagate-geometry {} { update idletasks }
|
|
|
|
# Basic sanity checks:
|
|
#
|
|
test panedwindow-1.0 "Setup" -body {
|
|
ttk::panedwindow .pw
|
|
} -result .pw
|
|
|
|
test panedwindow-1.1 "Make sure empty panedwindow doesn't crash" -body {
|
|
pack .pw -expand true -fill both
|
|
update
|
|
}
|
|
|
|
test panedwindow-1.2 "Add a pane" -body {
|
|
.pw add [ttk::frame .pw.f1]
|
|
winfo manager .pw.f1
|
|
} -result "panedwindow"
|
|
|
|
test panedwindow-1.3 "Steal pane" -body {
|
|
pack .pw.f1 -side bottom
|
|
winfo manager .pw.f1
|
|
} -result "pack"
|
|
|
|
test panedwindow-1.4 "Make sure empty panedwindow still doesn't crash" -body {
|
|
update
|
|
}
|
|
|
|
test panedwindow-1.5 "Remanage pane" -body {
|
|
#XXX .pw insert 0 .pw.f1
|
|
.pw add .pw.f1
|
|
winfo manager .pw.f1
|
|
} -result "panedwindow"
|
|
|
|
test panedwindow-1.6 "Forget pane" -body {
|
|
.pw forget .pw.f1
|
|
winfo manager .pw.f1
|
|
} -result ""
|
|
|
|
test panedwindow-1.7 "Make sure empty panedwindow still still doesn't crash" -body {
|
|
update
|
|
}
|
|
|
|
test panedwindow-1.8 "Re-forget pane" -body {
|
|
.pw forget .pw.f1
|
|
} -returnCodes 1 -result ".pw.f1 is not managed by .pw"
|
|
|
|
test panedwindow-1.end "Cleanup" -body {
|
|
destroy .pw
|
|
}
|
|
|
|
# Resize behavior:
|
|
#
|
|
test panedwindow-2.1 "..." -body {
|
|
ttk::panedwindow .pw -orient horizontal
|
|
|
|
.pw add [listbox .pw.l1]
|
|
.pw add [listbox .pw.l2]
|
|
.pw add [listbox .pw.l3]
|
|
.pw add [listbox .pw.l4]
|
|
|
|
pack .pw -expand true -fill both
|
|
update
|
|
set w1 [winfo width .]
|
|
|
|
# This should make the window shrink:
|
|
destroy .pw.l2
|
|
|
|
update
|
|
set w2 [winfo width .]
|
|
|
|
expr {$w2 < $w1}
|
|
} -result 1
|
|
|
|
test panedwindow-2.2 "..., cont'd" -body {
|
|
|
|
# This should keep the window from shrinking:
|
|
wm geometry . [wm geometry .]
|
|
|
|
set rw2 [winfo reqwidth .pw]
|
|
|
|
destroy .pw.l1
|
|
update
|
|
|
|
set w3 [winfo width .]
|
|
set rw3 [winfo reqwidth .pw]
|
|
|
|
expr {$w3 == $w2 && $rw3 < $rw2}
|
|
# problem: [winfo reqwidth] shrinks, but sashes haven't moved
|
|
# since we haven't gotten a ConfigureNotify.
|
|
# How to (a) check for this, and (b) fix it?
|
|
} -result 1
|
|
|
|
test panedwindow-2.3 "..., cont'd" -body {
|
|
|
|
.pw add [listbox .pw.l5]
|
|
update
|
|
set rw4 [winfo reqwidth .pw]
|
|
|
|
expr {$rw4 > $rw3}
|
|
} -result 1
|
|
|
|
test panedwindow-2.end "Cleanup" -body { destroy .pw }
|
|
|
|
#
|
|
# ...
|
|
#
|
|
test panedwindow-3.0 "configure pane" -body {
|
|
ttk::panedwindow .pw
|
|
.pw add [listbox .pw.lb1]
|
|
.pw add [listbox .pw.lb2]
|
|
.pw pane 1 -weight 2
|
|
.pw pane 1 -weight
|
|
} -result 2
|
|
|
|
test panedwindow-3.1 "configure pane -- errors" -body {
|
|
.pw pane 1 -weight -4
|
|
} -returnCodes 1 -match glob -result "-weight must be nonnegative"
|
|
|
|
test panedwindow-3.2 "add pane -- errors" -body {
|
|
.pw add [ttk::label .pw.l] -weight -1
|
|
} -returnCodes 1 -match glob -result "-weight must be nonnegative"
|
|
|
|
|
|
test panedwindow-3.end "cleanup" -body { destroy .pw }
|
|
|
|
|
|
test panedwindow-4.1 "forget" -body {
|
|
pack [ttk::panedwindow .pw -orient vertical] -expand true -fill both
|
|
.pw add [label .pw.l1 -text "L1"]
|
|
.pw add [label .pw.l2 -text "L2"]
|
|
.pw add [label .pw.l3 -text "L3"]
|
|
.pw add [label .pw.l4 -text "L4"]
|
|
|
|
update
|
|
|
|
.pw forget .pw.l1
|
|
.pw forget .pw.l2
|
|
.pw forget .pw.l3
|
|
.pw forget .pw.l4
|
|
update
|
|
}
|
|
|
|
test panedwindow-4.2 "forget forgotten" -body {
|
|
.pw forget .pw.l1
|
|
} -returnCodes 1 -result ".pw.l1 is not managed by .pw"
|
|
|
|
# checkorder $winlist --
|
|
# Ensure that Y coordinates windows in $winlist are strictly increasing.
|
|
#
|
|
proc checkorder {winlist} {
|
|
set pos -1
|
|
set positions [list]
|
|
foreach win $winlist {
|
|
lappend positions [set nextpos [winfo y $win]]
|
|
if {$nextpos <= $pos} {
|
|
error "window $win out of order ($positions)"
|
|
}
|
|
set pos $nextpos
|
|
}
|
|
}
|
|
|
|
test panedwindow-4.3 "insert command" -body {
|
|
.pw insert end .pw.l1
|
|
.pw insert end .pw.l3
|
|
.pw insert 1 .pw.l2
|
|
.pw insert end .pw.l4
|
|
|
|
update;
|
|
checkorder {.pw.l1 .pw.l2 .pw.l3 .pw.l4}
|
|
}
|
|
|
|
test panedwindow-4.END "cleanup" -body {
|
|
destroy .pw
|
|
}
|
|
|
|
# See #1292219
|
|
|
|
test panedwindow-5.1 "Propagate Map/Unmap state to children" -body {
|
|
set result [list]
|
|
pack [ttk::panedwindow .pw]
|
|
.pw add [ttk::button .pw.b]
|
|
update
|
|
|
|
lappend result [winfo ismapped .pw] [winfo ismapped .pw.b]
|
|
|
|
pack forget .pw
|
|
update
|
|
lappend result [winfo ismapped .pw] [winfo ismapped .pw.b]
|
|
|
|
set result
|
|
} -result [list 1 1 0 0] -cleanup {
|
|
destroy .pw
|
|
}
|
|
|
|
### sashpos tests.
|
|
#
|
|
proc sashpositions {pw} {
|
|
set positions [list]
|
|
set npanes [llength [winfo children $pw]]
|
|
for {set i 0} {$i < $npanes - 1} {incr i} {
|
|
lappend positions [$pw sashpos $i]
|
|
}
|
|
return $positions
|
|
}
|
|
|
|
test paned-sashpos-setup "Setup for sash position test" -body {
|
|
ttk::style theme use default
|
|
ttk::style configure -sashthickness 5
|
|
|
|
ttk::panedwindow .pw
|
|
.pw add [frame .pw.f1 -width 20 -height 20]
|
|
.pw add [frame .pw.f2 -width 20 -height 20]
|
|
.pw add [frame .pw.f3 -width 20 -height 20]
|
|
.pw add [frame .pw.f4 -width 20 -height 20]
|
|
|
|
propagate-geometry
|
|
list [winfo reqwidth .pw] [winfo reqheight .pw]
|
|
} -result [list 20 [expr {20*4 + 5*3}]]
|
|
|
|
test paned-sashpos-attempt-restore "Attempt to set sash positions" -body {
|
|
# This is not expected to succeed, since .pw isn't large enough yet.
|
|
#
|
|
.pw sashpos 0 30
|
|
.pw sashpos 1 60
|
|
.pw sashpos 2 90
|
|
|
|
list [winfo reqwidth .pw] [winfo reqheight .pw] [sashpositions .pw]
|
|
} -result [list 20 95 [list 0 5 10]]
|
|
|
|
test paned-sashpos-restore "Set height then sash positions" -body {
|
|
# Setting sash positions after setting -height _should_ succeed.
|
|
#
|
|
.pw configure -height 120
|
|
.pw sashpos 0 30
|
|
.pw sashpos 1 60
|
|
.pw sashpos 2 90
|
|
list [winfo reqwidth .pw] [winfo reqheight .pw] [sashpositions .pw]
|
|
} -result [list 20 120 [list 30 60 90]]
|
|
|
|
test paned-sashpos-cleanup "Clean up" -body { destroy .pw }
|
|
|
|
test paned-propagation-setup "Setup." -body {
|
|
ttk::style theme use default
|
|
ttk::style configure -sashthickness 5
|
|
wm geometry . {}
|
|
ttk::panedwindow .pw -orient vertical
|
|
|
|
frame .pw.f1 -width 100 -height 50
|
|
frame .pw.f2 -width 100 -height 50
|
|
|
|
list [winfo reqwidth .pw.f1] [winfo reqheight .pw.f1]
|
|
} -result [list 100 50]
|
|
|
|
test paned-propagation-1 "Initial request size" -body {
|
|
.pw add .pw.f1
|
|
.pw add .pw.f2
|
|
propagate-geometry
|
|
list [winfo reqwidth .pw] [winfo reqheight .pw]
|
|
} -result [list 100 105]
|
|
|
|
test paned-propagation-2 "Slave change before map" -body {
|
|
.pw.f1 configure -width 200 -height 100
|
|
propagate-geometry
|
|
list [winfo reqwidth .pw] [winfo reqheight .pw]
|
|
} -result [list 200 155]
|
|
|
|
test paned-propagation-3 "Map window" -body {
|
|
pack .pw -expand true -fill both
|
|
update
|
|
list [winfo width .pw] [winfo height .pw] [.pw sashpos 0]
|
|
} -result [list 200 155 100]
|
|
|
|
test paned-propagation-4 "Slave change after map, off-axis" -body {
|
|
.pw.f1 configure -width 100 ;# should be granted
|
|
propagate-geometry
|
|
list [winfo reqwidth .pw] [winfo reqheight .pw] [.pw sashpos 0]
|
|
} -result [list 100 155 100]
|
|
|
|
test paned-propagation-5 "Slave change after map, on-axis" -body {
|
|
.pw.f1 configure -height 50 ;# should be denied
|
|
propagate-geometry
|
|
list [winfo reqwidth .pw] [winfo reqheight .pw] [.pw sashpos 0]
|
|
} -result [list 100 155 100]
|
|
|
|
test paned-propagation-cleanup "Clean up." -body { destroy .pw }
|
|
|
|
tcltest::cleanupTests
|