diff options
Diffstat (limited to 'tests/border.test')
| -rw-r--r-- | tests/border.test | 195 |
1 files changed, 195 insertions, 0 deletions
diff --git a/tests/border.test b/tests/border.test new file mode 100644 index 0000000..e59b405 --- /dev/null +++ b/tests/border.test @@ -0,0 +1,195 @@ +# 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. +# +# RCS: @(#) $Id: border.test,v 1.2 1999/04/16 01:51:34 stanton Exp $ + +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} + +if {[info commands testborder] != "testborder"} { + puts "testborder command not available; skipping tests" + ::tcltest::cleanupTests + return +} + +eval destroy [winfo children .] +wm geometry . {} +raise . + +# Create a top-level with its own colormap (so we can test under +# controlled conditions), then check to make sure that the visual +# is color-mapped with 256 borders. If not, just skip this whole +# test file. + +if [catch {toplevel .t -visual {pseudocolor 8} -colormap new}] { + ::tcltest::cleanupTests + return +} +wm geom .t +0+0 +if {[winfo depth .t] != 8} { + destroy .t + ::tcltest::cleanupTests + return +} + +test border-1.1 {Tk_AllocBorderFromObj - converting internal reps} { + 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} { + 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} { + 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} { + 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} { + 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} { + 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} { + 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 get-2.1 {Tk_GetReliefFromObj} { + .b configure -relief flat + .b cget -relief +} {flat} +test get-2.2 {Tk_GetReliefFromObj} { + .b configure -relief groove + .b cget -relief +} {groove} +test get-2.3 {Tk_GetReliefFromObj} { + .b configure -relief raised + .b cget -relief +} {raised} +test get-2.3 {Tk_GetReliefFromObj} { + .b configure -relief ridge + .b cget -relief +} {ridge} +test get-2.3 {Tk_GetReliefFromObj} { + .b configure -relief solid + .b cget -relief +} {solid} +test get-2.3 {Tk_GetReliefFromObj} { + .b configure -relief sunken + .b cget -relief +} {sunken} +test get-2.4 {Tk_GetReliefFromObj - error} { + list [catch {.b configure -relief upanddown} msg] $msg +} {1 {bad relief "upanddown": must be flat, groove, raised, ridge, solid, or sunken}} + +destroy .t + +# cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + + |