1# This file is a Tcl script to test out the procedures in tkWinFont.c. 
2# It is organized in the standard fashion for Tcl tests.
3#
4# Many of these tests are visually oriented and cannot be checked
5# programmatically (such as "does an underlined font appear to be
6# underlined?"); these tests attempt to exercise the code in question,
7# but there are no results that can be checked.  
8#
9# Copyright (c) 1996-1997 Sun Microsystems, Inc.
10# Copyright (c) 1998-1999 by Scriptics Corporation.
11# All rights reserved.
12#
13# RCS: @(#) $Id$
14
15package require tcltest 2.1
16eval tcltest::configure $argv
17tcltest::loadTestedCommands
18
19catch {destroy .b}
20catch {font delete xyz}
21
22toplevel .b
23wm geometry .b +0+0
24update idletasks
25
26set courier {Courier 14}
27set cx [font measure $courier 0]
28
29label .b.l -padx 0 -pady 0 -bd 0 -highlightthickness 0 -justify left -text "0" -font systemfixed
30pack .b.l
31canvas .b.c -closeenough 0
32
33set t [.b.c create text 0 0 -anchor nw -just left -font $courier]
34pack .b.c
35update
36
37set ax [winfo reqwidth .b.l]
38set ay [winfo reqheight .b.l]
39proc getsize {} {
40    update
41    return "[winfo reqwidth .b.l] [winfo reqheight .b.l]"
42}
43
44test winfont-1.1 {TkpGetNativeFont procedure: not native} win {
45    list [catch {font measure {} xyz} msg] $msg
46} {1 {font "" doesn't exist}}
47test winfont-1.2 {TkpGetNativeFont procedure: native} win {
48    font measure ansifixed 0
49    font measure ansi 0
50    font measure device 0
51    font measure oemfixed 0
52    font measure systemfixed 0
53    font measure system 0
54    set x {}
55} {}
56
57test winfont-2.1 {TkpGetFontFromAttributes procedure: pointsize} win {
58    expr [font actual {-size -10} -size]>0
59} {1}
60test winfont-2.2 {TkpGetFontFromAttributes procedure: pointsize} win {
61    expr [font actual {-family Arial} -size]>0
62} {1}
63test winfont-2.3 {TkpGetFontFromAttributes procedure: normal weight} win {
64    font actual {-weight normal} -weight
65} {normal}
66test winfont-2.4 {TkpGetFontFromAttributes procedure: bold weight} win {
67    font actual {-weight bold} -weight
68} {bold}
69test winfont-2.5 {TkpGetFontFromAttributes procedure: no family} win {
70    catch {expr {[font actual {-size 10} -size]}}
71} 0
72test winfont-2.6 {TkpGetFontFromAttributes procedure: family} win {
73    font actual {-family Arial} -family
74} {Arial}
75test winfont-2.7 {TkpGetFontFromAttributes procedure: Times fonts} win {
76    set x {}
77    lappend x [font actual {-family "Times"} -family]
78    lappend x [font actual {-family "New York"} -family]
79    lappend x [font actual {-family "Times New Roman"} -family]
80} {{Times New Roman} {Times New Roman} {Times New Roman}}
81test winfont-2.8 {TkpGetFontFromAttributes procedure: Courier fonts} win {
82    set x {}
83    lappend x [font actual {-family "Courier"} -family]
84    lappend x [font actual {-family "Monaco"} -family]
85    lappend x [font actual {-family "Courier New"} -family]
86} {{Courier New} {Courier New} {Courier New}}
87test winfont-2.9 {TkpGetFontFromAttributes procedure: Helvetica fonts} win {
88    set x {}
89    lappend x [font actual {-family "Helvetica"} -family]
90    lappend x [font actual {-family "Geneva"} -family]
91    lappend x [font actual {-family "Arial"} -family]
92} {Arial Arial Arial}
93test winfont-2.10 {TkpGetFontFromAttributes procedure: fallback} win {
94    # No way to get it to fail! Any font name is acceptable.
95} {}
96
97test winfont-3.1 {TkpDeleteFont procedure} win {
98    font actual {-family xyz}
99    set x {}
100} {}
101
102test winfont-4.1 {TkpGetFontFamilies procedure} win {
103    font families
104    set x {}
105} {}
106
107test winfont-5.1 {Tk_MeasureChars procedure: unbounded right margin} win {
108    .b.l config -wrap 0 -text "000000"
109    getsize
110} "[expr $ax*6] $ay"
111test winfont-5.2 {Tk_MeasureChars procedure: static width buffer exceeded} win {
112    .b.l config -wrap 100000 -text "0000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000"
113    getsize
114} "[expr $ax*256] $ay"
115test winfont-5.3 {Tk_MeasureChars procedure: all chars did fit} win {
116    .b.l config -wrap [expr $ax*10] -text "00000000"
117    getsize
118} "[expr $ax*8] $ay"
119test winfont-5.4 {Tk_MeasureChars procedure: not all chars fit} win {
120    .b.l config -wrap [expr $ax*6] -text "00000000"
121    getsize
122} "[expr $ax*6] [expr $ay*2]"
123test winfont-5.5 {Tk_MeasureChars procedure: include last partial char} win {
124    .b.c dchars $t 0 end
125    .b.c insert $t 0 "0000"
126    .b.c index $t @[expr int($cx*2.5)],1
127} {2}
128test winfont-5.6 {Tk_MeasureChars procedure: at least one char on line} win {
129    .b.l config -text "000000" -wrap 1
130    getsize
131} "$ax [expr $ay*6]"
132test winfont-5.7 {Tk_MeasureChars procedure: whole words} win {
133    .b.l config -wrap [expr $ax*8] -text "000000 0000"
134    getsize
135} "[expr $ax*6] [expr $ay*2]"
136test winfont-5.8 {Tk_MeasureChars procedure: already saw space in line} win {
137    .b.l config -wrap [expr $ax*12] -text "000000    0000000"
138    getsize
139} "[expr $ax*7] [expr $ay*2]"
140test winfont-5.9 {Tk_MeasureChars procedure: internal spaces significant} win {
141    .b.l config -wrap [expr $ax*12] -text "000  00   00000"
142    getsize
143} "[expr $ax*7] [expr $ay*2]"
144test winfont-5.10 {Tk_MeasureChars procedure: make first part of word fit} win {
145    .b.l config -wrap [expr $ax*12] -text "0000000000000000"
146    getsize
147} "[expr $ax*12] [expr $ay*2]"
148test winfont-5.11 {Tk_MeasureChars procedure: check for kerning} \
149	{win nonPortable} {
150    set font [.b.l cget -font]
151    .b.l config -font {{MS Sans Serif} 8} -text "W"
152    set width [winfo reqwidth .b.l]
153    .b.l config -text "XaYoYaKaWx"
154    set x [lindex [getsize] 0]
155    .b.l config -font $font
156    expr $x < ($width*10)
157} 1
158
159test winfont-6.1 {Tk_DrawChars procedure: loop test} win {
160    .b.l config -text "a"
161    update
162} {}
163
164test winfont-7.1 {AllocFont procedure: use old font} win {
165    font create xyz
166    catch {destroy .c}
167    button .c -font xyz
168    font configure xyz -family times
169    update
170    destroy .c
171    font delete xyz
172} {}
173test winfont-7.2 {AllocFont procedure: extract info from logfont} win {
174    font actual {arial 10 bold italic underline overstrike}
175} {-family Arial -size 10 -weight bold -slant italic -underline 1 -overstrike 1}
176test winfont-7.3 {AllocFont procedure: extract info from textmetric} win {
177    font metric {arial 10 bold italic underline overstrike} -fixed
178} {0}
179test winfont-7.4 {AllocFont procedure: extract info from textmetric} win {
180    font metric systemfixed -fixed
181} {1}
182
183# cleanup
184destroy .b
185cleanupTests
186return
187