diff options
Diffstat (limited to 'tcl/tests/font.test')
| -rw-r--r-- | tcl/tests/font.test | 1380 |
1 files changed, 0 insertions, 1380 deletions
diff --git a/tcl/tests/font.test b/tcl/tests/font.test deleted file mode 100644 index 65fd00ac849..00000000000 --- a/tcl/tests/font.test +++ /dev/null @@ -1,1380 +0,0 @@ -# This file is a Tcl script to test out Tk's "font" command -# plus the procedures in tkFont.c. It is organized in the -# standard white-box fashion for Tcl tests. -# -# Copyright (c) 1996-1998 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. -# All rights reserved. -# -# RCS: @(#) $Id$ - -package require tcltest 2.1 -namespace import -force tcltest::configure -namespace import -force tcltest::testsDirectory -configure -testdir [file join [pwd] [file dirname [info script]]] -configure -loadfile [file join [testsDirectory] constraints.tcl] -tcltest::loadTestedCommands - -catch {destroy .b} -toplevel .b -wm geom .b +0+0 -update idletasks - -proc setup {} { - catch {destroy .b.f} - catch {eval font delete [font names]} - label .b.f - pack .b.f - update -} - -label .b.l -padx 0 -pady 0 -bd 0 -highlightthickness 0 -justify left -text "0" -font "Courier -12" -pack .b.l -canvas .b.c -closeenough 0 -.b.c create text 0 0 -tags text -anchor nw -just left -font "Courier -12" -pack .b.c -update - -set ax [winfo reqwidth .b.l] -set ay [winfo reqheight .b.l] -proc getsize {} { - update - return "[winfo reqwidth .b.l] [winfo reqheight .b.l]" -} - -proc csetup {{str ""}} { - focus -force .b.c - .b.c dchars text 0 end - .b.c insert text 0 $str - .b.c focus text -} - -setup - -case $tcl_platform(platform) { - unix {set fixed "fixed"} - windows {set fixed "courier 12"} - macintosh {set fixed "monaco 9"} -} -set times [font actual {times 0} -family] - -test font-1.1 {TkFontPkgInit} { - catch {interp delete foo} - interp create foo - foo eval { - load {} Tk - wm geometry . +0+0 - update - } - interp delete foo -} {} - -test font-2.1 {TkFontPkgFree} { - catch {interp delete foo} - interp create foo - set x {} - - # Makes sure that named font was visible only to child interp. - - foo eval { - load {} Tk - wm geometry . +0+0 - button .b -font {times 16} -text "hi" - pack .b - font create wiggles -family courier -underline 1 - update - } - lappend x [catch {font configure wiggles} msg; set msg] - - # Tests cancelling the idle handler for TheWorldHasChanged, - # because app goes away before idle serviced. - - foo eval { - .b config -font wiggles - font config wiggles -size 24 - destroy . - } - lappend x [foo eval {catch {font families} msg; set msg}] - - interp delete foo - set x -} {{named font "wiggles" doesn't exist} {can't invoke "font" command: application has been destroyed}} - - -test font-3.1 {font command: general} { - list [catch {font} msg] $msg -} {1 {wrong # args: should be "font option ?arg?"}} -test font-3.2 {font command: general} { - list [catch {font xyz} msg] $msg -} {1 {bad option "xyz": must be actual, configure, create, delete, families, measure, metrics, or names}} - -test font-4.1 {font command: actual: arguments} { - # (skip < 0) - list [catch {font actual xyz -displayof} msg] $msg -} {1 {value for "-displayof" missing}} -test font-4.2 {font command: actual: arguments} { - # (objc < 3) - list [catch {font actual} msg] $msg -} {1 {wrong # args: should be "font actual font ?-displayof window? ?option?"}} -test font-4.3 {font command: actual: arguments} { - # (objc - skip > 4) when skip == 0 - list [catch {font actual xyz abc def} msg] $msg -} {1 {wrong # args: should be "font actual font ?-displayof window? ?option?"}} -test font-4.4 {font command: actual: displayof specified, so skip to next} { - catch {font actual xyz -displayof . -size} -} {0} -test font-4.5 {font command: actual: displayof specified, so skip to next} { - lindex [font actual xyz -displayof .] 0 -} {-family} -test font-4.6 {font command: actual: arguments} { - # (objc - skip > 4) when skip == 2 - list [catch {font actual xyz -displayof . abc def} msg] $msg -} {1 {wrong # args: should be "font actual font ?-displayof window? ?option?"}} -test font-4.7 {font command: actual: arguments} {noExceed} { - # (tkfont == NULL) - list [catch {font actual "\{xyz"} msg] $msg -} [list 1 "font \"{xyz\" doesn't exist"] -test font-4.8 {font command: actual: all attributes} { - # not (objc > 3) so objPtr = NULL - lindex [font actual {-family times}] 0 -} {-family} -test font-4.9 {font command: actual} {macOrUnix noExceed} { - # (objc > 3) so objPtr = objv[3 + skip] - string tolower [font actual {-family times} -family] -} {times} -test font-4.10 {font command: actual} {pcOnly} { - # (objc > 3) so objPtr = objv[3 + skip] - font actual {-family times} -family -} {Times New Roman} -test font-4.11 {font command: bad option} { - list [catch {font actual xyz -style} msg] $msg -} {1 {bad option "-style": must be -family, -size, -weight, -slant, -underline, or -overstrike}} - -test font-5.1 {font command: configure} { - # (objc < 3) - list [catch {font configure} msg] $msg -} {1 {wrong # args: should be "font configure fontname ?options?"}} -test font-5.2 {font command: configure: non-existent font} { - # (namedHashPtr == NULL) - list [catch {font configure xyz} msg] $msg -} {1 {named font "xyz" doesn't exist}} -test font-5.3 {font command: configure: "deleted" font} { - # (nfPtr->deletePending != 0) - setup - font create xyz - .b.f configure -font xyz - font delete xyz - list [catch {font configure xyz} msg] $msg -} {1 {named font "xyz" doesn't exist}} -test font-5.4 {font command: configure: get all options} { - # (objc == 3) so objPtr = NULL - setup - font create xyz -family xyz - lindex [font configure xyz] 1 -} xyz -test font-5.5 {font command: configure: get one option} { - # (objc == 4) so objPtr = objv[3] - setup - font create xyz -family xyz - font configure xyz -family -} xyz -test font-5.6 {font command: configure: update existing font} { - # else result = ConfigAttributesObj() - setup - font create xyz - font configure xyz -family xyz - update - font configure xyz -family -} xyz -test font-5.7 {font command: configure: bad option} { - setup - font create xyz - list [catch {font configure xyz -style} msg] $msg -} {1 {bad option "-style": must be -family, -size, -weight, -slant, -underline, or -overstrike}} - -test font-6.1 {font command: create: make up name} { - # (objc < 3) so name = NULL - setup - font create - font names -} {font1} -test font-6.2 {font command: create: name specified} { - # not (objc < 3) - setup - font create xyz - font names -} {xyz} -test font-6.3 {font command: create: name not really specified} { - # (name[0] == '-') so name = NULL - setup - font create -family xyz - font names -} {font1} -test font-6.4 {font command: create: generate name} { - # (name == NULL) - setup - font create -family one - font create -family two - font create -family three - font delete font2 - font create -family four - font configure font2 -family -} {four} -test font-6.5 {font command: create: bad option creating new font} { - # name was specified so skip = 3 - setup - list [catch {font create xyz -xyz times} msg] $msg -} {1 {bad option "-xyz": must be -family, -size, -weight, -slant, -underline, or -overstrike}} -test font-6.6 {font command: create: bad option creating new font} { - # name was not specified so skip = 2 - setup - list [catch {font create -xyz times} msg] $msg -} {1 {bad option "-xyz": must be -family, -size, -weight, -slant, -underline, or -overstrike}} -test font-6.7 {font command: create: already exists} { - # (CreateNamedFont() != TCL_OK) - setup - font create xyz - list [catch {font create xyz} msg] $msg -} {1 {named font "xyz" already exists}} - -test font-7.1 {font command: delete: arguments} { - # (objc < 3) - list [catch {font delete} msg] $msg -} {1 {wrong # args: should be "font delete fontname ?fontname ...?"}} -test font-7.2 {font command: delete: loop test} { - # for (i = 2; i < objc; i++) - setup - set x {} - font create a -underline 1 - font create b -underline 1 - font create c -underline 1 - font create d -underline 1 - font create e -underline 1 - lappend x [lsort [font names]] - font delete a e c b - lappend x [lsort [font names]] -} {{a b c d e} d} -test font-7.3 {font command: delete: loop test} { - # (namedHashPtr == NULL) in middle of loop - setup - set x {} - font create a -underline 1 - font create b -underline 1 - font create c -underline 1 - font create d -underline 1 - font create e -underline 1 - lappend x [lsort [font names]] - catch {font delete a d q c e b} - lappend x [lsort [font names]] -} {{a b c d e} {b c e}} -test font-7.4 {font command: delete: non-existent} { - # (namedHashPtr == NULL) - setup - list [catch {font delete xyz} msg] $msg -} {1 {named font "xyz" doesn't exist}} -test font-7.5 {font command: delete: mark for later deletion} { - # (nfPtr->refCount != 0) - setup - font create xyz - .b.f configure -font xyz - font delete xyz - font actual xyz - list [catch {font configure xyz} msg] $msg [.b.f cget -font] -} {1 {named font "xyz" doesn't exist} xyz} -test font-7.6 {font command: delete: actually delete} { - # not (nfPtr->refCount != 0) - setup - font create xyz -underline 1 - font delete xyz - catch {font config xyz} -} {1} -setup - -test font-8.1 {font command: families: arguments} { - # (skip < 0) - list [catch {font families -displayof} msg] $msg -} {1 {value for "-displayof" missing}} -test font-8.2 {font command: families: arguments} { - # (objc - skip != 2) when skip == 0 - list [catch {font families xyz} msg] $msg -} {1 {wrong # args: should be "font families ?-displayof window?"}} -test font-8.3 {font command: families: arguments} { - # (objc - skip != 2) when skip == 2 - list [catch {font families -displayof . xyz} msg] $msg -} {1 {wrong # args: should be "font families ?-displayof window?"}} -test font-8.4 {font command: families} { - # TkpGetFontFamilies() - regexp -nocase times [font families] -} {1} - -test font-9.1 {font command: measure: arguments} { - # (skip < 0) - list [catch {font measure xyz -displayof} msg] $msg -} {1 {value for "-displayof" missing}} -test font-9.2 {font command: measure: arguments} { - # (objc - skip != 4) - list [catch {font measure} msg] $msg -} {1 {wrong # args: should be "font measure font ?-displayof window? text"}} -test font-9.3 {font command: measure: arguments} { - # (objc - skip != 4) - list [catch {font measure xyz abc def} msg] $msg -} {1 {wrong # args: should be "font measure font ?-displayof window? text"}} -test font-9.4 {font command: measure: arguments} {noExceed} { - # (tkfont == NULL) - list [catch {font measure "\{xyz" abc} msg] $msg -} [list 1 "font \"{xyz\" doesn't exist"] -test font-9.5 {font command: measure} { - # Tk_TextWidth() - expr [font measure $fixed "abcdefg"]==[font measure $fixed "a"]*7 -} {1} - -test font-10.1 {font command: metrics: arguments} { - list [catch {font metrics xyz -displayof} msg] $msg -} {1 {value for "-displayof" missing}} -test font-10.2 {font command: metrics: arguments} { - # (skip < 0) - list [catch {font metrics xyz -displayof} msg] $msg -} {1 {value for "-displayof" missing}} -test font-10.3 {font command: metrics: arguments} { - # (objc < 3) - list [catch {font metrics} msg] $msg -} {1 {wrong # args: should be "font metrics font ?-displayof window? ?option?"}} -test font-10.4 {font command: metrics: arguments} { - # (objc - skip) > 4) when skip == 0 - list [catch {font metrics xyz abc def} msg] $msg -} {1 {wrong # args: should be "font metrics font ?-displayof window? ?option?"}} -test font-10.5 {font command: metrics: arguments} { - # (objc - skip) > 4) when skip == 2 - list [catch {font metrics xyz -displayof . abc} msg] $msg -} {1 {bad metric "abc": must be -ascent, -descent, -linespace, or -fixed}} -test font-10.6 {font command: metrics: bad font} {noExceed} { - # (tkfont == NULL) - list [catch {font metrics "\{xyz"} msg] $msg -} [list 1 "font \"{xyz\" doesn't exist"] -test font-10.7 {font command: metrics: get all metrics} { - # (objc == 3) - catch {unset a} - array set a [font metrics {-family xyz}] - set x [lsort [array names a]] - unset a - set x -} {-ascent -descent -fixed -linespace} -test font-10.8 {font command: metrics: bad metric} { - # (Tcl_GetIndexFromObj() != TCL_OK) - list [catch {font metrics $fixed -xyz} msg] $msg -} {1 {bad metric "-xyz": must be -ascent, -descent, -linespace, or -fixed}} -test font-10.9 {font command: metrics: get individual metrics} { - font metrics $fixed -ascent - font metrics $fixed -descent - font metrics $fixed -linespace - font metrics $fixed -fixed -} {1} - -test font-11.1 {font command: names: arguments} { - # (objc != 2) - list [catch {font names xyz} msg] $msg -} {1 {wrong # args: should be "font names"}} -test font-11.2 {font command: names: loop test: no passes} { - setup - font names -} {} -test font-11.3 {font command: names: loop test: one pass} { - setup - font create - font names -} {font1} -test font-11.4 {font command: names: loop test: multiple passes} { - setup - font create xyz - font create abc - font create def - lsort [font names] -} {abc def xyz} -test font-11.5 {font command: names: skip deletePending fonts} { - # (nfPtr->deletePending == 0) - setup - set x {} - font create xyz - font create abc - lappend x [lsort [font names]] - .b.f config -font xyz - font delete xyz - lappend x [font names] -} {{abc xyz} abc} - -test font-12.1 {UpdateDependantFonts procedure: no users} { - # (nfPtr->refCount == 0) - setup - font create xyz - font configure xyz -family times -} {} -test font-12.2 {UpdateDependantFonts procedure: pings the widgets} { - setup - font create xyz -family times -size 20 - .b.f config -font xyz -text "abcd" -padx 0 -bd 0 -highlightthickness 0 - set a1 [font measure xyz "abcd"] - update - set b1 [winfo reqwidth .b.f] - font configure xyz -family helvetica -size 20 - set a2 [font measure xyz "abcd"] - update - set b2 [winfo reqwidth .b.f] - expr {$a1==$b1 && $a2==$b2} -} {1} - -test font-13.1 {CreateNamedFont: new named font} { - # not (new == 0) - setup - set x {} - lappend x [font names] - font create xyz - lappend x [font names] -} {{} xyz} -test font-13.2 {CreateNamedFont: named font already exists} { - # (new == 0) - setup - font create xyz - list [catch {font create xyz} msg] $msg -} {1 {named font "xyz" already exists}} -test font-13.3 {CreateNamedFont: named font already exists} { - # (nfPtr->deletePending == 0) - setup - font create xyz - list [catch {font create xyz} msg] $msg -} {1 {named font "xyz" already exists}} -test font-13.4 {CreateNamedFont: recreate "deleted" font} { - # not (nfPtr->deletePending == 0) - setup - font create xyz -family times - .b.f configure -font xyz - font delete xyz - font create xyz -family courier - font configure xyz -family -} {courier} - -test font-14.1 {Tk_GetFont procedure} { -} {} - -test font-15.1 {Tk_AllocFontFromObj - converting internal reps} testfont { - set x {Times 16} - lindex $x 0 - destroy .b1 .b2 - button .b1 -font $x - lindex $x 0 - testfont counts {Times 16} -} {{1 0}} -test font-15.2 {Tk_AllocFontFromObj - discard stale font} testfont { - set x {Times 16} - destroy .b1 .b2 - button .b1 -font $x - destroy .b1 - set result {} - lappend result [testfont counts {Times 16}] - button .b2 -font $x - lappend result [testfont counts {Times 16}] -} {{} {{1 1}}} -test font-15.3 {Tk_AllocFontFromObj - reuse existing font} testfont { - set x {Times 16} - destroy .b1 .b2 - button .b1 -font $x - set result {} - lappend result [testfont counts {Times 16}] - button .b2 -font $x - pack .b1 .b2 -side top - lappend result [testfont counts {Times 16}] -} {{{1 1}} {{2 1}}} -test font-15.4 {Tk_AllocFontFromObj procedure: bump ref count} { - # (new == 0) - setup - .b.f config -font {-family fixed} - lindex [font actual {-family fixed}] 0 -} {-family} -test font-15.5 {Tk_AllocFontFromObj procedure: get named font} { - # (namedHashPtr != NULL) - setup - font create xyz - .b.f config -font xyz -} {} -test font-15.6 {Tk_AllocFontFromObj procedure: not a named font} { - # not (namedHashPtr != NULL) - setup - .b.f config -font {times 20} -} {} -test font-15.7 {Tk_AllocFontFromObj procedure: get native font} {unixOnly} { - # not (fontPtr == NULL) - setup - .b.f config -font fixed -} {} -test font-15.8 {Tk_AllocFontFromObj procedure: get native font} {pcOnly} { - # not (fontPtr == NULL) - setup - .b.f config -font oemfixed -} {} -test font-15.9 {Tk_AllocFontFromObj procedure: get native font} {macOnly} { - # not (fontPtr == NULL) - setup - .b.f config -font application -} {} -test font-15.10 {Tk_AllocFontFromObj procedure: get attribute font} { - # (fontPtr == NULL) - list [catch {.b.f config -font {xxx yyy zzz}} msg] $msg -} {1 {expected integer but got "yyy"}} -test font-15.11 {Tk_AllocFontFromObj procedure: no match} {noExceed} { - # (ParseFontNameObj() != TCL_OK) - list [catch {font actual "\{xyz"} msg] $msg -} [list 1 "font \"{xyz\" doesn't exist"] -test font-15.12 {Tk_AllocFontFromObj procedure: get attribute font} { - # not (ParseFontNameObj() != TCL_OK) - lindex [font actual {plan 9}] 0 -} {-family} -test font-15.13 {Tk_AllocFontFromObj procedure: setup tab width} { - # Tk_MeasureChars(fontPtr, "0", ...) - label .l -bd 0 -padx 0 -highlightthickness 0 -font $fixed -text "a\tb" - update - set x [winfo reqwidth .l] - destroy .l - set x -} [expr [font measure $fixed "0"]*9] -test font-15.14 {Tk_AllocFontFromObj procedure: underline position} { - # (fontPtr->underlineHeight == 0) because size was < 10 - setup - .b.f config -text "underline" -font "times -8 underline" - update -} {} - -test font-16.1 {Tk_NameOfFont procedure} { - setup - .b.f config -font -family\ fixed - .b.f cget -font -} {-family fixed} - -test font-17.1 {Tk_FreeFontFromObj - reference counts} testfont { - set x {Courier 12} - destroy .b1 .b2 .b3 - button .b1 -font $x - button .b3 -font $x - button .b2 -font $x - set result {} - lappend result [testfont counts {Courier 12}] - destroy .b1 - lappend result [testfont counts {Courier 12}] - destroy .b2 - lappend result [testfont counts {Courier 12}] - destroy .b3 - lappend result [testfont counts {Courier 12}] -} {{{3 1}} {{2 1}} {{1 1}} {}} -test font-17.2 {Tk_FreeFont procedure: one ref} { - # (fontPtr->refCount == 0) - setup - .b.f config -font {-family fixed} - destroy .b.f -} {} -test font-17.3 {Tk_FreeFont procedure: multiple ref} { - # not (fontPtr->refCount == 0) - setup - .b.f config -font {-family fixed} - button .b.b -font {-family fixed} - destroy .b.f - set x [.b.b cget -font] - destroy .b.b - set x -} {-family fixed} -test font-17.4 {Tk_FreeFont procedure: named font} { - # (fontPtr->namedHashPtr != NULL) - setup - font create xyz - .b.f config -font xyz - destroy .b.f - font names -} {xyz} -test font-17.5 {Tk_FreeFont procedure: named font} { - # not (fontPtr->refCount == 0) - setup - font create xyz -underline 1 - .b.f config -font xyz - font delete xyz - set x [font actual xyz -underline] - destroy .b.f - list [font actual xyz -underline] $x -} {0 1} -test font-17.6 {Tk_FreeFont procedure: named font not deleted yet} { - setup - font create xyz - .b.f config -font xyz - button .b.b -font xyz - font delete xyz - set x [font actual xyz] - destroy .b.b - list [lindex [font actual xyz] 0] [lindex $x 0] -} {-family -family} - -test font-18.1 {FreeFontObjProc} testfont { - destroy .b1 - set x [format {Courier 12}] - button .b1 -font $x - set y [format {Courier 12}] - .b1 configure -font $y - set z [format {Courier 12}] - .b1 configure -font $z - set result {} - lappend result [testfont counts {Courier 12}] - set x red - lappend result [testfont counts {Courier 12}] - set z 32 - lappend result [testfont counts {Courier 12}] - destroy .b1 - lappend result [testfont counts {Courier 12}] - set y bogus - set result -} {{{1 3}} {{1 2}} {{1 1}} {}} - -test font-19.1 {Tk_FontId} { - .b.f config -font "times 20" - update -} {} - -test font-20.1 {Tk_GetFontMetrics procedure} { - button .b.w1 -text abc - entry .b.w2 -text abcd - update - destroy .b.w1 .b.w2 -} {} - -proc psfontname {name} { - set a [.b.c itemcget text -font] - .b.c itemconfig text -text "We need text" -font $name - set post [.b.c postscript] - .b.c itemconfig text -font $a - set end [string first "findfont" $post] - incr end -2 - set post [string range $post [expr $end-70] $end] - set start [string first "gsave" $post] - return [string range $post [expr $start+7] end] -} -test font-21.1 {Tk_PostscriptFontName procedure: native} {unixOnly} { - set x [font actual {{itc avant garde} 10} -family] - if {[string match *avant*garde $x]} { - psfontname "{itc avant garde} 10" - } else { - set x {AvantGarde-Book} - } -} {AvantGarde-Book} -test font-21.2 {Tk_PostscriptFontName procedure: native} {pcOnly} { - psfontname "arial 10" -} {Helvetica} -test font-21.3 {Tk_PostscriptFontName procedure: native} {pcOnly} { - psfontname "{times new roman} 10" -} {Times-Roman} -test font-21.4 {Tk_PostscriptFontName procedure: native} {pcOnly} { - psfontname "{courier new} 10" -} {Courier} -test font-21.5 {Tk_PostscriptFontName procedure: native} {macOnly} { - psfontname "geneva 10" -} {Helvetica} -test font-21.6 {Tk_PostscriptFontName procedure: native} {macOnly} { - psfontname "{new york} 10" -} {Times-Roman} -test font-21.7 {Tk_PostscriptFontName procedure: native} {macOnly} { - psfontname "monaco 10" -} {Courier} -test font-21.8 {Tk_PostscriptFontName procedure: spaces} {unixOnly} { - set x [font actual {{lucida bright} 10} -family] - if {[string match lucida*bright $x]} { - psfontname "{lucida bright} 10" - } else { - set x {LucidaBright} - } -} {LucidaBright} -test font-21.9 {Tk_PostscriptFontName procedure: spaces} {unixOnly} { - psfontname "{new century schoolbook} 10" -} {NewCenturySchlbk-Roman} -set i 10 -foreach p { - {"avantgarde" AvantGarde-Book AvantGarde-Demi AvantGarde-BookOblique AvantGarde-DemiOblique} - {"bookman" Bookman-Light Bookman-Demi Bookman-LightItalic Bookman-DemiItalic} - {"courier" Courier Courier-Bold Courier-Oblique Courier-BoldOblique} - {"helvetica" Helvetica Helvetica-Bold Helvetica-Oblique Helvetica-BoldOblique} - {"new century schoolbook" NewCenturySchlbk-Roman NewCenturySchlbk-Bold NewCenturySchlbk-Italic NewCenturySchlbk-BoldItalic} - {"palatino" Palatino-Roman Palatino-Bold Palatino-Italic Palatino-BoldItalic} - {"symbol" Symbol Symbol Symbol Symbol} - {"times" Times-Roman Times-Bold Times-Italic Times-BoldItalic} - {"zapfchancery" ZapfChancery-MediumItalic ZapfChancery-MediumItalic ZapfChancery-MediumItalic ZapfChancery-MediumItalic} - {"zapfdingbats" ZapfDingbats ZapfDingbats ZapfDingbats ZapfDingbats} -} { - test font-21.$i {Tk_PostscriptFontName procedure: exhaustive} {unixOnly} { - set family [lindex $p 0] - set x {} - set i 1 - foreach slant {roman italic} { - foreach weight {normal bold} { - set name [list $family 12 $slant $weight] - if {[font actual $name -family] == $family} { - lappend x [psfontname $name] - } else { - lappend x [lindex $p $i] - } - incr i - } - } - incr i - set x - } [lrange $p 1 end] -} -foreach p { - {"arial" Helvetica Helvetica-Bold Helvetica-Oblique Helvetica-BoldOblique} - {"courier new" Courier Courier-Bold Courier-Oblique Courier-BoldOblique} - {"helvetica" Helvetica Helvetica-Bold Helvetica-Oblique Helvetica-BoldOblique} - {"symbol" Symbol Symbol-Bold Symbol-Italic Symbol-BoldItalic} - {"times new roman" Times-Roman Times-Bold Times-Italic Times-BoldItalic} -} { - test font-21.$i {Tk_PostscriptFontName procedure: exhaustive} {pcOnly} { - set family [lindex $p 0] - set x {} - foreach slant {roman italic} { - foreach weight {normal bold} { - lappend x [psfontname [list $family 12 "$slant $weight"]] - } - } - incr i - set x - } [lrange $p 1 end] -} -foreach p { - {"courier" Courier Courier-Bold Courier-Oblique Courier-BoldOblique} - {"geneva" Helvetica Helvetica-Bold Helvetica-Oblique Helvetica-BoldOblique} - {"helvetica" Helvetica Helvetica-Bold Helvetica-Oblique Helvetica-BoldOblique} - {"monaco" Courier Courier-Bold Courier-Oblique Courier-BoldOblique} - {"new york" Times-Roman Times-Bold Times-Italic Times-BoldItalic} - {"symbol" Symbol Symbol-Bold Symbol-Italic Symbol-BoldItalic} - {"times" Times-Roman Times-Bold Times-Italic Times-BoldItalic} -} { - test font-21.$i {Tk_PostscriptFontName procedure: exhaustive} {macOnly} { - set family [lindex $p 0] - set x {} - foreach slant {roman italic} { - foreach weight {normal bold} { - lappend x [psfontname [list $family 12 $slant $weight]] - } - } - incr i - set x - } [lrange $p 1 end] -} - -test font-22.1 {Tk_TextWidth procedure} { - font measure [.b.l cget -font] "000" -} [expr $ax*3] - -test font-23.1 {Tk_UnderlineChars procedure} { - text .b.t - .b.t insert 1.0 abc\tdefg - .b.t tag config sel -underline 1 - .b.t tag add sel 1.0 end - update -} {} - -setup -test font-24.1 {Tk_ComputeTextLayout: empty string} { - .b.l config -text "" -} {} -test font-24.2 {Tk_ComputeTextLayout: simple string} { - .b.l config -text "000" - getsize -} "[expr $ax*3] $ay" -test font-24.3 {Tk_ComputeTextLayout: find special chars} { - .b.l config -text "000\n000" - getsize -} "[expr $ax*3] [expr $ay*2]" -test font-24.4 {Tk_ComputeTextLayout: calls Tk_MeasureChars} { - .b.l config -text "000\n000" - getsize -} "[expr $ax*3] [expr $ay*2]" -test font-24.5 {Tk_ComputeTextLayout: break line} { - .b.l config -text "000\t00000" -wrap [expr 9*$ax] - set x [getsize] - .b.l config -wrap 0 - set x -} "[expr 8*$ax] [expr 2*$ay]" -test font-24.6 {Tk_ComputeTextLayout: normal ended on special char} { - .b.l config -text "000\n000" -} {} -test font-24.7 {Tk_ComputeTextLayout: special char was \n} { - .b.l config -text "000\n0000" - getsize -} "[expr $ax*4] [expr $ay*2]" -test font-24.8 {Tk_ComputeTextLayout: special char was \t} { - .b.l config -text "000\t00" - getsize -} "[expr $ax*10] $ay" -test font-24.9 {Tk_ComputeTextLayout: tab didn't cause break} { - set x {} - .b.l config -text "000\t000" - lappend x [getsize] - .b.l config -text "000\t000" -wrap [expr 100*$ax] - lappend x [getsize] - .b.l config -wrap 0 - set x -} "{[expr $ax*11] $ay} {[expr $ax*11] $ay}" -test font-24.10 {Tk_ComputeTextLayout: tab caused break} { - set x {} - .b.l config -text "000\t" - lappend x [getsize] - .b.l config -text "000\t00" -wrap [expr $ax*6] - lappend x [getsize] - .b.l config -wrap 0 - set x -} "{[expr $ax*3] $ay} {[expr $ax*3] [expr $ay*2]}" -test font-24.11 {Tk_ComputeTextLayout: absorb spaces at eol} { - set x {} - .b.l config -text "000 000" -wrap [expr $ax*5] - lappend x [getsize] - .b.l config -text "000 " - lappend x [getsize] - .b.l config -wrap 0 - set x -} "{[expr $ax*3] [expr $ay*2]} {[expr $ax*3] $ay}" -test font-24.12 {Tk_ComputeTextLayout: append non-printing spaces to chunk} { - set x {} - .b.l config -text "000 0000" -wrap [expr $ax*5] - lappend x [getsize] - .b.l config -text "000\t00 0000" -wrap [expr $ax*12] - lappend x [getsize] - .b.l config -wrap 0 - set x -} "{[expr $ax*4] [expr $ay*2]} {[expr $ax*10] [expr $ay*2]}" -test font-24.13 {Tk_ComputeTextLayout: many lines -> realloc line array} { - .b.l config -text "\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n" - getsize -} "1 [expr $ay*129]" -test font-24.14 {Tk_ComputeTextLayout: text ended with \n} { - list [.b.l config -text "0000"; getsize] [.b.l config -text "0000\n"; getsize] -} "{[expr $ax*4] $ay} {[expr $ax*4] [expr $ay*2]}" -test font-24.15 {Tk_ComputeTextLayout: justification} { - csetup "000\n00000" - set x {} - .b.c itemconfig text -just left - lappend x [.b.c index text @[expr $ax*2],0] - .b.c itemconfig text -just center - lappend x [.b.c index text @[expr $ax*2],0] - .b.c itemconfig text -just right - lappend x [.b.c index text @[expr $ax*2],0] - .b.c itemconfig text -just left - set x -} {2 1 0} - -test font-25.1 {Tk_FreeTextLayout procedure} { - setup - .b.f config -text foo - .b.f config -text boo -} {} - -test font-26.1 {Tk_DrawTextLayout procedure: auto-detect last char} { - .b.f config -text foo -} {} -test font-26.2 {Tk_DrawTextLayout procedure: multiple chunks} { - csetup "000\t00\n000" -} {} -test font-26.3 {Tk_DrawTextLayout: draw subset of chunk: numDisplay <= 0} { - csetup "000\t00" - .b.c select from text 3 - .b.c select to text 5 -} {} -test font-26.4 {Tk_DrawTextLayout: draw subset of chunk: firstChar <= 0} { - .b.c select from text 3 - .b.c select to text 5 -} {} -test font-26.5 {Tk_DrawTextLayout: draw subset of chunk: firstChar > 0} { - .b.c select from text 2 - .b.c select to text 2 -} {} -test font-26.6 {Tk_DrawTextLayout: draw subset of chunk: lastChar < numChars} { - .b.c select from text 4 - .b.c select to text 4 -} {} - -test font-27.1 {Tk_UnderlineTextLayout procedure: no underline chosen} { - .b.f config -text "foo" -under -1 -} {} -test font-27.2 {Tk_UnderlineTextLayout procedure: underline not visible} { - .b.f config -text "000 00000" -wrap [expr $ax*7] -under 10 -} {} -test font-27.3 {Tk_UnderlineTextLayout procedure: underline is visible} { - .b.f config -text "000 00000" -wrap [expr $ax*7] -under 5 - .b.f config -wrap -1 -under -1 -} {} - -test font-28.1 {Tk_PointToChar procedure: above all lines} { - csetup "000" - .b.c index text @-1,0 -} {0} -test font-28.2 {Tk_PointToChar procedure: no chars} { - # After fixing the following bug: - # - # In canvas text item, it was impossible to click to position the - # insertion point just after the last character. - # - # introduced another bug that Tk_PointToChar() would return a character - # index of 1 if TextLayout contained 0 characters. - - csetup "" - .b.c index text @100,100 -} {0} -test font-28.3 {Tk_PointToChar procedure: loop test} { - csetup "000\n000\n000\n000" - .b.c index text @10000,0 -} {3} -test font-28.4 {Tk_PointToChar procedure: intersect line} { - csetup "000\n000\n000" - .b.c index text @0,$ay -} {4} -test font-28.5 {Tk_PointToChar procedure: to the left of all chunks} { - .b.c index text @-100,$ay -} {4} -test font-28.6 {Tk_PointToChar procedure: past any possible chunk} { - .b.c index text @100000,$ay -} {7} -test font-28.7 {Tk_PointToChar procedure: which chunk on this line} { - csetup "000\n000\t000\t000\n000" - .b.c index text @[expr $ax*2],$ay -} {6} -test font-28.8 {Tk_PointToChar procedure: which chunk on this line} { - csetup "000\n000\t000\t000\n000" - .b.c index text @[expr $ax*10],$ay -} {10} -test font-28.9 {Tk_PointToChar procedure: in special chunk} { - csetup "000\n000\t000\t000\n000" - .b.c index text @[expr $ax*6],$ay -} {7} -test font-28.10 {Tk_PointToChar procedure: past all chars in chunk} { - csetup "000 0000000" - .b.c itemconfig text -width [expr $ax*5] - set x [.b.c index text @[expr $ax*5],0] - .b.c itemconfig text -width 0 - set x -} {3} -test font-28.11 {Tk_PointToChar procedure: below all chunks} { - csetup "000 0000000" - .b.c index text @0,1000000 -} {11} - -test font-29.1 {Tk_CharBBox procedure: index < 0} { - .b.f config -text "000" -underline -1 -} {} -test font-29.2 {Tk_CharBBox procedure: loop} { - .b.f config -text "000\t000\t000\t000" -underline 9 -} {} -test font-29.3 {Tk_CharBBox procedure: special char} { - .b.f config -text "000\t000\t000" -underline 7 -} {} -test font-29.4 {Tk_CharBBox procedure: normal char} { - .b.f config -text "000" -underline 1 -} {} -test font-29.5 {Tk_CharBBox procedure: right edge of bbox truncated} { - .b.f config -text "0 0000" -wrap [expr $ax*4] -under 2 - .b.f config -wrap 0 -} {} -test font-29.6 {Tk_CharBBox procedure: bbox pegged to right edge} { - .b.f config -text "0 0000" -wrap [expr $ax*4] -under 3 - .b.f config -wrap 0 -} {} - -.b.c bind all <Enter> {lappend x [.b.c index current @%x,%y]} - -test font-30.1 {Tk_DistanceToTextLayout procedure: loop once} { - csetup "000\n000\n000" - set x {} - event generate .b.c <Leave> - event generate .b.c <Enter> -x 0 -y 0 - set x -} {0} -test font-30.2 {Tk_DistanceToTextLayout procedure: loop multiple} { - csetup "000\n000\n000" - set x {} - event generate .b.c <Leave> - event generate .b.c <Enter> -x $ax -y $ay - set x -} {5} -test font-30.3 {Tk_DistanceToTextLayout procedure: loop to end} { - csetup "000\n0\n000" - set x {} - event generate .b.c <Leave> - event generate .b.c <Enter> -x [expr $ax*2] -y $ay - set x -} {} -test font-30.4 {Tk_DistanceToTextLayout procedure: hit a special char (tab)} { - csetup "000\t000\n000" - set x {} - event generate .b.c <Leave> - event generate .b.c <Enter> -x [expr $ax*6] -y 0 - set x -} {3} -test font-30.5 {Tk_DistanceToTextLayout procedure: ignore newline} { - csetup "000\n0\n000" - set x {} - event generate .b.c <Leave> - event generate .b.c <Enter> -x [expr $ax*2] -y $ay - set x -} {} -test font-30.6 {Tk_DistanceToTextLayout procedure: ignore spaces at eol} { - csetup "000\n000 000000000" - .b.c itemconfig text -width [expr $ax*10] - set x {} - event generate .b.c <Leave> - event generate .b.c <Enter> -x [expr $ax*5] -y $ay - .b.c itemconfig text -width 0 - set x -} {} -.b.c itemconfig text -justify center -test font-30.7 {Tk_DistanceToTextLayout procedure: on left side} { - csetup "0\n000" - set x {} - event generate .b.c <Leave> - event generate .b.c <Enter> -x 0 -y 0 - set x -} {} -test font-30.8 {Tk_DistanceToTextLayout procedure: on right side} { - csetup "0\n000" - set x {} - event generate .b.c <Leave> - event generate .b.c <Enter> -x [expr $ax*2] -y 0 - set x -} {} -test font-30.9 {Tk_DistanceToTextLayout procedure: inside line} { - csetup "0\n000" - set x {} - event generate .b.c <Leave> - event generate .b.c <Enter> -x $ax -y 0 - set x -} {0} -test font-30.10 {Tk_DistanceToTextLayout procedure: above line} { - csetup "0\n000" - set x {} - event generate .b.c <Leave> - event generate .b.c <Enter> -x 0 -y 0 - set x -} {} -test font-30.11 {Tk_DistanceToTextLayout procedure: below line} { - csetup "000\n0" - set x {} - event generate .b.c <Leave> - event generate .b.c <Enter> -x 0 -y $ay - set x -} {} -test font-30.12 {Tk_DistanceToTextLayout procedure: in line} { - csetup "0\n000" - set x {} - event generate .b.c <Leave> - event generate .b.c <Enter> -x $ax -y $ay - set x -} {3} -.b.c itemconfig text -justify left -test font-30.13 {Tk_DistanceToTextLayout procedure: exact hit} { - csetup "000" - set x {} - event generate .b.c <Leave> - event generate .b.c <Enter> -x $ax -y 0 - set x -} {1} - -test font-31.1 {Tk_IntersectTextLayout procedure: loop once} { - csetup "000\n000\n000" - .b.c find overlapping 0 0 0 0 -} [.b.c find withtag text] -test font-31.2 {Tk_IntersectTextLayout procedure: loop multiple} { - csetup "000\t000\t000" - .b.c find overlapping [expr $ax*10] 0 [expr $ax*10] 0 -} [.b.c find withtag text] -test font-31.3 {Tk_IntersectTextLayout procedure: loop to end} { - csetup "0\n000" - .b.c find overlapping [expr $ax*2] 0 [expr $ax*2] 0 -} {} -test font-31.4 {Tk_IntersectTextLayout procedure: hit a special char (tab)} { - csetup "000\t000" - .b.c find overlapping [expr $ax*6] 0 [expr $ax*6] 0 -} [.b.c find withtag text] -test font-31.5 {Tk_IntersectTextLayout procedure: ignore newlines} { - csetup "000\n0\n000" - .b.c find overlapping $ax $ay $ax $ay -} {} -test font-31.6 {Tk_IntersectTextLayout procedure: ignore spaces at eol} { - csetup "000\n000 000000000" - .b.c itemconfig text -width [expr $ax*10] - set x [.b.c find overlapping [expr $ax*5] $ay [expr $ax*5] $ay] - .b.c itemconfig text -width 0 - set x -} {} - -test font-32.1 {Tk_TextLayoutToPostscript: ensure buffer doesn't overflow} { - # If there were a whole bunch of returns or tabs in a row, then the - # temporary buffer could overflow and write on the stack. - - csetup "qwertyuiopasdfghjklzxcvbnm1234qwertyuiopasdfghjklzxcvbnm\n" - .b.c itemconfig text -width 800 - .b.c insert text end "qwertyuiopasdfghjklzxcvbnm1234qwertyuiopasdfghjklzxcvbnm\n" - .b.c insert text end "\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n" - .b.c insert text end "end" - set x [.b.c postscript] - set i [string first "(qwerty" $x] - string range $x $i [expr {$i + 278}] -} {(qwertyuiopasdfghjklzxcvbnm1234qwertyuiopasdfghjklzxcvbnm)] -[(qwertyuiopasdfghjklzxcvbnm1234qwertyuiopasdfghjklzxcvbnm)] -[()] -[()] -[()] -[()] -[()] -[()] -[()] -[()] -[()] -[()] -[()] -[()] -[()] -[()] -[()] -[()] -[()] -[()] -[()] -[()] -[()] -[()] -[()] -[()] -[()] -[()] -[()] -[()] -[()] -[()] -[(end)] -} - -test font-33.1 {Tk_TextWidth procedure} { -} {} - -test font-33.2 {ConfigAttributesObj procedure: arguments} { - # (Tcl_GetIndexFromObj() != TCL_OK) - setup - list [catch {font create xyz -xyz} msg] $msg -} {1 {bad option "-xyz": must be -family, -size, -weight, -slant, -underline, or -overstrike}} -test font-34.1 {ConfigAttributesObj procedure: arguments} { - # (objc & 1) - setup - list [catch {font create xyz -family} msg] $msg -} {1 {value for "-family" option missing}} -set i 3 -foreach p { - {family xyz times} - {size 20 40} - {weight normal bold} - {slant roman italic} - {underline 0 1} - {overstrike 0 1} -} { - set opt [lindex $p 0] - test font-34.$i "ConfigAttributesObj procedure: $opt" { - setup - set x {} - font create xyz -$opt [lindex $p 1] - lappend x [font config xyz -$opt] - font config xyz -$opt [lindex $p 2] - lappend x [font config xyz -$opt] - } [lrange $p 1 2] - incr i -} -foreach p { - {size xyz {1 {expected integer but got "xyz"}}} - {weight xyz {1 {bad -weight value "xyz": must be normal, or bold}}} - {slant xyz {1 {bad -slant value "xyz": must be roman, or italic}}} - {underline xyz {1 {expected boolean value but got "xyz"}}} - {overstrike xyz {1 {expected boolean value but got "xyz"}}} -} { - test font-34.$i "ConfigAttributesObj procedure: [lindex $p 0]" { - setup - list [catch {font create xyz -[lindex $p 0] [lindex $p 1]} msg] $msg - } [lindex $p 2] - incr i -} - -test font-35.1 {GetAttributeInfoObj procedure: one attribute} { - # (objPtr != NULL) - setup - font create xyz -family xyz - font config xyz -family -} {xyz} -test font-36.1 {GetAttributeInfoObj procedure: unknown attribute} { - # (Tcl_GetIndexFromObj() != TCL_OK) - setup - font create xyz - list [catch {font config xyz -xyz} msg] $msg -} {1 {bad option "-xyz": must be -family, -size, -weight, -slant, -underline, or -overstrike}} -test font-37.1 {GetAttributeInfoObj procedure: all attributes} { - # not (objPtr != NULL) - setup - font create xyz -family xyz - font config xyz -} {-family xyz -size 0 -weight normal -slant roman -underline 0 -overstrike 0} -set i 4 -foreach p { - {family xyz xyz} - {size 20 20} - {weight normal normal} - {slant italic italic} - {underline yes 1} - {overstrike false 0} -} { - test font-31.$i "GetAttributeInfo procedure: [lindex $p 0]" { - setup - font create xyz -[lindex $p 0] [lindex $p 1] - font config xyz -[lindex $p 0] - } [lindex $p 2] - incr i -} - -# In tests below, one field is set to "xyz" so that font name doesn't -# look like a native X font, so that ParseFontNameObj or TkParseXLFD will -# be called. - -setup - -test font-38.1 {ParseFontNameObj procedure: begins with -} { - lindex [font actual -xyz-times-*-*-*-*-*-*-*-*-*-*-*-*] 1 -} $times -test font-38.2 {ParseFontNameObj procedure: begins with -*} { - lindex [font actual -*-times-xyz-*-*-*-*-*-*-*-*-*-*-*] 1 -} $times -test font-38.3 {ParseFontNameObj procedure: begins with -, doesn't look like list} { - lindex [font actual -xyz-times-*-*-*-*-*-*-*-*-*-*-*-*] 1 -} $times -test font-38.4 {ParseFontNameObj procedure: begins with -, looks like list} { - lindex [font actual {-family times}] 1 -} $times -test font-38.5 {ParseFontNameObj procedure: begins with *} { - lindex [font actual *-times-xyz-*-*-*-*-*-*-*-*-*-*-*] 1 -} $times -test font-38.6 {ParseFontNameObj procedure: begins with *} { - font actual *-times-xyz -family -} $times -test font-38.7 {ParseFontNameObj procedure: arguments} {noExceed} { - list [catch {font actual "\{xyz"} msg] $msg -} [list 1 "font \"{xyz\" doesn't exist"] -test font-38.8 {ParseFontNameObj procedure: arguments} {noExceed} { - list [catch {font actual ""} msg] $msg -} {1 {font "" doesn't exist}} -test font-38.9 {ParseFontNameObj procedure: arguments} { - list [catch {font actual {times 20 xyz xyz}} msg] $msg -} {1 {unknown font style "xyz"}} -test font-38.10 {ParseFontNameObj procedure: arguments} { - list [catch {font actual {times xyz xyz}} msg] $msg -} {1 {expected integer but got "xyz"}} -test font-38.11 {ParseFontNameObj procedure: stylelist loop} {macOnly} { - lrange [font actual {times 12 bold italic overstrike underline}] 4 end -} {-weight bold -slant italic -underline 1 -overstrike 0} -test font-38.12 {ParseFontNameObj procedure: stylelist loop} {unixOrPc} { - lrange [font actual {times 12 bold italic overstrike underline}] 4 end -} {-weight bold -slant italic -underline 1 -overstrike 1} -test font-38.13 {ParseFontNameObj procedure: stylelist error} { - list [catch {font actual {times 12 bold xyz}} msg] $msg -} {1 {unknown font style "xyz"}} - -test font-39.1 {NewChunk procedure: test realloc} { - .b.f config -text "xxx\nxxx\txxx\nxxx\t\t\t" -} {} - -test font-40.1 {TkFontParseXLFD procedure: initial dash} { - font actual -xyz-times-*-*-*-*-*-*-*-*-*-*-*-* -family -} $times -test font-40.2 {TkFontParseXLFD procedure: no initial dash} { - font actual *-times-*-*-*-*-*-*-*-*-*-*-*-xyz -family -} $times -test font-40.3 {TkFontParseXLFD procedure: not enough fields} { - font actual -xyz-times-*-*-* -family -} $times -test font-40.4 {TkFontParseXLFD procedure: all fields unspecified} { - lindex [font actual -xyz-*-*-*-*-*-*-*-*-*-*-*-*-*] 0 -} {-family} -test font-40.5 {TkFontParseXLFD procedure: all fields specified} { - lindex [font actual -foundry-times-weight-slant-setwidth-addstyle-10-10-10-10-spacing-avgwidth-registry-encoding] 1 -} $times -test font-41.1 {TkParseXLFD procedure: arguments} { - # XLFD with bad pointsize: fallback to some system font. - font actual -*-*-*-*-*-*-xyz-*-*-*-*-*-*-* - set x {} -} {} -test font-42.1 {TkFontParseXLFD procedure: arguments} { - # XLFD with bad pixelsize: fallback to some system font. - font actual -*-*-*-*-*-*-*-xyz-*-*-*-*-*-* - set x {} -} {} -test font-42.2 {TkFontParseXLFD procedure: pixelsize specified} { - font metrics -xyz-times-*-*-*-*-12-*-*-*-*-*-*-* -linespace - set x {} -} {} -test font-42.3 {TkFontParseXLFD procedure: weird pixelsize specified} { - font metrics {-xyz-times-*-*-*-*-[ 12.0 0 12.0 0]-*-*-*-*-*-*-*} -linespace - set x {} -} {} -test font-42.4 {TkFontParseXLFD procedure: pointsize specified} { - font metrics -xyz-times-*-*-*-*-*-120-*-*-*-*-*-* -linespace - set x {} -} {} -test font-42.5 {TkFontParseXLFD procedure: weird pointsize specified} { - font metrics {-xyz-times-*-*-*-*-*-[ 12.0 0 12.0 0]-*-*-*-*-*-*} -linespace - set x {} -} {} - -test font-43.1 {FieldSpecified procedure: specified vs. non-specified} { - font actual -xyz--*-*-*-*-*-*-*-*-*-*-*-* - font actual -xyz-*-*-*-*-*-*-*-*-*-*-*-*-* - font actual -xyz-?-*-*-*-*-*-*-*-*-*-*-*-* - lindex [font actual -xyz-times-*-*-*-*-*-*-*-*-*-*-*-*] 1 -} $times - -set oldscale [tk scaling] -tk scaling 0.5 -test font-44.1 {TkFontGetPixels: size < 0} { - font actual {times -12} -size -} {24} -test font-44.2 {TkFontGetPoints: size >= 0} {noExceed} { - font actual {times 12} -size -} {12} - -tk scaling $oldscale - -test font-45.1 {TkFontGetAliasList: no match} { - font actual {snarky 10} -family -} [font actual {-size 10} -family] -test font-45.2 {TkFontGetAliasList: match} {macOnly} { - # Result could be either "Times" or "New York" - font actual {{times new roman} 10} -family -} [font actual {times 10} -family] -test font-45.3 {TkFontGetAliasList: match} {pcOnly} { - font actual {times 10} -family -} {Times New Roman} -test font-45.4 {TkFontGetAliasList: match} {unixOnly noExceed} { - # can fail on Unix systems that have a real "times new roman" font - font actual {{times new roman} 10} -family -} [font actual {times 10} -family] - -setup - -destroy .b - -# cleanup -::tcltest::cleanupTests -return - - - - - - - - - - - - - |