Update to tcltest2

1 files changed, 332 insertions, 124 deletions

diff --git a/tests/winFont.test b/tests/winFont.test
index 82d0c36..4491de0 100644
--- a/tests/winFont.test
+++ b/tests/winFont.test
@@ -1,50 +1,30 @@
-# This file is a Tcl script to test out the procedures in tkWinFont.c. 
+# This file is a Tcl script to test out the procedures in tkWinFont.c.
 # It is organized in the standard fashion for Tcl tests.
 #
 # Many of these tests are visually oriented and cannot be checked
 # programmatically (such as "does an underlined font appear to be
 # underlined?"); these tests attempt to exercise the code in question,
-# but there are no results that can be checked.  
+# but there are no results that can be checked. 
 #
 # Copyright (c) 1996-1997 Sun Microsystems, Inc.
 # Copyright (c) 1998-1999 by Scriptics Corporation.
 # All rights reserved.
 #
-# RCS: @(#) $Id: winFont.test,v 1.11 2004/12/04 00:04:43 dkf Exp $
+# RCS: @(#) $Id: winFont.test,v 1.12 2008/08/30 21:52:26 aniap Exp $
 
-package require tcltest 2.1
-eval tcltest::configure $argv
+package require tcltest 2.2
+namespace import ::tcltest::*
+tcltest::configure {*}$argv
 tcltest::loadTestedCommands
 
-catch {destroy .b}
-catch {font delete xyz}
 
