tk/tests/winFont.test

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