diff options
Diffstat (limited to 'tests/winFont.test')
| -rw-r--r-- | tests/winFont.test | 456 |
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: + |