diff options
author | William Joye <wjoye@cfa.harvard.edu> | 2017-09-22 18:51:12 (GMT) |
---|---|---|
committer | William Joye <wjoye@cfa.harvard.edu> | 2017-09-22 18:51:12 (GMT) |
commit | 3fa8e6dc88e8041b6cb88d1b1e9c05676d3346b7 (patch) | |
tree | 69afbb41089c8358615879f7cd3c4cf7997f4c7e /tk8.6/tests/font.test | |
parent | a0e17db23c0fd7c771c0afce8cce350c98f90b02 (diff) | |
download | blt-3fa8e6dc88e8041b6cb88d1b1e9c05676d3346b7.zip blt-3fa8e6dc88e8041b6cb88d1b1e9c05676d3346b7.tar.gz blt-3fa8e6dc88e8041b6cb88d1b1e9c05676d3346b7.tar.bz2 |
update to tcl/tk 8.6.7
Diffstat (limited to 'tk8.6/tests/font.test')
-rw-r--r-- | tk8.6/tests/font.test | 2382 |
1 files changed, 0 insertions, 2382 deletions
diff --git a/tk8.6/tests/font.test b/tk8.6/tests/font.test deleted file mode 100644 index 9e44a93..0000000 --- a/tk8.6/tests/font.test +++ /dev/null @@ -1,2382 +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. - -package require tcltest 2.2 -namespace import ::tcltest::* -eval tcltest::configure $argv -tcltest::loadTestedCommands - - -set defaultfontlist [font names] - -proc getnondefaultfonts {} { - global defaultfontlist - set nondeffonts [list ] - foreach afont [font names] { - if {$afont ni $defaultfontlist} { - lappend nondeffonts $afont - } - } - set nondeffonts -} - -proc clearnondefaultfonts {} { - foreach afont [getnondefaultfonts] { - font delete $afont - } -} - -deleteWindows -# Toplevel used (in some tests) of the whole file -toplevel .t -wm geom .t +0+0 -update idletasks - -switch [tk windowingsystem] { - x11 {set fixed "fixed"} - win32 {set fixed "courier 12"} - aqua {set fixed "monaco 9"} -} - - -# Procedure used in tests: 24.15, 26.*, 28.*, 30.*, 31.*, 32.1 -proc csetup {{str ""}} { - focus -force .t.c - .t.c dchars text 0 end - .t.c insert text 0 $str - .t.c focus text -} - - -test font-1.1 {TkFontPkgInit} -setup { - catch {interp delete foo} -} -body { - interp create foo - foo eval { - load {} Tk - wm geometry . +0+0 - update - } - interp delete foo -} -result {} - - -test font-2.1 {TkFontPkgFree} -setup { - catch {interp delete foo} - set x {} -} -body { - interp create foo - - # 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}] -} -cleanup { - interp delete foo -} -result {{named font "wiggles" doesn't exist} {can't invoke "font" command: application has been destroyed}} - - -test font-3.1 {font command: general} -body { - font -} -returnCodes error -result {wrong # args: should be "font option ?arg?"} -test font-3.2 {font command: general} -body { - font xyz -} -returnCodes error -result {bad option "xyz": must be actual, configure, create, delete, families, measure, metrics, or names} - - -test font-4.1 {font command: actual: arguments} -body { - # (skip < 0) - font actual xyz -displayof -} -returnCodes error -result {value for "-displayof" missing} -test font-4.2 {font command: actual: arguments} -body { - # (objc < 3) - font actual -} -returnCodes error -result {wrong # args: should be "font actual font ?-displayof window? ?option? ?--? ?char?"} -test font-4.3 {font command: actual: arguments} -body { - # (objc - skip > 4) when skip == 0 - font actual xyz abc def -} -returnCodes error -result {wrong # args: should be "font actual font ?-displayof window? ?option? ?--? ?char?"} -test font-4.4 {font command: actual: displayof specified, so skip to next} -body { - catch {font actual xyz -displayof . -size} -} -result {0} -test font-4.5 {font command: actual: displayof specified, so skip to next} -body { - lindex [font actual xyz -displayof .] 0 -} -result {-family} -test font-4.6 {font command: actual: arguments} -body { - # (objc - skip > 4) when skip == 2 - font actual xyz -displayof . abc def -} -returnCodes error -result {wrong # args: should be "font actual font ?-displayof window? ?option? ?--? ?char?"} -test font-4.7 {font command: actual: arguments} -constraints noExceed -body { - # (tkfont == NULL) - font actual "\{xyz" -} -returnCodes error -result "font \"{xyz\" doesn't exist" -test font-4.8 {font command: actual: all attributes} -body { - # not (objc > 3) so objPtr = NULL - lindex [font actual {-family times}] 0 -} -result {-family} -test font-4.9 {font command: actual} -constraints {unix noExceed} -body { - # (objc > 3) so objPtr = objv[3 + skip] - string tolower [font actual {-family times} -family] -} -result {times} -test font-4.10 {font command: actual} -constraints win -body { - # (objc > 3) so objPtr = objv[3 + skip] - font actual {-family times} -family -} -result {Times New Roman} -test font-4.11 {font command: bad option} -body { - font actual xyz -style -} -returnCodes error -result {bad option "-style": must be -family, -size, -weight, -slant, -underline, or -overstrike} - - -test font-5.1 {font command: configure} -body { - # (objc < 3) - font configure -} -returnCodes error -result {wrong # args: should be "font configure fontname ?-option value ...?"} -test font-5.2 {font command: configure: non-existent font} -body { - # (namedHashPtr == NULL) - font configure xyz -} -returnCodes error -result {named font "xyz" doesn't exist} -test font-5.3 {font command: configure: "deleted" font} -setup { - destroy .t.f - catch {font delete xyz} - pack [label .t.f] - update -} -body { - # (nfPtr->deletePending != 0) - font create xyz - .t.f configure -font xyz - font delete xyz - font configure xyz -} -cleanup { - destroy .t.f -} -returnCodes error -result {named font "xyz" doesn't exist} -test font-5.4 {font command: configure: get all options} -setup { - catch {font delete xyz} -} -body { - # (objc == 3) so objPtr = NULL - font create xyz -family xyz - lindex [font configure xyz] 1 -} -cleanup { - font delete xyz -} -result xyz -test font-5.5 {font command: configure: get one option} -setup { - clearnondefaultfonts -} -body { - # (objc == 4) so objPtr = objv[3] - font create xyz -family xyz - font configure xyz -family - getnondefaultfonts -} -cleanup { - font delete xyz -} -result xyz -test font-5.6 {font command: configure: update existing font} -setup { - catch {font delete xyz} -} -body { - # else result = ConfigAttributesObj() - font create xyz - font configure xyz -family xyz - update - font configure xyz -family -} -cleanup { - font delete xyz -} -result xyz -test font-5.7 {font command: configure: bad option} -setup { - catch {font delete xyz} -} -body { - font create xyz - font configure xyz -style -} -cleanup { - font delete xyz -} -returnCodes error -result {bad option "-style": must be -family, -size, -weight, -slant, -underline, or -overstrike} - - -test font-6.1 {font command: create: make up name} -setup { - clearnondefaultfonts -} -body { - # (objc < 3) so name = NULL - font create - getnondefaultfonts -} -cleanup { - font delete font1 -} -result {font1} -test font-6.2 {font command: create: name specified} -setup { - clearnondefaultfonts -} -body { - # not (objc < 3) - font create xyz - getnondefaultfonts -} -cleanup { - font delete xyz -} -result {xyz} -test font-6.3 {font command: create: name not really specified} -setup { - clearnondefaultfonts -} -body { - # (name[0] == '-') so name = NULL - font create -family xyz - getnondefaultfonts -} -cleanup { - font delete font1 -} -result {font1} -test font-6.4 {font command: create: generate name} -setup { -} -body { - # (name == NULL) - font create -family one - font create -family two - font create -family three - font delete font2 - font create -family four - font configure font2 -family -} -cleanup { - font delete font1 font2 font3 -} -result {four} -test font-6.5 {font command: create: bad option creating new font} -setup { - catch {font delete xyz} -} -body { - # name was specified so skip = 3 - font create xyz -xyz times -} -returnCodes error -result {bad option "-xyz": must be -family, -size, -weight, -slant, -underline, or -overstrike} -test font-6.6 {font command: create: bad option creating new font} -setup { - clearnondefaultfonts -} -body { - # name was not specified so skip = 2 - font create -xyz times -} -returnCodes error -result {bad option "-xyz": must be -family, -size, -weight, -slant, -underline, or -overstrike} -test font-6.7 {font command: create: already exists} -setup { - catch {font delete xyz} -} -body { - # (CreateNamedFont() != TCL_OK) - font create xyz - font create xyz -} -cleanup { - font delete xyz -} -returnCodes error -result {named font "xyz" already exists} - -test font-7.1 {font command: delete: arguments} -body { - # (objc < 3) - font delete -} -returnCodes error -result {wrong # args: should be "font delete fontname ?fontname ...?"} -test font-7.2 {font command: delete: loop test} -setup { - clearnondefaultfonts - set x {} -} -body { - # for (i = 2; i < objc; i++) - 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 [getnondefaultfonts]] - font delete a e c b - lappend x [lsort [getnondefaultfonts]] -} -cleanup { - getnondefaultfonts -} -result {{a b c d e} d} -test font-7.3 {font command: delete: loop test} -setup { - clearnondefaultfonts - set x {} -} -body { - # (namedHashPtr == NULL) in middle of loop - 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 [getnondefaultfonts]] - catch {font delete a d q c e b} - lappend x [lsort [getnondefaultfonts]] -} -cleanup { - clearnondefaultfonts -} -result {{a b c d e} {b c e}} -test font-7.4 {font command: delete: non-existent} -setup { - catch {font delete xyz} -} -body { - # (namedHashPtr == NULL) - font delete xyz -} -returnCodes error -result {named font "xyz" doesn't exist} -test font-7.5 {font command: delete: mark for later deletion} -setup { - destroy .t.f - catch {font delete xyz} - pack [label .t.f] - update -} -body { - # (nfPtr->refCount != 0) - font create xyz - .t.f configure -font xyz - font delete xyz - font actual xyz - font configure xyz -} -cleanup { - destroy .t.f -} -returnCodes error -result {named font "xyz" doesn't exist} -test font-7.6 {font command: delete: mark for later deletion} -setup { - destroy .t.f - catch {font delete xyz} - pack [label .t.f] - update -} -body { - # (nfPtr->refCount != 0) - font create xyz - .t.f configure -font xyz - font delete xyz - font actual xyz - catch {font configure xyz} - .t.f cget -font -} -cleanup { - destroy .t.f -} -result xyz -test font-7.7 {font command: delete: actually delete} -setup { - catch {font delete xyz} -} -body { - # not (nfPtr->refCount != 0) - font create xyz -underline 1 - font delete xyz - font config xyz -} -returnCodes error -match glob -result {*} - - -test font-8.1 {font command: families: arguments} -body { - # (skip < 0) - font families -displayof -} -returnCodes error -result {value for "-displayof" missing} -test font-8.2 {font command: families: arguments} -body { - # (objc - skip != 2) when skip == 0 - font families xyz -} -returnCodes error -result {wrong # args: should be "font families ?-displayof window?"} -test font-8.3 {font command: families: arguments} -body { - # (objc - skip != 2) when skip == 2 - font families -displayof . xyz -} -returnCodes error -result {wrong # args: should be "font families ?-displayof window?"} -test font-8.4 {font command: families} -body { - # TkpGetFontFamilies() - regexp -nocase times [font families] -} -result 1 - - -test font-9.1 {font command: measure: arguments} -body { - # (skip < 0) - expr {[font measure xyz -displayof] > 0} -} -returnCodes ok -result 1 -test font-9.2 {font command: measure: arguments} -body { - # (objc - skip != 4) - font measure -} -returnCodes error -result {wrong # args: should be "font measure font ?-displayof window? text"} -test font-9.3 {font command: measure: arguments} -body { - # (objc - skip != 4) - font measure xyz abc def -} -returnCodes error -result {wrong # args: should be "font measure font ?-displayof window? text"} -test font-9.4 {font command: measure: arguments} -constraints noExceed -body { - # (tkfont == NULL) - font measure "\{xyz" abc -} -returnCodes error -result "font \"{xyz\" doesn't exist" -test font-9.5 {font command: measure} -body { - # Tk_TextWidth() - expr {[font measure $fixed "abcdefg"] == [font measure $fixed "a"]*7 } -} -result 1 -test font-9.6 {font command: measure -d} -body { - expr {[font measure $fixed -d] > 0} -} -returnCodes ok -result 1 -test font-9.7 {font command: measure -d with -displayof} -body { - expr {[font measure $fixed -displayof . -d] > 0} -} -returnCodes ok -result 1 -test font-9.8 {font command: measure: arguments} -body { - font measure $fixed -displayof . -} -returnCodes error -result {wrong # args: should be "font measure font ?-displayof window? text"} - - -test font-10.1 {font command: metrics: arguments} -body { - font metrics xyz -displayof -} -returnCodes error -result {value for "-displayof" missing} -test font-10.2 {font command: metrics: arguments} -body { - # (skip < 0) - font metrics xyz -displayof -} -returnCodes error -result {value for "-displayof" missing} -test font-10.3 {font command: metrics: arguments} -body { - # (objc < 3) - font metrics -} -returnCodes error -result {wrong # args: should be "font metrics font ?-displayof window? ?option?"} -test font-10.4 {font command: metrics: arguments} -body { - # (objc - skip) > 4) when skip == 0 - font metrics xyz abc def -} -returnCodes error -result {wrong # args: should be "font metrics font ?-displayof window? ?option?"} -test font-10.5 {font command: metrics: arguments} -body { - # (objc - skip) > 4) when skip == 2 - font metrics xyz -displayof . abc -} -returnCodes error -result {bad metric "abc": must be -ascent, -descent, -linespace, or -fixed} -test font-10.6 {font command: metrics: bad font} -constraints noExceed -body { - # (tkfont == NULL) - font metrics "\{xyz" -} -returnCodes error -result "font \"{xyz\" doesn't exist" -test font-10.7 {font command: metrics: get all metrics} -setup { - catch {unset a} -} -body { - # (objc == 3) - array set a [font metrics {-family xyz}] - lsort [array names a] -} -cleanup { - unset a -} -result {-ascent -descent -fixed -linespace} -test font-10.8 {font command: metrics: bad metric} -body { - # (Tcl_GetIndexFromObj() != TCL_OK) - font metrics $fixed -xyz -} -returnCodes error -result {bad metric "-xyz": must be -ascent, -descent, -linespace, or -fixed} -test font-10.9 {font command: metrics: get individual metrics} -body { - font metrics $fixed -ascent - font metrics $fixed -descent - font metrics $fixed -linespace - font metrics $fixed -fixed -} -result 1 - - -test font-11.1 {font command: names: arguments} -body { - # (objc != 2) - font names xyz -} -returnCodes error -result {wrong # args: should be "font names"} -test font-11.2 {font command: names: loop test: no passes} -setup { - clearnondefaultfonts -} -body { - getnondefaultfonts -} -result {} -test font-11.3 {font command: names: loop test: one pass} -setup { - clearnondefaultfonts -} -body { - font create - getnondefaultfonts -} -result {font1} -test font-11.4 {font command: names: loop test: multiple passes} -setup { - clearnondefaultfonts -} -body { - font create xyz - font create abc - font create def - lsort [getnondefaultfonts] -} -cleanup { - clearnondefaultfonts -} -result {abc def xyz} -test font-11.5 {font command: names: skip deletePending fonts} -setup { - destroy .t.f - clearnondefaultfonts - pack [label .t.f] - update - set x {} -} -body { - # (nfPtr->deletePending == 0) - font create xyz - font create abc - lappend x [lsort [getnondefaultfonts]] - .t.f config -font xyz - font delete xyz - lappend x [getnondefaultfonts] -} -cleanup { - clearnondefaultfonts -} -result {{abc xyz} abc} - - -test font-12.1 {UpdateDependantFonts procedure: no users} -setup { - catch {font delete xyz} -} -body { - # (nfPtr->refCount == 0) - font create xyz - font configure xyz -family times -} -cleanup { - font delete xyz -} -result {} -test font-12.2 {UpdateDependantFonts procedure: pings the widgets} -setup { - destroy .t.f - catch {font delete xyz} - pack [label .t.f] - update -} -body { - font create xyz -family times -size 20 - .t.f config -font xyz -text "abcd" -padx 0 -bd 0 -highlightthickness 0 - set a1 [font measure xyz "abcd"] - update - set b1 [winfo reqwidth .t.f] - font configure xyz -family helvetica -size 20 - set a2 [font measure xyz "abcd"] - update - set b2 [winfo reqwidth .t.f] - expr {$a1==$b1 && $a2==$b2} -} -cleanup { - destroy .t.f - font delete xyz -} -result {1} - - -test font-13.1 {CreateNamedFont: new named font} -setup { - catch {font delete xyz} - set x {} -} -body { - # not (new == 0) - lappend x [getnondefaultfonts] - font create xyz - lappend x [getnondefaultfonts] -} -cleanup { - font delete xyz -} -result {{} xyz} -test font-13.2 {CreateNamedFont: named font already exists} -setup { - catch {font delete xyz} -} -body { - # (new == 0) - font create xyz - font create xyz -} -cleanup { - font delete xyz -} -returnCodes error -result {named font "xyz" already exists} -test font-13.3 {CreateNamedFont: named font already exists} -setup { - catch {font delete xyz} -} -body { - # (nfPtr->deletePending == 0) - font create xyz - font create xyz -} -cleanup { - font delete xyz -} -returnCodes error -result {named font "xyz" already exists} -test font-13.4 {CreateNamedFont: recreate "deleted" font} -setup { - destroy .t.f - catch {font delete xyz} - pack [label .t.f] - update -} -body { - # not (nfPtr->deletePending == 0) - font create xyz -family times - .t.f configure -font xyz - font delete xyz - font create xyz -family courier - font configure xyz -family -} -cleanup { - font delete xyz - destroy .t.f -} -result {courier} - - -test font-14.1 {Tk_GetFont procedure} -body { -} -result {} - - -test font-15.1 {Tk_AllocFontFromObj - converting internal reps} -constraints { - testfont -} -setup { - destroy .b1 .b2 -} -body { - set x {Times 16} - lindex $x 0 - button .b1 -font $x - lindex $x 0 - testfont counts {Times 16} -} -cleanup { - destroy .b1 .b2 -} -result {{1 0}} -test font-15.2 {Tk_AllocFontFromObj - discard stale font} -constraints { - testfont -} -setup { - destroy .b1 .b2 - set result {} -} -body { - set x {Times 16} - button .b1 -font $x - destroy .b1 - lappend result [testfont counts {Times 16}] - button .b2 -font $x - lappend result [testfont counts {Times 16}] -} -cleanup { - destroy .b2 -} -result {{} {{1 1}}} -test font-15.3 {Tk_AllocFontFromObj - reuse existing font} -constraints { - testfont -} -setup { - destroy .b1 .b2 - set result {} -} -body { - set x {Times 16} - button .b1 -font $x - lappend result [testfont counts {Times 16}] - button .b2 -font $x - pack .b1 .b2 -side top - lappend result [testfont counts {Times 16}] -} -cleanup { - destroy .b1 .b2 -} -result {{{1 1}} {{2 1}}} -test font-15.4 {Tk_AllocFontFromObj procedure: bump ref count} -setup { - destroy .t.f - pack [label .t.f] - update -} -body { - # (new == 0) - .t.f config -font {-family fixed} - lindex [font actual {-family fixed}] 0 -} -cleanup { - destroy .t.f -} -result {-family} -test font-15.5 {Tk_AllocFontFromObj procedure: get named font} -setup { - destroy .t.f - catch {font delete xyz} - pack [label .t.f] - update -} -body { - # (namedHashPtr != NULL) - font create xyz - .t.f config -font xyz -} -cleanup { - destroy .t.f - font delete xyz -} -result {} -test font-15.6 {Tk_AllocFontFromObj procedure: not a named font} -setup { - destroy .t.f - pack [label .t.f] - update -} -body { - # not (namedHashPtr != NULL) - .t.f config -font {times 20} -} -cleanup { - destroy .t.f -} -result {-family} -result {} -test font-15.7 {Tk_AllocFontFromObj procedure: get native font} -constraints { - unix -} -setup { - destroy .t.f - pack [label .t.f] - update -} -body { - # not (fontPtr == NULL) - .t.f config -font fixed -} -result {} -test font-15.8 {Tk_AllocFontFromObj procedure: get native font} -constraints { - win -} -setup { - destroy .t.f - clearnondefaultfonts - pack [label .t.f] - update -} -body { - # not (fontPtr == NULL) - .t.f config -font oemfixed -} -cleanup { - destroy .t.f -} -result {} -test font-15.9 {Tk_AllocFontFromObj procedure: get attribute font} -setup { - destroy .t.f - pack [label .t.f] - update -} -body { - # (fontPtr == NULL) - .t.f config -font {xxx yyy zzz} -} -cleanup { - destroy .t.f -} -returnCodes error -result {expected integer but got "yyy"} -test font-15.10 {Tk_AllocFontFromObj procedure: no match} -constraints noExceed -body { - # (ParseFontNameObj() != TCL_OK) - font actual "\{xyz" -} -returnCodes error -result "font \"{xyz\" doesn't exist" -test font-15.11 {Tk_AllocFontFromObj procedure: get attribute font} -body { - # not (ParseFontNameObj() != TCL_OK) - lindex [font actual {plan 9}] 0 -} -result {-family} -test font-15.12 {Tk_AllocFontFromObj procedure: setup tab width} -setup { - destroy .l -} -body { - # Tk_MeasureChars(fontPtr, "0", ...) - label .l -bd 0 -padx 0 -highlightthickness 0 -font $fixed -text "a\tb" - update - set res1 [winfo reqwidth .l] - set res2 [expr [font measure $fixed "0"]*9] - expr {$res1 eq $res2} -} -cleanup { - destroy .l -} -result 1 -test font-15.13 {Tk_AllocFontFromObj procedure: underline position} -setup { - destroy .t.f - pack [label .t.f] - update -} -body { - # (fontPtr->underlineHeight == 0) because size was < 10 - .t.f config -text "underline" -font "times -8 underline" - update -} -cleanup { - destroy .t.f -} -result {} - - -test font-16.1 {Tk_NameOfFont procedure} -setup { - destroy .t.f - pack [label .t.f] - update -} -body { - .t.f config -font -family\ fixed - .t.f cget -font -} -cleanup { - destroy .t.f -} -result {-family fixed} - - -test font-17.1 {Tk_FreeFontFromObj - reference counts} -constraints { - testfont -} -setup { - destroy .b1 .b2 .b3 - set result {} -} -body { - set x {Courier 12} - button .b1 -font $x - button .b3 -font $x - button .b2 -font $x - 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}] -} -result {{{3 1}} {{2 1}} {{1 1}} {}} -test font-17.2 {Tk_FreeFont procedure: one ref} -setup { - destroy .t.f - pack [label .t.f] - update -} -body { - # (fontPtr->refCount == 0) - .t.f config -font {-family fixed} - destroy .t.f -} -result {} -test font-17.3 {Tk_FreeFont procedure: multiple ref} -setup { - destroy .t.f .t.b - pack [label .t.f] - update -} -body { - # not (fontPtr->refCount == 0) - .t.f config -font {-family fixed} - button .t.b -font {-family fixed} - destroy .t.f - .t.b cget -font -} -cleanup { - destroy .t.b -} -result {-family fixed} -test font-17.4 {Tk_FreeFont procedure: named font} -setup { - destroy .t.f - clearnondefaultfonts - pack [label .t.f] - update -} -body { - # (fontPtr->namedHashPtr != NULL) - font create xyz - .t.f config -font xyz - destroy .t.f - getnondefaultfonts -} -result {xyz} -test font-17.5 {Tk_FreeFont procedure: named font} -setup { - destroy .t.f - catch {font delete xyz} - pack [label .t.f] - update -} -body { - # not (fontPtr->refCount == 0) - font create xyz -underline 1 - .t.f config -font xyz - font delete xyz - set x [font actual xyz -underline] - destroy .t.f - list [font actual xyz -underline] $x -} -result {0 1} -test font-17.6 {Tk_FreeFont procedure: named font not deleted yet} -setup { - destroy .t.f .t.b - catch {font delete xyz} - pack [label .t.f] - update -} -body { - font create xyz - .t.f config -font xyz - button .t.b -font xyz - font delete xyz - set x [font actual xyz] - destroy .t.b - list [lindex [font actual xyz] 0] [lindex $x 0] -} -cleanup { - destroy .t.f -} -result {-family -family} - - -test font-18.1 {FreeFontObjProc} -constraints testfont -setup { - destroy .b1 - set result {} -} -body { - set x [join {Courier 12} { }] - button .b1 -font $x - set y [join {Courier 12} { }] - .b1 configure -font $y - set z [join {Courier 12} { }] - .b1 configure -font $z - 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 - return $result -} -result {{{1 3}} {{1 2}} {{1 1}} {}} - - -test font-19.1 {Tk_FontId} -setup { - destroy .t.f - pack [label .t.f] - update -} -body { - .t.f config -font "times 20" - update -} -cleanup { - destroy .t.f -} -result {} - - -test font-20.1 {Tk_GetFontMetrics procedure} -setup { - destroy .t.w1 .t.w2 -} -body { - button .t.w1 -text abc - entry .t.w2 -text abcd - update - destroy .t.w1 .t.w2 -} -result {} - - -# Procedure used in 21.* tests -proc psfontname {name} { - destroy .t.c - canvas .t.c -closeenough 0 - .t.c create text 0 0 -tags text -anchor nw -just left -font "Courier -12" - pack .t.c - update - set a [.t.c itemcget text -font] - .t.c itemconfig text -text "We need text" -font $name - set post [.t.c postscript] - .t.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] - destroy .t.c - return [string range $post [expr $start+7] end] -} -test font-21.1 {Tk_PostscriptFontName procedure: native} -constraints { - unix -} -body { - 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} - } -} -result {AvantGarde-Book} -test font-21.2 {Tk_PostscriptFontName procedure: native} -constraints { - win -} -body { - psfontname "arial 10" -} -result {Helvetica} -test font-21.3 {Tk_PostscriptFontName procedure: native} -constraints { - win -} -body { - psfontname "{times new roman} 10" -} -result {Times-Roman} -test font-21.4 {Tk_PostscriptFontName procedure: native} -constraints { - win -} -body { - psfontname "{courier new} 10" -} -result {Courier} -test font-21.5 {Tk_PostscriptFontName procedure: spaces} -constraints { - unix -} -body { - set x [font actual {{lucida bright} 10} -family] - if {[string match lucida*bright $x]} { - psfontname "{lucida bright} 10" - } else { - set x {LucidaBright} - } -} -result {LucidaBright} -test font-21.6 {Tk_PostscriptFontName procedure: spaces} -constraints { - unix -} -body { - psfontname "{new century schoolbook} 10" -} -result {NewCenturySchlbk-Roman} - -test font-21.7 {Tk_PostscriptFontName procedure: exhaustive} -constraints { - unix -} -body { - set name {avantgarde 12 roman normal} - if {[font actual {avantgarde 12 roman normal} -family] == "avantgarde"} { - set x [psfontname avantgarde 12 roman normal] - } else { - set x AvantGarde-Book - } -} -result {AvantGarde-Book} -test font-21.8 {Tk_PostscriptFontName procedure: exhaustive} -constraints { - unix -} -body { - set name {avantgarde 12 roman bold} - if {[font actual {avantgarde 12 roman normal} -family] == "avantgarde"} { - set x [psfontname avantgarde 12 roman normal] - } else { - set x AvantGarde-Demi - } -} -result {AvantGarde-Demi} -test font-21.9 {Tk_PostscriptFontName procedure: exhaustive} -constraints { - unix -} -body { - set name {avantgarde 12 italic normal} - if {[font actual {avantgarde 12 roman normal} -family] == "avantgarde"} { - set x [psfontname avantgarde 12 roman normal] - } else { - set x AvantGarde-BookOblique - } -} -result {AvantGarde-BookOblique} -test font-21.10 {Tk_PostscriptFontName procedure: exhaustive} -constraints { - unix -} -body { - set name {avantgarde 12 italic bold} - if {[font actual {avantgarde 12 roman normal} -family] == "avantgarde"} { - set x [psfontname avantgarde 12 roman normal] - } else { - set x AvantGarde-DemiOblique - } -} -result {AvantGarde-DemiOblique} - -test font-21.11 {Tk_PostscriptFontName procedure: exhaustive} -constraints { - unix -} -body { - set name {bookman 12 roman normal} - if {[font actual {avantgarde 12 roman normal} -family] == "bookman"} { - set x [psfontname avantgarde 12 roman normal] - } else { - set x Bookman-Light - } -} -result {Bookman-Light} -test font-21.12 {Tk_PostscriptFontName procedure: exhaustive} -constraints { - unix -} -body { - set name {bookman 12 roman bold} - if {[font actual {avantgarde 12 roman normal} -family] == "bookman"} { - set x [psfontname avantgarde 12 roman normal] - } else { - set x Bookman-Demi - } -} -result {Bookman-Demi} -test font-21.13 {Tk_PostscriptFontName procedure: exhaustive} -constraints { - unix -} -body { - set name {bookman 12 italic normal} - if {[font actual {avantgarde 12 roman normal} -family] == "bookman"} { - set x [psfontname avantgarde 12 roman normal] - } else { - set x Bookman-LightItalic - } -} -result {Bookman-LightItalic} -test font-21.14 {Tk_PostscriptFontName procedure: exhaustive} -constraints { - unix -} -body { - set name {bookman 12 italic bold} - if {[font actual {avantgarde 12 roman normal} -family] == "bookman"} { - set x [psfontname avantgarde 12 roman normal] - } else { - set x Bookman-DemiItalic - } -} -result {Bookman-DemiItalic} - -test font-21.15 {Tk_PostscriptFontName procedure: exhaustive} -constraints { - unix -} -body { - set name {courier 12 roman normal} - if {[font actual {avantgarde 12 roman normal} -family] == "courier"} { - set x [psfontname avantgarde 12 roman normal] - } else { - set x Courier - } -} -result {Courier} -test font-21.16 {Tk_PostscriptFontName procedure: exhaustive} -constraints { - unix -} -body { - set name {courier 12 roman bold} - if {[font actual {avantgarde 12 roman normal} -family] == "courier"} { - set x [psfontname avantgarde 12 roman normal] - } else { - set x Courier-Bold - } -} -result {Courier-Bold} -test font-21.17 {Tk_PostscriptFontName procedure: exhaustive} -constraints { - unix -} -body { - set name {courier 12 italic normal} - if {[font actual {avantgarde 12 roman normal} -family] == "courier"} { - set x [psfontname avantgarde 12 roman normal] - } else { - set x Courier-Oblique - } -} -result {Courier-Oblique} -test font-21.18 {Tk_PostscriptFontName procedure: exhaustive} -constraints { - unix -} -body { - set name {courier 12 italic bold} - if {[font actual {avantgarde 12 roman normal} -family] == "courier"} { - set x [psfontname avantgarde 12 roman normal] - } else { - set x Courier-BoldOblique - } -} -result {Courier-BoldOblique} - -test font-21.19 {Tk_PostscriptFontName procedure: exhaustive} -constraints { - unix -} -body { - set name {helvetica 12 roman normal} - if {[font actual {avantgarde 12 roman normal} -family] == "helvetica"} { - set x [psfontname avantgarde 12 roman normal] - } else { - set x Helvetica - } -} -result {Helvetica} -test font-21.20 {Tk_PostscriptFontName procedure: exhaustive} -constraints { - unix -} -body { - set name {helvetica 12 roman bold} - if {[font actual {avantgarde 12 roman normal} -family] == "helvetica"} { - set x [psfontname avantgarde 12 roman normal] - } else { - set x Helvetica-Bold - } -} -result {Helvetica-Bold} -test font-21.21 {Tk_PostscriptFontName procedure: exhaustive} -constraints { - unix -} -body { - set name {helvetica 12 italic normal} - if {[font actual {avantgarde 12 roman normal} -family] == "helvetica"} { - set x [psfontname avantgarde 12 roman normal] - } else { - set x Helvetica-Oblique - } -} -result {Helvetica-Oblique} -test font-21.22 {Tk_PostscriptFontName procedure: exhaustive} -constraints { - unix -} -body { - set name {helvetica 12 italic bold} - if {[font actual {avantgarde 12 roman normal} -family] == "helvetica"} { - set x [psfontname avantgarde 12 roman normal] - } else { - set x Helvetica-BoldOblique - } -} -result {Helvetica-BoldOblique} - -test font-21.23 {Tk_PostscriptFontName procedure: exhaustive} -constraints { - unix -} -body { - set name {{new century schoolbook} 12 roman normal} - if {[font actual {avantgarde 12 roman normal} -family] == "new century schoolbook"} { - set x [psfontname avantgarde 12 roman normal] - } else { - set x NewCenturySchlbk-Roman - } -} -result {NewCenturySchlbk-Roman} -test font-21.24 {Tk_PostscriptFontName procedure: exhaustive} -constraints { - unix -} -body { - set name {{new century schoolbook} 12 roman bold} - if {[font actual {avantgarde 12 roman normal} -family] == "new century schoolbook"} { - set x [psfontname avantgarde 12 roman normal] - } else { - set x NewCenturySchlbk-Bold - } -} -result {NewCenturySchlbk-Bold} -test font-21.25 {Tk_PostscriptFontName procedure: exhaustive} -constraints { - unix -} -body { - set name {{new century schoolbook} 12 italic normal} - if {[font actual {avantgarde 12 roman normal} -family] == "new century schoolbook"} { - set x [psfontname avantgarde 12 roman normal] - } else { - set x NewCenturySchlbk-Italic - } -} -result {NewCenturySchlbk-Italic} -test font-21.26 {Tk_PostscriptFontName procedure: exhaustive} -constraints { - unix -} -body { - set name {{new century schoolbook} 12 italic bold} - if {[font actual {avantgarde 12 roman normal} -family] == "new century schoolbook"} { - set x [psfontname avantgarde 12 roman normal] - } else { - set x NewCenturySchlbk-BoldItalic - } -} -result {NewCenturySchlbk-BoldItalic} - -test font-21.27 {Tk_PostscriptFontName procedure: exhaustive} -constraints { - unix -} -body { - set name {palatino 12 roman normal} - if {[font actual {avantgarde 12 roman normal} -family] == "palatino"} { - set x [psfontname avantgarde 12 roman normal] - } else { - set x Palatino-Roman - } -} -result {Palatino-Roman} -test font-21.28 {Tk_PostscriptFontName procedure: exhaustive} -constraints { - unix -} -body { - set name {palatino 12 roman bold} - if {[font actual {avantgarde 12 roman normal} -family] == "palatino"} { - set x [psfontname avantgarde 12 roman normal] - } else { - set x Palatino-Bold - } -} -result {Palatino-Bold} -test font-21.29 {Tk_PostscriptFontName procedure: exhaustive} -constraints { - unix -} -body { - set name {palatino 12 italic normal} - if {[font actual {avantgarde 12 roman normal} -family] == "palatino"} { - set x [psfontname avantgarde 12 roman normal] - } else { - set x Palatino-Italic - } -} -result {Palatino-Italic} -test font-21.30 {Tk_PostscriptFontName procedure: exhaustive} -constraints { - unix -} -body { - set name {palatino 12 italic bold} - if {[font actual {avantgarde 12 roman normal} -family] == "palatino"} { - set x [psfontname avantgarde 12 roman normal] - } else { - set x Palatino-BoldItalic - } -} -result {Palatino-BoldItalic} - -test font-21.31 {Tk_PostscriptFontName procedure: exhaustive} -constraints { - unix -} -body { - set name {symbol 12 roman normal} - if {[font actual {avantgarde 12 roman normal} -family] == "symbol"} { - set x [psfontname avantgarde 12 roman normal] - } else { - set x Symbol - } -} -result {Symbol} -test font-21.32 {Tk_PostscriptFontName procedure: exhaustive} -constraints { - unix -} -body { - set name {symbol 12 roman bold} - if {[font actual {avantgarde 12 roman normal} -family] == "symbol"} { - set x [psfontname avantgarde 12 roman normal] - } else { - set x Symbol - } -} -result {Symbol} -test font-21.33 {Tk_PostscriptFontName procedure: exhaustive} -constraints { - unix -} -body { - set name {symbol 12 italic normal} - if {[font actual {avantgarde 12 roman normal} -family] == "symbol"} { - set x [psfontname avantgarde 12 roman normal] - } else { - set x Symbol - } -} -result {Symbol} -test font-21.34 {Tk_PostscriptFontName procedure: exhaustive} -constraints { - unix -} -body { - set name {symbol 12 italic bold} - if {[font actual {avantgarde 12 roman normal} -family] == "symbol"} { - set x [psfontname avantgarde 12 roman normal] - } else { - set x Symbol - } -} -result {Symbol} - -test font-21.35 {Tk_PostscriptFontName procedure: exhaustive} -constraints { - unix -} -body { - set name {times 12 roman normal} - if {[font actual {avantgarde 12 roman normal} -family] == "times"} { - set x [psfontname avantgarde 12 roman normal] - } else { - set x Times-Roman - } -} -result {Times-Roman} -test font-21.36 {Tk_PostscriptFontName procedure: exhaustive} -constraints { - unix -} -body { - set name {times 12 roman bold} - if {[font actual {avantgarde 12 roman normal} -family] == "times"} { - set x [psfontname avantgarde 12 roman normal] - } else { - set x Times-Bold - } -} -result {Times-Bold} -test font-21.37 {Tk_PostscriptFontName procedure: exhaustive} -constraints { - unix -} -body { - set name {times 12 italic normal} - if {[font actual {avantgarde 12 roman normal} -family] == "times"} { - set x [psfontname avantgarde 12 roman normal] - } else { - set x Times-Italic - } -} -result {Times-Italic} -test font-21.38 {Tk_PostscriptFontName procedure: exhaustive} -constraints { - unix -} -body { - set name {times 12 italic bold} - if {[font actual {avantgarde 12 roman normal} -family] == "times"} { - set x [psfontname avantgarde 12 roman normal] - } else { - set x Times-BoldItalic - } -} -result {Times-BoldItalic} - -test font-21.39 {Tk_PostscriptFontName procedure: exhaustive} -constraints { - unix -} -body { - set name {zapfchancery 12 roman normal} - if {[font actual {avantgarde 12 roman normal} -family] == "zapfchancery"} { - set x [psfontname avantgarde 12 roman normal] - } else { - set x ZapfChancery-MediumItalic - } -} -result {ZapfChancery-MediumItalic} -test font-21.40 {Tk_PostscriptFontName procedure: exhaustive} -constraints { - unix -} -body { - set name {zapfchancery 12 roman bold} - if {[font actual {avantgarde 12 roman normal} -family] == "zapfchancery"} { - set x [psfontname avantgarde 12 roman normal] - } else { - set x ZapfChancery-MediumItalic - } -} -result {ZapfChancery-MediumItalic} -test font-21.41 {Tk_PostscriptFontName procedure: exhaustive} -constraints { - unix -} -body { - set name {zapfchancery 12 italic normal} - if {[font actual {avantgarde 12 roman normal} -family] == "zapfchancery"} { - set x [psfontname avantgarde 12 roman normal] - } else { - set x ZapfChancery-MediumItalic - } -} -result {ZapfChancery-MediumItalic} -test font-21.42 {Tk_PostscriptFontName procedure: exhaustive} -constraints { - unix -} -body { - set name {zapfchancery 12 italic bold} - if {[font actual {avantgarde 12 roman normal} -family] == "zapfchancery"} { - set x [psfontname avantgarde 12 roman normal] - } else { - set x ZapfChancery-MediumItalic - } -} -result {ZapfChancery-MediumItalic} - -test font-21.43 {Tk_PostscriptFontName procedure: exhaustive} -constraints { - unix -} -body { - set name {zapfdingbats 12 roman normal} - if {[font actual {avantgarde 12 roman normal} -family] == "zapfdingbats"} { - set x [psfontname avantgarde 12 roman normal] - } else { - set x ZapfDingbats - } -} -result {ZapfDingbats} -test font-21.44 {Tk_PostscriptFontName procedure: exhaustive} -constraints { - unix -} -body { - set name {zapfdingbats 12 roman bold} - if {[font actual {avantgarde 12 roman normal} -family] == "zapfdingbats"} { - set x [psfontname avantgarde 12 roman normal] - } else { - set x ZapfDingbats - } -} -result {ZapfDingbats} -test font-21.45 {Tk_PostscriptFontName procedure: exhaustive} -constraints { - unix -} -body { - set name {zapfdingbats 12 italic normal} - if {[font actual {avantgarde 12 roman normal} -family] == "zapfdingbats"} { - set x [psfontname avantgarde 12 roman normal] - } else { - set x ZapfDingbats - } -} -result {ZapfDingbats} -test font-21.46 {Tk_PostscriptFontName procedure: exhaustive} -constraints { - unix -} -body { - set name {zapfdingbats 12 italic bold} - if {[font actual {avantgarde 12 roman normal} -family] == "zapfdingbats"} { - set x [psfontname avantgarde 12 roman normal] - } else { - set x ZapfDingbats - } -} -result {ZapfDingbats} - -test font-21.47 {Tk_PostscriptFontName procedure: exhaustive} -constraints { - win -} -body { - set x [psfontname {arial 12 roman normal}] -} -result {Helvetica} -test font-21.48 {Tk_PostscriptFontName procedure: exhaustive} -constraints { - win -} -body { - set x [psfontname {arial 12 roman bold}] -} -result {Helvetica-Bold} -test font-21.49 {Tk_PostscriptFontName procedure: exhaustive} -constraints { - win -} -body { - set x [psfontname {arial 12 italic normal}] -} -result {Helvetica-Oblique} -test font-21.50 {Tk_PostscriptFontName procedure: exhaustive} -constraints { - win -} -body { - set x [psfontname {arial 12 italic bold}] -} -result {Helvetica-BoldOblique} - -test font-21.51 {Tk_PostscriptFontName procedure: exhaustive} -constraints { - win -} -body { - set x [psfontname {{courier new} 12 roman normal}] -} -result {Courier} -test font-21.52 {Tk_PostscriptFontName procedure: exhaustive} -constraints { - win -} -body { - set x [psfontname {{courier new} 12 roman bold}] -} -result {Courier-Bold} -test font-21.53 {Tk_PostscriptFontName procedure: exhaustive} -constraints { - win -} -body { - set x [psfontname {{courier new} 12 italic normal}] -} -result {Courier-Oblique} -test font-21.54 {Tk_PostscriptFontName procedure: exhaustive} -constraints { - win -} -body { - set x [psfontname {{courier new} 12 italic bold}] -} -result {Courier-BoldOblique} - -test font-21.55 {Tk_PostscriptFontName procedure: exhaustive} -constraints { - win -} -body { - set x [psfontname {helvetica 12 roman normal}] -} -result {Helvetica} -test font-21.56 {Tk_PostscriptFontName procedure: exhaustive} -constraints { - win -} -body { - set x [psfontname {helvetica 12 roman bold}] -} -result {Helvetica-Bold} -test font-21.57 {Tk_PostscriptFontName procedure: exhaustive} -constraints { - win -} -body { - set x [psfontname {helvetica 12 italic normal}] -} -result {Helvetica-Oblique} -test font-21.58 {Tk_PostscriptFontName procedure: exhaustive} -constraints { - win -} -body { - set x [psfontname {helvetica 12 italic bold}] -} -result {Helvetica-BoldOblique} - -test font-21.59 {Tk_PostscriptFontName procedure: exhaustive} -constraints { - win -} -body { - set x [psfontname {symbol 12 roman normal}] -} -result {Symbol} -test font-21.60 {Tk_PostscriptFontName procedure: exhaustive} -constraints { - win -} -body { - set x [psfontname {symbol 12 roman bold}] -} -result {Symbol-Bold} -test font-21.61 {Tk_PostscriptFontName procedure: exhaustive} -constraints { - win -} -body { - set x [psfontname {symbol 12 italic normal}] -} -result {Symbol-Italic} -test font-21.62 {Tk_PostscriptFontName procedure: exhaustive} -constraints { - win -} -body { - set x [psfontname {symbol 12 italic bold}] -} -result {Symbol-BoldItalic} - -test font-21.63 {Tk_PostscriptFontName procedure: exhaustive} -constraints { - win -} -body { - set x [psfontname {{times new roman} 12 roman normal}] -} -result {Times-Roman} -test font-21.64 {Tk_PostscriptFontName procedure: exhaustive} -constraints { - win -} -body { - set x [psfontname {{times new roman} 12 roman bold}] -} -result {Times-Bold} -test font-21.65 {Tk_PostscriptFontName procedure: exhaustive} -constraints { - win -} -body { - set x [psfontname {{times new roman} 12 italic normal}] -} -result {Times-Italic} -test font-21.66 {Tk_PostscriptFontName procedure: exhaustive} -constraints { - win -} -body { - set x [psfontname {{times new roman} 12 italic bold}] -} -result {Times-BoldItalic} - - -test font-22.1 {Tk_TextWidth procedure} -setup { - destroy .t.l -} -body { - label .t.l -padx 0 -pady 0 -bd 0 -highlightthickness 0 -justify left \ - -text "0" -font "Courier -12" - pack .t.l - set ax [winfo reqwidth .t.l] - expr {[font measure [.t.l cget -font] "000"] eq $ax*3} -} -cleanup { - destroy .t.l -} -result 1 - - -test font-23.1 {Tk_UnderlineChars procedure} -setup { - destroy .t.t -} -body { - text .t.t - .t.t insert 1.0 abc\tdefg - .t.t tag config sel -underline 1 - .t.t tag add sel 1.0 end - update -} -cleanup { - destroy .t.t -} -result {} - - -# Data used in 24.* tests -destroy .t.l -label .t.l -padx 0 -pady 0 -bd 0 -highlightthickness 0 -justify left \ - -text "0" -font "Courier -12" -pack .t.l -update -set ax [winfo reqwidth .t.l] -set ay [winfo reqheight .t.l] -test font-24.1 {Tk_ComputeTextLayout: empty string} -body { - .t.l config -text "" -} -result {} -test font-24.2 {Tk_ComputeTextLayout: simple string} -body { - .t.l config -text "000" - update - list [expr {[winfo reqwidth .t.l] eq [expr {$ax * 3}]}] \ - [expr {[winfo reqheight .t.l] eq $ay}] -} -result {1 1} -test font-24.3 {Tk_ComputeTextLayout: find special chars} -body { - .t.l config -text "000\n000" - update - list [expr {[winfo reqwidth .t.l] eq [expr {$ax * 3}]}] \ - [expr {[winfo reqheight .t.l] eq [expr {$ay * 2}]}] -} -result {1 1} -test font-24.4 {Tk_ComputeTextLayout: calls Tk_MeasureChars} -body { - .t.l config -text "000\n000" - update - list [expr {[winfo reqwidth .t.l] eq [expr {$ax * 3}]}] \ - [expr {[winfo reqheight .t.l] eq [expr {$ay * 2}]}] -} -result {1 1} -test font-24.5 {Tk_ComputeTextLayout: break line} -body { - .t.l config -text "000\t00000" -wrap [expr 9 * $ax] - update - list [expr {[winfo reqwidth .t.l] eq [expr {$ax * 8}]}] \ - [expr {[winfo reqheight .t.l] eq [expr {$ay * 2}]}] -} -cleanup { - .t.l config -wrap 0 -} -result {1 1} -test font-24.6 {Tk_ComputeTextLayout: normal ended on special char} -body { - .t.l config -text "000\n000" -} -result {} -test font-24.7 {Tk_ComputeTextLayout: special char was \n} -body { - .t.l config -text "000\n0000" - update - list [expr {[winfo reqwidth .t.l] eq [expr {$ax * 4}]}] \ - [expr {[winfo reqheight .t.l] eq [expr {$ay * 2}]}] -} -result {1 1} -test font-24.8 {Tk_ComputeTextLayout: special char was \t} -body { - .t.l config -text "000\t00" - update - list [expr {[winfo reqwidth .t.l] eq [expr {$ax * 10}]}] \ - [expr {[winfo reqheight .t.l] eq $ay}] -} -result {1 1} -test font-24.9 {Tk_ComputeTextLayout: tab didn't cause break} -body { - set x {} - .t.l config -text "000\t000" - update - lappend x [expr {[winfo reqwidth .t.l] eq [expr {$ax * 11}]}] - lappend x [expr {[winfo reqheight .t.l] eq $ay}] - .t.l config -text "000\t000" -wrap [expr 100 * $ax] - update - lappend x [expr {[winfo reqwidth .t.l] eq [expr {$ax * 11}]}] - lappend x [expr {[winfo reqheight .t.l] eq $ay}] - return $x -} -cleanup { - .t.l config -wrap 0 -} -result {1 1 1 1} -test font-24.10 {Tk_ComputeTextLayout: tab caused break} -body { - set x {} - .t.l config -text "000\t" - update - lappend x [expr {[winfo reqwidth .t.l] eq [expr {$ax * 8}]}] - lappend x [expr {[winfo reqheight .t.l] eq $ay}] - .t.l config -text "000\t00" -wrap [expr $ax * 6] - update - lappend x [expr {[winfo reqwidth .t.l] eq [expr {$ax * 8}]}] - lappend x [expr {[winfo reqheight .t.l] eq [expr {$ay * 2}]}] - return $x -} -cleanup { - .t.l config -wrap 0 -} -result {1 1 1 1} -test font-24.11 {Tk_ComputeTextLayout: absorb spaces at eol} -body { - set x {} - .t.l config -text "000 000" -wrap [expr {$ax * 5}] - update - lappend x [expr {[winfo reqwidth .t.l] eq [expr {$ax * 3}]}] - lappend x [expr {[winfo reqheight .t.l] eq [expr {$ay * 2}]}] - .t.l config -text "000 " - update - lappend x [expr {[winfo reqwidth .t.l] eq [expr {$ax * 3}]}] - lappend x [expr {[winfo reqheight .t.l] eq $ay}] - return $x -} -cleanup { - .t.l config -wrap 0 -} -result {1 1 1 1} -test font-24.12 {Tk_ComputeTextLayout: append non-printing spaces to chunk} -body { - set x {} - .t.l config -text "000 0000" -wrap [expr {$ax * 5}] - update - lappend x [expr {[winfo reqwidth .t.l] eq [expr {$ax * 4}]}] - lappend x [expr {[winfo reqheight .t.l] eq [expr {$ay * 2}]}] - .t.l config -text "000\t00 0000" -wrap [expr {$ax * 12}] - update - lappend x [expr {[winfo reqwidth .t.l] eq [expr {$ax * 10}]}] - lappend x [expr {[winfo reqheight .t.l] eq [expr {$ay * 2}]}] - return $x -} -cleanup { - .t.l config -wrap 0 -} -result {1 1 1 1} -test font-24.13 {Tk_ComputeTextLayout: many lines -> realloc line array} -body { - .t.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" - update - list [expr {[winfo reqwidth .t.l] eq 1}] \ - [expr {[winfo reqheight .t.l] eq [expr {$ay * 129}]}] -} -result {1 1} -test font-24.14 {Tk_ComputeTextLayout: text ended with \n} -body { - set x {} - .t.l config -text "0000" - update - lappend x [expr {[winfo reqwidth .t.l] eq [expr {$ax * 4}]}] - lappend x [expr {[winfo reqheight .t.l] eq $ay}] - .t.l config -text "0000\n" - update - lappend x [expr {[winfo reqwidth .t.l] eq [expr {$ax * 4}]}] - lappend x [expr {[winfo reqheight .t.l] eq [expr {$ay * 2}]}] - return $x -} -result {1 1 1 1} -destroy .t.l - -test font-24.15 {Tk_ComputeTextLayout: justification} -setup { - set x {} - destroy .t.c - canvas .t.c -closeenough 0 - .t.c create text 0 0 -tags text -anchor nw -just left -font "Courier -12" - pack .t.c - update -} -body { - csetup "000\n00000" - .t.c itemconfig text -just left - lappend x [.t.c index text @[expr $ax*2],0] - .t.c itemconfig text -just center - lappend x [.t.c index text @[expr $ax*2],0] - .t.c itemconfig text -just right - lappend x [.t.c index text @[expr $ax*2],0] - .t.c itemconfig text -just left - return $x -} -cleanup { - destroy .t.c -} -result {2 1 0} - - -test font-25.1 {Tk_FreeTextLayout procedure} -setup { - destroy .t.f - pack [label .t.f] - update -} -body { - .t.f config -text foo - .t.f config -text boo -} -cleanup { - destroy .t.f -} -result {} - - -# Canvas created for tests: 26.* -destroy .t.c -canvas .t.c -closeenough 0 -.t.c create text 0 0 -tags text -anchor nw -just left -font "Courier -12" -pack .t.c -update -test font-26.1 {Tk_DrawTextLayout procedure: auto-detect last char} -setup { - destroy .t.f - pack [label .t.f] - update -} -body { - .t.f config -text foo -} -cleanup { - destroy .t.f -} -result {} -test font-26.2 {Tk_DrawTextLayout procedure: multiple chunks} -body { - csetup "000\t00\n000" -} -result {} -test font-26.3 {Tk_DrawTextLayout: draw subset of chunk: numDisplay <= 0} -body { - csetup "000\t00" - .t.c select from text 3 - .t.c select to text 5 -} -result {} -test font-26.4 {Tk_DrawTextLayout: draw subset of chunk: firstChar <= 0} -body { - csetup "000\t00" - .t.c select from text 3 - .t.c select to text 5 -} -result {} -test font-26.5 {Tk_DrawTextLayout: draw subset of chunk: firstChar > 0} -body { - csetup "000\t00" - .t.c select from text 2 - .t.c select to text 2 -} -result {} -test font-26.6 {Tk_DrawTextLayout: draw subset of chunk: lastChar < numChars} -body { - csetup "000\t00" - .t.c select from text 4 - .t.c select to text 4 -} -result {} -destroy .t.c - -# Label used in 27.* tests -destroy .t.f -pack [label .t.f] -update -test font-27.1 {Tk_UnderlineTextLayout procedure: no underline chosen} -body { - .t.f config -text "foo" -under -1 -} -result {} -test font-27.2 {Tk_UnderlineTextLayout procedure: underline not visible} -body { - .t.f config -text "000 00000" -wrap [expr $ax*7] -under 10 -} -result {} -test font-27.3 {Tk_UnderlineTextLayout procedure: underline is visible} -body { - .t.f config -text "000 00000" -wrap [expr $ax*7] -under 5 - .t.f config -wrap -1 -under -1 -} -result {} -destroy .t.f - - - -# Canvas created for tests: 28.* -destroy .t.c -canvas .t.c -closeenough 0 -.t.c create text 0 0 -tags text -anchor nw -just left -font "Courier -12" -pack .t.c -update -test font-28.1 {Tk_PointToChar procedure: above all lines} -body { - csetup "000" - .t.c index text @-1,0 -} -result {0} -test font-28.2 {Tk_PointToChar procedure: no chars} -body { - # 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 "" - .t.c index text @100,100 -} -result {0} -test font-28.3 {Tk_PointToChar procedure: loop test} -body { - csetup "000\n000\n000\n000" - .t.c index text @10000,0 -} -result {3} -test font-28.4 {Tk_PointToChar procedure: intersect line} -body { - csetup "000\n000\n000" - .t.c index text @0,$ay -} -result {4} -test font-28.5 {Tk_PointToChar procedure: to the left of all chunks} -body { - csetup "000\n000\n000" - .t.c index text @-100,$ay -} -result {4} -test font-28.6 {Tk_PointToChar procedure: past any possible chunk} -body { - csetup "000\n000\n000" - .t.c index text @100000,$ay -} -result {7} -test font-28.7 {Tk_PointToChar procedure: which chunk on this line} -body { - csetup "000\n000\t000\t000\n000" - .t.c index text @[expr $ax*2],$ay -} -result {6} -test font-28.8 {Tk_PointToChar procedure: which chunk on this line} -body { - csetup "000\n000\t000\t000\n000" - .t.c index text @[expr $ax*10],$ay -} -result {10} -test font-28.9 {Tk_PointToChar procedure: in special chunk} -body { - csetup "000\n000\t000\t000\n000" - .t.c index text @[expr $ax*6],$ay -} -result {7} -test font-28.10 {Tk_PointToChar procedure: past all chars in chunk} -body { - csetup "000 0000000" - .t.c itemconfig text -width [expr $ax*5] - set x [.t.c index text @[expr $ax*5],0] - .t.c itemconfig text -width 0 - return $x -} -result {3} -test font-28.11 {Tk_PointToChar procedure: below all chunks} -body { - csetup "000 0000000" - .t.c index text @0,1000000 -} -result {11} -destroy .t.c - - -# Label used in 29.* tests -destroy .t.f -pack [label .t.f] -update -test font-29.1 {Tk_CharBBox procedure: index < 0} -body { - .t.f config -text "000" -underline -1 -} -result {} -test font-29.2 {Tk_CharBBox procedure: loop} -body { - .t.f config -text "000\t000\t000\t000" -underline 9 -} -result {} -test font-29.3 {Tk_CharBBox procedure: special char} -body { - .t.f config -text "000\t000\t000" -underline 7 -} -result {} -test font-29.4 {Tk_CharBBox procedure: normal char} -body { - .t.f config -text "000" -underline 1 -} -result {} -test font-29.5 {Tk_CharBBox procedure: right edge of bbox truncated} -body { - .t.f config -text "0 0000" -wrap [expr $ax*4] -under 2 - .t.f config -wrap 0 -} -result {} -test font-29.6 {Tk_CharBBox procedure: bbox pegged to right edge} -body { - .t.f config -text "0 0000" -wrap [expr $ax*4] -under 3 - .t.f config -wrap 0 -} -result {} -destroy .t.f - - - -# Canvas created for tests: 30.* -destroy .t.c -canvas .t.c -closeenough 0 -.t.c create text 0 0 -tags text -anchor nw -just left -font "Courier -12" -pack .t.c -update -test font-30.1 {Tk_DistanceToTextLayout procedure: loop once} -body { - csetup "000\n000\n000" - .t.c bind all <Enter> {lappend x [.t.c index current @%x,%y]} - set x {} - event generate .t.c <Leave> - event generate .t.c <Enter> -x 0 -y 0 - return $x -} -cleanup { - bind all <Enter> {} -} -result {0} -test font-30.2 {Tk_DistanceToTextLayout procedure: loop multiple} -body { - csetup "000\n000\n000" - .t.c bind all <Enter> {lappend x [.t.c index current @%x,%y]} - set x {} - event generate .t.c <Leave> - event generate .t.c <Enter> -x $ax -y $ay - return $x -} -cleanup { - bind all <Enter> {} -} -result {5} -test font-30.3 {Tk_DistanceToTextLayout procedure: loop to end} -body { - csetup "000\n0\n000" - .t.c bind all <Enter> {lappend x [.t.c index current @%x,%y]} - set x {} - event generate .t.c <Leave> - event generate .t.c <Enter> -x [expr $ax*2] -y $ay - return $x -} -cleanup { - bind all <Enter> {} -} -result {} -test font-30.4 {Tk_DistanceToTextLayout procedure: hit a special char (tab)} -body { - csetup "000\t000\n000" - .t.c bind all <Enter> {lappend x [.t.c index current @%x,%y]} - set x {} - event generate .t.c <Leave> - event generate .t.c <Enter> -x [expr $ax*6] -y 0 - return $x -} -cleanup { - bind all <Enter> {} -} -result {3} -test font-30.5 {Tk_DistanceToTextLayout procedure: ignore newline} -body { - csetup "000\n0\n000" - .t.c bind all <Enter> {lappend x [.t.c index current @%x,%y]} - set x {} - event generate .t.c <Leave> - event generate .t.c <Enter> -x [expr $ax*2] -y $ay - return $x -} -cleanup { - bind all <Enter> {} -} -result {} -test font-30.6 {Tk_DistanceToTextLayout procedure: ignore spaces at eol} -body { - csetup "000\n000 000000000" - .t.c itemconfig text -width [expr $ax*10] - .t.c bind all <Enter> {lappend x [.t.c index current @%x,%y]} - set x {} - event generate .t.c <Leave> - event generate .t.c <Enter> -x [expr $ax*5] -y $ay - .t.c itemconfig text -width 0 - return $x -} -cleanup { - bind all <Enter> {} -} -result {} -.t.c itemconfig text -justify center -test font-30.7 {Tk_DistanceToTextLayout procedure: on left side} -body { - csetup "0\n000" - .t.c bind all <Enter> {lappend x [.t.c index current @%x,%y]} - set x {} - event generate .t.c <Leave> - event generate .t.c <Enter> -x 0 -y 0 - return $x -} -cleanup { - bind all <Enter> {} -} -result {} -test font-30.8 {Tk_DistanceToTextLayout procedure: on right side} -body { - csetup "0\n000" - .t.c bind all <Enter> {lappend x [.t.c index current @%x,%y]} - set x {} - event generate .t.c <Leave> - event generate .t.c <Enter> -x [expr $ax*2] -y 0 - return $x -} -cleanup { - bind all <Enter> {} -} -result {} -test font-30.9 {Tk_DistanceToTextLayout procedure: inside line} -body { - csetup "0\n000" - .t.c bind all <Enter> {lappend x [.t.c index current @%x,%y]} - set x {} - event generate .t.c <Leave> - event generate .t.c <Enter> -x $ax -y 0 - return $x -} -cleanup { - bind all <Enter> {} -} -result {0} -test font-30.10 {Tk_DistanceToTextLayout procedure: above line} -body { - csetup "0\n000" - .t.c bind all <Enter> {lappend x [.t.c index current @%x,%y]} - set x {} - event generate .t.c <Leave> - event generate .t.c <Enter> -x 0 -y 0 - return $x -} -cleanup { - bind all <Enter> {} -} -result {} -test font-30.11 {Tk_DistanceToTextLayout procedure: below line} -body { - csetup "000\n0" - .t.c bind all <Enter> {lappend x [.t.c index current @%x,%y]} - set x {} - event generate .t.c <Leave> - event generate .t.c <Enter> -x 0 -y $ay - return $x -} -cleanup { - bind all <Enter> {} -} -result {} -test font-30.12 {Tk_DistanceToTextLayout procedure: in line} -body { - csetup "0\n000" - .t.c bind all <Enter> {lappend x [.t.c index current @%x,%y]} - set x {} - event generate .t.c <Leave> - event generate .t.c <Enter> -x $ax -y $ay - return $x -} -cleanup { - bind all <Enter> {} -} -result {3} -.t.c itemconfig text -justify left -test font-30.13 {Tk_DistanceToTextLayout procedure: exact hit} -body { - csetup "000" - .t.c bind all <Enter> {lappend x [.t.c index current @%x,%y]} - set x {} - event generate .t.c <Leave> - event generate .t.c <Enter> -x $ax -y 0 - return $x -} -cleanup { - bind all <Enter> {} -} -result {1} -destroy .t.c - - -# Canvas created for tests 31.* -destroy .t.c -canvas .t.c -closeenough 0 -.t.c create text 0 0 -tags text -anchor nw -just left -font "Courier -12" -pack .t.c -update -test font-31.1 {Tk_IntersectTextLayout procedure: loop once} -body { - csetup "000\n000\n000" - .t.c find overlapping 0 0 0 0 -} -result [.t.c find withtag text] -test font-31.2 {Tk_IntersectTextLayout procedure: loop multiple} -body { - csetup "000\t000\t000" - .t.c find overlapping [expr $ax*10] 0 [expr $ax*10] 0 -} -result [.t.c find withtag text] -test font-31.3 {Tk_IntersectTextLayout procedure: loop to end} -body { - csetup "0\n000" - .t.c find overlapping [expr $ax*2] 0 [expr $ax*2] 0 -} -result {} -test font-31.4 {Tk_IntersectTextLayout procedure: hit a special char (tab)} -body { - csetup "000\t000" - .t.c find overlapping [expr $ax*6] 0 [expr $ax*6] 0 -} -result [.t.c find withtag text] -test font-31.5 {Tk_IntersectTextLayout procedure: ignore newlines} -body { - csetup "000\n0\n000" - .t.c find overlapping $ax $ay $ax $ay -} -result {} -test font-31.6 {Tk_IntersectTextLayout procedure: ignore spaces at eol} -body { - csetup "000\n000 000000000" - .t.c itemconfig text -width [expr $ax*10] - set x [.t.c find overlapping [expr $ax*5] $ay [expr $ax*5] $ay] - .t.c itemconfig text -width 0 - return $x -} -result {} -destroy .t.c - - -test font-32.1 {Tk_TextLayoutToPostscript: ensure buffer doesn't overflow} -setup { - destroy .t.c - canvas .t.c -closeenough 0 - .t.c create text 0 0 -tags text -anchor nw -just left -font "Courier -12" - pack .t.c - update -} -body { - # 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" - .t.c itemconfig text -width 800 - .t.c insert text end "qwertyuiopasdfghjklzxcvbnm1234qwertyuiopasdfghjklzxcvbnm\n" - .t.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" - .t.c insert text end "end" - set x [.t.c postscript] - set i [string first "(qwerty" $x] - string range $x $i [expr {$i + 278}] -} -cleanup { - destroy .t.c -} -result {(qwertyuiopasdfghjklzxcvbnm1234qwertyuiopasdfghjklzxcvbnm)] -[(qwertyuiopasdfghjklzxcvbnm1234qwertyuiopasdfghjklzxcvbnm)] -[()] -[()] -[()] -[()] -[()] -[()] -[()] -[()] -[()] -[()] -[()] -[()] -[()] -[()] -[()] -[()] -[()] -[()] -[()] -[()] -[()] -[()] -[()] -[()] -[()] -[()] -[()] -[()] -[()] -[()] -[(end)] -} - - -test font-33.1 {Tk_TextWidth procedure} -body { -} -result {} - - -test font-34.1 {ConfigAttributesObj procedure: arguments} -setup { - catch {font delete xyz} -} -body { - # (Tcl_GetIndexFromObj() != TCL_OK) - font create xyz -xyz -} -returnCodes { - error -} -result {bad option "-xyz": must be -family, -size, -weight, -slant, -underline, or -overstrike} -test font-34.2 {ConfigAttributesObj procedure: arguments} -setup { - catch {font delete xyz} -} -body { - # (objc & 1) - font create xyz -family -} -returnCodes error -result {value for "-family" option missing} - -test font-34.3 {ConfigAttributesObj procedure: family} -setup { - catch {font delete xyz} - set x {} -} -body { - font create xyz -family xyz - lappend x [font config xyz -family] - font config xyz -family times - lappend x [font config xyz -family] -} -cleanup { - font delete xyz -} -result {xyz times} -test font-34.4 {ConfigAttributesObj procedure: size} -setup { - catch {font delete xyz} - set x {} -} -body { - font create xyz -size 20 - lappend x [font config xyz -size] - font config xyz -size 40 - lappend x [font config xyz -size] -} -cleanup { - font delete xyz -} -result {20 40} -test font-34.5 {ConfigAttributesObj procedure: weight} -setup { - catch {font delete xyz} - set x {} -} -body { - font create xyz -weight normal - lappend x [font config xyz -weight] - font config xyz -weight bold - lappend x [font config xyz -weight] -} -cleanup { - font delete xyz -} -result {normal bold} -test font-34.6 {ConfigAttributesObj procedure: slant} -setup { - catch {font delete xyz} - set x {} -} -body { - font create xyz -slant roman - lappend x [font config xyz -slant] - font config xyz -slant italic - lappend x [font config xyz -slant] -} -cleanup { - font delete xyz -} -result {roman italic} -test font-34.7 {ConfigAttributesObj procedure: underline} -setup { - catch {font delete xyz} - set x {} -} -body { - font create xyz -underline 0 - lappend x [font config xyz -underline] - font config xyz -underline 1 - lappend x [font config xyz -underline] -} -cleanup { - font delete xyz -} -result {0 1} -test font-34.8 {ConfigAttributesObj procedure: overstrike} -setup { - catch {font delete xyz} - set x {} -} -body { - font create xyz -overstrike 0 - lappend x [font config xyz -overstrike] - font config xyz -overstrike 1 - lappend x [font config xyz -overstrike] -} -cleanup { - font delete xyz -} -result {0 1} - -test font-34.9 {ConfigAttributesObj procedure: size} -body { - font create xyz -size xyz -} -returnCodes error -result {expected integer but got "xyz"} -test font-34.10 {ConfigAttributesObj procedure: weight} -body { - font create xyz -weight xyz -} -returnCodes error -result {bad -weight value "xyz": must be normal, or bold} -test font-34.11 {ConfigAttributesObj procedure: slant} -body { - font create xyz -slant xyz -} -returnCodes error -result {bad -slant value "xyz": must be roman, or italic} -test font-34.12 {ConfigAttributesObj procedure: underline} -body { - font create xyz -underline xyz -} -returnCodes error -result {expected boolean value but got "xyz"} -test font-34.13 {ConfigAttributesObj procedure: overstrike} -body { - font create xyz -overstrike xyz -} -returnCodes error -result {expected boolean value but got "xyz"} - - -test font-35.1 {GetAttributeInfoObj procedure: one attribute} -setup { - catch {font delete xyz} -} -body { - # (objPtr != NULL) - font create xyz -family xyz - font config xyz -family -} -cleanup { - font delete xyz -} -result {xyz} - - -test font-36.1 {GetAttributeInfoObj procedure: unknown attribute} -setup { - catch {font delete xyz} -} -body { - # (Tcl_GetIndexFromObj() != TCL_OK) - font create xyz - font config xyz -xyz -} -cleanup { - font delete xyz -} -returnCodes { - error -} -result {bad option "-xyz": must be -family, -size, -weight, -slant, -underline, or -overstrike} - - -test font-37.1 {GetAttributeInfoObj procedure: all attributes} -setup { - catch {font delete xyz} -} -body { - # not (objPtr != NULL) - font create xyz -family xyz - font config xyz -} -cleanup { - font delete xyz -} -result {-family xyz -size 0 -weight normal -slant roman -underline 0 -overstrike 0} -test font-37.2 {GetAttributeInfo procedure: family} -setup { - catch {font delete xyz} -} -body { - font create xyz -family xyz - font config xyz -family -} -cleanup { - font delete xyz -} -result {xyz} -test font-37.3 {GetAttributeInfo procedure: size} -setup { - catch {font delete xyz} - set x {} -} -body { - font create xyz -size 20 - font config xyz -size -} -cleanup { - font delete xyz -} -result {20} -test font-37.4 {GetAttributeInfo procedure: weight} -setup { - catch {font delete xyz} - set x {} -} -body { - font create xyz -weight normal - font config xyz -weight -} -cleanup { - font delete xyz -} -result {normal} -test font-37.5 {GetAttributeInfo procedure: slant} -setup { - catch {font delete xyz} - set x {} -} -body { - font create xyz -slant italic - font config xyz -slant -} -cleanup { - font delete xyz -} -result {italic} -test font-37.6 {GetAttributeInfo procedure: underline} -setup { - catch {font delete xyz} - set x {} -} -body { - font create xyz -underline yes - font config xyz -underline -} -cleanup { - font delete xyz -} -result {1} -test font-37.7 {GetAttributeInfo procedure: overstrike} -setup { - catch {font delete xyz} - set x {} -} -body { - font create xyz -overstrike no - font config xyz -overstrike -} -cleanup { - font delete xyz -} -result {0} - - -# 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. - -test font-38.1 {ParseFontNameObj procedure: begins with -} -body { - lindex [font actual -xyz-times-*-*-*-*-*-*-*-*-*-*-*-*] 1 -} -result [font actual {times 0} -family] -test font-38.2 {ParseFontNameObj procedure: begins with -*} -body { - lindex [font actual -*-times-xyz-*-*-*-*-*-*-*-*-*-*-*] 1 -} -result [font actual {times 0} -family] -test font-38.3 {ParseFontNameObj procedure: begins with -, doesn't look like list} -body { - lindex [font actual -xyz-times-*-*-*-*-*-*-*-*-*-*-*-*] 1 -} -result [font actual {times 0} -family] -test font-38.4 {ParseFontNameObj procedure: begins with -, looks like list} -body { - lindex [font actual {-family times}] 1 -} -result [font actual {times 0} -family] -test font-38.5 {ParseFontNameObj procedure: begins with *} -body { - lindex [font actual *-times-xyz-*-*-*-*-*-*-*-*-*-*-*] 1 -} -result [font actual {times 0} -family] -test font-38.6 {ParseFontNameObj procedure: begins with *} -body { - font actual *-times-xyz -family -} -result [font actual {times 0} -family] -test font-38.7 {ParseFontNameObj procedure: arguments} -constraints noExceed -body { - font actual "\{xyz" -} -returnCodes error -result "font \"{xyz\" doesn't exist" -test font-38.8 {ParseFontNameObj procedure: arguments} -constraints noExceed -body { - font actual "" -} -returnCodes error -result {font "" doesn't exist} -test font-38.9 {ParseFontNameObj procedure: arguments} -body { - font actual {times 20 xyz xyz} -} -returnCodes error -result {unknown font style "xyz"} -test font-38.10 {ParseFontNameObj procedure: arguments} -body { - font actual {times xyz xyz} -} -returnCodes error -result {expected integer but got "xyz"} -test font-38.11 {ParseFontNameObj procedure: stylelist loop} -constraints { - unixOrPc -} -body { - lrange [font actual {times 12 bold italic overstrike underline}] 4 end -} -result {-weight bold -slant italic -underline 1 -overstrike 1} -test font-38.12 {ParseFontNameObj procedure: stylelist error} -body { - font actual {times 12 bold xyz} -} -returnCodes error -result {unknown font style "xyz"} -test font-38.13 "ParseFontNameObj: options with hyphenated family: bug #2791352" -body { - font actual {-family sans-serif -size 12 -weight bold -slant roman -underline 0 -overstrike 0} -} -returnCodes ok -result [font actual {sans-serif 12 bold}] -test font-38.14 "ParseFontNameObj: bug #2791352" -body { - font actual {-invalidfont 8 bold} -} -returnCodes error -match glob -result {bad option "-invalidfont": *} - - -test font-39.1 {NewChunk procedure: test realloc} -setup { - destroy .t.f - pack [label .t.f] - update -} -body { - .t.f config -text "xxx\nxxx\txxx\nxxx\t\t\t" -} -cleanup { - destroy .t.f -} -result {} - - -test font-40.1 {TkFontParseXLFD procedure: initial dash} -body { - font actual -xyz-times-*-*-*-*-*-*-*-*-*-*-*-* -family -} -result [font actual {times 0} -family] -test font-40.2 {TkFontParseXLFD procedure: no initial dash} -body { - font actual *-times-*-*-*-*-*-*-*-*-*-*-*-xyz -family -} -result [font actual {times 0} -family] -test font-40.3 {TkFontParseXLFD procedure: not enough fields} -body { - font actual -xyz-times-*-*-* -family -} -result [font actual {times 0} -family] -test font-40.4 {TkFontParseXLFD procedure: all fields unspecified} -body { - lindex [font actual -xyz-*-*-*-*-*-*-*-*-*-*-*-*-*] 0 -} -result {-family} -test font-40.5 {TkFontParseXLFD procedure: all fields specified} -body { - lindex [font actual \ - -foundry-times-weight-slant-setwidth-addstyle-10-10-10-10-spacing-avgwidth-registry-encoding] 1 -} -result [font actual {times 0} -family] - - -test font-41.1 {TkParseXLFD procedure: arguments} -body { - # XLFD with bad pointsize: fallback to some system font. - font actual -*-*-*-*-*-*-xyz-*-*-*-*-*-*-* - set x {} -} -result {} - - -test font-42.1 {TkFontParseXLFD procedure: arguments} -body { - # XLFD with bad pixelsize: fallback to some system font. - font actual -*-*-*-*-*-*-*-xyz-*-*-*-*-*-* - set x {} -} -result {} -test font-42.2 {TkFontParseXLFD procedure: pixelsize specified} -body { - font metrics -xyz-times-*-*-*-*-12-*-*-*-*-*-*-* -linespace - set x {} -} -result {} -test font-42.3 {TkFontParseXLFD procedure: weird pixelsize specified} -body { - font metrics {-xyz-times-*-*-*-*-[ 12.0 0 12.0 0]-*-*-*-*-*-*-*} -linespace - set x {} -} -result {} -test font-42.4 {TkFontParseXLFD procedure: pointsize specified} -body { - font metrics -xyz-times-*-*-*-*-*-120-*-*-*-*-*-* -linespace - set x {} -} -result {} -test font-42.5 {TkFontParseXLFD procedure: weird pointsize specified} -body { - font metrics {-xyz-times-*-*-*-*-*-[ 12.0 0 12.0 0]-*-*-*-*-*-*} -linespace - set x {} -} -result {} - - -test font-43.1 {FieldSpecified procedure: specified vs. non-specified} -body { - font actual -xyz--*-*-*-*-*-*-*-*-*-*-*-* - font actual -xyz-*-*-*-*-*-*-*-*-*-*-*-*-* - font actual -xyz-?-*-*-*-*-*-*-*-*-*-*-*-* - lindex [font actual -xyz-times-*-*-*-*-*-*-*-*-*-*-*-*] 1 -} -result [font actual {times 0} -family] - - -test font-44.1 {TkFontGetPixels: size < 0} -setup { - set oldscale [tk scaling] -} -body { - tk scaling 0.5 - font actual {times -12} -size -} -cleanup { - tk scaling $oldscale -} -result {24} -test font-44.2 {TkFontGetPoints: size >= 0} -constraints noExceed -setup { - set oldscale [tk scaling] -} -body { - tk scaling 0.5 - font actual {times 12} -size -} -cleanup { - tk scaling $oldscale -} -result {12} - - -test font-45.1 {TkFontGetAliasList: no match} -body { - font actual {snarky 10} -family -} -result [font actual {-size 10} -family] -test font-45.2 {TkFontGetAliasList: match} -constraints win -body { - font actual {times 10} -family -} -result {Times New Roman} -test font-45.3 {TkFontGetAliasList: match} -constraints {unix noExceed} -body { - # can fail on Unix systems that have a real "times new roman" font - font actual {{times new roman} 10} -family -} -result [font actual {times 10} -family] - - -test font-46.1 {font actual, with character, no option, no --} -body { - font actual {times 10} a -} -match glob -result [list -family [font actual {times 10} -family] -size *\ - -slant roman -underline 0 -overstrike 0] - -test font-46.2 {font actual, with character introduced by --} -body { - font actual {times 10} -- - -} -match glob -result [list -family [font actual {times 10} -family] -size *\ - -slant roman -underline 0 -overstrike 0] - -test font-46.3 {font actual, with character and option} -body { - font actual {times 10} -family a -} -result [font actual {times 10} -family] - -test font-46.4 {font actual, with character, option and --} -body { - font actual {times 10} -family -- - -} -result [font actual {times 10} -family] - -test font-46.5 {font actual, too many chars} -body { - font actual {times 10} 123456789012345678901234567890123456789012345678901 -} -returnCodes error -result {expected a single character but got "1234567890123456789012345678901234567..."} - -test font-47.1 {Bug f214b8ad5b} -body { - interp create one - interp create two - load {} Tk one - load {} Tk two - one eval menu .menubar - two eval menu .menubar - interp delete one - interp delete two -} -result {} - -# cleanup -cleanupTests -return - - - - |