Permalink
Switch branches/tags
tip_443 tip-443 tclpro_1_5_0 tclpro_1_4_1 tclpro_1_4_0 tclpro-1-5-0 tclpro-1-4-1 tclpro-1-4-0 scriptics_tclpro_1_3_0 scriptics_tclpro_1_3_b4 scriptics_tclpro_1_3_b3 scriptics_tclpro_1_3_b2 scriptics_tclpro_1_3_b1 scriptics_tclpro_1_2 scriptics_tclpro_1_2_b2 scriptics_tclpro_1_2_b1 scriptics_tclpro_1_2_a1 scriptics_sc_2_0_fixed scriptics_sc_2_0_b5 scriptics_sc_2_0_b2 scriptics_sc_2_0_b1 scriptics_sc_1_1 scriptics_sc_1_1_base scriptics_sc_1_1_b1 scriptics_sc_1_0 scriptics_sc_1_0_base scriptics_bc_1_0_b1 scriptics-tclpro-1-3-b4 scriptics-tclpro-1-3-b3 scriptics-tclpro-1-3-b2 scriptics-tclpro-1-3-b1 scriptics-tclpro-1-3-0 scriptics-tclpro-1-2 scriptics-tclpro-1-2-b2 scriptics-tclpro-1-2-b1 scriptics-tclpro-1-2-a1 scriptics-sc-2-0-fixed scriptics-sc-2-0-b5 scriptics-sc-2-0-b2 scriptics-sc-2-0-b1 scriptics-sc-1-1 scriptics-sc-1-1-base scriptics-sc-1-1-b1 scriptics-sc-1-0 scriptics-sc-1-0-base scriptics-bc-1-0-b1 release rc4 rc3 rc2 rc1 rc0 mistake minor_change macosx_8_4_premerge_2002_08_31_trunk macosx_8_4_premerge_2002_08_31_branch macosx_8_4_merge_2002_08_31_trunk macosx_8_4_merge_2002_08_30_trunk macosx_8_4_merge_2002_08_30_branch macosx_8_4_merge_2002_08_20_trunk macosx_8_4_merge_2002_08_20_branch macosx_8_4_branchpoint macosx_premerge_6_9_02 macosx_cocoa_premerge macosx_cocoa_merge macosx_carbon_freeze macosx-premerge-6-9-02 macosx-cocoa-premerge macosx-cocoa-merge macosx-carbon-freeze macosx-8-4-premerge-2002-08-31-trunk macosx-8-4-premerge-2002-08-31-branch macosx-8-4-merge-2002-08-31-trunk macosx-8-4-merge-2002-08-30-trunk macosx-8-4-merge-2002-08-30-branch macosx-8-4-merge-2002-08-20-trunk macosx-8-4-merge-2002-08-20-branch macosx-8-4-branchpoint d6b95ce492 core_8_7_a1 core_8_6_7 core_8_6_6 core_8_6_5 core_8_6_4 core_8_6_3 core_8_6_2 core_8_6_1 core_8_6_0 core_8_6_b3 core_8_6_b2 core_8_6_b1 core_8_6_a3 core_8_6_a2 core_8_6_a1 core_8_5_19 core_8_5_18 core_8_5_17 core_8_5_16 core_8_5_15 core_8_5_14
Nothing to show
Find file
Fetching contributors…
Cannot retrieve contributors at this time
393 lines (351 sloc) 11 KB
# 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.
#
# Copyright (c) 1996-1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
package require tcltest 2.2
namespace import ::tcltest::*
tcltest::configure {*}$argv
tcltest::loadTestedCommands
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
font measure oemfixed 0
font measure systemfixed 0
font measure system 0
set x {}
} -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
} -result {normal}
test winfont-2.4 {TkpGetFontFromAttributes procedure: bold weight} -constraints {
win
} -body {
font actual {-weight bold} -weight
} -result {bold}
test winfont-2.5 {TkpGetFontFromAttributes procedure: no family} -constraints {
win
} -body {
catch {expr {[font actual {-size 10} -size]}}
} -result 0
test winfont-2.6 {TkpGetFontFromAttributes procedure: family} -constraints {
win
} -body {
font actual {-family Arial} -family
} -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]
} -result {Times Times {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]
} -result {Courier Courier {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]
} -result {Helvetica Helvetica 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} -constraints win -body {
catch {font delete xyz}
font actual {-family xyz}
set x {}
} -result {}
test winfont-4.1 {TkpGetFontFamilies procedure} -constraints win -body {
font families
set x {}
} -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]
.t.l config -font $font
expr $x < ($width*10)
} -cleanup {
destroy .t.l
} -result {1}
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} -constraints win -setup {
destroy .c
} -setup {
catch {font delete xyz}
} -body {
font create xyz
button .c -font xyz
font configure xyz -family times
update
destroy .c
font delete xyz
} -result {}
test winfont-7.2 {AllocFont procedure: extract info from logfont} -constraints {
win
} -body {
font actual {arial 10 bold italic underline overstrike}
} -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
} -result {0}
test winfont-7.4 {AllocFont procedure: extract info from textmetric} -constraints {
win
} -body {
font metric systemfixed -fixed
} -result {1}
# cleanup
cleanupTests
return
# Local variables:
# mode: tcl
# End: