2559 lines
79 KiB
Plaintext
2559 lines
79 KiB
Plaintext
# 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
|
|
|
|
# Some tests require support for 4-byte UTF-8 sequences
|
|
testConstraint fullutf [expr {[format %c 0x010000] != "\uFFFD"}]
|
|
|
|
testConstraint failsOnUbuntu [expr {![info exists ::env(CI)] || ![string match Linux $::tcl_platform(os)]}]
|
|
testConstraint failsOnUbuntuNoXft [expr {[testConstraint failsOnUbuntu] || (![catch {tk::pkgconfig get fontsystem} fs] && ($fs eq "xft"))}]
|
|
|
|
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 "TkFixedFont"}
|
|
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 failsOnUbuntu} -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-4.12 {font command: actual} -body {
|
|
font actual {-family times} -- \ud800
|
|
} -match glob -result {*}
|
|
test font-4.13 {font command: actual} -body {
|
|
font actual {-family times} -- \udc00
|
|
} -match glob -result {*}
|
|
test font-4.14 {font command: actual} -constraints win -body {
|
|
font actual {-family times} -family -- \uD800\uDC00
|
|
} -result {Times New Roman}
|
|
test font-4.15 {font command: actual} -body {
|
|
font actual {-family times} -- \udc00\ud800
|
|
} -returnCodes 1 -match glob -result {expected a single character but got "*"}
|
|
test font-4.16 {font command: actual} -constraints {fullutf win} -body {
|
|
font actual {-family times} -family -- \U10000
|
|
} -result {Times New Roman}
|
|
|
|
|
|
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} -constraints failsOnUbuntu -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 idletasks
|
|
} -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 idletasks
|
|
set b1 [winfo reqwidth .t.f]
|
|
font configure xyz -family helvetica -size 20
|
|
set a2 [font measure xyz "abcd"]
|
|
update idletasks
|
|
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 {
|
|
x11 failsOnUbuntu
|
|
} -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}]}]
|
|
set 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 {}
|
|
test font-31.7 {TkIntersectAngledTextLayout procedure: bug [514ff64dd0]} -body {
|
|
csetup "This is line one\nand line two\nand line three here"
|
|
.t.c itemconfigure text -angle 90
|
|
# Coordinates of the rectangle to check can be hardcoded:
|
|
# The goal of this test is to check whether the overlap detection algorithm
|
|
# works when the rectangle is entirely included in a chunk of the text layout.
|
|
# The text has been rotated 90 degrees around it's upper left corner,
|
|
# so it's enough to check with a small rectangle with small negative y coords.
|
|
.t.c find overlapping 5 -7 7 -5
|
|
} -result {1}
|
|
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 {
|
|
unixOrWin failsOnUbuntuNoXft
|
|
} -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} -constraints failsOnUbuntu -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 failsOnUbuntuNoXft} -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 {noExceed failsOnUbuntu} -body {
|
|
if {[font actual {{times new roman} 10} -family] eq "Times New Roman"} {
|
|
# avoid test failure on systems that have a real "times new roman" font
|
|
set res 1
|
|
} else {
|
|
set res [expr {[font actual {{times new roman} 10} -family] eq \
|
|
[font actual {times 10} -family]} ]
|
|
}
|
|
} -result {1}
|
|
|
|
|
|
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 {}
|
|
|
|
test font-47.2 {Bug 3049518,TIP 608 - Canvas} -body {
|
|
if {"MyFont" ni [font names]} {
|
|
font create MyFont -family "Liberation Sans" -size 13
|
|
}
|
|
set text Hello!
|
|
destroy .t.c
|
|
set c [canvas .t.c]
|
|
set textid [$c create text 20 20 -font MyFont -text $text -anchor nw]
|
|
set twidth [font measure MyFont $text]
|
|
set theight [font metrics MyFont -linespace]
|
|
set circid [$c create polygon \
|
|
15 15 \
|
|
[expr {15 + $twidth}] 15 \
|
|
[expr {15 + $twidth}] [expr {15 + $theight}] \
|
|
15 [expr {15 + $theight}] \
|
|
-width 1 -joinstyle round -smooth true -fill {} -outline blue]
|
|
pack $c -fill both -expand 1 -side top
|
|
tkwait visibility $c
|
|
|
|
# Lamda test functions
|
|
set circle_text {{w user_data text circ} {
|
|
if {[winfo class $w] ne "Canvas"} {
|
|
puts "Wrong widget type: $w"
|
|
return
|
|
}
|
|
if {$user_data ne "FontChanged"} {
|
|
return
|
|
}
|
|
lappend ::results called-$w
|
|
lassign [$w bbox $text] x0 y0 x1 y1
|
|
set offset 5
|
|
set coord [lmap expr {
|
|
$x0-5 $y0-5 $x1+5 $y0-5
|
|
$x1+5 $y1+5 $x0-5 $y1+5
|
|
} {expr $expr}]
|
|
if {[catch {$w coord $circ $coord} err]} {
|
|
puts Error:$err
|
|
}
|
|
}}
|
|
set waitfor {{tag {time 333}} {after $time incr ::wait4; vwait ::wait4}}
|
|
set enclosed {{can id} {$can find enclosed {*}[$can bbox $id]}}
|
|
|
|
set results {}
|
|
apply $circle_text $c FontChanged $textid $circid
|
|
bind $c <<TkWorldChanged>> [list apply $circle_text %W %d $textid $circid]
|
|
apply $waitfor 1
|
|
|
|
# Begin test:
|
|
set results {}
|
|
lappend results [apply $enclosed $c $circid]
|
|
font configure MyFont -size 26
|
|
apply $waitfor 2
|
|
lappend results [apply $enclosed $c $circid]
|
|
font configure MyFont -size 9
|
|
apply $waitfor 3
|
|
lappend results [apply $enclosed $c $circid]
|
|
apply $waitfor 4
|
|
font configure MyFont -size 12
|
|
apply $waitfor 5
|
|
lappend results [apply $enclosed $c $circid]
|
|
} -cleanup {
|
|
destroy $c
|
|
unset -nocomplain ::results
|
|
} -result {{1 2} called-.t.c {1 2} called-.t.c {1 2} called-.t.c {1 2}}
|
|
|
|
test font-47.3 {Bug 3049518, TIP 608 - Label} -body {
|
|
if {"MyFont" ni [font names]} {
|
|
font create MyFont -family "Liberation Sans" -size 13
|
|
}
|
|
set text "Label Test"
|
|
destroy .t.l
|
|
|
|
set make-img {{size} {
|
|
set img [image create photo -width $size -height $size]
|
|
$img blank
|
|
set max [expr {$size - 1}]
|
|
for {set x 0} {$x < $size} {incr x} {
|
|
$img put red -to $x $x
|
|
$img put black -to 0 $x
|
|
$img put black -to $x 0
|
|
$img put black -to $max $x
|
|
$img put black -to $x $max
|
|
}
|
|
return $img
|
|
}}
|
|
|
|
set testWorldChanged {{w user_data} {
|
|
global make-img
|
|
if {$user_data ne "FontChanged"} {
|
|
return
|
|
}
|
|
if {![winfo exists $w] || [winfo class $w] ne "Label"} {
|
|
return
|
|
}
|
|
if {[$w cget -image] ne ""} {
|
|
image delete [$w cget -image]
|
|
}
|
|
set size [font metrics [$w cget -font] -linespace]
|
|
set img [apply ${make-img} $size]
|
|
$w configure -image $img
|
|
}}
|
|
|
|
set waitfor {{tag {time 500}} {
|
|
after $time incr ::wait4
|
|
vwait ::wait4
|
|
}}
|
|
|
|
set check {{w} {
|
|
global results
|
|
set f [$w cget -font]
|
|
set i [$w cget -image]
|
|
set fs [font metrics $f -linespace]
|
|
set ish [image height $i]
|
|
set isw [image width $i]
|
|
lappend results [list [expr {$fs == $ish ? 1 : [list $fs $ish]}] [expr {$fs == $isw ? 1 : [list $fs $isw]}]]
|
|
}}
|
|
|
|
set size [font metrics MyFont -linespace]
|
|
set img [apply ${make-img} $size]
|
|
set l [label .t.l -compound left -image $img -text $text -font MyFont]
|
|
pack $l -side top -fill both -expand 1
|
|
bind $l <<TkWorldChanged>> [list apply $testWorldChanged %W %d]
|
|
set ::results {}
|
|
|
|
apply $waitfor 0
|
|
apply $check $l
|
|
font configure MyFont -size 26
|
|
apply $waitfor 1
|
|
apply $check $l
|
|
font configure MyFont -size 9
|
|
apply $waitfor 2
|
|
apply $check $l
|
|
font configure MyFont -size 13
|
|
apply $waitfor 3
|
|
apply $check $l
|
|
set results
|
|
} -cleanup {
|
|
destroy $l
|
|
unset -nocomplain ::results
|
|
} -result {{1 1} {1 1} {1 1} {1 1}}
|
|
|
|
# cleanup
|
|
cleanupTests
|
|
return
|
|
|
|
|
|
|
|
|