First step towards improving test style. Also start using Tcl 8.5 features.

1 files changed, 181 insertions, 168 deletions

diff --git a/tests/frame.test b/tests/frame.test
index 22f4091..41307fe 100644
--- a/tests/frame.test
+++ b/tests/frame.test
@@ -7,12 +7,20 @@
 # Copyright (c) 1998-1999 by Scriptics Corporation.
 # All rights reserved.
 #
-# RCS: @(#) $Id: frame.test,v 1.9 2003/07/16 23:16:52 pspjuth Exp $
+# RCS: @(#) $Id: frame.test,v 1.10 2004/05/23 17:34:48 dkf Exp $
 
 package require tcltest 2.1
 eval tcltest::configure $argv
 tcltest::loadTestedCommands
 
+testConstraint haveDISPLAY [info exists env(DISPLAY)]
+testConstraint edibleColors [expr {
+    ([winfo visual .] == "pseudocolor") && ([winfo depth .] == 8)
+}]
+testConstraint haveGrayscale8 [expr {
+    [lsearch -exact [winfo visualsavailable .] {grayscale 8}] >= 0
+}]
+
 # eatColors --
 # Creates a toplevel window and allocates enough colors in it to
 # use up all the slots in the colormap.
@@ -120,23 +128,22 @@ foreach test {
     {-takefocus "any string" "any string" {} {}}
     {-width 32 32 badValue {bad screen distance "badValue"}}
 } {
-    set name [lindex $test 0]
+    lassign $test opt goodValue goodResult badValue badResult
     test frame-1.$i {frame configuration options} {
-	.f configure $name [lindex $test 1]
-	lindex [.f configure $name] 4
-    } [lindex $test 2]
+	.f configure $opt $goodValue
+	lindex [.f configure $opt] 4
+    } $goodResult
     incr i
-    if {[lindex $test 3] != ""} {
-	test frame-1.$i {frame configuration options} {
-	    list [catch {.f configure $name [lindex $test 3]} msg] $msg
-	} [list 1 [lindex $test 4]]
+    if {$badValue ne ""} {
+	test frame-1.$i {frame configuration options} -body {
+	    .f configure $opt $badValue
+	} -returnCodes error -result $badResult
     }
-    .f configure $name [lindex [.f configure $name] 3]
+    .f configure $opt [lindex [.f configure $opt] 3]
     incr i
 }
 destroy .f
 
