diff options
Diffstat (limited to 'tests/font.test')
| -rw-r--r-- | tests/font.test | 873 |
1 files changed, 585 insertions, 288 deletions
diff --git a/tests/font.test b/tests/font.test index 909085b..264dee5 100644 --- a/tests/font.test +++ b/tests/font.test @@ -1,16 +1,21 @@ # 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 fashion for Tcl tests. +# standard white-box fashion for Tcl tests. # -# Copyright (c) 1996 Sun Microsystems, Inc. +# Copyright (c) 1996-1998 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# All rights reserved. # -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: font.test,v 1.3 1998/09/14 18:23:47 stanton Exp $ +# RCS: @(#) $Id: font.test,v 1.4 1999/04/16 01:51:37 stanton Exp $ + +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} -if {[string compare test [info procs test]] != 0} { - source defs +if {[info commands testfont] != "testfont"} { + puts "testfont command not available; skipping tests" + ::tcltest::cleanupTests + return } catch {destroy .b} @@ -20,7 +25,7 @@ update idletasks proc setup {} { catch {destroy .b.f} - catch {font delete xyz} + catch {eval font delete [font names]} label .b.f pack .b.f update @@ -56,243 +61,357 @@ case $tcl_platform(platform) { } set times [font actual {times 0} -family] -test font-1.1 {font command: general} { +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-1.2 {font command: actual: arguments} { +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-1.3 {font command: actual: arguments} { +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-1.4 {font command: actual: arguments} { +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-1.5 {font command: actual: arguments} { - list [catch {font actual {}} msg] $msg -} {1 {font "" doesn't exist}} -test font-1.6 {font command: actual: displayof specified, so skip to next} { +test font-4.4 {font command: actual: displayof specified, so skip to next} { catch {font actual xyz -displayof . -size} } {0} -test font-1.7 {font command: actual: displayof specified, so skip to next} { +test font-4.5 {font command: actual: displayof specified, so skip to next} { lindex [font actual xyz -displayof .] 0 } {-family} -test font-1.8 {font command: actual} {unix || mac} { +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} { + # (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} { + # (objc > 3) so objPtr = objv[3 + skip] string tolower [font actual {-family times} -family] } {times} -test font-1.9 {font command: actual} {pcOnly} { +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-1.10 {font command: actual} { - lindex [font actual {-family times}] 0 -} {-family} -test font-1.11 {font command: bad option} { +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-2.1 {font command: configure} { +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-2.2 {font command: configure: non-existent font} { +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-2.3 {font command: configure: "deleted" font} { +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-2.4 {font command: configure: get all options} { +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-2.5 {font command: configure: get one option} { +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-2.6 {font command: configure: update existing font} { +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-2.7 {font command: configure: bad option} { +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-3.1 {font command: create: make up name} { - font delete [font create] - font delete [font create -family xyz] -} {} -test font-3.2 {font command: create: already exists} { +test font-6.1 {font command: create: make up name} { + # (objc < 3) so name = NULL setup - font create xyz - list [catch {font create xyz} msg] $msg -} {1 {font "xyz" already exists}} -test font-3.3 {font command: create: error recreating "deleted" font} { + font create + font names +} {font1} +test font-6.2 {font command: create: name specified} { + # not (objc < 3) setup font create xyz - .b.f configure -font xyz - font delete xyz - list [catch {font create xyz -xyz times} msg] $msg -} {1 {bad option "-xyz": must be -family, -size, -weight, -slant, -underline, or -overstrike}} -test font-3.4 {font command: create: recreate "deleted" font} { + font names +} {xyz} +test font-6.3 {font command: create: name not really specified} { + # (name[0] == '-') so name = NULL setup - font create xyz - .b.f configure -font xyz - font delete xyz - font actual xyz - font create xyz -family times - update - font configure xyz -family -} {times} -test font-3.5 {font command: create: bad option creating new font} { + 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-3.6 {font command: create: totally new font} { +test font-6.6 {font command: create: bad option creating new font} { + # name was not specified so skip = 2 setup - font create xyz -family xyz - font configure xyz -family -} {xyz} + 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-4.1 {font command: delete: arguments} { +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-4.2 {font command: delete: loop test} { +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 delete a b c - list [font actual a -underline] [font actual b -underline] [font actual c -underline] -} {0 0 0} -test font-4.3 {font command: delete: non-existent} { + 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-4.4 {font command: delete: mark for later deletion} { +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 -} {1 {named font "xyz" doesn't exist}} -test font-4.5 {font command: delete: actually delete} { + 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 - font actual xyz -underline -} {0} + catch {font config xyz} +} {1} +setup -test font-5.1 {font command: families: arguments} { +test font-8.1 {font command: families: arguments} { + # (skip < 0) list [catch {font families -displayof} msg] $msg } {1 {value for "-displayof" missing}} -test font-5.2 {font command: families: arguments} { +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-5.3 {font command: families} { - font families - set x {} -} {} +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-6.1 {font command: measure: arguments} { +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-6.2 {font command: measure: arguments} { +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-6.3 {font command: measure: arguments} { +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-6.4 {font command: measure: arguments} { - list [catch {font measure {} abc} msg] $msg -} {1 {font "" doesn't exist}} -test font-6.5 {font command: measure} { +test font-9.4 {font command: measure: arguments} { + # (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-7.1 {font command: metrics: arguments} { +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-7.2 {font command: metrics: arguments} { +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-7.3 {font command: metrics: get all metrics} { +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} { + # (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-7.4 {font command: metrics: get ascent} { - catch {expr [font metrics $fixed -ascent]} -} {0} -test font-7.5 {font command: metrics: get descent} { - catch {expr [font metrics {-family xyz} -descent]} -} {0} -test font-7.6 {font command: metrics: get linespace} { - catch {expr [font metrics {-family fixed} -linespace]} -} {0} -test font-7.7 {font command: metrics: get fixed} { - catch {expr [font metrics {-family fixed} -fixed]} -} {0} -test font-7.8 {font command: metrics: get ascent} { - catch {expr [font metrics {-family xyz} -ascent]} -} {0} -test font-7.9 {font command: metrics: get descent} { - catch {expr [font metrics {-family xyz} -descent]} -} {0} -test font-7.10 {font command: metrics: get linespace} { - catch {expr [font metrics {-family fixed} -linespace]} -} {0} -test font-7.11 {font command: metrics: get fixed} { - catch {expr [font metrics {-family fixed} -fixed]} -} {0} -test font-7.12 {font command: metrics: bad metric} { - list [catch {font metrics {-family fixed} -xyz} msg] $msg +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-8.1 {font command: names: arguments} { +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-8.2 {font command: 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 - set x [lsort [font names]] - font delete abc - font delete xyz - set x -} {abc xyz} -test font-8.3 {font command: names} { + 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 - set x [lsort [font names]] + lappend x [lsort [font names]] .b.f config -font xyz font delete xyz lappend x [font names] - font delete abc - set x -} {abc xyz abc} +} {{abc xyz} abc} -test font-9.1 {font command: unknown option} { - list [catch {font xyz} msg] $msg -} {1 {bad option "xyz": must be actual, configure, create, delete, families, measure, metrics, or names}} - -test font-10.1 {UpdateDependantFonts procedure: no users} { +test font-12.1 {UpdateDependantFonts procedure: no users} { + # (nfPtr->refCount == 0) setup font create xyz font configure xyz -family times } {} -test font-10.2 {UpdateDependantFonts procedure: pings the widgets} { +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 @@ -306,56 +425,155 @@ test font-10.2 {UpdateDependantFonts procedure: pings the widgets} { expr {$a1==$b1 && $a2==$b2} } {1} -test font-11.1 {Tk_GetFont procedure: bump ref count} { +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} { + 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} { + 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} { + 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-11.2 {Tk_GetFont procedure: bump ref count of named font, too} { +test font-15.5 {Tk_AllocFontFromObj procedure: get named font} { + # (namedHashPtr != NULL) setup - font create xyz - .b.f config -font xyz - lindex [font actual xyz] 0 -} {-family} -test font-11.3 {Tk_GetFont procedure: get named font} { + font create xyz + .b.f config -font xyz +} {} +test font-15.6 {Tk_AllocFontFromObj procedure: not a named font} { + # not (namedHashPtr != NULL) setup - font create xyz - .b.f config -font xyz + .b.f config -font {times 20} } {} -test font-11.4 {Tk_GetFont procedure: get native font} {unixOnly} { +test font-15.7 {Tk_AllocFontFromObj procedure: get native font} {unixOnly} { + # not (fontPtr == NULL) setup .b.f config -font fixed } {} -test font-11.5 {Tk_GetFont procedure: get native font} {pcOnly} { +test font-15.8 {Tk_AllocFontFromObj procedure: get native font} {pcOnly} { + # not (fontPtr == NULL) setup .b.f config -font oemfixed } {} -test font-11.6 {Tk_GetFont procedure: get native font} {macOnly} { +test font-15.9 {Tk_AllocFontFromObj procedure: get native font} {macOnly} { + # not (fontPtr == NULL) setup .b.f config -font application } {} -test font-11.7 {Tk_GetFont procedure: get attribute font} { +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-11.8 {Tk_GetFont procedure: get attribute font} { +test font-15.11 {Tk_AllocFontFromObj procedure: no match} { + # (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-11.9 {Tk_GetFont procedure: no match} { - list [catch {font actual {}} msg] $msg -} {1 {font "" doesn't exist}} +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-12.1 {Tk_NameOfFont procedure} { +test font-16.1 {Tk_NameOfFont procedure} { setup - .b.f config -font {-family fixed} + .b.f config -font -family\ fixed .b.f cget -font } {-family fixed} -test font-13.1 {Tk_FreeFont procedure: one ref} { +test font-17.1 {Tk_FreeFontFromObj - reference counts} { + 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-13.2 {Tk_FreeFont procedure: multiple ref} { +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} @@ -364,14 +582,16 @@ test font-13.2 {Tk_FreeFont procedure: multiple ref} { destroy .b.b set x } {-family fixed} -test font-13.3 {Tk_FreeFont procedure: named font} { +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-13.4 {Tk_FreeFont procedure: named font} { +test font-17.5 {Tk_FreeFont procedure: named font} { + # not (fontPtr->refCount == 0) setup font create xyz -underline 1 .b.f config -font xyz @@ -380,9 +600,9 @@ test font-13.4 {Tk_FreeFont procedure: named font} { destroy .b.f list [font actual xyz -underline] $x } {0 1} -test font-13.5 {Tk_FreeFont procedure: named font not deleted yet} { +test font-17.6 {Tk_FreeFont procedure: named font not deleted yet} { setup - font create xyz + font create xyz .b.f config -font xyz button .b.b -font xyz font delete xyz @@ -391,12 +611,32 @@ test font-13.5 {Tk_FreeFont procedure: named font not deleted yet} { list [lindex [font actual xyz] 0] [lindex $x 0] } {-family -family} -test font-14.1 {Tk_FontId} { +test font-18.1 {FreeFontObjProc} { + 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-15.1 {Tk_FontMetrics procedure} { +test font-20.1 {Tk_GetFontMetrics procedure} { button .b.w1 -text abc entry .b.w2 -text abcd update @@ -414,7 +654,7 @@ proc psfontname {name} { set start [string first "gsave" $post] return [string range $post [expr $start+7] end] } -test font-16.1 {Tk_PostscriptFontName procedure: native} {unixOnly} { +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" @@ -422,25 +662,25 @@ test font-16.1 {Tk_PostscriptFontName procedure: native} {unixOnly} { set x {AvantGarde-Book} } } {AvantGarde-Book} -test font-16.2 {Tk_PostscriptFontName procedure: native} {pcOnly} { +test font-21.2 {Tk_PostscriptFontName procedure: native} {pcOnly} { psfontname "arial 10" } {Helvetica} -test font-16.3 {Tk_PostscriptFontName procedure: native} {pcOnly} { +test font-21.3 {Tk_PostscriptFontName procedure: native} {pcOnly} { psfontname "{times new roman} 10" } {Times-Roman} -test font-16.4 {Tk_PostscriptFontName procedure: native} {pcOnly} { +test font-21.4 {Tk_PostscriptFontName procedure: native} {pcOnly} { psfontname "{courier new} 10" } {Courier} -test font-16.5 {Tk_PostscriptFontName procedure: native} {macOnly} { +test font-21.5 {Tk_PostscriptFontName procedure: native} {macOnly} { psfontname "geneva 10" } {Helvetica} -test font-16.6 {Tk_PostscriptFontName procedure: native} {macOnly} { +test font-21.6 {Tk_PostscriptFontName procedure: native} {macOnly} { psfontname "{new york} 10" } {Times-Roman} -test font-16.7 {Tk_PostscriptFontName procedure: native} {macOnly} { +test font-21.7 {Tk_PostscriptFontName procedure: native} {macOnly} { psfontname "monaco 10" } {Courier} -test font-16.8 {Tk_PostscriptFontName procedure: spaces} {unixOnly} { +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" @@ -448,7 +688,7 @@ test font-16.8 {Tk_PostscriptFontName procedure: spaces} {unixOnly} { set x {LucidaBright} } } {LucidaBright} -test font-16.9 {Tk_PostscriptFontName procedure: spaces} {unixOnly} { +test font-21.9 {Tk_PostscriptFontName procedure: spaces} {unixOnly} { psfontname "{new century schoolbook} 10" } {NewCenturySchlbk-Roman} set i 10 @@ -464,7 +704,7 @@ foreach p { {"zapfchancery" ZapfChancery-MediumItalic ZapfChancery-MediumItalic ZapfChancery-MediumItalic ZapfChancery-MediumItalic} {"zapfdingbats" ZapfDingbats ZapfDingbats ZapfDingbats ZapfDingbats} } { - test font-16.$i {Tk_PostscriptFontName procedure: exhaustive} {unixOnly} { + test font-21.$i {Tk_PostscriptFontName procedure: exhaustive} {unixOnly} { set family [lindex $p 0] set x {} set i 1 @@ -490,7 +730,7 @@ foreach p { {"symbol" Symbol Symbol-Bold Symbol-Italic Symbol-BoldItalic} {"times new roman" Times-Roman Times-Bold Times-Italic Times-BoldItalic} } { - test font-16.$i {Tk_PostscriptFontName procedure: exhaustive} {pcOnly} { + test font-21.$i {Tk_PostscriptFontName procedure: exhaustive} {pcOnly} { set family [lindex $p 0] set x {} foreach slant {roman italic} { @@ -511,7 +751,7 @@ foreach p { {"symbol" Symbol Symbol-Bold Symbol-Italic Symbol-BoldItalic} {"times" Times-Roman Times-Bold Times-Italic Times-BoldItalic} } { - test font-16.$i {Tk_PostscriptFontName procedure: exhaustive} {macOnly} { + test font-21.$i {Tk_PostscriptFontName procedure: exhaustive} {macOnly} { set family [lindex $p 0] set x {} foreach slant {roman italic} { @@ -524,7 +764,11 @@ foreach p { } [lrange $p 1 end] } -test font-17.1 {Tk_UnderlineChars procedure} { +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 @@ -533,39 +777,39 @@ test font-17.1 {Tk_UnderlineChars procedure} { } {} setup -test font-18.1 {Tk_ComputeTextLayout: empty string} { +test font-24.1 {Tk_ComputeTextLayout: empty string} { .b.l config -text "" } {} -test font-18.2 {Tk_ComputeTextLayout: simple string} { +test font-24.2 {Tk_ComputeTextLayout: simple string} { .b.l config -text "000" getsize } "[expr $ax*3] $ay" -test font-18.3 {Tk_ComputeTextLayout: find special chars} { +test font-24.3 {Tk_ComputeTextLayout: find special chars} { .b.l config -text "000\n000" getsize } "[expr $ax*3] [expr $ay*2]" -test font-18.4 {Tk_ComputeTextLayout: calls Tk_MeasureChars} { +test font-24.4 {Tk_ComputeTextLayout: calls Tk_MeasureChars} { .b.l config -text "000\n000" getsize } "[expr $ax*3] [expr $ay*2]" -test font-18.5 {Tk_ComputeTextLayout: break line} { +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-18.6 {Tk_ComputeTextLayout: normal ended on special char} { +test font-24.6 {Tk_ComputeTextLayout: normal ended on special char} { .b.l config -text "000\n000" } {} -test font-18.7 {Tk_ComputeTextLayout: special char was \n} { +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-18.8 {Tk_ComputeTextLayout: special char was \t} { +test font-24.8 {Tk_ComputeTextLayout: special char was \t} { .b.l config -text "000\t00" getsize } "[expr $ax*10] $ay" -test font-18.9 {Tk_ComputeTextLayout: tab didn't cause break} { +test font-24.9 {Tk_ComputeTextLayout: tab didn't cause break} { set x {} .b.l config -text "000\t000" lappend x [getsize] @@ -574,7 +818,7 @@ test font-18.9 {Tk_ComputeTextLayout: tab didn't cause break} { .b.l config -wrap 0 set x } "{[expr $ax*11] $ay} {[expr $ax*11] $ay}" -test font-18.10 {Tk_ComputeTextLayout: tab caused break} { +test font-24.10 {Tk_ComputeTextLayout: tab caused break} { set x {} .b.l config -text "000\t" lappend x [getsize] @@ -583,7 +827,7 @@ test font-18.10 {Tk_ComputeTextLayout: tab caused break} { .b.l config -wrap 0 set x } "{[expr $ax*3] $ay} {[expr $ax*3] [expr $ay*2]}" -test font-18.11 {Tk_ComputeTextLayout: absorb spaces at eol} { +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] @@ -592,7 +836,7 @@ test font-18.11 {Tk_ComputeTextLayout: absorb spaces at eol} { .b.l config -wrap 0 set x } "{[expr $ax*3] [expr $ay*2]} {[expr $ax*3] $ay}" -test font-18.12 {Tk_ComputeTextLayout: append non-printing spaces to chunk} { +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] @@ -601,14 +845,14 @@ test font-18.12 {Tk_ComputeTextLayout: append non-printing spaces to chunk} { .b.l config -wrap 0 set x } "{[expr $ax*4] [expr $ay*2]} {[expr $ax*10] [expr $ay*2]}" -test font-18.13 {Tk_ComputeTextLayout: many lines -> realloc line array} { +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-18.14 {Tk_ComputeTextLayout: text ended with \n} { +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-18.15 {Tk_ComputeTextLayout: justification} { +test font-24.15 {Tk_ComputeTextLayout: justification} { csetup "000\n00000" set x {} .b.c itemconfig text -just left @@ -621,52 +865,52 @@ test font-18.15 {Tk_ComputeTextLayout: justification} { set x } {2 1 0} -test font-19.1 {Tk_FreeTextLayout procedure} { +test font-25.1 {Tk_FreeTextLayout procedure} { setup .b.f config -text foo .b.f config -text boo } {} -test font-20.1 {Tk_DrawTextLayout procedure: auto-detect last char} { +test font-26.1 {Tk_DrawTextLayout procedure: auto-detect last char} { .b.f config -text foo } {} -test font-20.2 {Tk_DrawTextLayout procedure: multiple chunks} { +test font-26.2 {Tk_DrawTextLayout procedure: multiple chunks} { csetup "000\t00\n000" } {} -test font-20.3 {Tk_DrawTextLayout: draw subset of chunk: numDisplay <= 0} { +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-20.4 {Tk_DrawTextLayout: draw subset of chunk: firstChar <= 0} { +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-20.5 {Tk_DrawTextLayout: draw subset of chunk: firstChar > 0} { +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-20.6 {Tk_DrawTextLayout: draw subset of chunk: lastChar < numChars} { +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-21.1 {Tk_UnderlineTextLayout procedure: no underline chosen} { +test font-27.1 {Tk_UnderlineTextLayout procedure: no underline chosen} { .b.f config -text "foo" -under -1 } {} -test font-21.2 {Tk_UnderlineTextLayout procedure: underline not visible} { +test font-27.2 {Tk_UnderlineTextLayout procedure: underline not visible} { .b.f config -text "000 00000" -wrap [expr $ax*7] -under 10 } {} -test font-21.3 {Tk_UnderlineTextLayout procedure: underline is visible} { +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-22.1 {Tk_PointToChar procedure: above all lines} { +test font-28.1 {Tk_PointToChar procedure: above all lines} { csetup "000" .b.c index text @-1,0 } {0} -test font-22.2 {Tk_PointToChar procedure: no chars} { +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 @@ -678,103 +922,103 @@ test font-22.2 {Tk_PointToChar procedure: no chars} { csetup "" .b.c index text @100,100 } {0} -test font-22.3 {Tk_PointToChar procedure: loop test} { +test font-28.3 {Tk_PointToChar procedure: loop test} { csetup "000\n000\n000\n000" .b.c index text @10000,0 } {3} -test font-22.4 {Tk_PointToChar procedure: intersect line} { +test font-28.4 {Tk_PointToChar procedure: intersect line} { csetup "000\n000\n000" .b.c index text @0,$ay } {4} -test font-22.5 {Tk_PointToChar procedure: to the left of all chunks} { +test font-28.5 {Tk_PointToChar procedure: to the left of all chunks} { .b.c index text @-100,$ay } {4} -test font-22.6 {Tk_PointToChar procedure: past any possible chunk} { +test font-28.6 {Tk_PointToChar procedure: past any possible chunk} { .b.c index text @100000,$ay } {7} -test font-22.7 {Tk_PointToChar procedure: which chunk on this line} { +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-22.8 {Tk_PointToChar procedure: which chunk on this line} { +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-22.9 {Tk_PointToChar procedure: in special chunk} { +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-22.10 {Tk_PointToChar procedure: past all chars in chunk} { +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-22.11 {Tk_PointToChar procedure: below all chunks} { +test font-28.11 {Tk_PointToChar procedure: below all chunks} { csetup "000 0000000" .b.c index text @0,1000000 } {11} -test font-23.1 {Tk_CharBBox procedure: index < 0} { +test font-29.1 {Tk_CharBBox procedure: index < 0} { .b.f config -text "000" -underline -1 } {} -test font-23.2 {Tk_CharBBox procedure: loop} { +test font-29.2 {Tk_CharBBox procedure: loop} { .b.f config -text "000\t000\t000\t000" -underline 9 } {} -test font-23.3 {Tk_CharBBox procedure: special char} { +test font-29.3 {Tk_CharBBox procedure: special char} { .b.f config -text "000\t000\t000" -underline 7 } {} -test font-23.4 {Tk_CharBBox procedure: normal char} { +test font-29.4 {Tk_CharBBox procedure: normal char} { .b.f config -text "000" -underline 1 } {} -test font-23.5 {Tk_CharBBox procedure: right edge of bbox truncated} { +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-23.6 {Tk_CharBBox procedure: bbox pegged to right edge} { +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-24.1 {Tk_TextLayoutToPoint procedure: loop once} { +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-24.2 {Tk_TextLayoutToPoint procedure: loop multiple} { +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-24.3 {Tk_TextLayoutToPoint procedure: loop to end} { +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-24.4 {Tk_TextLayoutToPoint procedure: hit a special char (tab)} { +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-24.5 {Tk_TextLayoutToPoint procedure: ignore newline} { +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-24.6 {Tk_TextLayoutToPoint procedure: ignore spaces at eol} { +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 {} @@ -784,42 +1028,42 @@ test font-24.6 {Tk_TextLayoutToPoint procedure: ignore spaces at eol} { set x } {} .b.c itemconfig text -justify center -test font-24.7 {Tk_TextLayoutToPoint procedure: on left side} { +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-24.8 {Tk_TextLayoutToPoint procedure: on right side} { +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-24.9 {Tk_TextLayoutToPoint procedure: inside line} { +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-24.10 {Tk_TextLayoutToPoint procedure: above line} { +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-24.11 {Tk_TextLayoutToPoint procedure: below line} { +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-24.12 {Tk_TextLayoutToPoint procedure: in line} { +test font-30.12 {Tk_DistanceToTextLayout procedure: in line} { csetup "0\n000" set x {} event generate .b.c <Leave> @@ -827,7 +1071,7 @@ test font-24.12 {Tk_TextLayoutToPoint procedure: in line} { set x } {3} .b.c itemconfig text -justify left -test font-24.13 {Tk_TextLayoutToPoint procedure: exact hit} { +test font-30.13 {Tk_DistanceToTextLayout procedure: exact hit} { csetup "000" set x {} event generate .b.c <Leave> @@ -835,27 +1079,27 @@ test font-24.13 {Tk_TextLayoutToPoint procedure: exact hit} { set x } {1} -test font-25.1 {Tk_TextLayoutToArea procedure: loop once} { +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-25.2 {Tk_TextLayoutToArea procedure: loop multiple} { +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-25.3 {Tk_TextLayoutToArea procedure: loop to end} { +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-25.4 {Tk_TextLayoutToArea procedure: hit a special char (tab)} { +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-25.5 {Tk_TextLayoutToArea procedure: ignore newlines} { +test font-31.5 {Tk_IntersectTextLayout procedure: ignore newlines} { csetup "000\n0\n000" .b.c find overlapping $ax $ay $ax $ay } {} -test font-25.6 {Tk_TextLayoutToArea procedure: ignore spaces at eol} { +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] @@ -863,7 +1107,7 @@ test font-25.6 {Tk_TextLayoutToArea procedure: ignore spaces at eol} { set x } {} -test font-26.1 {Tk_TextLayoutToPostscript: ensure buffer doesn't overflow} { +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. @@ -910,29 +1154,19 @@ test font-26.1 {Tk_TextLayoutToPostscript: ensure buffer doesn't overflow} { (end) } -test font-27.1 {Tk_TextWidth procedure} { - font measure [.b.l cget -font] "000" -} [expr $ax*3] - -test font-28.1 {SetupFontMetrics procedure} { - setup - .b.f config -font $fixed +test font-33.1 {Tk_TextWidth procedure} { } {} -test font-29.1 {TkInitFontAttributes procedure} { +test font-33.2 {ConfigAttributesObj procedure: arguments} { + # (Tcl_GetIndexFromObj() != TCL_OK) setup - font create xyz - font config xyz -} {-family {} -size 0 -weight normal -slant roman -underline 0 -overstrike 0} - -test font-30.1 {ConfigAttributes procedure: arguments} { + 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 {missing value for "-family" option}} -test font-30.2 {ConfigAttributes procedure: arguments} { - setup - list [catch {font create xyz -xyz xyz} msg] $msg -} {1 {bad option "-xyz": must be -family, -size, -weight, -slant, -underline, or -overstrike}} +} {1 {value for "-family" option missing}} set i 3 foreach p { {family xyz times} @@ -943,7 +1177,7 @@ foreach p { {overstrike 0 1} } { set opt [lindex $p 0] - test font-30.$i "ConfigAttributes procedure: $opt" { + test font-34.$i "ConfigAttributesObj procedure: $opt" { setup set x {} font create xyz -$opt [lindex $p 1] @@ -955,27 +1189,37 @@ foreach p { } foreach p { {size xyz {1 {expected integer but got "xyz"}}} - {weight xyz {1 {bad -weight value "xyz": must be normal, bold}}} - {slant xyz {1 {bad -slant value "xyz": must be roman, italic}}} + {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-30.$i "ConfigAttributes procedure: [lindex $p 0]" { + 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-31.1 {GetAttributeInfo procedure: error} { - list [catch {font actual xyz -style} msg] $msg -} {1 {bad option "-style": must be -family, -size, -weight, -slant, -underline, or -overstrike}} -test font-31.2 {GetAttributeInfo procedure: all attributes} { +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 3 +set i 4 foreach p { {family xyz xyz} {size 20 20} @@ -993,100 +1237,153 @@ foreach p { } # In tests below, one field is set to "xyz" so that font name doesn't -# look like a native X font, so that ParseFontName or TkParseXLFD will +# look like a native X font, so that ParseFontNameObj or TkParseXLFD will # be called. setup -test font-32.1 {ParseFontName procedure: begins with -} { +test font-38.1 {ParseFontNameObj procedure: begins with -} { lindex [font actual -xyz-times-*-*-*-*-*-*-*-*-*-*-*-*] 1 } $times -test font-32.2 {ParseFontName procedure: begins with -*} { +test font-38.2 {ParseFontNameObj procedure: begins with -*} { lindex [font actual -*-times-xyz-*-*-*-*-*-*-*-*-*-*-*] 1 } $times -test font-32.3 {ParseFontName procedure: begins with -, doesn't look like list} { +test font-38.3 {ParseFontNameObj procedure: begins with -, doesn't look like list} { lindex [font actual -xyz-times-*-*-*-*-*-*-*-*-*-*-*-*] 1 } $times -test font-32.4 {ParseFontName procedure: begins with -, looks like list} { +test font-38.4 {ParseFontNameObj procedure: begins with -, looks like list} { lindex [font actual {-family times}] 1 } $times -test font-32.5 {ParseFontName procedure: begins with *} { +test font-38.5 {ParseFontNameObj procedure: begins with *} { lindex [font actual *-times-xyz-*-*-*-*-*-*-*-*-*-*-*] 1 } $times -test font-32.6 {ParseFontName procedure: begins with *} { +test font-38.6 {ParseFontNameObj procedure: begins with *} { font actual *-times-xyz -family } $times -test font-32.7 {ParseFontName procedure: arguments} { - list [catch {font actual {}} msg] $msg +test font-38.7 {ParseFontNameObj procedure: arguments} { + list [catch {font actual "\{xyz"} msg] $msg +} [list 1 "font \"{xyz\" doesn't exist"] +test font-38.8 {ParseFontNameObj procedure: arguments} { + list [catch {font actual ""} msg] $msg } {1 {font "" doesn't exist}} -test font-32.8 {ParseFontName procedure: arguments} { +test font-38.9 {ParseFontNameObj procedure: arguments} { list [catch {font actual {times 20 xyz xyz}} msg] $msg } {1 {unknown font style "xyz"}} -test font-32.9 {ParseFontName procedure: arguments} { +test font-38.10 {ParseFontNameObj procedure: arguments} { list [catch {font actual {times xyz xyz}} msg] $msg } {1 {expected integer but got "xyz"}} -test font-32.10 {ParseFontName procedure: stylelist loop} {macOnly} { +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-32.11 {ParseFontName procedure: stylelist loop} {unixOrPc} { +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-32.12 {ParseFontName procedure: stylelist error} { +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-33.1 {TkParseXLFD procedure: initial dash} { +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-33.2 {TkParseXLFD procedure: no initial dash} { +test font-40.2 {TkFontParseXLFD procedure: no initial dash} { font actual *-times-*-*-*-*-*-*-*-*-*-*-*-xyz -family } $times -test font-33.3 {TkParseXLFD procedure: not enough fields} { +test font-40.3 {TkFontParseXLFD procedure: not enough fields} { font actual -xyz-times-*-*-* -family } $times -test font-33.4 {TkParseXLFD procedure: all fields unspecified} { +test font-40.4 {TkFontParseXLFD procedure: all fields unspecified} { lindex [font actual -xyz-*-*-*-*-*-*-*-*-*-*-*-*-*] 0 } {-family} -test font-33.5 {TkParseXLFD procedure: all fields specified} { +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-33.6 {TkParseXLFD procedure: arguments} { +test font-41.1 {TkParseXLFD procedure: arguments} { # XLFD with bad pointsize: fallback to some system font. font actual -*-*-*-*-*-*-xyz-*-*-*-*-*-*-* set x {} } {} -test font-33.7 {TkParseXLFD procedure: arguments} { +test font-42.1 {TkFontParseXLFD procedure: arguments} { # XLFD with bad pixelsize: fallback to some system font. font actual -*-*-*-*-*-*-*-xyz-*-*-*-*-*-* set x {} } {} -test font-33.8 {TkParseXLFD procedure: pixelsize specified} { +test font-42.2 {TkFontParseXLFD procedure: pixelsize specified} { font metrics -xyz-times-*-*-*-*-12-*-*-*-*-*-*-* -linespace set x {} } {} -test font-33.9 {TkParseXLFD procedure: weird pixelsize specified} { +test font-42.3 {TkFontParseXLFD procedure: weird pixelsize specified} { font metrics {-xyz-times-*-*-*-*-[ 12.0 0 12.0 0]-*-*-*-*-*-*-*} -linespace set x {} } {} -test font-33.10 {TkParseXLFD procedure: pointsize specified} { +test font-42.4 {TkFontParseXLFD procedure: pointsize specified} { font metrics -xyz-times-*-*-*-*-*-120-*-*-*-*-*-* -linespace set x {} } {} -test font-33.11 {TkParseXLFD procedure: weird pointsize specified} { +test font-42.5 {TkFontParseXLFD procedure: weird pointsize specified} { font metrics {-xyz-times-*-*-*-*-*-[ 12.0 0 12.0 0]-*-*-*-*-*-*} -linespace set x {} } {} -test font-34.1 {FieldSpecified procedure: specified vs. non-specified} { +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 -test font-35.1 {NewChunk procedure: test realloc} { - .b.f config -text "xxx\nxxx\txxx\nxxx\t\t\t" -} {} +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 {TkFontGetPixels: size >= 0} { + font actual {times 12} -size +} {12} + +test font-45.1 {TkFontGetPoints: size >= 0} { + font actual {times 12} -size +} {12} +test font-45.2 {TkFontGetPoints: size < 0} { + font actual {times -12} -size +} {24} + +tk scaling $oldscale + +test font-46.1 {TkFontGetAliasList: no match} { + font actual {snarky 10} -family +} [font actual {-size 10} -family] +test font-46.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-46.3 {TkFontGetAliasList: match} {pcOnly} { + font actual {times 10} -family +} {Times New Roman} +test font-46.4 {TkFontGetAliasList: match} {unixOnly} { + font actual {{times new roman} 10} -family +} [font actual {times 10} -family] + +setup destroy .b + +# cleanup +::tcltest::cleanupTests return + + + + + + + + + + + + + |