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