summaryrefslogtreecommitdiffstats
path: root/tests/border.test
diff options
context:
space:
mode:
Diffstat (limited to 'tests/border.test')
-rw-r--r--tests/border.test158
1 files changed, 98 insertions, 60 deletions
diff --git a/tests/border.test b/tests/border.test
index 30aed91..78d0fcd 100644
--- a/tests/border.test
+++ b/tests/border.test
@@ -5,49 +5,60 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
-package require tcltest 2.1
+package require tcltest 2.2
+namespace import ::tcltest::*
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 {
+test border-1.1 {Tk_AllocBorderFromObj - converting internal reps} -constraints {
+ testborder
+} -body {
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 {
+} -cleanup {
+ destroy .b1
+} -result {{1 0}}
+test border-1.2 {Tk_AllocBorderFromObj - discard stale border} -constraints {
+ testborder
+} -setup {
+ set result {}
+} -body {
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
+} -cleanup {
destroy .b1 .b2
- button .b1 -bg $x -text First
+} -result {{} {{1 1}}}
+test border-1.3 {Tk_AllocBorderFromObj - reuse existing border} -constraints {
+ testborder
+} -setup {
set result {}
+} -body {
+ set x orange
+ button .b1 -bg $x -text First
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} {
+} -cleanup {
+ destroy .b1 .b2
+} -result {{{1 1}} {{2 1}}}
+test border-1.4 {Tk_AllocBorderFromObj - try other borders in list} -constraints {
+ testborder pseudocolor8
+} -setup {
+ toplevel .t -visual {pseudocolor 8} -colormap new
+ wm geom .t +0+0
+ set result {}
+} -body {
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
@@ -55,18 +66,24 @@ test border-1.4 {Tk_AllocBorderFromObj - try other borders in list} {pseudocolor
button .b2 -bg $x -text Third
pack .b2 -side top
lappend result [testborder purple]
-} {{{1 1}} {{1 1} {1 0}} {{1 0} {2 1}}}
+} -cleanup {
+ destroy .b1 .b2 .t
+} -result {{{1 1}} {{1 1} {1 0}} {{1 0} {2 1}}}
-test border-3.1 {Tk_Free3DBorder - reference counts} {pseudocolor8 testborder} {
+test border-2.1 {Tk_Free3DBorder - reference counts} -constraints {
+ testborder pseudocolor8
+} -setup {
+ toplevel .t -visual {pseudocolor 8} -colormap new
+ wm geom .t +0+0
+ set result {}
+} -body {
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]
@@ -74,11 +91,18 @@ test border-3.1 {Tk_Free3DBorder - reference counts} {pseudocolor8 testborder} {
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
+} -cleanup {
+ destroy .b1 .b2 .t
+} -result {{{1 0} {2 1}} {{1 0} {1 1}} {{1 0}} {}}
+test border-2.2 {Tk_Free3DBorder - unlinking from list} -constraints {
+ testborder pseudocolor8
+} -setup {
+ toplevel .t -visual {pseudocolor 8} -colormap new
+ wm geom .t +0+0
toplevel .t2 -visual {pseudocolor 8} -colormap new
toplevel .t3 -visual {pseudocolor 8} -colormap new
+ set result {}
+} -body {
set x purple
button .b -bg $x -text .b1
button .t.b1 -bg $x -text .t.b1
@@ -90,7 +114,6 @@ test border-3.4 {Tk_Free3DBorder - unlinking from list} {pseudocolor8 testborder
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]
@@ -100,17 +123,21 @@ test border-3.4 {Tk_Free3DBorder - unlinking from list} {pseudocolor8 testborder
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}} {}}
+} -cleanup {
+ destroy .b .t2 .t3 .t
+} -result {{{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
+test border-3.1 {FreeBorderObjProc} -constraints {
+ testborder
+} -setup {
+ set result {}
+} -body {
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]
@@ -119,42 +146,53 @@ test border-4.1 {FreeBorderObjProc} testborder {
destroy .b
lappend result [testborder purple]
set y bogus
- set result
-} {{{1 3}} {{1 2}} {{1 1}} {}}
+ return $result
+} -cleanup {
+ destroy .b
+} -result {{{1 3}} {{1 2}} {{1 1}} {}}
-catch {destroy .b}
-button .b
-test border-5.1 {Tk_GetReliefFromObj} {
- .b configure -relief flat
+test border-4.1 {Tk_GetReliefFromObj} -body {
+ button .b -relief flat
.b cget -relief
-} {flat}
-test border-5.2 {Tk_GetReliefFromObj} {
- .b configure -relief groove
+} -cleanup {
+ destroy .b
+} -result {flat}
+test border-4.2 {Tk_GetReliefFromObj} -body {
+ button .b -relief groove
.b cget -relief
-} {groove}
-test border-5.3 {Tk_GetReliefFromObj} {
- .b configure -relief raised
+} -cleanup {
+ destroy .b
+} -result {groove}
+test border-4.3 {Tk_GetReliefFromObj} -body {
+ button .b -relief raised
.b cget -relief
-} {raised}
-test border-5.4 {Tk_GetReliefFromObj} {
- .b configure -relief ridge
+} -cleanup {
+ destroy .b
+} -result {raised}
+test border-4.4 {Tk_GetReliefFromObj} -body {
+ button .b -relief ridge
.b cget -relief
-} {ridge}
-test border-5.5 {Tk_GetReliefFromObj} {
- .b configure -relief solid
+} -cleanup {
+ destroy .b
+} -result {ridge}
+test border-4.5 {Tk_GetReliefFromObj} -body {
+ button .b -relief solid
.b cget -relief
-} {solid}
-test border-5.6 {Tk_GetReliefFromObj} {
- .b configure -relief sunken
+} -cleanup {
+ destroy .b
+} -result {solid}
+test border-4.6 {Tk_GetReliefFromObj} -body {
+ button .b -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}}
+} -cleanup {
+ destroy .b
+} -result {sunken}
+test border-4.7 {Tk_GetReliefFromObj - error} -body {
+ button .b -relief upanddown
+} -cleanup {
+ destroy .b
+} -returnCodes error -result {bad relief "upanddown": must be flat, groove, raised, ridge, solid, or sunken}
-if {[testConstraint pseudocolor8]} {
- destroy .t
-}
# cleanup
cleanupTests
generated by cgit v0.12 at 2024-11-02 21:47:18 (GMT)