Import Tk 8.5.15 (as of svn r89086)
This commit is contained in:
Zachary Ware
161
tests/border.test
Normal file
161
tests/border.test
Normal file
@@ -0,0 +1,161 @@
|
||||
# This file is a Tcl script to test out the procedures in the file
|
||||
# tkBorder.c. It is organized in the standard fashion for Tcl tests.
|
||||
#
|
||||
# Copyright (c) 1998 Sun Microsystems, Inc.
|
||||
# Copyright (c) 1998-1999 by Scriptics Corporation.
|
||||
# All rights reserved.
|
||||
|
||||
package require tcltest 2.1
|
||||
eval tcltest::configure $argv
|
||||
tcltest::loadTestedCommands
|
||||
|
||||
if {[testConstraint pseudocolor8]} {
|
||||
toplevel .t -visual {pseudocolor 8} -colormap new
|
||||
wm geom .t +0+0
|
||||
}
|
||||
|
||||
test border-1.1 {Tk_AllocBorderFromObj - converting internal reps} testborder {
|
||||
set x orange
|
||||
lindex $x 0
|
||||
destroy .b1
|
||||
button .b1 -bg $x -text .b1
|
||||
lindex $x 0
|
||||
testborder orange
|
||||
} {{1 0}}
|
||||
test border-1.3 {Tk_AllocBorderFromObj - discard stale border} testborder {
|
||||
set x orange
|
||||
destroy .b1 .b2
|
||||
button .b1 -bg $x -text First
|
||||
destroy .b1
|
||||
set result {}
|
||||
lappend result [testborder orange]
|
||||
button .b2 -bg $x -text Second
|
||||
lappend result [testborder orange]
|
||||
} {{} {{1 1}}}
|
||||
test border-1.2 {Tk_AllocBorderFromObj - reuse existing border} testborder {
|
||||
set x orange
|
||||
destroy .b1 .b2
|
||||
button .b1 -bg $x -text First
|
||||
set result {}
|
||||
lappend result [testborder orange]
|
||||
button .b2 -bg $x -text Second
|
||||
pack .b1 .b2 -side top
|
||||
lappend result [testborder orange]
|
||||
} {{{1 1}} {{2 1}}}
|
||||
test border-1.4 {Tk_AllocBorderFromObj - try other borders in list} {pseudocolor8 testborder} {
|
||||
set x purple
|
||||
destroy .b1 .b2 .t.b
|
||||
button .b1 -bg $x -text First
|
||||
pack .b1 -side top
|
||||
set result {}
|
||||
lappend result [testborder purple]
|
||||
button .t.b -bg $x -text Second
|
||||
pack .t.b -side top
|
||||
lappend result [testborder purple]
|
||||
button .b2 -bg $x -text Third
|
||||
pack .b2 -side top
|
||||
lappend result [testborder purple]
|
||||
} {{{1 1}} {{1 1} {1 0}} {{1 0} {2 1}}}
|
||||
|
||||
test border-3.1 {Tk_Free3DBorder - reference counts} {pseudocolor8 testborder} {
|
||||
set x purple
|
||||
destroy .b1 .b2 .t.b
|
||||
button .b1 -bg $x -text First
|
||||
pack .b1 -side top
|
||||
button .t.b -bg $x -text Second
|
||||
pack .t.b -side top
|
||||
button .b2 -bg $x -text Third
|
||||
pack .b2 -side top
|
||||
set result {}
|
||||
lappend result [testborder purple]
|
||||
destroy .b1
|
||||
lappend result [testborder purple]
|
||||
destroy .b2
|
||||
lappend result [testborder purple]
|
||||
destroy .t.b
|
||||
lappend result [testborder purple]
|
||||
} {{{1 0} {2 1}} {{1 0} {1 1}} {{1 0}} {}}
|
||||
test border-3.4 {Tk_Free3DBorder - unlinking from list} {pseudocolor8 testborder} {
|
||||
destroy .b .t.b .t2 .t3
|
||||
toplevel .t2 -visual {pseudocolor 8} -colormap new
|
||||
toplevel .t3 -visual {pseudocolor 8} -colormap new
|
||||
set x purple
|
||||
button .b -bg $x -text .b1
|
||||
button .t.b1 -bg $x -text .t.b1
|
||||
button .t.b2 -bg $x -text .t.b2
|
||||
button .t2.b1 -bg $x -text .t2.b1
|
||||
button .t2.b2 -bg $x -text .t2.b2
|
||||
button .t2.b3 -bg $x -text .t2.b3
|
||||
button .t3.b1 -bg $x -text .t3.b1
|
||||
button .t3.b2 -bg $x -text .t3.b2
|
||||
button .t3.b3 -bg $x -text .t3.b3
|
||||
button .t3.b4 -bg $x -text .t3.b4
|
||||
set result {}
|
||||
lappend result [testborder purple]
|
||||
destroy .t2
|
||||
lappend result [testborder purple]
|
||||
destroy .b
|
||||
lappend result [testborder purple]
|
||||
destroy .t3
|
||||
lappend result [testborder purple]
|
||||
destroy .t
|
||||
lappend result [testborder purple]
|
||||
} {{{4 1} {3 0} {2 0} {1 0}} {{4 1} {2 0} {1 0}} {{4 1} {2 0}} {{2 0}} {}}
|
||||
|
||||
test border-4.1 {FreeBorderObjProc} testborder {
|
||||
destroy .b
|
||||
set x [format purple]
|
||||
button .b -bg $x -text .b1
|
||||
set y [format purple]
|
||||
.b configure -bg $y
|
||||
set z [format purple]
|
||||
.b configure -bg $z
|
||||
set result {}
|
||||
lappend result [testborder purple]
|
||||
set x red
|
||||
lappend result [testborder purple]
|
||||
set z 32
|
||||
lappend result [testborder purple]
|
||||
destroy .b
|
||||
lappend result [testborder purple]
|
||||
set y bogus
|
||||
set result
|
||||
} {{{1 3}} {{1 2}} {{1 1}} {}}
|
||||
|
||||
catch {destroy .b}
|
||||
button .b
|
||||
test border-5.1 {Tk_GetReliefFromObj} {
|
||||
.b configure -relief flat
|
||||
.b cget -relief
|
||||
} {flat}
|
||||
test border-5.2 {Tk_GetReliefFromObj} {
|
||||
.b configure -relief groove
|
||||
.b cget -relief
|
||||
} {groove}
|
||||
test border-5.3 {Tk_GetReliefFromObj} {
|
||||
.b configure -relief raised
|
||||
.b cget -relief
|
||||
} {raised}
|
||||
test border-5.4 {Tk_GetReliefFromObj} {
|
||||
.b configure -relief ridge
|
||||
.b cget -relief
|
||||
} {ridge}
|
||||
test border-5.5 {Tk_GetReliefFromObj} {
|
||||
.b configure -relief solid
|
||||
.b cget -relief
|
||||
} {solid}
|
||||
test border-5.6 {Tk_GetReliefFromObj} {
|
||||
.b configure -relief sunken
|
||||
.b cget -relief
|
||||
} {sunken}
|
||||
test border-5.7 {Tk_GetReliefFromObj - error} {
|
||||
list [catch {.b configure -relief upanddown} msg] $msg
|
||||
} {1 {bad relief "upanddown": must be flat, groove, raised, ridge, solid, or sunken}}
|
||||
|
||||
if {[testConstraint pseudocolor8]} {
|
||||
destroy .t
|
||||
}
|
||||
|
||||
# cleanup
|
||||
cleanupTests
|
||||
return
|
||||
Reference in New Issue
Block a user