-toplevel .b
-wm geometry .b +0+0
-update idletasks
-
-set courier {Courier 14}
-set cx [font measure $courier 0]
-
-label .b.l -padx 0 -pady 0 -bd 0 -highlightthickness 0 -justify left -text "0" -font systemfixed
-pack .b.l
-canvas .b.c -closeenough 0
-
-set t [.b.c create text 0 0 -anchor nw -just left -font $courier]
-pack .b.c
-update
-
-set ax [winfo reqwidth .b.l]
-set ay [winfo reqheight .b.l]
-proc getsize {} {
-    update
-    return "[winfo reqwidth .b.l] [winfo reqheight .b.l]"
-}
-
-test winfont-1.1 {TkpGetNativeFont procedure: not native} win {
-    list [catch {font measure {} xyz} msg] $msg
-} {1 {font "" doesn't exist}}
-test winfont-1.2 {TkpGetNativeFont procedure: native} win {
+test winfont-1.1 {TkpGetNativeFont procedure: not native} -constraints {
+    win
+} -body {
+    catch {font delete xyz}
+    font measure {} xyz
+} -returnCodes error -result {font "" doesn't exist}
+test winfont-1.2 {TkpGetNativeFont procedure: native} -constraints win -body {
     font measure ansifixed 0
     font measure ansi 0
     font measure device 0
@@ -52,135 +32,363 @@ test winfont-1.2 {TkpGetNativeFont procedure: native} win {
     font measure systemfixed 0
     font measure system 0
     set x {}
-} {}
-
-test winfont-2.1 {TkpGetFontFromAttributes procedure: pointsize} win {
-    expr [font actual {-size -10} -size]>0
-} {1}
-test winfont-2.2 {TkpGetFontFromAttributes procedure: pointsize} win {
-    expr [font actual {-family Arial} -size]>0
-} {1}
-test winfont-2.3 {TkpGetFontFromAttributes procedure: normal weight} win {
+} -result {}
+
+
+test winfont-2.1 {TkpGetFontFromAttributes procedure: pointsize} -constraints {
+    win
+} -body {
+    expr {[font actual {-size -10} -size] > 0}
+} -result {1}
+test winfont-2.2 {TkpGetFontFromAttributes procedure: pointsize} -constraints {
+    win
+} -body {
+    expr {[font actual {-family Arial} -size] > 0}
+} -result {1}
+test winfont-2.3 {TkpGetFontFromAttributes procedure: normal weight} -constraints {
+    win
+} -body {
     font actual {-weight normal} -weight
-} {normal}
-test winfont-2.4 {TkpGetFontFromAttributes procedure: bold weight} win {
+} -result {normal}
+test winfont-2.4 {TkpGetFontFromAttributes procedure: bold weight} -constraints {
+    win
+} -body {
     font actual {-weight bold} -weight
-} {bold}
-test winfont-2.5 {TkpGetFontFromAttributes procedure: no family} win {
+} -result {bold}
+test winfont-2.5 {TkpGetFontFromAttributes procedure: no family} -constraints {
+    win
+} -body {
     catch {expr {[font actual {-size 10} -size]}}
-} 0
-test winfont-2.6 {TkpGetFontFromAttributes procedure: family} win {
+} -result 0
+test winfont-2.6 {TkpGetFontFromAttributes procedure: family} -constraints {
+    win
+} -body {
     font actual {-family Arial} -family
-} {Arial}
-test winfont-2.7 {TkpGetFontFromAttributes procedure: Times fonts} win {
+} -result {Arial}
+test winfont-2.7 {TkpGetFontFromAttributes procedure: Times fonts} -constraints {
+    win
+} -setup {
     set x {}
+} -body {
     lappend x [font actual {-family "Times"} -family]
     lappend x [font actual {-family "New York"} -family]
     lappend x [font actual {-family "Times New Roman"} -family]
-} {{Times New Roman} {Times New Roman} {Times New Roman}}
-test winfont-2.8 {TkpGetFontFromAttributes procedure: Courier fonts} win {
+} -result {{Times New Roman} {Times New Roman} {Times New Roman}}
+test winfont-2.8 {TkpGetFontFromAttributes procedure: Courier fonts} -constraints {
+    win
+} -setup {
     set x {}
+} -body {
     lappend x [font actual {-family "Courier"} -family]
     lappend x [font actual {-family "Monaco"} -family]
     lappend x [font actual {-family "Courier New"} -family]
-} {{Courier New} {Courier New} {Courier New}}
-test winfont-2.9 {TkpGetFontFromAttributes procedure: Helvetica fonts} win {
+} -result {{Courier New} {Courier New} {Courier New}}
+test winfont-2.9 {TkpGetFontFromAttributes procedure: Helvetica fonts} -constraints {
+    win
+} -setup {
     set x {}
+} -body {
     lappend x [font actual {-family "Helvetica"} -family]
     lappend x [font actual {-family "Geneva"} -family]
     lappend x [font actual {-family "Arial"} -family]
-} {Arial Arial Arial}
-test winfont-2.10 {TkpGetFontFromAttributes procedure: fallback} win {
+} -result {Arial Arial Arial}
+test winfont-2.10 {TkpGetFontFromAttributes procedure: fallback} -constraints {
+    win
+} -body {
     # No way to get it to fail! Any font name is acceptable.
-} {}
+} -result {}
 
-test winfont-3.1 {TkpDeleteFont procedure} win {
+
+test winfont-3.1 {TkpDeleteFont procedure} -constraints win -body {
+    catch {font delete xyz}
     font actual {-family xyz}
     set x {}
-} {}
+} -result {}
+
 
-test winfont-4.1 {TkpGetFontFamilies procedure} win {
+test winfont-4.1 {TkpGetFontFamilies procedure} -constraints win -body {
     font families
     set x {}
-} {}
-
-test winfont-5.1 {Tk_MeasureChars procedure: unbounded right margin} win {
-    .b.l config -wrap 0 -text "000000"
-    getsize
-} "[expr $ax*6] $ay"
-test winfont-5.2 {Tk_MeasureChars procedure: static width buffer exceeded} win {
-    .b.l config -wrap 100000 -text "0000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000"
-    getsize
-} "[expr $ax*256] $ay"
-test winfont-5.3 {Tk_MeasureChars procedure: all chars did fit} win {
-    .b.l config -wrap [expr $ax*10] -text "00000000"
-    getsize
-} "[expr $ax*8] $ay"
-test winfont-5.4 {Tk_MeasureChars procedure: not all chars fit} win {
-    .b.l config -wrap [expr $ax*6] -text "00000000"
-    getsize
-} "[expr $ax*6] [expr $ay*2]"
-test winfont-5.5 {Tk_MeasureChars procedure: include last partial char} win {
-    .b.c dchars $t 0 end
-    .b.c insert $t 0 "0000"
-    .b.c index $t @[expr int($cx*2.5)],1
-} {2}
-test winfont-5.6 {Tk_MeasureChars procedure: at least one char on line} win {
-    .b.l config -text "000000" -wrap 1
-    getsize
-} "$ax [expr $ay*6]"
-test winfont-5.7 {Tk_MeasureChars procedure: whole words} win {
-    .b.l config -wrap [expr $ax*8] -text "000000 0000"
-    getsize
-} "[expr $ax*6] [expr $ay*2]"
-test winfont-5.8 {Tk_MeasureChars procedure: already saw space in line} win {
-    .b.l config -wrap [expr $ax*12] -text "000000    0000000"
-    getsize
-} "[expr $ax*7] [expr $ay*2]"
-test winfont-5.9 {Tk_MeasureChars procedure: internal spaces significant} win {
-    .b.l config -wrap [expr $ax*12] -text "000  00   00000"
-    getsize
-} "[expr $ax*7] [expr $ay*2]"
-test winfont-5.10 {Tk_MeasureChars procedure: make first part of word fit} win {
-    .b.l config -wrap [expr $ax*12] -text "0000000000000000"
-    getsize
-} "[expr $ax*12] [expr $ay*2]"
-test winfont-5.11 {Tk_MeasureChars procedure: check for kerning} \
-	{win nonPortable} {
-    set font [.b.l cget -font]
-    .b.l config -font {{MS Sans Serif} 8} -text "W"
-    set width [winfo reqwidth .b.l]
-    .b.l config -text "XaYoYaKaWx"
+} -result {}
+
+destroy .t
+toplevel .t
+wm geometry .t +0+0
+update idletasks
+label .t.l -padx 0 -pady 0 -bd 0 -highlightthickness 0 -justify left -text "0" -font systemfixed
+pack .t.l
+canvas .t.c -closeenough 0
+
+set courier {Courier 14}
+set cx [font measure $courier 0]
+set t [.t.c create text 0 0 -anchor nw -just left -font $courier]
+pack .t.c
+update
+
+set ax [winfo reqwidth .t.l]
+set ay [winfo reqheight .t.l]
+proc getsize {} {
+    update
+    return "[winfo reqwidth .t.l] [winfo reqheight .t.l]"
+}
+
+test winfont-5.1 {Tk_MeasureChars procedure: unbounded right margin} -constraints {
+    win
+} -setup {
+    destroy .t.l
+} -body {
+    label .t.l -padx 0 -pady 0 -bd 0 -highlightthickness 0 -justify left \
+        -text "0" -font systemfixed
+    pack .t.l
+    update
+    set ax [winfo reqwidth .t.l]
+    set ay [winfo reqheight .t.l]
+   
+    .t.l config -wrap 0 -text "000000"
+    list [expr {[winfo reqwidth .t.l] eq 6*$ax}] \
+        [expr {[winfo reqheight .t.l] eq $ay}]
+} -cleanup {
+    destroy .t.l
+} -result {1 1}
+
+test winfont-5.2 {Tk_MeasureChars procedure: static width buffer exceeded} -constraints {
+    win
+} -setup {
+    destroy .t.l
+}  -body {
+    label .t.l -padx 0 -pady 0 -bd 0 -highlightthickness 0 -justify left \
+        -text "0" -font systemfixed
+    pack .t.l
+    update
+    set ax [winfo reqwidth .t.l]
+    set ay [winfo reqheight .t.l]
+   
+    .t.l config -wrap 100000 -text "0000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000"
+    list [expr {[winfo reqwidth .t.l] eq 256*$ax}] \
+        [expr {[winfo reqheight .t.l] eq $ay}]
+} -cleanup {
+    destroy .t.l
+} -result {1 1}
+
+test winfont-5.3 {Tk_MeasureChars procedure: all chars did fit} -constraints {
+    win
+} -setup {
+    destroy .t.l
+}  -body {
+    label .t.l -padx 0 -pady 0 -bd 0 -highlightthickness 0 -justify left \
+        -text "0" -font systemfixed
+    pack .t.l
+    update
+    set ax [winfo reqwidth .t.l]
+    set ay [winfo reqheight .t.l]
+   
+    .t.l config -wrap [expr $ax*10] -text "00000000"
+    list [expr {[winfo reqwidth .t.l] eq 8*$ax}] \
+        [expr {[winfo reqheight .t.l] eq $ay}]
+} -cleanup {
+    destroy .t.l
+} -result {1 1}
+
+test winfont-5.4 {Tk_MeasureChars procedure: not all chars fit} -constraints {
+    win
+} -setup {
+    destroy .t.l
+}  -body {
+    label .t.l -padx 0 -pady 0 -bd 0 -highlightthickness 0 -justify left \
+        -text "0" -font systemfixed
+    pack .t.l
+    update
+    set ax [winfo reqwidth .t.l]
+    set ay [winfo reqheight .t.l]
+   
+    .t.l config -wrap [expr $ax*6] -text "00000000"
+    list [expr {[winfo reqwidth .t.l] eq 6*$ax}] \
+        [expr {[winfo reqheight .t.l] eq 2*$ay}]
+} -cleanup {
+    destroy .t.l
+} -result {1 1}
+
+test winfont-5.5 {Tk_MeasureChars procedure: include last partial char} -constraints {
+    win
+} -setup {
+    destroy .t.c
+}  -body {
+    canvas .t.c -closeenough 0
+    set t [.t.c create text 0 0 -anchor nw -just left -font $courier]
+    pack .t.c
+    update
+
+    .t.c dchars $t 0 end
+    .t.c insert $t 0 "0000"
+    .t.c index $t @[expr int($cx*2.5)],1
+} -cleanup {
+    destroy .t.c
+} -result {2}
+
+test winfont-5.6 {Tk_MeasureChars procedure: at least one char on line} -constraints {
+    win
+} -setup {
+    destroy .t.l
+}  -body {
+    label .t.l -padx 0 -pady 0 -bd 0 -highlightthickness 0 -justify left \
+        -text "0" -font systemfixed
+    pack .t.l
+    update
+    set ax [winfo reqwidth .t.l]
+    set ay [winfo reqheight .t.l]
+   
+    .t.l config -text "000000" -wrap 1
+    list [expr {[winfo reqwidth .t.l] eq $ax}] \
+        [expr {[winfo reqheight .t.l] eq 6*$ay}]
+} -cleanup {
+    destroy .t.l
+} -result {1 1}
+
+test winfont-5.7 {Tk_MeasureChars procedure: whole words} -constraints {
+    win
+} -setup {
+    destroy .t.l
+}  -body {
+    label .t.l -padx 0 -pady 0 -bd 0 -highlightthickness 0 -justify left \
+        -text "0" -font systemfixed
+    pack .t.l
+    update
+    set ax [winfo reqwidth .t.l]
+    set ay [winfo reqheight .t.l]
+   
+    .t.l config -wrap [expr $ax*8] -text "000000 0000"
+    list [expr {[winfo reqwidth .t.l] eq 6*$ax}] \
+        [expr {[winfo reqheight .t.l] eq 2*$ay}]
+} -cleanup {
+    destroy .t.l
+} -result {1 1}
+
+test winfont-5.8 {Tk_MeasureChars procedure: already saw space in line} -constraints {
+    win
+} -setup {
+    destroy .t.l
+}  -body {
+    label .t.l -padx 0 -pady 0 -bd 0 -highlightthickness 0 -justify left \
+        -text "0" -font systemfixed
+    pack .t.l
+    update
+    set ax [winfo reqwidth .t.l]
+    set ay [winfo reqheight .t.l]
+   
+    .t.l config -wrap [expr $ax*12] -text "000000    0000000"
+    list [expr {[winfo reqwidth .t.l] eq 7*$ax}] \
+        [expr {[winfo reqheight .t.l] eq 2*$ay}]
+} -cleanup {
+    destroy .t.l
+} -result {1 1}
+
+test winfont-5.9 {Tk_MeasureChars procedure: internal spaces significant} -constraints {
+    win
+} -setup {
+    destroy .t.l
+}  -body {
+    label .t.l -padx 0 -pady 0 -bd 0 -highlightthickness 0 -justify left \
+        -text "0" -font systemfixed
+    pack .t.l
+    update
+    set ax [winfo reqwidth .t.l]
+    set ay [winfo reqheight .t.l]
+   
+    .t.l config -wrap [expr $ax*12] -text "000  00   00000"
+    list [expr {[winfo reqwidth .t.l] eq 7*$ax}] \
+        [expr {[winfo reqheight .t.l] eq 2*$ay}]
+} -cleanup {
+    destroy .t.l
+} -result {1 1}
+
+test winfont-5.10 {Tk_MeasureChars procedure: make first part of word fit} -constraints {
+    win
+} -setup {
+    destroy .t.l
+}  -body {
+    label .t.l -padx 0 -pady 0 -bd 0 -highlightthickness 0 -justify left \
+        -text "0" -font systemfixed
+    pack .t.l
+    update
+    set ax [winfo reqwidth .t.l]
+    set ay [winfo reqheight .t.l]
+   
+    .t.l config -wrap [expr $ax*12] -text "0000000000000000"
+    list [expr {[winfo reqwidth .t.l] eq 12*$ax}] \
+        [expr {[winfo reqheight .t.l] eq 2*$ay}]
+} -cleanup {
+    destroy .t.l
+} -result {1 1}
+
+test winfont-5.11 {Tk_MeasureChars procedure: check for kerning} -constraints {
+    win nonPortable
+} -setup {
+    destroy .t.l
+}  -body {
+    label .t.l -padx 0 -pady 0 -bd 0 -highlightthickness 0 -justify left \
+        -text "0" -font systemfixed
+    pack .t.l
+    update
+   
+    set font [.t.l cget -font]
+    .t.l config -font {{MS Sans Serif} 8} -text "W"
+    set width [winfo reqwidth .t.l]
+    .t.l config -text "XaYoYaKaWx"
     set x [lindex [getsize] 0]
-    .b.l config -font $font
+    .t.l config -font $font
     expr $x < ($width*10)
-} 1
+} -cleanup {
+    destroy .t.l
+} -result {1}
 
-test winfont-6.1 {Tk_DrawChars procedure: loop test} win {
-    .b.l config -text "a"
+
+test winfont-6.1 {Tk_DrawChars procedure: loop test} -constraints win -setup {
+    destroy .t.l
+}  -body {
+    label .t.l -padx 0 -pady 0 -bd 0 -highlightthickness 0 -justify left \
+        -text "0" -font systemfixed
+    pack .t.l
+    update
+    .t.l config -text "a"
     update
-} {}
+} -cleanup {
+    destroy .t.l
+} -result {}
+
 
-test winfont-7.1 {AllocFont procedure: use old font} win {
+test winfont-7.1 {AllocFont procedure: use old font} -constraints win -setup {
+    destroy .c
+} -setup {
+    catch {font delete xyz}
+} -body {
     font create xyz
-    catch {destroy .c}
     button .c -font xyz
     font configure xyz -family times
     update
     destroy .c
     font delete xyz
-} {}
-test winfont-7.2 {AllocFont procedure: extract info from logfont} win {
+} -result {}
+test winfont-7.2 {AllocFont procedure: extract info from logfont} -constraints {
+    win
+} -body {
     font actual {arial 10 bold italic underline overstrike}
-} {-family Arial -size 10 -weight bold -slant italic -underline 1 -overstrike 1}
-test winfont-7.3 {AllocFont procedure: extract info from textmetric} win {
+} -result {-family Arial -size 10 -weight bold -slant italic -underline 1 -overstrike 1}
+test winfont-7.3 {AllocFont procedure: extract info from textmetric} -constraints {
+    win
+} -body {
     font metric {arial 10 bold italic underline overstrike} -fixed
-} {0}
-test winfont-7.4 {AllocFont procedure: extract info from textmetric} win {
+} -result {0}
+test winfont-7.4 {AllocFont procedure: extract info from textmetric} -constraints {
+    win
+} -body {
     font metric systemfixed -fixed
-} {1}
+} -result {1}
 
 # cleanup
-destroy .b
 cleanupTests
 return
+
+# Local variables:
+# mode: tcl
+# End:
+