1# This file is a Tcl script to test out the procedures in tkUnixFont.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.  Some tests depend on the
8# fonts having or not having certain properties, which may not be valid
9# at all sites.  
10#
11# Copyright (c) 1996 Sun Microsystems, Inc.
12# Copyright (c) 1998-1999 by Scriptics Corporation.
13# All rights reserved.
14#
15# RCS: @(#) $Id: unixFont.test,v 1.7 2002/07/13 20:28:35 dgp Exp $
16
17package require tcltest 2.1
18namespace import -force tcltest::configure
19namespace import -force tcltest::testsDirectory
20configure -testdir [file join [pwd] [file dirname [info script]]]
21configure -loadfile [file join [testsDirectory] constraints.tcl]
22tcltest::loadTestedCommands
23
24testConstraint hasArial 1
25testConstraint hasCourierNew 1
26testConstraint hasTimesNew 1
27set xlsf [auto_execok xlsfonts]
28if {[llength $xlsf]} {
29    foreach {constraint font} {
30	hasArial	arial
31	hasCourierNew	"courier new"
32	hasTimesNew	"times new roman"
33    } {
34	if {![catch {eval exec $xlsf [list *-$font-*]} res]
35		&& ![string match *unmatched* $res]} {
36	    # Newer Unix systems have more default fonts installed, 
37	    # so we can't rely on fallbacks for fonts to need to
38	    # fall back on anything.
39	    testConstraint $constraint 0
40	}
41    }
42}
43
44catch {destroy .b}
45toplevel .b
46wm geom .b +0+0
47update idletasks
48
49# Font should be fixed width and have chars missing below char 32, so can
50# test control char expansion and missing character code.
51
52set courier {Courier -10}
53set cx [font measure $courier 0]
54
55label .b.l -padx 0 -pady 0 -bd 0 -highlightthickness 0 -justify left -text "0" -font fixed
56pack .b.l
57canvas .b.c -closeenough 0
58
59set t [.b.c create text 0 0 -anchor nw -just left -font $courier]
60pack .b.c
61update
62
63set ax [winfo reqwidth .b.l]
64set ay [winfo reqheight .b.l]
65proc getsize {} {
66    update
67    return "[winfo reqwidth .b.l] [winfo reqheight .b.l]"
68}
69
70test unixfont-1.1 {TkpGetNativeFont procedure: not native} {unix noExceed} {
71    list [catch {font measure {} xyz} msg] $msg
72} {1 {font "" doesn't exist}}
73test unixfont-1.2 {TkpGetNativeFont procedure: native} unix {
74    font measure fixed 0
75} {6}
76
77test unixfont-2.1 {TkpGetFontFromAttributes procedure: no family} unix {
78    font actual {-size 10}
79    set x {}
80} {}
81test unixfont-2.2 {TkpGetFontFromAttributes procedure: Times relatives} \
82	{unix noExceed hasTimesNew} {
83    set x {}
84    lappend x [lindex [font actual {-family "Times New Roman"}] 1]
85    lappend x [lindex [font actual {-family "New York"}] 1]
86    lappend x [lindex [font actual {-family "Times"}] 1]
87} {times times times}
88test unixfont-2.3 {TkpGetFontFromAttributes procedure: Courier relatives} \
89	{unix noExceed hasCourierNew} {
90    set x {}
91    lappend x [lindex [font actual {-family "Courier New"}] 1]
92    lappend x [lindex [font actual {-family "Monaco"}] 1]
93    lappend x [lindex [font actual {-family "Courier"}] 1]
94} {courier courier courier}
95test unixfont-2.4 {TkpGetFontFromAttributes procedure: Helvetica relatives} \
96	{unix noExceed hasArial} {
97    set x {}
98    lappend x [lindex [font actual {-family "Arial"}] 1]
99    lappend x [lindex [font actual {-family "Geneva"}] 1]
100    lappend x [lindex [font actual {-family "Helvetica"}] 1]
101} {helvetica helvetica helvetica}
102test unixfont-2.5 {TkpGetFontFromAttributes procedure: fallback} unix {
103    font actual {-xyz-xyz-*-*-*-*-*-*-*-*-*-*-*-*}
104    set x {}
105} {}
106test unixfont-2.6 {TkpGetFontFromAttributes: fallback to fixed family} unix {
107    lindex [font actual {-family fixed -size 10}] 1
108} {fixed}
109test unixfont-2.7 {TkpGetFontFromAttributes: fixed family not available!} unix {
110    # no test available
111} {}
112test unixfont-2.8 {TkpGetFontFromAttributes: loop over returned font names} unix {
113    lindex [font actual {-family fixed -size 31}] 1
114} {fixed}
115test unixfont-2.9 {TkpGetFontFromAttributes: reject adobe courier if possible} {unix noExceed} {
116    lindex [font actual {-family courier}] 1
117} {courier}
118test unixfont-2.10 {TkpGetFontFromAttributes: scalable font found} unix {
119    lindex [font actual {-family courier -size 37}] 3
120} {37}
121test unixfont-2.11 {TkpGetFontFromAttributes: font cannot be loaded} unix {
122    # On Linux, XListFonts() was returning names for fonts that do not
123    # actually exist, causing the subsequent XLoadQueryFont() to fail
124    # unexpectedly.  Now falls back to another font if that happens.
125
126    font actual {-size 14}
127    set x {}
128} {}    
129
130test unixfont-3.1 {TkpDeleteFont procedure} unix {
131    font actual {-family xyz}
132    set x {}
133} {}
134
135test unixfont-4.1 {TkpGetFontFamilies procedure} unix {
136    font families
137    set x {}
138} {}
139
140test unixfont-5.1 {Tk_MeasureChars procedure: no chars to be measured} unix {
141    .b.l config -text "000000" -wrap [expr $ax*3]
142    .b.l config -wrap 0
143} {}
144test unixfont-5.2 {Tk_MeasureChars procedure: no right margin} unix {
145    .b.l config -text "000000"
146} {}
147test unixfont-5.3 {Tk_MeasureChars procedure: loop over chars} unix {
148    .b.l config -text "0"
149    .b.l config -text "\377"
150    .b.l config -text "0\3770\377"
151    .b.l config -text "000000000000000"
152} {}
153.b.l config -wrap [expr $ax*10]
154test unixfont-5.4 {Tk_MeasureChars procedure: reached right edge} unix {
155    .b.l config -text "0000000000000"
156    getsize
157} "[expr $ax*10] [expr $ay*2]"
158test unixfont-5.5 {Tk_MeasureChars procedure: ran out of chars} unix {
159    .b.l config -text "000000"
160    getsize
161} "[expr $ax*6] $ay"
162test unixfont-5.6 {Tk_MeasureChars procedure: find last word} unix {
163    .b.l config -text "000000 00000"
164    getsize
165} "[expr $ax*6] [expr $ay*2]"
166test unixfont-5.7 {Tk_MeasureChars procedure: already saw space in line} unix {
167    .b.l config -text "000000     00000"
168    getsize
169} "[expr $ax*6] [expr $ay*2]"
170test unixfont-5.8 {Tk_MeasureChars procedure: internal spaces significant} unix {
171    .b.l config -text "00  000     00000"
172    getsize
173} "[expr $ax*7] [expr $ay*2]"
174test unixfont-5.9 {Tk_MeasureChars procedure: TK_PARTIAL_OK} unix {
175    .b.c dchars $t 0 end
176    .b.c insert $t 0 "0000"
177    .b.c index $t @[expr int($ax*2.5)],1
178} {2}
179test unixfont-5.10 {Tk_MeasureChars procedure: TK_AT_LEAST_ONE} unix {
180    .b.l config -text "000000000000"
181    getsize
182} "[expr $ax*10] [expr $ay*2]"
183test unixfont-5.11 {Tk_MeasureChars: TK_AT_LEAST_ONE + not even one char fit!} unix {
184    set a [.b.l cget -wrap]
185    .b.l config -text "000000" -wrap 1
186    set x [getsize]
187    .b.l config -wrap $a
188    set x
189} "$ax [expr $ay*6]"
190test unixfont-5.12 {Tk_MeasureChars procedure: include eol spaces} unix {
191    .b.l config -text "000   \n000"
192    getsize
193} "[expr $ax*6] [expr $ay*2]"
194
195test unixfont-6.1 {Tk_DrawChars procedure: loop test} unix {
196    .b.l config -text "a"
197    update
198} {}
199test unixfont-6.2 {Tk_DrawChars procedure: loop test} unix {
200    .b.l config -text "abcd"
201    update
202} {}
203test unixfont-6.3 {Tk_DrawChars procedure: special char} unix {
204    .b.l config -text "\001"
205    update
206} {}
207test unixfont-6.4 {Tk_DrawChars procedure: normal then special} unix {
208    .b.l config -text "ab\001"
209    update
210} {}
211test unixfont-6.5 {Tk_DrawChars procedure: ends with special} unix {
212    .b.l config -text "ab\001"
213    update
214} {}
215test unixfont-6.6 {Tk_DrawChars procedure: more normal chars at end} unix {
216    .b.l config -text "ab\001def"
217    update
218} {}
219
220test unixfont-7.1 {DrawChars procedure: no effects} unix {
221    .b.l config -text "abc"
222    update
223} {}
224test unixfont-7.2 {DrawChars procedure: underlining} unix {
225    set f [.b.l cget -font]
226    .b.l config -text "abc" -font "courier 10 underline"
227    update
228    .b.l config -font $f
229} {}
230test unixfont-7.3 {DrawChars procedure: overstrike} unix {
231    set f [.b.l cget -font]
232    .b.l config -text "abc" -font "courier 10 overstrike"
233    update
234    .b.l config -font $f
235} {}
236
237test unixfont-8.1 {AllocFont procedure: use old font} unix {
238    font create xyz
239    button .c -font xyz
240    font configure xyz -family times
241    update
242    destroy .c
243    font delete xyz
244} {}
245test unixfont-8.2 {AllocFont procedure: parse information from XLFD} unix {
246    expr {[lindex [font actual {-family times -size 0}] 3] == 0}
247} {0}
248test unixfont-8.3 {AllocFont procedure: can't parse info from name} unix {
249    catch {unset fontArray}
250    # check that font actual returns the correct attributes.
251    # the values of those attributes are system dependent.
252    array set fontArray [font actual a12biluc]
253    set result [lsort [array names fontArray]]
254    catch {unset fontArray}
255    set result
256} {-family -overstrike -size -slant -underline -weight}
257test unixfont-8.4 {AllocFont procedure: classify characters} unix {
258    set x 0
259    incr x [font measure $courier "\u4000"]   ;# 6
260    incr x [font measure $courier "\002"]   ;# 4
261    incr x [font measure $courier "\012"]   ;# 2
262    incr x [font measure $courier "\101"]   ;# 1
263    set x
264} [expr $cx*13]
265test unixfont-8.5 {AllocFont procedure: setup widths of normal chars} unix {
266    font metrics $courier -fixed
267} {1}
268test unixfont-8.6 {AllocFont procedure: setup widths of special chars} unix {
269    set x 0
270    incr x [font measure $courier "\001"]   ;# 4
271    incr x [font measure $courier "\002"]   ;# 4
272    incr x [font measure $courier "\012"]   ;# 2
273    set x
274} [expr $cx*10]
275test unixfont-8.7 {AllocFont procedure: XA_UNDERLINE_POSITION} unix {
276    catch {font actual -adobe-courier-bold-i-normal--0-0-0-0-m-0-iso8859-1}
277    set x {}
278} {}
279test unixfont-8.8 {AllocFont procedure: no XA_UNDERLINE_POSITION} unix {
280    catch {font actual --symbol-medium-r-normal--0-0-0-0-p-0-sun-fontspecific}
281    set x {}
282} {}
283test unixfont-8.9 {AllocFont procedure: XA_UNDERLINE_THICKNESS} unix {
284    catch {font actual -adobe-courier-bold-i-normal--0-0-0-0-m-0-iso8859-1}
285    set x {}
286} {}
287test unixfont-8.10 {AllocFont procedure: no XA_UNDERLINE_THICKNESS} unix {
288    catch {font actual --symbol-medium-r-normal--0-0-0-0-p-0-sun-fontspecific}
289    set x {}
290} {}
291test unixfont-8.11 {AllocFont procedure: XA_UNDERLINE_POSITION was 0} unix {
292    catch {font actual -adobe-courier-bold-i-normal--0-0-0-0-m-0-iso8859-1}
293    set x {}
294} {}
295
296test unixfont-9.1 {GetControlCharSubst procedure: 2 chars subst} unix {
297    .b.c dchars $t 0 end
298    .b.c insert $t 0 "0\a0"
299    set x {}
300    lappend x [.b.c index $t @[expr $ax*0],0]
301    lappend x [.b.c index $t @[expr $ax*1],0]
302    lappend x [.b.c index $t @[expr $ax*2],0]
303    lappend x [.b.c index $t @[expr $ax*3],0]
304} {0 1 1 2}
305test unixfont-9.2 {GetControlCharSubst procedure: 4 chars subst} unix {
306    .b.c dchars $t 0 end
307    .b.c insert $t 0 "0\0010"
308    set x {}
309    lappend x [.b.c index $t @[expr $ax*0],0]
310    lappend x [.b.c index $t @[expr $ax*1],0]
311    lappend x [.b.c index $t @[expr $ax*2],0]
312    lappend x [.b.c index $t @[expr $ax*3],0]
313    lappend x [.b.c index $t @[expr $ax*4],0]
314    lappend x [.b.c index $t @[expr $ax*5],0]
315} {0 1 1 1 1 2}
316
317# cleanup
318::tcltest::cleanupTests
319return
320
321
322
323
324
325
326
327
328
329
330
331
332
333