-set i 1
 test frame-2.1 {toplevel configuration options} {
     catch {destroy .t}
     toplevel .t -width 200 -height 100 -class NewClass
@@ -176,15 +183,13 @@ test frame-2.7 {toplevel configuration options} {
     catch {destroy .t}
     list [catch {toplevel .t -width 200 -height 100 -visual who_knows?} msg] $msg
 } {1 {unknown or ambiguous visual name "who_knows?": class must be best, directcolor, grayscale, greyscale, pseudocolor, staticcolor, staticgray, staticgrey, truecolor, or default}}
-if [info exists env(DISPLAY)] {
-    test frame-2.8 {toplevel configuration options} {
-	catch {destroy .t}
-	toplevel .t -width 200 -height 100 -screen $env(DISPLAY)
-	wm geometry .t +0+0
-	list [.t configure -screen] \
-		[catch {.t configure -screen another} msg] $msg
-    } [list [list -screen screen Screen {} $env(DISPLAY)] 1 {can't modify -screen option after widget is created}]
-}
+test frame-2.8 {toplevel configuration options} haveDISPLAY {
+    catch {destroy .t}
+    toplevel .t -width 200 -height 100 -screen $env(DISPLAY)
+    wm geometry .t +0+0
+    list [.t configure -screen] \
+	    [catch {.t configure -screen another} msg] $msg
+} [list [list -screen screen Screen {} $env(DISPLAY)] 1 {can't modify -screen option after widget is created}]
 test frame-2.9 {toplevel configuration options} {
     catch {destroy .t}
     list [catch {toplevel .t -width 200 -height 100 -screen bogus} msg] $msg
@@ -234,38 +239,40 @@ foreach test {
     {-relief ridge ridge badValue {bad relief "badValue": must be flat, groove, raised, ridge, solid, or sunken}}
     {-width 32 32 badValue {bad screen distance "badValue"}}
 } {
-    set name [lindex $test 0]
+    lassign $test opt goodValue goodResult badValue badResult
     test frame-2.$i {toplevel configuration options} {
-	.t configure $name [lindex $test 1]
-	lindex [.t configure $name] 4
-    } [lindex $test 2]
+	.t configure $opt $goodValue
+	lindex [.t configure $opt] 4
+    } $goodResult
     incr i
-    if {[lindex $test 3] != ""} {
-	test frame-2.$i {toplevel configuration options} {
-	    list [catch {.t configure $name [lindex $test 3]} msg] $msg
-	} [list 1 [lindex $test 4]]
+    if {$badValue ne ""} {
+	test frame-2.$i {toplevel configuration options} -body {
+	    .t configure $opt $badValue
+	} -returnCodes error -result $badResult
     }
-    .t configure $name [lindex [.t configure $name] 3]
+    .t configure $opt [lindex [.t configure $opt] 3]
     incr i
 }
 
-test frame-3.1 {TkCreateFrame procedure} {
-    list [catch frame msg] $msg
-} {1 {wrong # args: should be "frame pathName ?options?"}}
-test frame-3.2 {TkCreateFrame procedure} {
+test frame-3.1 {TkCreateFrame procedure} -body {
+    frame
+} -returnCodes error -result {wrong # args: should be "frame pathName ?options?"}
+test frame-3.2 {TkCreateFrame procedure} -setup {
     catch {destroy .f}
     frame .f
-    set result [.f configure -class]
+} -body {
+    .f configure -class
+} -cleanup {
     destroy .f
-    set result
-} {-class class Class Frame Frame}
-test frame-3.3 {TkCreateFrame procedure} {
+} -result {-class class Class Frame Frame}
+test frame-3.3 {TkCreateFrame procedure} -setup {
     catch {destroy .t}
     toplevel .t
     wm geometry .t +0+0
-    set result [.t configure -class]
+} -body {
+    .t configure -class
+} -cleanup {
     destroy .t
-    set result
 } {-class class Class Toplevel Toplevel}
 test frame-3.4 {TkCreateFrame procedure} {
     catch {destroy .t}
@@ -310,141 +317,147 @@ test frame-3.8 {TkCreateFrame procedure} {
     option clear
     list [lindex [.f configure -class] 4] [lindex [.f configure -background] 4]
 } {Silly #122334}
-test frame-3.9 {TkCreateFrame procedure, -use option} unixOnly {
+test frame-3.9 {TkCreateFrame procedure, -use option} -setup {
     catch {destroy .t}
     catch {destroy .x}
+} -constraints unixOnly -body {
     toplevel .t -container 1 -width 300 -height 120
     wm geometry .t +0+0
     toplevel .x -width 140 -height 300 -use [winfo id .t] -bg green
     tkwait visibility .x
-    set result "[expr [winfo rootx .x] - [winfo rootx .t]] [expr [winfo rooty .x] - [winfo rooty .t]] [winfo width .t] [winfo height .t]"
+    list [expr {[winfo rootx .x] - [winfo rootx .t]}] \
+	    [expr {[winfo rooty .x] - [winfo rooty .t]}] \
+	    [winfo width .t] [winfo height .t]
+} -cleanup {
     destroy .t
-    set result
-} {0 0 140 300}
-test frame-3.10 {TkCreateFrame procedure, -use option} unixOnly {
+} -result {0 0 140 300}
+test frame-3.10 {TkCreateFrame procedure, -use option} -setup {
     catch {destroy .t}
     catch {destroy .x}
+} -constraints unixOnly -body {
     toplevel .t -container 1 -width 300 -height 120
     wm geometry .t +0+0
     option add *x.use [winfo id .t]
     toplevel .x -width 140 -height 300 -bg green
     tkwait visibility .x
-    set result "[expr [winfo rootx .x] - [winfo rootx .t]] [expr [winfo rooty .x] - [winfo rooty .t]] [winfo width .t] [winfo height .t]"
-     destroy .t
+    list [expr {[winfo rootx .x] - [winfo rootx .t]}] \
+	    [expr {[winfo rooty .x] - [winfo rooty .t]}] \
+	    [winfo width .t] [winfo height .t]
+} -cleanup {
+    destroy .t
     option clear
-    set result
-} {0 0 140 300}
+} -result {0 0 140 300}
 
 # The tests below require specific display characteristics.  Even so,
 # they are non-portable:  some machines don't seem to ever run out of
 # colors.
 
-if {([winfo visual .] == "pseudocolor") && ([winfo depth .] == 8)} {
+if {[testConstraint edibleColors]} {
     eatColors .t1
-    test frame-3.11 {TkCreateFrame procedure} {nonPortable} {
-	catch {destroy .t}
-	toplevel .t -width 300 -height 200 -bg #475601
-	wm geometry .t +0+0
-	update
-	colorsFree .t
-    } {0}
-    test frame-3.12 {TkCreateFrame procedure} {nonPortable} {
-	catch {destroy .t}
-	toplevel .t -width 300 -height 200 -bg #475601 -colormap new
-	wm geometry .t +0+0
-	update
-	colorsFree .t
-    } {1}
-    test frame-3.13 {TkCreateFrame procedure} {nonPortable} {
-	catch {destroy .t}
-	option add *t.class Toplevel2
-	option add *Toplevel2.colormap new
-	toplevel .t -width 300 -height 200 -bg #475601
-	wm geometry .t +0+0
-	update
-	option clear
-	colorsFree .t
-    } {1}
-    test frame-3.14 {TkCreateFrame procedure} {nonPortable} {
-	catch {destroy .t}
-	option add *t.class Toplevel3
-	option add *Toplevel3.Colormap new
-	toplevel .t -width 300 -height 200 -bg #475601 -colormap new
-	wm geometry .t +0+0
-	update
-	option clear
-	colorsFree .t
-    } {1}
-    test frame-3.15 {TkCreateFrame procedure, -use and -colormap} {unixOnly nonPortable} {
-	catch {destroy .t}
-	catch {destroy .x}
-	toplevel .t -container 1 -width 300 -height 120
-	wm geometry .t +0+0
-	toplevel .x -width 140 -height 300 -use [winfo id .t] -bg green -colormap new
-	tkwait visibility .x
-	set result "[colorsFree .t] [colorsFree .x]"
-	destroy .t
-	set result
-    } {0 1}
-    test frame-3.16 {TkCreateFrame procedure} {nonPortable} {
-	catch {destroy .t}
-	toplevel .t -width 300 -height 200 -bg #475601 -visual default
-	wm geometry .t +0+0
-	update
-	colorsFree .t
-    } {0}
-    test frame-3.17 {TkCreateFrame procedure} {nonPortable} {
-	catch {destroy .t}
-	toplevel .t -width 300 -height 200 -bg #475601 -visual default \
-		-colormap new
-	wm geometry .t +0+0
-	update
-	colorsFree .t
-    } {1}
-    if {[lsearch -exact [winfo visualsavailable .] {grayscale 8}] >= 0} {
-        test frame-3.18 {TkCreateFrame procedure} {nonPortable} {
-	    catch {destroy .t}
-	    toplevel .t -visual {grayscale 8} -width 300 -height 200 \
-		    -bg #434343 
-	    wm geometry .t +0+0
-	    update
-	    colorsFree .t 131 131 131
-	} {1}
-        test frame-3.19 {TkCreateFrame procedure} {nonPortable} {
-	    catch {destroy .t}
-	    option add *t.class T4
-	    option add *T4.visual {grayscale 8}
-	    toplevel .t -width 300 -height 200 -bg #434343
-	    wm geometry .t +0+0
-	    update
-	    option clear
-	    list [colorsFree .t 131 131 131] [lindex [.t configure -visual] 4]
-	} {1 {grayscale 8}}
-        test frame-3.20 {TkCreateFrame procedure} {nonPortable} {
-	    catch {destroy .t}
-	    set x ok
-	    option add *t.class T5
-	    option add *T5.Visual {grayscale 8}
-	    toplevel .t -width 300 -height 200 -bg #434343
-	    wm geometry .t +0+0
-	    update
-	    option clear
-	    list [colorsFree .t 131 131 131] [lindex [.t configure -visual] 4]
-	} {1 {grayscale 8}}
-        test frame-3.21 {TkCreateFrame procedure} {nonPortable} {
-	    catch {destroy .t}
-	    set x ok
-	    toplevel .t -visual {grayscale 8} -width 300 -height 200 \
-		    -bg #434343 
-	    wm geometry .t +0+0
-	    update
-	    colorsFree .t 131 131 131
-	} {1}
-    }
+}
+test frame-3.11 {TkCreateFrame procedure} {edibleColors nonPortable} {
+    catch {destroy .t}
+    toplevel .t -width 300 -height 200 -bg #475601
+    wm geometry .t +0+0
+    update
+    colorsFree .t
+} {0}
+test frame-3.12 {TkCreateFrame procedure} {edibleColors nonPortable} {
+    catch {destroy .t}
+    toplevel .t -width 300 -height 200 -bg #475601 -colormap new
+    wm geometry .t +0+0
+    update
+    colorsFree .t
+} {1}
+test frame-3.13 {TkCreateFrame procedure} {edibleColors nonPortable} {
+    catch {destroy .t}
+    option add *t.class Toplevel2
+    option add *Toplevel2.colormap new
+    toplevel .t -width 300 -height 200 -bg #475601
+    wm geometry .t +0+0
+    update
+    option clear
+    colorsFree .t
+} {1}
+test frame-3.14 {TkCreateFrame procedure} {edibleColors nonPortable} {
+    catch {destroy .t}
+    option add *t.class Toplevel3
+    option add *Toplevel3.Colormap new
+    toplevel .t -width 300 -height 200 -bg #475601 -colormap new
+    wm geometry .t +0+0
+    update
+    option clear
+    colorsFree .t
+} {1}
+test frame-3.15 {TkCreateFrame procedure, -use and -colormap} -setup {
+    catch {destroy .t}
+    catch {destroy .x}
+} -constraints {edibleColors unixOnly nonPortable} -body {
+    toplevel .t -container 1 -width 300 -height 120
+    wm geometry .t +0+0
+    toplevel .x -width 140 -height 300 -use [winfo id .t] -bg green -colormap new
+    tkwait visibility .x
+    list [colorsFree .t] [colorsFree .x]
+} -cleanup {
+    destroy .t
+} -result {0 1}
+test frame-3.16 {TkCreateFrame procedure} {edibleColors nonPortable} {
+    catch {destroy .t}
+    toplevel .t -width 300 -height 200 -bg #475601 -visual default
+    wm geometry .t +0+0
+    update
+    colorsFree .t
+} {0}
+test frame-3.17 {TkCreateFrame procedure} {edibleColors nonPortable} {
+    catch {destroy .t}
+    toplevel .t -width 300 -height 200 -bg #475601 -visual default \
+	    -colormap new
+    wm geometry .t +0+0
+    update
+    colorsFree .t
+} {1}
+test frame-3.18 {TkCreateFrame procedure} {edibleColors haveGrayscale8 nonPortable} {
+    catch {destroy .t}
+    toplevel .t -visual {grayscale 8} -width 300 -height 200 -bg #434343 
+    wm geometry .t +0+0
+    update
+    colorsFree .t 131 131 131
+} {1}
+test frame-3.19 {TkCreateFrame procedure} {edibleColors haveGrayscale8 nonPortable} {
+    catch {destroy .t}
+    option add *t.class T4
+    option add *T4.visual {grayscale 8}
+    toplevel .t -width 300 -height 200 -bg #434343
+    wm geometry .t +0+0
+    update
+    option clear
+    list [colorsFree .t 131 131 131] [lindex [.t configure -visual] 4]
+} {1 {grayscale 8}}
+test frame-3.20 {TkCreateFrame procedure} {edibleColors haveGrayscale8 nonPortable} {
+    catch {destroy .t}
+    set x ok
+    option add *t.class T5
+    option add *T5.Visual {grayscale 8}
+    toplevel .t -width 300 -height 200 -bg #434343
+    wm geometry .t +0+0
+    update
+    option clear
+    list [colorsFree .t 131 131 131] [lindex [.t configure -visual] 4]
+} {1 {grayscale 8}}
+test frame-3.21 {TkCreateFrame procedure} {edibleColors haveGrayscale8 nonPortable} {
+    catch {destroy .t}
+    set x ok
+    toplevel .t -visual {grayscale 8} -width 300 -height 200 -bg #434343 
+    wm geometry .t +0+0
+    update
+    colorsFree .t 131 131 131
+} {1}
+if {[testConstraint edibleColors]} {
     destroy .t1
 }
-test frame-3.22 {TkCreateFrame procedure, default dimensions} {
+test frame-3.22 {TkCreateFrame procedure, default dimensions} -setup {
     catch {destroy .t}
+} -body {
     toplevel .t
     wm geometry .t +0+0
     update
@@ -453,20 +466,20 @@ test frame-3.22 {TkCreateFrame procedure, default dimensions} {
     pack .t.f
     update
     lappend result [winfo reqwidth .t.f] [winfo reqheight .t.f]
+} -cleanup {
     destroy .t
-    set result
-} {200 200 1 1}
-test frame-3.23 {TkCreateFrame procedure} {
+} -result {200 200 1 1}
+test frame-3.23 {TkCreateFrame procedure} -setup {
     catch {destroy .f}
-    list [catch {frame .f -gorp glob} msg] $msg
-} {1 {unknown option "-gorp"}}
-test frame-3.24 {TkCreateFrame procedure} {
+} -body {
+    frame .f -gorp glob
+} -returnCodes error -result {unknown option "-gorp"}
+test frame-3.24 {TkCreateFrame procedure} -setup {
     catch {destroy .t}
-    list [catch {
-	toplevel .t -width 300 -height 200 -colormap new -bogus option
-	wm geometry .t +0+0
-    } msg] $msg
-} {1 {unknown option "-bogus"}}
+} -body {
+    toplevel .t -width 300 -height 200 -colormap new -bogus option
+    wm geometry .t +0+0
+} -returnCodes error -result {unknown option "-bogus"}
 
 test frame-4.1 {TkCreateFrame procedure} {
     catch {destroy .f}
@@ -776,16 +789,16 @@ foreach test {
     {-text "any string" "any string" {} {}}
     {-width 32 32 badValue {bad screen distance "badValue"}}
 } {
-    set name [lindex $test 0]
+    lassign $test name goodValue goodResult badValue badResult
     test frame-13.$i {labelframe configuration options} {
-	.f configure $name [lindex $test 1]
+	.f configure $name $goodValue
 	lindex [.f configure $name] 4
-    } [lindex $test 2]
+    } $goodResult
     incr i
-    if {[lindex $test 3] != ""} {
-	test frame-13.$i {labelframe configuration options} {
-	    list [catch {.f configure $name [lindex $test 3]} msg] $msg
-	} [list 1 [lindex $test 4]]
+    if {$badValue ne ""} {
+	test frame-13.$i {labelframe configuration options} -body {
+	    .f configure $name $badValue
+	} -returnCodes error -result $badResult
     }
     .f configure $name [lindex [.f configure $name] 3]
     incr i