diff options
| -rw-r--r-- | ChangeLog | 7 | ||||
| -rw-r--r-- | tests/clrpick.test | 193 | ||||
| -rw-r--r-- | tests/font.test | 2804 | ||||
| -rw-r--r-- | tests/frame.test | 1483 | ||||
| -rw-r--r-- | tests/image.test | 604 |
5 files changed, 3439 insertions, 1652 deletions
@@ -1,3 +1,10 @@ +2008-08-15 Ania Pawelczyk <aniap@users.sourceforge.net> + + * tests/clrpick.test: Update to tcltest2 + * tests/frame.test: + * tests/font.test: + * tests/image.test: + 2008-08-14 Ania Pawelczyk <aniap@users.sourceforge.net> * test/event.test: Update to tcltest2 diff --git a/tests/clrpick.test b/tests/clrpick.test index 874a532..0502a69 100644 --- a/tests/clrpick.test +++ b/tests/clrpick.test @@ -5,12 +5,13 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: clrpick.test,v 1.13 2007/05/09 12:52:44 das Exp $ +# RCS: @(#) $Id: clrpick.test,v 1.14 2008/08/15 01:10:03 aniap Exp $ # -package require tcltest 2.1 +package require tcltest 2.2 eval tcltest::configure $argv tcltest::loadTestedCommands +namespace import -force tcltest::test if {[testConstraint defaultPseudocolor8]} { # let's soak up a bunch of colors...so that @@ -46,51 +47,54 @@ if {[testConstraint defaultPseudocolor8]} { testConstraint colorsLeftover 0 } -test clrpick-1.1 {tk_chooseColor command} { - list [catch {tk_chooseColor -foo} msg] $msg -} {1 {bad option "-foo": must be -initialcolor, -parent, or -title}} - -catch {tk_chooseColor -foo 1} msg -regsub -all , $msg "" options -regsub \"-foo\" $options "" options - -foreach option $options { - if {[string index $option 0] eq "-"} { - test clrpick-1.2$option {tk_chooseColor command} -body { - tk_chooseColor $option - } -returnCodes error -result "value for \"$option\" missing" - } -} - -test clrpick-1.3 {tk_chooseColor command} { - list [catch {tk_chooseColor -foo bar} msg] $msg -} {1 {bad option "-foo": must be -initialcolor, -parent, or -title}} -test clrpick-1.4 {tk_chooseColor command} { - list [catch {tk_chooseColor -initialcolor} msg] $msg -} {1 {value for "-initialcolor" missing}} -test clrpick-1.5 {tk_chooseColor command} { - list [catch {tk_chooseColor -parent foo.bar} msg] $msg -} {1 {bad window path name "foo.bar"}} -test clrpick-1.6 {tk_chooseColor command} { - list [catch {tk_chooseColor -initialcolor badbadbaadcolor} msg] $msg -} {1 {unknown color name "badbadbaadcolor"}} -test clrpick-1.7 {tk_chooseColor command} { - list [catch {tk_chooseColor -initialcolor ##badbadbaadcolor} msg] $msg -} {1 {invalid color name "##badbadbaadcolor"}} - +test clrpick-1.1 {tk_chooseColor command} -body { + tk_chooseColor -foo +} -returnCodes error -result {bad option "-foo": must be -initialcolor, -parent, or -title} + +test clrpick-1.2 {tk_chooseColor command } -body { + tk_chooseColor -initialcolor +} -returnCodes error -result {value for "-initialcolor" missing} +test clrpick-1.2 {tk_chooseColor command } -body { + tk_chooseColor -parent +} -returnCodes error -result {value for "-parent" missing} +test clrpick-1.2 {tk_chooseColor command } -body { + tk_chooseColor -title +} -returnCodes error -result {value for "-title" missing} + +test clrpick-1.3 {tk_chooseColor command} -body { + tk_chooseColor -foo bar +} -returnCodes error -result {bad option "-foo": must be -initialcolor, -parent, or -title} +test clrpick-1.4 {tk_chooseColor command} -body { + tk_chooseColor -initialcolor +} -returnCodes error -result {value for "-initialcolor" missing} +test clrpick-1.5 {tk_chooseColor command} -body { + tk_chooseColor -parent foo.bar +} -returnCodes error -result {bad window path name "foo.bar"} +test clrpick-1.6 {tk_chooseColor command} -body { + tk_chooseColor -initialcolor badbadbaadcolor +} -returnCodes error -result {unknown color name "badbadbaadcolor"} +test clrpick-1.7 {tk_chooseColor command} -body { + tk_chooseColor -initialcolor ##badbadbaadcolor +} -returnCodes error -result {invalid color name "##badbadbaadcolor"} + + +# tests 3.1 and 3.2 fail when individually run +# if there is no catch {tk_chooseColor -foo 1} msg +# before settin isNative +catch {tk_chooseColor -foo 1} msg set isNative [expr {[info commands tk::dialog::color::] eq ""}] proc ToPressButton {parent btn} { global isNative if {!$isNative} { - after 200 "SendButtonPress $parent $btn mouse" + after 200 "SendButtonPress . $btn mouse" } } proc ToChooseColorByKey {parent r g b} { global isNative if {!$isNative} { - after 200 ChooseColorByKey $parent $r $g $b + after 200 ChooseColorByKey . $r $g $b } } @@ -118,7 +122,7 @@ proc ChooseColorByKey {parent r g b} { # the values for us. tk::dialog::color::HandleRGBEntry $w - SendButtonPress $parent ok mouse + SendButtonPress . ok mouse } proc SendButtonPress {parent btn type} { @@ -140,65 +144,76 @@ proc SendButtonPress {parent btn type} { } } -set parent . - -set verylongstring longstring: -set verylongstring $verylongstring$verylongstring -set verylongstring $verylongstring$verylongstring -set verylongstring $verylongstring$verylongstring -set verylongstring $verylongstring$verylongstring -#set verylongstring $verylongstring$verylongstring -# Interesting thing...when this is too long, the -# delay caused in processing it kills the automated testing, -# and makes a lot of the test cases fail. -#set verylongstring $verylongstring$verylongstring -#set verylongstring $verylongstring$verylongstring -#set verylongstring $verylongstring$verylongstring -#set verylongstring $verylongstring$verylongstring - -set color #404040 -test clrpick-2.1 {tk_chooseColor command} \ - {nonUnixUserInteraction colorsLeftover} { - ToPressButton $parent ok - tk_chooseColor -title "Press Ok $verylongstring" -initialcolor $color \ - -parent $parent -} "$color" -set color #808040 -test clrpick-2.2 {tk_chooseColor command} \ - {nonUnixUserInteraction colorsLeftover} { + + +test clrpick-2.1 {tk_chooseColor command} -constraints { + nonUnixUserInteraction colorsLeftover +} -setup { + set verylongstring longstring: + set verylongstring $verylongstring$verylongstring + set verylongstring $verylongstring$verylongstring + set verylongstring $verylongstring$verylongstring + set verylongstring $verylongstring$verylongstring + #set verylongstring $verylongstring$verylongstring + # Interesting thing...when this is too long, the + # delay caused in processing it kills the automated testing, + # and makes a lot of the test cases fail. + #set verylongstring $verylongstring$verylongstring + #set verylongstring $verylongstring$verylongstring + #set verylongstring $verylongstring$verylongstring + #set verylongstring $verylongstring$verylongstring +} -body { + ToPressButton . ok + tk_chooseColor -title "Press Ok $verylongstring" -initialcolor #404040 \ + -parent . +} -result {#404040} +test clrpick-2.2 {tk_chooseColor command} -constraints { + nonUnixUserInteraction colorsLeftover +} -body { set colors "128 128 64" - ToChooseColorByKey $parent 128 128 64 - tk_chooseColor -parent $parent -title "choose $colors" -} "$color" -test clrpick-2.3 {tk_chooseColor command} \ - {nonUnixUserInteraction colorsLeftover} { - ToPressButton $parent ok - tk_chooseColor -parent $parent -title "Press OK" -} "$color" -test clrpick-2.4 {tk_chooseColor command} {nonUnixUserInteraction} { - ToPressButton $parent cancel - tk_chooseColor -parent $parent -title "Press Cancel" -} "" - -set color "#000000" -test clrpick-3.1 {tk_chooseColor: background events} {nonUnixUserInteraction} { + ToChooseColorByKey . 128 128 64 + tk_chooseColor -parent . -title "choose #808040" +} -result {#808040} +test clrpick-2.3 {tk_chooseColor command} -constraints { + nonUnixUserInteraction colorsLeftover +} -body { + ToPressButton . ok + tk_chooseColor -parent . -title "Press OK" +} -result {#808040} +test clrpick-2.4 {tk_chooseColor command} -constraints { + nonUnixUserInteraction colorsLeftover +} -body { + ToPressButton . cancel + tk_chooseColor -parent . -title "Press Cancel" +} -result {} + + +test clrpick-3.1 {tk_chooseColor: background events} -constraints { + nonUnixUserInteraction +} -body { after 1 {set x 53} - ToPressButton $parent ok - tk_chooseColor -parent $parent -title "Press OK" -initialcolor $color -} "#000000" -test clrpick-3.2 {tk_chooseColor: background events} {nonUnixUserInteraction} { + ToPressButton . ok + tk_chooseColor -parent . -title "Press OK" -initialcolor #000000 +} -result {#000000} +test clrpick-3.2 {tk_chooseColor: background events} -constraints { + nonUnixUserInteraction +} -body { after 1 {set x 53} - ToPressButton $parent cancel - tk_chooseColor -parent $parent -title "Press Cancel" -} "" + ToPressButton . cancel + tk_chooseColor -parent . -title "Press Cancel" +} -result {} -test clrpick-4.1 {tk_chooseColor: screen is inherited from parent} {unix notAqua} { + +test clrpick-4.1 {tk_chooseColor: screen is inherited from parent} -constraints { + unix notAqua +} -body { after 50 {set ::scr [winfo screen .__tk__color]} - ToPressButton $parent cancel - tk_chooseColor -parent $parent + ToPressButton . cancel + tk_chooseColor -parent . set ::scr -} [winfo screen $parent] +} -result [winfo screen .] # cleanup cleanupTests return + diff --git a/tests/font.test b/tests/font.test index b31bf5a..6cf820e 100644 --- a/tests/font.test +++ b/tests/font.test @@ -6,47 +6,20 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: font.test,v 1.18 2008/07/23 23:24:25 nijtmans Exp $ +# RCS: @(#) $Id: font.test,v 1.19 2008/08/15 01:10:03 aniap Exp $ -package require tcltest 2.1 +package require tcltest 2.2 +namespace import ::tcltest::* eval tcltest::configure $argv tcltest::loadTestedCommands -catch {destroy .b} -toplevel .b -wm geom .b +0+0 -update idletasks - -proc setup {} { - catch {destroy .b.f} - catch {eval font delete [font names]} - label .b.f - pack .b.f - update -} - -label .b.l -padx 0 -pady 0 -bd 0 -highlightthickness 0 -justify left -text "0" -font "Courier -12" -pack .b.l -canvas .b.c -closeenough 0 -.b.c create text 0 0 -tags text -anchor nw -just left -font "Courier -12" -pack .b.c -update - -set ax [winfo reqwidth .b.l] -set ay [winfo reqheight .b.l] -proc getsize {} { - update - return "[winfo reqwidth .b.l] [winfo reqheight .b.l]" -} -proc csetup {{str ""}} { - focus -force .b.c - .b.c dchars text 0 end - .b.c insert text 0 $str - .b.c focus text -} - -setup +catch {eval font delete [font names]} +deleteWindows +# Toplevel used (in some tests) of the whole file +toplevel .t +wm geom .t +0+0 +update idletasks case [tk windowingsystem] { x11 {set fixed "fixed"} @@ -56,195 +29,242 @@ case [tk windowingsystem] { } -set times [font actual {times 0} -family] +# 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} { + +test font-1.1 {TkFontPkgInit} -setup { catch {interp delete foo} +} -body { interp create foo foo eval { - load {} Tk - wm geometry . +0+0 - update + load {} Tk + wm geometry . +0+0 + update } interp delete foo -} {} +} -result {} -test font-2.1 {TkFontPkgFree} { + +test font-2.1 {TkFontPkgFree} -setup { catch {interp delete foo} - interp create 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 + 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 . + .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}} - interp delete foo - set x -} {{named font "wiggles" doesn't exist} {can't invoke "font" command: application has been destroyed}} +test font-3.1 {font command: general} -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-3.1 {font command: general} { - list [catch {font} msg] $msg -} {1 {wrong # args: should be "font option ?arg?"}} -test font-3.2 {font command: general} { - list [catch {font xyz} msg] $msg -} {1 {bad option "xyz": must be actual, configure, create, delete, families, measure, metrics, or names}} -test font-4.1 {font command: actual: arguments} { +test font-4.1 {font command: actual: arguments} -body { # (skip < 0) - list [catch {font actual xyz -displayof} msg] $msg -} {1 {value for "-displayof" missing}} -test font-4.2 {font command: actual: arguments} { + font actual xyz -displayof +} -returnCodes error -result {value for "-displayof" missing} +test font-4.2 {font command: actual: arguments} -body { # (objc < 3) - list [catch {font actual} msg] $msg -} {1 {wrong # args: should be "font actual font ?-displayof window? ?option? ?--? ?char?"}} -test font-4.3 {font command: actual: arguments} { + 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 - list [catch {font actual xyz abc def} msg] $msg -} {1 {wrong # args: should be "font actual font ?-displayof window? ?option? ?--? ?char?"}} -test font-4.4 {font command: actual: displayof specified, so skip to next} { + 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} -} {0} -test font-4.5 {font command: actual: displayof specified, so skip to next} { +} -result {0} +test font-4.5 {font command: actual: displayof specified, so skip to next} -body { lindex [font actual xyz -displayof .] 0 -} {-family} -test font-4.6 {font command: actual: arguments} { +} -result {-family} +test font-4.6 {font command: actual: arguments} -body { # (objc - skip > 4) when skip == 2 - list [catch {font actual xyz -displayof . abc def} msg] $msg -} {1 {wrong # args: should be "font actual font ?-displayof window? ?option? ?--? ?char?"}} -test font-4.7 {font command: actual: arguments} {noExceed} { + 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) - list [catch {font actual "\{xyz"} msg] $msg -} [list 1 "font \"{xyz\" doesn't exist"] -test font-4.8 {font command: actual: all attributes} { + 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 -} {-family} -test font-4.9 {font command: actual} {unix noExceed} { +} -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] -} {times} -test font-4.10 {font command: actual} win { +} -result {times} +test font-4.10 {font command: actual} -constraints win -body { # (objc > 3) so objPtr = objv[3 + skip] font actual {-family times} -family -} {Times New Roman} -test font-4.11 {font command: bad option} { - list [catch {font actual xyz -style} msg] $msg -} {1 {bad option "-style": must be -family, -size, -weight, -slant, -underline, or -overstrike}} +} -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} { + +test font-5.1 {font command: configure} -body { # (objc < 3) - list [catch {font configure} msg] $msg -} {1 {wrong # args: should be "font configure fontname ?-option value ...?"}} -test font-5.2 {font command: configure: non-existent font} { + 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) - list [catch {font configure xyz} msg] $msg -} {1 {named font "xyz" doesn't exist}} -test font-5.3 {font command: configure: "deleted" font} { + 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) - setup font create xyz - .b.f configure -font xyz + .t.f configure -font xyz font delete xyz - list [catch {font configure xyz} msg] $msg -} {1 {named font "xyz" doesn't exist}} -test font-5.4 {font command: configure: get all options} { + 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 - setup font create xyz -family xyz lindex [font configure xyz] 1 -} xyz -test font-5.5 {font command: configure: get one option} { +} -cleanup { + font delete xyz +} -result xyz +test font-5.5 {font command: configure: get one option} -setup { + catch {eval font delete [font names]} +} -body { # (objc == 4) so objPtr = objv[3] - setup font create xyz -family xyz font configure xyz -family -} xyz -test font-5.6 {font command: configure: update existing font} { + font names +} -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() - setup font create xyz font configure xyz -family xyz update font configure xyz -family -} xyz -test font-5.7 {font command: configure: bad option} { - setup +} -cleanup { + font delete xyz +} -result xyz +test font-5.7 {font command: configure: bad option} -setup { + catch {font delete xyz} +} -body { font create xyz - list [catch {font configure xyz -style} msg] $msg -} {1 {bad option "-style": must be -family, -size, -weight, -slant, -underline, or -overstrike}} + 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} { +test font-6.1 {font command: create: make up name} -setup { + catch {eval font delete [font names]} +} -body { # (objc < 3) so name = NULL - setup font create font names -} {font1} -test font-6.2 {font command: create: name specified} { +} -cleanup { + font delete font1 +} -result {font1} +test font-6.2 {font command: create: name specified} -setup { + catch {eval font delete [font names]} +} -body { # not (objc < 3) - setup font create xyz font names -} {xyz} -test font-6.3 {font command: create: name not really specified} { +} -cleanup { + font delete xyz +} -result {xyz} +test font-6.3 {font command: create: name not really specified} -setup { + catch {eval font delete [font names]} +} -body { # (name[0] == '-') so name = NULL - setup font create -family xyz font names -} {font1} -test font-6.4 {font command: create: generate name} { +} -cleanup { + font delete font1 +} -result {font1} +test font-6.4 {font command: create: generate name} -setup { + catch {eval font delete [font names]} +} -body { # (name == NULL) - setup font create -family one font create -family two font create -family three font delete font2 font create -family four font configure font2 -family -} {four} -test font-6.5 {font command: create: bad option creating new font} { +} -cleanup { + catch {eval font delete [font names]} +} -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 - setup - list [catch {font create xyz -xyz times} msg] $msg -} {1 {bad option "-xyz": must be -family, -size, -weight, -slant, -underline, or -overstrike}} -test font-6.6 {font command: create: bad option creating new font} { + 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 { + catch {eval font delete [font names]} +} -body { # name was not specified so skip = 2 - setup - list [catch {font create -xyz times} msg] $msg -} {1 {bad option "-xyz": must be -family, -size, -weight, -slant, -underline, or -overstrike}} -test font-6.7 {font command: create: already exists} { + 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) - setup font create xyz - list [catch {font create xyz} msg] $msg -} {1 {named font "xyz" already exists}} + font create xyz +} -cleanup { + font delete xyz +} -returnCodes error -result {named font "xyz" already exists} -test font-7.1 {font command: delete: arguments} { +test font-7.1 {font command: delete: arguments} -body { # (objc < 3) - list [catch {font delete} msg] $msg -} {1 {wrong # args: should be "font delete fontname ?fontname ...?"}} -test font-7.2 {font command: delete: loop test} { + font delete +} -returnCodes error -result {wrong # args: should be "font delete fontname ?fontname ...?"} +test font-7.2 {font command: delete: loop test} -setup { + catch {eval font delete [font names]} + set x {} +} -body { # for (i = 2; i < objc; i++) - setup - set x {} font create a -underline 1 font create b -underline 1 font create c -underline 1 @@ -253,11 +273,14 @@ test font-7.2 {font command: delete: loop test} { lappend x [lsort [font names]] font delete a e c b lappend x [lsort [font names]] -} {{a b c d e} d} -test font-7.3 {font command: delete: loop test} { +} -cleanup { + catch {eval font delete [font names]} +} -result {{a b c d e} d} +test font-7.3 {font command: delete: loop test} -setup { + catch {eval font delete [font names]} + set x {} +} -body { # (namedHashPtr == NULL) in middle of loop - setup - set x {} font create a -underline 1 font create b -underline 1 font create c -underline 1 @@ -266,299 +289,440 @@ test font-7.3 {font command: delete: loop test} { lappend x [lsort [font names]] catch {font delete a d q c e b} lappend x [lsort [font names]] -} {{a b c d e} {b c e}} -test font-7.4 {font command: delete: non-existent} { +} -cleanup { + catch {eval font delete [font names]} +} -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) - setup - list [catch {font delete xyz} msg] $msg -} {1 {named font "xyz" doesn't exist}} -test font-7.5 {font command: delete: mark for later deletion} { + 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) - setup font create xyz - .b.f configure -font xyz + .t.f configure -font xyz font delete xyz font actual xyz - list [catch {font configure xyz} msg] $msg [.b.f cget -font] -} {1 {named font "xyz" doesn't exist} xyz} -test font-7.6 {font command: delete: actually delete} { + 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) - setup font create xyz -underline 1 font delete xyz - catch {font config xyz} -} {1} -setup + font config xyz +} -returnCodes error -match glob -result {*} -test font-8.1 {font command: families: arguments} { + +test font-8.1 {font command: families: arguments} -body { # (skip < 0) - list [catch {font families -displayof} msg] $msg -} {1 {value for "-displayof" missing}} -test font-8.2 {font command: families: arguments} { + 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 - list [catch {font families xyz} msg] $msg -} {1 {wrong # args: should be "font families ?-displayof window?"}} -test font-8.3 {font command: families: arguments} { + 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 - list [catch {font families -displayof . xyz} msg] $msg -} {1 {wrong # args: should be "font families ?-displayof window?"}} -test font-8.4 {font command: families} { + 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] -} {1} +} -result 1 + -test font-9.1 {font command: measure: arguments} { +test font-9.1 {font command: measure: arguments} -body { # (skip < 0) - list [catch {expr {[font measure xyz -displayof]>0}} msg] $msg -} {0 1} -test font-9.2 {font command: measure: arguments} { + expr {[font measure xyz -displayof] > 0} +} -returnCodes ok -result 1 +test font-9.2 {font command: measure: arguments} -body { # (objc - skip != 4) - list [catch {font measure} msg] $msg -} {1 {wrong # args: should be "font measure font ?-displayof window? text"}} -test font-9.3 {font command: measure: arguments} { + 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) - list [catch {font measure xyz abc def} msg] $msg -} {1 {wrong # args: should be "font measure font ?-displayof window? text"}} -test font-9.4 {font command: measure: arguments} {noExceed} { + 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) - list [catch {font measure "\{xyz" abc} msg] $msg -} [list 1 "font \"{xyz\" doesn't exist"] -test font-9.5 {font command: measure} { + 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 -} {1} -test font-9.6 {font command: measure -d} { - list [catch {expr {[font measure $fixed -d] > 0}} msg] $msg -} {0 1} -test font-9.7 {font command: measure -d with -displayof} { - list [catch {expr {[font measure $fixed -displayof . -d] > 0}} msg] $msg -} {0 1} -test font-9.8 {font command: measure: arguments} { - list [catch {font measure $fixed -displayof .} msg] $msg -} {1 {wrong # args: should be "font measure font ?-displayof window? text"}} - -test font-10.1 {font command: metrics: arguments} { - list [catch {font metrics xyz -displayof} msg] $msg -} {1 {value for "-displayof" missing}} -test font-10.2 {font command: metrics: arguments} { + 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) - list [catch {font metrics xyz -displayof} msg] $msg -} {1 {value for "-displayof" missing}} -test font-10.3 {font command: metrics: arguments} { + font metrics xyz -displayof +} -returnCodes error -result {value for "-displayof" missing} +test font-10.3 {font command: metrics: arguments} -body { # (objc < 3) - list [catch {font metrics} msg] $msg -} {1 {wrong # args: should be "font metrics font ?-displayof window? ?option?"}} -test font-10.4 {font command: metrics: arguments} { + 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 - list [catch {font metrics xyz abc def} msg] $msg -} {1 {wrong # args: should be "font metrics font ?-displayof window? ?option?"}} -test font-10.5 {font command: metrics: arguments} { + 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 - list [catch {font metrics xyz -displayof . abc} msg] $msg -} {1 {bad metric "abc": must be -ascent, -descent, -linespace, or -fixed}} -test font-10.6 {font command: metrics: bad font} {noExceed} { + 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) - list [catch {font metrics "\{xyz"} msg] $msg -} [list 1 "font \"{xyz\" doesn't exist"] -test font-10.7 {font command: metrics: get all metrics} { - # (objc == 3) + 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}] - set x [lsort [array names a]] + lsort [array names a] +} -cleanup { unset a - set x -} {-ascent -descent -fixed -linespace} -test font-10.8 {font command: metrics: bad metric} { +} -result {-ascent -descent -fixed -linespace} +test font-10.8 {font command: metrics: bad metric} -body { # (Tcl_GetIndexFromObj() != TCL_OK) - list [catch {font metrics $fixed -xyz} msg] $msg -} {1 {bad metric "-xyz": must be -ascent, -descent, -linespace, or -fixed}} -test font-10.9 {font command: metrics: get individual metrics} { + font metrics $fixed -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 -} {1} +} -result 1 + -test font-11.1 {font command: names: arguments} { +test font-11.1 {font command: names: arguments} -body { # (objc != 2) - list [catch {font names xyz} msg] $msg -} {1 {wrong # args: should be "font names"}} -test font-11.2 {font command: names: loop test: no passes} { - setup + font names xyz +} -returnCodes error -result {wrong # args: should be "font names"} +test font-11.2 {font command: names: loop test: no passes} -setup { + catch {eval font delete [font names]} +} -body { font names -} {} -test font-11.3 {font command: names: loop test: one pass} { - setup +} -result {} +test font-11.3 {font command: names: loop test: one pass} -setup { + catch {eval font delete [font names]} +} -body { font create font names -} {font1} -test font-11.4 {font command: names: loop test: multiple passes} { - setup +} -result {font1} +test font-11.4 {font command: names: loop test: multiple passes} -setup { + catch {eval font delete [font names]} +} -body { font create xyz font create abc font create def lsort [font names] -} {abc def xyz} -test font-11.5 {font command: names: skip deletePending fonts} { - # (nfPtr->deletePending == 0) - setup +} -cleanup { + catch {eval font delete [font names]} +} -result {abc def xyz} +test font-11.5 {font command: names: skip deletePending fonts} -setup { + destroy .t.f + catch {eval font delete [font names]} + pack [label .t.f] + update set x {} +} -body { + # (nfPtr->deletePending == 0) font create xyz font create abc lappend x [lsort [font names]] - .b.f config -font xyz + .t.f config -font xyz font delete xyz lappend x [font names] -} {{abc xyz} abc} +} -cleanup { + catch {eval font delete [font names]} +} -result {{abc xyz} abc} -test font-12.1 {UpdateDependantFonts procedure: no users} { + +test font-12.1 {UpdateDependantFonts procedure: no users} -setup { + catch {font delete xyz} +} -body { # (nfPtr->refCount == 0) - setup font create xyz font configure xyz -family times -} {} -test font-12.2 {UpdateDependantFonts procedure: pings the widgets} { - setup +} -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 - .b.f config -font xyz -text "abcd" -padx 0 -bd 0 -highlightthickness 0 + .t.f config -font xyz -text "abcd" -padx 0 -bd 0 -highlightthickness 0 set a1 [font measure xyz "abcd"] update - set b1 [winfo reqwidth .b.f] + set b1 [winfo reqwidth .t.f] font configure xyz -family helvetica -size 20 set a2 [font measure xyz "abcd"] update - set b2 [winfo reqwidth .b.f] + set b2 [winfo reqwidth .t.f] expr {$a1==$b1 && $a2==$b2} -} {1} +} -cleanup { + destroy .t.f + font delete xyz +} -result {1} + -test font-13.1 {CreateNamedFont: new named font} { +test font-13.1 {CreateNamedFont: new named font} -setup { + catch {font delete xyz} + set x {} +} -body { # not (new == 0) - setup - set x {} lappend x [font names] font create xyz lappend x [font names] -} {{} xyz} -test font-13.2 {CreateNamedFont: named font already exists} { +} -cleanup { + font delete xyz +} -result {{} xyz} +test font-13.2 {CreateNamedFont: named font already exists} -setup { + catch {font delete xyz} +} -body { # (new == 0) - setup font create xyz - list [catch {font create xyz} msg] $msg -} {1 {named font "xyz" already exists}} -test font-13.3 {CreateNamedFont: named font already exists} { + 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) - setup font create xyz - list [catch {font create xyz} msg] $msg -} {1 {named font "xyz" already exists}} -test font-13.4 {CreateNamedFont: recreate "deleted" font} { + 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) - setup font create xyz -family times - .b.f configure -font xyz + .t.f configure -font xyz font delete xyz font create xyz -family courier font configure xyz -family -} {courier} +} -cleanup { + font delete xyz + destroy .t.f +} -result {courier} + + +test font-14.1 {Tk_GetFont procedure} -body { +} -result {} -test font-14.1 {Tk_GetFont procedure} { -} {} -test font-15.1 {Tk_AllocFontFromObj - converting internal reps} testfont { +test font-15.1 {Tk_AllocFontFromObj - converting internal reps} -constraints { + testfont +} -setup { + destroy .b1 .b2 +} -body { set x {Times 16} lindex $x 0 - destroy .b1 .b2 button .b1 -font $x lindex $x 0 testfont counts {Times 16} -} {{1 0}} -test font-15.2 {Tk_AllocFontFromObj - discard stale font} testfont { - set x {Times 16} +} -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 - set result {} lappend result [testfont counts {Times 16}] button .b2 -font $x lappend result [testfont counts {Times 16}] -} {{} {{1 1}}} -test font-15.3 {Tk_AllocFontFromObj - reuse existing font} testfont { - set x {Times 16} +} -cleanup { + destroy .b2 +} -result {{} {{1 1}}} +test font-15.3 {Tk_AllocFontFromObj - reuse existing font} -constraints { + testfont +} -setup { destroy .b1 .b2 - button .b1 -font $x 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}] -} {{{1 1}} {{2 1}}} -test font-15.4 {Tk_AllocFontFromObj procedure: bump ref count} { +} -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) - setup - .b.f config -font {-family fixed} + .t.f config -font {-family fixed} lindex [font actual {-family fixed}] 0 -} {-family} -test font-15.5 {Tk_AllocFontFromObj procedure: get named font} { +} -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) - setup font create xyz - .b.f config -font xyz -} {} -test font-15.6 {Tk_AllocFontFromObj procedure: not a named font} { + .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) - setup - .b.f config -font {times 20} -} {} -test font-15.7 {Tk_AllocFontFromObj procedure: get native font} unix { + .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) - setup - .b.f config -font fixed -} {} -test font-15.8 {Tk_AllocFontFromObj procedure: get native font} win { + .t.f config -font fixed +} -result {} +test font-15.8 {Tk_AllocFontFromObj procedure: get native font} -constraints { + win +} -setup { + destroy .t.f + catch {eval font delete [font names]} + pack [label .t.f] + update +} -body { # not (fontPtr == NULL) - setup - .b.f config -font oemfixed -} {} -test font-15.10 {Tk_AllocFontFromObj procedure: get attribute font} { + .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) - list [catch {.b.f config -font {xxx yyy zzz}} msg] $msg -} {1 {expected integer but got "yyy"}} -test font-15.11 {Tk_AllocFontFromObj procedure: no match} {noExceed} { + .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) - list [catch {font actual "\{xyz"} msg] $msg -} [list 1 "font \"{xyz\" doesn't exist"] -test font-15.12 {Tk_AllocFontFromObj procedure: get attribute font} { + 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 -} {-family} -test font-15.13 {Tk_AllocFontFromObj procedure: setup tab width} { +} -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 x [winfo reqwidth .l] - destroy .l - set x -} [expr [font measure $fixed "0"]*9] -test font-15.14 {Tk_AllocFontFromObj procedure: underline position} { + 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 - setup - .b.f config -text "underline" -font "times -8 underline" + .t.f config -text "underline" -font "times -8 underline" update -} {} +} -cleanup { + destroy .t.f +} -result {} -test font-16.1 {Tk_NameOfFont procedure} { - setup - .b.f config -font -family\ fixed - .b.f cget -font -} {-family fixed} -test font-17.1 {Tk_FreeFontFromObj - reference counts} testfont { - set x {Courier 12} +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 - set result {} lappend result [testfont counts {Courier 12}] destroy .b1 lappend result [testfont counts {Courier 12}] @@ -566,61 +730,83 @@ test font-17.1 {Tk_FreeFontFromObj - reference counts} testfont { lappend result [testfont counts {Courier 12}] destroy .b3 lappend result [testfont counts {Courier 12}] -} {{{3 1}} {{2 1}} {{1 1}} {}} -test font-17.2 {Tk_FreeFont procedure: one ref} { +} -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) - setup - .b.f config -font {-family fixed} - destroy .b.f -} {} -test font-17.3 {Tk_FreeFont procedure: multiple ref} { + .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) - setup - .b.f config -font {-family fixed} - button .b.b -font {-family fixed} - destroy .b.f - set x [.b.b cget -font] - destroy .b.b - set x -} {-family fixed} -test font-17.4 {Tk_FreeFont procedure: named font} { + .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 + catch {eval font delete [font names]} + pack [label .t.f] + update +} -body { # (fontPtr->namedHashPtr != NULL) - setup font create xyz - .b.f config -font xyz - destroy .b.f + .t.f config -font xyz + destroy .t.f font names -} {xyz} -test font-17.5 {Tk_FreeFont procedure: named font} { +} -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) - setup font create xyz -underline 1 - .b.f config -font xyz + .t.f config -font xyz font delete xyz set x [font actual xyz -underline] - destroy .b.f + destroy .t.f list [font actual xyz -underline] $x -} {0 1} -test font-17.6 {Tk_FreeFont procedure: named font not deleted yet} { - setup +} -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 - .b.f config -font xyz - button .b.b -font xyz + .t.f config -font xyz + button .t.b -font xyz font delete xyz set x [font actual xyz] - destroy .b.b + destroy .t.b list [lindex [font actual xyz] 0] [lindex $x 0] -} {-family -family} +} -cleanup { + destroy .t.f +} -result {-family -family} -test font-18.1 {FreeFontObjProc} testfont { + +test font-18.1 {FreeFontObjProc} -constraints testfont -setup { destroy .b1 + set result {} +} -body { set x [format {Courier 12}] button .b1 -font $x set y [format {Courier 12}] .b1 configure -font $y set z [format {Courier 12}] .b1 configure -font $z - set result {} lappend result [testfont counts {Courier 12}] set x red lappend result [testfont counts {Courier 12}] @@ -629,275 +815,864 @@ test font-18.1 {FreeFontObjProc} testfont { destroy .b1 lappend result [testfont counts {Courier 12}] set y bogus - set result -} {{{1 3}} {{1 2}} {{1 1}} {}} + return $result +} -result {{{1 3}} {{1 2}} {{1 1}} {}} + -test font-19.1 {Tk_FontId} { - .b.f config -font "times 20" +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} { - button .b.w1 -text abc - entry .b.w2 -text abcd +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 .b.w1 .b.w2 -} {} + destroy .t.w1 .t.w2 +} -result {} + +# Procedure used in 21.* tests proc psfontname {name} { - set a [.b.c itemcget text -font] - .b.c itemconfig text -text "We need text" -font $name - set post [.b.c postscript] - .b.c itemconfig text -font $a + 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} unix { +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" + psfontname "{itc avant garde} 10" } else { - set x {AvantGarde-Book} + set x {AvantGarde-Book} } -} {AvantGarde-Book} -test font-21.2 {Tk_PostscriptFontName procedure: native} win { +} -result {AvantGarde-Book} +test font-21.2 {Tk_PostscriptFontName procedure: native} -constraints { + win +} -body { psfontname "arial 10" -} {Helvetica} -test font-21.3 {Tk_PostscriptFontName procedure: native} win { +} -result {Helvetica} +test font-21.3 {Tk_PostscriptFontName procedure: native} -constraints { + win +} -body { psfontname "{times new roman} 10" -} {Times-Roman} -test font-21.4 {Tk_PostscriptFontName procedure: native} win { +} -result {Times-Roman} +test font-21.4 {Tk_PostscriptFontName procedure: native} -constraints { + win +} -body { psfontname "{courier new} 10" -} {Courier} -test font-21.8 {Tk_PostscriptFontName procedure: spaces} unix { +} -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" + psfontname "{lucida bright} 10" } else { - set x {LucidaBright} + set x {LucidaBright} } -} {LucidaBright} -test font-21.9 {Tk_PostscriptFontName procedure: spaces} unix { +} -result {LucidaBright} +test font-21.6 {Tk_PostscriptFontName procedure: spaces} -constraints { + unix +} -body { psfontname "{new century schoolbook} 10" -} {NewCenturySchlbk-Roman} -set i 10 -foreach p { - {font-21.10 "avantgarde" - AvantGarde-Book AvantGarde-Demi - AvantGarde-BookOblique AvantGarde-DemiOblique} - {font-21.11 "bookman" - Bookman-Light Bookman-Demi Bookman-LightItalic Bookman-DemiItalic} - {font-21.12 "courier" - Courier Courier-Bold Courier-Oblique Courier-BoldOblique} - {font-21.13 "helvetica" - Helvetica Helvetica-Bold Helvetica-Oblique Helvetica-BoldOblique} - {font-21.14 "new century schoolbook" - NewCenturySchlbk-Roman NewCenturySchlbk-Bold - NewCenturySchlbk-Italic NewCenturySchlbk-BoldItalic} - {font-21.15 "palatino" - Palatino-Roman Palatino-Bold Palatino-Italic Palatino-BoldItalic} - {font-21.16 "symbol" - Symbol Symbol Symbol Symbol} - {font-21.17 "times" - Times-Roman Times-Bold Times-Italic Times-BoldItalic} - {font-21.18 "zapfchancery" - ZapfChancery-MediumItalic ZapfChancery-MediumItalic - ZapfChancery-MediumItalic ZapfChancery-MediumItalic} - {font-21.19 "zapfdingbats" - ZapfDingbats ZapfDingbats ZapfDingbats ZapfDingbats} -} { - set values [lassign $p testName family] - test $testName {Tk_PostscriptFontName procedure: exhaustive} unix { - set x {} - set j 0 - foreach slant {roman italic} { - foreach weight {normal bold} { - set name [list $family 12 $slant $weight] - if {[font actual $name -family] == $family} { - lappend x [psfontname $name] - } else { - lappend x [lindex $values $j] - } - incr j - } - } - set x - } $values -} -foreach p { - {font-21.20 "arial" - Helvetica Helvetica-Bold Helvetica-Oblique Helvetica-BoldOblique} - {font-21.21 "courier new" - Courier Courier-Bold Courier-Oblique Courier-BoldOblique} - {font-21.22 "helvetica" - Helvetica Helvetica-Bold Helvetica-Oblique Helvetica-BoldOblique} - {font-21.23 "symbol" - Symbol Symbol-Bold Symbol-Italic Symbol-BoldItalic} - {font-21.24 "times new roman" - Times-Roman Times-Bold Times-Italic Times-BoldItalic} -} { - set values [lassign $p testName family] - test $testName {Tk_PostscriptFontName procedure: exhaustive} win { - set x {} - foreach slant {roman italic} { - foreach weight {normal bold} { - lappend x [psfontname [list $family 12 "$slant $weight"]] - } - } - set x - } $values -} +} -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 {} -test font-22.1 {Tk_TextWidth procedure} { - font measure [.b.l cget -font] "000" -} [expr $ax*3] -test font-23.1 {Tk_UnderlineChars procedure} { - text .b.t - .b.t insert 1.0 abc\tdefg - .b.t tag config sel -underline 1 - .b.t tag add sel 1.0 end - update -} {} - -setup -test font-24.1 {Tk_ComputeTextLayout: empty string} { - .b.l config -text "" -} {} -test font-24.2 {Tk_ComputeTextLayout: simple string} { - .b.l config -text "000" - getsize -} "[expr $ax*3] $ay" -test font-24.3 {Tk_ComputeTextLayout: find special chars} { - .b.l config -text "000\n000" - getsize -} "[expr $ax*3] [expr $ay*2]" -test font-24.4 {Tk_ComputeTextLayout: calls Tk_MeasureChars} { - .b.l config -text "000\n000" - getsize -} "[expr $ax*3] [expr $ay*2]" -test font-24.5 {Tk_ComputeTextLayout: break line} { - .b.l config -text "000\t00000" -wrap [expr 9*$ax] - set x [getsize] - .b.l config -wrap 0 - set x -} "[expr 8*$ax] [expr 2*$ay]" -test font-24.6 {Tk_ComputeTextLayout: normal ended on special char} { - .b.l config -text "000\n000" -} {} -test font-24.7 {Tk_ComputeTextLayout: special char was \n} { - .b.l config -text "000\n0000" - getsize -} "[expr $ax*4] [expr $ay*2]" -test font-24.8 {Tk_ComputeTextLayout: special char was \t} { - .b.l config -text "000\t00" - getsize -} "[expr $ax*10] $ay" -test font-24.9 {Tk_ComputeTextLayout: tab didn't cause break} { +# 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 {} - .b.l config -text "000\t000" - lappend x [getsize] - .b.l config -text "000\t000" -wrap [expr 100*$ax] - lappend x [getsize] - .b.l config -wrap 0 - set x -} "{[expr $ax*11] $ay} {[expr $ax*11] $ay}" -test font-24.10 {Tk_ComputeTextLayout: tab caused break} { + .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 {} - .b.l config -text "000\t" - lappend x [getsize] - .b.l config -text "000\t00" -wrap [expr $ax*6] - lappend x [getsize] - .b.l config -wrap 0 - set x -} "{[expr $ax*3] $ay} {[expr $ax*3] [expr $ay*2]}" -test font-24.11 {Tk_ComputeTextLayout: absorb spaces at eol} { + .t.l config -text "000\t" + update + lappend x [expr {[winfo reqwidth .t.l] eq [expr {$ax * 3}]}] + 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 * 3}]}] + 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 {} - .b.l config -text "000 000" -wrap [expr $ax*5] - lappend x [getsize] - .b.l config -text "000 " - lappend x [getsize] - .b.l config -wrap 0 - set x -} "{[expr $ax*3] [expr $ay*2]} {[expr $ax*3] $ay}" -test font-24.12 {Tk_ComputeTextLayout: append non-printing spaces to chunk} { + .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 {} - .b.l config -text "000 0000" -wrap [expr $ax*5] - lappend x [getsize] - .b.l config -text "000\t00 0000" -wrap [expr $ax*12] - lappend x [getsize] - .b.l config -wrap 0 - set x -} "{[expr $ax*4] [expr $ay*2]} {[expr $ax*10] [expr $ay*2]}" -test font-24.13 {Tk_ComputeTextLayout: many lines -> realloc line array} { - .b.l config -text "\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n" - getsize -} "1 [expr $ay*129]" -test font-24.14 {Tk_ComputeTextLayout: text ended with \n} { - list [.b.l config -text "0000"; getsize] [.b.l config -text "0000\n"; getsize] -} "{[expr $ax*4] $ay} {[expr $ax*4] [expr $ay*2]}" -test font-24.15 {Tk_ComputeTextLayout: justification} { - csetup "000\n00000" + .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 {} - .b.c itemconfig text -just left - lappend x [.b.c index text @[expr $ax*2],0] - .b.c itemconfig text -just center - lappend x [.b.c index text @[expr $ax*2],0] - .b.c itemconfig text -just right - lappend x [.b.c index text @[expr $ax*2],0] - .b.c itemconfig text -just left - set x -} {2 1 0} - -test font-25.1 {Tk_FreeTextLayout procedure} { - setup - .b.f config -text foo - .b.f config -text boo -} {} + 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 {} -test font-26.1 {Tk_DrawTextLayout procedure: auto-detect last char} { - .b.f config -text foo -} {} -test font-26.2 {Tk_DrawTextLayout procedure: multiple chunks} { + +# 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" -} {} -test font-26.3 {Tk_DrawTextLayout: draw subset of chunk: numDisplay <= 0} { +} -result {} +test font-26.3 {Tk_DrawTextLayout: draw subset of chunk: numDisplay <= 0} -body { csetup "000\t00" - .b.c select from text 3 - .b.c select to text 5 -} {} -test font-26.4 {Tk_DrawTextLayout: draw subset of chunk: firstChar <= 0} { - .b.c select from text 3 - .b.c select to text 5 -} {} -test font-26.5 {Tk_DrawTextLayout: draw subset of chunk: firstChar > 0} { - .b.c select from text 2 - .b.c select to text 2 -} {} -test font-26.6 {Tk_DrawTextLayout: draw subset of chunk: lastChar < numChars} { - .b.c select from text 4 - .b.c select to text 4 -} {} - -test font-27.1 {Tk_UnderlineTextLayout procedure: no underline chosen} { - .b.f config -text "foo" -under -1 -} {} -test font-27.2 {Tk_UnderlineTextLayout procedure: underline not visible} { - .b.f config -text "000 00000" -wrap [expr $ax*7] -under 10 -} {} -test font-27.3 {Tk_UnderlineTextLayout procedure: underline is visible} { - .b.f config -text "000 00000" -wrap [expr $ax*7] -under 5 - .b.f config -wrap -1 -under -1 -} {} - -test font-28.1 {Tk_PointToChar procedure: above all lines} { + .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" - .b.c index text @-1,0 -} {0} -test font-28.2 {Tk_PointToChar procedure: no chars} { + .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 @@ -907,206 +1682,277 @@ test font-28.2 {Tk_PointToChar procedure: no chars} { # index of 1 if TextLayout contained 0 characters. csetup "" - .b.c index text @100,100 -} {0} -test font-28.3 {Tk_PointToChar procedure: loop test} { + .t.c index text @100,100 +} -result {0} +test font-28.3 {Tk_PointToChar procedure: loop test} -body { csetup "000\n000\n000\n000" - .b.c index text @10000,0 -} {3} -test font-28.4 {Tk_PointToChar procedure: intersect line} { + .t.c index text @10000,0 +} -result {3} +test font-28.4 {Tk_PointToChar procedure: intersect line} -body { csetup "000\n000\n000" - .b.c index text @0,$ay -} {4} -test font-28.5 {Tk_PointToChar procedure: to the left of all chunks} { - .b.c index text @-100,$ay -} {4} -test font-28.6 {Tk_PointToChar procedure: past any possible chunk} { - .b.c index text @100000,$ay -} {7} -test font-28.7 {Tk_PointToChar procedure: which chunk on this line} { + .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" - .b.c index text @[expr $ax*2],$ay -} {6} -test font-28.8 {Tk_PointToChar procedure: which chunk on this line} { + .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" - .b.c index text @[expr $ax*10],$ay -} {10} -test font-28.9 {Tk_PointToChar procedure: in special chunk} { + .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" - .b.c index text @[expr $ax*6],$ay -} {7} -test font-28.10 {Tk_PointToChar procedure: past all chars in chunk} { + .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" - .b.c itemconfig text -width [expr $ax*5] - set x [.b.c index text @[expr $ax*5],0] - .b.c itemconfig text -width 0 - set x -} {3} -test font-28.11 {Tk_PointToChar procedure: below all chunks} { + .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" - .b.c index text @0,1000000 -} {11} - -test font-29.1 {Tk_CharBBox procedure: index < 0} { - .b.f config -text "000" -underline -1 -} {} -test font-29.2 {Tk_CharBBox procedure: loop} { - .b.f config -text "000\t000\t000\t000" -underline 9 -} {} -test font-29.3 {Tk_CharBBox procedure: special char} { - .b.f config -text "000\t000\t000" -underline 7 -} {} -test font-29.4 {Tk_CharBBox procedure: normal char} { - .b.f config -text "000" -underline 1 -} {} -test font-29.5 {Tk_CharBBox procedure: right edge of bbox truncated} { - .b.f config -text "0 0000" -wrap [expr $ax*4] -under 2 - .b.f config -wrap 0 -} {} -test font-29.6 {Tk_CharBBox procedure: bbox pegged to right edge} { - .b.f config -text "0 0000" -wrap [expr $ax*4] -under 3 - .b.f config -wrap 0 -} {} - -.b.c bind all <Enter> {lappend x [.b.c index current @%x,%y]} - -test font-30.1 {Tk_DistanceToTextLayout procedure: loop once} { + .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 .b.c <Leave> - event generate .b.c <Enter> -x 0 -y 0 - set x -} {0} -test font-30.2 {Tk_DistanceToTextLayout procedure: loop multiple} { + 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 .b.c <Leave> - event generate .b.c <Enter> -x $ax -y $ay - set x -} {5} -test font-30.3 {Tk_DistanceToTextLayout procedure: loop to end} { + 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 .b.c <Leave> - event generate .b.c <Enter> -x [expr $ax*2] -y $ay - set x -} {} -test font-30.4 {Tk_DistanceToTextLayout procedure: hit a special char (tab)} { + 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 .b.c <Leave> - event generate .b.c <Enter> -x [expr $ax*6] -y 0 - set x -} {3} -test font-30.5 {Tk_DistanceToTextLayout procedure: ignore newline} { + 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 .b.c <Leave> - event generate .b.c <Enter> -x [expr $ax*2] -y $ay - set x -} {} -test font-30.6 {Tk_DistanceToTextLayout procedure: ignore spaces at eol} { + 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" - .b.c itemconfig text -width [expr $ax*10] + .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 .b.c <Leave> - event generate .b.c <Enter> -x [expr $ax*5] -y $ay - .b.c itemconfig text -width 0 - set x -} {} -.b.c itemconfig text -justify center -test font-30.7 {Tk_DistanceToTextLayout procedure: on left side} { + 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 .b.c <Leave> - event generate .b.c <Enter> -x 0 -y 0 - set x -} {} -test font-30.8 {Tk_DistanceToTextLayout procedure: on right side} { + 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 .b.c <Leave> - event generate .b.c <Enter> -x [expr $ax*2] -y 0 - set x -} {} -test font-30.9 {Tk_DistanceToTextLayout procedure: inside line} { + 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 .b.c <Leave> - event generate .b.c <Enter> -x $ax -y 0 - set x -} {0} -test font-30.10 {Tk_DistanceToTextLayout procedure: above line} { + 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 .b.c <Leave> - event generate .b.c <Enter> -x 0 -y 0 - set x -} {} -test font-30.11 {Tk_DistanceToTextLayout procedure: below line} { + 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 .b.c <Leave> - event generate .b.c <Enter> -x 0 -y $ay - set x -} {} -test font-30.12 {Tk_DistanceToTextLayout procedure: in line} { + 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 .b.c <Leave> - event generate .b.c <Enter> -x $ax -y $ay - set x -} {3} -.b.c itemconfig text -justify left -test font-30.13 {Tk_DistanceToTextLayout procedure: exact hit} { + 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 .b.c <Leave> - event generate .b.c <Enter> -x $ax -y 0 - set x -} {1} - -test font-31.1 {Tk_IntersectTextLayout procedure: loop once} { + 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" - .b.c find overlapping 0 0 0 0 -} [.b.c find withtag text] -test font-31.2 {Tk_IntersectTextLayout procedure: loop multiple} { + .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" - .b.c find overlapping [expr $ax*10] 0 [expr $ax*10] 0 -} [.b.c find withtag text] -test font-31.3 {Tk_IntersectTextLayout procedure: loop to end} { + .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" - .b.c find overlapping [expr $ax*2] 0 [expr $ax*2] 0 -} {} -test font-31.4 {Tk_IntersectTextLayout procedure: hit a special char (tab)} { + .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" - .b.c find overlapping [expr $ax*6] 0 [expr $ax*6] 0 -} [.b.c find withtag text] -test font-31.5 {Tk_IntersectTextLayout procedure: ignore newlines} { + .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" - .b.c find overlapping $ax $ay $ax $ay -} {} -test font-31.6 {Tk_IntersectTextLayout procedure: ignore spaces at eol} { + .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" - .b.c itemconfig text -width [expr $ax*10] - set x [.b.c find overlapping [expr $ax*5] $ay [expr $ax*5] $ay] - .b.c itemconfig text -width 0 - set x -} {} - -test font-32.1 {Tk_TextLayoutToPostscript: ensure buffer doesn't overflow} { + .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" - .b.c itemconfig text -width 800 - .b.c insert text end "qwertyuiopasdfghjklzxcvbnm1234qwertyuiopasdfghjklzxcvbnm\n" - .b.c insert text end "\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n" - .b.c insert text end "end" - set x [.b.c postscript] + .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}] -} {(qwertyuiopasdfghjklzxcvbnm1234qwertyuiopasdfghjklzxcvbnm)] +} -cleanup { + destroy .t.c +} -result {(qwertyuiopasdfghjklzxcvbnm1234qwertyuiopasdfghjklzxcvbnm)] [(qwertyuiopasdfghjklzxcvbnm1234qwertyuiopasdfghjklzxcvbnm)] [()] [()] @@ -1141,242 +1987,366 @@ test font-32.1 {Tk_TextLayoutToPostscript: ensure buffer doesn't overflow} { [(end)] } -test font-33.1 {Tk_TextWidth procedure} { -} {} -test font-34.1 {ConfigAttributesObj procedure: arguments} { +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) - setup - list [catch {font create xyz -xyz} msg] $msg -} {1 {bad option "-xyz": must be -family, -size, -weight, -slant, -underline, or -overstrike}} -test font-34.2 {ConfigAttributesObj procedure: arguments} { + 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) - setup - list [catch {font create xyz -family} msg] $msg -} {1 {value for "-family" option missing}} -foreach p { - {font-34.3 family xyz times} - {font-34.4 size 20 40} - {font-34.5 weight normal bold} - {font-34.6 slant roman italic} - {font-34.7 underline 0 1} - {font-34.8 overstrike 0 1} -} { - lassign $p testName opt val1 val2 - test $testName "ConfigAttributesObj procedure: $opt" { - setup - set x {} - font create xyz -$opt $val1 - lappend x [font config xyz -$opt] - font config xyz -$opt $val2 - lappend x [font config xyz -$opt] - } [list $val1 $val2] -} -foreach p { - {font-34.9 size xyz {expected integer but got "xyz"}} - {font-34.10 weight xyz {bad -weight value "xyz": must be normal, or bold}} - {font-34.11 slant xyz {bad -slant value "xyz": must be roman, or italic}} - {font-34.12 underline xyz {expected boolean value but got "xyz"}} - {font-34.13 overstrike xyz {expected boolean value but got "xyz"}} -} { - lassign $p testName opt val result - test $testName "ConfigAttributesObj procedure: $opt" -setup { - setup - } -body { - font create xyz -$opt $val - } -returnCodes error -result $result -} + font create xyz -family +} -returnCodes error -result {value for "-family" option missing} -test font-35.1 {GetAttributeInfoObj procedure: one attribute} { +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) - setup font create xyz -family xyz font config xyz -family -} {xyz} +} -cleanup { + font delete xyz +} -result {xyz} + -test font-36.1 {GetAttributeInfoObj procedure: unknown attribute} { +test font-36.1 {GetAttributeInfoObj procedure: unknown attribute} -setup { + catch {font delete xyz} +} -body { # (Tcl_GetIndexFromObj() != TCL_OK) - setup font create xyz - list [catch {font config xyz -xyz} msg] $msg -} {1 {bad option "-xyz": must be -family, -size, -weight, -slant, -underline, or -overstrike}} - -test font-37.1 {GetAttributeInfoObj procedure: all attributes} { - # not (objPtr != NULL) - setup + font 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 -} {-family xyz -size 0 -weight normal -slant roman -underline 0 -overstrike 0} -set i 4 -foreach p { - {font-37.2 family xyz xyz} - {font-37.3 size 20 20} - {font-37.4 weight normal normal} - {font-37.5 slant italic italic} - {font-37.6 underline yes 1} - {font-37.7 overstrike false 0} -} { - lassign $p testName opt val expected - test $testName "GetAttributeInfo procedure: $opt" -setup { - setup - } -body { - font create xyz -$opt $val - font config xyz -$opt - } -result $expected -} +} -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. -setup - -test font-38.1 {ParseFontNameObj procedure: begins with -} { +test font-38.1 {ParseFontNameObj procedure: begins with -} -body { lindex [font actual -xyz-times-*-*-*-*-*-*-*-*-*-*-*-*] 1 -} $times -test font-38.2 {ParseFontNameObj procedure: begins with -*} { +} -result [font actual {times 0} -family] +test font-38.2 {ParseFontNameObj procedure: begins with -*} -body { lindex [font actual -*-times-xyz-*-*-*-*-*-*-*-*-*-*-*] 1 -} $times -test font-38.3 {ParseFontNameObj procedure: begins with -, doesn't look like list} { +} -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 -} $times -test font-38.4 {ParseFontNameObj procedure: begins with -, looks like list} { +} -result [font actual {times 0} -family] +test font-38.4 {ParseFontNameObj procedure: begins with -, looks like list} -body { lindex [font actual {-family times}] 1 -} $times -test font-38.5 {ParseFontNameObj procedure: begins with *} { +} -result [font actual {times 0} -family] +test font-38.5 {ParseFontNameObj procedure: begins with *} -body { lindex [font actual *-times-xyz-*-*-*-*-*-*-*-*-*-*-*] 1 -} $times -test font-38.6 {ParseFontNameObj procedure: begins with *} { +} -result [font actual {times 0} -family] +test font-38.6 {ParseFontNameObj procedure: begins with *} -body { font actual *-times-xyz -family -} $times -test font-38.7 {ParseFontNameObj procedure: arguments} {noExceed} { - list [catch {font actual "\{xyz"} msg] $msg -} [list 1 "font \"{xyz\" doesn't exist"] -test font-38.8 {ParseFontNameObj procedure: arguments} {noExceed} { - list [catch {font actual ""} msg] $msg -} {1 {font "" doesn't exist}} -test font-38.9 {ParseFontNameObj procedure: arguments} { - list [catch {font actual {times 20 xyz xyz}} msg] $msg -} {1 {unknown font style "xyz"}} -test font-38.10 {ParseFontNameObj procedure: arguments} { - list [catch {font actual {times xyz xyz}} msg] $msg -} {1 {expected integer but got "xyz"}} -test font-38.12 {ParseFontNameObj procedure: stylelist loop} {unixOrPc} { +} -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 -} {-weight bold -slant italic -underline 1 -overstrike 1} -test font-38.13 {ParseFontNameObj procedure: stylelist error} { - list [catch {font actual {times 12 bold xyz}} msg] $msg -} {1 {unknown font style "xyz"}} +} -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-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-39.1 {NewChunk procedure: test realloc} { - .b.f config -text "xxx\nxxx\txxx\nxxx\t\t\t" -} {} -test font-40.1 {TkFontParseXLFD procedure: initial dash} { +test font-40.1 {TkFontParseXLFD procedure: initial dash} -body { font actual -xyz-times-*-*-*-*-*-*-*-*-*-*-*-* -family -} $times -test font-40.2 {TkFontParseXLFD procedure: no initial dash} { +} -result [font actual {times 0} -family] +test font-40.2 {TkFontParseXLFD procedure: no initial dash} -body { font actual *-times-*-*-*-*-*-*-*-*-*-*-*-xyz -family -} $times -test font-40.3 {TkFontParseXLFD procedure: not enough fields} { +} -result [font actual {times 0} -family] +test font-40.3 {TkFontParseXLFD procedure: not enough fields} -body { font actual -xyz-times-*-*-* -family -} $times -test font-40.4 {TkFontParseXLFD procedure: all fields unspecified} { +} -result [font actual {times 0} -family] +test font-40.4 {TkFontParseXLFD procedure: all fields unspecified} -body { lindex [font actual -xyz-*-*-*-*-*-*-*-*-*-*-*-*-*] 0 -} {-family} -test font-40.5 {TkFontParseXLFD procedure: all fields specified} { - lindex [font actual -foundry-times-weight-slant-setwidth-addstyle-10-10-10-10-spacing-avgwidth-registry-encoding] 1 -} $times -test font-41.1 {TkParseXLFD procedure: arguments} { +} -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 {} -} {} -test font-42.1 {TkFontParseXLFD procedure: arguments} { +} -result {} + + +test font-42.1 {TkFontParseXLFD procedure: arguments} -body { # XLFD with bad pixelsize: fallback to some system font. font actual -*-*-*-*-*-*-*-xyz-*-*-*-*-*-* set x {} -} {} -test font-42.2 {TkFontParseXLFD procedure: pixelsize specified} { +} -result {} +test font-42.2 {TkFontParseXLFD procedure: pixelsize specified} -body { font metrics -xyz-times-*-*-*-*-12-*-*-*-*-*-*-* -linespace set x {} -} {} -test font-42.3 {TkFontParseXLFD procedure: weird pixelsize specified} { +} -result {} +test font-42.3 {TkFontParseXLFD procedure: weird pixelsize specified} -body { font metrics {-xyz-times-*-*-*-*-[ 12.0 0 12.0 0]-*-*-*-*-*-*-*} -linespace set x {} -} {} -test font-42.4 {TkFontParseXLFD procedure: pointsize specified} { +} -result {} +test font-42.4 {TkFontParseXLFD procedure: pointsize specified} -body { font metrics -xyz-times-*-*-*-*-*-120-*-*-*-*-*-* -linespace set x {} -} {} -test font-42.5 {TkFontParseXLFD procedure: weird pointsize specified} { +} -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} { + +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 -} $times +} -result [font actual {times 0} -family] + -set oldscale [tk scaling] -tk scaling 0.5 -test font-44.1 {TkFontGetPixels: size < 0} { +test font-44.1 {TkFontGetPixels: size < 0} -setup { + set oldscale [tk scaling] +} -body { + tk scaling 0.5 font actual {times -12} -size -} {24} -test font-44.2 {TkFontGetPoints: size >= 0} {noExceed} { +} -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 -} {12} +} -cleanup { + tk scaling $oldscale +} -result {12} -tk scaling $oldscale -test font-45.1 {TkFontGetAliasList: no match} { +test font-45.1 {TkFontGetAliasList: no match} -body { font actual {snarky 10} -family -} [font actual {-size 10} -family] -test font-45.3 {TkFontGetAliasList: match} win { +} -result [font actual {-size 10} -family] +test font-45.2 {TkFontGetAliasList: match} -constraints win -body { font actual {times 10} -family -} {Times New Roman} -test font-45.4 {TkFontGetAliasList: match} {unix noExceed} { +} -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 -} [font actual {times 10} -family] +} -result [font actual {times 10} -family] -test font-46.1 {font actual, with character, no option, no --} \ - -body { + +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 *\ +} -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 { +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 *\ +} -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} { +test font-46.3 {font actual, with character and option} -body { font actual {times 10} -family a -} [font actual {times 10} -family] +} -result [font actual {times 10} -family] -test font-46.4 {font actual, with character, option and --} { +test font-46.4 {font actual, with character, option and --} -body { font actual {times 10} -family -- - -} [font actual {times 10} -family] - -test font-46.5 {font actual, too many chars} { - list [catch { - font actual {times 10} 123456789012345678901234567890123456789012345678901 - } result] $result -} {1 {expected a single character but got "1234567890123456789012345678901234567..."}} +} -result [font actual {times 10} -family] -setup +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..."} -destroy .b # cleanup cleanupTests return + + + + diff --git a/tests/frame.test b/tests/frame.test index 6eaa356..577cac7 100644 --- a/tests/frame.test +++ b/tests/frame.test @@ -7,9 +7,10 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: frame.test,v 1.17 2008/07/23 23:24:25 nijtmans Exp $ +# RCS: @(#) $Id: frame.test,v 1.18 2008/08/15 01:10:03 aniap Exp $ -package require tcltest 2.1 +package require tcltest 2.2 +namespace import ::tcltest::* eval tcltest::configure $argv tcltest::loadTestedCommands @@ -53,40 +54,98 @@ proc colorsFree {w {red 31} {green 245} {blue 192}} { && ([lindex $vals 2]/256 == $blue) } -test frame-1.1 {frame configuration options} { + +test frame-1.1 {frame configuration options} -setup { + deleteWindows +} -body { + frame .f -class NewFrame + .f configure -class +} -cleanup { + deleteWindows +} -result {-class class Class Frame NewFrame} +test frame-1.2 {frame configuration options} -setup { + deleteWindows +} -body { frame .f -class NewFrame - list [.f configure -class] [catch {.f configure -class Different} msg] $msg -} {{-class class Class Frame NewFrame} 1 {can't modify -class option after widget is created}} -catch {destroy .f} -test frame-1.2 {frame configuration options} { + .f configure -class Different +} -cleanup { + deleteWindows +} -returnCodes error -result {can't modify -class option after widget is created} + +test frame-1.3 {frame configuration options} -setup { + deleteWindows +} -body { frame .f -colormap new - list [.f configure -colormap] [catch {.f configure -colormap .} msg] $msg -} {{-colormap colormap Colormap {} new} 1 {can't modify -colormap option after widget is created}} -catch {destroy .f} -test frame-1.3 {frame configuration options} { + .f configure -colormap +} -cleanup { + deleteWindows +} -result {-colormap colormap Colormap {} new} +test frame-1.4 {frame configuration options} -setup { + deleteWindows +} -body { + frame .f -colormap new + .f configure -colormap . +} -cleanup { + deleteWindows +} -returnCodes error -result {can't modify -colormap option after widget is created} + +test frame-1.5 {frame configuration options} -setup { + deleteWindows +} -body { frame .f -visual default - list [.f configure -visual] [catch {.f configure -visual best} msg] $msg -} {{-visual visual Visual {} default} 1 {can't modify -visual option after widget is created}} -catch {destroy .f} -test frame-1.4 {frame configuration options} { - list [catch {frame .f -screen bogus} msg] $msg -} {1 {unknown option "-screen"}} -test frame-1.5 {frame configuration options} { - set result [list [catch {frame .f -container true} msg] $msg \ - [.f configure -container]] - destroy .f - set result -} {0 .f {-container container Container 0 1}} -test frame-1.6 {frame configuration options} { - list [catch {frame .f -container bogus} msg] $msg -} {1 {expected boolean value but got "bogus"}} -test frame-1.7 {frame configuration options} { + .f configure -visual +} -cleanup { + deleteWindows +} -result {-visual visual Visual {} default} +test frame-1.6 {frame configuration options} -setup { + deleteWindows +} -body { + frame .f -visual default + .f configure -visual best +} -cleanup { + deleteWindows +} -returnCodes error -result {can't modify -visual option after widget is created} + +test frame-1.7 {frame configuration options} -setup { + deleteWindows +} -body { + frame .f -screen bogus +} -cleanup { + deleteWindows +} -returnCodes error -result {unknown option "-screen"} +test frame-1.8 {frame configuration options} -setup { + deleteWindows +} -body { + frame .f -container true +} -cleanup { + deleteWindows +} -result {.f} +test frame-1.9 {frame configuration options} -setup { + deleteWindows +} -body { + frame .f -container true + .f configure -container +} -cleanup { + deleteWindows +} -result {-container container Container 0 1} +test frame-1.10 {frame configuration options} -setup { + deleteWindows +} -body { + frame .f -container bogus +} -cleanup { + deleteWindows +} -returnCodes error -result {expected boolean value but got "bogus"} +test frame-1.11 {frame configuration options} -setup { + deleteWindows +} -body { frame .f - set result [list [catch {.f configure -container 1} msg] $msg] - destroy .f - set result -} {1 {can't modify -container option after widget is created}} -test frame-1.8 {frame configuration options} { + .f configure -container 1 +} -cleanup { + deleteWindows +} -returnCodes error -result {can't modify -container option after widget is created} +test frame-1.12 {frame configuration options} -setup { + deleteWindows +} -body { # Make sure all options can be set to the default value frame .f set opts {} @@ -97,120 +156,327 @@ test frame-1.8 {frame configuration options} { } eval frame .g $opts destroy .f .g -} {} +} -cleanup { + deleteWindows +} -result {} +destroy .f frame .f -set i 9 -foreach test { - {-background #ff0000 #ff0000 non-existent - {unknown color name "non-existent"}} - {-bd 4 4 badValue {bad screen distance "badValue"}} - {-bg #00ff00 #00ff00 non-existent - {unknown color name "non-existent"}} - {-borderwidth 1.3 1 badValue {bad screen distance "badValue"}} - {-cursor arrow arrow badValue {bad cursor spec "badValue"}} - {-height 100 100 not_a_number {bad screen distance "not_a_number"}} - {-highlightbackground #112233 #112233 ugly {unknown color name "ugly"}} - {-highlightcolor #123456 #123456 non-existent - {unknown color name "non-existent"}} - {-highlightthickness 6 6 badValue {bad screen distance "badValue"}} - {-padx 3 3 badValue {bad screen distance "badValue"}} - {-pady 4 4 badValue {bad screen distance "badValue"}} - {-relief ridge ridge badValue {bad relief "badValue": must be flat, groove, raised, ridge, solid, or sunken}} - {-takefocus "any string" "any string" {} {}} - {-width 32 32 badValue {bad screen distance "badValue"}} -} { - lassign $test opt goodValue goodResult badValue badResult - test frame-1.$i {frame configuration options} { - .f configure $opt $goodValue - lindex [.f configure $opt] 4 - } $goodResult - incr i - if {$badValue ne ""} { - test frame-1.$i {frame configuration options} -body { - .f configure $opt $badValue - } -returnCodes error -result $badResult - } - .f configure $opt [lindex [.f configure $opt] 3] - incr i -} +test frame-1.13 {frame configuration options} -body { + .f configure -background #ff0000 + lindex [.f configure -background] 4 +} -cleanup { + .f configure -background [lindex [.f configure -background] 3] +} -result {#ff0000} +test frame-1.14 {frame configuration options} -body { + .f configure -background non-existent +} -returnCodes error -result {unknown color name "non-existent"} +test frame-1.15 {frame configuration options} -body { + .f configure -bd 4 + lindex [.f configure -bd] 4 +} -cleanup { + .f configure -bd [lindex [.f configure -bd] 3] +} -result {4} +test frame-1.16 {frame configuration options} -body { + .f configure -bd badValue +} -returnCodes error -result {bad screen distance "badValue"} +test frame-1.17 {frame configuration options} -body { + .f configure -bg #00ff00 + lindex [.f configure -bg] 4 +} -cleanup { + .f configure -bg [lindex [.f configure -bg] 3] +} -result {#00ff00} +test frame-1.18 {frame configuration options} -body { + .f configure -bg non-existent +} -returnCodes error -result {unknown color name "non-existent"} +test frame-1.19 {frame configuration options} -body { + .f configure -borderwidth 1.3 + lindex [.f configure -borderwidth] 4 +} -cleanup { + .f configure -borderwidth [lindex [.f configure -borderwidth] 3] +} -result {1} +test frame-1.20 {frame configuration options} -body { + .f configure -borderwidth badValue +} -returnCodes error -result {bad screen distance "badValue"} +test frame-1.21 {frame configuration options} -body { + .f configure -cursor arrow + lindex [.f configure -cursor] 4 +} -cleanup { + .f configure -cursor [lindex [.f configure -cursor] 3] +} -result {arrow} +test frame-1.22 {frame configuration options} -body { + .f configure -cursor badValue +} -returnCodes error -result {bad cursor spec "badValue"} +test frame-1.23 {frame configuration options} -body { + .f configure -height 100 + lindex [.f configure -height] 4 +} -cleanup { + .f configure -height [lindex [.f configure -height] 3] +} -result {100} +test frame-1.24 {frame configuration options} -body { + .f configure -height not_a_number +} -returnCodes error -result {bad screen distance "not_a_number"} +test frame-1.25 {frame configuration options} -body { + .f configure -highlightbackground #112233 + lindex [.f configure -highlightbackground] 4 +} -cleanup { + .f configure -highlightbackground [lindex [.f configure -highlightbackground] 3] +} -result {#112233} +test frame-1.26 {frame configuration options} -body { + .f configure -highlightbackground ugly +} -returnCodes error -result {unknown color name "ugly"} +test frame-1.27 {frame configuration options} -body { + .f configure -highlightcolor #123456 + lindex [.f configure -highlightcolor] 4 +} -cleanup { + .f configure -highlightcolor [lindex [.f configure -highlightcolor] 3] +} -result {#123456} +test frame-1.28 {frame configuration options} -body { + .f configure -highlightcolor non-existent +} -returnCodes error -result {unknown color name "non-existent"} +test frame-1.29 {frame configuration options} -body { + .f configure -highlightthickness 6 + lindex [.f configure -highlightthickness] 4 +} -cleanup { + .f configure -highlightthickness [lindex [.f configure -highlightthickness] 3] +} -result {6} +test frame-1.30 {frame configuration options} -body { + .f configure -highlightthickness badValue +} -returnCodes error -result {bad screen distance "badValue"} +test frame-1.31 {frame configuration options} -body { + .f configure -padx 3 + lindex [.f configure -padx] 4 +} -cleanup { + .f configure -padx [lindex [.f configure -padx] 3] +} -result {3} +test frame-1.32 {frame configuration options} -body { + .f configure -padx badValue +} -returnCodes error -result {bad screen distance "badValue"} +test frame-1.33 {frame configuration options} -body { + .f configure -pady 4 + lindex [.f configure -pady] 4 +} -cleanup { + .f configure -pady [lindex [.f configure -pady] 3] +} -result {4} +test frame-1.34 {frame configuration options} -body { + .f configure -pady badValue +} -returnCodes error -result {bad screen distance "badValue"} +test frame-1.35 {frame configuration options} -body { + .f configure -relief ridge + lindex [.f configure -relief] 4 +} -cleanup { + .f configure -relief [lindex [.f configure -relief] 3] +} -result {ridge} +test frame-1.36 {frame configuration options} -body { + .f configure -relief badValue +} -returnCodes error -result {bad relief "badValue": must be flat, groove, raised, ridge, solid, or sunken} +test frame-1.37 {frame configuration options} -body { + .f configure -takefocus {any string} + lindex [.f configure -takefocus] 4 +} -cleanup { + .f configure -takefocus [lindex [.f configure -takefocus] 3] +} -result {any string} +test frame-1.38 {frame configuration options} -body { + .f configure -width 32 + lindex [.f configure -width] 4 +} -cleanup { + .f configure -width [lindex [.f configure -width] 3] +} -result {32} +test frame-1.39 {frame configuration options} -body { + .f configure -width badValue +} -returnCodes error -result {bad screen distance "badValue"} destroy .f -test frame-2.1 {toplevel configuration options} { - catch {destroy .t} + +test frame-2.1 {toplevel configuration options} -setup { + deleteWindows +} -body { toplevel .t -width 200 -height 100 -class NewClass wm geometry .t +0+0 - list [.t configure -class] [catch {.t configure -class Another} msg] $msg -} {{-class class Class Toplevel NewClass} 1 {can't modify -class option after widget is created}} -test frame-2.2 {toplevel configuration options} { - catch {destroy .t} + .t configure -class +} -cleanup { + deleteWindows +} -result {-class class Class Toplevel NewClass} +test frame-2.2 {toplevel configuration options} -setup { + deleteWindows +} -body { + toplevel .t -width 200 -height 100 -class NewClass + wm geometry .t +0+0 + .t configure -class Another +} -cleanup { + deleteWindows +} -returnCodes error -result {can't modify -class option after widget is created} + +test frame-2.3 {toplevel configuration options} -setup { + deleteWindows +} -body { toplevel .t -width 200 -height 100 -colormap new wm geometry .t +0+0 - list [.t configure -colormap] [catch {.t configure -colormap .} msg] $msg -} {{-colormap colormap Colormap {} new} 1 {can't modify -colormap option after widget is created}} -test frame-2.3 {toplevel configuration options} { + .t configure -colormap +} -cleanup { + deleteWindows +} -result {-colormap colormap Colormap {} new} +test frame-2.4 {toplevel configuration options} -setup { + deleteWindows +} -body { + toplevel .t -width 200 -height 100 -colormap new + wm geometry .t +0+0 + .t configure -colormap . +} -cleanup { + deleteWindows +} -returnCodes error -result {can't modify -colormap option after widget is created} + +test frame-2.5 {toplevel configuration options} -setup { + deleteWindows +} -body { + toplevel .t -width 200 -height 100 + wm geometry .t +0+0 + .t configure -container 1 +} -cleanup { + deleteWindows +} -returnCodes error -result {can't modify -container option after widget is created} +test frame-2.6 {toplevel configuration options} -setup { + deleteWindows +} -body { catch {destroy .t} toplevel .t -width 200 -height 100 wm geometry .t +0+0 - list [catch {.t configure -container 1} msg] $msg [.t configure -container] -} {1 {can't modify -container option after widget is created} {-container container Container 0 0}} -test frame-2.4 {toplevel configuration options} { + catch {.t configure -container 1} + .t configure -container +} -cleanup { + deleteWindows +} -result {-container container Container 0 0} + +test frame-2.7 {toplevel configuration options} -setup { + deleteWindows +} -body { + toplevel .t -width 200 -height 100 -colormap bogus +} -cleanup { + deleteWindows +} -returnCodes error -result {bad window path name "bogus"} + + +test frame-2.8 {toplevel configuration options} -constraints { + win +} -setup { + deleteWindows +} -body { catch {destroy .t} - list [catch {toplevel .t -width 200 -height 100 -colormap bogus} msg] $msg -} {1 {bad window path name "bogus"}} -set default "[winfo visual .] [winfo depth .]" -if {$tcl_platform(platform) == "windows"} { -test frame-2.5 {toplevel configuration options} { + toplevel .t -width 200 -height 100 + wm geometry .t +0+0 + .t configure -use 0x44022 +} -cleanup { + deleteWindows +} -returnCodes error -result {window "0x44022" doesn't exist} +test frame-2.9 {toplevel configuration options} -constraints { + win +} -setup { + deleteWindows +} -body { catch {destroy .t} toplevel .t -width 200 -height 100 wm geometry .t +0+0 - list [catch {.t configure -use 0x44022} msg] $msg [.t configure -use] -} {1 {window "0x44022" doesn't exist} {-use use Use {} {}}} -} else { -test frame-2.5 {toplevel configuration options} { + catch {.t configure -use 0x44022} + .t configure -use +} -cleanup { + deleteWindows +} -result {-use use Use {} {}} + +test frame-2.10 {toplevel configuration options} -constraints { + nonwin +} -setup { + deleteWindows +} -body { catch {destroy .t} toplevel .t -width 200 -height 100 wm geometry .t +0+0 - list [catch {.t configure -use 0x44022} msg] $msg [.t configure -use] -} {1 {can't modify -use option after widget is created} {-use use Use {} {}}} -} + .t configure -use 0x44022 +} -cleanup { + deleteWindows +} -returnCodes error -result {can't modify -use option after widget is created} +test frame-2.11 {toplevel configuration options} -constraints { + nonwin +} -setup { + deleteWindows +} -body { + catch {destroy .t} + toplevel .t -width 200 -height 100 + wm geometry .t +0+0 + catch {.t configure -use 0x44022} + .t configure -use +} -cleanup { + deleteWindows +} -result {-use use Use {} {}} -test frame-2.6 {toplevel configuration options} { +test frame-2.12 {toplevel configuration options} -setup { + deleteWindows +} -body { catch {destroy .t} toplevel .t -width 200 -height 100 -visual default wm geometry .t +0+0 - list [.t configure -visual] [catch {.t configure -visual best} msg] $msg -} {{-visual visual Visual {} default} 1 {can't modify -visual option after widget is created}} -test frame-2.7 {toplevel configuration options} { - catch {destroy .t} - list [catch {toplevel .t -width 200 -height 100 -visual who_knows?} msg] $msg -} {1 {unknown or ambiguous visual name "who_knows?": class must be best, directcolor, grayscale, greyscale, pseudocolor, staticcolor, staticgray, staticgrey, truecolor, or default}} -test frame-2.8 {toplevel configuration options} haveDISPLAY { + .t configure -visual +} -cleanup { + deleteWindows +} -result {-visual visual Visual {} default} +test frame-2.13 {toplevel configuration options} -setup { + deleteWindows +} -body { catch {destroy .t} + toplevel .t -width 200 -height 100 -visual default + wm geometry .t +0+0 + .t configure -visual best +} -cleanup { + deleteWindows +} -returnCodes error -result {can't modify -visual option after widget is created} + +test frame-2.14 {toplevel configuration options} -setup { + deleteWindows +} -body { + toplevel .t -width 200 -height 100 -visual who_knows? +} -cleanup { + deleteWindows +} -returnCodes error -result {unknown or ambiguous visual name "who_knows?": class must be best, directcolor, grayscale, greyscale, pseudocolor, staticcolor, staticgray, staticgrey, truecolor, or default} +test frame-2.15 {toplevel configuration options} -constraints haveDISPLAY -setup { + deleteWindows +} -body { toplevel .t -width 200 -height 100 -screen $env(DISPLAY) wm geometry .t +0+0 - set cfg [string compare [.t configure -screen] \ - "-screen screen Screen {} $env(DISPLAY)"] - list $cfg [catch {.t configure -screen another} msg] $msg -} {0 1 {can't modify -screen option after widget is created}} -test frame-2.9 {toplevel configuration options} { - catch {destroy .t} - list [catch {toplevel .t -width 200 -height 100 -screen bogus} msg] $msg -} {1 {couldn't connect to display "bogus"}} -test frame-2.10 {toplevel configuration options} { - catch {destroy .t} - catch {destroy .x} + string compare [.t configure -screen] "-screen screen Screen {} $env(DISPLAY)" +} -cleanup { + deleteWindows +} -result {0} +test frame-2.16 {toplevel configuration options} -constraints haveDISPLAY -setup { + deleteWindows +} -body { + toplevel .t -width 200 -height 100 -screen $env(DISPLAY) + wm geometry .t +0+0 + .t configure -screen another +} -cleanup { + deleteWindows +} -returnCodes error -result {can't modify -screen option after widget is created} + +test frame-2.17 {toplevel configuration options} -setup { + deleteWindows +} -body { + toplevel .t -width 200 -height 100 -screen bogus +} -cleanup { + deleteWindows +} -returnCodes error -result {couldn't connect to display "bogus"} +test frame-2.18 {toplevel configuration options} -setup { + deleteWindows +} -body { toplevel .t -container 1 -width 300 -height 120 wm geometry .t +0+0 - set result [list \ - [catch {toplevel .x -container 1 -use [winfo id .t]} msg] $msg] - destroy .t .x - set result -} {1 {A window cannot have both the -use and the -container option set.}} -test frame-2.11 {toplevel configuration options} { + toplevel .x -container 1 -use [winfo id .t] +} -cleanup { + deleteWindows +} -returnCodes error -result {A window cannot have both the -use and the -container option set.} +test frame-2.19 {toplevel configuration options} -setup { + deleteWindows + set opts {} +} -body { # Make sure all options can be set to the default value toplevel .f - set opts {} foreach opt [.f configure] { if {[llength $opt] == 5} { lappend opts [lindex $opt 0] [lindex $opt 4] @@ -218,112 +484,184 @@ test frame-2.11 {toplevel configuration options} { } eval toplevel .g $opts destroy .f .g -} {} +} -cleanup { + deleteWindows +} -result {} + -catch {destroy .t} +destroy .t toplevel .t -width 300 -height 150 wm geometry .t +0+0 update -set i 12 -foreach test { - {-background #ff0000 #ff0000 non-existent - {unknown color name "non-existent"}} - {-bd 4 4 badValue {bad screen distance "badValue"}} - {-bg #00ff00 #00ff00 non-existent - {unknown color name "non-existent"}} - {-borderwidth 1.3 1 badValue {bad screen distance "badValue"}} - {-cursor arrow arrow badValue {bad cursor spec "badValue"}} - {-height 100 100 not_a_number {bad screen distance "not_a_number"}} - {-highlightcolor #123456 #123456 non-existent - {unknown color name "non-existent"}} - {-highlightthickness 3 3 badValue {bad screen distance "badValue"}} - {-padx 3 3 badValue {bad screen distance "badValue"}} - {-pady 4 4 badValue {bad screen distance "badValue"}} - {-relief ridge ridge badValue {bad relief "badValue": must be flat, groove, raised, ridge, solid, or sunken}} - {-width 32 32 badValue {bad screen distance "badValue"}} -} { - lassign $test opt goodValue goodResult badValue badResult - test frame-2.$i {toplevel configuration options} { - .t configure $opt $goodValue - lindex [.t configure $opt] 4 - } $goodResult - incr i - if {$badValue ne ""} { - test frame-2.$i {toplevel configuration options} -body { - .t configure $opt $badValue - } -returnCodes error -result $badResult - } - .t configure $opt [lindex [.t configure $opt] 3] - incr i -} +test frame-2.20 {toplevel configuration options} -body { + .t configure -background #ff0000 + lindex [.t configure -background] 4 +} -result {#ff0000} +test frame-2.21 {toplevel configuration options} -body { + .t configure -background non-existent +} -returnCodes error -result {unknown color name "non-existent"} +test frame-2.22 {toplevel configuration options} -body { + .t configure -bd 4 + lindex [.t configure -bd] 4 +} -result {4} +test frame-2.23 {toplevel configuration options} -body { + .t configure -bd badValue +} -returnCodes error -result {bad screen distance "badValue"} +test frame-2.24 {toplevel configuration options} -body { + .t configure -bg #00ff00 + lindex [.t configure -bg] 4 +} -result {#00ff00} +test frame-2.25 {toplevel configuration options} -body { + .t configure -bg non-existent +} -returnCodes error -result {unknown color name "non-existent"} +test frame-2.26 {toplevel configuration options} -body { + .t configure -borderwidth 1.3 + lindex [.t configure -borderwidth] 4 +} -result {1} +test frame-2.27 {toplevel configuration options} -body { + .t configure -borderwidth badValue +} -returnCodes error -result {bad screen distance "badValue"} +test frame-2.28 {toplevel configuration options} -body { + .t configure -cursor arrow + lindex [.t configure -cursor] 4 +} -result {arrow} +test frame-2.29 {toplevel configuration options} -body { + .t configure -cursor badValue +} -returnCodes error -result {bad cursor spec "badValue"} +test frame-2.30 {toplevel configuration options} -body { + .t configure -height 100 + lindex [.t configure -height] 4 +} -result {100} +test frame-2.31 {toplevel configuration options} -body { + .t configure -height not_a_number +} -returnCodes error -result {bad screen distance "not_a_number"} +test frame-2.32 {toplevel configuration options} -body { + .t configure -highlightcolor #123456 + lindex [.t configure -highlightcolor] 4 +} -result {#123456} +test frame-2.33 {toplevel configuration options} -body { + .t configure -highlightcolor non-existent +} -returnCodes error -result {unknown color name "non-existent"} +test frame-2.34 {toplevel configuration options} -body { + .t configure -highlightthickness 3 + lindex [.t configure -highlightthickness] 4 +} -result {3} +test frame-2.35 {toplevel configuration options} -body { + .t configure -highlightthickness badValue +} -returnCodes error -result {bad screen distance "badValue"} +test frame-2.36 {toplevel configuration options} -body { + .t configure -padx 3 + lindex [.t configure -padx] 4 +} -result {3} +test frame-2.37 {toplevel configuration options} -body { + .t configure -padx badValue +} -returnCodes error -result {bad screen distance "badValue"} +test frame-2.38 {toplevel configuration options} -body { + .t configure -pady 4 + lindex [.t configure -pady] 4 +} -result {4} +test frame-2.39 {toplevel configuration options} -body { + .t configure -pady badValue +} -returnCodes error -result {bad screen distance "badValue"} +test frame-2.40 {toplevel configuration options} -body { + .t configure -relief ridge + lindex [.t configure -relief] 4 +} -result {ridge} +test frame-2.41 {toplevel configuration options} -body { + .t configure -relief badValue +} -returnCodes error -result {bad relief "badValue": must be flat, groove, raised, ridge, solid, or sunken} +test frame-2.42 {toplevel configuration options} -body { + .t configure -width 32 + lindex [.t configure -width] 4 +} -result {32} +test frame-2.43 {toplevel configuration options} -body { + .t configure -width badValue +} -returnCodes error -result {bad screen distance "badValue"} +destroy .t + test frame-3.1 {TkCreateFrame procedure} -body { frame } -returnCodes error -result {wrong # args: should be "frame pathName ?-option value ...?"} test frame-3.2 {TkCreateFrame procedure} -setup { - catch {destroy .f} + deleteWindows frame .f } -body { .f configure -class } -cleanup { - destroy .f + deleteWindows } -result {-class class Class Frame Frame} test frame-3.3 {TkCreateFrame procedure} -setup { - catch {destroy .t} + deleteWindows toplevel .t wm geometry .t +0+0 } -body { .t configure -class } -cleanup { - destroy .t + deleteWindows } -result {-class class Class Toplevel Toplevel} -test frame-3.4 {TkCreateFrame procedure} { - catch {destroy .t} +test frame-3.4 {TkCreateFrame procedure} -setup { + deleteWindows +} -body { toplevel .t -width 350 -class NewClass -bg black -visual default -height 90 wm geometry .t +0+0 update list [lindex [.t configure -width] 4] \ [lindex [.t configure -background] 4] \ [lindex [.t configure -height] 4] -} {350 black 90} +} -cleanup { + deleteWindows +} -result {350 black 90} # Be sure that the -class, -colormap, and -visual options are processed # before configuring the widget. - -test frame-3.5 {TkCreateFrame procedure} { - catch {destroy .f} +test frame-3.5 {TkCreateFrame procedure} -setup { + deleteWindows +} -body { option add *NewFrame.background #123456 frame .f -class NewFrame - option clear lindex [.f configure -background] 4 -} {#123456} -test frame-3.6 {TkCreateFrame procedure} { - catch {destroy .f} +} -cleanup { + deleteWindows + option clear +} -result {#123456} +test frame-3.6 {TkCreateFrame procedure} -setup { + deleteWindows +} -body { option add *NewFrame.background #123456 frame .f -class NewFrame - option clear lindex [.f configure -background] 4 -} {#123456} -test frame-3.7 {TkCreateFrame procedure} { - catch {destroy .f} +} -cleanup { + deleteWindows + option clear +} -result {#123456} +test frame-3.7 {TkCreateFrame procedure} -setup { + deleteWindows +} -body { option add *NewFrame.background #332211 option add *f.class NewFrame frame .f - option clear list [lindex [.f configure -class] 4] [lindex [.f configure -background] 4] -} {NewFrame #332211} -test frame-3.8 {TkCreateFrame procedure} { - catch {destroy .f} +} -cleanup { + deleteWindows + option clear +} -result {NewFrame #332211} +test frame-3.8 {TkCreateFrame procedure} -setup { + deleteWindows +} -body { option add *Silly.background #122334 option add *f.Class Silly frame .f - option clear list [lindex [.f configure -class] 4] [lindex [.f configure -background] 4] -} {Silly #122334} -test frame-3.9 {TkCreateFrame procedure, -use option} -setup { - catch {destroy .t} - catch {destroy .x} -} -constraints unix -body { +} -cleanup { + deleteWindows + option clear +} -result {Silly #122334} +test frame-3.9 {TkCreateFrame procedure, -use option} -constraints { + unix +} -setup { + deleteWindows +} -body { toplevel .t -container 1 -width 300 -height 120 wm geometry .t +0+0 toplevel .x -width 140 -height 300 -use [winfo id .t] -bg green @@ -332,12 +670,13 @@ test frame-3.9 {TkCreateFrame procedure, -use option} -setup { [expr {[winfo rooty .x] - [winfo rooty .t]}] \ [winfo width .t] [winfo height .t] } -cleanup { - destroy .t + deleteWindows } -result {0 0 140 300} -test frame-3.10 {TkCreateFrame procedure, -use option} -setup { - catch {destroy .t} - catch {destroy .x} -} -constraints unix -body { +test frame-3.10 {TkCreateFrame procedure, -use option} -constraints { + unix +} -setup { + deleteWindows +} -body { toplevel .t -container 1 -width 300 -height 120 wm geometry .t +0+0 option add *x.use [winfo id .t] @@ -355,26 +694,38 @@ test frame-3.10 {TkCreateFrame procedure, -use option} -setup { # they are run on a pseudocolor display of depth 8). Even so, they # are non-portable: some machines don't seem to ever run out of # colors. - if {[testConstraint defaultPseudocolor8]} { eatColors .t1 } -test frame-3.11 {TkCreateFrame procedure} {defaultPseudocolor8 nonPortable} { - catch {destroy .t} +test frame-3.11 {TkCreateFrame procedure} -constraints { + defaultPseudocolor8 nonPortable +} -setup { + deleteWindows +} -body { toplevel .t -width 300 -height 200 -bg #475601 wm geometry .t +0+0 update colorsFree .t -} {0} -test frame-3.12 {TkCreateFrame procedure} {defaultPseudocolor8 nonPortable} { - catch {destroy .t} +} -cleanup { + deleteWindows +} -result {0} +test frame-3.12 {TkCreateFrame procedure} -constraints { + defaultPseudocolor8 nonPortable +} -setup { + deleteWindows +} -body { toplevel .t -width 300 -height 200 -bg #475601 -colormap new wm geometry .t +0+0 update colorsFree .t -} {1} -test frame-3.13 {TkCreateFrame procedure} {defaultPseudocolor8 nonPortable} { - catch {destroy .t} +} -cleanup { + deleteWindows +} -result {1} +test frame-3.13 {TkCreateFrame procedure} -constraints { + defaultPseudocolor8 nonPortable +} -setup { + deleteWindows +} -body { option add *t.class Toplevel2 option add *Toplevel2.colormap new toplevel .t -width 300 -height 200 -bg #475601 @@ -382,9 +733,14 @@ test frame-3.13 {TkCreateFrame procedure} {defaultPseudocolor8 nonPortable} { update option clear colorsFree .t -} {1} -test frame-3.14 {TkCreateFrame procedure} {defaultPseudocolor8 nonPortable} { - catch {destroy .t} +} -cleanup { + deleteWindows +} -result {1} +test frame-3.14 {TkCreateFrame procedure} -constraints { + defaultPseudocolor8 nonPortable +} -setup { + deleteWindows +} -body { option add *t.class Toplevel3 option add *Toplevel3.Colormap new toplevel .t -width 300 -height 200 -bg #475601 -colormap new @@ -392,11 +748,14 @@ test frame-3.14 {TkCreateFrame procedure} {defaultPseudocolor8 nonPortable} { update option clear colorsFree .t -} {1} -test frame-3.15 {TkCreateFrame procedure, -use and -colormap} -setup { - catch {destroy .t} - catch {destroy .x} -} -constraints {defaultPseudocolor8 unix nonPortable} -body { +} -cleanup { + deleteWindows +} -result {1} +test frame-3.15 {TkCreateFrame procedure, -use and -colormap} -constraints { + defaultPseudocolor8 unix nonPortable +} -setup { + deleteWindows +} -body { toplevel .t -container 1 -width 300 -height 120 wm geometry .t +0+0 toplevel .x -width 140 -height 300 -use [winfo id .t] -bg green -colormap new @@ -405,30 +764,48 @@ test frame-3.15 {TkCreateFrame procedure, -use and -colormap} -setup { } -cleanup { destroy .t } -result {0 1} -test frame-3.16 {TkCreateFrame procedure} {defaultPseudocolor8 nonPortable} { - catch {destroy .t} +test frame-3.16 {TkCreateFrame procedure} -constraints { + defaultPseudocolor8 nonPortable +} -setup { + deleteWindows +} -body { toplevel .t -width 300 -height 200 -bg #475601 -visual default wm geometry .t +0+0 update colorsFree .t -} {0} -test frame-3.17 {TkCreateFrame procedure} {defaultPseudocolor8 nonPortable} { - catch {destroy .t} +} -cleanup { + deleteWindows +} -result {0} +test frame-3.17 {TkCreateFrame procedure} -constraints { + defaultPseudocolor8 nonPortable +} -setup { + deleteWindows +} -body { toplevel .t -width 300 -height 200 -bg #475601 -visual default \ -colormap new wm geometry .t +0+0 update colorsFree .t -} {1} -test frame-3.18 {TkCreateFrame procedure} {defaultPseudocolor8 haveGrayscale8 nonPortable} { - catch {destroy .t} +} -cleanup { + deleteWindows +} -result {1} +test frame-3.18 {TkCreateFrame procedure} -constraints { + defaultPseudocolor8 haveGrayscale8 nonPortable +} -setup { + deleteWindows +} -body { toplevel .t -visual {grayscale 8} -width 300 -height 200 -bg #434343 wm geometry .t +0+0 update colorsFree .t 131 131 131 -} {1} -test frame-3.19 {TkCreateFrame procedure} {defaultPseudocolor8 haveGrayscale8 nonPortable} { - catch {destroy .t} +} -cleanup { + deleteWindows +} -result {1} +test frame-3.19 {TkCreateFrame procedure} -constraints { + defaultPseudocolor8 haveGrayscale8 nonPortable +} -setup { + deleteWindows +} -body { option add *t.class T4 option add *T4.visual {grayscale 8} toplevel .t -width 300 -height 200 -bg #434343 @@ -436,9 +813,14 @@ test frame-3.19 {TkCreateFrame procedure} {defaultPseudocolor8 haveGrayscale8 no update option clear list [colorsFree .t 131 131 131] [lindex [.t configure -visual] 4] -} {1 {grayscale 8}} -test frame-3.20 {TkCreateFrame procedure} {defaultPseudocolor8 haveGrayscale8 nonPortable} { - catch {destroy .t} +} -cleanup { + deleteWindows +} -result {1 {grayscale 8}} +test frame-3.20 {TkCreateFrame procedure} -constraints { + defaultPseudocolor8 haveGrayscale8 nonPortable +} -setup { + deleteWindows +} -body { set x ok option add *t.class T5 option add *T5.Visual {grayscale 8} @@ -447,20 +829,28 @@ test frame-3.20 {TkCreateFrame procedure} {defaultPseudocolor8 haveGrayscale8 no update option clear list [colorsFree .t 131 131 131] [lindex [.t configure -visual] 4] -} {1 {grayscale 8}} -test frame-3.21 {TkCreateFrame procedure} {defaultPseudocolor8 haveGrayscale8 nonPortable} { - catch {destroy .t} +} -cleanup { + deleteWindows +} -result {1 {grayscale 8}} +test frame-3.21 {TkCreateFrame procedure} -constraints { + defaultPseudocolor8 haveGrayscale8 nonPortable +} -setup { + deleteWindows +} -body { set x ok toplevel .t -visual {grayscale 8} -width 300 -height 200 -bg #434343 wm geometry .t +0+0 update colorsFree .t 131 131 131 -} {1} +} -cleanup { + deleteWindows +} -result {1} if {[testConstraint defaultPseudocolor8]} { destroy .t1 } + test frame-3.22 {TkCreateFrame procedure, default dimensions} -setup { - catch {destroy .t} + deleteWindows } -body { toplevel .t wm geometry .t +0+0 @@ -471,87 +861,103 @@ test frame-3.22 {TkCreateFrame procedure, default dimensions} -setup { update lappend result [winfo reqwidth .t.f] [winfo reqheight .t.f] } -cleanup { - destroy .t + deleteWindows } -result {200 200 1 1} test frame-3.23 {TkCreateFrame procedure} -setup { - catch {destroy .f} + deleteWindows } -body { frame .f -gorp glob } -returnCodes error -result {unknown option "-gorp"} test frame-3.24 {TkCreateFrame procedure} -setup { - catch {destroy .t} + deleteWindows } -body { toplevel .t -width 300 -height 200 -colormap new -bogus option wm geometry .t +0+0 } -returnCodes error -result {unknown option "-bogus"} -test frame-4.1 {TkCreateFrame procedure} { - catch {destroy .f} + +test frame-4.1 {TkCreateFrame procedure} -setup { + deleteWindows +} -body { catch {frame .f -gorp glob} winfo exists .f -} 0 -test frame-4.2 {TkCreateFrame procedure} { - catch {destroy .f} +} -result 0 +test frame-4.2 {TkCreateFrame procedure} -setup { + deleteWindows +} -body { list [frame .f -width 200 -height 100] [winfo exists .f] -} {.f 1} +} -cleanup { + deleteWindows +} -result {.f 1} + -catch {destroy .f} frame .f -highlightcolor black -test frame-5.1 {FrameWidgetCommand procedure} { - list [catch .f msg] $msg -} {1 {wrong # args: should be ".f option ?arg ...?"}} -test frame-5.2 {FrameWidgetCommand procedure, cget option} { - list [catch {.f cget} msg] $msg -} {1 {wrong # args: should be ".f cget option"}} -test frame-5.3 {FrameWidgetCommand procedure, cget option} { - list [catch {.f cget a b} msg] $msg -} {1 {wrong # args: should be ".f cget option"}} -test frame-5.4 {FrameWidgetCommand procedure, cget option} { - list [catch {.f cget -gorp} msg] $msg -} {1 {unknown option "-gorp"}} -test frame-5.5 {FrameWidgetCommand procedure, cget option} { +test frame-5.1 {FrameWidgetCommand procedure} -body { + .f +} -returnCodes error -result {wrong # args: should be ".f option ?arg ...?"} +test frame-5.2 {FrameWidgetCommand procedure, cget option} -body { + .f cget +} -returnCodes error -result {wrong # args: should be ".f cget option"} +test frame-5.3 {FrameWidgetCommand procedure, cget option} -body { + .f cget a b +} -returnCodes error -result {wrong # args: should be ".f cget option"} +test frame-5.4 {FrameWidgetCommand procedure, cget option} -body { + .f cget -gorp +} -returnCodes error -result {unknown option "-gorp"} +test frame-5.5 {FrameWidgetCommand procedure, cget option} -body { .f cget -highlightcolor -} {black} -test frame-5.6 {FrameWidgetCommand procedure, cget option} { - list [catch {.f cget -screen} msg] $msg -} {1 {unknown option "-screen"}} -test frame-5.7 {FrameWidgetCommand procedure, cget option} { - catch {destroy .t} +} -result {black} +test frame-5.6 {FrameWidgetCommand procedure, cget option} -body { + .f cget -screen +} -returnCodes error -result {unknown option "-screen"} +test frame-5.7 {FrameWidgetCommand procedure, cget option} -setup { + destroy .t +} -body { toplevel .t - catch {.t cget -screen} -} {0} -catch {destroy .t} -test frame-5.8 {FrameWidgetCommand procedure, configure option} { + .t cget -screen +} -cleanup { + destroy .t +} -returnCodes ok -match glob -result * + +test frame-5.8 {FrameWidgetCommand procedure, configure option} -body { llength [.f configure] -} {18} -test frame-5.9 {FrameWidgetCommand procedure, configure option} { - list [catch {.f configure -gorp} msg] $msg -} {1 {unknown option "-gorp"}} -test frame-5.10 {FrameWidgetCommand procedure, configure option} { - list [catch {.f configure -gorp bogus} msg] $msg -} {1 {unknown option "-gorp"}} -test frame-5.11 {FrameWidgetCommand procedure, configure option} { - list [catch {.f configure -width 200 -height} msg] $msg -} {1 {value for "-height" missing}} -test frame-5.12 {FrameWidgetCommand procedure} { - list [catch {.f swizzle} msg] $msg -} {1 {bad option "swizzle": must be cget or configure}} -test frame-5.13 {FrameWidgetCommand procedure, configure option} { +} -result {18} +test frame-5.9 {FrameWidgetCommand procedure, configure option} -body { + .f configure -gorp +} -returnCodes error -result {unknown option "-gorp"} +test frame-5.10 {FrameWidgetCommand procedure, configure option} -body { + .f configure -gorp bogus +} -returnCodes error -result {unknown option "-gorp"} +test frame-5.11 {FrameWidgetCommand procedure, configure option} -body { + .f configure -width 200 -height +} -returnCodes error -result {value for "-height" missing} +test frame-5.12 {FrameWidgetCommand procedure} -body { + .f swizzle +} -returnCodes error -result {bad option "swizzle": must be cget or configure} +test frame-5.13 {FrameWidgetCommand procedure, configure option} -body { llength [. configure] -} {21} +} -result {21} +destroy .f -test frame-6.1 {ConfigureFrame procedure} { - catch {destroy .f} +test frame-6.1 {ConfigureFrame procedure} -setup { + deleteWindows +} -body { frame .f -width 150 list [winfo reqwidth .f] [winfo reqheight .f] -} {150 1} -test frame-6.2 {ConfigureFrame procedure} { - catch {destroy .f} +} -cleanup { + deleteWindows +} -result {150 1} +test frame-6.2 {ConfigureFrame procedure} -setup { + deleteWindows +} -body { frame .f -height 97 list [winfo reqwidth .f] [winfo reqheight .f] -} {1 97} -test frame-6.3 {ConfigureFrame procedure} { - catch {destroy .f} +} -cleanup { + deleteWindows +} -result {1 97} +test frame-6.3 {ConfigureFrame procedure} -setup { + deleteWindows +} -body { frame .f set result {} lappend result [winfo reqwidth .f] [winfo reqheight .f] @@ -559,77 +965,98 @@ test frame-6.3 {ConfigureFrame procedure} { lappend result [winfo reqwidth .f] [winfo reqheight .f] .f configure -width 0 -height 0 lappend result [winfo reqwidth .f] [winfo reqheight .f] -} {1 1 100 180 100 180} +} -cleanup { + deleteWindows +} -result {1 1 100 180 100 180} -test frame-7.1 {FrameEventProc procedure} { +test frame-7.1 {FrameEventProc procedure} -setup { + deleteWindows +} -body { frame .frame2 set result [info commands .frame2] destroy .frame2 lappend result [info commands .frame2] -} {.frame2 {}} -test frame-7.2 {FrameEventProc procedure} { - deleteWindows +} -result {.frame2 {}} +test frame-7.2 {FrameEventProc procedure} -setup { + deleteWindows + set x {} +} -body { frame .f1 -bg #543210 rename .f1 .f2 - set x {} lappend x [winfo children .] lappend x [.f2 cget -bg] destroy .f1 lappend x [info command .f*] [winfo children .] -} {.f1 #543210 {} {}} - -test frame-8.1 {FrameCmdDeletedProc procedure} { +} -cleanup { deleteWindows +} -result {.f1 #543210 {} {}} + +test frame-8.1 {FrameCmdDeletedProc procedure} -setup { + deleteWindows +} -body { frame .f1 rename .f1 {} list [info command .f*] [winfo children .] -} {{} {}} -test frame-8.2 {FrameCmdDeletedProc procedure} { +} -cleanup { deleteWindows +} -result {{} {}} +test frame-8.2 {FrameCmdDeletedProc procedure} -setup { + deleteWindows +} -body { toplevel .f1 -menu .m wm geometry .f1 +0+0 update rename .f1 {} update list [info command .f*] [winfo children .] -} {{} {}} +} -cleanup { + deleteWindows +} -result {{} {}} # # This one fails with the dash-patch!!!! Still don't know why :-( # -#test frame-8.3 {FrameCmdDeletedProc procedure} { +#test frame-8.3 {FrameCmdDeletedProc procedure} -setup { # eval destroy [winfo children .] +# deleteWindows +#} -body { # toplevel .f1 -menu .m # wm geometry .f1 +0+0 # menu .m # update # rename .f1 {} # update -# set result [list [info command .f*] [winfo children .]] +# list [info command .f*] [winfo children .] +#} -cleanup { # eval destroy [winfo children .] -# set result -#} {{} .m} +# deleteWindows +#} -result {{} .m} -test frame-9.1 {MapFrame procedure} { - catch {destroy .t} +test frame-9.1 {MapFrame procedure} -setup { + deleteWindows +} -body { toplevel .t -width 100 -height 400 wm geometry .t +0+0 set result [winfo ismapped .t] update idletasks lappend result [winfo ismapped .t] -} {0 1} -test frame-9.2 {MapFrame procedure} { - catch {destroy .t} +} -cleanup { + deleteWindows +} -result {0 1} +test frame-9.2 {MapFrame procedure} -setup { + deleteWindows +} -body { toplevel .t -width 100 -height 400 wm geometry .t +0+0 destroy .t update winfo exists .t -} {0} -test frame-9.3 {MapFrame procedure, window deleted while mapping} { +} -result {0} +test frame-9.3 {MapFrame procedure, window deleted while mapping} -setup { + deleteWindows +} -body { toplevel .t2 -width 200 -height 200 wm geometry .t2 +0+0 tkwait visibility .t2 - catch {destroy .t} toplevel .t -width 100 -height 400 wm geometry .t +0+0 frame .t2.f -width 50 -height 50 @@ -637,53 +1064,66 @@ test frame-9.3 {MapFrame procedure, window deleted while mapping} { pack .t2.f -side top update idletasks winfo exists .t -} {0} +} -cleanup { + deleteWindows +} -result {0} -set l [interp hidden] -deleteWindows -test frame-10.1 {frame widget vs hidden commands} { - catch {destroy .t} +test frame-10.1 {frame widget vs hidden commands} -setup { + deleteWindows +} -body { + set l [interp hidden] frame .t interp hide {} .t destroy .t - list [winfo children .] [interp hidden] -} [list {} $l] + set res1 [list [winfo children .] [interp hidden]] + set res2 [list {} $l] + expr {$res1 eq $res2} +} -result 1 -test frame-11.1 {TkInstallFrameMenu} { - catch {destroy .t} + +test frame-11.1 {TkInstallFrameMenu} -setup { + deleteWindows +} -body { menu .m1 .m1 add cascade -menu .m1.system menu .m1.system -tearoff 0 .m1.system add command -label foo - list [toplevel .t -menu .m1] [destroy .m1] [destroy .t] -} {.t {} {}} -test frame-11.2 {TkInstallFrameMenu - frame renamed} { - catch {destroy .t} + toplevel .t -menu .m1 +} -cleanup { + deleteWindows +} -result {.t} +test frame-11.2 {TkInstallFrameMenu - frame renamed} -setup { + deleteWindows +} -body { catch {rename foo {}} menu .m1 .m1 add cascade -menu .m1.system menu .m1.system -tearoff 0 .m1.system add command -label foo toplevel .t - list [rename .t foo] [destroy .t] [destroy foo] [destroy .m1] -} {{} {} {} {}} + rename .t foo +} -cleanup { + deleteWindows +} -result {} + -test frame-12.1 {FrameWorldChanged procedure} { +test frame-12.1 {FrameWorldChanged procedure} -setup { + deleteWindows +} -body { # Test -bd -padx and -pady - destroy .f frame .f -borderwidth 2 -padx 3 -pady 4 place .f -x 0 -y 0 -width 40 -height 40 pack [frame .f.f] -fill both -expand 1 update - set result [list [winfo x .f.f] [winfo y .f.f] \ - [winfo width .f.f] [winfo height .f.f]] - destroy .f - set result -} {5 6 30 28} -test frame-12.2 {FrameWorldChanged procedure} { + list [winfo x .f.f] [winfo y .f.f] [winfo width .f.f] [winfo height .f.f] +} -cleanup { + deleteWindows +} -result {5 6 30 28} +test frame-12.2 {FrameWorldChanged procedure} -setup { + deleteWindows +} -body { # Test all -labelanchor positions - destroy .f set font {helvetica 12} labelframe .f -highlightthickness 1 -bd 3 -padx 1 -pady 2 -font $font \ -text "Mupp" @@ -712,12 +1152,14 @@ test frame-12.2 {FrameWorldChanged procedure} { [winfo x .f.f] == $expx && [winfo y .f.f] == $expy &&\ [winfo width .f.f] == $expw && [winfo height .f.f] == $exph}] } - destroy .f - set result -} {1 1 1 1 1 1 1 1 1 1 1 1} -test frame-12.3 {FrameWorldChanged procedure} { + return $result +} -cleanup { + deleteWindows +} -result {1 1 1 1 1 1 1 1 1 1 1 1} +test frame-12.3 {FrameWorldChanged procedure} -setup { + deleteWindows +} -body { # Check reaction on font change - destroy .f font create myfont -family courier -size 10 labelframe .f -font myfont -text Mupp place .f -x 0 -y 0 -width 40 -height 40 @@ -729,103 +1171,267 @@ test frame-12.3 {FrameWorldChanged procedure} { update set h2 [font metrics myfont -linespace] set y2 [winfo y .f.f] - destroy .f - font delete myfont expr {($h2 - $h1) - ($y2 - $y1)} -} {0} +} -cleanup { + deleteWindows + font delete myfont +} -result {0} + -test frame-13.1 {labelframe configuration options} { +test frame-13.1 {labelframe configuration options} -setup { + deleteWindows +} -body { labelframe .f -class NewFrame - list [.f configure -class] [catch {.f configure -class Different} msg] $msg -} {{-class class Class Labelframe NewFrame} 1 {can't modify -class option after widget is created}} -catch {destroy .f} -test frame-13.2 {labelframe configuration options} { - list [catch {labelframe .f -colormap new} msg] $msg -} {0 .f} -catch {destroy .f} -test frame-13.3 {labelframe configuration options} { - list [catch {labelframe .f -visual default} msg] $msg -} {0 .f} -catch {destroy .f} -test frame-13.4 {labelframe configuration options} { - list [catch {labelframe .f -screen bogus} msg] $msg -} {1 {unknown option "-screen"}} -test frame-13.5 {labelframe configuration options} { - set result [list [catch {labelframe .f -container true} msg] $msg \ - [.f configure -container]] - destroy .f - set result -} {0 .f {-container container Container 0 1}} -test frame-13.6 {labelframe configuration options} { - list [catch {labelframe .f -container bogus} msg] $msg -} {1 {expected boolean value but got "bogus"}} -test frame-13.7 {labelframe configuration options} { + .f configure -class +} -cleanup { + deleteWindows +} -result {-class class Class Labelframe NewFrame} +test frame-13.2 {labelframe configuration options} -setup { + deleteWindows +} -body { + labelframe .f -class NewFrame + .f configure -class Different +} -cleanup { + deleteWindows +} -returnCodes error -result {can't modify -class option after widget is created} +test frame-13.3 {labelframe configuration options} -setup { + deleteWindows +} -body { + labelframe .f -colormap new +} -cleanup { + deleteWindows +} -result {.f} +test frame-13.4 {labelframe configuration options} -setup { + deleteWindows +} -body { + labelframe .f -visual default +} -cleanup { + deleteWindows +} -result {.f} +test frame-13.5 {labelframe configuration options} -setup { + deleteWindows +} -body { + labelframe .f -screen bogus +} -cleanup { + deleteWindows +} -returnCodes error -result {unknown option "-screen"} +test frame-13.6 {labelframe configuration options} -setup { + deleteWindows +} -body { + labelframe .f -container true +} -cleanup { + deleteWindows +} -result {.f} +test frame-13.7 {labelframe configuration options} -setup { + deleteWindows +} -body { + labelframe .f -container true + .f configure -container +} -cleanup { + deleteWindows +} -result {-container container Container 0 1} +test frame-13.8 {labelframe configuration options} -setup { + deleteWindows +} -body { + labelframe .f -container bogus +} -cleanup { + deleteWindows +} -returnCodes error -result {expected boolean value but got "bogus"} +test frame-13.9 {labelframe configuration options} -setup { + deleteWindows +} -body { labelframe .f - set result [list [catch {.f configure -container 1} msg] $msg] - destroy .f - set result -} {1 {can't modify -container option after widget is created}} + .f configure -container 1 +} -cleanup { + deleteWindows +} -returnCodes error -result {can't modify -container option after widget is created} + +destroy .f labelframe .f -set i 8 -foreach test { - {-background #ff0000 #ff0000 non-existent - {unknown color name "non-existent"}} - {-bd 4 4 badValue {bad screen distance "badValue"}} - {-bg #00ff00 #00ff00 non-existent - {unknown color name "non-existent"}} - {-borderwidth 1.3 1 badValue {bad screen distance "badValue"}} - {-cursor arrow arrow badValue {bad cursor spec "badValue"}} - {-fg #0000ff #0000ff non-existent - {unknown color name "non-existent"}} - {-font {courier 8} {courier 8} {} {}} - {-foreground #ff0000 #ff0000 non-existent - {unknown color name "non-existent"}} - {-height 100 100 not_a_number {bad screen distance "not_a_number"}} - {-highlightbackground #112233 #112233 ugly {unknown color name "ugly"}} - {-highlightcolor #123456 #123456 non-existent - {unknown color name "non-existent"}} - {-highlightthickness 6 6 badValue {bad screen distance "badValue"}} - {-labelanchor se se badValue {bad labelanchor "badValue": must be e, en, es, n, ne, nw, s, se, sw, w, wn, or ws}} - {-padx 3 3 badValue {bad screen distance "badValue"}} - {-pady 4 4 badValue {bad screen distance "badValue"}} - {-relief ridge ridge badValue {bad relief "badValue": must be flat, groove, raised, ridge, solid, or sunken}} - {-takefocus "any string" "any string" {} {}} - {-text "any string" "any string" {} {}} - {-width 32 32 badValue {bad screen distance "badValue"}} -} { - lassign $test name goodValue goodResult badValue badResult - test frame-13.$i {labelframe configuration options} { - .f configure $name $goodValue - lindex [.f configure $name] 4 - } $goodResult - incr i - if {$badValue ne ""} { - test frame-13.$i {labelframe configuration options} -body { - .f configure $name $badValue - } -returnCodes error -result $badResult - } - .f configure $name [lindex [.f configure $name] 3] - incr i -} +test frame-13.10 {labelframe configuration options} -body { + .f configure -background #ff0000 + lindex [.f configure -background] 4 +} -cleanup { + .f configure -background [lindex [.f configure -background] 3] +} -result {#ff0000} +test frame-13.11 {labelframe configuration options} -body { + .f configure -background non-existent +} -returnCodes error -result {unknown color name "non-existent"} +test frame-13.12 {labelframe configuration options} -body { + .f configure -bd 4 + lindex [.f configure -bd] 4 +} -cleanup { + .f configure -bd [lindex [.f configure -bd] 3] +} -result {4} +test frame-13.13 {labelframe configuration options} -body { + .f configure -bd badValue +} -returnCodes error -result {bad screen distance "badValue"} +test frame-13.14 {labelframe configuration options} -body { + .f configure -bg #00ff00 + lindex [.f configure -bg] 4 +} -cleanup { + .f configure -bg [lindex [.f configure -bg] 3] +} -result {#00ff00} +test frame-13.15 {labelframe configuration options} -body { + .f configure -bg non-existent +} -returnCodes error -result {unknown color name "non-existent"} +test frame-13.16 {labelframe configuration options} -body { + .f configure -borderwidth 1.3 + lindex [.f configure -borderwidth] 4 +} -cleanup { + .f configure -borderwidth [lindex [.f configure -borderwidth] 3] +} -result {1} +test frame-13.17 {labelframe configuration options} -body { + .f configure -borderwidth badValue +} -returnCodes error -result {bad screen distance "badValue"} +test frame-13.18 {labelframe configuration options} -body { + .f configure -cursor arrow + lindex [.f configure -cursor] 4 +} -cleanup { + .f configure -cursor [lindex [.f configure -cursor] 3] +} -result {arrow} +test frame-13.19 {labelframe configuration options} -body { + .f configure -cursor badValue +} -returnCodes error -result {bad cursor spec "badValue"} +test frame-13.20 {labelframe configuration options} -body { + .f configure -fg #0000ff + lindex [.f configure -fg] 4 +} -cleanup { + .f configure -fg [lindex [.f configure -fg] 3] +} -result {#0000ff} +test frame-13.21 {labelframe configuration options} -body { + .f configure -fg non-existent +} -returnCodes error -result {unknown color name "non-existent"} +test frame-13.22 {labelframe configuration options} -body { + .f configure -font {courier 8} + lindex [.f configure -font] 4 +} -cleanup { + .f configure -font [lindex [.f configure -font] 3] +} -result {courier 8} +test frame-13.23 {labelframe configuration options} -body { + .f configure -foreground #ff0000 + lindex [.f configure -foreground] 4 +} -cleanup { + .f configure -foreground [lindex [.f configure -foreground] 3] +} -result {#ff0000} +test frame-13.24 {labelframe configuration options} -body { + .f configure -foreground non-existent +} -returnCodes error -result {unknown color name "non-existent"} +test frame-13.25 {labelframe configuration options} -body { + .f configure -height 100 + lindex [.f configure -height] 4 +} -cleanup { + .f configure -height [lindex [.f configure -height] 3] +} -result {100} +test frame-13.26 {labelframe configuration options} -body { + .f configure -height not_a_number +} -returnCodes error -result {bad screen distance "not_a_number"} +test frame-13.27 {labelframe configuration options} -body { + .f configure -highlightbackground #112233 + lindex [.f configure -highlightbackground] 4 +} -cleanup { + .f configure -highlightbackground [lindex [.f configure -highlightbackground] 3] +} -result {#112233} +test frame-13.28 {labelframe configuration options} -body { + .f configure -highlightbackground ugly +} -returnCodes error -result {unknown color name "ugly"} +test frame-13.29 {labelframe configuration options} -body { + .f configure -highlightcolor #123456 + lindex [.f configure -highlightcolor] 4 +} -cleanup { + .f configure -highlightcolor [lindex [.f configure -highlightcolor] 3] +} -result {#123456} +test frame-13.30 {labelframe configuration options} -body { + .f configure -highlightcolor non-existent +} -returnCodes error -result {unknown color name "non-existent"} +test frame-13.31 {labelframe configuration options} -body { + .f configure -highlightthickness 6 + lindex [.f configure -highlightthickness] 4 +} -cleanup { + .f configure -highlightthickness [lindex [.f configure -highlightthickness] 3] +} -result {6} +test frame-13.32 {labelframe configuration options} -body { + .f configure -highlightthickness badValue +} -returnCodes error -result {bad screen distance "badValue"} +test frame-13.33 {labelframe configuration options} -body { + .f configure -labelanchor se + lindex [.f configure -labelanchor] 4 +} -cleanup { + .f configure -labelanchor [lindex [.f configure -labelanchor] 3] +} -result {se} +test frame-13.34 {labelframe configuration options} -body { + .f configure -labelanchor badValue +} -returnCodes error -result {bad labelanchor "badValue": must be e, en, es, n, ne, nw, s, se, sw, w, wn, or ws} +test frame-13.35 {labelframe configuration options} -body { + .f configure -padx 3 + lindex [.f configure -padx] 4 +} -cleanup { + .f configure -padx [lindex [.f configure -padx] 3] +} -result {3} +test frame-13.36 {labelframe configuration options} -body { + .f configure -padx badValue +} -returnCodes error -result {bad screen distance "badValue"} +test frame-13.37 {labelframe configuration options} -body { + .f configure -pady 4 + lindex [.f configure -pady] 4 +} -cleanup { + .f configure -pady [lindex [.f configure -pady] 3] +} -result {4} +test frame-13.38 {labelframe configuration options} -body { + .f configure -pady badValue +} -returnCodes error -result {bad screen distance "badValue"} +test frame-13.39 {labelframe configuration options} -body { + .f configure -relief ridge + lindex [.f configure -relief] 4 +} -cleanup { + .f configure -relief [lindex [.f configure -relief] 3] +} -result {ridge} +test frame-13.40 {labelframe configuration options} -body { + .f configure -relief badValue +} -returnCodes error -result {bad relief "badValue": must be flat, groove, raised, ridge, solid, or sunken} +test frame-13.41 {labelframe configuration options} -body { + .f configure -takefocus {any string} + lindex [.f configure -takefocus] 4 +} -cleanup { + .f configure -takefocus [lindex [.f configure -takefocus] 3] +} -result {any string} +test frame-13.42 {labelframe configuration options} -body { + .f configure -text {any string} + lindex [.f configure -text] 4 +} -cleanup { + .f configure -text [lindex [.f configure -text] 3] +} -result {any string} +test frame-13.43 {labelframe configuration options} -body { + .f configure -width 32 + lindex [.f configure -width] 4 +} -cleanup { + .f configure -width [lindex [.f configure -width] 3] +} -result {32} +test frame-13.44 {labelframe configuration options} -body { + .f configure -width badValue +} -returnCodes error -result {bad screen distance "badValue"} destroy .f -test frame-14.1 {labelframe labelwidget option} { + +test frame-14.1 {labelframe labelwidget option} -setup { + deleteWindows +} -body { # Test that label is moved in stacking order - destroy .f .l label .l -text Mupp -font {helvetica 8} labelframe .f -labelwidget .l pack .f frame .f.f -width 50 -height 50 pack .f.f update - set res [list [winfo children .] [winfo width .f] \ - [expr {[winfo height .f] - [winfo height .l]}]] - destroy .f .l - set res -} {{.f .l} 54 52} -test frame-14.2 {labelframe labelwidget option} { + list [winfo children .] [winfo width .f] \ + [expr {[winfo height .f] - [winfo height .l]}] +} -cleanup { + deleteWindows +} -result {{.f .l} 54 52} +test frame-14.2 {labelframe labelwidget option} -setup { + deleteWindows +} -body { # Test the labelframe's reaction if the label is destroyed - destroy .f .l label .l -text Aratherlonglabel labelframe .f -labelwidget .l pack .f @@ -838,12 +1444,13 @@ test frame-14.2 {labelframe labelwidget option} { lappend res [.f cget -labelwidget] update lappend res [expr {[winfo width .f] - [winfo width .f.l]}] - destroy .f - set res -} {.l 12 {} 4} -test frame-14.3 {labelframe labelwidget option} { +} -cleanup { + deleteWindows +} -result {.l 12 {} 4} +test frame-14.3 {labelframe labelwidget option} -setup { + deleteWindows +} -body { # Test the labelframe's reaction if the label is stolen - destroy .f .l label .l -text Aratherlonglabel labelframe .f -labelwidget .l pack .f @@ -856,12 +1463,13 @@ test frame-14.3 {labelframe labelwidget option} { lappend res [.f cget -labelwidget] update lappend res [expr {[winfo width .f] - [winfo width .f.l]}] - destroy .f .l - set res -} {.l 12 {} 4} -test frame-14.4 {labelframe labelwidget option} { +} -cleanup { + deleteWindows +} -result {.l 12 {} 4} +test frame-14.4 {labelframe labelwidget option} -setup { + deleteWindows +} -body { # Test the label's reaction if the labelframe is destroyed - destroy .f .l label .l -text Mupp labelframe .f -labelwidget .l pack .f @@ -869,12 +1477,13 @@ test frame-14.4 {labelframe labelwidget option} { set res [list [winfo manager .l]] destroy .f lappend res [winfo manager .l] - destroy .l - set res -} {labelframe {}} -test frame-14.5 {labelframe labelwidget option} { +} -cleanup { + deleteWindows +} -result {labelframe {}} +test frame-14.5 {labelframe labelwidget option} -setup { + deleteWindows +} -body { # Test that the labelframe reacts on changes in label - destroy .f .l label .l -text Aratherlonglabel labelframe .f -labelwidget .l pack .f @@ -891,24 +1500,25 @@ test frame-14.5 {labelframe labelwidget option} { update lappend res [expr {[winfo width .f] - [winfo width .l]}] lappend res [expr {[winfo width .f] > $first}] - destroy .f .l - set res -} {12 12 1 12 1} -test frame-14.6 {labelframe labelwidget option} { +} -cleanup { + deleteWindows +} -result {12 12 1 12 1} +test frame-14.6 {labelframe labelwidget option} -setup { + deleteWindows +} -body { # Destroying a labelframe with a child label caused a crash # when not handling mapping of the label correctly. # This test does not test anything directly, it's just ment # to catch if the same mistake is made again. - destroy .f labelframe .f pack .f label .f.l -text Mupp .f configure -labelwidget .f.l update - destroy .f -} {} - -catch {destroy .f} +} -cleanup { + deleteWindows +} -result {} +deleteWindows rename eatColors {} rename colorsFree {} @@ -916,3 +1526,6 @@ rename colorsFree {} cleanupTests return + + + diff --git a/tests/image.test b/tests/image.test index b6f9ec7..5f2466d 100644 --- a/tests/image.test +++ b/tests/image.test @@ -7,40 +7,57 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: image.test,v 1.15 2008/07/23 23:24:25 nijtmans Exp $ +# RCS: @(#) $Id: image.test,v 1.16 2008/08/15 01:10:03 aniap Exp $ -package require tcltest 2.1 +package require tcltest 2.2 +namespace import ::tcltest::* eval tcltest::configure $argv tcltest::loadTestedCommands -namespace import -force ::tk::test::loadTkCommand eval image delete [image names] +# Canvas used in some tests in the whole file canvas .c -highlightthickness 2 pack .c update -test image-1.1 {Tk_ImageCmd procedure, "create" option} { - list [catch image msg] $msg -} {1 {wrong # args: should be "image option ?args?"}} -test image-1.2 {Tk_ImageCmd procedure, "create" option} { - list [catch {image gorp} msg] $msg -} {1 {bad option "gorp": must be create, delete, height, inuse, names, type, types, or width}} -test image-1.3 {Tk_ImageCmd procedure, "create" option} { - list [catch {image create} msg] $msg -} {1 {wrong # args: should be "image create type ?name? ?-option value ...?"}} -test image-1.4 {Tk_ImageCmd procedure, "create" option} { - list [catch {image c bad_type} msg] $msg -} {1 {image type "bad_type" doesn't exist}} -test image-1.5 {Tk_ImageCmd procedure, "create" option} testImageType { + + +test image-1.1 {Tk_ImageCmd procedure, "create" option} -body { + image +} -returnCodes error -result {wrong # args: should be "image option ?args?"} +test image-1.2 {Tk_ImageCmd procedure, "create" option} -body { + image gorp +} -returnCodes error -result {bad option "gorp": must be create, delete, height, inuse, names, type, types, or width} +test image-1.3 {Tk_ImageCmd procedure, "create" option} -body { + image create +} -returnCodes error -result {wrong # args: should be "image create type ?name? ?-option value ...?"} +test image-1.4 {Tk_ImageCmd procedure, "create" option} -body { + image c bad_type +} -returnCodes error -result {image type "bad_type" doesn't exist} +test image-1.5 {Tk_ImageCmd procedure, "create" option} -constraints { + testImageType +} -body { list [image create test myimage] [image names] -} {myimage myimage} -test image-1.6 {Tk_ImageCmd procedure, "create" option} testImageType { +} -cleanup { + eval image delete [image names] +} -result {myimage myimage} +test image-1.6 {Tk_ImageCmd procedure, "create" option} -constraints { + testImageType +} -setup { + eval image delete [image names] +} -body { scan [image create test] image%d first image create test myimage scan [image create test -variable x] image%d second expr $second-$first -} {1} -test image-1.7 {Tk_ImageCmd procedure, "create" option} testImageType { - image delete myimage +} -cleanup { + eval image delete [image names] +} -result {1} + +test image-1.7 {Tk_ImageCmd procedure, "create" option} -constraints { + testImageType +} -setup { + eval image delete [image names] +} -body { image create test myimage -variable x .c create image 100 50 -image myimage .c create image 100 150 -image myimage @@ -48,10 +65,16 @@ test image-1.7 {Tk_ImageCmd procedure, "create" option} testImageType { set x {} image create test myimage -variable x update - set x -} {{myimage free} {myimage free} {myimage delete} {myimage get} {myimage get} {myimage display 0 0 30 15 30 30} {myimage display 0 0 30 15 30 130}} -test image-1.8 {Tk_ImageCmd procedure, "create" option} testImageType { - .c delete all + return $x +} -cleanup { + eval image delete [image names] +} -result {{myimage free} {myimage free} {myimage delete} {myimage get} {myimage get} {myimage display 0 0 30 15 30 30} {myimage display 0 0 30 15 30 130}} +test image-1.8 {Tk_ImageCmd procedure, "create" option} -constraints { + testImageType +} -setup { + .c delete all + eval image delete [image names] +} -body { image create test myimage -variable x .c create image 100 50 -image myimage .c create image 100 150 -image myimage @@ -60,185 +83,279 @@ test image-1.8 {Tk_ImageCmd procedure, "create" option} testImageType { set x {} image create test myimage -variable x update - set x -} {{myimage get} {myimage get} {myimage display 0 0 30 15 30 30} {myimage display 0 0 30 15 30 130}} -test image-1.9 {Tk_ImageCmd procedure, "create" option} testImageType { + return $x +} -cleanup { .c delete all - eval image delete [image names] - list [catch {image create test -badName foo} msg] $msg [image names] -} {1 {bad option name "-badName"} {}} -test image-1.10 {Tk_ImageCmd procedure, "create" option with same name as main window} { + eval image delete [image names] +} -result {{myimage get} {myimage get} {myimage display 0 0 30 15 30 30} {myimage display 0 0 30 15 30 130}} +test image-1.9 {Tk_ImageCmd procedure, "create" option} -constraints { + testImageType +} -body { + image create test -badName foo +} -returnCodes error -result {bad option name "-badName"} +test image-1.10 {Tk_ImageCmd procedure, "create" option} -constraints { + testImageType +} -body { + catch {image create test -badName foo} + image names +} -result {} +test image-1.11 {Tk_ImageCmd procedure, "create" option with same name as main window} -body { set code [loadTkCommand] append code { - update - puts [list [catch {image create photo .} msg] $msg] - exit + update + puts [list [catch {image create photo .} msg] $msg] + exit } set script [makeFile $code script] - set x [list [catch {exec [interpreter] <$script} msg] $msg] + exec [interpreter] <$script +} -cleanup { removeFile script - set x -} {0 {1 {images may not be named the same as the main window}}} -test image-1.11 {Tk_ImageCmd procedure, "create" option with same name as main window after renaming} { +} -result {1 {images may not be named the same as the main window}} +test image-1.12 {Tk_ImageCmd procedure, "create" option with same name as main window after renaming} -body { set code [loadTkCommand] append code { - update - puts [list [catch {rename . foo;image create photo foo} msg] $msg] - exit + update + puts [list [catch {rename . foo;image create photo foo} msg] $msg] + exit } set script [makeFile $code script] - set x [list [catch {exec [interpreter] <$script} msg] $msg] + exec [interpreter] <$script +} -cleanup { removeFile script - set x -} {0 {1 {images may not be named the same as the main window}}} -test image-1.12 {Tk_ImageCmd, "create" option: do not generated command name in use} -setup { +} -result {1 {images may not be named the same as the main window}} +test image-1.13 {Tk_ImageCmd, "create" option: do not generated command name in use} -setup { + .c delete all + eval image delete [image names] +} -body { set i [image create bitmap] regexp {^image(\d+)$} $i -> serial incr serial proc image$serial {} {return works} set j [image create bitmap] -} -body { + image$serial } -cleanup { rename image$serial {} image delete $i $j } -result works -test image-2.1 {Tk_ImageCmd procedure, "delete" option} { - list [catch {image delete} msg] $msg -} {0 {}} -test image-2.2 {Tk_ImageCmd procedure, "delete" option} testImageType { - .c delete all - eval image delete [image names] +test image-2.1 {Tk_ImageCmd procedure, "delete" option} -body { + image delete +} -result {} +test image-2.2 {Tk_ImageCmd procedure, "delete" option} -constraints { + testImageType +} -setup { + eval image delete [image names] + set result {} +} -body { image create test myimage image create test img2 - set result {} lappend result [lsort [image names]] image d myimage img2 lappend result [image names] -} {{img2 myimage} {}} -test image-2.3 {Tk_ImageCmd procedure, "delete" option} testImageType { - .c delete all - eval image delete [image names] +} -cleanup { + eval image delete [image names] +} -result {{img2 myimage} {}} +test image-2.3 {Tk_ImageCmd procedure, "delete" option} -constraints { + testImageType +} -setup { + eval image delete [image names] +} -body { image create test myimage image create test img2 - list [catch {image delete myimage gorp img2} msg] $msg [image names] -} {1 {image "gorp" doesn't exist} img2} - -test image-3.1 {Tk_ImageCmd procedure, "height" option} { - list [catch {image height} msg] $msg -} {1 {wrong # args: should be "image height name"}} -test image-3.2 {Tk_ImageCmd procedure, "height" option} { - list [catch {image height a b} msg] $msg -} {1 {wrong # args: should be "image height name"}} -test image-3.3 {Tk_ImageCmd procedure, "height" option} { - list [catch {image height foo} msg] $msg -} {1 {image "foo" doesn't exist}} -test image-3.4 {Tk_ImageCmd procedure, "height" option} testImageType { + image delete myimage gorp img2 +} -cleanup { + eval image delete [image names] +} -returnCodes error -result {image "gorp" doesn't exist} +test image-2.4 {Tk_ImageCmd procedure, "delete" option} -constraints { + testImageType +} -setup { + eval image delete [image names] +} -body { + image create test myimage + image create test img2 + catch {image delete myimage gorp img2} + image names +} -cleanup { + eval image delete [image names] +} -result {img2} + + +test image-3.1 {Tk_ImageCmd procedure, "height" option} -body { + image height +} -returnCodes error -result {wrong # args: should be "image height name"} +test image-3.2 {Tk_ImageCmd procedure, "height" option} -body { + image height a b +} -returnCodes error -result {wrong # args: should be "image height name"} +test image-3.3 {Tk_ImageCmd procedure, "height" option} -body { + image height foo +} -returnCodes error -result {image "foo" doesn't exist} +test image-3.4 {Tk_ImageCmd procedure, "height" option} -constraints { + testImageType +} -setup { + eval image delete [image names] +} -body { image create test myimage set x [image h myimage] myimage changed 0 0 0 0 60 50 list $x [image height myimage] -} {15 50} +} -cleanup { + eval image delete [image names] +} -result {15 50} -test image-4.1 {Tk_ImageCmd procedure, "names" option} { - list [catch {image names x} msg] $msg -} {1 {wrong # args: should be "image names"}} -test image-4.2 {Tk_ImageCmd procedure, "names" option} testImageType { - .c delete all - eval image delete [image names] + +test image-4.1 {Tk_ImageCmd procedure, "names" option} -body { + image names x +} -returnCodes error -result {wrong # args: should be "image names"} +test image-4.2 {Tk_ImageCmd procedure, "names" option} -constraints { + testImageType +} -setup { + eval image delete [image names] +} -body { image create test myimage image create test img2 image create test 24613 lsort [image names] -} {24613 img2 myimage} -test image-4.3 {Tk_ImageCmd procedure, "names" option} { - .c delete all - eval image delete [image names] +} -cleanup { + eval image delete [image names] +} -result {24613 img2 myimage} +test image-4.3 {Tk_ImageCmd procedure, "names" option} -setup { + eval image delete [image names] +} -body { + eval image delete [image names] [image names] lsort [image names] -} {} - -test image-5.1 {Tk_ImageCmd procedure, "type" option} { - list [catch {image type} msg] $msg -} {1 {wrong # args: should be "image type name"}} -test image-5.2 {Tk_ImageCmd procedure, "type" option} { - list [catch {image type a b} msg] $msg -} {1 {wrong # args: should be "image type name"}} -test image-5.3 {Tk_ImageCmd procedure, "type" option} { - list [catch {image type foo} msg] $msg -} {1 {image "foo" doesn't exist}} -test image-5.4 {Tk_ImageCmd procedure, "type" option} testImageType { +} -cleanup { + eval image delete [image names] +} -result {} + + +test image-5.1 {Tk_ImageCmd procedure, "type" option} -body { + image type +} -returnCodes error -result {wrong # args: should be "image type name"} +test image-5.2 {Tk_ImageCmd procedure, "type" option} -body { + image type a b +} -returnCodes error -result {wrong # args: should be "image type name"} +test image-5.3 {Tk_ImageCmd procedure, "type" option} -body { + image type foo +} -returnCodes error -result {image "foo" doesn't exist} + +test image-5.4 {Tk_ImageCmd procedure, "type" option} -constraints { + testImageType +} -setup { + eval image delete [image names] +} -body { image create test myimage image type myimage -} {test} -test image-5.5 {Tk_ImageCmd procedure, "type" option} testImageType { +} -cleanup { + eval image delete [image names] +} -result {test} +test image-5.5 {Tk_ImageCmd procedure, "type" option} -constraints { + testImageType +} -setup { + eval image delete [image names] +} -body { image create test myimage .c create image 50 50 -image myimage image delete myimage - list [catch {image type myimage} msg] $msg -} {1 {image "myimage" doesn't exist}} -test image-5.6 {Tk_ImageCmd procedure, "type" option} testOldImageType { + image type myimage +} -cleanup { + eval image delete [image names] +} -returnCodes error -result {image "myimage" doesn't exist} +test image-5.6 {Tk_ImageCmd procedure, "type" option} -constraints { + testOldImageType +} -setup { + eval image delete [image names] +} -body { image create oldtest myimage image type myimage -} {oldtest} -test image-5.7 {Tk_ImageCmd procedure, "type" option} testOldImageType { +} -cleanup { + eval image delete [image names] +} -result {oldtest} +test image-5.7 {Tk_ImageCmd procedure, "type" option} -constraints { + testOldImageType +} -setup { + .c delete all + eval image delete [image names] +} -body { image create oldtest myimage .c create image 50 50 -image myimage image delete myimage - list [catch {image type myimage} msg] $msg -} {1 {image "myimage" doesn't exist}} + image type myimage +} -cleanup { + .c delete all + eval image delete [image names] +} -returnCodes error -result {image "myimage" doesn't exist} + -test image-6.1 {Tk_ImageCmd procedure, "types" option} { - list [catch {image types x} msg] $msg -} {1 {wrong # args: should be "image types"}} -test image-6.2 {Tk_ImageCmd procedure, "types" option} testImageType { +test image-6.1 {Tk_ImageCmd procedure, "types" option} -body { + image types x +} -returnCodes error -result {wrong # args: should be "image types"} +test image-6.2 {Tk_ImageCmd procedure, "types" option} -constraints { + testImageType +} -body { lsort [image types] -} {bitmap oldtest photo test} - -test image-7.1 {Tk_ImageCmd procedure, "width" option} { - list [catch {image width} msg] $msg -} {1 {wrong # args: should be "image width name"}} -test image-7.2 {Tk_ImageCmd procedure, "width" option} { - list [catch {image width a b} msg] $msg -} {1 {wrong # args: should be "image width name"}} -test image-7.3 {Tk_ImageCmd procedure, "width" option} { - list [catch {image width foo} msg] $msg -} {1 {image "foo" doesn't exist}} -test image-7.4 {Tk_ImageCmd procedure, "width" option} testImageType { +} -result {bitmap oldtest photo test} + + +test image-7.1 {Tk_ImageCmd procedure, "width" option} -body { + image width +} -returnCodes error -result {wrong # args: should be "image width name"} +test image-7.2 {Tk_ImageCmd procedure, "width" option} -body { + image width a b +} -returnCodes error -result {wrong # args: should be "image width name"} +test image-7.3 {Tk_ImageCmd procedure, "width" option} -body { + image width foo +} -returnCodes error -result {image "foo" doesn't exist} +test image-7.4 {Tk_ImageCmd procedure, "width" option} -constraints { + testImageType +} -setup { + eval image delete [image names] +} -body { image create test myimage set x [image w myimage] myimage changed 0 0 0 0 60 50 list $x [image width myimage] -} {30 60} +} -cleanup { + eval image delete [image names] +} -result {30 60} -test image-8.1 {Tk_ImageCmd procedure, "inuse" option} testImageType { - catch {image delete myimage2} - image create test myimage2 + +test image-8.1 {Tk_ImageCmd procedure, "inuse" option} -constraints { + testImageType +} -setup { + eval image delete [image names] set res {} + destroy .b +} -body { + image create test myimage2 lappend res [image inuse myimage2] - catch {destroy .b} button .b -image myimage2 lappend res [image inuse myimage2] +} -cleanup { + eval image delete [image names] catch {destroy .b} - image delete myimage2 - set res -} [list 0 1] +} -result [list 0 1] -test image-9.1 {Tk_ImageChanged procedure} testImageType { - .c delete all - eval image delete [image names] +test image-9.1 {Tk_ImageChanged procedure} -constraints testImageType -setup { + .c delete all + eval image delete [image names] +} -body { image create test foo -variable x .c create image 50 50 -image foo update set x {} foo changed 5 6 7 8 30 15 update - set x -} {{foo display 5 6 7 8 30 30}} -test image-9.2 {Tk_ImageChanged procedure} testImageType { + return $x +} -cleanup { .c delete all - eval image delete [image names] + eval image delete [image names] +} -result {{foo display 5 6 7 8 30 30}} +test image-9.2 {Tk_ImageChanged procedure} -constraints testImageType -setup { + .c delete all + eval image delete [image names] +} -body { image create test foo -variable x .c create image 50 50 -image foo .c create image 90 100 -image foo @@ -246,25 +363,38 @@ test image-9.2 {Tk_ImageChanged procedure} testImageType { set x {} foo changed 5 6 7 8 30 15 update - set x -} {{foo display 5 6 25 9 30 30} {foo display 0 0 12 14 65 74}} + return $x +} -cleanup { + .c delete all + eval image delete [image names] +} -result {{foo display 5 6 25 9 30 30} {foo display 0 0 12 14 65 74}} -test image-10.1 {Tk_GetImage procedure} { - list [catch {.c create image 100 10 -image bad_name} msg] $msg -} {1 {image "bad_name" doesn't exist}} -test image-10.2 {Tk_GetImage procedure} testImageType { + +test image-10.1 {Tk_GetImage procedure} -setup { + eval image delete [image names] +} -body { + .c create image 100 10 -image bad_name +} -cleanup { + eval image delete [image names] +} -returnCodes error -result {image "bad_name" doesn't exist} +test image-10.2 {Tk_GetImage procedure} -constraints testImageType -setup { + destroy .l + eval image delete [image names] +} -body { image create test mytest - catch {destroy .l} label .l -image mytest image delete mytest - set result [list [catch {label .l2 -image mytest} msg] $msg] + label .l2 -image mytest +} -cleanup { destroy .l - set result -} {1 {image "mytest" doesn't exist}} + eval image delete [image names] +} -returnCodes error -result {image "mytest" doesn't exist} -test image-11.1 {Tk_FreeImage procedure} testImageType { - .c delete all - eval image delete [image names] + +test image-11.1 {Tk_FreeImage procedure} -constraints testImageType -setup { + .c delete all + eval image delete [image names] +} -body { image create test foo -variable x .c create image 50 50 -image foo -tags i1 .c create image 90 100 -image foo -tags i2 @@ -275,10 +405,14 @@ test image-11.1 {Tk_FreeImage procedure} testImageType { pack .c update list [image names] $x -} {foo {{foo free} {foo display 0 0 30 15 103 121}}} -test image-11.2 {Tk_FreeImage procedure} testImageType { +} -cleanup { .c delete all - eval image delete [image names] + eval image delete [image names] +} -result {foo {{foo free} {foo display 0 0 30 15 103 121}}} +test image-11.2 {Tk_FreeImage procedure} -constraints testImageType -setup { + .c delete all + eval image delete [image names] +} -body { image create test foo -variable x .c create image 50 50 -image foo -tags i1 set names [image names] @@ -291,137 +425,179 @@ test image-11.2 {Tk_FreeImage procedure} testImageType { pack .c update list $names $names2 [image names] $x -} {foo {} {} {}} +} -cleanup { + .c delete all + eval image delete [image names] +} -result {foo {} {} {}} -# Non-portable, apparently due to differences in rounding: -test image-12.1 {Tk_RedrawImage procedure, redisplay area clipping} \ - {testImageType nonPortable} { - .c delete all - eval image delete [image names] +# Non-portable, apparently due to differences in rounding: +test image-12.1 {Tk_RedrawImage procedure, redisplay area clipping} -constraints { + testImageType nonPortable +} -setup { + eval image delete [image names] +} -body { image create test foo -variable x .c create image 50 60 -image foo -tags i1 -anchor nw update .c create rectangle 30 40 55 65 -width 0 -fill black -outline {} set x {} update - set x -} {{foo display 0 0 5 5 50 50}} -test image-12.2 {Tk_RedrawImage procedure, redisplay area clipping} \ - {testImageType nonPortable} { - .c delete all - eval image delete [image names] + return $x +} -cleanup { + eval image delete [image names] +} -result {{foo display 0 0 5 5 50 50}} +test image-12.2 {Tk_RedrawImage procedure, redisplay area clipping} -constraints { + testImageType nonPortable +} -setup { + eval image delete [image names] +} -body { image create test foo -variable x .c create image 50 60 -image foo -tags i1 -anchor nw update .c create rectangle 60 40 100 65 -width 0 -fill black -outline {} set x {} update - set x -} {{foo display 10 0 20 5 30 50}} -test image-12.3 {Tk_RedrawImage procedure, redisplay area clipping} \ - {testImageType nonPortable} { - .c delete all - eval image delete [image names] + return $x +} -cleanup { + eval image delete [image names] +} -result {{foo display 10 0 20 5 30 50}} +test image-12.3 {Tk_RedrawImage procedure, redisplay area clipping} -constraints { + testImageType nonPortable +} -setup { + eval image delete [image names] +} -body { image create test foo -variable x .c create image 50 60 -image foo -tags i1 -anchor nw update .c create rectangle 60 70 100 200 -width 0 -fill black -outline {} set x {} update - set x -} {{foo display 10 10 20 5 30 30}} -test image-12.4 {Tk_RedrawImage procedure, redisplay area clipping} \ - {testImageType nonPortable} { - .c delete all - eval image delete [image names] + return $x +} -cleanup { + eval image delete [image names] +} -result {{foo display 10 10 20 5 30 30}} +test image-12.4 {Tk_RedrawImage procedure, redisplay area clipping} -constraints { + testImageType nonPortable +} -setup { + eval image delete [image names] +} -body { image create test foo -variable x .c create image 50 60 -image foo -tags i1 -anchor nw update .c create rectangle 30 70 55 200 -width 0 -fill black -outline {} set x {} update - set x -} {{foo display 0 10 5 5 50 30}} -test image-12.5 {Tk_RedrawImage procedure, redisplay area clipping} \ - {testImageType nonPortable} { - .c delete all - eval image delete [image names] + return $x +} -cleanup { + eval image delete [image names] +} -result {{foo display 0 10 5 5 50 30}} +test image-12.5 {Tk_RedrawImage procedure, redisplay area clipping} -constraints { + testImageType nonPortable +} -setup { + eval image delete [image names] +} -body { image create test foo -variable x .c create image 50 60 -image foo -tags i1 -anchor nw update .c create rectangle 10 20 120 130 -width 0 -fill black -outline {} set x {} update - set x -} {{foo display 0 0 30 15 70 70}} -test image-12.6 {Tk_RedrawImage procedure, redisplay area clipping} \ - {testImageType nonPortable} { - .c delete all - eval image delete [image names] + return $x +} -cleanup { + eval image delete [image names] +} -result {{foo display 0 0 30 15 70 70}} +test image-12.6 {Tk_RedrawImage procedure, redisplay area clipping} -constraints { + testImageType nonPortable +} -setup { + eval image delete [image names] +} -body { image create test foo -variable x .c create image 50 60 -image foo -tags i1 -anchor nw update .c create rectangle 55 65 75 70 -width 0 -fill black -outline {} set x {} update - set x -} {{foo display 5 5 20 5 30 30}} + return $x +} -cleanup { + eval image delete [image names] +} -result {{foo display 5 5 20 5 30 30}} -test image-13.1 {Tk_SizeOfImage procedure} testImageType { - eval image delete [image names] + +test image-13.1 {Tk_SizeOfImage procedure} -constraints testImageType -setup { + eval image delete [image names] +} -body { image create test foo -variable x set result [list [image width foo] [image height foo]] foo changed 0 0 0 0 85 60 lappend result [image width foo] [image height foo] -} {30 15 85 60} +} -cleanup { + eval image delete [image names] +} -result {30 15 85 60} -test image-13.2 {DeleteImage procedure} testImageType { - .c delete all - eval image delete [image names] +test image-13.2 {DeleteImage procedure} -constraints testImageType -setup { + .c delete all + eval image delete [image names] +} -body { + eval image delete [image names] [image names] image create test foo -variable x .c create image 50 50 -image foo -tags i1 .c create image 90 100 -image foo -tags i2 set x {} image delete foo lappend x | [image names] | [catch {image delete foo} msg] | $msg | [image names] | -} {{foo free} {foo free} {foo delete} | {} | 1 | {image "foo" doesn't exist} | {} |} +} -cleanup { + eval image delete [image names] +} -result {{foo free} {foo free} {foo delete} | {} | 1 | {image "foo" doesn't exist} | {} |} -test image-13.3 {Tk_SizeOfImage procedure} testOldImageType { - eval image delete [image names] +test image-13.3 {Tk_SizeOfImage procedure} -constraints testOldImageType -setup { + eval image delete [image names] +} -body { + eval image delete [image names] [image names] image create oldtest foo -variable x set result [list [image width foo] [image height foo]] foo changed 0 0 0 0 85 60 lappend result [image width foo] [image height foo] -} {30 15 85 60} +} -cleanup { + eval image delete [image names] +} -result {30 15 85 60} -test image-13.4 {DeleteImage procedure} testOldImageType { +test image-13.4 {DeleteImage procedure} -constraints testOldImageType -setup { + .c delete all + eval image delete [image names] +} -body { .c delete all - eval image delete [image names] + eval image delete [image names] [image names] image create oldtest foo -variable x .c create image 50 50 -image foo -tags i1 .c create image 90 100 -image foo -tags i2 set x {} image delete foo lappend x | [image names] | [catch {image delete foo} msg] | $msg | [image names] | -} {{foo free} {foo free} {foo delete} | {} | 1 | {image "foo" doesn't exist} | {} |} - +} -cleanup { + .c delete all + eval image delete [image names] +} -result {{foo free} {foo free} {foo delete} | {} | 1 | {image "foo" doesn't exist} | {} |} -catch {image delete hidden} -set l [image names] -set h [interp hidden] -test image-14.1 {image command vs hidden commands} { +test image-14.1 {image command vs hidden commands} -body { catch {image delete hidden} + set l [image names] + set h [interp hidden] image create photo hidden interp hide {} hidden image delete hidden - list [image names] [interp hidden] -} [list $l $h] + set res1 [list [image names] [interp hidden]] + set res2 [list $l $h] + expr {$res1 eq $res2} +} -result 1 + eval image delete [image names] -test image-15.1 {deleting image does not make widgets forget about it} { - .c delete all +test image-15.1 {deleting image does not make widgets forget about it} -setup { + .c delete all + eval image delete [image names] +} -body { image create photo foo -width 10 -height 10 .c create image 10 10 -image foo -tags i1 -anchor nw update @@ -431,7 +607,10 @@ test image-15.1 {deleting image does not make widgets forget about it} { lappend x [image names] image create photo foo -width 20 -height 20 lappend x [.c bbox i1] [image names] -} {10 10 20 20 foo {} {10 10 30 30} foo} +} -cleanup { + .c delete all + eval image delete [image names] +} -result {10 10 20 20 foo {} {10 10 30 30} foo} destroy .c eval image delete [image names] @@ -439,3 +618,6 @@ eval image delete [image names] # cleanup cleanupTests return + + + |