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