diff options
83 files changed, 3498 insertions, 2904 deletions
@@ -28,7 +28,15 @@ to the userbase. - [Tk_Get3DBorderColors broken by design](https://core.tcl-lang.org/tk/tktview/517165) - [MS-Win: Incorrect system menu entries for transient toplevels](https://core.tcl-lang.org/tk/tktview/159aa5) - [MS-Win: Withdrawn Tk transient windows can reappear in Windows taskbar preview](https://core.tcl-lang.org/tk/tktview/91d0e9) - - [Aqua windows don't always move focus correctly](https://core.tcl-lang.org/tkview/28d33f) + - [Aqua windows don't always move focus correctly](https://core.tcl-lang.org/tk/tktview/28d33f) + - [Cross compiling using x86_64-w64-mingw32-gcc](https://core.tcl-lang.org/tk/tktview/f6d40f) + - [BWidget Drag & Drop no longer works on Aqua](https://core.tcl-lang.org/tk/tktview/855ec4) + - [tk print command fails with canvas widget](https://core.tcl-lang.org/tk/tktview/d2eac2) + - [tk print command fails on windows](https://core.tcl-lang.org/tk/tktview/bb5c3d) + - [tk print fails for canvas items with non integer widths](https://core.tcl-lang.org/tk/tktview/7716cb) + - [tk print canvas with smooth lines crashes on windows](https://core.tcl-lang.org/tk/tktview/9b23b6) + - [Collect utility procs for the Tk test suite](https://core.tcl-lang.org/tk/tktview/718cbc) + - [Setting ttk state may change the a variable passed by value](https://core.tcl-lang.org/tk/info/7231bf) Release Tk 9.0.1 arises from the check-in with tag `core-9-0-1`. diff --git a/doc/colors.n b/doc/colors.n index 1150956..329626e 100644 --- a/doc/colors.n +++ b/doc/colors.n @@ -27,7 +27,7 @@ AntiqueWhite1 255 239 219 AntiqueWhite2 238 223 204 AntiqueWhite3 205 192 176 AntiqueWhite4 139 131 120 -agua 0 255 255 +aqua 0 255 255 aquamarine 127 255 212 aquamarine1 127 255 212 aquamarine2 118 238 198 @@ -92,7 +92,7 @@ cornsilk1 255 248 220 cornsilk2 238 232 205 cornsilk3 205 200 177 cornsilk4 139 136 120 -crymson 220 20 60 +crimson 220 20 60 cyan 0 255 255 cyan1 0 255 255 cyan2 0 238 238 diff --git a/generic/ttk/ttkState.c b/generic/ttk/ttkState.c index d06795c..48ca322 100644 --- a/generic/ttk/ttkState.c +++ b/generic/ttk/ttkState.c @@ -110,10 +110,13 @@ static int StateSpecSetFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr) } } - /* Invalidate old intrep: + /* Invalidate old intrep, but make sure there's a string rep, see [7231bf9941]. */ - if (objPtr->typePtr && objPtr->typePtr->freeIntRepProc) { - objPtr->typePtr->freeIntRepProc(objPtr); + if (objPtr->typePtr) { + (void)Tcl_GetString(objPtr); + if (objPtr->typePtr->freeIntRepProc) { + objPtr->typePtr->freeIntRepProc(objPtr); + } } objPtr->typePtr = &StateSpecObjType.objType; diff --git a/library/fontchooser.tcl b/library/fontchooser.tcl index c53d1d6..8fcf0e0 100644 --- a/library/fontchooser.tcl +++ b/library/fontchooser.tcl @@ -172,7 +172,7 @@ proc ::tk::fontchooser::Create {} { if {![winfo exists $S(W)]} { toplevel $S(W) -class TkFontDialog if {[package provide tcltest] ne {}} { - set ::tk_dialog $S(W) + set ::tk::test::dialog::testDialog $S(W) } wm withdraw $S(W) wm title $S(W) $S(-title) diff --git a/library/print.tcl b/library/print.tcl index 76cf16f..504b975 100644 --- a/library/print.tcl +++ b/library/print.tcl @@ -76,19 +76,19 @@ namespace eval ::tk::print { #Next, set values. Some are taken from the printer, #some are sane defaults. - if {[info exists printer_name] && $printer_name ne ""} { - set printargs(hDC) $printer_name - set printargs(pw) $paper_width - set printargs(pl) $paper_height - set printargs(lm) 1000 - set printargs(tm) 1000 - set printargs(rm) 1000 - set printargs(bm) 1000 - set printargs(resx) $dpi_x - set printargs(resy) $dpi_y - set printargs(copies) $copies - set printargs(resolution) [list $dpi_x $dpi_y] - } + if {[info exists printer_name] && $printer_name ne ""} { + set printargs(hDC) $printer_name + set printargs(pw) $paper_width + set printargs(pl) $paper_height + set printargs(lm) 1000 + set printargs(tm) 1000 + set printargs(rm) 1000 + set printargs(bm) 1000 + set printargs(resx) $dpi_x + set printargs(resy) $dpi_y + set printargs(copies) $copies + set printargs(resolution) [list $dpi_x $dpi_y] + } } # _print_data @@ -279,8 +279,8 @@ namespace eval ::tk::print { set sc [$wid cget -scrollregion] # if there is no scrollregion, use width and height. if {$sc eq ""} { - set window_x [$wid cget -width] - set window_y [$wid cget -height] + set window_x [winfo pixels $wid [$wid cget -width]] + set window_y [winfo pixels $wid [$wid cget -height]] } else { set window_x [lindex $sc 2] set window_y [lindex $sc 3] diff --git a/macosx/tkMacOSXWindowEvent.c b/macosx/tkMacOSXWindowEvent.c index 8d57d83..368822e 100644 --- a/macosx/tkMacOSXWindowEvent.c +++ b/macosx/tkMacOSXWindowEvent.c @@ -116,6 +116,18 @@ extern NSString *NSWindowDidOrderOffScreenNotification; GenerateActivateEvents(winPtr, true); } } + /* + * Make sure that the updated keyWindow is associated with the + * current TkEventTarget. + */ + + NSWindow *keyWin = [NSApp keyWindow]; + if (keyWin) { + TkWindow *keyWinPtr = TkMacOSXGetTkWindow(keyWin); + if (keyWinPtr) { + [NSApp setTkEventTarget:keyWinPtr]; + } + } } - (void) windowBoundsChanged: (NSNotification *) notification @@ -245,9 +257,15 @@ extern NSString *NSWindowDidOrderOffScreenNotification; #endif NSWindow *w = [notification object]; TkWindow *winPtr = TkMacOSXGetTkWindow(w); - - if (winPtr && winPtr->wmInfoPtr->hints.initial_state != IconicState) { - winPtr->wmInfoPtr->hints.initial_state = IconicState; + NSString *name = [notification name]; + if (!winPtr) { + return; + } + if ([name isEqualToString:NSWindowWillMiniaturizeNotification]) { + if (winPtr && winPtr->wmInfoPtr->hints.initial_state != IconicState) { + winPtr->wmInfoPtr->hints.initial_state = IconicState; + } + } else { TkWmUnmapWindow(winPtr); } } @@ -344,6 +362,7 @@ extern NSString *NSWindowDidOrderOffScreenNotification; observe(NSWindowDidResizeNotification, windowBoundsChanged:); observe(NSWindowDidDeminiaturizeNotification, windowExpanded:); observe(NSWindowDidMiniaturizeNotification, windowCollapsed:); + observe(NSWindowWillMiniaturizeNotification, windowCollapsed:); observe(NSWindowWillOrderOnScreenNotification, windowMapped:); observe(NSWindowDidOrderOnScreenNotification, windowBecameVisible:); observe(NSWindowWillStartLiveResizeNotification, windowLiveResize:); @@ -376,10 +395,12 @@ static void RefocusGrabWindow(void *data) { - (void) applicationActivate: (NSNotification *) notification { - (void)notification; + NSWindow *iconifiedWindow = nil; #ifdef TK_MAC_DEBUG_NOTIFICATIONS TKLog(@"-[%@(%p) %s] %@", [self class], self, sel_getName(_cmd), notification); +#else + (void) notification; #endif [NSApp tkCheckPasteboard]; @@ -403,10 +424,17 @@ static void RefocusGrabWindow(void *data) { } if (winPtr->dispPtr->grabWinPtr == winPtr) { Tcl_DoWhenIdle(RefocusGrabWindow, winPtr); - } else { - [[self keyWindow] orderFront: self]; } + if (iconifiedWindow == nil && [win isMiniaturized]) { + iconifiedWindow = win; + } + } + if ([self keyWindow] == nil && iconifiedWindow != nil) { + [iconifiedWindow makeKeyAndOrderFront:self]; + } else { + [[self keyWindow] orderFront:self]; } + } - (void) applicationDeactivate: (NSNotification *) notification diff --git a/macosx/tkMacOSXWm.c b/macosx/tkMacOSXWm.c index 4ddac2bbc..d5a38fb 100644 --- a/macosx/tkMacOSXWm.c +++ b/macosx/tkMacOSXWm.c @@ -1311,9 +1311,6 @@ TkWmDeadWindow( * preventing zombies is to set the key window to nil. */ - TkMacOSXAssignNewKeyWindow(Tk_Interp((Tk_Window) winPtr), - deadNSWindow); - /* * Prevent zombies on systems with a TouchBar. */ @@ -1322,6 +1319,13 @@ TkWmDeadWindow( [NSApp _setKeyWindow:nil]; [NSApp _setMainWindow:nil]; } + + /* + * Find a new keyWindow. It will be assinged as the new + * TkEventTarget when [NSApp WindowActivation] is called.. + */ + + TkMacOSXAssignNewKeyWindow(Tk_Interp((Tk_Window) winPtr), deadNSWindow); /* * Avoid redrawing the view after it is released. diff --git a/tests/all.tcl b/tests/all.tcl index 99e6d0c..fcdbd23 100644 --- a/tests/all.tcl +++ b/tests/all.tcl @@ -14,7 +14,7 @@ package require tcltest 2.2 tcltest::configure {*}$argv tcltest::configure -testdir [file normalize [file dirname [info script]]] tcltest::configure -loadfile \ - [file join [tcltest::testsDirectory] constraints.tcl] + [file join [tcltest::testsDirectory] main.tcl] tcltest::configure -singleproc 1 set ErrorOnFailures [info exists env(ERROR_ON_FAILURES)] encoding system utf-8 diff --git a/tests/button.test b/tests/button.test index c60750a..96847c1 100644 --- a/tests/button.test +++ b/tests/button.test @@ -11,11 +11,11 @@ package require tcltest 2.2 namespace import ::tcltest::* eval tcltest::configure $argv tcltest::loadTestedCommands -imageInit -proc bogusTrace args { - error "trace aborted" -} +# Import utility procs for specific functional areas +testutils import button image + +imageInit test button-1.1 {configuration option: "activebackground" for label} -setup { label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} @@ -4007,8 +4007,12 @@ test button-15.3 {Bug [5d991b822e]} { destroy .b } {} +# +# CLEANUP +# imageFinish +testutils forget button image cleanupTests return diff --git a/tests/canvImg.test b/tests/canvImg.test index 2ac7435..69309fc 100644 --- a/tests/canvImg.test +++ b/tests/canvImg.test @@ -11,6 +11,10 @@ package require tcltest 2.2 namespace import ::tcltest::* eval tcltest::configure $argv tcltest::loadTestedCommands + +# Import utility procs for specific functional areas +testutils import image + imageInit # Canvas used in every test case of the whole file @@ -799,8 +803,12 @@ test canvImg-11.3 {ImageChangedProc procedure} -constraints { image delete foo2 } -result {{foo2 display 0 0 80 60}} -# cleanup +# +# CLEANUP +# + imageFinish +testutils forget image cleanupTests return diff --git a/tests/canvPs.test b/tests/canvPs.test index 1f3e1dc..df5c340 100644 --- a/tests/canvPs.test +++ b/tests/canvPs.test @@ -10,6 +10,10 @@ package require tcltest 2.2 namespace import ::tcltest::* eval tcltest::configure $argv tcltest::loadTestedCommands + +# Import utility procs for specific functional areas +testutils import image + imageInit # canvas used in 1.* and 2.* test cases @@ -199,10 +203,13 @@ test canvPs-5.2 {test ps generation with image} -body { destroy .c } -returnCodes ok -match glob -result * +# +# CLEANUP +# -# cleanup unset -nocomplain foo bar imageFinish +testutils forget image deleteWindows cleanupTests return diff --git a/tests/canvText.test b/tests/canvText.test index 5b08df7..cf98bef 100644 --- a/tests/canvText.test +++ b/tests/canvText.test @@ -11,8 +11,6 @@ namespace import ::tcltest::* eval tcltest::configure $argv tcltest::loadTestedCommands -testConstraint failsOnXQuarz [expr {$tcl_platform(os) ne "Darwin" || [tk windowingsystem] ne "x11" }] - # Canvas used in 1.* - 17.* tests canvas .c -width 400 -height 300 -bd 2 -relief sunken pack .c @@ -262,7 +260,7 @@ test canvText-5.1 {ConfigureText procedure: adjust cursor} -body { } -result {} -test canvText-6.1 {ComputeTextBbox procedure} -constraints {fonts failsOnXQuarz} -setup { +test canvText-6.1 {ComputeTextBbox procedure} -constraints {fonts failsOnXQuartz} -setup { .c delete test } -body { set font "-adobe-times-medium-r-normal--*-200-*-*-*-*-*-*" @@ -314,7 +312,7 @@ test canvText-6.4 {ComputeTextBbox procedure} -constraints fonts -setup { } -cleanup { .c delete test } -result 1 -test canvText-6.5 {ComputeTextBbox procedure} -constraints {fonts failsOnXQuarz} -setup { +test canvText-6.5 {ComputeTextBbox procedure} -constraints {fonts failsOnXQuartz} -setup { .c delete test } -body { set font "-adobe-times-medium-r-normal--*-200-*-*-*-*-*-*" @@ -366,7 +364,7 @@ test canvText-6.8 {ComputeTextBbox procedure} -constraints fonts -setup { } -cleanup { .c delete test } -result 1 -test canvText-6.9 {ComputeTextBbox procedure} -constraints {fonts failsOnXQuarz} -setup { +test canvText-6.9 {ComputeTextBbox procedure} -constraints {fonts failsOnXQuartz} -setup { .c delete test } -body { set font "-adobe-times-medium-r-normal--*-200-*-*-*-*-*-*" diff --git a/tests/canvas.test b/tests/canvas.test index b0e1379..937ae60 100644 --- a/tests/canvas.test +++ b/tests/canvas.test @@ -10,6 +10,10 @@ package require tcltest 2.2 eval tcltest::configure $argv tcltest::loadTestedCommands + +# Import utility procs for specific functional areas +testutils import image + imageInit # XXX - This test file is woefully incomplete. At present, only a few of the @@ -1312,8 +1316,12 @@ test canvas-23.3 {canvas image with subsample and zoom} -setup { image delete testimage } -result 1 -# cleanup +# +# CLEANUP +# + imageCleanup +testutils forget image cleanupTests return diff --git a/tests/choosedir.test b/tests/choosedir.test index 5ddc2e7..172aa2b 100644 --- a/tests/choosedir.test +++ b/tests/choosedir.test @@ -10,28 +10,20 @@ namespace import ::tcltest::* eval tcltest::configure $argv tcltest::loadTestedCommands +# Import utility procs for specific functional areas +testutils import dialog + #---------------------------------------------------------------------- # # Procedures needed by this test file # #---------------------------------------------------------------------- -proc ToPressButton {parent btn} { - after 100 SendButtonPress $parent $btn mouse -} - proc ToEnterDirsByKey {parent dirs} { after 100 [list EnterDirsByKey $parent $dirs] } -proc PressButton {btn} { - event generate $btn <Enter> - event generate $btn <Button-1> -x 5 -y 5 - event generate $btn <ButtonRelease-1> -x 5 -y 5 -} - proc EnterDirsByKey {parent dirs} { - global tk_strictMotif if {$parent == "."} { set w .__tk_choosedir } else { @@ -48,31 +40,6 @@ proc EnterDirsByKey {parent dirs} { } } -proc SendButtonPress {parent btn type} { - global tk_strictMotif - if {$parent == "."} { - set w .__tk_choosedir - } else { - set w $parent.__tk_choosedir - } - upvar ::tk::dialog::file::__tk_choosedir data - - set button $data($btn\Btn) - if ![winfo ismapped $button] { - update - } - - if {$type == "mouse"} { - PressButton $button - } else { - event generate $w <Enter> - focus $w - event generate $button <Enter> - event generate $w <Key> -keysym Return - } -} - - #---------------------------------------------------------------------- # # The test suite proper @@ -168,7 +135,11 @@ test choosedir-5.1 {tk_chooseDirectory, handles {} entry text} -constraints { -parent $parent } -result $real -# cleanup +# +# CLEANUP +# + removeDirectory choosedirTest +testutils forget dialog cleanupTests return diff --git a/tests/clipboard.test b/tests/clipboard.test index 1e2b686..88e309e 100644 --- a/tests/clipboard.test +++ b/tests/clipboard.test @@ -21,6 +21,9 @@ namespace import ::tcltest::* eval tcltest::configure $argv tcltest::loadTestedCommands +# Import utility procs for specific functional areas +testutils import child + # set up a very large buffer to test INCR retrievals set longValue "" foreach i {a b c d e f g j h i j k l m o p q r s t u v w x y z} { @@ -29,7 +32,7 @@ foreach i {a b c d e f g j h i j k l m o p q r s t u v w x y z} { } # Now we start the main body of the test code - + test clipboard-1.1 {ClipboardHandler procedure} -setup { clipboard clear } -body { @@ -236,13 +239,13 @@ test clipboard-6.1 {Tk_ClipboardAppend procedure} -setup { test clipboard-6.2 {Tk_ClipboardAppend procedure} -constraints x11 -setup { clipboard clear } -body { - setupbg + childTkProcess create clipboard append -f INTEGER -t TEST "16" - set result [dobg {clipboard get TEST}] + set result [childTkProcess eval {clipboard get TEST}] return $result } -cleanup { clipboard clear - cleanupbg + childTkProcess exit } -result {0x10 } test clipboard-6.3 {Tk_ClipboardAppend procedure} -setup { clipboard clear @@ -354,8 +357,12 @@ test clipboard-7.20 {Tk_ClipboardCmd procedure} -setup { } -cleanup { clipboard clear } -result {-type} - -# cleanup + +# +# CLEANUP +# + +testutils forget child cleanupTests return diff --git a/tests/clrpick.test b/tests/clrpick.test index afecb95..2e8d0bf 100644 --- a/tests/clrpick.test +++ b/tests/clrpick.test @@ -10,6 +10,9 @@ eval tcltest::configure $argv tcltest::loadTestedCommands namespace import -force tcltest::test +# Import utility procs for specific functional areas +testutils import dialog + if {[testConstraint defaultPseudocolor8]} { # let's soak up a bunch of colors...so that # machines with small color palettes still fail. @@ -74,33 +77,12 @@ 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 setting 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 . $btn mouse" - } -} - proc ToChooseColorByKey {parent r g b} { - global isNative - if {!$isNative} { + if {! $::dialogIsNative} { after 200 ChooseColorByKey . $r $g $b } } -proc PressButton {btn} { - event generate $btn <Enter> - event generate $btn <Button-1> -x 5 -y 5 - event generate $btn <ButtonRelease-1> -x 5 -y 5 -} - proc ChooseColorByKey {parent r g b} { set w .__tk__color upvar ::tk::dialog::color::[winfo name $w] data @@ -122,26 +104,6 @@ proc ChooseColorByKey {parent r g b} { SendButtonPress . ok mouse } -proc SendButtonPress {parent btn type} { - set w .__tk__color - upvar ::tk::dialog::color::[winfo name $w] data - - set button $data($btn\Btn) - if ![winfo ismapped $button] { - update - } - - if {$type == "mouse"} { - PressButton $button - } else { - event generate $w <Enter> - focus $w - event generate $button <Enter> - event generate $w <Key> -keysym Return - } -} - - test clrpick-2.1 {tk_chooseColor command} -constraints { nonUnixUserInteraction colorsLeftover } -setup { @@ -197,7 +159,10 @@ test clrpick-4.1 {tk_chooseColor: screen is inherited from parent} -constraints set ::scr } -result [winfo screen .] -# cleanup +# +# CLEANUP +# + +testutils forget dialog cleanupTests return - diff --git a/tests/color.test b/tests/color.test index af0695e..75ed035 100644 --- a/tests/color.test +++ b/tests/color.test @@ -9,6 +9,9 @@ package require tcltest 2.2 eval tcltest::configure $argv tcltest::loadTestedCommands +# Import utility procs for specific functional areas +testutils import colors + # cname -- # Returns a proper name for a color, given its intensities. # @@ -74,22 +77,6 @@ proc c255 {vals} { [expr {[lindex $vals 2]/256}] } -# colorsFree -- -# -# Returns 1 if there appear to be free colormap entries in a window, -# 0 otherwise. -# -# Arguments: -# w - Name of window in which to check. -# red, green, blue - Intensities to use in a trial color allocation -# to see if there are colormap entries free. - -proc colorsFree {w {red 31} {green 245} {blue 192}} { - set vals [winfo rgb $w [format #%02x%02x%02x $red $green $blue]] - expr ([lindex $vals 0]/256 == $red) && ([lindex $vals 1]/256 == $green) \ - && ([lindex $vals 2]/256 == $blue) -} - # -- WARNING (SB, 6.4.2017) -- # # The if block below looks _very_ outdated. It didn't get any @@ -305,6 +292,10 @@ test color-4.1 {FreeColorObjProc} -constraints { destroy .t -# cleanup +# +# CLEANUP +# + +testutils forget colors cleanupTests return diff --git a/tests/constraints.tcl b/tests/constraints.tcl index 8327734..660fe47 100644 --- a/tests/constraints.tcl +++ b/tests/constraints.tcl @@ -1,273 +1,17 @@ -if {[namespace exists tk::test]} { - deleteWindows - wm geometry . {} - raise . - return -} - -package require tk -tk appname tktest -wm title . tktest -# If the main window isn't already mapped (e.g. because the tests are -# being run automatically) , specify a precise size for it so that the -# user won't have to position it manually. - -if {![winfo ismapped .]} { - wm geometry . +0+0 - update -} - -package require tcltest 2.2 - -namespace eval tk { - namespace eval test { - - namespace export loadTkCommand - proc loadTkCommand {} { - set tklib {} - foreach pair [info loaded {}] { - foreach {lib pfx} $pair break - if {$pfx eq "Tk"} { - set tklib $lib - break - } - } - return [list load $tklib Tk] - } - - namespace eval bg { - # Manage a background process. - # Replace with child interp or thread? - namespace import ::tcltest::interpreter - namespace import ::tk::test::loadTkCommand - namespace export setup cleanup do - - proc cleanup {} { - variable fd - # catch in case the background process has closed $fd - catch {puts $fd exit} - catch {close $fd} - set fd "" - } - proc setup args { - variable fd - if {[info exists fd] && [string length $fd]} { - cleanup - } - set fd [open "|[list [interpreter] \ - -geometry +0+0 -name tktest] $args" r+] - puts $fd "puts foo; flush stdout" - flush $fd - if {[gets $fd data] < 0} { - error "unexpected EOF from \"[interpreter]\"" - } - if {$data ne "foo"} { - error "unexpected output from\ - background process: \"$data\"" - } - puts $fd [loadTkCommand] - flush $fd - fileevent $fd readable [namespace code Ready] - } - proc Ready {} { - variable fd - variable Data - variable Done - set x [gets $fd] - if {[eof $fd]} { - fileevent $fd readable {} - set Done 1 - } elseif {$x eq "**DONE**"} { - set Done 1 - } else { - append Data $x - } - } - proc do {cmd {block 0}} { - variable fd - variable Data - variable Done - if {$block} { - fileevent $fd readable {} - } - puts $fd "[list catch $cmd msg]; update; puts \$msg;\ - puts **DONE**; flush stdout" - flush $fd - set Data {} - if {$block} { - while {![eof $fd]} { - set line [gets $fd] - if {$line eq "**DONE**"} { - break - } - append Data $line - } - } else { - set Done 0 - vwait [namespace which -variable Done] - } - return $Data - } - } - - proc Export {internal as external} { - uplevel 1 [list namespace import $internal] - uplevel 1 [list rename [namespace tail $internal] $external] - uplevel 1 [list namespace export $external] - } - Export bg::setup as setupbg - Export bg::cleanup as cleanupbg - Export bg::do as dobg - - namespace export deleteWindows - proc deleteWindows {} { - destroy {*}[winfo children .] - # This update is needed to avoid intermittent failures on macOS in unixEmbed.test - # with the (GitHub Actions) CI runner. - # Reason for the failures is unclear but could have to do with window ids being deleted - # after the destroy command returns. The detailed mechanism of such delayed deletions - # is not understood, but it appears that this update prevents the test failures. - update - } - - namespace export fixfocus - proc fixfocus {} { - catch {destroy .focus} - toplevel .focus - wm geometry .focus +0+0 - entry .focus.e - .focus.e insert 0 "fixfocus" - pack .focus.e - update - focus -force .focus.e - destroy .focus - } - - namespace export imageInit imageFinish imageCleanup imageNames - variable ImageNames - proc imageInit {} { - variable ImageNames - if {![info exists ImageNames]} { - set ImageNames [lsearch -all -inline -glob -not [lsort [image names]] ::tk::icons::indicator*] - } - imageCleanup - if {[lsort [image names]] ne $ImageNames} { - return -code error "IMAGE NAMES mismatch: [image names] != $ImageNames" - } - } - proc imageFinish {} { - variable ImageNames - set imgs [lsearch -all -inline -glob -not [lsort [image names]] ::tk::icons::indicator*] - if {$imgs ne $ImageNames} { - return -code error "images remaining: [image names] != $ImageNames" - } - imageCleanup - } - proc imageCleanup {} { - variable ImageNames - foreach img [image names] { - if {$img ni $ImageNames} {image delete $img} - } - } - proc imageNames {} { - variable ImageNames - set r {} - foreach img [image names] { - if {$img ni $ImageNames} {lappend r $img} - } - return $r - } - - # - # CONTROL TIMING ASPECTS OF POINTER WARPING - # - # The proc [controlPointerWarpTiming] is intended to ensure that the (mouse) - # pointer has actually been moved to its new position after a Tk test issued: - # - # [event generate $w $event -warp 1 ...] - # - # It takes care of the following timing details of pointer warping: - # - # a. Allow pointer warping to happen if it was scheduled for execution at - # idle time. This happens synchronously if $w refers to the - # whole screen or if the -when option to [event generate] is "now". - # - # b. Work around a race condition associated with OS notification of - # mouse motion on Windows. - # - # When calling [event generate $w $event -warp 1 ...], the following - # sequence occurs: - # - At some point in the processing of this command, either via a - # synchronous execution path, or asynchronously at idle time, Tk calls - # an OS function* to carry out the mouse cursor motion. - # - Tk has previously registered a callback function** with the OS, for - # the OS to call in order to notify Tk when a mouse move is completed. - # - Tk doesn't wait for the callback function to receive the notification - # from the OS, but continues processing. This suits most use cases - # because usually the notification arrives fast enough (within a few tens - # of microseconds). However ... - # - A problem arises if Tk performs some processing, immediately following - # up on [event generate $w $event -warp 1 ...], and that processing - # relies on the mouse pointer having actually moved. If such processing - # happens just before the notification from the OS has been received, - # Tk will be using not yet updated info (e.g. mouse coordinates). - # - # Hickup, choke etc ... ! - # - # * the function SendInput() of the Win32 API - # ** the callback function is TkWinChildProc() - # - # This timing issue can be addressed by putting the Tk process on hold - # (do nothing at all) for a somewhat extended amount of time, while - # letting the OS complete its job in the meantime. This is what is - # accomplished by calling [after ms]. - # - # ---- - # For the history of this issue please refer to Tk ticket [69b48f427e], - # specifically the comment on 2019-10-27 14:24:26. - # - # - # Beware: there are cases, not (yet) exercised by the Tk test suite, where - # [controlPointerWarpTiming] doesn't ensure the new position of the pointer. - # For example, when issued under Tk8.7+, if the value for the -when option - # to [event generate $w] is not "now", and $w refers to a Tk window, i.e. not - # the whole screen. - # - proc controlPointerWarpTiming {{duration 50}} { - update idletasks ;# see a. above - if {[tk windowingsystem] eq "win32"} { - after $duration ;# see b. above - } - } - namespace export controlPointerWarpTiming - - # On macOS windows are not allowed to overlap the menubar at the top of the - # screen or the dock. So tests which move a window and then check whether it - # got moved to the requested location should use a y coordinate larger than the - # height of the menubar (normally 23 pixels) and an x coordinate larger than the - # width of the dock, if it happens to be on the left. - # The C-level command "testmenubarheight" deals with this issue but it may - # not be available on each platform. Therefore, provide a fallback here. - if {[llength [info commands testmenubarheight]] == 0} { - if {[tk windowingsystem] ne "aqua"} { - # Windows may overlap the menubar - proc testmenubarheight {} { - return 0 - } - } else { - # Windows may not overlap the menubar - proc testmenubarheight {} { - return 30 ; # arbitrary value known to be larger than the menubar height - } - } - namespace export testmenubarheight - } - } -} - -namespace import -force tk::test::* +# constraints.tcl -- +# +# This file is sourced by each test file when invoking "tcltest::loadTestedCommands". +# It defines test constraints that are used by several test files in the +# Tk test suite. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. namespace import -force tcltest::testConstraint + +# +# WINDOWING SYSTEM AND DISPLAY +# testConstraint notAqua [expr {[tk windowingsystem] ne "aqua"}] testConstraint aqua [expr {[tk windowingsystem] eq "aqua"}] testConstraint x11 [expr {[tk windowingsystem] eq "x11"}] @@ -275,42 +19,35 @@ testConstraint nonwin [expr {[tk windowingsystem] ne "win32"}] testConstraint aquaOrWin32 [expr { ([tk windowingsystem] eq "win32") || [testConstraint aqua] }] -testConstraint userInteraction 0 -testConstraint nonUnixUserInteraction [expr { - [testConstraint userInteraction] || - ([testConstraint unix] && [testConstraint notAqua]) -}] testConstraint haveDISPLAY [expr {[info exists env(DISPLAY)] && [testConstraint x11]}] testConstraint altDisplay [info exists env(TK_ALT_DISPLAY)] -testConstraint deprecated [expr {![::tk::build-info no-deprecate]}] - # constraint for running a test on all windowing system except aqua # where the test fails due to a known bug testConstraint aquaKnownBug [expr {[testConstraint notAqua] || [testConstraint knownBug]}] -# constraints for testing facilities defined in the tktest executable... -testConstraint testbitmap [llength [info commands testbitmap]] -testConstraint testborder [llength [info commands testborder]] -testConstraint testcbind [llength [info commands testcbind]] -testConstraint testclipboard [llength [info commands testclipboard]] -testConstraint testcolor [llength [info commands testcolor]] -testConstraint testcursor [llength [info commands testcursor]] -testConstraint testembed [llength [info commands testembed]] -testConstraint testfont [llength [info commands testfont]] -testConstraint testImageType [expr {"test" in [image types]}] -testConstraint testmakeexist [llength [info commands testmakeexist]] -testConstraint testmenubar [llength [info commands testmenubar]] -testConstraint testmetrics [llength [info commands testmetrics]] -testConstraint testmovemouse [llength [info commands testmovemouse]] -testConstraint testobjconfig [llength [info commands testobjconfig]] -testConstraint testpressbutton [llength [info commands testpressbutton]] -testConstraint testsend [llength [info commands testsend]] -testConstraint testtext [llength [info commands testtext]] -testConstraint testwinevent [llength [info commands testwinevent]] -testConstraint testwrapper [llength [info commands testwrapper]] +# constraint based on whether our display is secure +testutils import child +childTkProcess create +set app [childTkProcess eval {tk appname}] +testConstraint secureserver 0 +if {[llength [info commands send]]} { + testConstraint secureserver 1 + if {[catch {send $app set a 0} msg] == 1} { + if {[string match "X server insecure *" $msg]} { + testConstraint secureserver 0 + } + } +} +childTkProcess exit +testutils forget child -# constraints about what sort of fonts are available +testConstraint failsOnUbuntu [expr {![info exists ::env(CI)] || ![string match Linux $::tcl_platform(os)]}] +testConstraint failsOnXQuartz [expr {$tcl_platform(os) ne "Darwin" || [tk windowingsystem] ne "x11" }] + +# +# FONTS +# testConstraint fonts 1 destroy .e entry .e -width 0 -font {Helvetica -12} -bd 1 -highlightthickness 1 @@ -345,13 +82,10 @@ unset fs # in the other one). The following constraints are useful in this kind of # situation. testConstraint haveTimesFamilyFont [expr { - [string tolower [font actual {-family times} -family]] == "times" + [string tolower [font actual {-family times} -family]] eq "times" }] testConstraint haveFixedFamilyFont [expr { - [string tolower [font actual {-family fixed} -family]] == "fixed" -}] -testConstraint haveCourierFamilyFont [expr { - [string tolower [font actual {-family courier} -family]] == "courier" + [string tolower [font actual {-family fixed} -family]] eq "fixed" }] # Although unexpected, some systems may have a very limited set of fonts available. @@ -386,7 +120,9 @@ testConstraint haveBigFontTwiceLargerThanTextFont [expr { }] unset fixedFont bigFont -# constraints for the visuals available +# +# VISUALS +# testConstraint pseudocolor8 [expr { ([catch { toplevel .t -visual {pseudocolor 8} -colormap new @@ -403,30 +139,37 @@ testConstraint defaultPseudocolor8 [expr { ([winfo visual .] eq "pseudocolor") && ([winfo depth .] == 8) }] -# constraint based on whether our display is secure -setupbg -set app [dobg {tk appname}] -testConstraint secureserver 0 -if {[llength [info commands send]]} { - testConstraint secureserver 1 - if {[catch {send $app set a 0} msg] == 1} { - if {[string match "X server insecure *" $msg]} { - testConstraint secureserver 0 - } - } -} -cleanupbg -eval tcltest::configure $argv -namespace import -force tcltest::test -namespace import -force tcltest::makeFile -namespace import -force tcltest::removeFile -namespace import -force tcltest::makeDirectory -namespace import -force tcltest::removeDirectory -namespace import -force tcltest::interpreter -namespace import -force tcltest::testsDirectory -namespace import -force tcltest::cleanupTests +# +# VARIOUS +# +testConstraint userInteraction 0 +testConstraint nonUnixUserInteraction [expr { + [testConstraint userInteraction] || + ([testConstraint unix] && [testConstraint notAqua]) +}] + +testConstraint deprecated [expr {![::tk::build-info no-deprecate]}] + +# constraints for testing facilities defined in the tktest executable +testConstraint testbitmap [llength [info commands testbitmap]] +testConstraint testborder [llength [info commands testborder]] +testConstraint testcbind [llength [info commands testcbind]] +testConstraint testclipboard [llength [info commands testclipboard]] +testConstraint testcolor [llength [info commands testcolor]] +testConstraint testcursor [llength [info commands testcursor]] +testConstraint testembed [llength [info commands testembed]] +testConstraint testfont [llength [info commands testfont]] +testConstraint testImageType [expr {"test" in [image types]}] +testConstraint testmakeexist [llength [info commands testmakeexist]] +testConstraint testmenubar [llength [info commands testmenubar]] +testConstraint testmetrics [llength [info commands testmetrics]] +testConstraint testmovemouse [llength [info commands testmovemouse]] +testConstraint testobjconfig [llength [info commands testobjconfig]] +testConstraint testpressbutton [llength [info commands testpressbutton]] +testConstraint testsend [llength [info commands testsend]] +testConstraint testtext [llength [info commands testtext]] +testConstraint testwinevent [llength [info commands testwinevent]] +testConstraint testwrapper [llength [info commands testwrapper]] -deleteWindows -wm geometry . {} -raise . +# EOF diff --git a/tests/dialog.test b/tests/dialog.test index a7c1ac9..d78d825 100644 --- a/tests/dialog.test +++ b/tests/dialog.test @@ -6,6 +6,9 @@ eval tcltest::configure $argv tcltest::loadTestedCommands namespace import -force tcltest::test +# Import utility procs for specific functional areas +testutils import dialog + test dialog-1.1 {tk_dialog command} -body { tk_dialog } -match glob -returnCodes error -result {wrong # args: should be "tk_dialog w title text bitmap default *"} @@ -18,19 +21,14 @@ test dialog-1.3 {tk_dialog command} -body { destroy .d } -returnCodes error -result {bitmap "fooBitmap" not defined} - -test dialog-2.1 {tk_dialog operation} -setup { - proc PressButton {btn} { - if {![winfo ismapped $btn]} { +test dialog-2.1 {tk_dialog operation} -body { + set x [after 5000 [list set tk::Priv(button) "no response"]] + after 100 { + if {![winfo ismapped .d.button0]} { update } - event generate $btn <Enter> - event generate $btn <Button-1> -x 5 -y 5 - event generate $btn <ButtonRelease-1> -x 5 -y 5 + PressButton .d.button0 } -} -body { - set x [after 5000 [list set tk::Priv(button) "no response"]] - after 100 PressButton .d.button0 set res [tk_dialog .d foo foo info 0 click] after cancel $x return $res @@ -62,6 +60,10 @@ test dialog-2.3 {tk_dialog operation} -body { destroy .b } -result -1 +# +# CLEANUP +# + +testutils forget dialog cleanupTests return - diff --git a/tests/entry.test b/tests/entry.test index 82259b1..d20bb52 100644 --- a/tests/entry.test +++ b/tests/entry.test @@ -11,33 +11,12 @@ namespace import ::tcltest::* eval tcltest::configure $argv tcltest::loadTestedCommands -# For xscrollcommand -set scrollInfo {} -proc scroll args { - global scrollInfo - set scrollInfo $args -} -# For trace add variable -proc override args { - global x - set x 12345 -} +# Import utility procs for specific functional areas +testutils import entry scroll -# Procedures used in widget VALIDATION tests -proc doval {W d i P s S v V} { - set ::vVals [list $W $d $i $P $s $S $v $V] - return 1 -} -proc doval2 {W d i P s S v V} { - set ::vVals [list $W $d $i $P $s $S $v $V] - set ::e mydata - return 1 -} -proc doval3 {W d i P s S v V} { - set ::vVals [list $W $d $i $P $s $S $v $V] - return 0 +foreach i {1 2 3} { + set validateCmd$i [list validateCommand$i %W %d %i %P %s %S %v %V] } - set cy [font metrics {Courier -12} -linespace] @@ -895,20 +874,20 @@ test entry-3.24 {EntryWidgetCmd procedure, "delete" widget command} -setup { entry .e pack .e ; update idletasks update - set x {} + set result {} } -body { # UTF .e insert end "01234乎67890" .e delete 6 - lappend x [.e get] + lappend result [.e get] .e delete 0 end .e insert end "012345乎7890" .e delete 6 - lappend x [.e get] + lappend result [.e get] .e delete 0 end .e insert end "0123456乎890" .e delete 6 - lappend x [.e get] + lappend result [.e get] } -cleanup { destroy .e } -result [list "01234乎7890" "0123457890" "012345乎890"] @@ -1562,13 +1541,13 @@ test entry-3.86 {EntryWidgetCmd procedure, "xview" widget command} -setup { # UTF # If Tcl_NumUtfChars wasn't used, wrong answer would be: # 0.106383 0.117021 0.117021 - set x {} + set result {} .e xview moveto .1 - lappend x [format {%.6f} [lindex [.e xview] 0]] + lappend result [format {%.6f} [lindex [.e xview] 0]] .e xview moveto .11 - lappend x [format {%.6f} [lindex [.e xview] 0]] + lappend result [format {%.6f} [lindex [.e xview] 0]] .e xview moveto .12 - lappend x [format {%.6f} [lindex [.e xview] 0]] + lappend result [format {%.6f} [lindex [.e xview] 0]] } -cleanup { destroy .e } -result {0.095745 0.106383 0.117021} @@ -1588,7 +1567,7 @@ test entry-3.82 {EntryWidgetCmd procedure} -setup { # ensure that resources get properly freed. test entry-4.1 {DestroyEntry procedure} -body { - entry .e -textvariable x -show * + entry .e -textvariable textVar -show * pack .e ; update idletasks .e insert end "Sample text" update @@ -1596,48 +1575,48 @@ test entry-4.1 {DestroyEntry procedure} -body { } -result {} test entry-5.1 {ConfigureEntry procedure, -textvariable} -body { - set x 12345 - entry .e -textvariable x + set textVar 12345 + entry .e -textvariable textVar .e get } -cleanup { destroy .e } -result 12345 test entry-5.2 {ConfigureEntry procedure, -textvariable} -body { - set x 12345 - entry .e -textvariable x + set textVar 12345 + entry .e -textvariable textVar set y abcde .e configure -textvariable y - set x 54321 + set textVar 54321 .e get } -cleanup { destroy .e } -result {abcde} test entry-5.3 {ConfigureEntry procedure, -textvariable} -setup { - unset -nocomplain x + unset -nocomplain textVar entry .e } -body { .e insert 0 "Some text" - .e configure -textvariable x - set x + .e configure -textvariable textVar + set textVar } -cleanup { destroy .e } -result {Some text} test entry-5.4 {ConfigureEntry procedure, -textvariable} -setup { - unset -nocomplain x + unset -nocomplain textVar entry .e } -body { - trace add variable x write override + trace add variable textVar write override .e insert 0 "Some text" - .e configure -textvariable x - list $x [.e get] + .e configure -textvariable textVar + list $textVar [.e get] } -cleanup { destroy .e - trace remove variable x write override - unset x; + trace remove variable textVar write override + unset textVar } -result {12345 12345} test entry-5.5 {ConfigureEntry procedure} -setup { - set x {} + set result {} entry .e1 entry .e2 } -body { @@ -1647,13 +1626,13 @@ test entry-5.5 {ConfigureEntry procedure} -setup { pack .e1 .e2 ; update idletasks .e2 select from 0 .e2 select to 10 - lappend x [selection get] + lappend result [selection get] .e1 select from 1 .e1 select to 5 - lappend x [selection get] + lappend result [selection get] .e1 configure -exportselection 1 - lappend x [selection get] - set x + lappend result [selection get] + set result } -cleanup { destroy .e1 .e2 } -result {{This is so} {This is so} 1234} @@ -1687,7 +1666,7 @@ test entry-5.7 {ConfigureEntry procedure} -setup { entry .e -font {Helvetica -12} -borderwidth 2 -highlightthickness 2 pack .e ; update idletasks } -body { - .e configure -font {Courier -12} -width 4 -xscrollcommand scroll + .e configure -font {Courier -12} -width 4 -xscrollcommand setScrollInfo .e insert end "01234567890" update set scrollInfo wrong @@ -1881,11 +1860,11 @@ test entry-6.10 {EntryComputeGeometry procedure} -constraints { .e configure -bd 1 -relief raised -width 0 -show . .e insert 0 12345 update - set x [winfo reqwidth .e] + set result [winfo reqwidth .e] .e configure -show X - lappend x [winfo reqwidth .e] + lappend result [winfo reqwidth .e] .e configure -show "" - lappend x [winfo reqwidth .e] + lappend result [winfo reqwidth .e] } -cleanup { destroy .e } -result {23 53 43} @@ -1900,15 +1879,15 @@ test entry-6.11 {EntryComputeGeometry procedure} -constraints { update set x1 [winfo reqwidth .e] set x2 [expr {8+5*[font measure {helvetica 12} .]}] - set x [expr {$x1 eq $x2}] + set result [expr {$x1 eq $x2}] .e configure -show X set x1 [winfo reqwidth .e] set x2 [expr {8+5*[font measure {helvetica 12} X]}] - lappend x [expr {$x1 eq $x2}] + lappend result [expr {$x1 eq $x2}] .e configure -show "" set x1 [winfo reqwidth .e] set x2 [expr {8+[font measure {helvetica 12} 12345]}] - lappend x [expr {$x1 eq $x2}] + lappend result [expr {$x1 eq $x2}] } -cleanup { destroy .e } -result {1 1 1} @@ -1933,7 +1912,7 @@ test entry-7.1 {InsertChars procedure} -setup { pack .e ; update idletasks focus .e } -body { - .e configure -textvariable contents -xscrollcommand scroll + .e configure -textvariable contents -xscrollcommand setScrollInfo update set scrollInfo wrong .e insert 0 abcde @@ -1950,7 +1929,7 @@ test entry-7.2 {InsertChars procedure} -setup { pack .e ; update idletasks focus .e } -body { - .e configure -textvariable contents -xscrollcommand scroll + .e configure -textvariable contents -xscrollcommand setScrollInfo update set scrollInfo wrong .e insert 0 abcde @@ -1968,9 +1947,9 @@ test entry-7.3 {InsertChars procedure} -setup { .e select from 2 .e select to 6 .e insert 2 XXX - set x "[.e index sel.first] [.e index sel.last]" + set result "[.e index sel.first] [.e index sel.last]" .e select to 8 - lappend x [.e index sel.first] [.e index sel.last] + lappend result [.e index sel.first] [.e index sel.last] } -cleanup { destroy .e } -result {5 9 5 8} @@ -1982,9 +1961,9 @@ test entry-7.4 {InsertChars procedure} -setup { .e select from 2 .e select to 6 .e insert 3 XXX - set x "[.e index sel.first] [.e index sel.last]" + set result "[.e index sel.first] [.e index sel.last]" .e select to 8 - lappend x [.e index sel.first] [.e index sel.last] + lappend result [.e index sel.first] [.e index sel.last] } -cleanup { destroy .e } -result {2 9 2 8} @@ -1996,9 +1975,9 @@ test entry-7.5 {InsertChars procedure} -setup { .e select from 2 .e select to 6 .e insert 5 XXX - set x "[.e index sel.first] [.e index sel.last]" + set result "[.e index sel.first] [.e index sel.last]" .e select to 8 - lappend x [.e index sel.first] [.e index sel.last] + lappend result [.e index sel.first] [.e index sel.last] } -cleanup { destroy .e } -result {2 9 2 8} @@ -2010,9 +1989,9 @@ test entry-7.6 {InsertChars procedure} -setup { .e select from 2 .e select to 6 .e insert 6 XXX - set x "[.e index sel.first] [.e index sel.last]" + set result "[.e index sel.first] [.e index sel.last]" .e select to 5 - lappend x [.e index sel.first] [.e index sel.last] + lappend result [.e index sel.first] [.e index sel.last] } -cleanup { destroy .e } -result {2 6 2 5} @@ -2020,7 +1999,7 @@ test entry-7.7 {InsertChars procedure} -setup { entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 pack .e ; update idletasks } -body { - .e configure -xscrollcommand scroll + .e configure -xscrollcommand setScrollInfo .e insert 0 0123456789 .e icursor 4 .e insert 4 XXX @@ -2084,7 +2063,7 @@ test entry-8.1 {DeleteChars procedure} -setup { pack .e ; update idletasks focus .e } -body { - .e configure -textvariable contents -xscrollcommand scroll + .e configure -textvariable contents -xscrollcommand setScrollInfo update set scrollInfo wrong .e insert 0 abcde @@ -2100,7 +2079,7 @@ test entry-8.2 {DeleteChars procedure} -setup { pack .e ; update idletasks focus .e } -body { - .e configure -textvariable contents -xscrollcommand scroll + .e configure -textvariable contents -xscrollcommand setScrollInfo update set scrollInfo wrong .e insert 0 abcde @@ -2116,7 +2095,7 @@ test entry-8.3 {DeleteChars procedure} -setup { pack .e ; update idletasks focus .e } -body { - .e configure -textvariable contents -xscrollcommand scroll + .e configure -textvariable contents -xscrollcommand setScrollInfo update set scrollInfo wrong .e insert 0 abcde @@ -2136,9 +2115,9 @@ test entry-8.4 {DeleteChars procedure} -setup { .e select to 8 .e delete 1 3 update - set x "[.e index sel.first] [.e index sel.last]" + set result "[.e index sel.first] [.e index sel.last]" .e select to 5 - lappend x [.e index sel.first] [.e index sel.last] + lappend result [.e index sel.first] [.e index sel.last] } -cleanup { destroy .e } -result {1 6 1 5} @@ -2152,9 +2131,9 @@ test entry-8.5 {DeleteChars procedure} -setup { .e select to 8 .e delete 1 4 update - set x "[.e index sel.first] [.e index sel.last]" + set result "[.e index sel.first] [.e index sel.last]" .e select to 4 - lappend x [.e index sel.first] [.e index sel.last] + lappend result [.e index sel.first] [.e index sel.last] } -cleanup { destroy .e } -result {1 5 1 4} @@ -2168,9 +2147,9 @@ test entry-8.6 {DeleteChars procedure} -setup { .e select to 8 .e delete 1 7 update - set x "[.e index sel.first] [.e index sel.last]" + set result "[.e index sel.first] [.e index sel.last]" .e select to 5 - lappend x [.e index sel.first] [.e index sel.last] + lappend result [.e index sel.first] [.e index sel.last] } -cleanup { destroy .e } -result {1 2 1 5} @@ -2198,9 +2177,9 @@ test entry-8.8 {DeleteChars procedure} -setup { .e select to 8 .e delete 3 7 update - set x "[.e index sel.first] [.e index sel.last]" + set result "[.e index sel.first] [.e index sel.last]" .e select to 8 - lappend x [.e index sel.first] [.e index sel.last] + lappend result [.e index sel.first] [.e index sel.last] } -cleanup { destroy .e } -result {3 4 3 8} @@ -2227,9 +2206,9 @@ test entry-8.10 {DeleteChars procedure} -setup { .e select to 3 .e delete 5 8 update - set x "[.e index sel.first] [.e index sel.last]" + set result "[.e index sel.first] [.e index sel.last]" .e select to 8 - lappend x [.e index sel.first] [.e index sel.last] + lappend result [.e index sel.first] [.e index sel.last] } -cleanup { destroy .e } -result {3 5 5 8} @@ -2243,9 +2222,9 @@ test entry-8.11 {DeleteChars procedure} -setup { .e select to 3 .e delete 8 10 update - set x "[.e index sel.first] [.e index sel.last]" + set result "[.e index sel.first] [.e index sel.last]" .e select to 4 - lappend x [.e index sel.first] [.e index sel.last] + lappend result [.e index sel.first] [.e index sel.last] } -cleanup { destroy .e } -result {3 8 4 8} @@ -2351,25 +2330,25 @@ test entry-8.18 {DeleteChars procedure} -setup { } -result {1} test entry-9.1 {EntryValueChanged procedure} -setup { - unset -nocomplain x + unset -nocomplain textVar } -body { - trace add variable x write override - entry .e -textvariable x -width 0 + trace add variable textVar write override + entry .e -textvariable textVar -width 0 .e insert 0 foo - list $x [.e get] + list $textVar [.e get] } -cleanup { destroy .e - trace remove variable x write override - unset x + trace remove variable textVar write override + unset textVar } -result {12345 12345} test entry-10.1 {EntrySetValue procedure} -constraints fonts -body { - set x abcde + set textVar abcde set y ab entry .e -font {Helvetica -12} -highlightthickness 2 -bd 2 -width 0 pack .e ; update idletasks - .e configure -textvariable x + .e configure -textvariable textVar .e configure -textvariable y update list [.e get] [winfo reqwidth .e] @@ -2377,100 +2356,100 @@ test entry-10.1 {EntrySetValue procedure} -constraints fonts -body { destroy .e } -result {ab 24} test entry-10.2 {EntrySetValue procedure, updating selection} -setup { - unset -nocomplain x + unset -nocomplain textVar entry .e -font {Helvetica -12} -highlightthickness 2 -bd 2 pack .e ; update idletasks } -body { - .e configure -textvariable x + .e configure -textvariable textVar .e insert 0 "abcdefghjklmnopqrstu" .e selection range 4 10 - set x "a" + set textVar "a" .e index sel.first } -cleanup { destroy .e } -returnCodes error -result {selection isn't in widget .e} test entry-10.3 {EntrySetValue procedure, updating selection} -setup { - unset -nocomplain x + unset -nocomplain textVar entry .e -font {Helvetica -12} -highlightthickness 2 -bd 2 pack .e ; update idletasks } -body { - .e configure -textvariable x + .e configure -textvariable textVar .e insert 0 "abcdefghjklmnopqrstu" .e selection range 4 10 - set x "abcdefg" + set textVar "abcdefg" list [.e index sel.first] [.e index sel.last] } -cleanup { destroy .e } -result {4 7} test entry-10.4 {EntrySetValue procedure, updating selection} -setup { - unset -nocomplain x + unset -nocomplain textVar entry .e -font {Helvetica -12} -highlightthickness 2 -bd 2 pack .e ; update idletasks } -body { - .e configure -textvariable x + .e configure -textvariable textVar .e insert 0 "abcdefghjklmnopqrstu" .e selection range 4 10 - set x "abcdefghijklmn" + set textVar "abcdefghijklmn" list [.e index sel.first] [.e index sel.last] } -cleanup { destroy .e } -result {4 10} test entry-10.5 {EntrySetValue procedure, updating display position} -setup { - unset -nocomplain x + unset -nocomplain textVar entry .e -highlightthickness 2 -bd 2 pack .e ; update idletasks } -body { - .e configure -width 10 -font {Courier -12} -textvariable x + .e configure -width 10 -font {Courier -12} -textvariable textVar .e insert 0 "abcdefghjklmnopqrstuvwxyz" .e xview 10 update - set x "abcdefg" + set textVar "abcdefg" update .e index @0 } -cleanup { destroy .e } -result 0 test entry-10.6 {EntrySetValue procedure, updating display position} -setup { - unset -nocomplain x + unset -nocomplain textVar entry .e -highlightthickness 2 -bd 2 pack .e ; update idletasks } -body { - .e configure -width 10 -font {Courier -12} -textvariable x + .e configure -width 10 -font {Courier -12} -textvariable textVar pack .e ; update idletasks .e insert 0 "abcdefghjklmnopqrstuvwxyz" .e xview 10 update - set x "1234567890123456789012" + set textVar "1234567890123456789012" update .e index @0 } -cleanup { destroy .e } -result 10 test entry-10.7 {EntrySetValue procedure, updating insertion cursor} -setup { - unset -nocomplain x + unset -nocomplain textVar entry .e -highlightthickness 2 -bd 2 pack .e ; update idletasks update } -body { - .e configure -width 10 -font {Courier -12} -textvariable x + .e configure -width 10 -font {Courier -12} -textvariable textVar pack .e ; update idletasks .e insert 0 "abcdefghjklmnopqrstuvwxyz" .e icursor 5 - set x "123" + set textVar "123" .e index insert } -cleanup { destroy .e } -result 3 test entry-10.8 {EntrySetValue procedure, updating insertion cursor} -setup { - unset -nocomplain x + unset -nocomplain textVar entry .e -highlightthickness 2 -bd 2 pack .e ; update idletasks } -body { - .e configure -width 10 -font {Courier -12} -textvariable x + .e configure -width 10 -font {Courier -12} -textvariable textVar pack .e ; update idletasks .e insert 0 "abcdefghjklmnopqrstuvwxyz" .e icursor 5 - set x "123456" + set textVar "123456" .e index insert } -cleanup { destroy .e @@ -2487,14 +2466,14 @@ test entry-11.1 {EntryEventProc procedure} -setup { destroy .e } -result {} test entry-11.2 {EntryEventProc procedure} -setup { - set x {} + set result {} } -body { entry .e1 -fg #112233 rename .e1 .e2 - lappend x [winfo children .] - lappend x [.e2 cget -fg] + lappend result [winfo children .] + lappend result [.e2 cget -fg] destroy .e1 - lappend x [info command .e*] [winfo children .] + lappend result [info command .e*] [winfo children .] } -cleanup { destroy .e1 } -result {.e1 #112233 {} {}} @@ -2894,16 +2873,16 @@ test entry-14.2 {EntryFetchSelection procedure} -body { destroy .e } -result {*****************} test entry-14.3 {EntryFetchSelection procedure} -setup { - set x {} + set textVar {} for {set i 1} {$i <= 500} {incr i} { - append x "This is line $i, out of 500\n" + append textVar "This is line $i, out of 500\n" } } -body { entry .e - .e insert end $x + .e insert end $textVar .e select from 0 .e select to end - string compare [selection get] $x + string compare [selection get] $textVar } -cleanup { destroy .e } -result 0 @@ -2963,7 +2942,7 @@ test entry-16.4 {EntryVisibleRange procedure} -body { test entry-17.1 {EntryUpdateScrollbar procedure} -body { - entry .e -width 10 -xscrollcommand scroll -font {Courier -12} + entry .e -width 10 -xscrollcommand setScrollInfo -font {Courier -12} pack .e update set scrollInfo wrong @@ -2975,7 +2954,7 @@ test entry-17.1 {EntryUpdateScrollbar procedure} -body { destroy .e } -result {0.000000 1.000000} test entry-17.2 {EntryUpdateScrollbar procedure} -body { - entry .e -width 10 -xscrollcommand scroll -font {Courier -12} + entry .e -width 10 -xscrollcommand setScrollInfo -font {Courier -12} pack .e update set scrollInfo wrong @@ -2987,7 +2966,7 @@ test entry-17.2 {EntryUpdateScrollbar procedure} -body { destroy .e } -result {0.187500 0.812500} test entry-17.3 {EntryUpdateScrollbar procedure} -body { - entry .e -width 10 -xscrollcommand scroll -font {Courier -12} + entry .e -width 10 -xscrollcommand setScrollInfo -font {Courier -12} pack .e update set scrollInfo wrong @@ -3000,8 +2979,8 @@ test entry-17.3 {EntryUpdateScrollbar procedure} -body { } -result {0.315789 0.842105} test entry-17.4 {EntryUpdateScrollbar procedure} -setup { proc bgerror msg { - global x - set x $msg + global textVar + set textVar $msg } } -body { entry .e -width 5 @@ -3010,7 +2989,7 @@ test entry-17.4 {EntryUpdateScrollbar procedure} -setup { set scrollInfo wrong .e configure -xscrollcommand thisisnotacommand update - list $x $errorInfo + list $textVar $errorInfo } -cleanup { destroy .e rename bgerror {} @@ -3042,125 +3021,125 @@ test entry-18.1 {Entry widget vs hiding} -setup { # test cases. This was replaced by inserting recently set configurations # that matters for the test case test entry-19.1 {entry widget validation} -setup { - unset -nocomplain ::e ::vVals + unset -nocomplain textVar validationData } -body { entry .e -validate all \ - -validatecommand [list doval %W %d %i %P %s %S %v %V] \ + -validatecommand $validateCmd1 \ -invalidcommand bell \ - -textvariable ::e \ + -textvariable textVar \ -background red -foreground white pack .e ; update idletasks .e insert 0 a - set ::vVals + set validationData } -cleanup { destroy .e } -result {.e 1 0 a {} a all key} test entry-19.2 {entry widget validation} -setup { - unset -nocomplain ::e ::vVals + unset -nocomplain textVar validationData } -body { entry .e -validate all \ - -validatecommand [list doval %W %d %i %P %s %S %v %V] \ + -validatecommand $validateCmd1 \ -invalidcommand bell \ - -textvariable ::e \ + -textvariable textVar \ -background red -foreground white pack .e ; update idletasks .e insert 0 a ;# previous settings .e insert 1 b - return $::vVals + return $validationData } -cleanup { destroy .e } -result {.e 1 1 ab a b all key} test entry-19.3 {entry widget validation} -setup { - unset -nocomplain ::e ::vVals + unset -nocomplain textVar validationData } -body { entry .e -validate all \ - -validatecommand [list doval %W %d %i %P %s %S %v %V] \ + -validatecommand $validateCmd1 \ -invalidcommand bell \ - -textvariable ::e \ + -textvariable textVar \ -background red -foreground white pack .e ; update idletasks .e insert 0 ab ;# previous settings .e insert end c - set ::vVals + set validationData } -cleanup { destroy .e } -result {.e 1 2 abc ab c all key} test entry-19.4 {entry widget validation} -setup { - unset -nocomplain ::e ::vVals + unset -nocomplain textVar validationData } -body { entry .e -validate all \ - -validatecommand [list doval %W %d %i %P %s %S %v %V] \ + -validatecommand $validateCmd1 \ -invalidcommand bell \ - -textvariable ::e \ + -textvariable textVar \ -background red -foreground white pack .e ; update idletasks .e insert 0 abc ;# previous settings .e insert 1 123 - list $::vVals $::e + list $validationData $textVar } -cleanup { destroy .e } -result {{.e 1 1 a123bc abc 123 all key} a123bc} test entry-19.5 {entry widget validation} -setup { - unset -nocomplain ::e ::vVals + unset -nocomplain textVar validationData } -body { entry .e -validate all \ - -validatecommand [list doval %W %d %i %P %s %S %v %V] \ + -validatecommand $validateCmd1 \ -invalidcommand bell \ - -textvariable ::e \ + -textvariable textVar \ -background red -foreground white pack .e ; update idletasks .e insert 0 a123bc ;# previous settings .e delete 2 - set ::vVals + set validationData } -cleanup { destroy .e } -result {.e 0 2 a13bc a123bc 2 all key} test entry-19.6 {entry widget validation} -setup { - unset -nocomplain ::e ::vVals + unset -nocomplain textVar validationData } -body { entry .e -validate all \ - -validatecommand [list doval %W %d %i %P %s %S %v %V] \ + -validatecommand $validateCmd1 \ -invalidcommand bell \ - -textvariable ::e \ + -textvariable textVar \ -background red -foreground white pack .e ; update idletasks .e insert 0 a13bc ;# previous settings .e configure -validate key .e delete 1 3 - set ::vVals + set validationData } -cleanup { destroy .e } -result {.e 0 1 abc a13bc 13 key key} test entry-19.7 {entry widget validation} -setup { - unset -nocomplain ::e ::vVals + unset -nocomplain textVar validationData } -body { entry .e -validate focus \ - -validatecommand [list doval %W %d %i %P %s %S %v %V] \ + -validatecommand $validateCmd1 \ -invalidcommand bell \ - -textvariable ::e \ + -textvariable textVar \ -background red -foreground white pack .e ; update idletasks .e insert end abc ;# previous settings - set ::vVals {} + set validationData {} .e insert end d - set ::vVals + set validationData } -cleanup { destroy .e } -result {} test entry-19.8 {entry widget validation} -setup { - unset -nocomplain ::e ::vVals + unset -nocomplain textVar validationData } -body { entry .e -validate all \ - -validatecommand [list doval %W %d %i %P %s %S %v %V] \ + -validatecommand $validateCmd1 \ -invalidcommand bell \ - -textvariable ::e \ + -textvariable textVar \ -background red -foreground white pack .e ; update idletasks .e configure -validate focus ;# previous settings @@ -3168,18 +3147,18 @@ test entry-19.8 {entry widget validation} -setup { focus -force .e # update necessary to process FocusIn event update - set ::vVals + set validationData } -cleanup { destroy .e } -result {.e -1 -1 abcd abcd {} focus focusin} test entry-19.9 {entry widget validation} -setup { - unset -nocomplain ::e ::vVals + unset -nocomplain textVar validationData } -body { entry .e -validate focus \ - -validatecommand [list doval %W %d %i %P %s %S %v %V] \ + -validatecommand $validateCmd1 \ -invalidcommand bell \ - -textvariable ::e \ + -textvariable textVar \ -background red -foreground white pack .e ; update idletasks .e insert end abcd ;# previous settings @@ -3189,36 +3168,36 @@ test entry-19.9 {entry widget validation} -setup { focus -force . # update necessary to process FocusOut event update - set ::vVals + set validationData } -cleanup { destroy .e } -result {.e -1 -1 abcd abcd {} focus focusout} test entry-19.10 {entry widget validation} -setup { - unset -nocomplain ::e ::vVals + unset -nocomplain textVar validationData } -body { entry .e -validate all \ - -validatecommand [list doval %W %d %i %P %s %S %v %V] \ + -validatecommand $validateCmd1 \ -invalidcommand bell \ - -textvariable ::e \ + -textvariable textVar \ -background red -foreground white pack .e ; update idletasks .e insert end abcd ;# previous settings focus -force .e # update necessary to process FocusIn event update - set ::vVals + set validationData } -cleanup { destroy .e } -result {.e -1 -1 abcd abcd {} all focusin} test entry-19.11 {entry widget validation} -setup { - unset -nocomplain ::e ::vVals + unset -nocomplain textVar validationData } -body { entry .e -validate all \ - -validatecommand [list doval %W %d %i %P %s %S %v %V] \ + -validatecommand $validateCmd1 \ -invalidcommand bell \ - -textvariable ::e \ + -textvariable textVar \ -background red -foreground white pack .e ; update idletasks .e insert end abcd ;# previous settings @@ -3228,125 +3207,125 @@ test entry-19.11 {entry widget validation} -setup { focus -force . # update necessary to process FocusOut event update - set ::vVals + set validationData } -cleanup { destroy .e } -result {.e -1 -1 abcd abcd {} all focusout} test entry-19.12 {entry widget validation} -setup { - unset -nocomplain ::e ::vVals + unset -nocomplain textVar validationData } -body { entry .e -validate focusin \ - -validatecommand [list doval %W %d %i %P %s %S %v %V] \ + -validatecommand $validateCmd1 \ -invalidcommand bell \ - -textvariable ::e \ + -textvariable textVar \ -background red -foreground white pack .e ; update idletasks .e insert 0 abcd ;# previous settings focus -force .e # update necessary to process FocusIn event update - set ::vVals + set validationData } -cleanup { destroy .e } -result {.e -1 -1 abcd abcd {} focusin focusin} test entry-19.13 {entry widget validation} -setup { - unset -nocomplain ::e ::vVals + unset -nocomplain textVar validationData } -body { entry .e -validate focusin \ - -validatecommand [list doval %W %d %i %P %s %S %v %V] \ + -validatecommand $validateCmd1 \ -invalidcommand bell \ - -textvariable ::e \ + -textvariable textVar \ -background red -foreground white pack .e ; update idletasks .e insert end abcd ;# previous settings - set ::vVals {} + set validationData {} focus -force . # update necessary to process FocusOut event update - set ::vVals + set validationData } -cleanup { destroy .e } -result {} test entry-19.14 {entry widget validation} -setup { - unset -nocomplain ::e ::vVals + unset -nocomplain textVar validationData } -body { entry .e -validate focuso \ - -validatecommand [list doval %W %d %i %P %s %S %v %V] \ + -validatecommand $validateCmd1 \ -invalidcommand bell \ - -textvariable ::e \ + -textvariable textVar \ -background red -foreground white pack .e ; update idletasks .e insert end abcd ;# previous settings - set ::vVals {} ;# previous settings + set validationData {} ;# previous settings focus -force .e # update necessary to process FocusIn event update - set ::vVals + set validationData } -cleanup { destroy .e } -result {} test entry-19.15 {entry widget validation} -setup { - unset -nocomplain ::e ::vVals + unset -nocomplain textVar validationData } -body { entry .e -validate focuso \ - -validatecommand [list doval %W %d %i %P %s %S %v %V] \ + -validatecommand $validateCmd1 \ -invalidcommand bell \ - -textvariable ::e \ + -textvariable textVar \ -background red -foreground white pack .e ; update idletasks .e insert end abcd ;# previous settings - set ::vVals {} ;# previous settings + set validationData {} ;# previous settings focus -force .e ;# previous settings # update necessary to process FocusIn event update ;# previous settings focus -force . # update necessary to process FocusOut event update - set ::vVals + set validationData } -cleanup { destroy .e } -result {.e -1 -1 abcd abcd {} focusout focusout} # the same as 19.16 but added [.e validate] to returned list test entry-19.16 {entry widget validation} -setup { - unset -nocomplain ::e ::vVals + unset -nocomplain textVar validationData } -body { entry .e -validate focuso \ - -validatecommand [list doval %W %d %i %P %s %S %v %V] \ + -validatecommand $validateCmd1 \ -invalidcommand bell \ - -textvariable ::e \ + -textvariable textVar \ -background red -foreground white pack .e ; update idletasks .e insert end abcd ;# previous settings - set ::vVals {} ;# previous settings + set validationData {} ;# previous settings focus -force .e ;# previous settings # update necessary to process FocusIn event update ;# previous settings focus -force . # update necessary to process FocusOut event update - list [.e validate] $::vVals + list [.e validate] $validationData } -cleanup { destroy .e } -result {1 {.e -1 -1 abcd abcd {} all forced}} test entry-19.17 {entry widget validation} -setup { - unset -nocomplain ::e ::vVals + unset -nocomplain textVar validationData } -body { entry .e -validate focuso \ - -validatecommand [list doval %W %d %i %P %s %S %v %V] \ + -validatecommand $validateCmd1 \ -invalidcommand bell \ - -textvariable ::e \ + -textvariable textVar \ -background red -foreground white pack .e ; update idletasks .e insert end abcd ;# previous settings - set ::e newdata - list [.e cget -validate] $::vVals + set textVar newdata + list [.e cget -validate] $validationData } -cleanup { destroy .e } -result {focusout {.e -1 -1 newdata abcd {} focusout forced}} @@ -3354,18 +3333,18 @@ test entry-19.17 {entry widget validation} -setup { # proc doval changed - returns 0 test entry-19.18 {entry widget validation} -setup { - unset -nocomplain ::e ::vVals + unset -nocomplain textVar validationData } -body { entry .e -validate all \ - -validatecommand [list doval3 %W %d %i %P %s %S %v %V] \ + -validatecommand $validateCmd3 \ -invalidcommand bell \ - -textvariable ::e \ + -textvariable textVar \ -background red -foreground white pack .e ; update idletasks - set ::e newdata ;# previous settings + set textVar newdata ;# previous settings .e configure -validate all - set ::e nextdata - list [.e cget -validate] $::vVals + set textVar nextdata + list [.e cget -validate] $validationData } -cleanup { destroy .e } -result {none {.e -1 -1 nextdata newdata {} all forced}} @@ -3374,19 +3353,19 @@ test entry-19.18 {entry widget validation} -setup { ## loop condition in the validation, when the entry textvar is also set # proc doval2 used test entry-19.19 {entry widget validation} -setup { - unset -nocomplain ::e ::vVals + unset -nocomplain textVar validationData } -body { entry .e -validate all \ - -validatecommand [list doval3 %W %d %i %P %s %S %v %V] \ + -validatecommand $validateCmd3 \ -invalidcommand bell \ - -textvariable ::e \ + -textvariable textVar \ -background red -foreground white pack .e ; update idletasks - set ::e nextdata ;# previous settings + set textVar nextdata ;# previous settings - .e configure -validatecommand [list doval2 %W %d %i %P %s %S %v %V] + .e configure -validatecommand $validateCmd2 .e validate - list [.e cget -validate] [.e get] $::vVals + list [.e cget -validate] [.e get] $validationData } -cleanup { destroy .e } -result {none nextdata {.e -1 -1 nextdata nextdata {} all forced}} @@ -3397,21 +3376,21 @@ test entry-19.19 {entry widget validation} -setup { ## one of those "dangerous" conditions where the user will have a ## different value in the entry widget shown as is in the textvar. test entry-19.20 {entry widget validation} -setup { - unset -nocomplain ::e ::vVals + unset -nocomplain textVar validationData } -body { entry .e -validate all \ - -validatecommand [list doval %W %d %i %P %s %S %v %V] \ + -validatecommand $validateCmd1 \ -invalidcommand bell \ - -textvariable ::e \ + -textvariable textVar \ -background red -foreground white pack .e ; update idletasks - set ::e nextdata ;# previous settings - .e configure -validatecommand [list doval2 %W %d %i %P %s %S %v %V] ;# prev + set textVar nextdata ;# previous settings + .e configure -validatecommand $validateCmd2 ;# prev .e validate ;# previous settings .e configure -validate all - set ::e testdata - list [.e cget -validate] [.e get] $::e $::vVals + set textVar testdata + list [.e cget -validate] [.e get] $textVar $validationData } -cleanup { destroy .e } -result {all testdata mydata {.e -1 -1 testdata mydata {} all forced}} @@ -3422,15 +3401,15 @@ test entry-19.20 {entry widget validation} -setup { ## one of those "dangerous" conditions where the user will have a ## different value in the entry widget shown as is in the textvar. test entry-19.21 {entry widget validation - bug 40e4bf6198} -setup { - unset -nocomplain ::e ::vVals + unset -nocomplain textVar validationData } -body { entry .e -validate key \ - -validatecommand [list doval2 %W %d %i %P %s %S %v %V] \ - -textvariable ::e + -validatecommand $validateCmd2 \ + -textvariable textVar pack .e ; update idletasks - set ::e origdata + set textVar origdata .e insert 0 A - list [.e cget -validate] [.e get] $::e $::vVals + list [.e cget -validate] [.e get] $textVar $validationData } -cleanup { destroy .e } -result {none origdata mydata {.e 1 0 Aorigdata origdata A key key}} @@ -3625,10 +3604,16 @@ test entry-25.3 {Bug [2a32225cd1] - Navigation in a password made of several wor # XXX Still need to write tests for EntryScanTo and EntrySelectTo. # No tests for EventuallyRedraw +# +# CLEANUP +# + # option clear -# cleanup +foreach i {1 2 3} { + unset validateCmd$i +} +unset i +testutils forget entry scroll cleanupTests return - - diff --git a/tests/event.test b/tests/event.test index 2cbe9b5..316c3b9 100644 --- a/tests/event.test +++ b/tests/event.test @@ -79,12 +79,12 @@ proc _keypress {win key} { focus -force $win } event generate $win <Key-$keysym> - _pause 50 + pause 50 if {[focus] != $win} { focus -force $win } event generate $win <KeyRelease-$keysym> - _pause 50 + pause 50 } # Call _keypress for each character in the given string @@ -95,23 +95,6 @@ proc _keypress_string {win string} { } } -# Delay script execution for a given amount of time - -proc _pause {{msecs 1000}} { - global _pause - - if {! [info exists _pause(number)]} { - set _pause(number) 0 - } - - set num [incr _pause(number)] - set _pause($num) 0 - - after $msecs "set _pause($num) 1" - vwait _pause($num) - unset _pause($num) -} - # Helper proc to convert index to x y position proc _text_ind_to_x_y {text ind} { @@ -222,9 +205,9 @@ test event-2.3(keypress) {type into entry widget, triple click, hit Delete key, event generate $e <Enter> for {set i 0} {$i < 3} {incr i} { - _pause 100 + pause 100 event generate $e <Button-1> - _pause 100 + pause 100 event generate $e <ButtonRelease-1> } @@ -277,9 +260,9 @@ test event-2.6(keypress) {type into text widget, triple click, event generate $e <Enter> for {set i 0} {$i < 3} {incr i} { - _pause 100 + pause 100 event generate $e <Button-1> - _pause 100 + pause 100 event generate $e <ButtonRelease-1> } @@ -322,11 +305,11 @@ test event-3.1(click-drag) {click and drag in a text widget, this tests foreach {current_x current_y} [_text_ind_to_x_y $e $current] break event generate $e <B1-Motion> -x $current_x -y $current_y set current [$e index [list $current + 1 char]] - _pause 50 + pause 50 } event generate $e <ButtonRelease-1> -x $current_x -y $current_y - _pause 200 + pause 200 # Save the position of the insert cursor lappend result [$e index insert] @@ -342,11 +325,11 @@ test event-3.1(click-drag) {click and drag in a text widget, this tests foreach {current_x current_y} [_text_ind_to_x_y $e $current] break event generate $e <B1-Motion> -x $current_x -y $current_y set current [$e index [list $current - 1 char]] - _pause 50 + pause 50 } event generate $e <ButtonRelease-1> -x $current_x -y $current_y - _pause 200 + pause 200 # Save the position of the insert cursor lappend result [$e index insert] @@ -389,11 +372,11 @@ test event-3.1(click-drag) {click and drag in a text widget, this tests foreach {current_x current_y} [_text_ind_to_x_y $e $current] break event generate $e <B1-Motion> -x $current_x -y $current_y incr current - _pause 50 + pause 50 } event generate $e <ButtonRelease-1> -x $current_x -y $current_y - _pause 200 + pause 200 # Save the position of the insert cursor lappend result [$e index insert] @@ -409,11 +392,11 @@ test event-3.1(click-drag) {click and drag in a text widget, this tests foreach {current_x current_y} [_text_ind_to_x_y $e $current] break event generate $e <B1-Motion> -x $current_x -y $current_y incr current -1 - _pause 50 + pause 50 } event generate $e <ButtonRelease-1> -x $current_x -y $current_y - _pause 200 + pause 200 # Save the position of the insert cursor lappend result [$e index insert] @@ -443,11 +426,11 @@ test event-4.1(double-click-drag) {click down, click up, click down again, # Click down, release, then click down again event generate $e <Enter> event generate $e <Button-1> -x $anchor_x -y $anchor_y - _pause 50 + pause 50 event generate $e <ButtonRelease-1> -x $anchor_x -y $anchor_y - _pause 50 + pause 50 event generate $e <Button-1> -x $anchor_x -y $anchor_y - _pause 50 + pause 50 # Save the highlighted text set result [list] @@ -461,7 +444,7 @@ test event-4.1(double-click-drag) {click down, click up, click down again, foreach {current_x current_y} [_text_ind_to_x_y $e $current] break event generate $e <B1-Motion> -x $current_x -y $current_y - _pause 50 + pause 50 # Insert cursor should be before the l in "select" lappend result [$e index insert] @@ -474,7 +457,7 @@ test event-4.1(double-click-drag) {click down, click up, click down again, foreach {current_x current_y} [_text_ind_to_x_y $e $current] break event generate $e <B1-Motion> -x $current_x -y $current_y - _pause 200 + pause 200 lappend result [$e index insert] lappend result [_get_selection $e] @@ -484,7 +467,7 @@ test event-4.1(double-click-drag) {click down, click up, click down again, foreach {current_x current_y} [_text_ind_to_x_y $e $current] break event generate $e <B1-Motion> -x $current_x -y $current_y - _pause 50 + pause 50 # Selection should now be "Word select" lappend result [_get_selection $e] @@ -514,11 +497,11 @@ test event-4.2(double-click-drag) {click down, click up, click down again, # Click down, release, then click down again event generate $e <Enter> event generate $e <Button-1> -x $anchor_x -y $anchor_y - _pause 50 + pause 50 event generate $e <ButtonRelease-1> -x $anchor_x -y $anchor_y - _pause 50 + pause 50 event generate $e <Button-1> -x $anchor_x -y $anchor_y - _pause 50 + pause 50 set result [list] lappend result [_get_selection $e] @@ -531,7 +514,7 @@ test event-4.2(double-click-drag) {click down, click up, click down again, foreach {current_x current_y} [_text_ind_to_x_y $e $current] break event generate $e <B1-Motion> -x $current_x -y $current_y - _pause 50 + pause 50 # Insert cursor should be before the l in "select" lappend result [$e index insert] @@ -544,7 +527,7 @@ test event-4.2(double-click-drag) {click down, click up, click down again, foreach {current_x current_y} [_text_ind_to_x_y $e $current] break event generate $e <B1-Motion> -x $current_x -y $current_y - _pause 50 + pause 50 lappend result [$e index insert] lappend result [_get_selection $e] @@ -554,7 +537,7 @@ test event-4.2(double-click-drag) {click down, click up, click down again, foreach {current_x current_y} [_text_ind_to_x_y $e $current] break event generate $e <B1-Motion> -x $current_x -y $current_y - _pause 50 + pause 50 # Selection should now be "Word select" lappend result [_get_selection $e] @@ -586,17 +569,17 @@ test event-5.1(triple-click-drag) {Triple click and drag across lines in a event generate $e <Enter> event generate $e <Button-1> -x $anchor_x -y $anchor_y - _pause 50 + pause 50 event generate $e <ButtonRelease-1> -x $anchor_x -y $anchor_y - _pause 50 + pause 50 event generate $e <Button-1> -x $anchor_x -y $anchor_y - _pause 50 + pause 50 event generate $e <ButtonRelease-1> -x $anchor_x -y $anchor_y - _pause 50 + pause 50 event generate $e <Button-1> -x $anchor_x -y $anchor_y - _pause 50 + pause 50 set result [list] lappend result [_get_selection $e] @@ -607,7 +590,7 @@ test event-5.1(triple-click-drag) {Triple click and drag across lines in a foreach {current_x current_y} [_text_ind_to_x_y $e $current] break event generate $e <B1-Motion> -x $current_x -y $current_y - _pause 50 + pause 50 lappend result [_get_selection $e] @@ -617,7 +600,7 @@ test event-5.1(triple-click-drag) {Triple click and drag across lines in a foreach {current_x current_y} [_text_ind_to_x_y $e $current] break event generate $e <B1-Motion> -x $current_x -y $current_y - _pause 50 + pause 50 lappend result [_get_selection $e] @@ -675,13 +658,13 @@ test event-7.1(double-click) {A double click on a lone character event generate $e <Enter> event generate $e <Button-1> -x $left_x -y $left_y - _pause 50 + pause 50 event generate $e <ButtonRelease-1> -x $left_x -y $left_y - _pause 50 + pause 50 event generate $e <Button-1> -x $left_x -y $left_y - _pause 50 + pause 50 event generate $e <ButtonRelease-1> -x $left_x -y $left_y - _pause 50 + pause 50 set result [list] lappend result [$e index insert] @@ -690,20 +673,20 @@ test event-7.1(double-click) {A double click on a lone character # Clear selection by clicking at 0,0 event generate $e <Button-1> -x 0 -y 0 - _pause 50 + pause 50 event generate $e <ButtonRelease-1> -x 0 -y 0 - _pause 50 + pause 50 # Double click near right hand edge of the letter A event generate $e <Button-1> -x $right_x -y $right_y - _pause 50 + pause 50 event generate $e <ButtonRelease-1> -x $right_x -y $right_y - _pause 50 + pause 50 event generate $e <Button-1> -x $right_x -y $right_y - _pause 50 + pause 50 event generate $e <ButtonRelease-1> -x $right_x -y $right_y - _pause 50 + pause 50 lappend result [$e index insert] lappend result [_get_selection $e] @@ -742,13 +725,13 @@ test event-7.2(double-click) {A double click on a lone character event generate $e <Enter> event generate $e <Button-1> -x $left_x -y $left_y - _pause 50 + pause 50 event generate $e <ButtonRelease-1> -x $left_x -y $left_y - _pause 50 + pause 50 event generate $e <Button-1> -x $left_x -y $left_y - _pause 50 + pause 50 event generate $e <ButtonRelease-1> -x $left_x -y $left_y - _pause 50 + pause 50 set result [list] lappend result [$e index insert] @@ -757,20 +740,20 @@ test event-7.2(double-click) {A double click on a lone character # Clear selection by clicking at 0,0 event generate $e <Button-1> -x 0 -y 0 - _pause 50 + pause 50 event generate $e <ButtonRelease-1> -x 0 -y 0 - _pause 50 + pause 50 # Double click near right hand edge of the letter A event generate $e <Button-1> -x $right_x -y $right_y - _pause 50 + pause 50 event generate $e <ButtonRelease-1> -x $right_x -y $right_y - _pause 50 + pause 50 event generate $e <Button-1> -x $right_x -y $right_y - _pause 50 + pause 50 event generate $e <ButtonRelease-1> -x $right_x -y $right_y - _pause 50 + pause 50 lappend result [$e index insert] lappend result [_get_selection $e] @@ -821,21 +804,21 @@ test event-9.1 {enter . window by destroying a toplevel - bug b1d115fa60} -setup } -body { wm geometry . 200x200+300+300 wm deiconify . - _pause 200 + pause 200 toplevel .top2 -width 200 -height 200 wm geometry .top2 +[expr {[winfo rootx .]+50}]+[expr {[winfo rooty .]+50}] update idletasks wm deiconify .top2 update idletasks raise .top2 - _pause 400 + pause 400 event generate .top2 <Motion> -warp 1 -x 50 -y 50 - _pause 100 + pause 100 bind . <Enter> {lappend res %W} set res [list ] destroy .top2 update idletasks - _pause 200 + pause 200 set res } -cleanup { deleteWindows @@ -858,20 +841,20 @@ test event-9.2 {enter toplevel window by destroying a toplevel - bug b1d115fa60} toplevel .top1 wm geometry .top1 200x200+300+300 wm deiconify .top1 - _pause 200 + pause 200 toplevel .top2 -width 200 -height 200 wm geometry .top2 +[expr {[winfo rootx .top1]+50}]+[expr {[winfo rooty .top1]+50}] - _pause 200 + pause 200 wm deiconify .top2 update idletasks raise .top2 - _pause 400 + pause 400 event generate .top2 <Motion> -warp 1 -x 50 -y 50 - _pause 100 + pause 100 bind .top1 <Enter> {lappend res %W} set res [list ] destroy .top2 - _pause 200 + pause 200 set res } -cleanup { deleteWindows ; # destroy all children of ".", this already includes .top1 @@ -948,7 +931,7 @@ test event-9.11 {pointer window container = parent} -setup { create_and_pack_frames .one wm deiconify .one tkwait visibility .one.f1.f2 - _pause 200; # needed for Windows + pause 200; # needed for Windows update idletasks; # finish display of window set result "|" } -body { @@ -973,7 +956,7 @@ test event-9.12 {pointer window container != parent} -setup { wm deiconify .one tkwait visibility .one.g event generate .one <Motion> -warp 1 -x 250 -y 250 - _pause 200; # needed for Windows + pause 200; # needed for Windows set result "|" } -body { bind all <Leave> {append result "<Leave> %d %W|"} @@ -1067,7 +1050,7 @@ test event-9.16 {Successive destructions (pointer window + parent), single gener wm deiconify .one tkwait visibility .one.f1.f2 update idletasks; # finish displaying window - _pause 200; # needed for Windows + pause 200; # needed for Windows set result "|" } -body { bind all <Leave> {append result "<Leave> %d %W|"} @@ -1091,7 +1074,7 @@ test event-9.17 {Successive destructions (pointer window + parent), separate cro wm deiconify .one tkwait visibility .one.f1.f2 update idletasks; # finish displaying window - _pause 200; # needed for Windows + pause 200; # needed for Windows set result "|" } -body { bind all <Leave> {append result "<Leave> %d %W|"} @@ -1189,14 +1172,13 @@ test event-9.20 {Successive destructions (pointer window + ancestors including i # cleanup # macOS sometimes has trouble deleting the test window, # causing a failure in focus.test. -_pause 200; +pause 200; deleteWindows update unset -nocomplain keypress_lookup rename _init_keypress_lookup {} rename _keypress_lookup {} rename _keypress {} -rename _pause {} rename _text_ind_to_x_y {} rename _get_selection {} rename create_and_pack_frames {} diff --git a/tests/filebox.test b/tests/filebox.test index 96c4807..cd655e9 100644 --- a/tests/filebox.test +++ b/tests/filebox.test @@ -10,6 +10,9 @@ package require tcltest 2.2 eval tcltest::configure $argv tcltest::loadTestedCommands +# Import utility procs for specific functional areas +testutils import dialog + test fileDialog-0.1 {GetFileName: file types: MakeFilter() fails} { # MacOS type that is too long @@ -46,26 +49,12 @@ set tk_strictMotif_old $tk_strictMotif # #---------------------------------------------------------------------- -proc ToPressButton {parent btn} { - global isNative - if {!$isNative} { - after 100 SendButtonPress $parent $btn mouse - } -} - proc ToEnterFileByKey {parent fileName fileDir} { - global isNative - if {!$isNative} { + if {! $::dialogIsNative} { after 100 EnterFileByKey $parent [list $fileName] [list $fileDir] } } -proc PressButton {btn} { - event generate $btn <Enter> - event generate $btn <Button-1> -x 5 -y 5 - event generate $btn <ButtonRelease-1> -x 5 -y 5 -} - proc EnterFileByKey {parent fileName fileDir} { global tk_strictMotif if {$parent == "."} { @@ -87,30 +76,6 @@ proc EnterFileByKey {parent fileName fileDir} { SendButtonPress $parent ok mouse } -proc SendButtonPress {parent btn type} { - if {$parent == "."} { - set w .__tk_filedialog - } else { - set w $parent.__tk_filedialog - } - upvar ::tk::dialog::file::__tk_filedialog data - - set button $data($btn\Btn) - if ![winfo ismapped $button] { - update - } - - if {$type == "mouse"} { - PressButton $button - } else { - event generate $w <Enter> - focus $w - event generate $button <Enter> - event generate $w <Key> -keysym Return - } -} - - #---------------------------------------------------------------------- # # The test suite proper @@ -205,11 +170,6 @@ foreach mode $modes { tk_getOpenFile -filetypes {Foo} } -returnCodes error -result {bad file type "Foo", should be "typeName {extension ?extensions ...?} ?{macType ?macTypes ...?}?"} - set isNative [expr { - [info commands ::tk::MotifFDialog] eq "" && - [info commands ::tk::dialog::file::] eq "" - }] - set parent . set verylongstring longstring: @@ -350,11 +310,6 @@ test fileDialog-2.7-$mode {"tk_getOpenFile: bad extension" -body { tk_getSaveFile -filetypes {Foo} } -returnCodes error -result {bad file type "Foo", should be "typeName {extension ?extensions ...?} ?{macType ?macTypes ...?}?"} - set isNative [expr { - [info commands ::tk::MotifFDialog] eq "" && - [info commands ::tk::dialog::file::] eq "" - }] - test filebox-5.1-$mode "tk_getSaveFile command" nonUnixUserInteraction { ToPressButton $parent cancel tk_getSaveFile -title "Press Cancel ($verylongstring)" -parent $parent @@ -486,9 +441,12 @@ test fileDialog-2.7-$mode {"tk_getOpenFile: bad extension" -body { # needed on the other platforms because they use native file dialogs. } -set tk_strictMotif $tk_strictMotif_old +# +# CLEANUP +# -# cleanup +set tk_strictMotif $tk_strictMotif_old removeFile filebox.tmp +testutils forget dialog cleanupTests return diff --git a/tests/focus.test b/tests/focus.test index add0f37..4c7d3bb 100644 --- a/tests/focus.test +++ b/tests/focus.test @@ -10,14 +10,14 @@ package require tcltest 2.2 eval tcltest::configure $argv tcltest::loadTestedCommands namespace import -force tcltest::test + +# Import utility procs for specific functional areas +testutils import child + if {[tk windowingsystem] eq "aqua"} { - interp create childInterp - load {} Tk childInterp + childTkInterp childInterp } -testConstraint failsOnUbuntu [expr {![info exists ::env(CI)] || ![string match Linux $::tcl_platform(os)]}] -testConstraint failsOnXQuarz [expr {$tcl_platform(os) ne "Darwin" || [tk windowingsystem] ne "x11" }] - proc focusSetup {} { destroy .t toplevel .t @@ -62,7 +62,7 @@ if {[tk windowingsystem] eq "aqua"} { } } else { proc focusClear {} { - dobg {after 200; focus -force .; update} + childTkProcess eval {after 200; focus -force .; update} after 400 update } @@ -76,8 +76,8 @@ pack .b # Make sure the window manager knows who has focus catch {fixfocus} -# cleanupbg will be after 4.3 test -setupbg +# childTkProcess exit will be after 4.3 test +childTkProcess create update bind all <FocusIn> { append focusInfo "in %W %d\n" @@ -169,7 +169,7 @@ test focus-1.11 {Tk_FocusCmd procedure, -displayof option} -constraints { test focus-1.12 {Tk_FocusCmd procedure, -displayof option} -constraints { unix } -body { - # Move focus to the root window in the child or bg interpreter. + # Move focus to the root window in the child process/interpreter. focusClear # The main application does not have focus, so this has no effect now. focus .t @@ -332,7 +332,7 @@ in .t.b1 NotifyNonlinear } .t.b1} test focus-2.6 {TkFocusFilterEvent procedure, FocusIn events} -constraints { - unix testwrapper failsOnUbuntu failsOnXQuarz + unix testwrapper failsOnUbuntu failsOnXQuartz } -body { focus .t.b1 focus . @@ -344,7 +344,7 @@ test focus-2.6 {TkFocusFilterEvent procedure, FocusIn events} -constraints { list $x $focusInfo } -result {.t.b1 {press .t.b1 x}} test focus-2.7 {TkFocusFilterEvent procedure, FocusOut events} -constraints { - unix testwrapper failsOnUbuntu failsOnXQuarz + unix testwrapper failsOnUbuntu failsOnXQuartz } -body { set result {} foreach detail {NotifyAncestor NotifyInferior NotifyNonlinear @@ -365,7 +365,7 @@ test focus-2.8 {TkFocusFilterEvent procedure, FocusOut events} -constraints { focus } -result {.t.b1} test focus-2.9 {TkFocusFilterEvent procedure, FocusOut events} -constraints { - unix testwrapper failsOnUbuntu failsOnXQuarz + unix testwrapper failsOnUbuntu failsOnXQuartz } -body { focus .t.b1 event gen [testwrapper .] <FocusOut> -detail NotifyAncestor @@ -615,7 +615,7 @@ test focus-4.4 {TkFocusDeadWindow procedure} -constraints { destroy .t.b2 focus } -result {.t} -cleanupbg +childTkProcess exit # I don't know how to test most of the remaining procedures of this file @@ -623,20 +623,20 @@ cleanupbg # Test 5.1 fails (before and after update) test focus-5.1 {ChangeXFocus procedure, don't take focus unless have it} -constraints { - unix testwrapper secureserver failsOnUbuntu failsOnXQuarz + unix testwrapper secureserver failsOnUbuntu failsOnXQuartz } -body { - setupbg + childTkProcess create focusSetup focus -force .t update set result [focus] - send [dobg {tk appname}] {focus -force .; update} + send [childTkProcess eval {tk appname}] {focus -force .; update} lappend result [focus] focus .t.b2 update lappend result [focus] } -cleanup { - cleanupbg + childTkProcess exit } -result {.t {} {}} destroy .t bind all <FocusIn> {} @@ -704,7 +704,7 @@ test focus-6.1 {miscellaneous - embedded application in same process} -constrain test focus-6.2 {miscellaneous - embedded application in different process} -constraints { unix testwrapper } -body { - setupbg + childTkProcess create toplevel .t wm geometry .t +0+0 frame .t.f1 -container 1 @@ -714,8 +714,8 @@ test focus-6.2 {miscellaneous - embedded application in different process} -cons pack .t.f2.e1 bind all <FocusIn> {lappend x "focus in %W %d"} bind all <FocusOut> {lappend x "focus out %W %d"} - setupbg -use [winfo id .t.f1] - dobg { + childTkProcess create -use [winfo id .t.f1] + childTkProcess eval { entry .e1 -bg lightBlue pack .e1 bind all <FocusIn> {lappend x "focus in %W %d"} @@ -729,27 +729,27 @@ test focus-6.2 {miscellaneous - embedded application in different process} -cons after 300 {set timer 1} vwait timer set x {} - lappend x [focus] [dobg focus] + lappend x [focus] [childTkProcess eval focus] # See if a "focus" command will move the focus to the embedded # application. - dobg {focus .e1} + childTkProcess eval {focus .e1} after 300 {set timer 1} vwait timer lappend x | - dobg {lappend x |} + childTkProcess eval {lappend x |} # Bring the focus back to the main application. focus .t.f2.e1 after 300 {set timer 1} vwait timer - set result [list $x [dobg {set x}]] + set result [list $x [childTkProcess eval {set x}]] return $result } -cleanup { destroy .t - cleanupbg + childTkProcess exit bind all <FocusIn> {} bind all <FocusOut> {} } -result {{.t.f2.e1 {} {focus out .t.f2.e1 NotifyNonlinear} {focus out .t.f2 NotifyNonlinearVirtual} {focus in .t.f1 NotifyNonlinear} | {focus out .t.f1 NotifyNonlinear} {focus in .t.f2 NotifyNonlinearVirtual} {focus in .t.f2.e1 NotifyNonlinear}} {{focus in . NotifyVirtual} {focus in .e1 NotifyAncestor} | {focus out .e1 NotifyAncestor} {focus out . NotifyVirtual}}} @@ -799,9 +799,12 @@ test focus-8.1 {fdc0ed342d - segfault on focus -force} -body { crashit } -result {Reached} -deleteWindows +# +# CLEANUP +# -# cleanup +deleteWindows +testutils forget child cleanupTests if {[tk windowingsystem] eq "aqua"} { interp delete childInterp diff --git a/tests/fontchooser.test b/tests/fontchooser.test index 76333e1..7a7c37d 100644 --- a/tests/fontchooser.test +++ b/tests/fontchooser.test @@ -6,46 +6,10 @@ package require tcltest 2.2 eval tcltest::configure $argv tcltest::loadTestedCommands -# the following helper functions are related to the functions used -# in winDialog.test where they are used to send messages to the win32 -# dialog (hence the weirdness). - -proc start {cmd} { - set ::tk_dialog {} - set ::iter_after 0 - after 1 $cmd -} -proc then {cmd} { - set ::command $cmd - set ::dialogresult {} - set ::testfont {} - afterbody - vwait ::dialogresult - return $::dialogresult -} -proc afterbody {} { - if {$::tk_dialog == {}} { - if {[incr ::iter_after] > 30} { - set ::dialogresult ">30 iterations waiting for tk_dialog" - return - } - after 150 {afterbody} - return - } - uplevel #0 {set dialogresult [eval $command]} -} -proc Click {button} { - switch -exact -- $button { - ok { $::tk_dialog.ok invoke } - cancel { $::tk_dialog.cancel invoke } - apply { $::tk_dialog.apply invoke } - default { return -code error "invalid button name \"$button\"" } - } -} -proc ApplyFont {font} { -# puts stderr "apply: $font" - set ::testfont $font -} +# Import utility procs for specific functional areas +testutils import dialog + +set applyFontCmd [list set testDialogFont] # ------------------------------------------------------------------------- @@ -95,37 +59,37 @@ test fontchooser-1.9 {tk fontchooser: usage} -returnCodes error -body { testConstraint scriptImpl [llength [info proc ::tk::fontchooser::Configure]] test fontchooser-2.0 {fontchooser -title} -constraints scriptImpl -body { - start { + testDialog launch { tk::fontchooser::Configure -title "Hello" tk::fontchooser::Show } - then { - set x [wm title $::tk_dialog] + testDialog onDisplay { + set x [wm title $testDialog] Click cancel } set x } -result {Hello} test fontchooser-2.1 {fontchooser -title (cyrillic)} -constraints scriptImpl -body { - start { + testDialog launch { tk::fontchooser::Configure \ -title "Привет" tk::fontchooser::Show } - then { - set x [wm title $::tk_dialog] + testDialog onDisplay { + set x [wm title $testDialog] Click cancel } set x } -result "Привет" test fontchooser-3.0 {fontchooser -parent} -constraints scriptImpl -body { - start { + testDialog launch { tk::fontchooser::Configure -parent . tk::fontchooser::Show } - then { - set x [winfo parent $::tk_dialog] + testDialog onDisplay { + set x [winfo parent $testDialog] Click cancel } set x @@ -136,58 +100,58 @@ test fontchooser-3.1 {fontchooser -parent (invalid)} -constraints scriptImpl -bo } -returnCodes error -match glob -result {bad window path *} test fontchooser-4.0 {fontchooser -font} -constraints scriptImpl -body { - start { - tk::fontchooser::Configure -command ApplyFont -font courier + testDialog launch { + tk::fontchooser::Configure -command $applyFontCmd -font courier tk::fontchooser::Show } - then { + testDialog onDisplay { Click cancel } - set ::testfont + set testDialogFont } -result {} test fontchooser-4.1 {fontchooser -font} -constraints scriptImpl -body { - start { - tk::fontchooser::Configure -command ApplyFont -font courier + testDialog launch { + tk::fontchooser::Configure -command $applyFontCmd -font courier tk::fontchooser::Show } - then { + testDialog onDisplay { Click ok } - expr {$::testfont ne {}} + expr {$testDialogFont ne {}} } -result 1 test fontchooser-4.2 {fontchooser -font} -constraints scriptImpl -body { - start { - tk::fontchooser::Configure -command ApplyFont -font TkDefaultFont + testDialog launch { + tk::fontchooser::Configure -command $applyFontCmd -font TkDefaultFont tk::fontchooser::Show } - then { + testDialog onDisplay { Click ok } - expr {$::testfont ne {}} + expr {$testDialogFont ne {}} } -result 1 test fontchooser-4.3 {fontchooser -font} -constraints scriptImpl -body { - start { - tk::fontchooser::Configure -command ApplyFont -font {times 14 bold} + testDialog launch { + tk::fontchooser::Configure -command $applyFontCmd -font {times 14 bold} tk::fontchooser::Show } - then { + testDialog onDisplay { Click ok } - expr {$::testfont ne {}} + expr {$testDialogFont ne {}} } -result 1 test fontchooser-4.4 {fontchooser -font} -constraints {scriptImpl havePointsize14BoldFont} -body { - start { - tk::fontchooser::Configure -command ApplyFont -font {times 14 bold} + testDialog launch { + tk::fontchooser::Configure -command $applyFontCmd -font {times 14 bold} tk::fontchooser::Show } - then { + testDialog onDisplay { Click ok } - lrange $::testfont 1 end + lrange $testDialogFont 1 end } -result {14 bold} test fontchooser-5.1 {fontchooser multiple configure} -constraints {scriptImpl} -body { @@ -196,8 +160,12 @@ test fontchooser-5.1 {fontchooser multiple configure} -constraints {scriptImpl} tk fontchooser configure -title } -result {TestTitle} -# ------------------------------------------------------------------------- +# +# CLEANUP +# +unset applyFontCmd +testutils forget dialog cleanupTests return diff --git a/tests/frame.test b/tests/frame.test index 9cb5070..bb68dba 100644 --- a/tests/frame.test +++ b/tests/frame.test @@ -12,46 +12,8 @@ namespace import ::tcltest::* tcltest::configure {*}$argv tcltest::loadTestedCommands -tcltest::testConstraint x11 [expr {[tk windowingsystem] eq "x11"}] - -# eatColors -- -# Creates a toplevel window and allocates enough colors in it to use up all -# the slots in an 8-bit colormap. -# -# Arguments: -# w - Name of toplevel window to create. - -proc eatColors {w} { - catch {destroy $w} - toplevel $w - wm geom $w +0+0 - canvas $w.c -width 400 -height 200 -bd 0 - pack $w.c - for {set y 0} {$y < 8} {incr y} { - for {set x 0} {$x < 40} {incr x} { - set color [format #%02x%02x%02x [expr {$x*6}] [expr {$y*30}] 0] - $w.c create rectangle [expr {10*$x}] [expr {20*$y}] \ - [expr {10*$x + 10}] [expr {20*$y + 20}] -outline {} \ - -fill $color - } - } - update -} - -# colorsFree -- -# -# Returns 1 if there appear to be free colormap entries in a window, 0 -# otherwise. -# -# Arguments: -# w - Name of window in which to check. -# red, green, blue - Intensities to use in a trial color allocation -# to see if there are colormap entries free. - -proc colorsFree {w {red 31} {green 245} {blue 192}} { - lassign [winfo rgb $w [format "#%02x%02x%02x" $red $green $blue]] r g b - expr {($r/256 == $red) && ($g/256 == $green) && ($b/256 == $blue)} -} +# Import utility procs for specific functional areas +testutils import colors # uniq -- # @@ -1767,13 +1729,16 @@ test frame-15.14 {TIP 262: toplevel background images} -setup { deleteWindows catch {image delete gorp} } -result {{gorp get} {gorp display 0 0 30 15} {gorp display 0 0 30 10} {gorp display 0 0 20 15} {gorp display 0 0 20 10}} - -# cleanup + +# +# CLEANUP +# + deleteWindows apply {cmds {foreach cmd $cmds {rename $cmd {}}}} { - eatColors colorsFree uniq optnames + uniq optnames } - +testutils forget colors cleanupTests return diff --git a/tests/geometry.test b/tests/geometry.test index 1588bb9..231da90 100644 --- a/tests/geometry.test +++ b/tests/geometry.test @@ -7,11 +7,6 @@ # Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. -proc getsize w { - regexp {(^[^+-]*)} [wm geometry $w] foo x - return $x -} - package require tcltest 2.2 eval tcltest::configure $argv tcltest::loadTestedCommands diff --git a/tests/image.test b/tests/image.test index e149a26..e3cd268 100644 --- a/tests/image.test +++ b/tests/image.test @@ -12,6 +12,9 @@ namespace import ::tcltest::* eval tcltest::configure $argv tcltest::loadTestedCommands +# Import utility procs for specific functional areas +testutils import image + imageInit # Canvas used in some tests in the whole file @@ -585,10 +588,13 @@ test image-15.1 {deleting image does not make widgets forget about it} -setup { imageCleanup } -result {10 10 20 20 foo {} {10 10 30 30} foo} +# +# CLEANUP +# + destroy .c imageFinish - -# cleanup +testutils forget image cleanupTests return diff --git a/tests/imgBmap.test b/tests/imgBmap.test index c498c90..95cfab3 100644 --- a/tests/imgBmap.test +++ b/tests/imgBmap.test @@ -11,6 +11,10 @@ package require tcltest 2.2 namespace import ::tcltest::* eval tcltest::configure $argv tcltest::loadTestedCommands + +# Import utility procs for specific functional areas +testutils import image + imageInit set data1 {#define foo_width 16 @@ -506,11 +510,14 @@ test imageBmap-12.1 {ImgBmapCmdDeletedProc procedure} -body { list [expr {"i2" in [imageNames]}] [catch {i2 foo} msg] $msg } -result {0 1 {invalid command name "i2"}} +# +# CLEANUP +# + removeFile foo.bm removeFile foo2.bm imageFinish - -# cleanup +testutils forget image cleanupTests return diff --git a/tests/imgListFormat.test b/tests/imgListFormat.test index f7f2553..cc43dff 100644 --- a/tests/imgListFormat.test +++ b/tests/imgListFormat.test @@ -12,6 +12,9 @@ namespace import ::tcltest::* tcltest::configure {*}$argv tcltest::loadTestedCommands +# Import utility procs for specific functional areas +testutils import image + imageInit set teapotPhotoFile [file join [file dirname [info script]] teapot.ppm] @@ -19,7 +22,7 @@ set transpTeapotPhotoFile [file join [file dirname [info script]] teapotTranspar # --------------------------------------------------------------------- - + test imgListFormat-1.1 {ParseFormatOptions: default values} -setup { image create photo photo1 } -body { @@ -103,9 +106,9 @@ test imgListFormat-1.11 {valid colorformats} -setup { imageCleanup unset result } -result {{{#ffffff}} {{#ffffff78}} {{{255 255 255 120}}}} - + # GetBadOptMsg: only use case already tested with imgListFormat-1.4 - + test imgListFormat-3.1 {StringMatchDef: data is not a list} -body { testphotostringmatch {not a " proper list} # " (this comment is here only for editor highlighting) @@ -147,7 +150,7 @@ test imgListFormat-3.5 {StringMatchDef: valid data} -setup { } -cleanup { imageCleanup } -result {2 3 {0 0 0 255}} - + # ImgStringRead: most of the error cases cannot be tested with current code, # as the errors are detected by StringMatchDef test imgListFormat-4.1 {StringReadDef: use with -format opt} -setup { @@ -193,7 +196,7 @@ test imgListFormat-4.5 {StringReadDef: correct compositing rule} -setup { } -cleanup { imageCleanup } -result {{255 0 0 255} {0 78 185 225} {255 0 0 255}} - + test imgListFormat-5.1 {StringWriteDef: format options not a list} -setup { image create photo photo1 } -body { @@ -308,7 +311,7 @@ test imgListFormat-5.10 {StringWriteDef: test some pixels #5} -setup { unset result imageCleanup } -result {{0 78 185 225} {161 65 0 170} {255 202 159 175}} - + test imgListFormat-6.1 {ParseColor: empty string} -setup { image create photo photo1 set result {} @@ -397,7 +400,7 @@ test imgListFormat-6.8 {ParseColor: overall test} -setup { {255 250 250 128} {255 238 238 136} {255 238 238 128} {255 238 238 128}\ {255 250 250 128} {255 250 250 136} {255 250 250 128} {255 250 250 128}\ {255 250 250 255} {255 238 238 136} {255 250 250 128} {255 250 250 255}} - + # Note: these tests were written for an earlier implementation of # ParseColorAsList. For this reason, their order and layout do not follow the # current code very well. Test coverage is pretty good, nevertheless. @@ -476,7 +479,7 @@ test imgListFormat-7.10 {ParseColorAsList: list format, string rep} -setup { } -cleanup { imageCleanup } -result {111 222 33 44} - + test imgListFormat-8.1 {ParseColorAsHex: RGB format} -setup { image create photo photo1 } -body { @@ -508,7 +511,7 @@ test imgListFormat-8.4 {ParseColor: valid #RGBA color} -setup { } -cleanup { imageCleanup } -result {{155 213 2 13} {119 170 204 255}} - + test imgListFormat-9.1 {ParseColorAsStandard: Tk color, valid suffixes} -setup { image create photo photo1 @@ -633,11 +636,11 @@ test imgListFormat-9.14 {ParseColorAsStandard: suffix not allowed #2} -setup { imageCleanup } -returnCodes error -result {invalid color name "#1111#1"} - -# --------------------------------------------------------------------- +# +# CLEANUP +# imageFinish - -# cleanup +testutils forget image cleanupTests return diff --git a/tests/imgPNG.test b/tests/imgPNG.test index ab65842..ce39b06 100644 --- a/tests/imgPNG.test +++ b/tests/imgPNG.test @@ -12,6 +12,10 @@ package require tcltest 2.2 namespace import ::tcltest::* eval tcltest::configure $argv tcltest::loadTestedCommands + +# Import utility procs for specific functional areas +testutils import image + imageInit namespace eval png { @@ -1060,7 +1064,7 @@ r661tV1eju/ne8YJrkWtES0tmRe2VOviv2j2aBp5nHihiRaz/A4oCnsAsje/+AAAAAElFTkSuQmCC" "iVBORw0KGgoAAAANSUhEUgAAAAIAAAACCAIAAAD91JpzAAAACXBIWXMAAA9hAAAewgEw8YEEAAAA FklEQVR4nGP4+vXrP11lJgYGhj9xSQAzOwXsETZ69QAAAABJRU5ErkJggg==" } - + # $encoded(basn0g08), $encoded(basn2c08), $encoded(basn3p08), $encoded(basn6a08) test imgPNG-1.1 {reading basic images; grayscale} -setup { catch {rename foo ""} @@ -1164,8 +1168,13 @@ test imgPNG-4.4 {file output with metadata} -setup { } +# +# CLEANUP +# + namespace delete png imageFinish +testutils forget image cleanupTests return diff --git a/tests/imgPPM.test b/tests/imgPPM.test index 2458107..907098f 100644 --- a/tests/imgPPM.test +++ b/tests/imgPPM.test @@ -11,6 +11,9 @@ namespace import ::tcltest::* eval tcltest::configure $argv tcltest::loadTestedCommands +# Import utility procs for specific functional areas +testutils import image + imageInit # Note that we do not use [tcltest::makeFile] because it is @@ -21,7 +24,7 @@ proc put {file data} { puts -nonewline $f $data close $f } - + test imgPPM-1.1 {FileReadPPM procedure} -body { put test.ppm "P6\n0 256\n255\nabcdef" image create photo p1 -file test.ppm @@ -225,11 +228,14 @@ test imgPPM-5.9 {StringReadPPM procedure} -setup { } -cleanup { image delete ppm } -result {5 4} - -imageFinish -# cleanup +# +# CLEANUP +# + +imageFinish catch {file delete test.ppm} +testutils forget image cleanupTests return diff --git a/tests/imgPhoto.test b/tests/imgPhoto.test index d3a2b80..d01ca1f 100644 --- a/tests/imgPhoto.test +++ b/tests/imgPhoto.test @@ -79,6 +79,9 @@ namespace import ::tcltest::* tcltest::configure {*}$argv tcltest::loadTestedCommands +# Import utility procs for specific functional areas +testutils import image + # # Used for imgPhoto-4.65 - imgPhoto-4.73 # @@ -190,7 +193,7 @@ test imgPhoto-1.13 {option -withalpha, normal use} -setup { test imgPhoto-1.14 {options for photo images - error case} -body { image create photo photo1 -metadata } -returnCodes error -result {value for "-metadata" missing} - + test imgPhoto-2.1 {ImgPhotoCreate procedure} -setup { imageCleanup } -body { @@ -271,7 +274,7 @@ test imgPhoto-3.6 {ImgPhotoConfigureModel: -data <default>} -setup { } -cleanup { imageCleanup } -result {20 20} - + test imgPhoto-4.1 {ImgPhotoCmd procedure} -setup { image create photo photo1 } -body { @@ -1314,7 +1317,7 @@ test imgPhoto-4.118 {ImgPhotoCmd data: using data for new image unset result imageCleanup } -result {} - + test imgPhoto-5.1 {ImgPhotoGet/Free procedures, shared instances} -setup { destroy .c pack [canvas .c] @@ -1808,7 +1811,7 @@ test imgPhoto-18.1 {MatchFileFormat: "default" format not supported} -setup { catch {removeFile $f} unset f } -returnCodes error -result {-file option isn't supported for default images} - + test imgPhoto-19.1 {MatchStringFormat: with "-format default"} -setup { image create photo photo1 } -body { @@ -2700,13 +2703,17 @@ test imgPhoto-25.6 {Read PNG file with -from option, read large region from smal } -result {{coordinates for -from option extend outside source image} 0 0} unset ousterPhotoFile +# +# CLEANUP +# + catch {rename foreachPixel {}} catch {rename checkImgTrans {}} catch {rename checkImgTransLoop {}} imageFinish - -# cleanup removeFile README-imgPhoto + +testutils forget image cleanupTests return diff --git a/tests/imgSVGnano.test b/tests/imgSVGnano.test index dc1bf45..222222e 100644 --- a/tests/imgSVGnano.test +++ b/tests/imgSVGnano.test @@ -9,6 +9,10 @@ package require tcltest 2.2 namespace import ::tcltest::* eval tcltest::configure $argv tcltest::loadTestedCommands + +# Import utility procs for specific functional areas +testutils import image + imageInit namespace eval svgnano { @@ -253,8 +257,13 @@ test imgSVGnano-5.2 {bug d6e9b4db40 - "<svg" and ">" must be present} -body { };# end of namespace svgnano +# +# CLEANUP +# + namespace delete svgnano imageFinish +testutils forget image cleanupTests return diff --git a/tests/listbox.test b/tests/listbox.test index c4b7c15..2deebc4 100644 --- a/tests/listbox.test +++ b/tests/listbox.test @@ -3210,10 +3210,13 @@ test listbox-32.2 {Bug [5d991b822e]} { unset new } {} +# +# CLEANUP +# + resetGridInfo deleteWindows option clear - -# cleanup +rename getsize {} cleanupTests return diff --git a/tests/main.tcl b/tests/main.tcl new file mode 100644 index 0000000..d7cc999 --- /dev/null +++ b/tests/main.tcl @@ -0,0 +1,66 @@ +# main.tcl -- +# +# This file is loaded by each test file when invoking "tcltest::loadTestedCommands". +# It performs an initial Tk setup for the root window, and loads, in turn, +# definitions of global utility procs and test constraints. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. + +# +# SETUP FOR APPLICATION AND ROOT WINDOW +# +if {[namespace exists tk::test]} { + # reset windows + deleteWindows + wm geometry . {} + raise . + return +} + +package require tk +tk appname tktest +wm title . tktest +# If the main window isn't already mapped (e.g. because the tests are +# being run automatically) , specify a precise size for it so that the +# user won't have to position it manually. + +if {![winfo ismapped .]} { + wm geometry . +0+0 + update +} + +# +# LOAD AND CONFIGURE TEST HARNESS +# +package require tcltest 2.2 +eval tcltest::configure $argv +namespace import -force tcltest::test +namespace import -force tcltest::makeFile +namespace import -force tcltest::removeFile +namespace import -force tcltest::makeDirectory +namespace import -force tcltest::removeDirectory +namespace import -force tcltest::interpreter +namespace import -force tcltest::testsDirectory +namespace import -force tcltest::cleanupTests + +# +# SOURCE DEFINITIONS OF GLOBAL UTILITY PROCS AND CONSTRAINTS +# +# Note: tcltest uses [uplevel] to evaluate this script. Therefore, [info script] +# cannot be used to determine the main Tk test directory, and we use +# [tcltest::configure -loadfile] instead. +# +set mainTestDir [file dirname [tcltest::configure -loadfile]] +source [file join $mainTestDir testutils.tcl] +source [file join $mainTestDir constraints.tcl] +unset mainTestDir + +# +# RESET WINDOWS +# +deleteWindows +wm geometry . {} +raise . + +# EOF diff --git a/tests/menu.test b/tests/menu.test index 912b0a7..1b3bddd 100644 --- a/tests/menu.test +++ b/tests/menu.test @@ -9,6 +9,10 @@ package require tcltest 2.2 namespace import ::tcltest::* eval tcltest::configure $argv tcltest::loadTestedCommands + +# Import utility procs for specific functional areas +testutils import image + imageInit @@ -4282,9 +4286,13 @@ test menu-41.14 {identifiers - reserved word} -setup { destroy .m } -result {2} -# cleanup +# +# CLEANUP +# + imageFinish deleteWindows +testutils forget image cleanupTests return diff --git a/tests/menuDraw.test b/tests/menuDraw.test index 9456ae1..95601f4 100644 --- a/tests/menuDraw.test +++ b/tests/menuDraw.test @@ -9,6 +9,10 @@ package require tcltest 2.2 eval tcltest::configure $argv tcltest::loadTestedCommands namespace import -force tcltest::test + +# Import utility procs for specific functional areas +testutils import image + imageInit test menuDraw-1.1 {TkMenuInitializeDrawingFields} -setup { @@ -706,9 +710,13 @@ test menuDraw-17.2 {AdjustMenuCoords - menu} -constraints { deleteWindows } -result {} -# cleanup +# +# CLEANUP +# + imageFinish deleteWindows +testutils forget image cleanupTests return diff --git a/tests/menubut.test b/tests/menubut.test index f997e55..cbfb977 100644 --- a/tests/menubut.test +++ b/tests/menubut.test @@ -14,6 +14,10 @@ package require tcltest 2.2 eval tcltest::configure $argv tcltest::loadTestedCommands namespace import -force tcltest::test + +# Import utility procs for specific functional areas +testutils import image + imageInit # Create entries in the option database to be sure that geometry options @@ -779,14 +783,15 @@ test menubutton-9.2 {Bug [5d991b822e]} { unset new } {} - - +# +# CLEANUP +# deleteWindows option clear imageFinish -# cleanup +testutils forget image cleanupTests return diff --git a/tests/msgbox.test b/tests/msgbox.test index 60955a4..0e92dfa 100644 --- a/tests/msgbox.test +++ b/tests/msgbox.test @@ -10,6 +10,8 @@ eval tcltest::configure $argv tcltest::loadTestedCommands namespace import -force tcltest::test +# Import utility procs for specific functional areas +testutils import dialog test msgbox-1.1.1 {tk_messageBox command} -constraints notAqua -body { tk_messageBox -foo @@ -75,47 +77,18 @@ test msgbox-1.19 {tk_messageBox command} -body { } -returnCodes error -result {bad window path name "foo.bar"} -catch {tk_messageBox -foo bar} -set isNative [expr {[info commands tk::MessageBox] == ""}] - proc ChooseMsg {parent btn} { - global isNative - if {!$isNative} { - after 100 SendEventToMsg $parent $btn mouse + if {! $::dialogIsNative} { + after 100 SendButtonPress $parent $btn mouse } } proc ChooseMsgByKey {parent btn} { - global isNative - if {!$isNative} { - after 100 SendEventToMsg $parent $btn key + if {! $::dialogIsNative} { + after 100 SendButtonPress $parent $btn key } } -proc PressButton {btn} { - event generate $btn <Enter> - event generate $btn <Button-1> -x 5 -y 5 - event generate $btn <ButtonRelease-1> -x 5 -y 5 -} - -proc SendEventToMsg {parent btn type} { - if {$parent != "."} { - set w $parent.__tk__messagebox - } else { - set w .__tk__messagebox - } - if ![winfo ismapped $w.$btn] { - update - } - if {$type == "mouse"} { - PressButton $w.$btn - } else { - event generate $w <Enter> - focus $w - event generate $w.$btn <Enter> - event generate $w <Key> -keysym Return - } -} # # Try out all combinations of (type) x (default button) and # (type) x (icon). @@ -440,8 +413,10 @@ test msgbox-3.2 {tk_messageBox handles iconified parent} -constraints { wm deiconify . } -result {ok} -# cleanup +# +# CLEANUP +# + +testutils forget dialog cleanupTests return - - diff --git a/tests/pack.test b/tests/pack.test index db1bd88..3a332ed 100644 --- a/tests/pack.test +++ b/tests/pack.test @@ -11,9 +11,6 @@ eval tcltest::configure $argv tcltest::loadTestedCommands namespace import -force tcltest::test -testConstraint failsOnUbuntu [expr {![info exists ::env(CI)] || ![string match Linux $::tcl_platform(os)]}] -testConstraint failsOnXQuarz [expr {$tcl_platform(os) ne "Darwin" || [tk windowingsystem] ne "x11" }] - # Create some test windows. destroy .pack @@ -1536,7 +1533,7 @@ test pack-17.2 {PackLostContentProc procedure} -setup { # Tests pack-18.1.1 and pack-18.2 are constrained with failsOnUbuntu # because they are failing in the GitHub CI environment, using Linux Ubuntu. -# These tests are also constrained with failsOnXQuarz because they fail +# These tests are also constrained with failsOnXQuartz because they fail # on macOS when building with clang --disable-aqua (which uses XQuartz) # (this is the case both at GitHub CI and on a real Mac). # Analysis shows that, on both cases, WaitForMapNotify is giving up on @@ -1559,7 +1556,7 @@ test pack-17.2 {PackLostContentProc procedure} -setup { # colored. So, evidently, even though the size changes are honored, # the window is sometimes not completely configured. test pack-18.1.1 {unmap content when container unmapped} -constraints { - macOrUnix failsOnUbuntu failsOnXQuarz + macOrUnix failsOnUbuntu failsOnXQuartz } -setup { destroy {*}[winfo children .pack] # adjust the position of .pack before test to avoid a screen switch @@ -1605,7 +1602,7 @@ test pack-18.1.2 {unmap content when container unmapped} -constraints { lappend result [winfo ismapped .pack.a] } -result {1 0 200 75 1} -test pack-18.2 {unmap content when container unmapped} -constraints {failsOnUbuntu failsOnXQuarz} -setup { +test pack-18.2 {unmap content when container unmapped} -constraints {failsOnUbuntu failsOnXQuartz} -setup { destroy {*}[winfo children .pack] # adjust the position of .pack before test to avoid a screen switch # that occurs with window managers that have desktops four times as big @@ -1753,7 +1750,7 @@ test pack-20.6 {<<NoManagedChild>> does not fire on last pack forget if propagat bind . <<NoManagedChild>> {} destroy .1 } -result 0 - + # cleanup cleanupTests return diff --git a/tests/place.test b/tests/place.test index 4a2ee38..96cda0e 100644 --- a/tests/place.test +++ b/tests/place.test @@ -13,9 +13,6 @@ tcltest::loadTestedCommands # Used for constraining memory leak tests testConstraint memory [llength [info commands memory]] -testConstraint failsOnUbuntu [expr {![info exists ::env(CI)] || ![string match Linux $::tcl_platform(os)]}] -testConstraint failsOnXQuarz [expr {$tcl_platform(os) ne "Darwin" || [tk windowingsystem] ne "x11" }] - # XXX - This test file is woefully incomplete. At present, only a # few of the features are tested. @@ -263,7 +260,7 @@ test place-7.10 {ReconfigurePlacement procedure, computing size} -setup { # Tests place-8.1 and place-8.2 are constrained with failsOnUbuntu # because they are failing in the GitHub CI environment, using Linux Ubuntu. -# These tests are also constrained with failsOnXQuarz because they fail +# These tests are also constrained with failsOnXQuartz because they fail # on macOS when building with clang --disable-aqua (which uses XQuartz) # (this is the case both at GitHub CI and on a real Mac). # Analysis shows that, on both cases, WaitForMapNotify is giving up on @@ -271,7 +268,7 @@ test place-7.10 {ReconfigurePlacement procedure, computing size} -setup { # 'wm iconify'. The timeout delay (2s) is exceeded without the unmapping # having happened. The cause for this is unknown (see comments in WaitForMapNotify). -test place-8.1 {PlaceStructureProc, mapping and unmapping content} -constraints {failsOnUbuntu failsOnXQuarz} -setup { +test place-8.1 {PlaceStructureProc, mapping and unmapping content} -constraints {failsOnUbuntu failsOnXQuartz} -setup { place forget .t.f2 place forget .t.f } -body { @@ -287,7 +284,7 @@ test place-8.1 {PlaceStructureProc, mapping and unmapping content} -constraints update lappend result [winfo ismapped .t.f2] } -result {1 0 40 30 0 1} -test place-8.2 {PlaceStructureProc, mapping and unmapping content} -constraints {failsOnUbuntu failsOnXQuarz} -setup { +test place-8.2 {PlaceStructureProc, mapping and unmapping content} -constraints {failsOnUbuntu failsOnXQuartz} -setup { place forget .t.f2 place forget .t.f } -body { diff --git a/tests/safePrimarySelection.test b/tests/safePrimarySelection.test index 4605735..84d2d0f 100644 --- a/tests/safePrimarySelection.test +++ b/tests/safePrimarySelection.test @@ -11,6 +11,9 @@ namespace import ::tcltest::* eval tcltest::configure $argv tcltest::loadTestedCommands +# Import utility procs for specific functional areas +testutils import child + # ------------------------------------------------------------------------------ # Tests that a Safe Base interpreter cannot write to the PRIMARY selection. # ------------------------------------------------------------------------------ @@ -26,42 +29,12 @@ tcltest::loadTestedCommands # PRIMARY selection. # - A safe interpreter must not write to the PRIMARY selection. # - The spinbox, ttk::spinbox are variants of entry, ttk::entry respectively. +# - The command "childTkInterp" is not needed for Safe Base children because +# safe::loadTk does something similar and works correctly. # ------------------------------------------------------------------------------ namespace eval ::_test_tmp {} -# ------------------------------------------------------------------------------ -# Proc ::_test_tmp::unsafeInterp -# ------------------------------------------------------------------------------ -# Command that creates an child interpreter and tries to load Tk. -# - This is necessary for loading Tk if the tests are done in the build -# directory without installing Tk. In that case the usual auto_path loading -# mechanism cannot work because the tk binary is not where pkgIndex.tcl says -# it is. -# - This command is not needed for Safe Base children because safe::loadTk does -# something similar and works correctly. -# - Based on scripts in winSend.test. -# ------------------------------------------------------------------------------ - -namespace eval ::_test_tmp { - variable TkLoadCmd -} - -foreach pkg [info loaded] { - if {[lindex $pkg 1] eq "Tk"} { - set ::_test_tmp::TkLoadCmd [list load {*}$pkg] - break - } -} - -proc ::_test_tmp::unsafeInterp {name} { - variable TkLoadCmd - interp create $name - $name eval [list set argv [list -name $name]] - catch {{*}$TkLoadCmd $name} -} - - set ::_test_tmp::script { package require tk namespace eval ::_test_tmp {} @@ -337,7 +310,7 @@ test safePrimarySelection-2.1 {child interpreter, text, no existing selection} - ::_test_tmp::clearPrimarySelection } -body { set int2 child2 - ::_test_tmp::unsafeInterp $int2 + childTkInterp $int2 $int2 eval $::_test_tmp::script $int2 eval ::_test_tmp::tryText $int2 eval ::_test_tmp::getPrimarySelection @@ -354,7 +327,7 @@ test safePrimarySelection-2.2 {child interpreter, entry, no existing selection} ::_test_tmp::clearPrimarySelection } -body { set int2 child2 - ::_test_tmp::unsafeInterp $int2 + childTkInterp $int2 $int2 eval $::_test_tmp::script $int2 eval ::_test_tmp::tryEntry $int2 eval ::_test_tmp::getPrimarySelection @@ -371,7 +344,7 @@ test safePrimarySelection-2.3 {child interpreter, ttk::entry, no existing select ::_test_tmp::clearPrimarySelection } -body { set int2 child2 - ::_test_tmp::unsafeInterp $int2 + childTkInterp $int2 $int2 eval $::_test_tmp::script $int2 eval ::_test_tmp::tryTtkEntry $int2 eval ::_test_tmp::getPrimarySelection @@ -388,7 +361,7 @@ test safePrimarySelection-2.4 {child interpreter, listbox, no existing selection ::_test_tmp::clearPrimarySelection } -body { set int2 child2 - ::_test_tmp::unsafeInterp $int2 + childTkInterp $int2 $int2 eval $::_test_tmp::script $int2 eval ::_test_tmp::tryListbox $int2 eval ::_test_tmp::getPrimarySelection @@ -405,7 +378,7 @@ test safePrimarySelection-2.5 {child interpreter, spinbox as entry, no existing ::_test_tmp::clearPrimarySelection } -body { set int2 child2 - ::_test_tmp::unsafeInterp $int2 + childTkInterp $int2 $int2 eval $::_test_tmp::script $int2 eval ::_test_tmp::trySpinbox 1 $int2 eval ::_test_tmp::getPrimarySelection @@ -422,7 +395,7 @@ test safePrimarySelection-2.6 {child interpreter, spinbox spun, no existing sele ::_test_tmp::clearPrimarySelection } -body { set int2 child2 - ::_test_tmp::unsafeInterp $int2 + childTkInterp $int2 $int2 eval $::_test_tmp::script $int2 eval ::_test_tmp::trySpinbox 2 $int2 eval ::_test_tmp::getPrimarySelection @@ -439,7 +412,7 @@ test safePrimarySelection-2.7 {child interpreter, spinbox spun/selected/spun, no ::_test_tmp::clearPrimarySelection } -body { set int2 child2 - ::_test_tmp::unsafeInterp $int2 + childTkInterp $int2 $int2 eval $::_test_tmp::script $int2 eval ::_test_tmp::trySpinbox 3 $int2 eval ::_test_tmp::getPrimarySelection @@ -456,7 +429,7 @@ test safePrimarySelection-2.8 {child interpreter, ttk::spinbox as entry, no exis ::_test_tmp::clearPrimarySelection } -body { set int2 child2 - ::_test_tmp::unsafeInterp $int2 + childTkInterp $int2 $int2 eval $::_test_tmp::script $int2 eval ::_test_tmp::tryTtkSpinbox 1 $int2 eval ::_test_tmp::getPrimarySelection @@ -473,7 +446,7 @@ test safePrimarySelection-2.9 {child interpreter, ttk::spinbox spun, no existing ::_test_tmp::clearPrimarySelection } -body { set int2 child2 - ::_test_tmp::unsafeInterp $int2 + childTkInterp $int2 $int2 eval $::_test_tmp::script $int2 eval ::_test_tmp::tryTtkSpinbox 2 $int2 eval ::_test_tmp::getPrimarySelection @@ -490,7 +463,7 @@ test safePrimarySelection-2.10 {child interpreter, ttk::spinbox spun/selected/sp ::_test_tmp::clearPrimarySelection } -body { set int2 child2 - ::_test_tmp::unsafeInterp $int2 + childTkInterp $int2 $int2 eval $::_test_tmp::script $int2 eval ::_test_tmp::tryTtkSpinbox 3 $int2 eval ::_test_tmp::getPrimarySelection @@ -837,7 +810,7 @@ test safePrimarySelection-5.1 {child interpreter, text, existing selection} -set ::_test_tmp::setPrimarySelection } -body { set int2 child2 - ::_test_tmp::unsafeInterp $int2 + childTkInterp $int2 $int2 eval $::_test_tmp::script $int2 eval ::_test_tmp::tryText $int2 eval ::_test_tmp::getPrimarySelection @@ -854,7 +827,7 @@ test safePrimarySelection-5.2 {child interpreter, entry, existing selection} -se ::_test_tmp::setPrimarySelection } -body { set int2 child2 - ::_test_tmp::unsafeInterp $int2 + childTkInterp $int2 $int2 eval $::_test_tmp::script $int2 eval ::_test_tmp::tryEntry $int2 eval ::_test_tmp::getPrimarySelection @@ -871,7 +844,7 @@ test safePrimarySelection-5.3 {child interpreter, ttk::entry, existing selection ::_test_tmp::setPrimarySelection } -body { set int2 child2 - ::_test_tmp::unsafeInterp $int2 + childTkInterp $int2 $int2 eval $::_test_tmp::script $int2 eval ::_test_tmp::tryTtkEntry $int2 eval ::_test_tmp::getPrimarySelection @@ -888,7 +861,7 @@ test safePrimarySelection-5.4 {child interpreter, listbox, existing selection} - ::_test_tmp::setPrimarySelection } -body { set int2 child2 - ::_test_tmp::unsafeInterp $int2 + childTkInterp $int2 $int2 eval $::_test_tmp::script $int2 eval ::_test_tmp::tryListbox $int2 eval ::_test_tmp::getPrimarySelection @@ -905,7 +878,7 @@ test safePrimarySelection-5.5 {child interpreter, spinbox as entry, existing sel ::_test_tmp::setPrimarySelection } -body { set int2 child2 - ::_test_tmp::unsafeInterp $int2 + childTkInterp $int2 $int2 eval $::_test_tmp::script $int2 eval ::_test_tmp::trySpinbox 1 $int2 eval ::_test_tmp::getPrimarySelection @@ -922,7 +895,7 @@ test safePrimarySelection-5.6 {child interpreter, spinbox spun, existing selecti ::_test_tmp::setPrimarySelection } -body { set int2 child2 - ::_test_tmp::unsafeInterp $int2 + childTkInterp $int2 $int2 eval $::_test_tmp::script $int2 eval ::_test_tmp::trySpinbox 2 $int2 eval ::_test_tmp::getPrimarySelection @@ -939,7 +912,7 @@ test safePrimarySelection-5.7 {child interpreter, spinbox spun/selected/spun, ex ::_test_tmp::setPrimarySelection } -body { set int2 child2 - ::_test_tmp::unsafeInterp $int2 + childTkInterp $int2 $int2 eval $::_test_tmp::script $int2 eval ::_test_tmp::trySpinbox 3 $int2 eval ::_test_tmp::getPrimarySelection @@ -956,7 +929,7 @@ test safePrimarySelection-5.8 {child interpreter, ttk::spinbox as entry, existin ::_test_tmp::setPrimarySelection } -body { set int2 child2 - ::_test_tmp::unsafeInterp $int2 + childTkInterp $int2 $int2 eval $::_test_tmp::script $int2 eval ::_test_tmp::tryTtkSpinbox 1 $int2 eval ::_test_tmp::getPrimarySelection @@ -973,7 +946,7 @@ test safePrimarySelection-5.9 {child interpreter, ttk::spinbox spun, existing se ::_test_tmp::setPrimarySelection } -body { set int2 child2 - ::_test_tmp::unsafeInterp $int2 + childTkInterp $int2 $int2 eval $::_test_tmp::script $int2 eval ::_test_tmp::tryTtkSpinbox 2 $int2 eval ::_test_tmp::getPrimarySelection @@ -990,7 +963,7 @@ test safePrimarySelection-5.10 {child interpreter, ttk::spinbox spun/selected/sp ::_test_tmp::setPrimarySelection } -body { set int2 child2 - ::_test_tmp::unsafeInterp $int2 + childTkInterp $int2 $int2 eval $::_test_tmp::script $int2 eval ::_test_tmp::tryTtkSpinbox 3 $int2 eval ::_test_tmp::getPrimarySelection @@ -1211,10 +1184,11 @@ test safePrimarySelection-6.10 {IMPORTANT, safe interpreter, ttk::spinbox spun/s ::_test_tmp::clearPrimarySelection } -result {OLD_VALUE----OLD_VALUE} +# +# CLEANUP +# namespace delete ::_test_tmp - -# option clear -# cleanup +testutils forget child cleanupTests return diff --git a/tests/scrollbar.test b/tests/scrollbar.test index 0413f7d..f925a05 100644 --- a/tests/scrollbar.test +++ b/tests/scrollbar.test @@ -11,11 +11,6 @@ package require tcltest 2.2 eval tcltest::configure $argv tcltest::loadTestedCommands -proc scroll args { - global scrollInfo - set scrollInfo $args -} - proc getTroughSize {w} { if {[testConstraint testmetrics]} { # Only Windows has [testmetrics] @@ -137,7 +132,7 @@ test scrollbar-2.5 {Tk_ScrollbarCmd procedure} -setup { destroy .s } -result .s -scrollbar .s -orient vertical -command scroll -highlightthickness 2 -bd 2 +scrollbar .s -orient vertical -highlightthickness 2 -bd 2 pack .s -side right -fill y update test scrollbar-3.1 {ScrollbarWidgetCmd procedure} { diff --git a/tests/select.test b/tests/select.test index a55e279..661bd06 100644 --- a/tests/select.test +++ b/tests/select.test @@ -13,102 +13,25 @@ package require tcltest 2.2 namespace import ::tcltest::* -namespace import ::tk::test:loadTkCommand eval tcltest::configure $argv tcltest::loadTestedCommands +# Import utility procs for specific functional areas +testutils import child select + testConstraint cliboardManagerPresent 0 if {![catch {selection get -selection CLIPBOARD_MANAGER -type TARGETS}]} { if {"SAVE_TARGETS" in [selection get -selection CLIPBOARD_MANAGER -type TARGETS]} { testConstraint cliboardManagerPresent 1 } } -testConstraint failsOnUbuntu [expr {![info exists ::env(CI)] || ![string match Linux $::tcl_platform(os)]}] - -global longValue selValue selInfo - -set selValue {} -set selInfo {} - -proc handler {type offset count} { - global selValue selInfo - lappend selInfo $type $offset $count - set numBytes [expr {[string length $selValue] - $offset}] - if {$numBytes <= 0} { - return "" - } - string range $selValue $offset [expr {$numBytes+$offset}] -} - -proc errIncrHandler {type offset count} { - global selValue selInfo pass - if {$offset == 4000} { - if {$pass == 0} { - # Just sizing the selection; don't do anything here. - set pass 1 - } else { - # Fetching the selection; wait long enough to cause a timeout. - after 6000 - } - } - lappend selInfo $type $offset $count - set numBytes [expr {[string length $selValue] - $offset}] - if {$numBytes <= 0} { - return "" - } - string range $selValue $offset [expr {$numBytes+$offset}] -} - -proc errHandler args { - error "selection handler aborted" -} - -proc badHandler {path type offset count} { - global selValue selInfo - selection handle -type $type $path {} - lappend selInfo $path $type $offset $count - set numBytes [expr {[string length $selValue] - $offset}] - if {$numBytes <= 0} { - return "" - } - string range $selValue $offset [expr {$numBytes+$offset}] -} -proc reallyBadHandler {path type offset count} { - global selValue selInfo pass - if {$offset == 4000} { - if {$pass == 0} { - set pass 1 - } else { - selection handle -type $type $path {} - } - } - lappend selInfo $path $type $offset $count - set numBytes [expr {[string length $selValue] - $offset}] - if {$numBytes <= 0} { - return "" - } - string range $selValue $offset [expr {$numBytes+$offset}] -} # Eliminate any existing selection on the screen. This is needed in case # there is a selection in some other application, in order to prevent races # from causing false errors in the tests below. - selection clear . after 1500 -# common setup code -proc setup {{path .f1} {display {}}} { - catch {destroy $path} - if {$display == {}} { - frame $path - } else { - toplevel $path -screen $display - wm geom $path +0+0 - } - selection own $path -} - # set up a very large buffer to test INCR retrievals set longValue "" foreach i {a b c d e f g j h i j k l m o p q r s t u v w x y z} { @@ -117,21 +40,20 @@ foreach i {a b c d e f g j h i j k l m o p q r s t u v w x y z} { } # Now we start the main body of the test code - + test select-1.1 {Tk_CreateSelHandler procedure} -setup { - setup + selectionSetup } -body { lsort [selection get TARGETS] } -result {MULTIPLE TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW} test select-1.2 {Tk_CreateSelHandler procedure} -setup { - setup + selectionSetup } -body { selection handle .f1 {handler TEST} TEST lsort [selection get TARGETS] } -result {MULTIPLE TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW} test select-1.3 {Tk_CreateSelHandler procedure} -setup { - global selValue selInfo - setup + selectionSetup } -body { selection handle .f1 {handler TEST} TEST set selValue "Test value" @@ -139,22 +61,21 @@ test select-1.3 {Tk_CreateSelHandler procedure} -setup { list [selection get TEST] $selInfo } -result {{Test value} {TEST 0 4000}} test select-1.4.1 {Tk_CreateSelHandler procedure} -constraints unix -setup { - setup + selectionSetup } -body { selection handle .f1 {handler TEST} TEST selection handle .f1 {handler STRING} lsort [selection get TARGETS] } -result {MULTIPLE STRING TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW UTF8_STRING} test select-1.4.2 {Tk_CreateSelHandler procedure} -constraints win -setup { - setup + selectionSetup } -body { selection handle .f1 {handler TEST} TEST selection handle .f1 {handler STRING} lsort [selection get TARGETS] } -result {MULTIPLE STRING TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW} test select-1.5 {Tk_CreateSelHandler procedure} -setup { - global selValue selInfo - setup + selectionSetup } -body { selection handle .f1 {handler TEST} TEST selection handle .f1 {handler STRING} @@ -163,8 +84,7 @@ test select-1.5 {Tk_CreateSelHandler procedure} -setup { list [selection get] $selInfo } -result {{} {STRING 0 4000}} test select-1.6.1 {Tk_CreateSelHandler procedure} -constraints unix -setup { - global selValue selInfo - setup + selectionSetup } -body { selection handle .f1 {handler TEST} TEST selection handle .f1 {handler STRING} @@ -177,8 +97,7 @@ test select-1.6.1 {Tk_CreateSelHandler procedure} -constraints unix -setup { list $selInfo [lsort [selection get TARGETS]] } -result {{STRING 0 4000 TEST 0 4000 TEST2 0 4000} {MULTIPLE STRING TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW UTF8_STRING}} test select-1.6.2 {Tk_CreateSelHandler procedure} -constraints win -setup { - global selValue selInfo - setup + selectionSetup } -body { selection handle .f1 {handler TEST} TEST selection handle .f1 {handler STRING} @@ -191,7 +110,7 @@ test select-1.6.2 {Tk_CreateSelHandler procedure} -constraints win -setup { list $selInfo [lsort [selection get TARGETS]] } -result {{STRING 0 4000 TEST 0 4000 TEST2 0 4000} {MULTIPLE STRING TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW}} test select-1.7.1 {Tk_CreateSelHandler procedure} -constraints unix -setup { - setup + selectionSetup } -body { selection own -selection CLIPBOARD .f1 selection handle -selection CLIPBOARD .f1 {handler TEST} TEST @@ -200,7 +119,7 @@ test select-1.7.1 {Tk_CreateSelHandler procedure} -constraints unix -setup { [lsort [selection get -selection CLIPBOARD TARGETS]] } -result {{MULTIPLE STRING TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW UTF8_STRING} {MULTIPLE TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW}} test select-1.7.2 {Tk_CreateSelHandler procedure} -constraints win -setup { - setup + selectionSetup } -body { selection own -selection CLIPBOARD .f1 selection handle -selection CLIPBOARD .f1 {handler TEST} TEST @@ -209,7 +128,7 @@ test select-1.7.2 {Tk_CreateSelHandler procedure} -constraints win -setup { [lsort [selection get -selection CLIPBOARD TARGETS]] } -result {{MULTIPLE STRING TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW} {MULTIPLE TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW}} test select-1.8 {Tk_CreateSelHandler procedure} -setup { - setup + selectionSetup } -body { selection handle -format INTEGER -type TEST .f1 {handler TEST} lsort [selection get TARGETS] @@ -218,7 +137,7 @@ test select-1.8 {Tk_CreateSelHandler procedure} -setup { ############################################################################## test select-2.1 {Tk_DeleteSelHandler procedure} -constraints unix -setup { - setup + selectionSetup } -body { selection handle .f1 {handler STRING} selection handle -type TEST .f1 {handler TEST} @@ -228,7 +147,7 @@ test select-2.1 {Tk_DeleteSelHandler procedure} -constraints unix -setup { lappend result [lsort [selection get TARGETS]] } -result {{MULTIPLE STRING TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW USER UTF8_STRING} {MULTIPLE STRING TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW USER UTF8_STRING}} test select-2.2 {Tk_DeleteSelHandler procedure} -constraints unix -setup { - setup + selectionSetup } -body { selection handle .f1 {handler STRING} selection handle -type TEST .f1 {handler TEST} @@ -238,7 +157,7 @@ test select-2.2 {Tk_DeleteSelHandler procedure} -constraints unix -setup { lappend result [lsort [selection get TARGETS]] } -result {{MULTIPLE STRING TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW USER UTF8_STRING} {MULTIPLE STRING TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW UTF8_STRING}} test select-2.3 {Tk_DeleteSelHandler procedure} -constraints unix -setup { - setup + selectionSetup } -body { selection own -selection CLIPBOARD .f1 selection handle -selection PRIMARY .f1 {handler STRING} @@ -248,7 +167,7 @@ test select-2.3 {Tk_DeleteSelHandler procedure} -constraints unix -setup { [lsort [selection get -selection CLIPBOARD TARGETS]] } -result {{MULTIPLE STRING TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW UTF8_STRING} {MULTIPLE TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW}} test select-2.4 {Tk_DeleteSelHandler procedure} -constraints win -setup { - setup + selectionSetup } -body { selection handle .f1 {handler STRING} selection handle -type TEST .f1 {handler TEST} @@ -258,7 +177,7 @@ test select-2.4 {Tk_DeleteSelHandler procedure} -constraints win -setup { lappend result [lsort [selection get TARGETS]] } -result {{MULTIPLE STRING TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW USER} {MULTIPLE STRING TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW USER}} test select-2.5 {Tk_DeleteSelHandler procedure} -constraints win -setup { - setup + selectionSetup } -body { selection handle .f1 {handler STRING} selection handle -type TEST .f1 {handler TEST} @@ -268,7 +187,7 @@ test select-2.5 {Tk_DeleteSelHandler procedure} -constraints win -setup { lappend result [lsort [selection get TARGETS]] } -result {{MULTIPLE STRING TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW USER} {MULTIPLE STRING TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW}} test select-2.6 {Tk_DeleteSelHandler procedure} -constraints win -setup { - setup + selectionSetup } -body { selection own -selection CLIPBOARD .f1 selection handle -selection PRIMARY .f1 {handler STRING} @@ -278,7 +197,7 @@ test select-2.6 {Tk_DeleteSelHandler procedure} -constraints win -setup { [lsort [selection get -selection CLIPBOARD TARGETS]] } -result {{MULTIPLE STRING TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW} {MULTIPLE TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW}} test select-2.7 {Tk_DeleteSelHandler procedure} -setup { - setup + selectionSetup } -body { selection handle .f1 {handler STRING} list [selection handle .f1 {}] [selection handle .f1 {}] @@ -287,26 +206,26 @@ test select-2.7 {Tk_DeleteSelHandler procedure} -setup { ############################################################################## test select-3.1 {Tk_OwnSelection procedure} -setup { - setup + selectionSetup } -body { selection own } -result {.f1} test select-3.2 {Tk_OwnSelection procedure} -body { - setup .f1 + selectionSetup .f1 set result [selection own] - setup .f2 + selectionSetup .f2 lappend result [selection own] } -result {.f1 .f2} test select-3.3 {Tk_OwnSelection procedure} -setup { - setup .f1 - setup .f2 + selectionSetup .f1 + selectionSetup .f2 } -body { selection own -selection CLIPBOARD .f1 list [selection own] [selection own -selection CLIPBOARD] } -result {.f2 .f1} test select-3.4 {Tk_OwnSelection procedure} -setup { global lostSel - setup + selectionSetup } -body { set lostSel {owned} selection own -command { set lostSel {lost} } .f1 @@ -315,8 +234,8 @@ test select-3.4 {Tk_OwnSelection procedure} -setup { } -result {lost} test select-3.5 {Tk_OwnSelection procedure} -setup { global lostSel - setup .f1 - setup .f2 + selectionSetup .f1 + selectionSetup .f2 } -body { set lostSel {owned} selection own -command { set lostSel {lost1} } .f1 @@ -325,7 +244,7 @@ test select-3.5 {Tk_OwnSelection procedure} -setup { } -result {lost1 .f2} test select-3.6 {Tk_OwnSelection procedure} -setup { global lostSel - setup + selectionSetup } -body { set lostSel {owned} selection own -command { set lostSel {lost1} } .f1 @@ -336,29 +255,29 @@ test select-3.6 {Tk_OwnSelection procedure} -setup { } -result {owned lost2} test select-3.7 {Tk_OwnSelection procedure} -constraints x11 -setup { global lostSel - setup - setupbg + selectionSetup + childTkProcess create } -body { set lostSel {owned} selection own -command { set lostSel {lost1} } .f1 update set result {} - lappend result [dobg { selection own . }] - lappend result [dobg {selection own}] + lappend result [childTkProcess eval { selection own . }] + lappend result [childTkProcess eval {selection own}] update - cleanupbg + childTkProcess exit lappend result $lostSel } -result {{} . lost1} # check reentrancy on selection replacement test select-3.8 {Tk_OwnSelection procedure} -setup { - setup + selectionSetup } -body { selection own -selection CLIPBOARD -command { destroy .f1 } .f1 selection own -selection CLIPBOARD . } -result {} test select-3.9 {Tk_OwnSelection procedure} -setup { - setup .f2 - setup .f1 + selectionSetup .f2 + selectionSetup .f1 } -body { selection own -selection CLIPBOARD -command { destroy .f2 } .f1 selection own -selection CLIPBOARD .f2 @@ -367,59 +286,59 @@ test select-3.9 {Tk_OwnSelection procedure} -setup { test select-3.10 {Tk_OwnSelection procedure} -constraints { altDisplay } -body { - setup .f1 - setup .f2 $env(TK_ALT_DISPLAY) + selectionSetup .f1 + selectionSetup .f2 $env(TK_ALT_DISPLAY) list [selection own -displayof .f1] [selection own -displayof .f2] } -result {.f1 .f2} test select-3.11 {Tk_OwnSelection procedure} -constraints { altDisplay } -setup { - setup .f1 - setup .f2 $env(TK_ALT_DISPLAY) - setupbg + selectionSetup .f1 + selectionSetup .f2 $env(TK_ALT_DISPLAY) + childTkProcess create update set result "" } -body { - lappend result [dobg "toplevel .t -screen $env(TK_ALT_DISPLAY); wm geom .t +0+0; selection own .t; update"] + lappend result [childTkProcess eval "toplevel .t -screen $env(TK_ALT_DISPLAY); wm geom .t +0+0; selection own .t; update"] lappend result [selection own -displayof .f1] \ [selection own -displayof .f2] } -cleanup { - cleanupbg + childTkProcess exit } -result {{} .f1 {}} ############################################################################## test select-4.1 {Tk_ClearSelection procedure} -setup { - setup + selectionSetup } -body { set result [selection own] selection clear .f1 lappend result [selection own] } -result {.f1 {}} test select-4.2 {Tk_ClearSelection procedure} -setup { - setup + selectionSetup } -body { selection own -selection CLIPBOARD .f1 selection clear .f1 selection own -selection CLIPBOARD } -result {.f1} test select-4.3 {Tk_ClearSelection procedure} -setup { - setup + selectionSetup } -body { list [selection clear .f1] [selection clear .f1] } -result {{} {}} test select-4.4 {Tk_ClearSelection procedure} -constraints x11 -setup { global lostSel - setup - setupbg + selectionSetup + childTkProcess create } -body { set lostSel {owned} selection own -command { set lostSel {lost1} } .f1 update set result {} - lappend result [dobg {selection clear; update}] + lappend result [childTkProcess eval {selection clear; update}] update - cleanupbg + childTkProcess exit lappend result [selection own] } -result {{} {}} # multiple display tests @@ -427,8 +346,8 @@ test select-4.5 {Tk_ClearSelection procedure} -constraints { altDisplay } -setup { global lostSel lostSel2 - setup .f1 - setup .f2 $env(TK_ALT_DISPLAY) + selectionSetup .f1 + selectionSetup .f2 $env(TK_ALT_DISPLAY) } -body { set lostSel {owned} set lostSel2 {owned2} @@ -442,9 +361,9 @@ test select-4.5 {Tk_ClearSelection procedure} -constraints { test select-4.6 {Tk_ClearSelection procedure} -constraints { x11 altDisplay } -setup { - setup .f1 - setup .f2 $env(TK_ALT_DISPLAY) - setupbg + selectionSetup .f1 + selectionSetup .f2 $env(TK_ALT_DISPLAY) + childTkProcess create } -body { set lostSel {owned} set lostSel2 {owned2} @@ -452,27 +371,27 @@ test select-4.6 {Tk_ClearSelection procedure} -constraints { selection own -command { set lostSel2 {lost2} } .f2 update set result "" - lappend result [dobg "toplevel .t -screen $env(TK_ALT_DISPLAY); wm geom .t +0+0; selection own .t; update"] + lappend result [childTkProcess eval "toplevel .t -screen $env(TK_ALT_DISPLAY); wm geom .t +0+0; selection own .t; update"] lappend result [selection own -displayof .f1] \ [selection own -displayof .f2] $lostSel $lostSel2 - cleanupbg + childTkProcess exit set result } -result {{} .f1 {} owned lost2} ############################################################################## test select-5.1 {Tk_GetSelection procedure} -returnCodes error -setup { - setup + selectionSetup } -body { selection get TEST } -result {PRIMARY selection doesn't exist or form "TEST" not defined} test select-5.2 {Tk_GetSelection procedure} -setup { - setup + selectionSetup } -body { selection get TK_WINDOW } -result {.f1} test select-5.3 {Tk_GetSelection procedure} -setup { - setup + selectionSetup } -body { selection handle -selection PRIMARY .f1 {handler TEST} TEST set selValue "Test value" @@ -480,13 +399,13 @@ test select-5.3 {Tk_GetSelection procedure} -setup { list [selection get TEST] $selInfo } -result {{Test value} {TEST 0 4000}} test select-5.4 {Tk_GetSelection procedure} -setup { - setup + selectionSetup } -returnCodes error -body { selection handle .f1 ERROR errHandler selection get ERROR } -result {PRIMARY selection doesn't exist or form "ERROR" not defined} test select-5.5 {Tk_GetSelection procedure} -setup { - setup + selectionSetup } -body { set selValue $longValue set selInfo "" @@ -494,7 +413,7 @@ test select-5.5 {Tk_GetSelection procedure} -setup { list [selection get] $selInfo } -result "$longValue {STRING 0 4000 STRING 4000 4000 STRING 8000 4000 STRING 12000 4000 STRING 16000 4000}" test select-5.6 {Tk_GetSelection procedure} -setup { - setup + selectionSetup } -returnCodes error -body { set selValue $longValue set selInfo "" @@ -505,7 +424,7 @@ test select-5.6 {Tk_GetSelection procedure} -setup { selection get } -result {PRIMARY selection doesn't exist or form "STRING" not defined} test select-5.7 {Tk_GetSelection procedure} -setup { - setup + selectionSetup } -returnCodes error -body { set selValue "Test Value" set selInfo "" @@ -516,7 +435,7 @@ test select-5.7 {Tk_GetSelection procedure} -setup { selection get } -result {PRIMARY selection doesn't exist or form "STRING" not defined} test select-5.8 {Tk_GetSelection procedure} -setup { - setup + selectionSetup } -body { set selValue $longValue set selInfo "" @@ -527,21 +446,21 @@ test select-5.8 {Tk_GetSelection procedure} -setup { list [selection get] $selInfo [catch {selection get} msg] $msg } -result "$longValue {STRING 0 4000 STRING 4000 4000 STRING 8000 4000 STRING 12000 4000 STRING 16000 4000} 1 {PRIMARY selection doesn't exist or form \"STRING\" not defined}" test select-5.9 {Tk_GetSelection procedure} -constraints x11 -setup { - setup - setupbg + selectionSetup + childTkProcess create } -body { selection handle -selection PRIMARY .f1 {handler TEST} TEST update set selValue "Test value" set selInfo "" set result "" - lappend result [dobg {selection get TEST}] - cleanupbg + lappend result [childTkProcess eval {selection get TEST}] + childTkProcess exit lappend result $selInfo } -result {{Test value} {TEST 0 4000}} test select-5.10 {Tk_GetSelection procedure} -constraints x11 -setup { - setup - setupbg + selectionSetup + childTkProcess create } -body { selection handle -selection PRIMARY .f1 {handler TEST} TEST update @@ -549,16 +468,16 @@ test select-5.10 {Tk_GetSelection procedure} -constraints x11 -setup { set selInfo "" selection own .f1 set result "" - lappend result [dobg {selection get TEST} 1] - cleanupbg + lappend result [childTkProcess eval {selection get TEST} 1] + childTkProcess exit lappend result $selInfo } -result {{selection owner didn't respond} {}} # multiple display tests test select-5.11 {Tk_GetSelection procedure} -constraints { altDisplay } -setup { - setup .f1 - setup .f2 $env(TK_ALT_DISPLAY) + selectionSetup .f1 + selectionSetup .f2 $env(TK_ALT_DISPLAY) } -body { selection handle -selection PRIMARY .f1 {handler TEST} TEST selection handle -selection PRIMARY .f2 {handler TEST2} TEST @@ -573,8 +492,8 @@ test select-5.12 {Tk_GetSelection procedure} -constraints { altDisplay } -setup { global lostSel lostSel2 - setup .f1 - setup .f2 $env(TK_ALT_DISPLAY) + selectionSetup .f1 + selectionSetup .f2 $env(TK_ALT_DISPLAY) } -body { selection handle -selection PRIMARY .f1 {handler TEST} TEST selection handle -selection PRIMARY .f2 {} TEST @@ -589,9 +508,9 @@ test select-5.12 {Tk_GetSelection procedure} -constraints { test select-5.13 {Tk_GetSelection procedure} -constraints { x11 altDisplay } -setup { - setup .f1 - setup .f2 $env(TK_ALT_DISPLAY) - setupbg + selectionSetup .f1 + selectionSetup .f2 $env(TK_ALT_DISPLAY) + childTkProcess create } -body { selection handle -selection PRIMARY .f1 {handler TEST} TEST selection own .f1 @@ -601,18 +520,18 @@ test select-5.13 {Tk_GetSelection procedure} -constraints { set selInfo "" update set result "" - lappend result [dobg "toplevel .t -screen $env(TK_ALT_DISPLAY); wm geom .t +0+0; selection get -displayof .t TEST"] + lappend result [childTkProcess eval "toplevel .t -screen $env(TK_ALT_DISPLAY); wm geom .t +0+0; selection get -displayof .t TEST"] set selValue "Test value2" - lappend result [dobg "selection get TEST"] - cleanupbg + lappend result [childTkProcess eval "selection get TEST"] + childTkProcess exit lappend result $selInfo } -result {{Test value} {Test value2} {TEST2 0 4000 TEST 0 4000}} test select-5.14 {Tk_GetSelection procedure} -constraints { x11 altDisplay } -setup { - setup .f1 - setup .f2 $env(TK_ALT_DISPLAY) - setupbg + selectionSetup .f1 + selectionSetup .f2 $env(TK_ALT_DISPLAY) + childTkProcess create } -body { selection handle -selection PRIMARY .f1 {handler TEST} TEST selection own .f1 @@ -622,14 +541,14 @@ test select-5.14 {Tk_GetSelection procedure} -constraints { set selInfo "" update set result "" - lappend result [dobg "toplevel .t -screen $env(TK_ALT_DISPLAY); wm geom .t +0+0; selection get -displayof .t TEST"] + lappend result [childTkProcess eval "toplevel .t -screen $env(TK_ALT_DISPLAY); wm geom .t +0+0; selection get -displayof .t TEST"] set selValue "Test value2" - lappend result [dobg "selection get TEST"] - cleanupbg + lappend result [childTkProcess eval "selection get TEST"] + childTkProcess exit lappend result $selInfo } -result {{PRIMARY selection doesn't exist or form "TEST" not defined} {Test value2} {TEST 0 4000}} test select-5.15 {Tk_GetSelection procedure} -setup { - setup + selectionSetup if {[llength [info command ::bgerror]]} { rename ::bgerror ::TMPbgerror } @@ -655,7 +574,7 @@ test select-6.2 {Tk_SelectionCmd procedure} -body { selection clear -selection } -returnCodes error -result {value for "-selection" missing} test select-6.3 {Tk_SelectionCmd procedure} -setup { - setup + selectionSetup } -body { selection own . set result [selection own] @@ -663,7 +582,7 @@ test select-6.3 {Tk_SelectionCmd procedure} -setup { lappend result [selection own] } -result {. {}} test select-6.4 {Tk_SelectionCmd procedure} -setup { - setup + selectionSetup } -body { selection own -selection CLIPBOARD .f1 set result [list [selection own] [selection own -selection CLIPBOARD]] @@ -671,7 +590,7 @@ test select-6.4 {Tk_SelectionCmd procedure} -setup { lappend result [selection own] [selection own -selection CLIPBOARD] } -result {.f1 .f1 .f1 {}} test select-6.5 {Tk_SelectionCmd procedure} -setup { - setup + selectionSetup } -body { selection own -selection CLIPBOARD . set result [list [selection own] [selection own -selection CLIPBOARD]] @@ -693,14 +612,14 @@ test select-6.9 {Tk_SelectionCmd procedure} -body { selection clear .f2 } -returnCodes error -result {bad window path name ".f2"} test select-6.10 {Tk_SelectionCmd procedure} -setup { - setup + selectionSetup } -body { set result [selection own -selection PRIMARY] selection clear lappend result [selection own -selection PRIMARY] } -result {.f1 {}} test select-6.11 {Tk_SelectionCmd procedure} -setup { - setup + selectionSetup } -body { selection own -selection CLIPBOARD .f1 set result [selection own -selection CLIPBOARD] @@ -715,8 +634,7 @@ test select-6.13 {Tk_SelectionCmd procedure} -body { selection get -selection } -returnCodes error -result {value for "-selection" missing} test select-6.14 {Tk_SelectionCmd procedure} -setup { - global selValue selInfo - setup + selectionSetup } -body { selection handle .f1 {handler TEST} set selValue "Test value" @@ -724,8 +642,7 @@ test select-6.14 {Tk_SelectionCmd procedure} -setup { list [selection get -displayof .f1] $selInfo } -result {{Test value} {TEST 0 4000}} test select-6.15 {Tk_SelectionCmd procedure} -setup { - global selValue selInfo - setup + selectionSetup } -body { selection handle .f1 {handler STRING} selection handle -selection CLIPBOARD .f1 {handler TEST} @@ -735,8 +652,7 @@ test select-6.15 {Tk_SelectionCmd procedure} -setup { list [selection get -selection CLIPBOARD] $selInfo } -result {{Test value} {TEST 0 4000}} test select-6.16 {Tk_SelectionCmd procedure} -setup { - global selValue selInfo - setup + selectionSetup } -body { selection handle -type TEST .f1 {handler TEST} selection handle -type STRING .f1 {handler STRING} @@ -758,8 +674,7 @@ test select-6.20 {Tk_SelectionCmd procedure} -returnCodes error -body { selection get foo bar } -result {wrong # args: should be "selection get ?-option value ...?"} test select-6.21 {Tk_SelectionCmd procedure} -setup { - global selValue selInfo - setup + selectionSetup } -body { selection handle -type TEST .f1 {handler TEST} selection handle -type STRING .f1 {handler STRING} @@ -773,8 +688,7 @@ test select-6.22 {Tk_SelectionCmd procedure} -body { selection handle -selection } -returnCodes error -result {value for "-selection" missing} test select-6.23 {Tk_SelectionCmd procedure} -setup { - global selValue selInfo - setup + selectionSetup } -body { set selValue "Test value" set selInfo "" @@ -804,13 +718,13 @@ test select-6.30 {Tk_SelectionCmd procedure} -body { selection own -selection } -returnCodes error -result {value for "-selection" missing} test select-6.31 {Tk_SelectionCmd procedure} -setup { - setup + selectionSetup } -body { selection own . selection own -displayof .f1 } -result {.} test select-6.32 {Tk_SelectionCmd procedure} -setup { - setup + selectionSetup } -body { selection own . selection own -selection CLIPBOARD .f1 @@ -818,7 +732,7 @@ test select-6.32 {Tk_SelectionCmd procedure} -setup { } -result {. .f1} test select-6.33 {Tk_SelectionCmd procedure} -setup { global lostSel - setup + selectionSetup } -body { set lostSel owned selection own -command { set lostSel lost } . @@ -854,7 +768,7 @@ test select-6.39 {Tk_SelectionCmd procedure} -returnCodes error -body { # selection request when the window doesn't exist, which causes a different # error message. test select-7.1 {TkSelDeadWindow procedure} -constraints nonPortable -setup { - setup + selectionSetup } -body { selection handle .f1 { handler TEST } set result [selection own] @@ -866,22 +780,22 @@ test select-7.1 {TkSelDeadWindow procedure} -constraints nonPortable -setup { # Check reentrancy on losing selection test select-8.1 {TkSelEventProc procedure} -constraints x11 -setup { - setup - setupbg + selectionSetup + childTkProcess create } -body { selection own -selection CLIPBOARD -command {destroy .f1} .f1 update - dobg {selection own -selection CLIPBOARD .} + childTkProcess eval {selection own -selection CLIPBOARD .} winfo children . } -cleanup { - cleanupbg + childTkProcess exit } -result {} ############################################################################## test select-9.1 {SelCvtToX and SelCvtFromX procedures} -setup { - setup - setupbg + selectionSetup + childTkProcess create } -constraints x11 -body { set selValue "1024" set selInfo "" @@ -889,52 +803,52 @@ test select-9.1 {SelCvtToX and SelCvtFromX procedures} -setup { .f1 {handler TEST} update set result "" - lappend result [dobg {selection get TEST}] - cleanupbg + lappend result [childTkProcess eval {selection get TEST}] + childTkProcess exit lappend result $selInfo } -result {{0x400 } {TEST 0 4000}} test select-9.2 {SelCvtToX and SelCvtFromX procedures} -setup { - setup - setupbg + selectionSetup + childTkProcess create } -constraints {x11 failsOnUbuntu} -body { set selValue "1024 0xffff 2048 -2 " set selInfo "" selection handle -selection PRIMARY -format INTEGER -type TEST \ .f1 {handler TEST} set result "" - lappend result [dobg {selection get TEST}] - cleanupbg + lappend result [childTkProcess eval {selection get TEST}] + childTkProcess exit lappend result $selInfo } -result {{0x400 0xffff 0x800 0xfffffffe } {TEST 0 4000}} test select-9.3 {SelCvtToX and SelCvtFromX procedures} -setup { - setup - setupbg + selectionSetup + childTkProcess create } -constraints {x11 failsOnUbuntu} -body { set selValue " " set selInfo "" selection handle -selection PRIMARY -format INTEGER -type TEST \ .f1 {handler TEST} set result "" - lappend result [dobg {selection get TEST}] - cleanupbg + lappend result [childTkProcess eval {selection get TEST}] + childTkProcess exit lappend result $selInfo } -result {{ } {TEST 0 4000}} test select-9.4 {SelCvtToX and SelCvtFromX procedures} -setup { - setup - setupbg + selectionSetup + childTkProcess create } -constraints {x11 failsOnUbuntu} -body { set selValue "16 foobar 32" set selInfo "" selection handle -selection PRIMARY -format INTEGER -type TEST \ .f1 {handler TEST} set result "" - lappend result [dobg {selection get TEST}] - cleanupbg + lappend result [childTkProcess eval {selection get TEST}] + childTkProcess exit lappend result $selInfo } -result {{0x10 0x0 0x20 } {TEST 0 4000}} test select-9.5 {SelCvtToX and SelCvtFromX procedures} -setup { - setup - setupbg + selectionSetup + childTkProcess create } -constraints x11 -body { # Ensure that lists of atoms are constructed correctly, even when the # atom names have spaces in. [Bug 1353414] @@ -943,9 +857,9 @@ test select-9.5 {SelCvtToX and SelCvtFromX procedures} -setup { set selType {text/x-tk-test;detail="foo bar"} selection handle -selection PRIMARY -format STRING -type $selType \ .f1 [list handler $selType] - lsort [dobg {selection get TARGETS}] + lsort [childTkProcess eval {selection get TARGETS}] } -cleanup { - cleanupbg + childTkProcess exit } -result {MULTIPLE TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW {text/x-tk-test;detail="foo bar"}} ############################################################################## @@ -955,7 +869,7 @@ test select-9.5 {SelCvtToX and SelCvtFromX procedures} -setup { test select-10.1 {ConvertSelection procedure, race with selection clear} -constraints { x11 } -setup { - setup + selectionSetup } -body { proc Ready {fd} { variable x @@ -984,63 +898,63 @@ test select-10.1 {ConvertSelection procedure, race with selection clear} -constr lappend x $selInfo } -result {{1:PRIMARY selection doesn't exist or form "STRING" not defined} {}} test select-10.2 {ConvertSelection procedure} -constraints x11 -setup { - setup - setupbg + selectionSetup + childTkProcess create } -body { set selValue [string range $longValue 0 3999] set selInfo "" selection handle .f1 {handler STRING} set result "" - lappend result [dobg {selection get}] - cleanupbg + lappend result [childTkProcess eval {selection get}] + childTkProcess exit lappend result $selInfo } -result [list [string range $longValue 0 3999] {STRING 0 4000 STRING 4000 4000 STRING 0 4000 STRING 4000 4000}] test select-10.3 {ConvertSelection procedure} -constraints x11 -setup { - setup - setupbg + selectionSetup + childTkProcess create } -body { selection handle .f1 ERROR errHandler - dobg {selection get ERROR} + childTkProcess eval {selection get ERROR} } -cleanup { - cleanupbg + childTkProcess exit } -result {PRIMARY selection doesn't exist or form "ERROR" not defined} # testing timers # This one hangs in Exceed test select-10.4 {ConvertSelection procedure} -constraints { x11 failsOnUbuntu } -setup { - setup - setupbg + selectionSetup + childTkProcess create } -body { set selValue $longValue set selInfo "" selection handle .f1 {errIncrHandler STRING} set result "" set pass 0 - lappend result [dobg {selection get}] - cleanupbg + lappend result [childTkProcess eval {selection get}] + childTkProcess exit lappend result $selInfo } -result {{selection owner didn't respond} {STRING 0 4000 STRING 4000 4000 STRING 8000 4000 STRING 12000 4000 STRING 16000 4000 STRING 0 4000 STRING 4000 4000}} test select-10.5 {ConvertSelection procedure, reentrancy issues} -constraints { x11 failsOnUbuntu } -setup { - setup - setupbg + selectionSetup + childTkProcess create } -body { set selValue "Test value" set selInfo "" selection handle -type TEST .f1 { handler TEST } selection handle -type STRING .f1 { badHandler .f1 STRING } set result "" - lappend result [dobg {selection get}] - cleanupbg + lappend result [childTkProcess eval {selection get}] + childTkProcess exit lappend result $selInfo } -result {{PRIMARY selection doesn't exist or form "STRING" not defined} {.f1 STRING 0 4000}} test select-10.6 {ConvertSelection procedure, reentrancy issues} -constraints { x11 failsOnUbuntu } -setup { - setup - setupbg + selectionSetup + childTkProcess create } -body { proc weirdHandler {type offset count} { destroy .f1 @@ -1050,8 +964,8 @@ test select-10.6 {ConvertSelection procedure, reentrancy issues} -constraints { set selInfo "" selection handle .f1 {weirdHandler STRING} set result "" - lappend result [dobg {selection get}] - cleanupbg + lappend result [childTkProcess eval {selection get}] + childTkProcess exit lappend result $selInfo } -cleanup { rename weirdHandler {} @@ -1061,8 +975,8 @@ test select-10.6 {ConvertSelection procedure, reentrancy issues} -constraints { # testing reentrancy test select-11.1 {TkSelPropProc procedure} -constraints {x11 failsOnUbuntu} -setup { - setup - setupbg + selectionSetup + childTkProcess create } -body { set selValue $longValue set selInfo "" @@ -1070,8 +984,8 @@ test select-11.1 {TkSelPropProc procedure} -constraints {x11 failsOnUbuntu} -set selection handle -type STRING .f1 { reallyBadHandler .f1 STRING } set result "" set pass 0 - lappend result [dobg {selection get}] - cleanupbg + lappend result [childTkProcess eval {selection get}] + childTkProcess exit lappend result $selInfo } -result {{selection owner didn't respond} {.f1 STRING 0 4000 .f1 STRING 4000 4000 .f1 STRING 8000 4000 .f1 STRING 12000 4000 .f1 STRING 16000 4000 .f1 STRING 0 4000 .f1 STRING 4000 4000}} @@ -1079,50 +993,50 @@ test select-11.1 {TkSelPropProc procedure} -constraints {x11 failsOnUbuntu} -set # Note, this assumes we are using CurrentTtime test select-12.1 {DefaultSelection procedure} -constraints x11 -body { - setup + selectionSetup set result [selection get -type TIMESTAMP] - setupbg - lappend result [dobg {selection get -type TIMESTAMP}] - cleanupbg + childTkProcess create + lappend result [childTkProcess eval {selection get -type TIMESTAMP}] + childTkProcess exit set result } -result {0x0 {0x0 }} test select-12.2 {DefaultSelection procedure} -constraints x11 -body { - setup + selectionSetup set result [lsort [list [selection get -type TARGETS]]] - setupbg - lappend result [dobg {lsort [selection get -type TARGETS]}] - cleanupbg + childTkProcess create + lappend result [childTkProcess eval {lsort [selection get -type TARGETS]}] + childTkProcess exit set result } -result {{MULTIPLE TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW} {MULTIPLE TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW}} test select-12.3 {DefaultSelection procedure} -constraints x11 -body { - setup + selectionSetup selection handle .f1 {handler TEST} TEST set result [list [lsort [selection get -type TARGETS]]] - setupbg - lappend result [dobg {lsort [selection get -type TARGETS]}] - cleanupbg + childTkProcess create + lappend result [childTkProcess eval {lsort [selection get -type TARGETS]}] + childTkProcess exit set result } -result {{MULTIPLE TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW} {MULTIPLE TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW}} test select-12.4 {DefaultSelection procedure} -constraints x11 -setup { - setup + selectionSetup set result "" } -body { lappend result [selection get -type TK_APPLICATION] - setupbg - lappend result [dobg {selection get -type TK_APPLICATION}] - cleanupbg + childTkProcess create + lappend result [childTkProcess eval {selection get -type TK_APPLICATION}] + childTkProcess exit set result } -result [list [winfo name .] [winfo name .]] test select-12.5 {DefaultSelection procedure} -constraints x11 -body { - setup + selectionSetup set result [selection get -type TK_WINDOW] - setupbg - lappend result [dobg {selection get -type TK_WINDOW}] - cleanupbg + childTkProcess create + lappend result [childTkProcess eval {selection get -type TK_WINDOW}] + childTkProcess exit set result } -result {.f1 .f1} test select-12.6 {DefaultSelection procedure} -body { - setup + selectionSetup selection handle .f1 {handler TARGETS.f1} TARGETS set selValue "Targets value" set selInfo "" @@ -1134,29 +1048,16 @@ test select-12.6 {DefaultSelection procedure} -body { test select-13.1 {SelectionSize procedure, handler deleted} -constraints { x11 failsOnUbuntu } -setup { - setup - setupbg -} -body { - proc badHandler {path type offset count} { - global selValue selInfo abortCount - incr abortCount -1 - if {$abortCount == 0} { - selection handle -type $type $path {} - } - lappend selInfo $path $type $offset $count - set numBytes [expr {[string length $selValue] - $offset}] - if {$numBytes <= 0} { - return "" - } - string range $selValue $offset [expr {$numBytes+$offset}] - } + selectionSetup + childTkProcess create +} -body { set selValue $longValue set selInfo "" - selection handle .f1 {badHandler .f1 STRING} + selection handle .f1 {badHandler2 .f1 STRING} set result "" set abortCount 2 - lappend result [dobg {selection get}] - cleanupbg + lappend result [childTkProcess eval {selection get}] + childTkProcess exit lappend result $selInfo } -result {{PRIMARY selection doesn't exist or form "STRING" not defined} {.f1 STRING 0 4000 .f1 STRING 4000 4000}} @@ -1172,9 +1073,12 @@ test select-14.1 {Bug [73ba07efcd]: Use correct property type when handling MULT } -cleanup { rename get_clip {} } -result {abcd} - -# cleanup +# +# CLEANUP +# + +testutils forget child select cleanupTests return diff --git a/tests/send.test b/tests/send.test index 84d4f30..ee2ca74 100644 --- a/tests/send.test +++ b/tests/send.test @@ -14,27 +14,10 @@ package require tcltest 2.2 eval tcltest::configure $argv tcltest::loadTestedCommands -testConstraint xhost [llength [auto_execok xhost]] -testConstraint failsOnUbuntu [expr {![info exists ::env(CI)] || ![string match Linux $::tcl_platform(os)]}] -testConstraint failsOnXQuarz [expr {$tcl_platform(os) ne "Darwin" || [tk windowingsystem] ne "x11" }] - -# Compute a script that will load Tk into a child interpreter. - -foreach pkg [info loaded] { - if {[lindex $pkg 1] == "Tk"} { - set loadTk "load $pkg" - break - } -} - -# Procedure to create a new application with a given name and class. +# Import utility procs for specific functional areas +testutils import child -proc newApp {screen name class} { - global loadTk - interp create $name - $name eval [list set argv [list -display $screen -name $name -class $class]] - eval $loadTk $name -} +testConstraint xhost [llength [auto_execok xhost]] set name [tk appname] set commId "" @@ -156,7 +139,7 @@ if {[testConstraint nonPortable] && [testConstraint xhost]} { winfo interps tk appname tktest update - setupbg + childTkProcess create set x [split [exec xhost] \n] foreach i [lrange $x 1 end] { exec xhost - $i @@ -165,19 +148,19 @@ if {[testConstraint nonPortable] && [testConstraint xhost]} { test send-6.1 {ServerSecure procedure} {nonPortable secureserver} { set a 44 - list [dobg [list send [tk appname] set a 55]] $a + list [childTkProcess eval [list send [tk appname] set a 55]] $a } {55 55} test send-6.2 {ServerSecure procedure} {nonPortable secureserver xhost} { set a 22 exec xhost [exec hostname] - list [catch {dobg [list send [tk appname] set a 33]} msg] $a $msg + list [catch {childTkProcess eval [list send [tk appname] set a 33]} msg] $a $msg } {0 22 {X server insecure (must use xauth-style authorization); command ignored}} test send-6.3 {ServerSecure procedure} {nonPortable secureserver xhost} { set a abc exec xhost - [exec hostname] - list [dobg [list send [tk appname] set a new]] $a + list [childTkProcess eval [list send [tk appname] set a new]] $a } {new new} -cleanupbg +childTkProcess exit test send-7.1 {Tk_SetAppName procedure} {secureserver testsend} { testsend prop root InterpRegistry "" @@ -201,28 +184,28 @@ test send-7.4 {Tk_SetAppName procedure, name in use} {secureserver testsend} { #macOS does not send to other processes test send-8.1 {Tk_SendCmd procedure, options} {secureserver notAqua} { - setupbg - set app [dobg {tk appname}] + childTkProcess create + set app [childTkProcess eval {tk appname}] set a 66 send -async $app [list send [tk appname] set a 77] set result $a after 200 set x 40 tkwait variable x - cleanupbg + childTkProcess exit lappend result $a } {66 77} test send-8.2 {Tk_SendCmd procedure, options} {secureserver altDisplay} { - setupbg -display $env(TK_ALT_DISPLAY) + childTkProcess create -display $env(TK_ALT_DISPLAY) tk appname xyzgorp set a homeDisplay - set result [dobg " + set result [childTkProcess eval " toplevel .t -screen [winfo screen .] wm geometry .t +0+0 set a altDisplay tk appname xyzgorp list \[send xyzgorp set a\] \[send -displayof .t xyzgorp set a\] "] - cleanupbg + childTkProcess exit set result } {altDisplay homeDisplay} # Since macOS has no registry of interpreters, 8.3 and 8.10 will fail. @@ -262,7 +245,7 @@ test send-8.10 {Tk_SendCmd procedure, no such interpreter} {secureserver notAqua } {1 {no application named "bogus_name"}} catch { - newApp "" t_s_1 Test + childTkInterp t_s_1 -class Test t_s_1 eval wm withdraw . } @@ -282,7 +265,7 @@ test send-8.13 {Tk_SendCmd procedure, local execution, different interp} {secure list $a [send t_s_1 {set a}] } {us them} test send-8.14 {Tk_SendCmd procedure, local interp killed by send} {secureserver testsend} { - newApp "" t_s_2 Test + childTkInterp t_s_2 -class Test list [catch {send t_s_2 {destroy .; concat result}} msg] $msg } {0 result} @@ -298,7 +281,7 @@ test send-8.15 {Tk_SendCmd procedure, local interp, error info} {secureserver te "if 1 {open bogus_file_name}" invoked from within "send t_s_1 {if 1 {open bogus_file_name}}"} {POSIX ENOENT {no such file or directory}}} -test send-8.16 {Tk_SendCmd procedure, bogusCommWindow} {secureserver testsend failsOnUbuntu failsOnXQuarz} { +test send-8.16 {Tk_SendCmd procedure, bogusCommWindow} {secureserver testsend failsOnUbuntu failsOnXQuartz} { testsend prop root InterpRegistry "10234 bogus\n" set result [list [catch {send bogus bogus command} msg] $msg] winfo interps @@ -313,8 +296,8 @@ test send-8.17 {Tk_SendCmd procedure, deferring events} {secureserver nonPortabl # requests so can't guarantee that new app's window won't # obscure .f, thereby masking the Expose event. - setupbg - set app [dobg {tk appname}] + childTkProcess create + set app [childTkProcess eval {tk appname}] raise . ; # Don't want new app obscuring .f catch {destroy .f} frame .f @@ -325,15 +308,15 @@ test send-8.17 {Tk_SendCmd procedure, deferring events} {secureserver nonPortabl lappend result [send $app send [list [tk appname]] set a] lappend result $a update - cleanupbg + childTkProcess exit lappend result $a } {{no event yet} {no event yet} exposed} test send-8.18 {Tk_SendCmd procedure, error in remote app} {secureserver} { - setupbg - set app [dobg {tk appname}] + childTkProcess create + set app [childTkProcess eval {tk appname}] set result [string tolower [list [catch {send $app open bad_name} msg] \ $msg $errorInfo $errorCode]] - cleanupbg + childTkProcess exit set result } {1 {couldn't open "bad_name": no such file or directory} {couldn't open "bad_name": no such file or directory while executing @@ -341,15 +324,15 @@ test send-8.18 {Tk_SendCmd procedure, error in remote app} {secureserver} { invoked from within "send $app open bad_name"} {posix enoent {no such file or directory}}} test send-8.19 {Tk_SendCmd, using modal timeouts} {secureserver} { - setupbg - set app [dobg {tk appname}] + childTkProcess create + set app [childTkProcess eval {tk appname}] set x no set result "" after 0 {set x yes} lappend result [send $app {concat x y z}] lappend result $x update - cleanupbg + childTkProcess exit lappend result $x } {{x y z} no yes} @@ -501,17 +484,17 @@ test send-10.17 {SendEventProc procedure, errorCode and errorInfo} {secureserver list [catch {send dummy foo} msg] $msg $errorInfo $errorCode } {4 {} oldErrorInfo oldErrorCode} test send-10.18 {SendEventProc procedure, send kills application} {secureserver testsend} { - setupbg - dobg {tk appname t_s_3} + childTkProcess create + childTkProcess eval {tk appname t_s_3} set x [list [catch {send t_s_3 destroy .} msg] $msg] - cleanupbg + childTkProcess exit set x } {0 {}} test send-10.19 {SendEventProc procedure, send exits} {secureserver testsend} { - setupbg - dobg {tk appname t_s_3} + childTkProcess create + childTkProcess eval {tk appname t_s_3} set x [list [catch {send t_s_3 exit} msg] $msg] - cleanupbg + childTkProcess exit set x } {1 {target application died}} @@ -542,14 +525,14 @@ test send-12.2 {TimeoutProc procedure} {secureserver notAqua} { winfo interps tk appname tktest update - setupbg - set app [dobg { + childTkProcess create + set app [childTkProcess eval { after 10 {after 10 {after 5000; exit}} tk appname }] after 200 set result [list [catch {send $app foo} msg] $msg] - cleanupbg + childTkProcess exit set result } {1 {target application died}} @@ -557,10 +540,10 @@ test send-12.2 {TimeoutProc procedure} {secureserver notAqua} { winfo interps tk appname tktest test send-13.1 {DeleteProc procedure} {secureserver notAqua} { - setupbg - set app [dobg {rename send {}; tk appname}] + childTkProcess create + set app [childTkProcess eval {rename send {}; tk appname}] set result [list [catch {send $app foo} msg] $msg [winfo interps]] - cleanupbg + childTkProcess exit set result } {1 {no application named "tktest #2"} tktest} test send-13.2 {DeleteProc procedure} {secureserver notAqua} { @@ -574,8 +557,8 @@ test send-13.2 {DeleteProc procedure} {secureserver notAqua} { } {{} {} foo send} test send-14.1 {SendRestrictProc procedure, sends crossing from different displays} {secureserver altDisplay} { - setupbg -display $env(TK_ALT_DISPLAY) - set result [dobg " + childTkProcess create -display $env(TK_ALT_DISPLAY) + set result [childTkProcess eval " toplevel .t -screen [winfo screen .] wm geometry .t +0+0 tk appname xyzgorp1 @@ -588,7 +571,7 @@ test send-14.1 {SendRestrictProc procedure, sends crossing from different displa set y parent set result [send -displayof .t xyzgorp1 {list $x [send -displayof .t xyzgorp2 set y]}] destroy .t - cleanupbg + childTkProcess exit set result } {child parent} @@ -598,9 +581,9 @@ catch { } test send-15.1 {UpdateCommWindow procedure} {secureserver testsend} { set x [list [testsend prop comm TK_APPLICATION]] - newApp "" t_s_1 Test + childTkInterp t_s_1 -class Test send t_s_1 wm withdraw . - newApp "" t_s_2 Test + childTkInterp t_s_2 -class Test send t_s_2 wm withdraw . lappend x [testsend prop comm TK_APPLICATION] interp delete t_s_1 @@ -609,13 +592,16 @@ test send-15.1 {UpdateCommWindow procedure} {secureserver testsend} { lappend x [testsend prop comm TK_APPLICATION] } {tktest {t_s_2 t_s_1 tktest} {t_s_2 tktest} tktest} +# +# CLEANUP +# + catch { tk appname $name testsend prop root InterpRegistry $registry testdeleteapps } -rename newApp {} -# cleanup +testutils forget child cleanupTests return diff --git a/tests/spinbox.test b/tests/spinbox.test index 87fb946..94e0b5f 100644 --- a/tests/spinbox.test +++ b/tests/spinbox.test @@ -11,35 +11,15 @@ namespace import ::tcltest::* eval tcltest::configure $argv tcltest::loadTestedCommands -# For xscrollcommand -set scrollInfo {} -proc scroll args { - global scrollInfo - set scrollInfo $args -} -# For trace add variable -proc override args { - global x - set x 12345 -} +# Import utility procs for specific functional areas +testutils import entry scroll -# Procedures used in widget VALIDATION tests -proc doval {W d i P s S v V} { - set ::vVals [list $W $d $i $P $s $S $v $V] - return 1 -} -proc doval2 {W d i P s S v V} { - set ::vVals [list $W $d $i $P $s $S $v $V] - set ::e mydata - return 1 +foreach i {1 2 3} { + set validateCmd$i [list validateCommand$i %W %d %i %P %s %S %v %V] } -proc doval3 {W d i P s S v V} { - set ::vVals [list $W $d $i $P $s $S $v $V] - return 0 -} - set cy [font metrics {Courier -12} -linespace] + test spinbox-1.1 {configuration option: "activebackground"} -setup { spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \ -relief sunken @@ -1233,20 +1213,20 @@ test spinbox-3.24 {SpinboxWidgetCmd procedure, "delete" widget command} -setup { spinbox .e pack .e update - set x {} + set textVar {} } -body { # UTF .e insert end "01234乎67890" .e delete 6 - lappend x [.e get] + lappend textVar [.e get] .e delete 0 end .e insert end "012345乎7890" .e delete 6 - lappend x [.e get] + lappend textVar [.e get] .e delete 0 end .e insert end "0123456乎890" .e delete 6 - lappend x [.e get] + lappend textVar [.e get] } -cleanup { destroy .e } -result [list "01234乎7890" "0123457890" "012345乎890"] @@ -1900,13 +1880,13 @@ test spinbox-3.81 {SpinboxWidgetCmd procedure, "xview" widget command} -setup { # UTF # If Tcl_NumUtfChars wasn't used, wrong answer would be: # 0.106383 0.117021 0.117021 - set x {} + set textVar {} .e xview moveto .1 - lappend x [format {%.6f} [lindex [.e xview] 0]] + lappend textVar [format {%.6f} [lindex [.e xview] 0]] .e xview moveto .11 - lappend x [format {%.6f} [lindex [.e xview] 0]] + lappend textVar [format {%.6f} [lindex [.e xview] 0]] .e xview moveto .12 - lappend x [format {%.6f} [lindex [.e xview] 0]] + lappend textVar [format {%.6f} [lindex [.e xview] 0]] } -cleanup { destroy .e } -result {0.095745 0.106383 0.117021} @@ -1922,47 +1902,47 @@ test spinbox-3.82 {SpinboxWidgetCmd procedure} -setup { } -returnCodes error -result {bad option "gorp": must be bbox, cget, configure, delete, get, icursor, identify, index, insert, invoke, scan, selection, set, validate, or xview} test spinbox-5.1 {ConfigureSpinbox procedure, -textvariable} -body { - set x 12345 - spinbox .e -textvariable x + set textVar 12345 + spinbox .e -textvariable textVar .e get } -cleanup { destroy .e } -result 12345 test spinbox-5.2 {ConfigureSpinbox procedure, -textvariable} -body { - set x 12345 - spinbox .e -textvariable x + set textVar 12345 + spinbox .e -textvariable textVar set y abcde .e configure -textvariable y - set x 54321 + set textVar 54321 .e get } -cleanup { destroy .e } -result {abcde} test spinbox-5.3 {ConfigureSpinbox procedure, -textvariable} -setup { - unset -nocomplain x + unset -nocomplain textVar spinbox .e } -body { .e insert 0 "Some text" - .e configure -textvariable x - set x + .e configure -textvariable textVar + set textVar } -cleanup { destroy .e } -result {Some text} test spinbox-5.4 {ConfigureSpinbox procedure, -textvariable} -setup { - unset -nocomplain x + unset -nocomplain textVar spinbox .e } -body { - trace add variable x write override + trace add variable textVar write override .e insert 0 "Some text" - .e configure -textvariable x - list $x [.e get] + .e configure -textvariable textVar + list $textVar [.e get] } -cleanup { destroy .e - trace remove variable x write override + trace remove variable textVar write override } -result {12345 12345} test spinbox-5.5 {ConfigureSpinbox procedure} -setup { - set x {} + set textVar {} spinbox .e1 spinbox .e2 } -body { @@ -1972,13 +1952,13 @@ test spinbox-5.5 {ConfigureSpinbox procedure} -setup { pack .e1 .e2 .e2 select from 0 .e2 select to 10 - lappend x [selection get] + lappend textVar [selection get] .e1 select from 1 .e1 select to 5 - lappend x [selection get] + lappend textVar [selection get] .e1 configure -exportselection 1 - lappend x [selection get] - set x + lappend textVar [selection get] + set textVar } -cleanup { destroy .e1 .e2 } -result {{This is so} {This is so} 1234} @@ -2012,7 +1992,7 @@ test spinbox-5.7 {ConfigureSpinbox procedure} -setup { spinbox .e -font {Helvetica -12} -borderwidth 2 -highlightthickness 2 pack .e } -body { - .e configure -font {Courier -12} -width 4 -xscrollcommand scroll + .e configure -font {Courier -12} -width 4 -xscrollcommand setScrollInfo .e insert end "01234567890" update set scrollInfo wrong @@ -2218,7 +2198,7 @@ test spinbox-7.1 {InsertChars procedure} -setup { pack .e focus .e } -body { - .e configure -textvariable contents -xscrollcommand scroll + .e configure -textvariable contents -xscrollcommand setScrollInfo .e insert 0 abcde update set scrollInfo wrong @@ -2235,7 +2215,7 @@ test spinbox-7.2 {InsertChars procedure} -setup { pack .e focus .e } -body { - .e configure -textvariable contents -xscrollcommand scroll + .e configure -textvariable contents -xscrollcommand setScrollInfo .e insert 0 abcde update set scrollInfo wrong @@ -2253,9 +2233,9 @@ test spinbox-7.3 {InsertChars procedure} -setup { .e select from 2 .e select to 6 .e insert 2 XXX - set x "[.e index sel.first] [.e index sel.last]" + set textVar "[.e index sel.first] [.e index sel.last]" .e select to 8 - lappend x [.e index sel.first] [.e index sel.last] + lappend textVar [.e index sel.first] [.e index sel.last] } -cleanup { destroy .e } -result {5 9 5 8} @@ -2267,9 +2247,9 @@ test spinbox-7.4 {InsertChars procedure} -setup { .e select from 2 .e select to 6 .e insert 3 XXX - set x "[.e index sel.first] [.e index sel.last]" + set textVar "[.e index sel.first] [.e index sel.last]" .e select to 8 - lappend x [.e index sel.first] [.e index sel.last] + lappend textVar [.e index sel.first] [.e index sel.last] } -cleanup { destroy .e } -result {2 9 2 8} @@ -2281,9 +2261,9 @@ test spinbox-7.5 {InsertChars procedure} -setup { .e select from 2 .e select to 6 .e insert 5 XXX - set x "[.e index sel.first] [.e index sel.last]" + set textVar "[.e index sel.first] [.e index sel.last]" .e select to 8 - lappend x [.e index sel.first] [.e index sel.last] + lappend textVar [.e index sel.first] [.e index sel.last] } -cleanup { destroy .e } -result {2 9 2 8} @@ -2295,9 +2275,9 @@ test spinbox-7.6 {InsertChars procedure} -setup { .e select from 2 .e select to 6 .e insert 6 XXX - set x "[.e index sel.first] [.e index sel.last]" + set textVar "[.e index sel.first] [.e index sel.last]" .e select to 5 - lappend x [.e index sel.first] [.e index sel.last] + lappend textVar [.e index sel.first] [.e index sel.last] } -cleanup { destroy .e } -result {2 6 2 5} @@ -2305,7 +2285,7 @@ test spinbox-7.7 {InsertChars procedure} -setup { spinbox .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 pack .e } -body { - .e configure -xscrollcommand scroll + .e configure -xscrollcommand setScrollInfo .e insert 0 0123456789 .e icursor 4 .e insert 4 XXX @@ -2369,7 +2349,7 @@ test spinbox-8.1 {DeleteChars procedure} -setup { pack .e focus .e } -body { - .e configure -textvariable contents -xscrollcommand scroll + .e configure -textvariable contents -xscrollcommand setScrollInfo .e insert 0 abcde update set scrollInfo wrong @@ -2385,7 +2365,7 @@ test spinbox-8.2 {DeleteChars procedure} -setup { pack .e focus .e } -body { - .e configure -textvariable contents -xscrollcommand scroll + .e configure -textvariable contents -xscrollcommand setScrollInfo .e insert 0 abcde update set scrollInfo wrong @@ -2401,7 +2381,7 @@ test spinbox-8.3 {DeleteChars procedure} -setup { pack .e focus .e } -body { - .e configure -textvariable contents -xscrollcommand scroll + .e configure -textvariable contents -xscrollcommand setScrollInfo .e insert 0 abcde update set scrollInfo wrong @@ -2421,9 +2401,9 @@ test spinbox-8.4 {DeleteChars procedure} -setup { .e select to 8 .e delete 1 3 update - set x "[.e index sel.first] [.e index sel.last]" + set textVar "[.e index sel.first] [.e index sel.last]" .e select to 5 - lappend x [.e index sel.first] [.e index sel.last] + lappend textVar [.e index sel.first] [.e index sel.last] } -cleanup { destroy .e } -result {1 6 1 5} @@ -2437,9 +2417,9 @@ test spinbox-8.5 {DeleteChars procedure} -setup { .e select to 8 .e delete 1 4 update - set x "[.e index sel.first] [.e index sel.last]" + set textVar "[.e index sel.first] [.e index sel.last]" .e select to 4 - lappend x [.e index sel.first] [.e index sel.last] + lappend textVar [.e index sel.first] [.e index sel.last] } -cleanup { destroy .e } -result {1 5 1 4} @@ -2453,9 +2433,9 @@ test spinbox-8.6 {DeleteChars procedure} -setup { .e select to 8 .e delete 1 7 update - set x "[.e index sel.first] [.e index sel.last]" + set textVar "[.e index sel.first] [.e index sel.last]" .e select to 5 - lappend x [.e index sel.first] [.e index sel.last] + lappend textVar [.e index sel.first] [.e index sel.last] } -cleanup { destroy .e } -result {1 2 1 5} @@ -2483,9 +2463,9 @@ test spinbox-8.8 {DeleteChars procedure} -setup { .e select to 8 .e delete 3 7 update - set x "[.e index sel.first] [.e index sel.last]" + set textVar "[.e index sel.first] [.e index sel.last]" .e select to 8 - lappend x [.e index sel.first] [.e index sel.last] + lappend textVar [.e index sel.first] [.e index sel.last] } -cleanup { destroy .e } -result {3 4 3 8} @@ -2512,9 +2492,9 @@ test spinbox-8.10 {DeleteChars procedure} -setup { .e select to 3 .e delete 5 8 update - set x "[.e index sel.first] [.e index sel.last]" + set textVar "[.e index sel.first] [.e index sel.last]" .e select to 8 - lappend x [.e index sel.first] [.e index sel.last] + lappend textVar [.e index sel.first] [.e index sel.last] } -cleanup { destroy .e } -result {3 5 5 8} @@ -2528,9 +2508,9 @@ test spinbox-8.11 {DeleteChars procedure} -setup { .e select to 3 .e delete 8 10 update - set x "[.e index sel.first] [.e index sel.last]" + set textVar "[.e index sel.first] [.e index sel.last]" .e select to 4 - lappend x [.e index sel.first] [.e index sel.last] + lappend textVar [.e index sel.first] [.e index sel.last] } -cleanup { destroy .e } -result {3 8 4 8} @@ -2641,24 +2621,24 @@ test spinbox-8.18 {DeleteChars procedure} -setup { } -result {1} test spinbox-9.1 {SpinboxValueChanged procedure} -setup { - unset -nocomplain x + unset -nocomplain textVar } -body { - trace add variable x write override - spinbox .e -textvariable x -width 0 + trace add variable textVar write override + spinbox .e -textvariable textVar -width 0 .e insert 0 foo - list $x [.e get] + list $textVar [.e get] } -cleanup { destroy .e - trace remove variable x write override + trace remove variable textVar write override } -result {12345 12345} test spinbox-10.1 {SpinboxSetValue procedure} -constraints fonts -body { - set x abcde + set textVar abcde set y ab spinbox .e -font {Helvetica -12} -highlightthickness 2 -bd 2 -width 0 pack .e - .e configure -textvariable x + .e configure -textvariable textVar .e configure -textvariable y update list [.e get] [winfo reqwidth .e] @@ -2666,100 +2646,100 @@ test spinbox-10.1 {SpinboxSetValue procedure} -constraints fonts -body { destroy .e } -result {ab 35} test spinbox-10.2 {SpinboxSetValue procedure, updating selection} -setup { - unset -nocomplain x + unset -nocomplain textVar spinbox .e -font {Helvetica -12} -highlightthickness 2 -bd 2 pack .e } -body { - .e configure -textvariable x + .e configure -textvariable textVar .e insert 0 "abcdefghjklmnopqrstu" .e selection range 4 10 - set x "a" + set textVar "a" .e index sel.first } -cleanup { destroy .e } -returnCodes error -result {selection isn't in widget .e} test spinbox-10.3 {SpinboxSetValue procedure, updating selection} -setup { - unset -nocomplain x + unset -nocomplain textVar spinbox .e -font {Helvetica -12} -highlightthickness 2 -bd 2 pack .e } -body { - .e configure -textvariable x + .e configure -textvariable textVar .e insert 0 "abcdefghjklmnopqrstu" .e selection range 4 10 - set x "abcdefg" + set textVar "abcdefg" list [.e index sel.first] [.e index sel.last] } -cleanup { destroy .e } -result {4 7} test spinbox-10.4 {SpinboxSetValue procedure, updating selection} -setup { - unset -nocomplain x + unset -nocomplain textVar spinbox .e -font {Helvetica -12} -highlightthickness 2 -bd 2 pack .e } -body { - .e configure -textvariable x + .e configure -textvariable textVar .e insert 0 "abcdefghjklmnopqrstu" .e selection range 4 10 - set x "abcdefghijklmn" + set textVar "abcdefghijklmn" list [.e index sel.first] [.e index sel.last] } -cleanup { destroy .e } -result {4 10} test spinbox-10.5 {SpinboxSetValue procedure, updating display position} -setup { - unset -nocomplain x + unset -nocomplain textVar spinbox .e -highlightthickness 2 -bd 2 pack .e } -body { - .e configure -width 10 -font {Courier -12} -textvariable x + .e configure -width 10 -font {Courier -12} -textvariable textVar .e insert 0 "abcdefghjklmnopqrstuvwxyz" .e xview 10 update - set x "abcdefg" + set textVar "abcdefg" update .e index @0 } -cleanup { destroy .e } -result 0 test spinbox-10.6 {SpinboxSetValue procedure, updating display position} -setup { - unset -nocomplain x + unset -nocomplain textVar spinbox .e -highlightthickness 2 -bd 2 pack .e } -body { - .e configure -width 10 -font {Courier -12} -textvariable x + .e configure -width 10 -font {Courier -12} -textvariable textVar pack .e .e insert 0 "abcdefghjklmnopqrstuvwxyz" .e xview 10 update - set x "1234567890123456789012" + set textVar "1234567890123456789012" update .e index @0 } -cleanup { destroy .e } -result 10 test spinbox-10.7 {SpinboxSetValue procedure, updating insertion cursor} -setup { - unset -nocomplain x + unset -nocomplain textVar spinbox .e -highlightthickness 2 -bd 2 pack .e update } -body { - .e configure -width 10 -font {Courier -12} -textvariable x + .e configure -width 10 -font {Courier -12} -textvariable textVar pack .e .e insert 0 "abcdefghjklmnopqrstuvwxyz" .e icursor 5 - set x "123" + set textVar "123" .e index insert } -cleanup { destroy .e } -result 3 test spinbox-10.8 {SpinboxSetValue procedure, updating insertion cursor} -setup { - unset -nocomplain x + unset -nocomplain textVar spinbox .e -highlightthickness 2 -bd 2 pack .e } -body { - .e configure -width 10 -font {Courier -12} -textvariable x + .e configure -width 10 -font {Courier -12} -textvariable textVar pack .e .e insert 0 "abcdefghjklmnopqrstuvwxyz" .e icursor 5 - set x "123456" + set textVar "123456" .e index insert } -cleanup { destroy .e @@ -2776,14 +2756,14 @@ test spinbox-11.1 {SpinboxEventProc procedure} -setup { destroy .e } -result {} test spinbox-11.2 {SpinboxEventProc procedure} -setup { - set x {} + set textVar {} } -body { spinbox .e1 -fg #112233 rename .e1 .e2 - lappend x [winfo children .] - lappend x [.e2 cget -fg] + lappend textVar [winfo children .] + lappend textVar [.e2 cget -fg] destroy .e1 - lappend x [info command .e*] [winfo children .] + lappend textVar [info command .e*] [winfo children .] } -cleanup { destroy .e1 } -result {.e1 #112233 {} {}} @@ -3155,16 +3135,16 @@ test spinbox-14.1 {SpinboxFetchSelection procedure} -body { destroy .e } -result {his is a test str} test spinbox-14.3 {SpinboxFetchSelection procedure} -setup { - set x {} + set textVar {} for {set i 1} {$i <= 500} {incr i} { - append x "This is line $i, out of 500\n" + append textVar "This is line $i, out of 500\n" } } -body { spinbox .e - .e insert end $x + .e insert end $textVar .e select from 0 .e select to end - string compare [selection get] $x + string compare [selection get] $textVar } -cleanup { destroy .e } -result 0 @@ -3202,7 +3182,7 @@ test spinbox-16.2 {SpinboxVisibleRange procedure} -body { test spinbox-17.1 {SpinboxUpdateScrollbar procedure} -body { - spinbox .e -width 10 -xscrollcommand scroll -font {Courier -12} + spinbox .e -width 10 -xscrollcommand setScrollInfo -font {Courier -12} pack .e update set scrollInfo wrong @@ -3214,7 +3194,7 @@ test spinbox-17.1 {SpinboxUpdateScrollbar procedure} -body { destroy .e } -result {0.000000 1.000000} test spinbox-17.2 {SpinboxUpdateScrollbar procedure} -body { - spinbox .e -width 10 -xscrollcommand scroll -font {Courier -12} + spinbox .e -width 10 -xscrollcommand setScrollInfo -font {Courier -12} pack .e .e insert 0 0123456789abcdef update @@ -3226,7 +3206,7 @@ test spinbox-17.2 {SpinboxUpdateScrollbar procedure} -body { destroy .e } -result {0.187500 0.812500} test spinbox-17.3 {SpinboxUpdateScrollbar procedure} -body { - spinbox .e -width 10 -xscrollcommand scroll -font {Courier -12} + spinbox .e -width 10 -xscrollcommand setScrollInfo -font {Courier -12} pack .e update set scrollInfo wrong @@ -3239,8 +3219,8 @@ test spinbox-17.3 {SpinboxUpdateScrollbar procedure} -body { } -result {0.000000 0.526316} test spinbox-17.4 {SpinboxUpdateScrollbar procedure} -setup { proc bgerror msg { - global x - set x $msg + global textVar + set textVar $msg } } -body { spinbox .e -width 5 @@ -3249,7 +3229,7 @@ test spinbox-17.4 {SpinboxUpdateScrollbar procedure} -setup { set scrollInfo wrong .e configure -xscrollcommand thisisnotacommand update - list $x $errorInfo + list $textVar $errorInfo } -cleanup { destroy .e rename bgerror {} @@ -3280,125 +3260,125 @@ test spinbox-18.1 {Spinbox widget vs hiding} -setup { # test cases. This was replaced by inserting recently set configurations # that matters for the test case test spinbox-19.1 {spinbox widget validation} -setup { - unset -nocomplain ::e ::vVals + unset -nocomplain textVar validationData } -body { spinbox .e -validate all \ - -validatecommand [list doval %W %d %i %P %s %S %v %V] \ + -validatecommand $validateCmd1 \ -invalidcommand bell \ - -textvariable ::e \ + -textvariable textVar \ -background red -foreground white pack .e .e insert 0 a - set ::vVals + set validationData } -cleanup { destroy .e } -result {.e 1 0 a {} a all key} test spinbox-19.2 {spinbox widget validation} -setup { - unset -nocomplain ::e ::vVals + unset -nocomplain textVar validationData } -body { spinbox .e -validate all \ - -validatecommand [list doval %W %d %i %P %s %S %v %V] \ + -validatecommand $validateCmd1 \ -invalidcommand bell \ - -textvariable ::e \ + -textvariable textVar \ -background red -foreground white pack .e .e insert 0 a ;# previous settings .e insert 1 b - set ::vVals + set validationData } -cleanup { destroy .e } -result {.e 1 1 ab a b all key} test spinbox-19.3 {spinbox widget validation} -setup { - unset -nocomplain ::e ::vVals + unset -nocomplain textVar validationData } -body { spinbox .e -validate all \ - -validatecommand [list doval %W %d %i %P %s %S %v %V] \ + -validatecommand $validateCmd1 \ -invalidcommand bell \ - -textvariable ::e \ + -textvariable textVar \ -background red -foreground white pack .e .e insert 0 ab ;# previous settings .e insert end c - set ::vVals + set validationData } -cleanup { destroy .e } -result {.e 1 2 abc ab c all key} test spinbox-19.4 {spinbox widget validation} -setup { - unset -nocomplain ::e ::vVals + unset -nocomplain textVar validationData } -body { spinbox .e -validate all \ - -validatecommand [list doval %W %d %i %P %s %S %v %V] \ + -validatecommand $validateCmd1 \ -invalidcommand bell \ - -textvariable ::e \ + -textvariable textVar \ -background red -foreground white pack .e .e insert 0 abc ;# previous settings .e insert 1 123 - list $::vVals $::e + list $validationData $textVar } -cleanup { destroy .e } -result {{.e 1 1 a123bc abc 123 all key} a123bc} test spinbox-19.5 {spinbox widget validation} -setup { - unset -nocomplain ::e ::vVals + unset -nocomplain textVar validationData } -body { spinbox .e -validate all \ - -validatecommand [list doval %W %d %i %P %s %S %v %V] \ + -validatecommand $validateCmd1 \ -invalidcommand bell \ - -textvariable ::e \ + -textvariable textVar \ -background red -foreground white pack .e .e insert 0 a123bc ;# previous settings .e delete 2 - set ::vVals + set validationData } -cleanup { destroy .e } -result {.e 0 2 a13bc a123bc 2 all key} test spinbox-19.6 {spinbox widget validation} -setup { - unset -nocomplain ::e ::vVals + unset -nocomplain textVar validationData } -body { spinbox .e -validate all \ - -validatecommand [list doval %W %d %i %P %s %S %v %V] \ + -validatecommand $validateCmd1 \ -invalidcommand bell \ - -textvariable ::e \ + -textvariable textVar \ -background red -foreground white pack .e .e insert 0 a13bc ;# previous settings .e configure -validate key .e delete 1 3 - set ::vVals + set validationData } -cleanup { destroy .e } -result {.e 0 1 abc a13bc 13 key key} test spinbox-19.7 {spinbox widget validation} -setup { - unset -nocomplain ::e ::vVals + unset -nocomplain textVar validationData } -body { spinbox .e -validate focus \ - -validatecommand [list doval %W %d %i %P %s %S %v %V] \ + -validatecommand $validateCmd1 \ -invalidcommand bell \ - -textvariable ::e \ + -textvariable textVar \ -background red -foreground white pack .e .e insert end abc ;# previous settings - set ::vVals {} + set validationData {} .e insert end d - set ::vVals + set validationData } -cleanup { destroy .e } -result {} test spinbox-19.8 {spinbox widget validation} -setup { - unset -nocomplain ::e ::vVals + unset -nocomplain textVar validationData } -body { spinbox .e -validate all \ - -validatecommand [list doval %W %d %i %P %s %S %v %V] \ + -validatecommand $validateCmd1 \ -invalidcommand bell \ - -textvariable ::e \ + -textvariable textVar \ -background red -foreground white pack .e .e configure -validate focus ;# previous settings @@ -3406,18 +3386,18 @@ test spinbox-19.8 {spinbox widget validation} -setup { focus -force .e # update necessary to process FocusIn event update - set ::vVals + set validationData } -cleanup { destroy .e } -result {.e -1 -1 abcd abcd {} focus focusin} test spinbox-19.9 {spinbox widget validation} -setup { - unset -nocomplain ::e ::vVals + unset -nocomplain textVar validationData } -body { spinbox .e -validate focus \ - -validatecommand [list doval %W %d %i %P %s %S %v %V] \ + -validatecommand $validateCmd1 \ -invalidcommand bell \ - -textvariable ::e \ + -textvariable textVar \ -background red -foreground white pack .e .e insert end abcd ;# previous settings @@ -3427,36 +3407,36 @@ test spinbox-19.9 {spinbox widget validation} -setup { focus -force . # update necessary to process FocusOut event update - set ::vVals + set validationData } -cleanup { destroy .e } -result {.e -1 -1 abcd abcd {} focus focusout} test spinbox-19.10 {spinbox widget validation} -setup { - unset -nocomplain ::e ::vVals + unset -nocomplain textVar validationData } -body { spinbox .e -validate all \ - -validatecommand [list doval %W %d %i %P %s %S %v %V] \ + -validatecommand $validateCmd1 \ -invalidcommand bell \ - -textvariable ::e \ + -textvariable textVar \ -background red -foreground white pack .e .e insert end abcd ;# previous settings focus -force .e # update necessary to process FocusIn event update - set ::vVals + set validationData } -cleanup { destroy .e } -result {.e -1 -1 abcd abcd {} all focusin} test spinbox-19.11 {spinbox widget validation} -setup { - unset -nocomplain ::e ::vVals + unset -nocomplain textVar validationData } -body { spinbox .e -validate all \ - -validatecommand [list doval %W %d %i %P %s %S %v %V] \ + -validatecommand $validateCmd1 \ -invalidcommand bell \ - -textvariable ::e \ + -textvariable textVar \ -background red -foreground white pack .e .e insert end abcd ;# previous settings @@ -3466,144 +3446,144 @@ test spinbox-19.11 {spinbox widget validation} -setup { focus -force . # update necessary to process FocusOut event update - set ::vVals + set validationData } -cleanup { destroy .e } -result {.e -1 -1 abcd abcd {} all focusout} test spinbox-19.12 {spinbox widget validation} -setup { - unset -nocomplain ::e ::vVals + unset -nocomplain textVar validationData } -body { spinbox .e -validate focusin \ - -validatecommand [list doval %W %d %i %P %s %S %v %V] \ + -validatecommand $validateCmd1 \ -invalidcommand bell \ - -textvariable ::e \ + -textvariable textVar \ -background red -foreground white pack .e .e insert 0 abcd ;# previous settings focus -force .e # update necessary to process FocusIn event update - set ::vVals + set validationData } -cleanup { destroy .e } -result {.e -1 -1 abcd abcd {} focusin focusin} test spinbox-19.13 {spinbox widget validation} -setup { - unset -nocomplain ::e ::vVals + unset -nocomplain textVar validationData } -body { spinbox .e -validate focusin \ - -validatecommand [list doval %W %d %i %P %s %S %v %V] \ + -validatecommand $validateCmd1 \ -invalidcommand bell \ - -textvariable ::e \ + -textvariable textVar \ -background red -foreground white pack .e .e insert end abcd ;# previous settings - set ::vVals {} + set validationData {} focus -force . # update necessary to process FocusOut event update - set ::vVals + set validationData } -cleanup { destroy .e } -result {} test spinbox-19.14 {spinbox widget validation} -setup { - unset -nocomplain ::e ::vVals + unset -nocomplain textVar validationData } -body { spinbox .e -validate focuso \ - -validatecommand [list doval %W %d %i %P %s %S %v %V] \ + -validatecommand $validateCmd1 \ -invalidcommand bell \ - -textvariable ::e \ + -textvariable textVar \ -background red -foreground white pack .e .e insert end abcd ;# previous settings - set ::vVals {} ;# previous settings + set validationData {} ;# previous settings focus -force .e # update necessary to process FocusIn event update - set ::vVals + set validationData } -cleanup { destroy .e } -result {} test spinbox-19.15 {spinbox widget validation} -setup { - unset -nocomplain ::e ::vVals + unset -nocomplain textVar validationData } -body { spinbox .e -validate focuso \ - -validatecommand [list doval %W %d %i %P %s %S %v %V] \ + -validatecommand $validateCmd1 \ -invalidcommand bell \ - -textvariable ::e \ + -textvariable textVar \ -background red -foreground white pack .e .e insert end abcd ;# previous settings - set ::vVals {} ;# previous settings + set validationData {} ;# previous settings focus -force .e ;# previous settings # update necessary to process FocusIn event update ;# previous settings focus -force . # update necessary to process FocusOut event update - set ::vVals + set validationData } -cleanup { destroy .e } -result {.e -1 -1 abcd abcd {} focusout focusout} # the same as 19.16 but added [.e validate] to returned list test spinbox-19.16 {spinbox widget validation} -setup { - unset -nocomplain ::e ::vVals + unset -nocomplain textVar validationData } -body { spinbox .e -validate focuso \ - -validatecommand [list doval %W %d %i %P %s %S %v %V] \ + -validatecommand $validateCmd1 \ -invalidcommand bell \ - -textvariable ::e \ + -textvariable textVar \ -background red -foreground white pack .e .e insert end abcd ;# previous settings - set ::vVals {} ;# previous settings + set validationData {} ;# previous settings focus -force .e ;# previous settings # update necessary to process FocusIn event update ;# previous settings focus -force . # update necessary to process FocusOut event update - list [.e validate] $::vVals + list [.e validate] $validationData } -cleanup { destroy .e } -result {1 {.e -1 -1 abcd abcd {} all forced}} test spinbox-19.17 {spinbox widget validation} -setup { - unset -nocomplain ::e ::vVals + unset -nocomplain textVar validationData } -body { spinbox .e -validate focuso \ - -validatecommand [list doval %W %d %i %P %s %S %v %V] \ + -validatecommand $validateCmd1 \ -invalidcommand bell \ - -textvariable ::e \ + -textvariable textVar \ -background red -foreground white pack .e .e insert end abcd ;# previous settings - set ::e newdata - list [.e cget -validate] $::vVals + set textVar newdata + list [.e cget -validate] $validationData } -cleanup { destroy .e } -result {focusout {.e -1 -1 newdata abcd {} focusout forced}} -# proc doval changed - returns 0 +# Note: changed validateCmd - returns 0 test spinbox-19.18 {spinbox widget validation} -setup { - unset -nocomplain ::e ::vVals + unset -nocomplain textVar validationData } -body { spinbox .e -validate all \ - -validatecommand [list doval3 %W %d %i %P %s %S %v %V] \ + -validatecommand $validateCmd3 \ -invalidcommand bell \ - -textvariable ::e \ + -textvariable textVar \ -background red -foreground white pack .e - set ::e newdata ;# previous settings + set textVar newdata ;# previous settings .e configure -validate all - set ::e nextdata - list [.e cget -validate] $::vVals + set textVar nextdata + list [.e cget -validate] $validationData } -cleanup { destroy .e } -result {none {.e -1 -1 nextdata newdata {} all forced}} @@ -3611,21 +3591,21 @@ test spinbox-19.18 {spinbox widget validation} -setup { ## This sets validate to none because it shows that we prevent a possible ## loop condition in the validation, when the spinbox textvar is also set -# proc doval2 used +# proc validateCmd2 used test spinbox-19.19 {spinbox widget validation} -setup { - unset -nocomplain ::e ::vVals + unset -nocomplain textVar validationData } -body { spinbox .e -validate all \ - -validatecommand [list doval3 %W %d %i %P %s %S %v %V] \ + -validatecommand $validateCmd3 \ -invalidcommand bell \ - -textvariable ::e \ + -textvariable textVar \ -background red -foreground white pack .e - set ::e nextdata ;# previous settings + set textVar nextdata ;# previous settings - .e configure -validatecommand [list doval2 %W %d %i %P %s %S %v %V] + .e configure -validatecommand $validateCmd2 .e validate - list [.e cget -validate] [.e get] $::vVals + list [.e cget -validate] [.e get] $validationData } -cleanup { destroy .e } -result {none nextdata {.e -1 -1 nextdata nextdata {} all forced}} @@ -3636,21 +3616,21 @@ test spinbox-19.19 {spinbox widget validation} -setup { ## one of those "dangerous" conditions where the user will have a ## different value in the spinbox widget shown as is in the textvar. test spinbox-19.20 {spinbox widget validation} -setup { - unset -nocomplain ::e ::vVals + unset -nocomplain textVar validationData } -body { spinbox .e -validate all \ - -validatecommand [list doval %W %d %i %P %s %S %v %V] \ + -validatecommand $validateCmd1 \ -invalidcommand bell \ - -textvariable ::e \ + -textvariable textVar \ -background red -foreground white pack .e - set ::e nextdata ;# previous settings - .e configure -validatecommand [list doval2 %W %d %i %P %s %S %v %V] ;# prev + set textVar nextdata ;# previous settings + .e configure -validatecommand $validateCmd2 ;# prev .e validate ;# previous settings .e configure -validate all - set ::e testdata - list [.e cget -validate] [.e get] $::e $::vVals + set textVar testdata + list [.e cget -validate] [.e get] $textVar $validationData } -cleanup { destroy .e } -result {all testdata mydata {.e -1 -1 testdata mydata {} all forced}} @@ -3661,15 +3641,15 @@ test spinbox-19.20 {spinbox widget validation} -setup { ## one of those "dangerous" conditions where the user will have a ## different value in the entry widget shown as is in the textvar. test spinbox-19.21 {spinbox widget validation - bug 40e4bf6198} -setup { - unset -nocomplain ::e ::vVals + unset -nocomplain textVar validationData } -body { spinbox .e -validate key \ - -validatecommand [list doval2 %W %d %i %P %s %S %v %V] \ - -textvariable ::e + -validatecommand $validateCmd2 \ + -textvariable textVar pack .e - set ::e origdata + set textVar origdata .e insert 0 A - list [.e cget -validate] [.e get] $::e $::vVals + list [.e cget -validate] [.e get] $textVar $validationData } -cleanup { destroy .e } -result {none origdata mydata {.e 1 0 Aorigdata origdata A key key}} @@ -3916,9 +3896,15 @@ test spinbox-25.3 {Bugs [2a32225cd1] and [9fa3e08243]} -setup { # XXX Still need to write tests for SpinboxScanTo and SpinboxSelectTo. # No tests for EventuallyRedraw +# +# CLEANUP +# + # option clear -# cleanup +foreach i {1 2 3} { + unset validateCmd$i +} +unset i +testutils forget entry scroll cleanupTests return - - diff --git a/tests/systray.test b/tests/systray.test index 6f38823..5a0d1c8 100644 --- a/tests/systray.test +++ b/tests/systray.test @@ -10,6 +10,9 @@ namespace import ::tcltest::* eval tcltest::configure $argv tcltest::loadTestedCommands +# Import utility procs for specific functional areas +testutils import child + test systray-1 {systray icon creation, all options} -setup { image create photo _book -data R0lGODlhDwAPAKIAAP//////AP8AAMDAwICAgAAAAAAAAAAAACwAAAAADwAPAAADSQhA2u5ksPeKABKSCaya29d4WKgERFF0l1IMQCAKatvBJ0OTdzzXI1xMB3TBZAvATtB6NSLKleXi3OBoLqrVgc0yv+DVSEUuFxIAOw== } -body { @@ -124,15 +127,7 @@ test systray-14 {systray icon creation, create one per interp, visibiliy checks} image create photo _book -data R0lGODlhDwAPAKIAAP//////AP8AAMDAwICAgAAAAAAAAAAAACwAAAAADwAPAAADSQhA2u5ksPeKABKSCaya29d4WKgERFF0l1IMQCAKatvBJ0OTdzzXI1xMB3TBZAvATtB6NSLKleXi3OBoLqrVgc0yv+DVSEUuFxIAOw== } -body { tk systray create -image _book -text "first interp" - interp create second - # load Tk into the 'second' interp - foreach pkg [info loaded] { - if {[lindex $pkg 1] == "Tk"} { - set loadTk "load $pkg" - break - } - } - eval $loadTk second + childTkInterp second # create the icon in the 'second' interp second eval { # should trigger an error: image _book unknown in 'second' interp' @@ -149,15 +144,7 @@ test systray-15 {systray icon creation, create one per interp} -setup { image create photo _book -data R0lGODlhDwAPAKIAAP//////AP8AAMDAwICAgAAAAAAAAAAAACwAAAAADwAPAAADSQhA2u5ksPeKABKSCaya29d4WKgERFF0l1IMQCAKatvBJ0OTdzzXI1xMB3TBZAvATtB6NSLKleXi3OBoLqrVgc0yv+DVSEUuFxIAOw== } -body { tk systray create -image _book -text "first interp" - interp create second - # load Tk into the 'second' interp - foreach pkg [info loaded] { - if {[lindex $pkg 1] == "Tk"} { - set loadTk "load $pkg" - break - } - } - eval $loadTk second + childTkInterp second # create the icon in the 'second' interp second eval { image create photo _page -data R0lGODlhCwAPAKIAAP//////AMDAwICAgAAA/wAAAAAAAAAAACwAAAAACwAPAAADMzi6CzAugiAgDGE68aB0RXgRJBFVX0SNpQlUWfahQOvSsgrX7eZJMlQMWBEYj8iQchlKAAA7 @@ -236,5 +223,9 @@ test sysnotify-2.2 {system notification is not linked to any systray icon on X11 tk sysnotify {Alert} {This is an alert} } -result {} +# +# CLEANUP +# +testutils forget child cleanupTests diff --git a/tests/testutils.GUIDE b/tests/testutils.GUIDE new file mode 100644 index 0000000..5125f5e --- /dev/null +++ b/tests/testutils.GUIDE @@ -0,0 +1,190 @@ +================================================================================ + TESTUTILS GUIDE FOR TEST AUTHORS AND MAINTAINERS + + Erik Leunissen +================================================================================ + + +INTRODUCTION +============ +"testutils" is a mechanism that manages utility procs that are used by multiple +test files: +- it keeps them in a central place to prevent code duplication. +- it provides these utility procs to test files, similar to what a Tcl package + (using a namespace) does: it exports the utilities, and the test files import + them. +The entire mechanism is implemented in a single file "testutils.tcl". + +Section A of this document explains the usage of the mechanism, targeted at +test authors. Section B provides a more detailed description of the innards and +workings of the testutils mechanism. This information is specifically targeted +at developers carrying out maintenance of the testutils mechanism. + + +A. USING UTILITY PROCS IN TESTS AND TEST FILES +============================================== +This section explains to test authors how utility procs are organized, how to +use existing utility procs in a test file, and how to create new utility procs. + +A1. Organization of utility procs using namespaces +-------------------------------------------------- +The utility procs that testutils provides are grouped into functional areas. +These functional areas are also called "domains", or "utility domains". They +carry names such as "dialog","entry", "text", which conform more or less to +names of test files in the Tk test suite. + +Utility procs are imported on demand by test files, using the command "testutils". +(See the explanation of this command in the next section.) Utility procs for +the domain "generic" are an exception to this general rule: these procs are +imported into the global namespace as a standard policy. They are readily +available to the test author, in each test file. + +Each domain has its own namespace below ::tk::test in which utility procs are +defined. For example: utilities that are specific for Tk dialogs are stored +inside the namespace ::tk::test::dialog. + +A2. Using existing utility procs in test files +---------------------------------------------- +The command "testutils" is the interface to the testutils mechanism for the test +author. The test author may use it to import utility procs into the namespace +in which tests are executed (normally, this is the global namespace). The command +takes the following form: + + testutils (import|forget) domain ?domain domain ...? + +The command "testutils import" is typically invoked at the top of a test file. +The command "testutils forget" is typically invoked at the end of a test file. +These commands take care of the importing and cleaning up of utility procs +for a specific domain. They also take care of importing any namespace variables +associated with these procs so that they can be accessed from within a test. + +Typical invocations in a test file (using the domain "dialog" as an example), are: + +┃ testutils import dialog +┃ ⋮ +┃ test foo-1.0 -body { +┃ ⋮ +┃ ⋮ +┃ SendButtonPress; # invoke utility proc imported from domain "dialog" +┃ ⋮ +┃ ⋮ +┃ } -result {foo_result} +┃ ⋮ +┃ testutils forget dialog + +The command "testutils import" fails if a proc or variable, unrelated to the +testutils mechanism, but having the same name as a utility proc or associated +variable, was already defined in the importing namespace. Therefore, test +authors need to take care that such procs and variables are cleaned up before +the end of a test file. + +A3. Adding new utility procs +---------------------------- +Test authors may define new utility procs in the file "testutils.tcl". When doing +so, there are several points to be aware of: + +1. Consider whether the new utility proc is used in multiple test files. If + it's not, it may as well be defined inside the specific test file that uses + it, because in that case the issue of code duplication doesn't exist. + +2. Add the proc definition to the proper domain namespace. If necessary, create + a new domain namespace. + +3. It may be the case that tests need to access (read/write) variables that are + associated with the new utility proc. The command "testutils" also handles + the importing and initialization of these associated variables, but attention + is needed for the following: + + Their definition needs to be to placed in the reserved proc "init" (inside + the proper domain namespace). The command "testutils import" will import any + variables defined in this proc into the namespace where tests are executing. + + Note that just placing associated namespace variables inside the "namespace eval" + scope for the specific domain, but outside the init proc, isn't good enough + because that foregoes the importing of the namespace variables as well as their + automatic initialization. + + Also: any namespace variables initialized inside the "namespace eval" scope + for the specific domain, but outside the init proc, will NOT be cleaned up + upon the invocation of "testutils forget", in contrast to imported + namespace variables. + +4. If you created a new domain namespace in step 2, then export the test + utilities using the command "testutils export". This ensures that all utility + procs in the domain namespace are exported, except any init proc. + +The file testutils.tcl contains various examples showing this practice. + + +B. INNER WORKINGS OF THE TESTUTILS MECHANISM +============================================ +This section is targeted at developers carrying out maintenance of the testutils +mechanism, whether debugging or improving it otherwise. + +B1. Files and file loading +-------------------------- +The entire testutils mechanism is implemented in a single file "testutils.tcl". +This file is sourced on behalf of each test file by a command in the file +"main.tcl", which in turn is loaded through the tcltest option "-loadfile" in +the file "all.tcl". + +B2. Importing procs and associated namespace variables +------------------------------------------------------ +The command "testutils" makes utility procs available to the namespace in which +test files execute. The command employs a plain "namespace export/namespace import" +for importing procs; there is nothing special about that. However, special +attention is needed for those utility procs that store state in a namespace +variable that is also accessed from the namespace in which tests are executing. +Such variables are made available to the namespace in which tests are executing +using an upvar statement. The process of importing these associated namespace +variables needs to handle some specifics: + +Besides making them available to test files, some tests require such variables +to be initialized, regardless whatever the previous test file did to them. +Therefore, the proc "testutils" needs to re-initialize these upvar'ed variables +for each test file that imports them. The steps in this auto-initialization +process are as follows: + +- if a namespace for a specific functional area holds a proc "init", the + command "testutils import xxx" will invoke it, thus initializing namespace + variables. It subsequently imports the variables into the namespace where + tests are executing, using "upvar"; +- upon test file cleanup, "testutils forget xxx" removes the imported utility + procs and unsets the upvar'ed variables. (Note that this doesn't remove the + upvar link in the source namespace.) When a subsequent test file invokes + "testutils import xxx" again, the command will re-initialize the namespace + variables. + +A typical init proc (for a fictitious domain "cuisine") is: + + proc init {} { + variable doneNess medium-rare + variable seasonings [list salt pepper] + variable tasteVerdict + } + +Note that the namespace variables "doneNess" and "seasonings" are initialized +with a value, while the namespace variable "tasteVerdict" is not. Both variants +of declaring/defining a namespace variable are supported. + +B3. Tricky aspects of repeated initialization +--------------------------------------------- +While the entire Tk test suite is running, many test files are loaded, each of +which may import and subsequently forget utility domains. When tracking a single +utility domain across test files that come and go, associated namespace variables +may be imported, initialized and cleaned up repeatedly. This repetitive cycle +presents tricky aspects for the re-initialization of those namespace variables +that were declared using the "variable" command without supplying a value. This +is caused by the fact that, once established, the upvar link for imported +namespace variables cannot be removed. The tricky details are explicitly +described by comments in the proc testutils. + +Another tricky detail - that testutils currently evades - is the fact that +unsetting an upvar'ed namespace variable changes its visibility for "info vars" +in the utility namespace where the variable was defined, but not in the namespace +where the upvar statement was invoked. + +B4. Test file +------------- +The correct functioning of the testutils mechanism is tested by the test +file "testutils.test". diff --git a/tests/testutils.tcl b/tests/testutils.tcl new file mode 100644 index 0000000..322e277 --- /dev/null +++ b/tests/testutils.tcl @@ -0,0 +1,989 @@ +# testutils.tcl -- +# +# This file is sourced by each test file when invoking "tcltest::loadTestedCommands". +# It implements the testutils mechanism which is used to import utility procs +# into test files that need them. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. + +# +# DOCUMENTATION FOR TEST AUTHORS AND MAINTAINERS +# +# The testutils mechanism is documented in the separate file "testutils.GUIDE", +# which is placed in the same directory as this file "testutils.tcl". +# + +namespace eval ::tk::test { + # + # The namespace ::tk::test itself doesn't contain any procs or variables. + # The contents of this namespace exist solely in child namespaces that + # are defined hereafter. + # + # Each child namespace represents a functional area, also called "domain". + # +} + + +namespace eval ::tk::test::generic { + + proc assert {expr} { + if {! [uplevel 1 [list expr $expr]]} { + return -code error "assertion failed: \"[uplevel 1 [list subst -nocommands $expr]]\"" + } + } + + # controlPointerWarpTiming -- + # + # This proc is intended to ensure that the (mouse) pointer has actually + # been moved to its new position after a Tk test issued: + # + # [event generate $w $event -warp 1 ...] + # + # It takes care of the following timing details of pointer warping: + # + # a. Allow pointer warping to happen if it was scheduled for execution at + # idle time. This happens synchronously if $w refers to the + # whole screen or if the -when option to [event generate] is "now". + # + # b. Work around a race condition associated with OS notification of + # mouse motion on Windows. + # + # When calling [event generate $w $event -warp 1 ...], the following + # sequence occurs: + # - At some point in the processing of this command, either via a + # synchronous execution path, or asynchronously at idle time, Tk calls + # an OS function* to carry out the mouse cursor motion. + # - Tk has previously registered a callback function** with the OS, for + # the OS to call in order to notify Tk when a mouse move is completed. + # - Tk doesn't wait for the callback function to receive the notification + # from the OS, but continues processing. This suits most use cases + # because usually the notification arrives fast enough (within a few tens + # of microseconds). However ... + # - A problem arises if Tk performs some processing, immediately following + # up on [event generate $w $event -warp 1 ...], and that processing + # relies on the mouse pointer having actually moved. If such processing + # happens just before the notification from the OS has been received, + # Tk will be using not yet updated info (e.g. mouse coordinates). + # + # Hickup, choke etc ... ! + # + # * the function SendInput() of the Win32 API + # ** the callback function is TkWinChildProc() + # + # This timing issue can be addressed by putting the Tk process on hold + # (do nothing at all) for a somewhat extended amount of time, while + # letting the OS complete its job in the meantime. This is what is + # accomplished by calling [after ms]. + # + # ---- + # For the history of this issue please refer to Tk ticket [69b48f427e], + # specifically the comment on 2019-10-27 14:24:26. + # + # + # Beware: there are cases, not (yet) exercised by the Tk test suite, where + # [controlPointerWarpTiming] doesn't ensure the new position of the pointer. + # For example, when issued under Tk8.7+, if the value for the -when option + # to [event generate $w] is not "now", and $w refers to a Tk window, i.e. not + # the whole screen. + # + proc controlPointerWarpTiming {{duration 50}} { + update idletasks ;# see a. above + if {[tk windowingsystem] eq "win32"} { + after $duration ;# see b. above + } + } + + proc deleteWindows {} { + destroy {*}[winfo children .] + # This update is needed to avoid intermittent failures on macOS in unixEmbed.test + # with the (GitHub Actions) CI runner. + # Reason for the failures is unclear but could have to do with window ids being deleted + # after the destroy command returns. The detailed mechanism of such delayed deletions + # is not understood, but it appears that this update prevents the test failures. + update + } + + proc fixfocus {} { + catch {destroy .focus} + toplevel .focus + wm geometry .focus +0+0 + entry .focus.e + .focus.e insert 0 "fixfocus" + pack .focus.e + update + focus -force .focus.e + destroy .focus + } + + proc loadTkCommand {} { + variable TkLoadCmd + if {! [info exists TkLoadCmd]} { + foreach pkg [info loaded] { + if {[lindex $pkg 1] eq "Tk"} { + set TkLoadCmd [list load {*}$pkg] + break + } + } + } + return $TkLoadCmd + } + + # Suspend script execution for a given amount of time, but continue + # processing events. + proc pause {ms} { + variable _pause + + set num [incr _pause(count)] + set _pause($num) 1 + + after $ms [list unset [namespace current]::_pause($num)] + vwait [namespace current]::_pause($num) + } + + # On macOS windows are not allowed to overlap the menubar at the top of the + # screen or the dock. So tests which move a window and then check whether it + # got moved to the requested location should use a y coordinate larger than the + # height of the menubar (normally 23 pixels) and an x coordinate larger than the + # width of the dock, if it happens to be on the left. + # The C-level command "testmenubarheight" deals with this issue but it may + # not be available on each platform. Therefore, provide a fallback here. + if {[llength [info commands testmenubarheight]] == 0} { + if {[tk windowingsystem] ne "aqua"} { + # Windows may overlap the menubar + proc testmenubarheight {} { + return 0 + } + } else { + # Windows may not overlap the menubar + proc testmenubarheight {} { + return 30 ; # arbitrary value known to be larger than the menubar height + } + } + } + + # testutils -- + # + # Takes care of exporting/importing/forgetting utility procs and any + # associated variables from a specific test domain (functional area). + # + # More information is available in the file "testutils.GUIDE" + # + # Arguments: + # subCmd : "export", "import" or "forget" + # args : a sequence of domains that need to be imported/forgotten, + # unused for "export" + # + proc testutils {subCmd args} { + variable importedDomains + variable importVars + + if {$subCmd ni [list export import forget]} { + return -code error "invalid subCmd \"$subCmd\". Usage: [lindex [info level 0] 0] export|import|forget ?domain domain ...?" + } + + set argc [llength $args] + if {$subCmd eq "export"} { + if {$argc != 0} { + return -code error "invalid #args. Usage: [lindex [info level 0] 0] export" + } + + # export all procs from the invoking domain namespace except "init" + uplevel 1 { + if {[info procs init] eq "init"} { + set exports [info procs] + namespace export {*}[lremove $exports [lsearch $exports "init"]] + unset exports + } else { + namespace export * + } + } + return + } + if {$argc < 1} { + return -code error "invalid #args. Usage: [lindex [info level 0] 0] import|forget domain ?domain ...?" + } + + # determine the requesting namespace + set ns [uplevel 1 {namespace current}] + + # import/forget domains + foreach domain $args { + if {! [namespace exists ::tk::test::$domain]} { + return -code error "testutils domain \"$domain\" doesn't exist" + } + + switch -- $subCmd { + import { + if {[info exists importedDomains($ns)] && ($domain in $importedDomains($ns))} { + return -code error "testutils domain \"$domain\" was already imported" + } else { + + # import procs + if {[catch { + uplevel 1 [list namespace import ::tk::test::${domain}::*] + } errMsg]} { + # revert import of procs already done + uplevel 1 [list namespace forget ::tk::test::${domain}::*] + return -code error "import from testutils domain \"$domain\" failed: $errMsg" + } + + # import associated namespace variables declared in the init proc + if {"init" in [namespace inscope ::tk::test::$domain {info procs init}]} { + if {[info exists importVars($ns,$domain)]} { + # + # Note [A1]: + # If test files inadvertently leave behind a variable with the same name + # as an upvar'ed namespace variable, its last value will serve as a new + # initial value in case that the init proc declares that variable without + # a value. Also, the result of "info exists varName" would be different + # between test files. + # + # The next unset prevents such artefacts. See also note [A2] below. + # + uplevel 1 [list unset -nocomplain {*}$importVars($ns,$domain)] + } + ::tk::test::${domain}::init + if {($ns ne "::") || (! [info exists importVars($ns,$domain)])} { + # + # Importing associated namespace variables into the global namespace where + # tests are normally executing, needs to be done only once because an upvar + # link cannot be removed from a namespace. For other requesting namespaces + # we need to reckon with deletion and re-creation of the namespace in the + # meantime. + # + if {[info exists importVars($ns,$domain)]} { + set associatedVars $importVars($ns,$domain) + } else { + set associatedVars [namespace inscope ::tk::test::$domain {info vars}] + } + foreach varName $associatedVars { + if {[catch { + uplevel 1 [list upvar #0 ::tk::test::${domain}::$varName $varName] + } errMsg]} { + # revert imported procs and partial variable import + uplevel 1 [list unset -nocomplain {*}$associatedVars] + uplevel 1 [list namespace forget ::tk::test::${domain}::*] + return -code error "import from testutils domain \"$domain\" failed: $errMsg" + } + } + set importVars($ns,$domain) $associatedVars + } + } + + # register domain as imported + lappend importedDomains($ns) $domain + } + } + forget { + if {(! [info exists importedDomains($ns)]) || ($domain ni $importedDomains($ns))} { + return -code error "testutils domain \"$domain\" was not imported" + } + + # remove imported utility procs from the namespace where tests are executing + uplevel 1 [list namespace forget ::tk::test::${domain}::*] + + # + # Some namespace variables are meant to persist across test files + # in the entire Tk test suite (notably the variable ImageNames, + # domain "image"). These variables are also not meant to be accessed + # from, and imported into the namespace where tests are executing, + # and they should not be cleaned up here. + # + + if {[info exists importVars($ns,$domain)]} { + # + # Remove imported namespace variables. + # + # Note [A2]: + # The upvar link in the namespace where tests are executing cannot be removed. + # Without specific attention, this can cause surprising behaviour upon + # re-initialization. See also note [A1] above. + # + uplevel 1 [list unset -nocomplain {*}$importVars($ns,$domain)] + } + set importedDomains($ns) [lremove $importedDomains($ns) [lsearch $importedDomains($ns) $domain]] + } + } + } + } + + testutils export +} + +# Import generic utility procs into the global namespace (in which tests are +# normally executing) as a standard policy. +::tk::test::generic::testutils import generic + +namespace eval ::tk::test::button { + proc bogusTrace args { + error "trace aborted" + } + testutils export +} + +namespace eval ::tk::test::child { + + # childTkInterp -- + # + # Create a new Tk application in a child interpreter, with + # a given name and class. + # + proc childTkInterp {name args} { + set index [lsearch $args "-safe"] + if {$index >= 0} { + set safe 1 + set options [lremove $args $index] + } else { + set safe 0 + set options $args + } + if {[llength $options] ni {0 2}} { + return -code error "invalid #args" + } + + set cmdArgs [list -name $name] + foreach {key value} $options { + if {$key ne "-class"} { + return -code error "invalid option \"$key\"" + } + lappend cmdArgs $key $value + } + + if {$safe} { + interp create -safe $name + } else { + interp create $name + } + + $name eval [list set argv $cmdArgs] + catch {eval [loadTkCommand] $name} + } + + # childTkProcess -- + # + # Create a new Tk application in a child process, and enable it to + # evaluate scripts on our behalf. + # + # Suggestion: replace with child interp or thread ? + # + proc childTkProcess {subcmd args} { + variable fd + switch -- $subcmd { + create { + if {[info exists fd] && [string length $fd]} { + childTkProcess exit + } + set fd [open "|[list [::tcltest::interpreter] \ + -geometry +0+0 -name tktest] $args" r+] + puts $fd "puts foo; flush stdout" + flush $fd + if {[gets $fd data] < 0} { + error "unexpected EOF from \"[::tcltest::interpreter]\"" + } + if {$data ne "foo"} { + error "unexpected output from\ + background process: \"$data\"" + } + puts $fd [loadTkCommand] + flush $fd + fileevent $fd readable [namespace code {childTkProcess read}] + } + eval { + variable Data + variable Done + + set script [lindex $args 0] + set block 0 + if {[llength $args] == 2} { + set block [lindex $args 1] + } + + if {$block} { + fileevent $fd readable {} + } + puts $fd "[list catch $script msg]; update; puts \$msg;\ + puts **DONE**; flush stdout" + flush $fd + set Data {} + if {$block} { + while {![eof $fd]} { + set line [gets $fd] + if {$line eq "**DONE**"} { + break + } + append Data $line + } + } else { + set Done 0 + vwait [namespace which -variable Done] + } + return $Data + } + exit { + # catch in case the child process has closed $fd + catch {puts $fd exit} + catch {close $fd} + set fd "" + } + read { + variable Data + variable Done + set x [gets $fd] + if {[eof $fd]} { + fileevent $fd readable {} + set Done 1 + } elseif {$x eq "**DONE**"} { + set Done 1 + } else { + append Data $x + } + } + } + } + + testutils export +} + +namespace eval ::tk::test::colors { + # colorsFree -- + # + # Returns 1 if there appear to be free colormap entries in a window, 0 + # otherwise. + # + # Arguments: + # w : name of window in which to check. + # red, green, blue : intensities to use in a trial color allocation + # to see if there are colormap entries free. + # + proc colorsFree {w {red 31} {green 245} {blue 192}} { + lassign [winfo rgb $w [format "#%02x%02x%02x" $red $green $blue]] r g b + expr {($r/256 == $red) && ($g/256 == $green) && ($b/256 == $blue)} + } + + # eatColors -- + # + # Creates a toplevel window and allocates enough colors in it to use up all + # the slots in an 8-bit colormap. + # + # Arguments: + # w : name of toplevel window to create. + # + proc eatColors {w} { + catch {destroy $w} + toplevel $w + wm geom $w +0+0 + canvas $w.c -width 400 -height 200 -bd 0 + pack $w.c + for {set y 0} {$y < 8} {incr y} { + for {set x 0} {$x < 40} {incr x} { + set color [format #%02x%02x%02x [expr {$x*6}] [expr {$y*30}] 0] + $w.c create rectangle [expr {10*$x}] [expr {20*$y}] \ + [expr {10*$x + 10}] [expr {20*$y + 20}] -outline {} \ + -fill $color + } + } + update + } + + testutils export +} + +namespace eval ::tk::test::dialog { + + # init -- + # + # This is a reserved proc that is part of the mechanism that the proc + # testutils employs when making utility procs and associated namespace + # variables available to test files. + # + # Test authors should define and initialize namespace variables here if + # they need to be imported into the namespace in which tests are executing. + # This proc must not be exported. + # + # For more information, see the documentation in the file "testutils.GUIDE" + # + proc init {} { + variable dialogType [file rootname [file tail [info script]]] + variable dialogIsNative [isNative $dialogType] + variable testDialog + variable testDialogFont + } + + proc Click {button} { + variable dialogType + variable testDialog + + switch -- $dialogType { + "fontchooser" { + if {$button ni "ok cancel apply"} { + return -code error "invalid button name \"$button\"" + } + $testDialog.$button invoke + } + "winDialog" { + switch -exact -- $button { + ok { set button 1 } + cancel { set button 2 } + } + testwinevent $testDialog $button WM_LBUTTONDOWN 1 0x000a000b + testwinevent $testDialog $button WM_LBUTTONUP 0 0x000a000b + } + default { + return -code error "invalid dialog type \"$dialogType\"" + } + } + } + + proc isNative {type} { + switch -- $type { + "choosedir" { + set cmd ::tk_chooseDirectory + } + "clrpick" { + set cmd ::tk_chooseColor + } + "filebox" { + set cmd ::tk_getOpenFile + } + "msgbox" { + set cmd ::tk_messageBox + } + "dialog" - + "fontchooser" - + "winDialog" { + return "N/A" + } + default { + return -code error "invalid dialog type \"$type\"" + } + } + return [expr {[info procs $cmd] eq ""}] + } + + proc PressButton {btn} { + event generate $btn <Enter> + event generate $btn <Button-1> -x 5 -y 5 + event generate $btn <ButtonRelease-1> -x 5 -y 5 + } + + proc SendButtonPress {parent btn buttonType} { + variable dialogType + switch -- $dialogType { + "choosedir" { + if {$parent eq "."} { + set w .__tk_choosedir + } else { + set w $parent.__tk_choosedir + } + upvar ::tk::dialog::file::__tk_choosedir data + } + "clrpick" { + set w .__tk__color + upvar ::tk::dialog::color::[winfo name $w] data + } + "filebox" { + if {$parent eq "."} { + set w .__tk_filedialog + } else { + set w $parent.__tk_filedialog + } + upvar ::tk::dialog::file::__tk_filedialog data + } + "msgbox" { + if {$parent eq "."} { + set w .__tk__messagebox + } else { + set w $parent.__tk__messagebox + } + } + default { + return -code error "invalid dialog type \"$dialogType\"" + } + } + + if {$dialogType eq "msgbox"} { + set button $w.$btn + } else { + set button $data($btn\Btn) + } + if {! [winfo ismapped $button]} { + update + } + + if {$buttonType eq "mouse"} { + PressButton $button + } else { + event generate $w <Enter> + focus $w + event generate $button <Enter> + event generate $w <Key> -keysym Return + } + } + + proc testDialog {stage {script ""}} { + variable testDialogCmd + variable testDialogResult + variable testDialogFont + variable iter_after + variable testDialog; # On MS Windows, this variable is set at the C level + # by SetTestDialog() in tkWinDialog.c + + switch -- $stage { + launch { + set iter_after 0 + set testDialog {} + if {$::tcl_platform(platform) eq "windows"} { + variable testDialogClass "#32770" + } + + after 1 $script + } + onDisplay { + set testDialogCmd $script + set testDialogResult {} + set testDialogFont {} + + if {$::tcl_platform(platform) eq "windows"} { + # Do not make the delay too short. The newer Vista dialogs take + # time to come up. + after 500 [list [namespace current]::testDialog onDisplay2] + } else { + testDialog onDisplay2 + } + vwait ::tk::test::dialog::testDialogResult + return $testDialogResult + } + onDisplay2 { + set doRepeat 0 + + if {$::tcl_platform(platform) eq "windows"} { + # On Vista and later, using the new file dialogs we have to + # find the window using its title as testDialog will not be + # set at the C level. + variable testDialogClass + if {[catch {testfindwindow "" $testDialogClass} testDialog]} { + set doRepeat 1 + } + } elseif {$testDialog eq ""} { + set doRepeat 1 + } + + if {$doRepeat} { + if {[incr iter_after] > 30} { + set testDialogResult ">30 iterations waiting for testDialog" + return + } + after 150 [list ::tk::test::dialog::testDialog onDisplay2] + return + } + set testDialogResult [uplevel #0 $testDialogCmd] + } + default { + return -code error "invalid parameter \"$stage\"" + } + } + } + + proc ToPressButton {parent btn} { + variable dialogIsNative + if {! $dialogIsNative} { + after 100 SendButtonPress $parent $btn mouse + } + } + + testutils export +} + + +namespace eval ::tk::test::entry { + + # init -- + # + # This is a reserved proc that is part of the mechanism that the proc + # testutils employs when making utility procs and associated namespace + # variables available to test files. + # + # Test authors should define and initialize namespace variables here if + # they need to be imported into the namespace in which tests are executing. + # This proc must not be exported. + # + # For more information, see the documentation in the file "testutils.GUIDE" + # + proc init {} { + variable textVar + variable validationData + } + + # Handler for variable trace on namespace variable textVar + proc override args { + variable textVar 12345 + } + + # Procedures used by widget validation tests + proc validateCommand1 {W d i P s S v V} { + variable validationData [list $W $d $i $P $s $S $v $V] + return 1 + } + proc validateCommand2 {W d i P s S v V} { + variable validationData [list $W $d $i $P $s $S $v $V] + variable textVar mydata + return 1 + } + proc validateCommand3 {W d i P s S v V} { + variable validationData [list $W $d $i $P $s $S $v $V] + return 0 + } + proc validateCommand4 {W d i P s S v V} { + variable validationData [list $W $d $i $P $s $S $v $V] + .e delete 0 end; + .e insert end dovaldata + return 0 + } + + testutils export +} + +namespace eval ::tk::test::geometry { + proc getsize {w} { + update + return "[winfo reqwidth $w] [winfo reqheight $w]" + } + + testutils export +} + +namespace eval ::tk::test::image { + + proc imageCleanup {} { + variable ImageNames + foreach img [image names] { + if {$img ni $ImageNames} {image delete $img} + } + } + + proc imageFinish {} { + variable ImageNames + set imgs [lsearch -all -inline -glob -not [lsort [image names]] ::tk::icons::indicator*] + if {$imgs ne $ImageNames} { + return -code error "images remaining: [image names] != $ImageNames" + } + imageCleanup + } + + proc imageInit {} { + variable ImageNames + if {![info exists ImageNames]} { + set ImageNames [lsearch -all -inline -glob -not [lsort [image names]] ::tk::icons::indicator*] + } + imageCleanup + if {[lsort [image names]] ne $ImageNames} { + return -code error "IMAGE NAMES mismatch: [image names] != $ImageNames" + } + } + + proc imageNames {} { + variable ImageNames + set r {} + foreach img [image names] { + if {$img ni $ImageNames} {lappend r $img} + } + return $r + } + + testutils export +} + +namespace eval ::tk::test::scroll { + + # init -- + # + # This is a reserved proc that is part of the mechanism that the proc + # testutils employs when making utility procs and associated namespace + # variables available to test files. + # + # Test authors should define and initialize namespace variables here if + # they need to be imported into the namespace in which tests are executing. + # This proc must not be exported. + # + # For more information, see the documentation in the file "testutils.GUIDE" + # + proc init {} { + variable scrollInfo {} + } + + # Used as the scrolling command for widgets, set with "-[xy]scrollcommand". + # It saves the scrolling information in a namespace variable "scrollInfo". + proc setScrollInfo {args} { + variable scrollInfo $args + } + + testutils export +} + +namespace eval ::tk::test::select { + + # init -- + # + # This is a reserved proc that is part of the mechanism that the proc + # testutils employs when making utility procs and associated namespace + # variables available to test files. + # + # Test authors should define and initialize namespace variables here if + # they need to be imported into the namespace in which tests are executing. + # This proc must not be exported. + # + # For more information, see the documentation in the file "testutils.GUIDE" + # + proc init {} { + variable selValue {} selInfo {} + variable abortCount + variable pass + } + + proc badHandler {path type offset count} { + variable selInfo + variable selValue + selection handle -type $type $path {} + lappend selInfo $path $type $offset $count + set numBytes [expr {[string length $selValue] - $offset}] + if {$numBytes <= 0} { + return "" + } + string range $selValue $offset [expr {$numBytes+$offset}] + } + + proc badHandler2 {path type offset count} { + variable abortCount + variable selInfo + variable selValue + incr abortCount -1 + if {$abortCount == 0} { + selection handle -type $type $path {} + } + lappend selInfo $path $type $offset $count + set numBytes [expr {[string length $selValue] - $offset}] + if {$numBytes <= 0} { + return "" + } + string range $selValue $offset [expr {$numBytes+$offset}] + } + + proc errHandler args { + error "selection handler aborted" + } + + proc errIncrHandler {type offset count} { + variable selInfo + variable selValue + variable pass + if {$offset == 4000} { + if {$pass == 0} { + # Just sizing the selection; don't do anything here. + set pass 1 + } else { + # Fetching the selection; wait long enough to cause a timeout. + after 6000 + } + } + lappend selInfo $type $offset $count + set numBytes [expr {[string length $selValue] - $offset}] + if {$numBytes <= 0} { + return "" + } + string range $selValue $offset [expr $numBytes+$offset] + } + + proc handler {type offset count} { + variable selInfo + variable selValue + lappend selInfo $type $offset $count + set numBytes [expr {[string length $selValue] - $offset}] + if {$numBytes <= 0} { + return "" + } + string range $selValue $offset [expr $numBytes+$offset] + } + + proc reallyBadHandler {path type offset count} { + variable selInfo + variable selValue + variable pass + if {$offset == 4000} { + if {$pass == 0} { + set pass 1 + } else { + selection handle -type $type $path {} + } + } + lappend selInfo $path $type $offset $count + set numBytes [expr {[string length $selValue] - $offset}] + if {$numBytes <= 0} { + return "" + } + string range $selValue $offset [expr {$numBytes+$offset}] + } + + proc selectionSetup {{path .f1} {display {}}} { + catch {destroy $path} + if {$display eq ""} { + frame $path + } else { + toplevel $path -screen $display + wm geom $path +0+0 + } + selection own $path + } + + testutils export +} + +namespace eval ::tk::test::text { + + # init -- + # + # This is a reserved proc that is part of the mechanism that the proc + # testutils employs when making utility procs and associated namespace + # variables available to test files. + # + # Test authors should define and initialize namespace variables here if + # they need to be imported into the namespace in which tests are executing. + # This proc must not be exported. + # + # For more information, see the documentation in the file "testutils.GUIDE" + # + proc init {} { + variable fixedFont {Courier -12} + variable fixedWidth [font measure $fixedFont m] + variable fixedHeight [font metrics $fixedFont -linespace] + variable fixedAscent [font metrics $fixedFont -ascent] + } + + # full border size of the text widget, i.e. first x or y coordinate inside the text widget + # warning: -padx is supposed to be the same as -pady (same border size horizontally and + # vertically around the widget) + proc bo {{w .t}} { + return [expr {[$w cget -borderwidth] + [$w cget -highlightthickness] + [$w cget -padx]}] + } + + # x-coordinate of the first pixel of $n-th char (count starts at zero), left justified + proc xchar {n {w .t}} { + return [expr {[bo $w] + [xw $n]}] + } + + # x-width of $n chars, fixed width font + proc xw {n} { + variable fixedWidth + return [expr {$n * $fixedWidth}] + } + + # y-coordinate of the first pixel of $l-th display line (count starts at 1) + proc yline {l {w .t}} { + variable fixedHeight + return [expr {[bo $w] + ($l - 1) * $fixedHeight}] + } + + testutils export +} + +# EOF diff --git a/tests/testutils.test b/tests/testutils.test new file mode 100644 index 0000000..747b0e2 --- /dev/null +++ b/tests/testutils.test @@ -0,0 +1,188 @@ +# Tests for the "testutils" command, defined in testutils.tcl +# +# © 2025 Erik Leunissen +# +# See the file "license.terms" for information on usage and redistribution of +# this file, and for a DISCLAIMER OF ALL WARRANTIES. +# + +package require tcltest 2.2 +eval tcltest::configure $argv +tcltest::loadTestedCommands + +# Notes: +# +# - All tests have been constrained with test constraint "testutils". This +# constraint isn't set anywhere, and therefore false by default. Therefore, +# the tests in this file are skipped in a regular invocation of the Tk test +# suite. In order to run these test, you need to use the tcltest option +# "-constraints testutils" in the invocation, possibly combined with the +# option "-file testutils.test" to exclude other test files, or with +# "-limitconstraints true" to exclude other tests. +# +# - At this place in the test file, the file "testutils.tcl" has already been +# sourced (through tcltest::loadTestedCommands above), and the utility procs +# from domain "generic" are already available. Therefore we can make use of +# proc "assert" here. +# + +assert {"testutils" in [info procs testutils]} + +# +# Section 1: invalid invocations +# +test testutils-1.1 {invalid subcommand} -constraints testutils -body { + testutils foo +} -result {invalid subCmd "foo". Usage: testutils export|import|forget ?domain domain ...?} -returnCodes error + +test testutils-1.2 {invalid #args for subCmd export} -constraints testutils -body { + testutils export foo +} -result {invalid #args. Usage: testutils export} -returnCodes error + +test testutils-1.3 {invalid #args for subCmd import} -constraints testutils -body { + testutils import +} -result {invalid #args. Usage: testutils import|forget domain ?domain ...?} -returnCodes error + +test testutils-1.4 {invalid #args for subCmd forget} -constraints testutils -body { + testutils forget +} -result {invalid #args. Usage: testutils import|forget domain ?domain ...?} -returnCodes error + +test testutils-1.5 {invalid domain for subCmd import} -constraints testutils -body { + testutils import foo +} -result {testutils domain "foo" doesn't exist} -returnCodes error + +test testutils-1.6 {invalid domain for subCmd forget} -constraints testutils -body { + testutils forget foo +} -result {testutils domain "foo" doesn't exist} -returnCodes error + +# +# Create a domain namespace for testing export, import, forget +# +assert {"::tk::test::foo" ni [namespace children ::tk::test]} +assert {"::tk::test::zez" ni [namespace children ::tk::test]} +catch {rename init {}} +catch {rename kuk {}} +unset -nocomplain bar pip +namespace eval ::tk::test::foo { + proc init {} { + variable bar 123 + variable pip + } + proc kuk {} {} + testutils export +} +set initVars [info vars]; lappend initVars initVars + +# +# 2. Domain failures for forget and import +# +test testutils-2.1 {forget not-imported domain} -constraints testutils -body { + testutils forget foo +} -result {testutils domain "foo" was not imported} -returnCodes error + +test testutils-2.2 {duplicate import} -constraints testutils -body { + testutils import foo + testutils import foo +} -result {testutils domain "foo" was already imported} -returnCodes error -cleanup { + testutils forget foo +} + +# +# 3. Import procs +# +test testutils-3.1 {utility proc is imported and init proc is not} -constraints testutils -body { + testutils import foo + expr {([info procs kuk] eq "kuk") && ([info procs init] eq "")} +} -result 1 -cleanup { + testutils forget foo +} + +test testutils-3.2 {forget removes utility proc} -constraints testutils -body { + testutils import foo + testutils forget foo + info procs kuk +} -result {} + +test testutils-3.3 {import fails: proc already exists} -constraints testutils -setup { + namespace eval ::zez { + proc kuk {} {} + } +} -body { + namespace eval ::zez { + testutils import foo + } +} -result "import from testutils domain \"foo\" failed: can't import command \"kuk\": already exists" -returnCodes error -cleanup { + namespace delete ::zez +} + +# +# 4. Import variables +# +test testutils-4.1 {associated variables are imported} -constraints testutils -body { + testutils import foo + set varNames [info vars] + foreach name $initVars { + set varNames [lremove $varNames [lsearch $varNames $name]] + } + list [lsort $varNames] [info exists bar] [info exists pip] $bar +} -result [list {bar pip} 1 0 123] -cleanup { + unset -nocomplain name varNames + testutils forget foo +} + +test testutils-4.2 { + Repeated initialization keeps imported variable defined without value non-existent, + even if a test file inadvertently assigns it a value in the meantime. +} -constraints testutils -body { + catch { + testutils import foo + } + testutils forget foo + set pip 11111 + testutils import foo + info exists pip +} -result 0 -cleanup { + testutils forget foo +} + +test testutils-4.3 {import fails: variable already exists} -constraints testutils -setup { + # + # We need a pristine new namespace in which the variable bar was never imported + # and hence no upvar link for it exists. + # + namespace eval ::zez { + set bar 11 + } +} -body { + namespace eval ::zez { + testutils import foo + } +} -result "import from testutils domain \"foo\" failed: variable \"bar\" already exists" -returnCodes error -cleanup { + namespace delete ::zez +} + +test testutils-4.4 {repeated creation/deletion of requesting namespace doesn't fool testutils} -constraints testutils -setup { +} -body { + namespace eval ::zez { + testutils import foo + testutils forget foo + } + namespace delete ::zez + namespace eval ::zez { + set pip 22 + testutils import foo + list [info exists bar] [info exists pip] $bar + } +} -result {1 0 123} -cleanup { + namespace delete ::zez +} + +# +# CLEANUP +# + +namespace delete ::tk::test::foo +unset -nocomplain bar initVars pip +cleanupTests + +# EOF diff --git a/tests/textBTree.test b/tests/textBTree.test index 35d274f..0f099a6 100644 --- a/tests/textBTree.test +++ b/tests/textBTree.test @@ -1304,6 +1304,10 @@ test btree-18.9 {tag search back, large complex btree spans} -setup { destroy .t } -result {{500.0 520.0} {200.0 220.0}} -# cleanup +# +# CLEANUP +# + +rename setup {} cleanupTests return diff --git a/tests/textDisp.test b/tests/textDisp.test index 3555ae7..d5380b3 100644 --- a/tests/textDisp.test +++ b/tests/textDisp.test @@ -11,6 +11,9 @@ eval tcltest::configure $argv tcltest::loadTestedCommands namespace import -force tcltest::test +# Import utility procs for specific functional areas +testutils import scroll text + # The delay procedure needs to wait long enough for the asynchronous updates # performed by the text widget to run. proc delay {} { @@ -19,14 +22,6 @@ proc delay {} { update } -# The procedure below is used as the scrolling command for the text; -# it just saves the scrolling information in a variable "scrollInfo". - -proc scroll args { - global scrollInfo - set scrollInfo $args -} - # The procedure below is used to generate errors during scrolling commands. proc scrollError args { @@ -64,11 +59,6 @@ catch {destroy .f .t} frame .f -width 100 -height 20 pack .f -side left -set fixedFont {Courier -12} -set fixedHeight [font metrics $fixedFont -linespace] -set fixedWidth [font measure $fixedFont m] -set fixedAscent [font metrics $fixedFont -ascent] - set bigFont {Helvetica -24} ; # note: not a fixed-width font! set bigHeight [font metrics $bigFont -linespace] set bigAscent [font metrics $bigFont -ascent] @@ -97,37 +87,17 @@ Some of the upcoming tests will probably fail." # Option -width 20 (characters) below is a fundamental assumption of many # upcoming tests when wrapping enters in play # Also -height 10 (lines) is an important assumption -text .t -font $fixedFont -width 20 -height 10 -yscrollcommand scroll +text .t -font $fixedFont -width 20 -height 10 -yscrollcommand setScrollInfo pack .t -expand 1 -fill both .t tag configure big -font $bigFont .t debug on wm geometry . {} -# full border size of the text widget, i.e. first x or y coordinate inside the text widget -# warning: -padx is supposed to be the same as -pady (same border size horizontally and -# vertically around the widget) -proc bo {{w .t}} { - return [expr {[$w cget -borderwidth] + [$w cget -highlightthickness] + [$w cget -padx]}] -} -# x-width of $n chars, fixed width font -proc xw {n} { - global fixedWidth - return [expr {$n * $fixedWidth}] -} -# x-coordinate of the first pixel of $n-th char (count starts at zero), left justified -proc xchar {n {w .t}} { - return [expr {[bo $w] + [xw $n]}] -} # x-coordinate in widget $w of the first pixel of $n-th char counted from the right, right justified proc xcharr {n {w .t}} { return [expr {[winfo width $w] - [bo $w] - [xw $n]}] } -# y-coordinate of the first pixel of $l-th display line (count starts at 1) -proc yline {l {w .t}} { - global fixedHeight - return [expr {[bo $w] + ($l - 1) * $fixedHeight}] -} # x-pixels of empty space in widget $w on a line containing $n chars proc xe {n {w .t}} { return [expr {[winfo width $w] - (2 * [bo $w]) - [xw $n]}] @@ -1094,7 +1064,7 @@ test textDisp-6.8 {DisplayText, vertical scrollbar updates} { .t count -update -ypixels 1.0 end ; update set scrollInfo } [list 0.0 [expr {10.0/13}]] -.t configure -yscrollcommand {} -xscrollcommand scroll +.t configure -yscrollcommand {} -xscrollcommand setScrollInfo test textDisp-6.9 {DisplayText, horizontal scrollbar updates} { .t configure -wrap none .t delete 1.0 end @@ -1336,7 +1306,7 @@ test textDisp-8.10 {TkTextChanged} haveBigFontTwiceLargerThanTextFont { test textDisp-8.11 {TkTextChanged, scrollbar notification when changes are off-screen} { .t delete 1.0 end .t insert end "1\n2\n3\n4\n5\n6\n7\n8\n9\n10\n11\n12\n" - .t configure -yscrollcommand scroll + .t configure -yscrollcommand setScrollInfo update set scrollInfo "" .t insert end "a\nb\nc\n" @@ -2671,7 +2641,7 @@ test textDisp-17.10 {TkTextScanCmd procedure, word wrapping} { update lequal [list $x [.t index @0,0]] $expected } {1} -.t configure -xscrollcommand scroll -yscrollcommand {} +.t configure -xscrollcommand setScrollInfo -yscrollcommand {} test textDisp-18.1 {GetXView procedure} { .t configure -wrap none @@ -2773,7 +2743,7 @@ test textDisp-18.8 {GetXView procedure} { catch {rename bgerror {}} catch {rename bogus {}} -.t configure -xscrollcommand {} -yscrollcommand scroll +.t configure -xscrollcommand {} -yscrollcommand setScrollInfo test textDisp-19.1 {GetYView procedure} { .t configure -wrap char .t delete 1.0 end @@ -3110,7 +3080,7 @@ test textDisp-19.15 {GetYView procedure} { .t delete 1.0 end update rename bgerror {} - .t configure -yscrollcommand scroll + .t configure -yscrollcommand setScrollInfo set x } {{{scrolling error}} {scrolling error while executing @@ -4924,9 +4894,12 @@ test textDisp-36.1 {Display bug with 'yview insert'} -constraints {knownBug} -se destroy .t1 } -result {} +# +# CLEANUP +# + +testutils forget scroll text deleteWindows option clear - -# cleanup cleanupTests return diff --git a/tests/textImage.test b/tests/textImage.test index f3f9c19..b2befd9 100644 --- a/tests/textImage.test +++ b/tests/textImage.test @@ -11,6 +11,10 @@ package require tcltest 2.2 namespace import ::tcltest::* eval tcltest::configure $argv tcltest::loadTestedCommands + +# Import utility procs for specific functional areas +testutils import image + imageInit # One time setup. Create a font to insure the tests are font metric invariant. @@ -461,12 +465,14 @@ test textImage-5.1 {peer widget images} -setup { image delete small large } -result {} -# cleanup +# +# CLEANUP +# + destroy .t font delete test_font imageFinish - -# cleanup +testutils forget image cleanupTests return diff --git a/tests/textIndex.test b/tests/textIndex.test index 17eb3f4..10ca7ad 100644 --- a/tests/textIndex.test +++ b/tests/textIndex.test @@ -10,6 +10,7 @@ package require tcltest 2.2 eval tcltest::configure $argv tcltest::loadTestedCommands namespace import -force tcltest::test +testutils import text catch {destroy .t} text .t -font {Courier -12} -width 20 -height 10 @@ -716,10 +717,6 @@ test textIndex-18.1 {Object indices don't cache mark names} { frame .f -width 100 -height 20 pack .f -side left -set fixedFont {Courier -12} -set fixedHeight [font metrics $fixedFont -linespace] -set fixedWidth [font measure $fixedFont m] - set varFont {Times -14} set bigFont {Helvetica -24} destroy .t @@ -1027,5 +1024,6 @@ test textIndex-26.2 {GetIndex errors out if mark, image, window, or tag is outsi # cleanup rename textimage {} catch {destroy .t} +testutils forget text cleanupTests return diff --git a/tests/textTag.test b/tests/textTag.test index 0adc93a..f3677bd 100644 --- a/tests/textTag.test +++ b/tests/textTag.test @@ -11,18 +11,23 @@ namespace import ::tcltest::* eval tcltest::configure $argv tcltest::loadTestedCommands -set fixedFont {Courier 12} +# +# Don't use the variable name "fixedFont" since that variable is already defined +# in utility namespace ::tk::test::text for importing in the namespace in which +# test files are executing. +# +set fixedFont2 {Courier 12} set bigFont {Helvetica 24} # Warn the user if the actual font is too different from what was requested. -if {[font metrics [font actual $fixedFont] -fixed] != 1} { - puts "---> Warning: the font actually used by the tests, which is \"[font actual $fixedFont]\",\ +if {[font metrics [font actual $fixedFont2] -fixed] != 1} { + puts "---> Warning: the font actually used by the tests, which is \"[font actual $fixedFont2]\",\ does not seem to be a fixed-width font as expected. If this is really the case, many upcoming\ tests will fail." } destroy .t -text .t -width 20 -height 10 -font $fixedFont +text .t -width 20 -height 10 -font $fixedFont2 pack .t -expand 1 -fill both update diff --git a/tests/textWind.test b/tests/textWind.test index 56525fd..83d58c1 100644 --- a/tests/textWind.test +++ b/tests/textWind.test @@ -11,12 +11,10 @@ namespace import ::tcltest::* tcltest::configure {*}$argv tcltest::loadTestedCommands -deleteWindows +# Import utility procs for specific functional areas +testutils import text -set fixedFont {Courier -12} -set fixedHeight [font metrics $fixedFont -linespace] -set fixedWidth [font measure $fixedFont m] -set fixedAscent [font metrics $fixedFont -ascent] +deleteWindows # On Windows at least, the tests do work with {Courier -10}, {Courier -12} or {Courier -14} as fixedFont. # Warn the user if the actual font is too different from what was requested. @@ -49,27 +47,6 @@ update wm geometry . {} -# full border size of the text widget, i.e. first x or y coordinate inside the text widget -# warning: -padx is supposed to be the same as -pady (same border size horizontally and -# vertically around the widget) -proc bo {{w .t}} { - return [expr {[$w cget -borderwidth] + [$w cget -highlightthickness] + [$w cget -padx]}] -} -# x-width of $n chars, fixed width font -proc xw {n} { - global fixedWidth - return [expr {$n * $fixedWidth}] -} -# x-coordinate of the first pixel of $n-th char (count starts at zero), left justified -proc xchar {n {w .t}} { - return [expr {[bo $w] + [xw $n]}] -} -# y-coordinate of the first pixel of $l-th display line (count starts at 1) -proc yline {l {w .t}} { - global fixedHeight - return [expr {[bo $w] + ($l - 1) * $fixedHeight}] -} - set color [expr {[winfo depth .t] > 1 ? "green" : "black"}] # The statements below reset the main window; it's needed if the window @@ -1666,8 +1643,12 @@ test textWind-18.3 {embedded window destruction in cascade} -setup { destroy .t .f } -result {} -option clear -# cleanup +# +# CLEANUP +# + +option clear +testutils forget text cleanupTests return diff --git a/tests/ttk/all.tcl b/tests/ttk/all.tcl index 8f0234d..4d79948 100644 --- a/tests/ttk/all.tcl +++ b/tests/ttk/all.tcl @@ -14,7 +14,7 @@ package require tcltest 2.2 tcltest::configure {*}$argv tcltest::configure -testdir [file normalize [file dirname [info script]]] tcltest::configure -loadfile \ - [file join [file dirname [tcltest::testsDirectory]] constraints.tcl] + [file join [file dirname [tcltest::testsDirectory]] main.tcl] tcltest::configure -singleproc 1 set ErrorOnFailures [info exists env(ERROR_ON_FAILURES)] encoding system utf-8 diff --git a/tests/ttk/entry.test b/tests/ttk/entry.test index 0187720..099eb5f 100644 --- a/tests/ttk/entry.test +++ b/tests/ttk/entry.test @@ -7,11 +7,8 @@ package require tcltest 2.2 namespace import -force tcltest::* loadTestedCommands -variable scrollInfo -proc scroll args { - global scrollInfo - set scrollInfo $args -} +# Import utility procs for specific functional areas +testutils import entry scroll # Some of the tests raise background errors; # override default bgerror to catch them. @@ -95,10 +92,10 @@ test entry-2.1.1 "Create entry before scrollbar - scrollbar catches up" -body { } -result 1 -cleanup {destroy .te .tsb} test entry-2.2 "Initial scroll position" -body { - ttk::entry .e -font fixed -width 5 -xscrollcommand scroll + ttk::entry .e -font fixed -width 5 -xscrollcommand setScrollInfo .e insert end "0123456789" pack .e; - set timeout [after 500 {set $scrollInfo "timeout"}] + set timeout [after 500 {set scrollInfo "timeout"}] vwait scrollInfo set scrollInfo } -cleanup { @@ -238,35 +235,31 @@ test entry-5.1 {widget deletion while active} -body { # -textvariable tests. test entry-6.1 {Update linked variable in write trace} -body { - proc override args { - global x - set x "Overridden!" - } catch {destroy .e} - set x "" - trace add variable x write override - ttk::entry .e -textvariable x + set textVar "" + trace add variable textVar write override + ttk::entry .e -textvariable textVar .e insert 0 "Some text" - set result [list $x [.e get]] + set result [list $textVar [.e get]] set result -} -result {Overridden! Overridden!} -cleanup { - unset x - rename override {} +} -result {12345 12345} -cleanup { + trace remove variable textVar write override + unset textVar destroy .e } test entry-6.2 {-textvariable tests} -body { set result [list] - ttk::entry .e -textvariable x - set x "text" + ttk::entry .e -textvariable textVar + set textVar "text" lappend result [.e get] - unset x + unset textVar lappend result [.e get] .e insert end "newtext" - lappend result [.e get] [set x] + lappend result [.e get] $textVar } -result [list "text" "" "newtext" "newtext"] -cleanup { destroy .e - unset -nocomplain x + unset -nocomplain textVar } test entry-7.1 {Bad style options} -body { @@ -407,4 +400,9 @@ test entry-12.2 "style command" -body { destroy .w } -result {customStyle.TEntry customStyle.TEntry TEntry} +# +# CLEANUP +# + +testutils forget entry scroll tcltest::cleanupTests diff --git a/tests/ttk/scrollbar.test b/tests/ttk/scrollbar.test index ac10f56..e1bae69 100644 --- a/tests/ttk/scrollbar.test +++ b/tests/ttk/scrollbar.test @@ -3,8 +3,6 @@ package require tcltest 2.2 namespace import -force tcltest::* loadTestedCommands -testConstraint coreScrollbar [expr {[tk windowingsystem] eq "aqua"}] - # Before 2019 the code in library/ttk/scrollbar.tcl would replace the # constructor of ttk::scrollbar with the constructor of tk::scrollbar # unless the -class or -style options were specified.. @@ -15,7 +13,7 @@ testConstraint coreScrollbar [expr {[tk windowingsystem] eq "aqua"}] test scrollbar-swapout-1 "Don't use core scrollbars on OSX..." \ -constraints { - coreScrollbar + aqua } -body { ttk::scrollbar .sb -command "yadda" list [winfo class .sb] [.sb cget -command] @@ -25,7 +23,7 @@ test scrollbar-swapout-1 "Don't use core scrollbars on OSX..." \ test scrollbar-swapout-2 "... regardless of whether -style ..." \ -constraints { - coreScrollbar + aqua } -body { ttk::style layout Vertical.Custom.TScrollbar \ [ttk::style layout Vertical.TScrollbar] ; # See #1833339 @@ -36,7 +34,7 @@ test scrollbar-swapout-2 "... regardless of whether -style ..." \ } test scrollbar-swapout-3 "... or -class is specified." -constraints { - coreScrollbar + aqua } -body { ttk::scrollbar .sb -command "yadda" -class Custom.TScrollbar list [winfo class .sb] [.sb cget -command] diff --git a/tests/ttk/treetags.test b/tests/ttk/treetags.test index 9e8ef61..5934fc2 100644 --- a/tests/ttk/treetags.test +++ b/tests/ttk/treetags.test @@ -7,12 +7,6 @@ loadTestedCommands ### treeview tag invariants: # -proc assert {expr {message ""}} { - if {![uplevel 1 [list expr $expr]]} { - error "PANIC: $message ($expr failed)" - } -} - proc itemConstraints {tv item} { # $tag in [$tv item $item -tags] <==> [$tv tag has $tag $item] foreach tag [$tv item $item -tags] { diff --git a/tests/ttk/treeview.test b/tests/ttk/treeview.test index 36749d7..8d70e7a 100644 --- a/tests/ttk/treeview.test +++ b/tests/ttk/treeview.test @@ -8,6 +8,9 @@ package require tcltest 2.2 namespace import -force tcltest::* loadTestedCommands +# Import utility procs for specific functional areas +testutils import scroll + # consistencyCheck -- # Traverse the tree to make sure the item data structures # are properly linked. @@ -18,21 +21,13 @@ loadTestedCommands proc consistencyCheck {tv {item {}}} { set i 0 foreach child [$tv children $item] { - assert {[$tv parent $child] == $item} "parent $child = $item" - assert {[$tv index $child] == $i} "index $child [$tv index $child]=$i" + assert {[$tv parent $child] eq $item} + assert {[$tv index $child] == $i} incr i consistencyCheck $tv $child } } -proc assert {expr {message ""}} { - if {![uplevel 1 [list expr $expr]]} { - set error "PANIC! PANIC! PANIC: $message ($expr failed)" - puts stderr $error - error $error - } -} - proc tvSetup {} { destroy .tv ttk::treeview .tv -columns {a b c} @@ -613,15 +608,12 @@ test treeview-8.11 "<<TreeviewSelect>> when toggling" -body { ### NEED: more tests for see/yview/scrolling -proc scrollcallback {args} { - set ::scrolldata $args -} test treeview-9.0 "scroll callback - empty tree" -body { tvSetup - .tv configure -yscrollcommand scrollcallback + .tv configure -yscrollcommand setScrollInfo .tv delete [.tv children {}] update - set ::scrolldata + set scrollInfo } -result [list 0.0 1.0] test treeview-9.1 "scrolling" -setup { @@ -1508,4 +1500,9 @@ test treeview-23.1 "cell padding" -setup { destroy .tv } -result {2 4 6 8} +# +# CLEANUP +# + +testutils forget scroll tcltest::cleanupTests diff --git a/tests/ttk/ttk.test b/tests/ttk/ttk.test index afe147e..022efa6 100644 --- a/tests/ttk/ttk.test +++ b/tests/ttk/ttk.test @@ -206,7 +206,7 @@ test ttk-2.7 "instate scripts, true" -body { set x } -result 1 -test ttk-2.8 "bug 3223850: button state disabled during click" -setup { +test ttk-2.8 {Bug [3223850]: Button remains stuck when disabled as depressed on XP} -setup { destroy .b set ttk28 {} pack [ttk::button .b -command {set ::ttk28 failed}] @@ -224,6 +224,16 @@ test ttk-2.8 "bug 3223850: button state disabled during click" -setup { unset -nocomplain ttk28 aid } -result 1 +test ttk-2.9 {Bug [7231bf99]: Setting ttk state may change the variable passed by value} -body { + pack [ttk::button .b1 -text Hi!] + set state [list invalid disabled] + .b1 state $state + set state +} -cleanup { + unset state + destroy .b1 +} -result [list invalid disabled] + foreach wc $widgetClasses { test ttk-coreoptions-$wc "$wc has all core options" -body { ttk::$wc .w @@ -257,7 +267,7 @@ test ttk-3.3 "Constructor failure with cursor" -body { ttk::button .b -cursor bottom_right_corner -style BadStyle } -returnCodes error -result "Layout BadStyle not found" -test ttk-3.4 "SF#2009213" -body { +test ttk-3.4 {Bug [2009213]: Segfault after setting bad -sliderrelief and packing scale} -body { ttk::style configure TScale -sliderrelief {} pack [ttk::scale .s] update @@ -598,7 +608,7 @@ test ttk-14.3 "-textvariable in nonexistant namespace" -body { } -returnCodes error -result {can't trace *: parent namespace doesn't exist} \ -match glob -cleanup { destroy .tw } -test ttk-15.1 {Bug 3062331} -setup { +test ttk-15.1 {Tcl bug [3062331]: segfault in variable traces with ttk::* widgets} -setup { destroy .b } -body { set Y {} @@ -609,7 +619,7 @@ test ttk-15.1 {Bug 3062331} -setup { destroy .b } -result {} -test ttk-15.2 {Bug 3341056} -setup { +test ttk-15.2 {Bug [3341056]: Usage of recreated ttk::checkbutton causes crash} -setup { proc foo {} { destroy .lf ttk::labelframe .lf diff --git a/tests/ttk/validate.test b/tests/ttk/validate.test index 89c3207..fc5545f 100644 --- a/tests/ttk/validate.test +++ b/tests/ttk/validate.test @@ -5,14 +5,19 @@ package require tk package require tcltest 2.2 +eval tcltest::configure $argv namespace import -force tcltest::* - loadTestedCommands +# Import utility procs for specific functional areas +testutils import entry +foreach i {1 2 3 4} { + set validateCmd$i [list validateCommand$i %W %d %i %P %s %S %v %V] +} + testConstraint ttkEntry 1 testConstraint coreEntry [expr {![testConstraint ttkEntry]}] -eval tcltest::configure $argv test validate-0.0 "Setup" -constraints ttkEntry -body { rename entry {} @@ -22,18 +27,14 @@ test validate-0.0 "Setup" -constraints ttkEntry -body { test validate-0.1 "More setup" -body { destroy .e - catch {unset ::e} - catch {unset ::vVals} + catch {unset textVar} + unset -nocomplain validationData; # not necessary entry .e -validate all \ - -validatecommand [list doval %W %d %i %P %s %S %v %V] \ + -validatecommand $validateCmd1 \ -invalidcommand bell \ - -textvariable ::e \ + -textvariable textVar \ ; pack .e - proc doval {W d i P s S v V} { - set ::vVals [list $W $d $i $P $s $S $v $V] - return 1 - } } # The validation tests build each one upon the previous, so cascading @@ -41,149 +42,138 @@ test validate-0.1 "More setup" -body { # test validate-1.1 {entry widget validation - insert} -body { .e insert 0 a - set ::vVals + set validationData } -result {.e 1 0 a {} a all key} test validate-1.2 {entry widget validation - insert} -body { .e insert 1 b - set ::vVals + set validationData } -result {.e 1 1 ab a b all key} test validate-1.3 {entry widget validation - insert} -body { .e insert end c - set ::vVals + set validationData } -result {.e 1 2 abc ab c all key} test validate-1.4 {entry widget validation - insert} -body { .e insert 1 123 - list $::vVals $::e + list $validationData $textVar } -result {{.e 1 1 a123bc abc 123 all key} a123bc} test validate-1.5 {entry widget validation - delete} -body { .e delete 2 - set ::vVals + set validationData } -result {.e 0 2 a13bc a123bc 2 all key} test validate-1.6 {entry widget validation - delete} -body { .e configure -validate key .e delete 1 3 - set ::vVals + set validationData } -result {.e 0 1 abc a13bc 13 key key} test validate-1.7 {entry widget validation - vmode focus} -body { - set ::vVals {} + set validationData {} .e configure -validate focus .e insert end d - set ::vVals + set validationData } -result {} test validate-1.8 {entry widget validation - vmode focus} -body { - set ::vVals {} - set timer [after 300 lappend ::vVals timeout] + set validationData {} + set timer [after 300 validationData lappend timeout] focus -force .e - vwait ::vVals + vwait validationData after cancel $timer - set ::vVals + set validationData } -result {.e -1 -1 abcd abcd {} focus focusin} test validate-1.9 {entry widget validation - vmode focus} -body { - set ::vVals {} - set timer [after 300 lappend ::vVals timeout] + set validationData {} + set timer [after 300 validationData lappend timeout] focus -force . - vwait ::vVals + vwait validationData after cancel $timer - set ::vVals + set validationData } -result {.e -1 -1 abcd abcd {} focus focusout} .e configure -validate all test validate-1.10 {entry widget validation - vmode all} -body { - set ::vVals {} - set timer [after 300 lappend ::vVals timeout] + set validationData {} + set timer [after 300 validationData lappend timeout] focus -force .e - vwait ::vVals + vwait validationData after cancel $timer - set ::vVals + set validationData } -result {.e -1 -1 abcd abcd {} all focusin} test validate-1.11 {entry widget validation} -body { - set ::vVals {} - set timer [after 300 lappend ::vVals timeout] + set validationData {} + set timer [after 300 validationData lappend timeout] focus -force . - vwait ::vVals + vwait validationData after cancel $timer - set ::vVals + set validationData } -result {.e -1 -1 abcd abcd {} all focusout} .e configure -validate focusin test validate-1.12 {entry widget validation} -body { - set ::vVals {} - set timer [after 300 lappend ::vVals timeout] + set validationData {} + set timer [after 300 validationData lappend timeout] focus -force .e - vwait ::vVals + vwait validationData after cancel $timer - set ::vVals + set validationData } -result {.e -1 -1 abcd abcd {} focusin focusin} test validate-1.13 {entry widget validation} -body { - set ::vVals {} + set validationData {} focus -force . update - set ::vVals + set validationData } -result {} .e configure -validate focuso test validate-1.14 {entry widget validation} -body { - set ::vVals {} + set validationData {} focus -force .e update - set ::vVals + set validationData } -result {} test validate-1.15 {entry widget validation} -body { focus -force . # update necessary to process FocusOut event update - set ::vVals + set validationData } -result {.e -1 -1 abcd abcd {} focusout focusout} # DIFFERENCE: core entry temporarily sets "-validate all", ttk::entry doesn't. test validate-1.16 {entry widget validation} -body { .e configure -validate all - list [.e validate] $::vVals + list [.e validate] $validationData } -result {1 {.e -1 -1 abcd abcd {} all forced}} # DIFFERENCE: ttk::entry does not perform validation when setting the -variable test validate-1.17 {entry widget validation} -constraints coreEntry -body { .e configure -validate all - set ::e newdata - list [.e cget -validate] $::vVals + set textVar newdata + list [.e cget -validate] $validationData } -result {all {.e -1 -1 newdata abcd {} all forced}} -proc doval {W d i P s S v V} { - set ::vVals [list $W $d $i $P $s $S $v $V] - return 0 -} - test validate-1.18 {entry widget validation} -constraints coreEntry -body { - .e configure -validate all - set ::e nextdata - list [.e cget -validate] $::vVals + .e configure -validate all -validatecommand $validateCmd3 + set textVar nextdata + list [.e cget -validate] $validationData } -result {none {.e -1 -1 nextdata newdata {} all forced}} # DIFFERENCE: ttk::entry doesn't validate when setting linked -variable # DIFFERENCE: ttk::entry doesn't disable validation -proc doval {W d i P s S v V} { - set ::vVals [list $W $d $i $P $s $S $v $V] - set ::e mydata - return 1 -} - ## This sets validate to none because it shows that we prevent a possible ## loop condition in the validation, when the entry textvar is also set test validate-1.19 {entry widget validation} -constraints coreEntry -body { - .e configure -validate all + .e configure -validate all -validatecommand $validateCmd2 .e validate - list [.e cget -validate] [.e get] $::vVals + list [.e cget -validate] [.e get] $validationData } -result {none mydata {.e -1 -1 nextdata nextdata {} all forced}} ## This leaves validate alone because we trigger validation through the @@ -194,31 +184,22 @@ test validate-1.19 {entry widget validation} -constraints coreEntry -body { # DIFFERENCE: ttk entry doesn't get out of sync w/textvar test validate-1.20 {entry widget validation} -constraints coreEntry -body { - .e configure -validate all - set ::e testdata - list [.e cget -validate] [.e get] $::e $::vVals + .e configure -validate all -validatecommand $validateCmd2 + set textVar testdata + list [.e cget -validate] [.e get] $textVar $validationData } -result {all testdata mydata {.e -1 -1 testdata mydata {} all forced}} -# -# New tests, -JE: -# -proc doval {W d i P s S v V} { - set ::vVals [list $W $d $i $P $s $S $v $V] - .e delete 0 end; - .e insert end dovaldata - return 0 -} test validate-2.1 "Validation script changes value" -body { - .e configure -validate none - set ::e testdata + .e configure -validate none -validatecommand $validateCmd4 + set textVar testdata .e configure -validate all .e validate - list [.e get] $::e $::vVals + list [.e get] $textVar $validationData } -result {dovaldata dovaldata {.e -1 -1 testdata testdata {} all forced}} # DIFFERENCE: core entry disables validation, ttk entry does not. destroy .e -catch {unset ::e ::vVals} +catch {unset textVar} # See bug #1236979 @@ -281,6 +262,13 @@ test validate-3.6 "...until the value becomes valid" -constraints NA -body { test validate-3.last "Cleanup" -body { destroy .e } +# +# CLEANUP +# -### +foreach i {1 2 3 4} { + unset validateCmd$i +} +unset i +testutils forget entry tcltest::cleanupTests diff --git a/tests/unixButton.test b/tests/unixButton.test index f77ec73..501e779 100644 --- a/tests/unixButton.test +++ b/tests/unixButton.test @@ -9,9 +9,13 @@ # All rights reserved. package require tcltest 2.2 +namespace import -force tcltest::test eval tcltest::configure $argv tcltest::loadTestedCommands -namespace import -force tcltest::test + +# Import utility procs for specific functional areas +testutils import button image + imageInit # Create entries in the option database to be sure that geometry options @@ -30,11 +34,6 @@ option add *Radiobutton.borderWidth 2 option add *Radiobutton.highlightThickness 2 option add *Radiobutton.font {Helvetica -12 bold} - -proc bogusTrace args { - error "trace aborted" -} - if {[tk windowingsystem] eq "aqua"} { set smallIndicator 20 set bigIndicator 20 @@ -258,9 +257,12 @@ test unixbutton-2.1 {disabled coloring check, bug 669595} -constraints { deleteWindows } -result 1 +# +# CLEANUP +# -# cleanup imageFinish +testutils forget button image cleanupTests return diff --git a/tests/unixEmbed.test b/tests/unixEmbed.test index c28d6bd..0270a98 100644 --- a/tests/unixEmbed.test +++ b/tests/unixEmbed.test @@ -11,82 +11,11 @@ eval tcltest::configure $argv tcltest::loadTestedCommands namespace import -force tcltest::test -testConstraint failsOnUbuntu [expr {![info exists ::env(CI)] || ![string match Linux $::tcl_platform(os)]}] -testConstraint failsOnXQuarz [expr {$tcl_platform(os) ne "Darwin" || [tk windowingsystem] ne "x11" }] +# Import utility procs for specific functional areas +testutils import colors child -namespace eval ::_test_tmp {} - -# ------------------------------------------------------------------------------ -# Proc ::_test_tmp::testInterp -# ------------------------------------------------------------------------------ -# Command that creates an child interpreter and tries to load Tk. -# This code is borrowed from safePrimarySelection.test -# This is necessary for loading Tktest if the tests are done in the build -# directory without installing Tk. In that case the usual auto_path loading -# mechanism cannot work because the tk binary is not where pkgIndex.tcl says -# it is. -# ------------------------------------------------------------------------------ - -namespace eval ::_test_tmp { - variable TkLoadCmd -} - -foreach pkg [info loaded] { - if {[lindex $pkg 1] eq "Tk"} { - set ::_test_tmp::TkLoadCmd [list load {*}$pkg] - break - } -} - -proc ::_test_tmp::testInterp {name} { - variable TkLoadCmd - interp create $name - $name eval [list set argv [list -name $name]] - catch {{*}$TkLoadCmd $name} -} - -setupbg -dobg {wm withdraw .} - -# eatColors -- -# Creates a toplevel window and allocates enough colors in it to -# use up all the slots in the colormap. -# -# Arguments: -# w - Name of toplevel window to create. - -proc eatColors {w} { - catch {destroy $w} - toplevel $w - wm geom $w +0+0 - canvas $w.c -width 400 -height 200 -bd 0 - pack $w.c - for {set y 0} {$y < 8} {incr y} { - for {set x 0} {$x < 40} {incr x} { - set color [format #%02x%02x%02x [expr $x*6] [expr $y*30] 0] - $w.c create rectangle [expr 10*$x] [expr 20*$y] \ - [expr 10*$x + 10] [expr 20*$y + 20] -outline {} \ - -fill $color - } - } - update -} - -# colorsFree -- -# -# Returns 1 if there appear to be free colormap entries in a window, -# 0 otherwise. -# -# Arguments: -# w - Name of window in which to check. -# red, green, blue - Intensities to use in a trial color allocation -# to see if there are colormap entries free. - -proc colorsFree {w {red 31} {green 245} {blue 192}} { - set vals [winfo rgb $w [format #%02x%02x%02x $red $green $blue]] - expr ([lindex $vals 0]/256 == $red) && ([lindex $vals 1]/256 == $green) \ - && ([lindex $vals 2]/256 == $blue) -} +childTkProcess create +childTkProcess eval {wm withdraw .} test unixEmbed-1.1 {Tk_UseWindow procedure, bad window identifier} -constraints { unix @@ -138,8 +67,8 @@ test unixEmbed-1.5 {Tk_UseWindow procedure, creating Container records} -constra frame .f1 -container 1 -width 200 -height 50 frame .f2 -container 1 -width 200 -height 50 pack .f1 .f2 - dobg "set w [winfo id .f1]" - dobg { + childTkProcess eval "set w [winfo id .f1]" + childTkProcess eval { destroy {*}[winfo children .] toplevel .t -use $w list [testembed] [expr [lindex [lindex [testembed all] 0] 0] - $w] @@ -152,7 +81,7 @@ test unixEmbed-1.5a {Tk_UseWindow procedure, creating Container records} -constr } -setup { deleteWindows catch {interp delete child} - ::_test_tmp::testInterp child + childTkInterp child load {} Tktest child } -body { frame .f1 -container 1 -width 200 -height 50 @@ -176,9 +105,9 @@ test unixEmbed-1.6 {Tk_UseWindow procedure, creating Container records} -constra frame .f1 -container 1 -width 200 -height 50 frame .f2 -container 1 -width 200 -height 50 pack .f1 .f2 - dobg "set w1 [winfo id .f1]" - dobg "set w2 [winfo id .f2]" - dobg { + childTkProcess eval "set w1 [winfo id .f1]" + childTkProcess eval "set w2 [winfo id .f2]" + childTkProcess eval { destroy {*}[winfo children .] toplevel .t1 -use $w1 toplevel .t2 -use $w2 @@ -192,7 +121,7 @@ test unixEmbed-1.6a {Tk_UseWindow procedure, creating Container records} -constr } -setup { deleteWindows catch {interp delete child} - ::_test_tmp::testInterp child + childTkInterp child load {} Tktest child } -body { frame .f1 -container 1 -width 200 -height 50 @@ -236,15 +165,15 @@ test unixEmbed-2.1 {EmbeddedEventProc procedure} -constraints { } -body { frame .f1 -container 1 -width 200 -height 50 pack .f1 - dobg "set w1 [winfo id .f1]" - dobg { + childTkProcess eval "set w1 [winfo id .f1]" + childTkProcess eval { destroy {*}[winfo children .] toplevel .t1 -use $w1 testembed } destroy .f1 update - dobg { + childTkProcess eval { testembed } } -cleanup { @@ -255,7 +184,7 @@ test unixEmbed-2.1a {EmbeddedEventProc procedure} -constraints { } -setup { deleteWindows catch {interp delete child} - ::_test_tmp::testInterp child + childTkInterp child load {} Tktest child } -body { frame .f1 -container 1 -width 200 -height 50 @@ -272,6 +201,7 @@ test unixEmbed-2.1a {EmbeddedEventProc procedure} -constraints { testembed } } -cleanup { + interp delete child deleteWindows } -result {} test unixEmbed-2.2 {EmbeddedEventProc procedure} -constraints { @@ -281,8 +211,8 @@ test unixEmbed-2.2 {EmbeddedEventProc procedure} -constraints { } -body { frame .f1 -container 1 -width 200 -height 50 pack .f1 - dobg "set w1 [winfo id .f1]" - dobg { + childTkProcess eval "set w1 [winfo id .f1]" + childTkProcess eval { destroy {*}[winfo children .] toplevel .t1 -use $w1 testembed @@ -297,7 +227,7 @@ test unixEmbed-2.2a {EmbeddedEventProc procedure} -constraints { } -setup { deleteWindows catch {interp delete child} - ::_test_tmp::testInterp child + childTkInterp child load {} Tktest child } -body { frame .f1 -container 1 -width 200 -height 50 @@ -348,9 +278,9 @@ test unixEmbed-3.1 {ContainerEventProc procedure, detect creation} -constraints } -body { frame .f1 -container 1 -width 200 -height 50 pack .f1 - dobg "set w1 [winfo id .f1]" + childTkProcess eval "set w1 [winfo id .f1]" set x [testembed] - dobg { + childTkProcess eval { destroy {*}[winfo children .] toplevel .t1 -use $w1 wm withdraw .t1 @@ -363,7 +293,7 @@ test unixEmbed-3.1a {ContainerEventProc procedure, detect creation} -constraints unix testembed } -setup { catch {interp delete child} - ::_test_tmp::testInterp child + childTkInterp child load {} Tktest child } -body { frame .f1 -container 1 -width 200 -height 50 @@ -401,15 +331,15 @@ test unixEmbed-3.3 {ContainerEventProc procedure, disallow position changes} -co } -body { frame .f1 -container 1 -width 200 -height 50 pack .f1 - dobg "set w1 [winfo id .f1]" - dobg { + childTkProcess eval "set w1 [winfo id .f1]" + childTkProcess eval { destroy {*}[winfo children .] toplevel .t1 -use $w1 -bd 2 -relief raised update wm geometry .t1 +30+40 } update - dobg { + childTkProcess eval { wm geometry .t1 } } -cleanup { @@ -420,7 +350,7 @@ test unixEmbed-3.3a {ContainerEventProc procedure, disallow position changes} -c } -setup { deleteWindows catch {interp delete child} - ::_test_tmp::testInterp child + childTkInterp child load {} Tktest child } -body { frame .f1 -container 1 -width 200 -height 50 @@ -445,15 +375,15 @@ test unixEmbed-3.4 {ContainerEventProc procedure, disallow position changes} -co } -body { frame .f1 -container 1 -width 200 -height 50 pack .f1 - dobg "set w1 [winfo id .f1]" - dobg { + childTkProcess eval "set w1 [winfo id .f1]" + childTkProcess eval { destroy {*}[winfo children .] toplevel .t1 -use $w1 update wm geometry .t1 300x100+30+40 } update - dobg { + childTkProcess eval { wm geometry .t1 } } -cleanup { @@ -464,7 +394,7 @@ test unixEmbed-3.4a {ContainerEventProc procedure, disallow position changes} -c } -setup { deleteWindows catch {interp delete child} - ::_test_tmp::testInterp child + childTkInterp child load {} Tktest child } -body { frame .f1 -container 1 -width 200 -height 50 @@ -489,17 +419,17 @@ test unixEmbed-3.5 {ContainerEventProc procedure, geometry requests} -constraint } -body { frame .f1 -container 1 -width 200 -height 50 pack .f1 - dobg "set w1 [winfo id .f1]" - dobg { + childTkProcess eval "set w1 [winfo id .f1]" + childTkProcess eval { destroy {*}[winfo children .] toplevel .t1 -use $w1 } update - dobg { + childTkProcess eval { .t1 configure -width 300 -height 80 } update - list [winfo width .f1] [winfo height .f1] [dobg {wm geometry .t1}] + list [winfo width .f1] [winfo height .f1] [childTkProcess eval {wm geometry .t1}] } -cleanup { deleteWindows } -result {300 80 300x80+0+0} @@ -508,7 +438,7 @@ test unixEmbed-3.5a {ContainerEventProc procedure, geometry requests} -constrain } -setup { deleteWindows catch {interp delete child} - ::_test_tmp::testInterp child + childTkInterp child load {} Tktest child } -body { frame .f1 -container 1 -width 200 -height 50 @@ -532,15 +462,15 @@ test unixEmbed-3.6 {ContainerEventProc procedure, map requests} -constraints { } -body { frame .f1 -container 1 -width 200 -height 50 pack .f1 - dobg "set w1 [winfo id .f1]" - dobg { + childTkProcess eval "set w1 [winfo id .f1]" + childTkProcess eval { destroy {*}[winfo children .] toplevel .t1 -use $w1 set x unmapped bind .t1 <Map> {set x mapped} } update - dobg { + childTkProcess eval { after 100 update set x @@ -553,7 +483,7 @@ test unixEmbed-3.6a {ContainerEventProc procedure, map requests} -constraints { } -setup { deleteWindows catch {interp delete child} - ::_test_tmp::testInterp child + childTkInterp child load {} Tktest child } -body { frame .f1 -container 1 -width 200 -height 50 @@ -580,15 +510,15 @@ test unixEmbed-3.7 {ContainerEventProc procedure, destroy events} -constraints { } -body { frame .f1 -container 1 -width 200 -height 50 pack .f1 - dobg "set w1 [winfo id .f1]" + childTkProcess eval "set w1 [winfo id .f1]" bind .f1 <Destroy> {set x dead} set x alive - dobg { + childTkProcess eval { destroy {*}[winfo children .] toplevel .t1 -use $w1 } update - dobg { + childTkProcess eval { destroy .t1 } update @@ -601,7 +531,7 @@ test unixEmbed-3.7a {ContainerEventProc procedure, destroy events} -constraints } -setup { deleteWindows catch {interp delete child} - ::_test_tmp::testInterp child + childTkInterp child load {} Tktest child } -body { frame .f1 -container 1 -width 200 -height 50 @@ -629,17 +559,17 @@ test unixEmbed-4.1 {EmbedStructureProc procedure, configure events} -constraints } -body { frame .f1 -container 1 -width 200 -height 50 pack .f1 - dobg "set w1 [winfo id .f1]" - dobg { + childTkProcess eval "set w1 [winfo id .f1]" + childTkProcess eval { destroy {*}[winfo children .] toplevel .t1 -use $w1 } update - dobg { + childTkProcess eval { .t1 configure -width 180 -height 100 } update - dobg { + childTkProcess eval { winfo geometry .t1 } } -cleanup { @@ -650,7 +580,7 @@ test unixEmbed-4.1a {EmbedStructureProc procedure, configure events} -constraint } -setup { deleteWindows catch {interp delete child} - ::_test_tmp::testInterp child + childTkInterp child load {} Tktest child } -body { frame .f1 -container 1 -width 200 -height 50 @@ -675,8 +605,8 @@ test unixEmbed-4.2 {EmbedStructureProc procedure, destroy events} -constraints { } -body { frame .f1 -container 1 -width 200 -height 50 pack .f1 - dobg "set w1 [winfo id .f1]" - dobg { + childTkProcess eval "set w1 [winfo id .f1]" + childTkProcess eval { destroy {*}[winfo children .] toplevel .t1 -use $w1 } @@ -693,7 +623,7 @@ test unixEmbed-4.2a {EmbedStructureProc procedure, destroy events} -constraints } -setup { deleteWindows catch {interp delete child} - ::_test_tmp::testInterp child + childTkInterp child load {} Tktest child } -body { frame .f1 -container 1 -width 200 -height 50 @@ -721,8 +651,8 @@ test unixEmbed-5.1 {EmbedFocusProc procedure, FocusIn events} -constraints { frame .f1 -container 1 -width 200 -height 50 pack .f1 update - dobg "set w1 [winfo id .f1]" - dobg { + childTkProcess eval "set w1 [winfo id .f1]" + childTkProcess eval { destroy {*}[winfo children .] toplevel .t1 -use $w1 bind .t1 <FocusIn> {lappend x "focus in %W"} @@ -731,7 +661,7 @@ test unixEmbed-5.1 {EmbedFocusProc procedure, FocusIn events} -constraints { } focus -force .f1 update - dobg {set x} + childTkProcess eval {set x} } -cleanup { deleteWindows } -result {{focus in .t1}} @@ -740,7 +670,7 @@ test unixEmbed-5.1a {EmbedFocusProc procedure, FocusIn events} -constraints { } -setup { deleteWindows catch {interp delete child} - ::_test_tmp::testInterp child + childTkInterp child load {} Tktest child } -body { frame .f1 -container 1 -width 200 -height 50 @@ -770,13 +700,13 @@ test unixEmbed-5.2 {EmbedFocusProc procedure, focusing on dead window} -constrai frame .f1 -container 1 -width 200 -height 50 pack .f1 update - dobg "set w1 [winfo id .f1]" - dobg { + childTkProcess eval "set w1 [winfo id .f1]" + childTkProcess eval { destroy {*}[winfo children .] toplevel .t1 -use $w1 } update - dobg { + childTkProcess eval { after 200 {destroy .t1} } after 400 @@ -790,7 +720,7 @@ test unixEmbed-5.2a {EmbedFocusProc procedure, focusing on dead window} -constra } -setup { deleteWindows catch {interp delete child} - ::_test_tmp::testInterp child + childTkInterp child load {} Tktest child } -body { frame .f1 -container 1 -width 200 -height 50 @@ -818,8 +748,8 @@ test unixEmbed-5.3 {EmbedFocusProc procedure, FocusOut events} -constraints { frame .f1 -container 1 -width 200 -height 50 pack .f1 update - dobg "set w1 [winfo id .f1]" - dobg { + childTkProcess eval "set w1 [winfo id .f1]" + childTkProcess eval { destroy {*}[winfo children .] toplevel .t1 -use $w1 bind .t1 <FocusIn> {lappend x "focus in %W"} @@ -828,10 +758,10 @@ test unixEmbed-5.3 {EmbedFocusProc procedure, FocusOut events} -constraints { } focus -force .f1 update - set x [dobg {update; set x}] + set x [childTkProcess eval {update; set x}] focus . update - list $x [dobg {update; set x}] + list $x [childTkProcess eval {update; set x}] } -cleanup { deleteWindows } -result {{{focus in .t1}} {{focus in .t1} {focus out .t1}}} @@ -840,7 +770,7 @@ test unixEmbed-5.3a {EmbedFocusProc procedure, FocusOut events} -constraints { } -setup { deleteWindows catch {interp delete child} - ::_test_tmp::testInterp child + childTkInterp child load {} Tktest child } -body { frame .f1 -container 1 -width 200 -height 50 @@ -874,8 +804,8 @@ test unixEmbed-6.1 {EmbedGeometryRequest procedure, window changes size} -constr } -body { frame .f1 -container 1 -width 200 -height 50 pack .f1 - dobg "set w1 [winfo id .f1]" - dobg { + childTkProcess eval "set w1 [winfo id .f1]" + childTkProcess eval { destroy {*}[winfo children .] toplevel .t1 -use $w1 update @@ -893,7 +823,7 @@ test unixEmbed-6.1a {EmbedGeometryRequest procedure, window changes size} -const } -setup { deleteWindows catch {interp delete child} - ::_test_tmp::testInterp child + childTkInterp child load {} Tktest child } -body { frame .f1 -container 1 -width 200 -height 50 @@ -920,8 +850,8 @@ test unixEmbed-6.2 {EmbedGeometryRequest procedure, window changes size} -constr } -body { frame .f1 -container 1 -width 200 -height 50 place .f1 -width 200 -height 200 - dobg "set w1 [winfo id .f1]" - dobg { + childTkProcess eval "set w1 [winfo id .f1]" + childTkProcess eval { destroy {*}[winfo children .] toplevel .t1 -use $w1 update @@ -939,7 +869,7 @@ test unixEmbed-6.2a {EmbedGeometryRequest procedure, window changes size} -const } -setup { deleteWindows catch {interp delete child} - ::_test_tmp::testInterp child + childTkInterp child load {} Tktest child } -body { frame .f1 -container 1 -width 200 -height 50 @@ -971,15 +901,15 @@ test unixEmbed-7.1 {TkpRedirectKeyEvent procedure, forward keystroke} -constrain deleteWindows frame .f1 -container 1 -width 200 -height 50 pack .f1 - dobg "set w1 [winfo id .f1]" - dobg { + childTkProcess eval "set w1 [winfo id .f1]" + childTkProcess eval { destroy {*}[winfo children .] toplevel .t1 -use $w1 } focus -force . bind . <Key> {lappend x {key %A %E}} set x {} - set y [dobg { + set y [childTkProcess eval { update bind .t1 <Key> {lappend y {key %A}} set y {} @@ -995,11 +925,11 @@ test unixEmbed-7.1 {TkpRedirectKeyEvent procedure, forward keystroke} -constrain # TkpRedirectKeyEvent is not implemented in win or aqua. If someone # implements it they should change the constraints for this test. test unixEmbed-7.1a {TkpRedirectKeyEvent procedure, forward keystroke} -constraints { - unix notAqua failsOnXQuarz + unix notAqua failsOnXQuartz } -setup { deleteWindows catch {interp delete child} - ::_test_tmp::testInterp child + childTkInterp child load {} Tktest child } -body { deleteWindows @@ -1034,8 +964,8 @@ test unixEmbed-7.2 {TkpRedirectKeyEvent procedure, don't forward keystroke width } -body { frame .f1 -container 1 -width 200 -height 50 pack .f1 - dobg "set w1 [winfo id .f1]" - dobg { + childTkProcess eval "set w1 [winfo id .f1]" + childTkProcess eval { destroy {*}[winfo children .] toplevel .t1 -use $w1 } @@ -1044,7 +974,7 @@ test unixEmbed-7.2 {TkpRedirectKeyEvent procedure, don't forward keystroke width update bind . <Key> {lappend x {key %A}} set x {} - set y [dobg { + set y [childTkProcess eval { update bind .t1 <Key> {lappend y {key %A}} set y {} @@ -1062,7 +992,7 @@ test unixEmbed-7.2a {TkpRedirectKeyEvent procedure, don't forward keystroke widt } -setup { deleteWindows catch {interp delete child} - ::_test_tmp::testInterp child + childTkInterp child load {} Tktest child } -body { frame .f1 -container 1 -width 200 -height 50 @@ -1093,21 +1023,21 @@ test unixEmbed-7.2a {TkpRedirectKeyEvent procedure, don't forward keystroke widt } -result {{} {{key b}}} test unixEmbed-8.1 {TkpClaimFocus procedure} -constraints { - unix notAqua failsOnUbuntu failsOnXQuarz + unix notAqua failsOnUbuntu failsOnXQuartz } -setup { deleteWindows } -body { frame .f1 -container 1 -width 200 -height 50 frame .f2 -width 200 -height 50 pack .f1 .f2 - dobg "set w1 [winfo id .f1]" - dobg { + childTkProcess eval "set w1 [winfo id .f1]" + childTkProcess eval { destroy {*}[winfo children .] toplevel .t1 -use $w1 -highlightthickness 2 -bd 2 -relief sunken } focus -force .f2 update - list [dobg { + list [childTkProcess eval { focus .t1 set x [list [focus]] update @@ -1121,7 +1051,7 @@ test unixEmbed-8.1 {TkpClaimFocus procedure} -constraints { test unixEmbed-8.1a {TkpClaimFocus procedure} -constraints unix -setup { deleteWindows catch {interp delete child} - ::_test_tmp::testInterp child + childTkInterp child load {} Tktest child } -body { frame .f1 -container 1 -width 200 -height 50 @@ -1202,8 +1132,8 @@ test unixEmbed-9.2 {EmbedWindowDeleted procedure, check embeddedPtr} -constraint frame .f1 -container 1 -width 200 -height 50 pack .f1 update - dobg "set w1 [winfo id .f1]" - dobg { + childTkProcess eval "set w1 [winfo id .f1]" + childTkProcess eval { destroy {*}[winfo children .] toplevel .t1 -use $w1 -highlightthickness 2 -bd 2 -relief sunken set x {} @@ -1219,7 +1149,7 @@ test unixEmbed-9.2a {EmbedWindowDeleted procedure, check embeddedPtr} -constrain } -setup { deleteWindows catch {interp delete child} - ::_test_tmp::testInterp child + childTkInterp child load {} Tktest child } -body { frame .f1 -container 1 -width 200 -height 50 @@ -1322,9 +1252,12 @@ test unixEmbed-11.2 {mouse coordinates in embedded toplevels} -constraints { deleteWindows } -result {.main.b {pushed .main.b} .embed.b {pushed .embed.b}} +# +# CLEANUP +# -# cleanup deleteWindows -cleanupbg +childTkProcess exit +testutils forget child colors cleanupTests return diff --git a/tests/unixFont.test b/tests/unixFont.test index aae6d9c..b97a607 100644 --- a/tests/unixFont.test +++ b/tests/unixFont.test @@ -16,6 +16,9 @@ package require tcltest 2.2 eval tcltest::configure $argv tcltest::loadTestedCommands +# Import utility procs for specific functional areas +testutils import geometry + if {[tk windowingsystem] eq "x11"} { if {[testConstraint withXft]} { set fontsystemcmd [auto_execok fc-list] @@ -71,10 +74,6 @@ set cx [font measure TkFixedFont 0] set ax [winfo reqwidth .b.l] set ay [winfo reqheight .b.l] -proc getsize {} { - update - return "[winfo reqwidth .b.l] [winfo reqheight .b.l]" -} test unixfont-1.1 {TkpGetNativeFont procedure: not native} {x11} { list [catch {font measure {} xyz} msg] $msg @@ -121,9 +120,6 @@ test unixfont-2.7 {TkpGetFontFromAttributes: fixed family not available!} x11 { test unixfont-2.8 {TkpGetFontFromAttributes: loop over returned font names} {x11 haveFixedFamilyFont} { lindex [font actual {-family fixed -size 31}] 1 } {fixed} -test unixfont-2.9 {TkpGetFontFromAttributes: reject adobe courier if possible} {x11 haveCourierFamilyFont} { - lindex [font actual {-family courier}] 1 -} {courier} test unixfont-2.10 {TkpGetFontFromAttributes: scalable font found} {x11 havePointsize37Font} { lindex [font actual {-family courier -size 37}] 3 } 37 @@ -162,23 +158,23 @@ test unixfont-5.3 {Tk_MeasureChars procedure: loop over chars} x11 { .b.l config -wrap [expr $ax*10] test unixfont-5.4 {Tk_MeasureChars procedure: reached right edge} x11 { .b.l config -text "0000000000000" - getsize + getsize .b.l } "[expr $ax*10] [expr $ay*2]" test unixfont-5.5 {Tk_MeasureChars procedure: ran out of chars} x11 { .b.l config -text "000000" - getsize + getsize .b.l } "[expr $ax*6] $ay" test unixfont-5.6 {Tk_MeasureChars procedure: find last word} x11 { .b.l config -text "000000 00000" - getsize + getsize .b.l } "[expr $ax*6] [expr $ay*2]" test unixfont-5.7 {Tk_MeasureChars procedure: already saw space in line} x11 { .b.l config -text "000000 00000" - getsize + getsize .b.l } "[expr $ax*6] [expr $ay*2]" test unixfont-5.8 {Tk_MeasureChars procedure: internal spaces significant} {x11} { .b.l config -text "00 000 00000" - getsize + getsize .b.l } "[expr $ax*7] [expr $ay*2]" test unixfont-5.9 {Tk_MeasureChars procedure: TK_PARTIAL_OK} {x11} { .b.c dchars $t 0 end @@ -187,18 +183,18 @@ test unixfont-5.9 {Tk_MeasureChars procedure: TK_PARTIAL_OK} {x11} { } 2 test unixfont-5.10 {Tk_MeasureChars procedure: TK_AT_LEAST_ONE} x11 { .b.l config -text "000000000000" - getsize + getsize .b.l } "[expr $ax*10] [expr $ay*2]" test unixfont-5.11 {Tk_MeasureChars: TK_AT_LEAST_ONE + not even one char fit!} x11 { set a [.b.l cget -wrap] .b.l config -text "000000" -wrap 1 - set x [getsize] + set x [getsize .b.l] .b.l config -wrap $a set x } "$ax [expr $ay*6]" test unixfont-5.12 {Tk_MeasureChars procedure: include eol spaces} {x11} { .b.l config -text "000 \n000" - getsize + getsize .b.l } "[expr $ax*6] [expr $ay*2]" test unixfont-6.1 {Tk_DrawChars procedure: loop test} x11 { @@ -332,6 +328,10 @@ test unixfont-9.2 {4 chars substituted in inserted text} {x11 nonPortable} { lappend x [.b.c index $t @[expr $ax*5],0] } {0 1 1 1 1 2} -# cleanup +# +# CLEANUP +# + +testutils forget geometry cleanupTests return diff --git a/tests/unixSelect.test b/tests/unixSelect.test index ece8a95..59d02c6 100644 --- a/tests/unixSelect.test +++ b/tests/unixSelect.test @@ -14,90 +14,15 @@ namespace import ::tcltest::* tcltest::configure {*}$argv tcltest::loadTestedCommands -global longValue selValue selInfo - -set selValue {} -set selInfo {} - -proc handler {type offset count} { - global selValue selInfo - lappend selInfo $type $offset $count - set numBytes [expr {[string length $selValue] - $offset}] - if {$numBytes <= 0} { - return "" - } - string range $selValue $offset [expr $numBytes+$offset] -} - -proc errIncrHandler {type offset count} { - global selValue selInfo pass - if {$offset == 4000} { - if {$pass == 0} { - # Just sizing the selection; don't do anything here. - set pass 1 - } else { - # Fetching the selection; wait long enough to cause a timeout. - after 6000 - } - } - lappend selInfo $type $offset $count - set numBytes [expr {[string length $selValue] - $offset}] - if {$numBytes <= 0} { - return "" - } - string range $selValue $offset [expr $numBytes+$offset] -} - -proc errHandler args { - error "selection handler aborted" -} - -proc badHandler {path type offset count} { - global selValue selInfo - selection handle -type $type $path {} - lappend selInfo $path $type $offset $count - set numBytes [expr {[string length $selValue] - $offset}] - if {$numBytes <= 0} { - return "" - } - string range $selValue $offset [expr $numBytes+$offset] -} -proc reallyBadHandler {path type offset count} { - global selValue selInfo pass - if {$offset == 4000} { - if {$pass == 0} { - set pass 1 - } else { - selection handle -type $type $path {} - } - } - lappend selInfo $path $type $offset $count - set numBytes [expr {[string length $selValue] - $offset}] - if {$numBytes <= 0} { - return "" - } - string range $selValue $offset [expr $numBytes+$offset] -} +# Import utility procs for specific functional areas +testutils import child select # Eliminate any existing selection on the screen. This is needed in case # there is a selection in some other application, in order to prevent races # from causing false errors in the tests below. - selection clear . after 1500 -# common setup code -proc setup {{path .f1} {display {}}} { - catch {destroy $path} - if {$display == {}} { - frame $path - } else { - toplevel $path -screen $display - wm geom $path +0+0 - } - selection own $path -} - # set up a very large buffer to test INCR retrievals set longValue "" foreach i {a b c d e f g j h i j k l m o p q r s t u v w x y z} { @@ -111,24 +36,24 @@ test unixSelect-1.1 {TkSelGetSelection procedure: simple i18n text} -constraints x11 } -setup { destroy .e - setupbg + childTkProcess create } -body { pack [entry .e] update .e insert 0 über .e selection range 0 end - dobg {string length [selection get]} + childTkProcess eval {string length [selection get]} } -cleanup { - cleanupbg + childTkProcess exit destroy .e } -result 4 test unixSelect-1.2 {TkSelGetSelection procedure: simple i18n text, iso8859-1} -constraints { x11 } -setup { - setupbg + childTkProcess create } -body { - dobg { + childTkProcess eval { pack [entry .e] update .e insert 0 üф @@ -136,34 +61,34 @@ test unixSelect-1.2 {TkSelGetSelection procedure: simple i18n text, iso8859-1} - } selection get } -cleanup { - cleanupbg + childTkProcess exit } -result ü? test unixSelect-1.3 {TkSelGetSelection procedure: simple i18n text, iso2022} -constraints { x11 } -setup { - setupbg - setup + childTkProcess create + selectionSetup } -body { selection handle -type COMPOUND_TEXT -format COMPOUND_TEXT . \ {handler COMPOUND_TEXT} selection own . set selValue üф set selInfo {} - set result [dobg { + set result [childTkProcess eval { set x [selection get -type COMPOUND_TEXT] list [string equal üф $x] [string length $x] }] lappend result $selInfo } -cleanup { - cleanupbg + childTkProcess exit } -result {1 2 {COMPOUND_TEXT 0 4000}} test unixSelect-1.4 {TkSelGetSelection procedure: INCR i18n text, iso2022} -constraints { x11 } -setup { - setupbg - setup + childTkProcess create + selectionSetup } -body { # This test is subtle. The selection ends up getting fetched twice by # Tk: once to compute the length, and again to actually send the data. @@ -174,7 +99,7 @@ test unixSelect-1.4 {TkSelGetSelection procedure: INCR i18n text, iso2022} -cons selection own . set selValue [string repeat x 3999]üф[string repeat x 3999] set selInfo {} - set result [dobg { + set result [childTkProcess eval { set x [selection get -type COMPOUND_TEXT] list [string equal \ [string repeat x 3999]üф[string repeat x 3999] $x] \ @@ -182,48 +107,48 @@ test unixSelect-1.4 {TkSelGetSelection procedure: INCR i18n text, iso2022} -cons }] lappend result $selInfo } -cleanup { - cleanupbg + childTkProcess exit } -result {1 8000 {COMPOUND_TEXT 0 4000 COMPOUND_TEXT 4000 3999 COMPOUND_TEXT 7998 4000 COMPOUND_TEXT 0 4000 COMPOUND_TEXT 4000 3998 COMPOUND_TEXT 7997 4000}} test unixSelect-1.5 {TkSelGetSelection procedure: simple i18n text, iso2022} -constraints { x11 } -setup { - setupbg - setup + childTkProcess create + selectionSetup } -body { selection handle -type COMPOUND_TEXT -format COMPOUND_TEXT . \ {handler COMPOUND_TEXT} selection own . set selValue üф set selInfo {} - set result [dobg { + set result [childTkProcess eval { set x [selection get -type COMPOUND_TEXT] list [string equal üф $x] [string length $x] }] lappend result $selInfo } -cleanup { - cleanupbg + childTkProcess exit } -result {1 2 {COMPOUND_TEXT 0 4000}} test unixSelect-1.6 {TkSelGetSelection procedure: INCR i18n text} -constraints { x11 } -setup { - setupbg + childTkProcess create } -body { - dobg [subst -nobackslashes {entry .e; pack .e; update + childTkProcess eval [subst -nobackslashes {entry .e; pack .e; update .e insert 0 über$longValue .e selection range 0 end}] string length [selection get] } -cleanup { - cleanupbg + childTkProcess exit } -result [expr {4 + [string length $longValue]}] test unixSelect-1.7 {TkSelGetSelection procedure: INCR i18n text} -constraints { x11 } -setup { - setupbg + childTkProcess create } -body { - dobg { + childTkProcess eval { pack [entry .e] update .e insert 0 [string repeat x 3999]ü @@ -231,15 +156,15 @@ test unixSelect-1.7 {TkSelGetSelection procedure: INCR i18n text} -constraints { } selection get } -cleanup { - cleanupbg + childTkProcess exit } -result [string repeat x 3999]ü test unixSelect-1.8 {TkSelGetSelection procedure: INCR i18n text} -constraints { x11 } -setup { - setupbg + childTkProcess create } -body { - dobg { + childTkProcess eval { pack [entry .e] update .e insert 0 ü[string repeat x 3999] @@ -247,15 +172,15 @@ test unixSelect-1.8 {TkSelGetSelection procedure: INCR i18n text} -constraints { } selection get } -cleanup { - cleanupbg + childTkProcess exit } -result ü[string repeat x 3999] test unixSelect-1.9 {TkSelGetSelection procedure: INCR i18n text} -constraints { x11 } -setup { - setupbg + childTkProcess create } -body { - dobg { + childTkProcess eval { pack [entry .e] update .e insert 0 [string repeat x 3999]ü[string repeat x 4000] @@ -263,7 +188,7 @@ test unixSelect-1.9 {TkSelGetSelection procedure: INCR i18n text} -constraints { } selection get } -cleanup { - cleanupbg + childTkProcess exit } -result [string repeat x 3999]ü[string repeat x 4000] # Now some tests to make sure that the right thing is done when # transferring UTF8 selections, to prevent [Bug 614650] and its ilk @@ -272,9 +197,9 @@ test unixSelect-1.9 {TkSelGetSelection procedure: INCR i18n text} -constraints { test unixSelect-1.10 {TkSelGetSelection procedure: INCR i18n text, utf-8} -constraints { x11 } -setup { - setupbg + childTkProcess create } -body { - dobg { + childTkProcess eval { pack [entry .e] update .e insert 0 [string repeat x 3999]ü @@ -282,15 +207,15 @@ test unixSelect-1.10 {TkSelGetSelection procedure: INCR i18n text, utf-8} -const } selection get -type UTF8_STRING } -cleanup { - cleanupbg + childTkProcess exit } -result [string repeat x 3999]ü test unixSelect-1.11 {TkSelGetSelection procedure: INCR i18n text, utf-8} -constraints { x11 } -setup { - setupbg + childTkProcess create } -body { - dobg { + childTkProcess eval { pack [entry .e] update .e insert 0 ü[string repeat x 3999] @@ -298,15 +223,15 @@ test unixSelect-1.11 {TkSelGetSelection procedure: INCR i18n text, utf-8} -const } selection get -type UTF8_STRING } -cleanup { - cleanupbg + childTkProcess exit } -result ü[string repeat x 3999] test unixSelect-1.12 {TkSelGetSelection procedure: INCR i18n text, utf-8} -constraints { x11 } -setup { - setupbg + childTkProcess create } -body { - dobg { + childTkProcess eval { pack [entry .e] update .e insert 0 [string repeat x 3999]ü[string repeat x 4000] @@ -314,31 +239,31 @@ test unixSelect-1.12 {TkSelGetSelection procedure: INCR i18n text, utf-8} -const } selection get -type UTF8_STRING } -cleanup { - cleanupbg + childTkProcess exit } -result [string repeat x 3999]ü[string repeat x 4000] test unixSelect-1.13 {TkSelGetSelection procedure: simple i18n text, utf-8} -constraints { x11 } -setup { destroy .e - setupbg + childTkProcess create } -body { pack [entry .e] update .e insert 0 überф .e selection range 0 end - dobg {string length [selection get -type UTF8_STRING]} + childTkProcess eval {string length [selection get -type UTF8_STRING]} } -cleanup { destroy .e - cleanupbg + childTkProcess exit } -result 5 test unixSelect-1.14 {TkSelGetSelection procedure: simple i18n text, utf-8} -constraints { x11 } -setup { - setupbg + childTkProcess create } -body { - dobg { + childTkProcess eval { pack [entry .e] update .e insert 0 üф @@ -346,15 +271,15 @@ test unixSelect-1.14 {TkSelGetSelection procedure: simple i18n text, utf-8} -con } selection get -type UTF8_STRING } -cleanup { - cleanupbg + childTkProcess exit } -result üф test unixSelect-1.15 {TkSelGetSelection procedure: INCR i18n text, utf-8} -constraints { x11 } -setup { - setupbg + childTkProcess create } -body { - dobg { + childTkProcess eval { pack [entry .e] update .e insert 0 [string repeat [string repeat Ää 50]\n 21] @@ -362,15 +287,15 @@ test unixSelect-1.15 {TkSelGetSelection procedure: INCR i18n text, utf-8} -const } selection get -type UTF8_STRING } -cleanup { - cleanupbg + childTkProcess exit } -result [string repeat [string repeat Ää 50]\n 21] test unixSelect-1.16 {TkSelGetSelection procedure: INCR i18n text, utf-8} -constraints { x11 } -setup { - setupbg + childTkProcess create } -body { - dobg { + childTkProcess eval { pack [entry .e] update .e insert 0 i[string repeat [string repeat Ää 50]\n 21] @@ -378,15 +303,15 @@ test unixSelect-1.16 {TkSelGetSelection procedure: INCR i18n text, utf-8} -const } selection get -type UTF8_STRING } -cleanup { - cleanupbg + childTkProcess exit } -result i[string repeat [string repeat Ää 50]\n 21] test unixSelect-1.17 {TkSelGetSelection procedure: INCR i18n text, utf-8} -constraints { x11 } -setup { - setupbg + childTkProcess create } -body { - dobg { + childTkProcess eval { pack [text .t] update .t insert 1.0 [string repeat [string repeat Ää 50]\n 21] @@ -396,15 +321,15 @@ test unixSelect-1.17 {TkSelGetSelection procedure: INCR i18n text, utf-8} -const after 10 selection get -type UTF8_STRING } -cleanup { - cleanupbg + childTkProcess exit } -result [string repeat [string repeat Ää 50]\n 21] test unixSelect-1.18 {TkSelGetSelection procedure: INCR i18n text, utf-8} -constraints { x11 } -setup { - setupbg + childTkProcess create } -body { - dobg { + childTkProcess eval { pack [text .t] update .t insert 1.0 i[string repeat [string repeat Ää 50]\n 21] @@ -414,7 +339,7 @@ test unixSelect-1.18 {TkSelGetSelection procedure: INCR i18n text, utf-8} -const after 10 selection get -type UTF8_STRING } -cleanup { - cleanupbg + childTkProcess exit } -result i[string repeat [string repeat Ää 50]\n 21] test unixSelect-1.19 {Automatic UTF8_STRING support for selection handle} -constraints { @@ -432,6 +357,10 @@ test unixSelect-1.19 {Automatic UTF8_STRING support for selection handle} -const destroy .l } -result {This is the selection value} -# cleanup +# +# CLEANUP +# + +testutils forget child select cleanupTests return diff --git a/tests/unixWm.test b/tests/unixWm.test index 59cfdaa..5c02963 100644 --- a/tests/unixWm.test +++ b/tests/unixWm.test @@ -11,17 +11,6 @@ package require tcltest 2.2 eval tcltest::configure $argv tcltest::loadTestedCommands -namespace import -force ::tk::test:loadTkCommand - -testConstraint failsOnUbuntu [expr {![info exists ::env(CI)] || ![string match Linux $::tcl_platform(os)]}] -testConstraint failsOnXQuarz [expr {$tcl_platform(os) ne "Darwin" || [tk windowingsystem] ne "x11" }] - -proc sleep ms { - global x - after $ms {set x 1} - vwait x -} - # Procedure to set up a collection of top-level windows proc makeToplevels {} { @@ -114,11 +103,11 @@ set i 1 foreach geom "+$X+80 +$X+40 +$X+$Y0" { test unixWm-4.$i {moving window while withdrawn} unix { wm withdraw .t - sleep 10 + pause 10 wm geom .t $geom update idletasks wm deiconify .t - sleep 10 + pause 10 wm geom .t } 100x150$geom incr i @@ -293,7 +282,7 @@ test unixWm-8.3 {icon windows} unix { toplevel .t -width 100 -height 30 list [catch {wm iconwindow .t b c} msg] $msg } {1 {wrong # args: should be "wm iconwindow window ?pathName?"}} -test unixWm-8.4 {icon windows} {unix failsOnUbuntu failsOnXQuarz} { +test unixWm-8.4 {icon windows} {unix failsOnUbuntu failsOnXQuartz} { destroy .t destroy .icon toplevel .t -width 100 -height 30 @@ -638,7 +627,7 @@ test unixWm-16.2 {Tk_WmCmd procedure, "deiconify" option} unix { destroy .icon set result } {1 {can't deiconify .icon: it is an icon for .t}} -test unixWm-16.3 {Tk_WmCmd procedure, "deiconify" option} {unix failsOnUbuntu failsOnXQuarz} { +test unixWm-16.3 {Tk_WmCmd procedure, "deiconify" option} {unix failsOnUbuntu failsOnXQuartz} { wm iconify .t set result {} lappend result [winfo ismapped .t] [wm state .t] @@ -851,7 +840,7 @@ test unixWm-23.4 {Tk_WmCmd procedure, "iconify" option} unix { destroy .t2 set result } {1 {can't iconify ".t2": it is an icon for ".t"}} -test unixWm-23.5 {Tk_WmCmd procedure, "iconify" option} {unix failsOnUbuntu failsOnXQuarz} { +test unixWm-23.5 {Tk_WmCmd procedure, "iconify" option} {unix failsOnUbuntu failsOnXQuartz} { destroy .t2 toplevel .t2 wm geom .t2 +0+0 @@ -862,7 +851,7 @@ test unixWm-23.5 {Tk_WmCmd procedure, "iconify" option} {unix failsOnUbuntu fail destroy .t2 set result } 0 -test unixWm-23.6 {Tk_WmCmd procedure, "iconify" option} {unix failsOnUbuntu failsOnXQuarz} { +test unixWm-23.6 {Tk_WmCmd procedure, "iconify" option} {unix failsOnUbuntu failsOnXQuartz} { destroy .t2 toplevel .t2 wm geom .t2 -0+0 @@ -1435,7 +1424,7 @@ test unixWm-41.4 {ConfigureEvent procedure, synthesized Configure events} unix { # No tests for ReparentEvent or ComputeReparentGeometry; I can't figure # out how to exercise these procedures reliably. -test unixWm-42.1 {WrapperEventProc procedure, map and unmap events} {unix failsOnUbuntu failsOnXQuarz} { +test unixWm-42.1 {WrapperEventProc procedure, map and unmap events} {unix failsOnUbuntu failsOnXQuartz} { destroy .t toplevel .t -width 400 -height 150 wm geometry .t +0+0 @@ -1796,7 +1785,7 @@ if {[tk windowingsystem] eq "aqua"} { # Windows are assumed to have a border (invisible in Gnome 3). set result_50_1 {{} {} .t {} .t2 {} .t2 {} .t} } -test unixWm-50.1 {Tk_CoordsToWindow procedure, finding a toplevel, x-coords, title bar} {unix failsOnUbuntu failsOnXQuarz} { +test unixWm-50.1 {Tk_CoordsToWindow procedure, finding a toplevel, x-coords, title bar} {unix failsOnUbuntu failsOnXQuartz} { update toplevel .t -width 300 -height 400 -bg green wm geom .t +100+100 @@ -1961,7 +1950,7 @@ test unixWm-50.8 {Tk_CoordsToWindow procedure, more basics} unix { [winfo containing [expr $x + 350] $y] \ [winfo containing [expr $x + 450] $y] } {.t .t.f .t.f.f .t {}} -test unixWm-50.9 {Tk_CoordsToWindow procedure, unmapped windows} {unix failsOnUbuntu failsOnXQuarz} { +test unixWm-50.9 {Tk_CoordsToWindow procedure, unmapped windows} {unix failsOnUbuntu failsOnXQuartz} { destroy .t destroy .t2 update @@ -2062,7 +2051,7 @@ test unixWm-51.6 {TkWmRestackToplevel procedure, window to be stacked isn't mapp # This test assumes that .t2 is not mapped yet, but that is not really guaranteed. winfo containing 100 100 } {.t} -test unixWm-51.7 {TkWmRestackToplevel procedure, other window isn't mapped} {unix failsOnXQuarz} { +test unixWm-51.7 {TkWmRestackToplevel procedure, other window isn't mapped} {unix failsOnXQuartz} { foreach w {.t .t2 .t3} { destroy $w toplevel $w -width 200 -height 200 -bg green diff --git a/tests/visual.test b/tests/visual.test index c4e26d2..05bfcf7 100644 --- a/tests/visual.test +++ b/tests/visual.test @@ -12,47 +12,10 @@ namespace import ::tcltest::* tcltest::configure {*}$argv tcltest::loadTestedCommands -update - -# eatColors -- -# Creates a toplevel window and allocates enough colors in it to -# use up all the slots in the colormap. -# -# Arguments: -# w - Name of toplevel window to create. - -proc eatColors {w} { - catch {destroy $w} - toplevel $w - wm geom $w +0+0 - canvas $w.c -width 400 -height 200 -bd 0 - pack $w.c - for {set y 0} {$y < 8} {incr y} { - for {set x 0} {$x < 40} {incr x} { - set color [format #%02x%02x%02x [expr {$x*6}] [expr {$y*30}] 0] - $w.c create rectangle [expr {10*$x}] [expr {20*$y}] \ - [expr {10*$x + 10}] [expr {20*$y + 20}] -outline {} \ - -fill $color - } - } - update -} +# Import utility procs for specific functional areas +testutils import colors -# colorsFree -- -# -# Returns 1 if there appear to be free colormap entries in a window, -# 0 otherwise. -# -# Arguments: -# w - Name of window in which to check. -# red, green, blue - Intensities to use in a trial color allocation -# to see if there are colormap entries free. - -proc colorsFree {w {red 31} {green 245} {blue 192}} { - set vals [winfo rgb $w [format #%02x%02x%02x $red $green $blue]] - expr {([lindex $vals 0]/256 == $red) && ([lindex $vals 1]/256 == $green) - && ([lindex $vals 2]/256 == $blue)} -} +update # If more than one visual type is available for the screen, pick one # that is *not* the default. @@ -556,12 +519,12 @@ test visual-8.2 {Tk_FreeColormap procedure} -constraints haveOtherVisual -setup deleteWindows } -result {} +# +# CLEANUP +# deleteWindows -rename eatColors {} -rename colorsFree {} - -# cleanup +testutils forget colors cleanupTests return diff --git a/tests/winButton.test b/tests/winButton.test index e2107ba..406133a 100644 --- a/tests/winButton.test +++ b/tests/winButton.test @@ -12,11 +12,12 @@ package require tcltest 2.2 namespace import ::tcltest::* tcltest::configure {*}$argv tcltest::loadTestedCommands + +# Import utility procs for specific functional areas +testutils import button image + imageInit -proc bogusTrace args { - error "trace aborted" -} option clear # ---------------------------------------------------------------------- @@ -191,9 +192,13 @@ test winbutton-1.9 {TkpComputeButtonGeometry procedure} -constraints win -setup deleteWindows } -result {23 33} -# cleanup +# +# CLEANUP +# + imageFinish deleteWindows +testutils forget button image cleanupTests return diff --git a/tests/winDialog.test b/tests/winDialog.test index a544238..8f9ad01 100755 --- a/tests/winDialog.test +++ b/tests/winDialog.test @@ -12,6 +12,10 @@ namespace import ::tcltest::* tcltest::configure {*}$argv tcltest::loadTestedCommands +# Import utility procs for specific functional areas +testutils import dialog +set applyFontCmd [list set testDialogFont] + if {[testConstraint testwinevent]} { catch {testwinevent debug 1} } @@ -22,91 +26,20 @@ testConstraint english [expr { && (([testwinlocale] & 0xff) == 9) }] -proc vista? {{prevista 0} {postvista 1}} { - lassign [split $::tcl_platform(osVersion) .] major - return [expr {$major >= 6 ? $postvista : $prevista}] -} - -# What directory to use in initialdir tests. Old code used to use -# c:/. However, on Vista/later that is a protected directory if you -# are not running privileged. Moreover, not everyone has a drive c: -# but not having a TEMP would break a lot Windows programs -proc initialdir {} { - # file join to return in Tcl canonical format (/ separator, not \) - #return [file join $::env(TEMP)] - return [tcltest::temporaryDirectory] -} - - -proc start {arg} { - set ::tk_dialog 0 - set ::iter_after 0 - set ::dialogclass "#32770" - - after 1 $arg -} - -proc then {cmd} { - set ::command $cmd - set ::dialogresult {} - set ::testfont {} - - # Do not make the delay too short. The newer Vista dialogs take - # time to come up. Even if the testforwindow returns true, the - # controls are not ready to accept messages - after 500 afterbody - vwait ::dialogresult - return $::dialogresult -} - -proc afterbody {} { - # On Vista and later, using the new file dialogs we have to find - # the window using its title as tk_dialog will not be set at the C level - if {[vista?]} { - if {[catch {testfindwindow "" $::dialogclass} ::tk_dialog]} { - if {[incr ::iter_after] > 30} { - set ::dialogresult ">30 iterations waiting on tk_dialog" - return - } - after 150 {afterbody} - return - } - } else { - if {$::tk_dialog == 0} { - if {[incr ::iter_after] > 30} { - set ::dialogresult ">30 iterations waiting on tk_dialog" - return - } - after 150 {afterbody} - return - } - } - uplevel #0 {set dialogresult [eval $command]} -} - -proc Click {button} { - switch -exact -- $button { - ok { set button 1 } - cancel { set button 2 } - } - testwinevent $::tk_dialog $button WM_LBUTTONDOWN 1 0x000a000b - testwinevent $::tk_dialog $button WM_LBUTTONUP 0 0x000a000b -} +set initialDir [tcltest::temporaryDirectory] proc GetText {id} { + variable testDialog switch -exact -- $id { ok { set id 1 } cancel { set id 2 } } - return [testwinevent $::tk_dialog $id WM_GETTEXT] + return [testwinevent $testDialog $id WM_GETTEXT] } proc SetText {id text} { - return [testwinevent $::tk_dialog $id WM_SETTEXT $text] -} - -proc ApplyFont {font} { - set ::testfont $font + variable testDialog + return [testwinevent $testDialog $id WM_SETTEXT $text] } # ---------------------------------------------------------------------- @@ -114,16 +47,16 @@ proc ApplyFont {font} { test winDialog-1.1 {Tk_ChooseColorObjCmd} -constraints { testwinevent } -body { - start {tk_chooseColor} - then { + testDialog launch {tk_chooseColor} + testDialog onDisplay { Click cancel } } -result 0 test winDialog-1.2 {Tk_ChooseColorObjCmd} -constraints { testwinevent } -body { - start {set clr [tk_chooseColor -initialcolor "#ff9933"]} - then { + testDialog launch {set clr [tk_chooseColor -initialcolor "#ff9933"]} + testDialog onDisplay { set x [Click cancel] } list $x $clr @@ -131,8 +64,8 @@ test winDialog-1.2 {Tk_ChooseColorObjCmd} -constraints { test winDialog-1.3 {Tk_ChooseColorObjCmd} -constraints { testwinevent } -body { - start {set clr [tk_chooseColor -initialcolor "#ff9933"]} - then { + testDialog launch {set clr [tk_chooseColor -initialcolor "#ff9933"]} + testDialog onDisplay { set x [Click ok] } list $x $clr @@ -143,10 +76,10 @@ test winDialog-1.4 {Tk_ChooseColorObjCmd: -title} -constraints { catch {unset a x} } -body { set x {} - start {set clr [tk_chooseColor -initialcolor "#ff9933" -title "Hello"]} - then { + testDialog launch {set clr [tk_chooseColor -initialcolor "#ff9933" -title "Hello"]} + testDialog onDisplay { if {[catch { - array set a [testgetwindowinfo $::tk_dialog] + array set a [testgetwindowinfo $testDialog] if {[info exists a(text)]} {lappend x $a(text)} } err]} { lappend x $err } lappend x [Click ok] @@ -159,13 +92,13 @@ test winDialog-1.5 {Tk_ChooseColorObjCmd: -title} -constraints { catch {unset a x} } -body { set x {} - start { + testDialog launch { set clr [tk_chooseColor -initialcolor "#ff9933" \ -title "Привет"] } - then { + testDialog onDisplay { if {[catch { - array set a [testgetwindowinfo $::tk_dialog] + array set a [testgetwindowinfo $testDialog] if {[info exists a(text)]} {lappend x $a(text)} } err]} { lappend x $err } lappend x [Click ok] @@ -177,11 +110,11 @@ test winDialog-1.6 {Tk_ChooseColorObjCmd: -parent} -constraints { } -setup { catch {unset a x} } -body { - start {set clr [tk_chooseColor -initialcolor "#ff9933" -parent .]} + testDialog launch {set clr [tk_chooseColor -initialcolor "#ff9933" -parent .]} set x {} - then { + testDialog onDisplay { if {[catch { - array set a [testgetwindowinfo $::tk_dialog] + array set a [testgetwindowinfo $testDialog] if {[info exists a(parent)]} { append x [expr {$a(parent) == [wm frame .]}] } @@ -202,8 +135,8 @@ test winDialog-2.1 {ColorDlgHookProc} -constraints {emptyTest nt} -body {} test winDialog-3.1 {Tk_GetOpenFileObjCmd} -constraints { nt testwinevent english } -body { - start {tk_getOpenFile} - then { + testDialog launch {tk_getOpenFile} + testDialog onDisplay { set x [GetText cancel] Click cancel } @@ -214,8 +147,8 @@ test winDialog-3.1 {Tk_GetOpenFileObjCmd} -constraints { test winDialog-4.1 {Tk_GetSaveFileObjCmd} -constraints { nt testwinevent english } -body { - start {tk_getSaveFile} - then { + testDialog launch {tk_getSaveFile} + testDialog onDisplay { set x [GetText cancel] Click cancel } @@ -225,8 +158,8 @@ test winDialog-4.1 {Tk_GetSaveFileObjCmd} -constraints { test winDialog-5.1 {GetFileName: no arguments} -constraints { nt testwinevent } -body { - start {tk_getOpenFile -title Open} - then { + testDialog launch {tk_getOpenFile -title Open} + testDialog onDisplay { Click cancel } } -result 0 @@ -238,8 +171,8 @@ test winDialog-5.2 {GetFileName: one argument} -constraints { test winDialog-5.3 {GetFileName: many arguments} -constraints { nt testwinevent } -body { - start {tk_getOpenFile -initialdir [initialdir] -parent . -title test -initialfile foo} - then { + testDialog launch {tk_getOpenFile -initialdir $initialDir -parent . -title test -initialfile foo} + testDialog onDisplay { Click cancel } } -result 0 @@ -251,8 +184,8 @@ test winDialog-5.4 {GetFileName: Tcl_GetIndexFromObj() != TCL_OK} -constraints { test winDialog-5.5 {GetFileName: Tcl_GetIndexFromObj() == TCL_OK} -constraints { nt testwinevent } -body { - start {set x [tk_getOpenFile -title bar]} - set y [then { + testDialog launch {set x [tk_getOpenFile -title bar]} + set y [testDialog onDisplay { Click cancel }] # Note this also tests fix for @@ -269,10 +202,10 @@ test winDialog-5.6 {GetFileName: valid option, but missing value} -constraints { test winDialog-5.7 {GetFileName: extension begins with .} -constraints { nt testwinevent } -body { - start {set x [tk_getSaveFile -defaultextension .foo -title Save]} + testDialog launch {set x [tk_getSaveFile -defaultextension .foo -title Save]} set msg {} - then { - if {[catch {SetText [vista? 0x47C 0x3e9] bar} msg]} { + testDialog onDisplay { + if {[catch {SetText 0x3e9 bar} msg]} { Click cancel } else { Click ok @@ -286,10 +219,10 @@ test winDialog-5.7 {GetFileName: extension begins with .} -constraints { test winDialog-5.7.1 {GetFileName: extension {} } -constraints { nt testwinevent } -body { - start {set x [tk_getSaveFile -defaultextension {} -title Save]} + testDialog launch {set x [tk_getSaveFile -defaultextension {} -title Save]} set msg {} - then { - if {[catch {SetText [vista? 0x47C 0x3e9] bar} msg]} { + testDialog onDisplay { + if {[catch {SetText 0x3e9 bar} msg]} { Click cancel } else { Click ok @@ -303,10 +236,10 @@ test winDialog-5.7.1 {GetFileName: extension {} } -constraints { test winDialog-5.7.2 {GetFileName: extension {} Bug 47af31bd3ac6fbbb33cde1a5bab1e756ff2a6e00 } -constraints { nt testwinevent } -body { - start {set x [tk_getSaveFile -filetypes {{All *}} -defaultextension {} -title Save]} + testDialog launch {set x [tk_getSaveFile -filetypes {{All *}} -defaultextension {} -title Save]} set msg {} - then { - if {[catch {SetText [vista? 0x47C 0x3e9] bar} msg]} { + testDialog onDisplay { + if {[catch {SetText 0x3e9 bar} msg]} { Click cancel } else { Click ok @@ -320,10 +253,10 @@ test winDialog-5.7.2 {GetFileName: extension {} Bug 47af31bd3ac6fbbb33cde1a5bab1 test winDialog-5.7.3 {GetFileName: extension {} Bug 47af31bd3ac6fbbb33cde1a5bab1e756ff2a6e00 } -constraints { nt testwinevent } -body { - start {set x [tk_getSaveFile -filetypes {{All *}} -defaultextension {} -title Save]} + testDialog launch {set x [tk_getSaveFile -filetypes {{All *}} -defaultextension {} -title Save]} set msg {} - then { - if {[catch {SetText [vista? 0x47C 0x3e9] bar.c} msg]} { + testDialog onDisplay { + if {[catch {SetText 0x3e9 bar.c} msg]} { Click cancel } else { Click ok @@ -339,10 +272,10 @@ test winDialog-5.7.4 {GetFileName: extension {} } -constraints { } -body { # Although the docs do not explicitly mention, -filetypes seems to # override -defaultextension - start {set x [tk_getSaveFile -filetypes {{C .c} {Tcl .tcl}} -defaultextension {foo} -title Save]} + testDialog launch {set x [tk_getSaveFile -filetypes {{C .c} {Tcl .tcl}} -defaultextension {foo} -title Save]} set msg {} - then { - if {[catch {SetText [vista? 0x47C 0x3e9] bar} msg]} { + testDialog onDisplay { + if {[catch {SetText 0x3e9 bar} msg]} { Click cancel } else { Click ok @@ -358,10 +291,10 @@ test winDialog-5.7.5 {GetFileName: extension {} } -constraints { } -body { # Although the docs do not explicitly mention, -filetypes seems to # override -defaultextension - start {set x [tk_getSaveFile -filetypes {{C .c} {Tcl .tcl}} -defaultextension {} -title Save]} + testDialog launch {set x [tk_getSaveFile -filetypes {{C .c} {Tcl .tcl}} -defaultextension {} -title Save]} set msg {} - then { - if {[catch {SetText [vista? 0x47C 0x3e9] bar} msg]} { + testDialog onDisplay { + if {[catch {SetText 0x3e9 bar} msg]} { Click cancel } else { Click ok @@ -377,10 +310,10 @@ test winDialog-5.7.6 {GetFileName: All/extension } -constraints { nt testwinevent } -body { # In 8.6.4 this combination resulted in bar.aaa.aaa which is bad - start {set x [tk_getSaveFile -filetypes {{All *}} -defaultextension {aaa} -title Save]} + testDialog launch {set x [tk_getSaveFile -filetypes {{All *}} -defaultextension {aaa} -title Save]} set msg {} - then { - if {[catch {SetText [vista? 0x47C 0x3e9] bar} msg]} { + testDialog onDisplay { + if {[catch {SetText 0x3e9 bar} msg]} { Click cancel } else { Click ok @@ -395,39 +328,39 @@ test winDialog-5.7.7 {tk_getOpenFile: -defaultextension} -constraints { nt testwinevent } -body { unset -nocomplain x - tcltest::makeFile "" "5 7 7.aaa" [initialdir] - start {set x [tk_getOpenFile \ + tcltest::makeFile "" "5 7 7.aaa" $initialDir + testDialog launch {set x [tk_getOpenFile \ -defaultextension aaa \ - -initialdir [file nativename [initialdir]] \ + -initialdir [file nativename $initialDir] \ -initialfile "5 7 7" -title Foo]} - then { + testDialog onDisplay { Click ok } return $x -} -result [file join [initialdir] "5 7 7.aaa"] +} -result [file join $initialDir "5 7 7.aaa"] test winDialog-5.7.8 {tk_getOpenFile: -defaultextension} -constraints { nt testwinevent } -body { unset -nocomplain x - tcltest::makeFile "" "5 7 8.aaa" [initialdir] - start {set x [tk_getOpenFile \ + tcltest::makeFile "" "5 7 8.aaa" $initialDir + testDialog launch {set x [tk_getOpenFile \ -defaultextension aaa \ - -initialdir [file nativename [initialdir]] \ + -initialdir [file nativename $initialDir] \ -initialfile "5 7 8.aaa" -title Foo]} - then { + testDialog onDisplay { Click ok } return $x -} -result [file join [initialdir] "5 7 8.aaa"] +} -result [file join $initialDir "5 7 8.aaa"] test winDialog-5.8 {GetFileName: extension doesn't begin with .} -constraints { nt testwinevent } -body { - start {set x [tk_getSaveFile -defaultextension foo -title Save]} + testDialog launch {set x [tk_getSaveFile -defaultextension foo -title Save]} set msg {} - then { - if {[catch {SetText [vista? 0x47C 0x3e9] bar} msg]} { + testDialog onDisplay { + if {[catch {SetText 0x3e9 bar} msg]} { Click cancel } else { Click ok @@ -438,27 +371,24 @@ test winDialog-5.8 {GetFileName: extension doesn't begin with .} -constraints { unset msg } -result bar.foo test winDialog-5.9 {GetFileName: file types} -constraints { - nt testwinevent -} -body { - # case FILE_TYPES: - - start {tk_getSaveFile -filetypes {{"foo files" .foo FOOF}} -title Foo} - # XXX - currently disabled for vista style dialogs because the file - # types control has no control ID and we don't have a mechanism to - # locate it. - if {[vista?]} { - then { - Click cancel - } - return 1 - } else { - then { - set x [GetText 0x470] - Click cancel - } - return [string equal $x {foo files (*.foo)}] + nt testwinevent knownBug +} -body { + # + # This test was used with MS Windows versions before Windows Vista. + # Starting from that version, the test is not valid anymore because the + # dialog's file types control has no control ID and we don't have a + # mechanism to locate it. + # The test remains at this place, with constraint knownBug, to serve as an + # example/template in the event that the situation changes in the future + # somehow. + # + testDialog launch {tk_getSaveFile -filetypes {{"foo files" .foo FOOF}} -title Foo} + testDialog onDisplay { + set x [GetText 0x470] + Click cancel } -} -result 1 + return $x +} -result {foo files (*.foo)} test winDialog-5.10 {GetFileName: file types: MakeFilter() fails} -constraints { nt } -body { @@ -471,24 +401,24 @@ test winDialog-5.11 {GetFileName: initial directory} -constraints { } -body { # case FILE_INITDIR: unset -nocomplain x - start {set x [tk_getSaveFile \ - -initialdir [initialdir] \ + testDialog launch {set x [tk_getSaveFile \ + -initialdir $initialDir \ -initialfile "12x 455" -title Foo]} - then { + testDialog onDisplay { Click ok } return $x -} -result [file join [initialdir] "12x 455"] +} -result [file join $initialDir "12x 455"] test winDialog-5.12.4 {tk_getSaveFile: initial directory: unicode} -constraints { nt testwinevent } -body { set dir [tcltest::makeDirectory "ŧéŝŧ"] unset -nocomplain x - start {set x [tk_getSaveFile \ + testDialog launch {set x [tk_getSaveFile \ -initialdir $dir \ -initialfile "testfile" -title Foo]} - then { + testDialog onDisplay { Click ok } string equal $x [file join $dir testfile] @@ -498,29 +428,29 @@ test winDialog-5.12.5 {tk_getSaveFile: initial directory: nativename} -constrain nt testwinevent } -body { unset -nocomplain x - start {set x [tk_getSaveFile \ - -initialdir [file nativename [initialdir]] \ + testDialog launch {set x [tk_getSaveFile \ + -initialdir [file nativename $initialDir] \ -initialfile "5 12 5" -title Foo]} - then { + testDialog onDisplay { Click ok } return $x -} -result [file join [initialdir] "5 12 5"] +} -result [file join $initialDir "5 12 5"] test winDialog-5.12.6 {tk_getSaveFile: initial directory: relative} -constraints { nt testwinevent } -body { # Windows remembers dirs from previous selections so use - # a subdir for this test, not [initialdir] itself + # a subdir for this test, not $initialDir itself set dir [tcltest::makeDirectory "5 12 6"] set cur [pwd] try { cd [file dirname $dir] unset -nocomplain x - start {set x [tk_getSaveFile \ + testDialog launch {set x [tk_getSaveFile \ -initialdir "5 12 6" \ -initialfile "testfile" -title Foo]} - then { + testDialog onDisplay { Click ok } } finally { @@ -533,17 +463,17 @@ test winDialog-5.12.8 {tk_getOpenFile: initial directory: .} -constraints { nt testwinevent } -body { # Windows remembers dirs from previous selections so use - # a subdir for this test, not [initialdir] itself + # a subdir for this test, not $initialDir itself set newdir [tcltest::makeDirectory "5 12 8"] set path [tcltest::makeFile "" "testfile" $newdir] set cur [pwd] try { cd $newdir unset -nocomplain x - start {set x [tk_getOpenFile \ + testDialog launch {set x [tk_getOpenFile \ -initialdir . \ -initialfile "testfile" -title Foo]} - then { + testDialog onDisplay { Click ok } } finally { @@ -558,10 +488,10 @@ test winDialog-5.12.9 {tk_getOpenFile: initial directory: unicode} -constraints set dir [tcltest::makeDirectory "ŧéŝŧ"] set path [tcltest::makeFile "" testfile $dir] unset -nocomplain x - start {set x [tk_getOpenFile \ + testDialog launch {set x [tk_getOpenFile \ -initialdir $dir \ -initialfile "testfile" -title Foo]} - then { + testDialog onDisplay { Click ok } string equal $x $path @@ -571,31 +501,31 @@ test winDialog-5.12.10 {tk_getOpenFile: initial directory: nativename} -constrai nt testwinevent } -body { unset -nocomplain x - tcltest::makeFile "" "5 12 10" [initialdir] - start {set x [tk_getOpenFile \ - -initialdir [file nativename [initialdir]] \ + tcltest::makeFile "" "5 12 10" $initialDir + testDialog launch {set x [tk_getOpenFile \ + -initialdir [file nativename $initialDir] \ -initialfile "5 12 10" -title Foo]} - then { + testDialog onDisplay { Click ok } return $x -} -result [file join [initialdir] "5 12 10"] +} -result [file join $initialDir "5 12 10"] test winDialog-5.12.11 {tk_getOpenFile: initial directory: relative} -constraints { nt testwinevent } -body { # Windows remembers dirs from previous selections so use - # a subdir for this test, not [initialdir] itself + # a subdir for this test, not $initialDir itself set dir [tcltest::makeDirectory "5 12 11"] set path [tcltest::makeFile "" testfile $dir] set cur [pwd] try { cd [file dirname $dir] unset -nocomplain x - start {set x [tk_getOpenFile \ + testDialog launch {set x [tk_getOpenFile \ -initialdir [file tail $dir] \ -initialfile "testfile" -title Foo]} - then { + testDialog onDisplay { Click ok } } finally { @@ -609,12 +539,13 @@ test winDialog-5.13 {GetFileName: initial file} -constraints { } -body { # case FILE_INITFILE: - start {set x [tk_getSaveFile -initialfile "12x 456" -title Foo]} - then { + testDialog launch {set x [tk_getSaveFile -initialfile "12x 456" -title Foo]} + testDialog onDisplay { Click ok } file tail $x } -result "12x 456" + test winDialog-5.16 {GetFileName: parent} -constraints { nt } -body { @@ -622,8 +553,8 @@ test winDialog-5.16 {GetFileName: parent} -constraints { toplevel .t set x 0 - start {tk_getOpenFile -parent .t -title Parent; set x 1} - then { + testDialog launch {tk_getOpenFile -parent .t -title Parent; set x 1} + testDialog onDisplay { destroy .t } return $x @@ -633,39 +564,24 @@ test winDialog-5.17 {GetFileName: title} -constraints { } -body { # case FILE_TITLE: - start {tk_getOpenFile -title Narf} - then { + testDialog launch {tk_getOpenFile -title Narf} + testDialog onDisplay { Click cancel } } -result 0 -if {[vista?]} { - # In the newer file dialogs, the file type widget does not even exist - # if no file types specified - test winDialog-5.18 {GetFileName: no filter specified} -constraints { - nt testwinevent - } -body { - # if (ofn.lpstrFilter == NULL) - start {tk_getOpenFile -title Filter} - then { - catch {set x [GetText 0x470]} y - Click cancel - } - return $y - } -result {Could not find control with id 1136} -} else { - test winDialog-5.18 {GetFileName: no filter specified} -constraints { - nt testwinevent - } -body { - # if (ofn.lpstrFilter == NULL) - - start {tk_getOpenFile -title Filter} - then { - set x [GetText 0x470] - Click cancel - } - return $x - } -result {All Files (*.*)} -} +# In the newer file dialogs, the file type widget does not even exist +# if no file types specified +test winDialog-5.18 {GetFileName: no filter specified} -constraints { + nt testwinevent +} -body { + # if (ofn.lpstrFilter == NULL) + testDialog launch {tk_getOpenFile -title Filter} + testDialog onDisplay { + catch {set x [GetText 0x470]} y + Click cancel + } + return $y +} -result {Could not find control with id 1136} test winDialog-5.19 {GetFileName: parent HWND doesn't yet exist} -constraints { nt } -setup { @@ -674,8 +590,8 @@ test winDialog-5.19 {GetFileName: parent HWND doesn't yet exist} -constraints { # if (Tk_WindowId(parent) == None) toplevel .t - start {tk_getOpenFile -parent .t -title Open} - then { + testDialog launch {tk_getOpenFile -parent .t -title Open} + testDialog onDisplay { destroy .t } } -result {} @@ -686,8 +602,8 @@ test winDialog-5.20 {GetFileName: parent HWND already exists} -constraints { } -body { toplevel .t update - start {tk_getOpenFile -parent .t -title Open} - then { + testDialog launch {tk_getOpenFile -parent .t -title Open} + testDialog onDisplay { destroy .t } } -result {} @@ -696,8 +612,8 @@ test winDialog-5.21 {GetFileName: call GetOpenFileName} -constraints { } -body { # winCode = GetOpenFileName(&ofn); - start {tk_getOpenFile -title Open} - then { + testDialog launch {tk_getOpenFile -title Open} + testDialog onDisplay { set x [GetText ok] Click cancel } @@ -708,8 +624,8 @@ test winDialog-5.22 {GetFileName: call GetSaveFileName} -constraints { } -body { # winCode = GetSaveFileName(&ofn); - start {tk_getSaveFile -title Save} - then { + testDialog launch {tk_getSaveFile -title Save} + testDialog onDisplay { set x [GetText ok] Click cancel } @@ -719,10 +635,10 @@ test winDialog-5.23 {GetFileName: convert \ to /} -constraints { nt testwinevent } -body { set msg {} - start {set x [tk_getSaveFile -title Back]} - then { - if {[catch {SetText [vista? 0x47C 0x3e9] [file nativename \ - [file join [initialdir] "12x 457"]]} msg]} { + testDialog launch {set x [tk_getSaveFile -title Back]} + testDialog onDisplay { + if {[catch {SetText 0x3e9 [file nativename \ + [file join $initialDir "12x 457"]]} msg]} { Click cancel } else { Click ok @@ -731,14 +647,14 @@ test winDialog-5.23 {GetFileName: convert \ to /} -constraints { return $x$msg } -cleanup { unset msg -} -result [file join [initialdir] "12x 457"] +} -result [file join $initialDir "12x 457"] test winDialog-5.24 {GetFileName: file types: MakeFilter() succeeds} -constraints { nt } -body { # MacOS type that is correct, but has embedded nulls. - start {set x [catch {tk_getSaveFile -filetypes {{"foo" .foo {\0\0\0\0}}}}]} - then { + testDialog launch {set x [catch {tk_getSaveFile -filetypes {{"foo" .foo {\0\0\0\0}}}}]} + testDialog onDisplay { Click cancel } return $x @@ -748,8 +664,8 @@ test winDialog-5.25 {GetFileName: file types: MakeFilter() succeeds} -constraint } -body { # MacOS type that is correct, but has embedded high-bit chars. - start {set x [catch {tk_getSaveFile -filetypes {{"foo" .foo {••••}}}}]} - then { + testDialog launch {set x [catch {tk_getSaveFile -filetypes {{"foo" .foo {••••}}}}]} + testDialog onDisplay { Click cancel } return $x @@ -772,8 +688,8 @@ test winDialog-8.1 {OFNHookProc} -constraints {emptyTest nt} -body {} test winDialog-9.1 {Tk_ChooseDirectoryObjCmd: no arguments} -constraints { nt testwinevent } -body { - start {set x [tk_chooseDirectory]} - set y [then { + testDialog launch {set x [tk_chooseDirectory]} + set y [testDialog onDisplay { Click cancel }] # $x should be "" on a Cancel @@ -787,10 +703,10 @@ test winDialog-9.2 {Tk_ChooseDirectoryObjCmd: one argument} -constraints { test winDialog-9.3 {Tk_ChooseDirectoryObjCmd: many arguments} -constraints { nt testwinevent } -body { - start { - tk_chooseDirectory -initialdir [initialdir] -mustexist 1 -parent . -title test + testDialog launch { + tk_chooseDirectory -initialdir $initialDir -mustexist 1 -parent . -title test } - then { + testDialog onDisplay { Click cancel } } -result 0 @@ -802,8 +718,8 @@ test winDialog-9.4 {Tk_ChooseDirectoryObjCmd: Tcl_GetIndexFromObj() != TCL_OK} - test winDialog-9.5 {Tk_ChooseDirectoryObjCmd: Tcl_GetIndexFromObj() == TCL_OK} -constraints { nt testwinevent } -body { - start {tk_chooseDirectory -title bar} - then { + testDialog launch {tk_chooseDirectory -title bar} + testDialog onDisplay { Click cancel } } -result 0 @@ -817,104 +733,104 @@ test winDialog-9.7 {Tk_ChooseDirectoryObjCmd: -initialdir} -constraints { } -body { # case DIR_INITIAL: - start {set x [tk_chooseDirectory -initialdir [initialdir] -title Foo]} - then { + testDialog launch {set x [tk_chooseDirectory -initialdir $initialDir -title Foo]} + testDialog onDisplay { Click ok } string tolower [set x] -} -result [string tolower [initialdir]] +} -result [string tolower $initialDir] test winDialog-10.1 {Tk_FontchooserObjCmd: no arguments} -constraints { nt testwinevent } -body { - start {tk fontchooser show} - list [then { + testDialog launch {tk fontchooser show} + list [testDialog onDisplay { Click cancel - }] $::testfont + }] $testDialogFont } -result {0 {}} test winDialog-10.2 {Tk_FontchooserObjCmd: -initialfont} -constraints { nt testwinevent } -body { - start { - tk fontchooser configure -command ApplyFont -font system + testDialog launch { + tk fontchooser configure -command $applyFontCmd -font system tk fontchooser show } - list [then { + list [testDialog onDisplay { Click cancel - }] $::testfont + }] $testDialogFont } -result {0 {}} test winDialog-10.3 {Tk_FontchooserObjCmd: -initialfont} -constraints { nt testwinevent } -body { - start { - tk fontchooser configure -command ApplyFont -font system + testDialog launch { + tk fontchooser configure -command $applyFontCmd -font system tk fontchooser show } - list [then { + list [testDialog onDisplay { Click 1 - }] [expr {[llength $::testfont] ne {}}] + }] [expr {[llength $testDialogFont] > 0}] } -result {0 1} test winDialog-10.4 {Tk_FontchooserObjCmd: -title} -constraints { nt testwinevent } -body { - start { - tk fontchooser configure -command ApplyFont -title "tk test" + testDialog launch { + tk fontchooser configure -command $applyFontCmd -title "tk test" tk fontchooser show } - list [then { + list [testDialog onDisplay { Click cancel - }] $::testfont + }] $testDialogFont } -result {0 {}} test winDialog-10.5 {Tk_FontchooserObjCmd: -parent} -constraints { nt testwinevent } -setup { array set a {parent {}} } -body { - start { - tk fontchooser configure -command ApplyFont -parent . + testDialog launch { + tk fontchooser configure -command $applyFontCmd -parent . tk fontchooser show } - then { - array set a [testgetwindowinfo $::tk_dialog] + testDialog onDisplay { + array set a [testgetwindowinfo $testDialog] Click cancel } - list [expr {$a(parent) == [wm frame .]}] $::testfont + list [expr {$a(parent) == [wm frame .]}] $testDialogFont } -result {1 {}} test winDialog-10.6 {Tk_FontchooserObjCmd: -apply} -constraints { nt testwinevent } -body { - start { + testDialog launch { tk fontchooser configure -command FooBarBaz tk fontchooser show } - then { + testDialog onDisplay { Click cancel } } -result 0 test winDialog-10.7 {Tk_FontchooserObjCmd: -apply} -constraints { nt testwinevent } -body { - start { - tk fontchooser configure -command ApplyFont -parent . + testDialog launch { + tk fontchooser configure -command $applyFontCmd -parent . tk fontchooser show } - list [then { + list [testDialog onDisplay { Click [expr {0x0402}] ;# value from XP Click cancel - }] [expr {[llength $::testfont] > 0}] + }] [expr {[llength $testDialogFont] > 0}] } -result {0 1} test winDialog-10.8 {Tk_FontchooserObjCmd: -title} -constraints { nt testwinevent } -setup { array set a {text failed} } -body { - start { - tk fontchooser configure -command ApplyFont -title "Hello" + testDialog launch { + tk fontchooser configure -command $applyFontCmd -title "Hello" tk fontchooser show } - then { - array set a [testgetwindowinfo $::tk_dialog] + testDialog onDisplay { + array set a [testgetwindowinfo $testDialog] Click cancel } set a(text) @@ -924,13 +840,13 @@ test winDialog-10.9 {Tk_FontchooserObjCmd: -title} -constraints { } -setup { array set a {text failed} } -body { - start { - tk fontchooser configure -command ApplyFont \ + testDialog launch { + tk fontchooser configure -command $applyFontCmd \ -title "Привет" tk fontchooser show } - then { - array set a [testgetwindowinfo $::tk_dialog] + testDialog onDisplay { + array set a [testgetwindowinfo $testDialog] Click cancel } set a(text) @@ -940,7 +856,12 @@ if {[testConstraint testwinevent]} { catch {testwinevent debug 0} } -# cleanup +# +# CLEANUP +# + +unset applyFontCmd initialDir +testutils forget dialog cleanupTests return diff --git a/tests/winFont.test b/tests/winFont.test index 495a5d2..c036313 100644 --- a/tests/winFont.test +++ b/tests/winFont.test @@ -15,6 +15,8 @@ namespace import ::tcltest::* tcltest::configure {*}$argv tcltest::loadTestedCommands +# Import utility procs for specific functional areas +testutils import geometry test winfont-1.1 {TkpGetNativeFont procedure: not native} -constraints { win @@ -125,10 +127,6 @@ update set ax [winfo reqwidth .t.l] set ay [winfo reqheight .t.l] -proc getsize {} { - update - return "[winfo reqwidth .t.l] [winfo reqheight .t.l]" -} test winfont-5.1 {Tk_MeasureChars procedure: unbounded right margin} -constraints { win @@ -332,7 +330,7 @@ test winfont-5.11 {Tk_MeasureChars procedure: check for kerning} -constraints { .t.l config -font {{MS Sans Serif} 8} -text "W" set width [winfo reqwidth .t.l] .t.l config -text "XaYoYaKaWx" - set x [lindex [getsize] 0] + set x [lindex [getsize .t.l] 0] .t.l config -font $font expr {$x < ($width*10)} } -cleanup { @@ -382,11 +380,14 @@ test winfont-7.4 {InitFont procedure: extract info from textmetric} -constraints font metric systemfixed -fixed } -result 1 -# cleanup +# +# CLEANUP +# + +testutils forget geometry cleanupTests return # Local variables: # mode: tcl # End: - diff --git a/tests/winMsgbox.test b/tests/winMsgbox.test index ea81266..ab5698c 100644 --- a/tests/winMsgbox.test +++ b/tests/winMsgbox.test @@ -13,10 +13,6 @@ if {[testConstraint testwinevent]} { catch {testwinevent debug 1} } -proc Click {hwnd button} { - testwinevent $hwnd $button WM_COMMAND -} - proc GetWindowInfo {title button} { global windowInfo set windowInfo {} diff --git a/tests/winSend.test b/tests/winSend.test index 4a7f81d..c7426cc 100644 --- a/tests/winSend.test +++ b/tests/winSend.test @@ -11,27 +11,8 @@ package require tcltest 2.2 eval tcltest::configure $argv tcltest::loadTestedCommands -# Compute a script that will load Tk into a child interpreter. - -foreach pkg [info loaded] { - if {[lindex $pkg 1] == "Tk"} { - set loadTk "load $pkg" - break - } -} - -# Procedure to create a new application with a given name and class. - -proc newApp {name {safe {}}} { - global loadTk - if {[string compare $safe "-safe"] == 0} { - interp create -safe $name - } else { - interp create $name - } - $name eval [list set argv [list -name $name]] - catch {eval $loadTk $name} -} +# Import utility procs for specific functional areas +testutils import child set currentInterps [winfo interps] if { @@ -65,32 +46,32 @@ if { # setting up dde server is done when the first interp is created and # cannot be tested very easily. test winSend-1.1 {Tk_SetAppName - changing name of interp} winSend { - newApp testApp + childTkInterp testApp list [testApp eval tk appname testApp2] [interp delete testApp] } {testApp2 {}} test winSend-1.2 {Tk_SetAppName - changing name - not front of linked list} winSend { - newApp testApp - newApp testApp2 + childTkInterp testApp + childTkInterp testApp2 list [testApp eval tk appname testApp3] [interp delete testApp] [interp delete testApp2] } {testApp3 {} {}} test winSend-1.3 {Tk_SetAppName - unique name - no conflicts} winSend { - newApp testApp + childTkInterp testApp list [testApp eval tk appname testApp] [interp delete testApp] } {testApp {}} test winSend-1.4 {Tk_SetAppName - unique name - one conflict} winSend { - newApp testApp - newApp foobar + childTkInterp testApp + childTkInterp foobar list [foobar eval tk appname testApp] [interp delete foobar] [interp delete testApp] } {{testApp #2} {} {}} test winSend-1.5 {Tk_SetAppName - unique name - one conflict} winSend { - newApp testApp - newApp foobar - newApp blaz + childTkInterp testApp + childTkInterp foobar + childTkInterp blaz foobar eval tk appname testApp list [blaz eval tk appname testApp] [interp delete foobar] [interp delete testApp] [interp delete blaz] } {{testApp #3} {} {} {}} test winSend-1.6 {Tk_SetAppName - safe interps} winSend { - newApp testApp -safe + childTkInterp testApp -safe list [catch {testApp eval send testApp {set foo a}} msg] $msg [interp delete testApp] } {1 {invalid command name "send"} {}} @@ -113,11 +94,11 @@ test winSend-2.2 {Tk_SendObjCmd - sending to ourselves} winSend { list [send [tk appname] {set foo a}] } {a} test winSend-2.3 {Tk_SendObjCmd - sending to ourselves in a different interpreter} winSend { - newApp testApp + childTkInterp testApp list [catch {send testApp {set foo b}} msg] $msg [interp delete testApp] } {0 b {}} test winSend-2.4 {Tk_SendObjCmd - sending to ourselves in a different interp with errors} winSend { - newApp testApp + childTkInterp testApp list [catch {send testApp {expr {2 / 0}}} msg] $msg $errorCode $errorInfo [interp delete testApp] } "1 {divide by zero} {ARITH DIVZERO {divide by zero}} {divide by zero\n while executing\n\"expr {2 / 0}\"\n invoked from within\n\"send testApp {expr {2 / 0}}\"} {}" test winSend-2.5 {Tk_SendObjCmd - sending to another app async} winSend { @@ -155,11 +136,11 @@ test winSend-3.1 {TkGetInterpNames} winSend { } 1 test winSend-4.1 {DeleteProc - changing name of app} winSend { - newApp a + childTkInterp a list [a eval tk appname foo] [interp delete a] } {foo {}} test winSend-4.2 {DeleteProc - normal} winSend { - newApp a + childTkInterp a list [interp delete a] } {{}} @@ -271,7 +252,7 @@ test winSend-6.8 {SendDDEServer - XTYP_WILDCONNECT} winSend { } 0 test winSend-7.1 {DDEExitProc} winSend { - newApp testApp + childTkInterp testApp list [interp delete testApp] } {{}} @@ -402,6 +383,10 @@ while {[llength $newInterps] != [llength $currentInterps]} { } } -# cleanup +# +# CLEANUP +# + +testutils forget child cleanupTests return diff --git a/tests/winWm.test b/tests/winWm.test index 783a4e1..999e886 100644 --- a/tests/winWm.test +++ b/tests/winWm.test @@ -14,9 +14,6 @@ namespace import ::tcltest::* tcltest::configure {*}$argv tcltest::loadTestedCommands -testConstraint failsOnUbuntu [expr {![info exists ::env(CI)] || ![string match Linux $::tcl_platform(os)]}] -testConstraint failsOnXQuarz [expr {$tcl_platform(os) ne "Darwin" || [tk windowingsystem] ne "x11" }] - test winWm-1.1 {TkWmMapWindow} -constraints win -setup { destroy .t } -body { @@ -533,7 +530,7 @@ test winWm-9.1 "delayed activation of grabbed destroyed window" -constraints win destroy .tx .t .sd } -result ok -test winWm-9.2 "check wm forget for unmapped parent (#3205464,#2967911)" -constraints {failsOnUbuntu failsOnXQuarz} -setup { +test winWm-9.2 "check wm forget for unmapped parent (#3205464,#2967911)" -constraints {failsOnUbuntu failsOnXQuartz} -setup { destroy .t toplevel .t set winwm92 {} diff --git a/tests/window.test b/tests/window.test index de34221..f25720d 100644 --- a/tests/window.test +++ b/tests/window.test @@ -9,7 +9,7 @@ package require tcltest 2.2 namespace import ::tcltest::* tcltest::configure {*}$argv tcltest::loadTestedCommands -namespace import ::tk::test::loadTkCommand + update # Move the mouse out of the way for window-2.1 event generate {} <Motion> -warp 1 -x 640 -y 10 diff --git a/tests/winfo.test b/tests/winfo.test index 76c57c9..b19f762 100644 --- a/tests/winfo.test +++ b/tests/winfo.test @@ -11,33 +11,8 @@ namespace import ::tcltest::* tcltest::configure {*}$argv tcltest::loadTestedCommands -testConstraint failsOnUbuntu [expr {![info exists ::env(CI)] || ![string match Linux $::tcl_platform(os)]}] -testConstraint failsOnXQuarz [expr {$tcl_platform(os) ne "Darwin" || [tk windowingsystem] ne "x11" }] - -# eatColors -- -# Creates a toplevel window and allocates enough colors in it to -# use up all the slots in the colormap. -# -# Arguments: -# w - Name of toplevel window to create. -# options - Options for w, such as "-colormap new". - -proc eatColors {w {options ""}} { - destroy $w - eval toplevel $w $options - wm geom $w +0+0 - canvas $w.c -width 400 -height 200 -bd 0 - pack $w.c - for {set y 0} {$y < 8} {incr y} { - for {set x 0} {$x < 40} {incr x} { - set color [format #%02x%02x%02x [expr {$x*6}] [expr {$y*30}] 0] - $w.c create rectangle [expr {10*$x}] [expr {20*$y}] \ - [expr {10*$x + 10}] [expr {20*$y + 20}] -outline {} \ - -fill $color - } - } - update -} +# Import utility procs for specific functional areas +testutils import colors # XXX - This test file is woefully incomplete. At present, only a # few of the winfo options are tested. @@ -294,7 +269,7 @@ test winfo-9.2 {"winfo viewable" command} -body { test winfo-9.3 {"winfo viewable" command} -body { winfo viewable . } -result 1 -test winfo-9.4 {"winfo viewable" command} -constraints {failsOnUbuntu failsOnXQuarz} -body { +test winfo-9.4 {"winfo viewable" command} -constraints {failsOnUbuntu failsOnXQuartz} -body { wm iconify . winfo viewable . } -cleanup { @@ -323,7 +298,7 @@ test winfo-9.6 {"winfo viewable" command} -setup { } -cleanup { deleteWindows } -result {0 0} -test winfo-9.7 {"winfo viewable" command} -constraints {failsOnUbuntu failsOnXQuarz} -setup { +test winfo-9.7 {"winfo viewable" command} -constraints {failsOnUbuntu failsOnXQuartz} -setup { deleteWindows } -body { frame .f1 -width 100 -height 100 -relief raised -bd 2 @@ -487,8 +462,12 @@ test winfo-14.4 {mapped at idle time} -setup { destroy .t } -result 1 +# +# CLEANUP +# + deleteWindows -# cleanup +testutils forget colors cleanupTests return diff --git a/tests/wm.test b/tests/wm.test index b5500f8..cf1bbd7 100644 --- a/tests/wm.test +++ b/tests/wm.test @@ -92,9 +92,6 @@ proc stdWindow {} { update } -testConstraint failsOnUbuntu [expr {![info exists ::env(CI)] || ![string match Linux $::tcl_platform(os)]}] -testConstraint failsOnXQuarz [expr {$tcl_platform(os) ne "Darwin" || [tk windowingsystem] ne "x11" }] - # [raise] and [lower] may return before the window manager has completed the # operation. The raiseDelay procedure idles for a while to give the operation # a chance to complete. @@ -106,12 +103,6 @@ proc raiseDelay {} { update } -# How to carry out a small delay while processing events - -proc eventDelay {{delay 200}} { - after $delay "set done 1" ; vwait done -} - deleteWindows ############################################################################## @@ -362,11 +353,11 @@ test wm-attributes-1.4.0 {setting/unsetting fullscreen does not change the focus lappend results [focus] wm attributes .t -fullscreen 1 - eventDelay + pause 200 lappend results [focus] wm attributes .t -fullscreen 0 - eventDelay + pause 200 lappend results [focus] } -cleanup { deleteWindows @@ -379,19 +370,19 @@ test wm-attributes-1.4.1 {setting fullscreen does not generate FocusIn on wrappe pack [entry .t.e] lower .t bind .t <FocusIn> {lappend focusin %W} - eventDelay + pause 200 lappend focusin 1 focus -force .t.e - eventDelay + pause 200 lappend focusin 2 wm attributes .t -fullscreen 1 - eventDelay + pause 200 lappend focusin 3 wm attributes .t -fullscreen 0 - eventDelay + pause 200 lappend focusin final [focus] } -cleanup { @@ -405,13 +396,13 @@ test wm-attributes-1.5.0 {fullscreen stackorder} -setup { } -constraints win -body { toplevel .t lappend results [wm stackorder .] - eventDelay + pause 200 lappend results [wm stackorder .] # Default stacking is on top of other windows on the display. Setting the # fullscreen attribute does not change this. wm attributes .t -fullscreen 1 - eventDelay + pause 200 lappend results [wm stackorder .] } -cleanup { deleteWindows @@ -421,13 +412,13 @@ test wm-attributes-1.5.1 {fullscreen stackorder} -setup { } -constraints win -body { toplevel .t lower .t - eventDelay + pause 200 lappend results [wm stackorder .] # If stacking order is explicitly set, then setting the fullscreen # attribute should not change it. wm attributes .t -fullscreen 1 - eventDelay + pause 200 lappend results [wm stackorder .] } -cleanup { deleteWindows @@ -443,7 +434,7 @@ test wm-attributes-1.5.2 {fullscreen stackorder} -setup { # If stacking order is explicitly set for an unmapped window, then setting # the fullscreen attribute should not change it. wm attributes .t -fullscreen 1 - eventDelay + pause 200 lappend results [wm stackorder .] } -cleanup { deleteWindows @@ -452,16 +443,16 @@ test wm-attributes-1.5.3 {fullscreen stackorder} -setup { set results [list] } -constraints win -body { toplevel .t - eventDelay + pause 200 lappend results [wm stackorder .] wm attributes .t -fullscreen 1 - eventDelay + pause 200 lappend results [wm stackorder .] # Unsetting the fullscreen attribute should not change the stackorder. wm attributes .t -fullscreen 0 - eventDelay + pause 200 lappend results [wm stackorder .] } -cleanup { deleteWindows @@ -471,16 +462,16 @@ test wm-attributes-1.5.4 {fullscreen stackorder} -setup { } -constraints win -body { toplevel .t lower .t - eventDelay + pause 200 lappend results [wm stackorder .] wm attributes .t -fullscreen 1 - eventDelay + pause 200 lappend results [wm stackorder .] # Unsetting the fullscreen attribute should not change the stackorder. wm attributes .t -fullscreen 0 - eventDelay + pause 200 lappend results [wm stackorder .] } -cleanup { deleteWindows @@ -494,16 +485,16 @@ test wm-attributes-1.5.5 {fullscreen stackorder} -setup { raise .a raise .b raise .c - eventDelay + pause 200 lappend results [wm stackorder .] wm attributes .b -fullscreen 1 - eventDelay + pause 200 lappend results [wm stackorder .] # Unsetting the fullscreen attribute should not change the stackorder. wm attributes .b -fullscreen 0 - eventDelay + pause 200 lappend results [wm stackorder .] } -cleanup { deleteWindows @@ -946,7 +937,7 @@ test wm-iconify-2.4.2 {Misc errors} -constraints !win -setup { destroy .t2 .r.f } -result {can't iconify ".t2": it is an embedded window} -test wm-iconify-3.1 {iconify behavior} -constraints {failsOnUbuntu failsOnXQuarz} -body { +test wm-iconify-3.1 {iconify behavior} -constraints {failsOnUbuntu failsOnXQuartz} -body { toplevel .t2 wm geom .t2 -0+0 update idletasks @@ -1567,7 +1558,7 @@ test wm-stackorder-2.7 {stacking order: no children returns self} -setup { deleteWindows -test wm-stackorder-3.1 {unmapped toplevel} -constraints {failsOnUbuntu failsOnXQuarz} -body { +test wm-stackorder-3.1 {unmapped toplevel} -constraints {failsOnUbuntu failsOnXQuartz} -body { toplevel .t1 ; update raiseDelay toplevel .t2 ; update @@ -1686,7 +1677,7 @@ test wm-stackorder-5.1 {a menu is not a toplevel} -body { destroy .t } -result {.t .} test wm-stackorder-5.2 {A normal toplevel can't be raised above an \ - overrideredirect toplevel on unix} -constraints {x11 failsOnUbuntu failsOnXQuarz} -body { + overrideredirect toplevel on unix} -constraints {x11 failsOnUbuntu failsOnXQuartz} -body { toplevel .t wm overrideredirect .t 1 tkwait visibility .t @@ -1886,7 +1877,7 @@ test wm-transient-3.3 {withdraw/deiconify on the toplevel } -result {withdrawn 0 normal 1} test wm-transient-4.1 {transient toplevel is withdrawn - when mapped if toplevel is iconic} -constraints {failsOnUbuntu failsOnXQuarz} -body { + when mapped if toplevel is iconic} -constraints {failsOnUbuntu failsOnXQuartz} -body { toplevel .top wm iconify .top update @@ -1898,7 +1889,7 @@ test wm-transient-4.1 {transient toplevel is withdrawn deleteWindows } -result {withdrawn 0} test wm-transient-4.2 {already mapped transient toplevel - is withdrawn if toplevel is iconic} -constraints {failsOnUbuntu failsOnXQuarz} -body { + is withdrawn if toplevel is iconic} -constraints {failsOnUbuntu failsOnXQuartz} -body { toplevel .top raiseDelay wm iconify .top @@ -1912,7 +1903,7 @@ test wm-transient-4.2 {already mapped transient toplevel deleteWindows } -result {withdrawn 0} test wm-transient-4.3 {iconify/deiconify on the toplevel - does a withdraw/deiconify on the transient} -constraints {failsOnUbuntu failsOnXQuarz} -setup { + does a withdraw/deiconify on the transient} -constraints {failsOnUbuntu failsOnXQuartz} -setup { set results [list] } -body { toplevel .top @@ -2088,7 +2079,7 @@ test wm-transient-7.5 {Reassign transient, destroy transient} -body { deleteWindows } -test wm-transient-8.1 {transient to withdrawn window, Bug 1163496} -constraints {failsOnUbuntu failsOnXQuarz} -setup { +test wm-transient-8.1 {transient to withdrawn window, Bug 1163496} -constraints {failsOnUbuntu failsOnXQuartz} -setup { deleteWindows set result {} } -body { @@ -2165,7 +2156,7 @@ test wm-state-2.7 {state change before map} -body { } -cleanup { deleteWindows } -result {iconic} -test wm-state-2.8 {state change after map} -constraints {failsOnUbuntu failsOnXQuarz} -body { +test wm-state-2.8 {state change after map} -constraints {failsOnUbuntu failsOnXQuartz} -body { toplevel .t update wm state .t iconic @@ -2173,7 +2164,7 @@ test wm-state-2.8 {state change after map} -constraints {failsOnUbuntu failsOnXQ } -cleanup { deleteWindows } -result {iconic} -test wm-state-2.9 {state change after map} -constraints {failsOnUbuntu failsOnXQuarz} -body { +test wm-state-2.9 {state change after map} -constraints {failsOnUbuntu failsOnXQuartz} -body { toplevel .t update wm iconify .t diff --git a/win/rules.vc b/win/rules.vc index b1bb93b..0b47765 100644 --- a/win/rules.vc +++ b/win/rules.vc @@ -24,7 +24,7 @@ _RULES_VC = 1 # For modifications that are not backward-compatible, you *must* change
# the major version.
RULES_VERSION_MAJOR = 1
-RULES_VERSION_MINOR = 14
+RULES_VERSION_MINOR = 15
# The PROJECT macro must be defined by parent makefile.
!if "$(PROJECT)" == ""
@@ -1641,7 +1641,7 @@ default-target: $(DEFAULT_BUILD_TARGET) !if $(MULTIPLATFORM_INSTALL)
default-pkgindex:
- @echo if {[package vsatisfies [package provide Tcl] 9.0-]} { > $(OUT_DIR)\pkgIndex.tcl
+ @echo if {[package vsatisfies [package provide Tcl] 9.0]} { > $(OUT_DIR)\pkgIndex.tcl
@echo package ifneeded $(PRJ_PACKAGE_TCLNAME) $(DOTVERSION) \
[list load [file join $$dir $(PLATFORM_IDENTIFY) $(PRJLIBNAME9)]] >> $(OUT_DIR)\pkgIndex.tcl
@echo } else { >> $(OUT_DIR)\pkgIndex.tcl
@@ -1650,7 +1650,7 @@ default-pkgindex: @echo } >> $(OUT_DIR)\pkgIndex.tcl
!else
default-pkgindex:
- @echo if {[package vsatisfies [package provide Tcl] 9.0-]} { > $(OUT_DIR)\pkgIndex.tcl
+ @echo if {[package vsatisfies [package provide Tcl] 9.0]} { > $(OUT_DIR)\pkgIndex.tcl
@echo package ifneeded $(PRJ_PACKAGE_TCLNAME) $(DOTVERSION) \
[list load [file join $$dir $(PRJLIBNAME9)]] >> $(OUT_DIR)\pkgIndex.tcl
@echo } else { >> $(OUT_DIR)\pkgIndex.tcl
@@ -1690,6 +1690,7 @@ default-install-libraries: default-install-scripts default-install-scripts: $(OUT_DIR)\pkgIndex.tcl
@echo Installing libraries to '$(SCRIPT_INSTALL_DIR)'
+ @if not exist "$(SCRIPT_INSTALL_DIR)" mkdir "$(SCRIPT_INSTALL_DIR)"
@if exist $(LIBDIR) $(CPY) $(LIBDIR)\*.tcl "$(SCRIPT_INSTALL_DIR)"
@echo Installing package index in '$(SCRIPT_INSTALL_DIR)'
@$(CPY) $(OUT_DIR)\pkgIndex.tcl $(SCRIPT_INSTALL_DIR)
diff --git a/win/targets.vc b/win/targets.vc index 077e8f7..08f8441 100644 --- a/win/targets.vc +++ b/win/targets.vc @@ -53,6 +53,7 @@ default-install: default-install-stubs default-install: default-install-headers
default-install-headers:
@echo Installing headers to '$(INCLUDE_INSTALL_DIR)'
+ @if not exist "$(INCLUDE_INSTALL_DIR)" $(MKDIR) "$(INCLUDE_INSTALL_DIR)"
@for %f in ($(PRJ_HEADERS_PUBLIC)) do @$(COPY) %f "$(INCLUDE_INSTALL_DIR)"
!endif
diff --git a/win/tkWinDialog.c b/win/tkWinDialog.c index 6332f66..264c3ec 100644 --- a/win/tkWinDialog.c +++ b/win/tkWinDialog.c @@ -153,7 +153,8 @@ typedef struct { typedef struct OFNData { Tcl_Interp *interp; /* Interp, used only if debug is turned on, - * for setting the "tk_dialog" variable. */ + * for setting the variable + * "::tk::test::dialog::testDialog". */ int dynFileBufferSize; /* Dynamic filename buffer size, stored to * avoid shrinking and expanding the buffer * when selection changes */ @@ -588,7 +589,7 @@ static int MakeFilter(Tcl_Interp *interp, Tcl_Obj *valuePtr, static UINT APIENTRY OFNHookProc(HWND hdlg, UINT uMsg, WPARAM wParam, LPARAM lParam); static LRESULT CALLBACK MsgBoxCBTProc(int nCode, WPARAM wParam, LPARAM lParam); -static void SetTkDialog(void *clientData); +static void SetTestDialog(void *clientData); static const char *ConvertExternalFilename(LPCWSTR, Tcl_DString *); /* @@ -646,9 +647,9 @@ EatSpuriousMessageBugFix(void) * TkWinDialogDebug -- * * Function to turn on/off debugging support for common dialogs under - * windows. The variable "tk_debug" is set to the identifier of the - * dialog window when the modal dialog window pops up and it is safe to - * send messages to the dialog. + * windows. The variable "::tk::test::dialog::testDialog" is set to the + * identifier of the dialog window when the modal dialog window pops up + * and it is safe to send messages to the dialog. * * Results: * None. @@ -872,7 +873,7 @@ ColorDlgHookProc( } if (tsdPtr->debugFlag) { tsdPtr->debugInterp = (Tcl_Interp *) ccPtr->lpTemplateName; - Tcl_DoWhenIdle(SetTkDialog, hDlg); + Tcl_DoWhenIdle(SetTestDialog, hDlg); } return TRUE; } @@ -1839,7 +1840,7 @@ GetFileName( * * OFNHookProc -- * - * Dialog box hook function. This is used to set the "tk_dialog" + * Dialog box hook function. This is used to set the "::tk::test::dialog::testDialog" * variable for test/debugging when the dialog is ready to receive * messages. When multiple file selection is enabled this function * is used to process the list of names. @@ -1985,7 +1986,7 @@ OFNHookProc( if (ofnData->interp != NULL) { hdlg = GetParent(hdlg); tsdPtr->debugInterp = ofnData->interp; - Tcl_DoWhenIdle(SetTkDialog, hdlg); + Tcl_DoWhenIdle(SetTestDialog, hdlg); } TkWinSetUserData(hdlg, NULL); } @@ -2572,7 +2573,7 @@ ChooseDirectoryValidateProc( if (tsdPtr->debugFlag) { tsdPtr->debugInterp = (Tcl_Interp *) chooseDirSharedData->interp; - Tcl_DoWhenIdle(SetTkDialog, hwnd); + Tcl_DoWhenIdle(SetTestDialog, hwnd); } chooseDirSharedData->retDir[0] = '\0'; switch (message) { @@ -2947,18 +2948,19 @@ MsgBoxCBTProc( /* * ---------------------------------------------------------------------- * - * SetTkDialog -- + * SetTestDialog -- * - * Records the HWND for a native dialog in the 'tk_dialog' variable so - * that the test-suite can operate on the correct dialog window. Use of - * this is enabled when a test program calls TkWinDialogDebug by calling - * the test command 'tkwinevent debug 1'. + * Records the HWND for a native dialog in the variable + * "::tk::test::dialog::testDialog" so that the test-suite can operate + * on the correct dialog window. Use of this is enabled when a test + * program calls TkWinDialogDebug by calling the test command + * 'testwinevent debug 1'. * * ---------------------------------------------------------------------- */ static void -SetTkDialog( +SetTestDialog( void *clientData) { ThreadSpecificData *tsdPtr = (ThreadSpecificData *) @@ -2966,7 +2968,8 @@ SetTkDialog( char buf[32]; snprintf(buf, sizeof(buf), "0x%" TCL_Z_MODIFIER "x", (size_t)clientData); - Tcl_SetVar2(tsdPtr->debugInterp, "tk_dialog", NULL, buf, TCL_GLOBAL_ONLY); + Tcl_SetVar2(tsdPtr->debugInterp, "::tk::test::dialog::testDialog", NULL, + buf, TCL_GLOBAL_ONLY); } /* @@ -3100,7 +3103,7 @@ HookProc( phd->hwnd = hwndDlg; if (tsdPtr->debugFlag) { tsdPtr->debugInterp = phd->interp; - Tcl_DoWhenIdle(SetTkDialog, hwndDlg); + Tcl_DoWhenIdle(SetTestDialog, hwndDlg); } if (phd->titleObj != NULL) { Tcl_DString title; diff --git a/win/tkWinGDI.c b/win/tkWinGDI.c index bcc7796..6290979 100644 --- a/win/tkWinGDI.c +++ b/win/tkWinGDI.c @@ -57,7 +57,7 @@ static int GdiGetColor(Tcl_Obj *nameObj, COLORREF *color); */ static int GdiMakeLogFont(Tcl_Interp *interp, const char *str, LOGFONTW *lf, HDC hDC); -static int GdiMakePen(Tcl_Interp *interp, int width, +static int GdiMakePen(Tcl_Interp *interp, double dwidth, int dashstyle, const char *dashstyledata, int capstyle, int joinstyle, int stipplestyle, const char *stippledata, @@ -144,7 +144,7 @@ static const struct gdi_command { static int GdiArc( TCL_UNUSED(void *), Tcl_Interp *interp, - int argc, + int objc, Tcl_Obj *const *objv) { static const char usage_message[] = @@ -153,12 +153,12 @@ static int GdiArc( "-fill color -outline color " "-width dimension -dash dashrule " "-outlinestipple ignored -stipple ignored\n" ; - int x1, y1, x2, y2; + double x1, y1, x2, y2; int xr0, yr0, xr1, yr1; HDC hDC; double extent = 0.0, start = 0.0; DrawFunc drawfunc; - int width = 0; + double width = 0.0; HPEN hPen; COLORREF linecolor = 0, fillcolor = BS_NULL; int dolinecolor = 0, dofillcolor = 0; @@ -171,23 +171,23 @@ static int GdiArc( drawfunc = Pie; /* Verrrrrry simple for now.... */ - if (argc < 6) { + if (objc < 6) { Tcl_AppendResult(interp, usage_message, (char *)NULL); return TCL_ERROR; } hDC = printDC; - if ((Tcl_GetIntFromObj(interp, objv[2], &x1) != TCL_OK) - || (Tcl_GetIntFromObj(interp, objv[3], &y1) != TCL_OK) - || (Tcl_GetIntFromObj(interp, objv[4], &x2) != TCL_OK) - || (Tcl_GetIntFromObj(interp, objv[5], &y2) != TCL_OK)) { + if ((Tcl_GetDoubleFromObj(interp, objv[2], &x1) != TCL_OK) + || (Tcl_GetDoubleFromObj(interp, objv[3], &y1) != TCL_OK) + || (Tcl_GetDoubleFromObj(interp, objv[4], &x2) != TCL_OK) + || (Tcl_GetDoubleFromObj(interp, objv[5], &y2) != TCL_OK)) { return TCL_ERROR; } - argc -= 6; + objc -= 6; objv += 6; - while (argc >= 2) { + while (objc >= 2) { if (strcmp(Tcl_GetString(objv[0]), "-extent") == 0) { extent = atof(Tcl_GetString(objv[1])); } else if (strcmp(Tcl_GetString(objv[0]), "-start") == 0) { @@ -214,7 +214,7 @@ static int GdiArc( } else if (strcmp(Tcl_GetString(objv[0]), "-stipple") == 0) { /* ignored */ } else if (strcmp(Tcl_GetString(objv[0]), "-width") == 0) { - if (Tcl_GetIntFromObj(interp, objv[1], &width)) { + if (Tcl_GetDoubleFromObj(interp, objv[1], &width)) { return TCL_ERROR; } } else if (strcmp(Tcl_GetString(objv[0]), "-dash") == 0) { @@ -227,7 +227,7 @@ static int GdiArc( Tcl_AppendResult(interp, usage_message, (char *)NULL); return TCL_ERROR; } - argc -= 2; + objc -= 2; objv += 2; } xr0 = xr1 = (x1 + x2) / 2; @@ -368,7 +368,7 @@ static int GdiImage( static int GdiPhoto( TCL_UNUSED(void *), Tcl_Interp *interp, - int argc, + int objc, Tcl_Obj *const *objv) { static const char usage_message[] = @@ -392,7 +392,7 @@ static int GdiPhoto( */ /* HDC is required. */ - if (argc < 2) { + if (objc < 2) { Tcl_AppendResult(interp, usage_message, (char *)NULL); return TCL_ERROR; } @@ -412,13 +412,13 @@ static int GdiPhoto( } /* Parse the command line arguments. */ - for (j = 2; j < argc; j++) { + for (j = 2; j < objc; j++) { if (strcmp(Tcl_GetString(objv[j]), "-destination") == 0) { double x, y, w, h; int count = 0; char dummy; - if (j < argc) { + if (j < objc) { count = sscanf(Tcl_GetString(objv[++j]), "%lf%lf%lf%lf%c", &x, &y, &w, &h, &dummy); } @@ -563,7 +563,7 @@ static int Bezierize( POINT* polypoints, int npoly, int nStep, - POINT* bpointptr) + POINT** bpointptr) { /* First, translate my points into a list of doubles. */ double *inPointList, *outPointList; @@ -606,7 +606,7 @@ static int Bezierize( bpoints[n].y = (long)outPointList[2*n + 1]; } ckfree(outPointList); - *bpointptr = *bpoints; + *bpointptr = bpoints; return nbpoints; } @@ -626,7 +626,7 @@ static int Bezierize( static int GdiLine( TCL_UNUSED(void *), Tcl_Interp *interp, - int argc, + int objc, Tcl_Obj *const *objv) { static const char usage_message[] = @@ -646,7 +646,7 @@ static int GdiLine( LOGBRUSH lbrush; HBRUSH hBrush = NULL; - int width = 0; + double width = 0.0; COLORREF linecolor = 0; int dolinecolor = 0; int dosmooth = 0; @@ -657,36 +657,41 @@ static int GdiLine( int dodash = 0; const char *dashdata = 0; + double p1x, p1y, p2x, p2y; arrowshape[0] = 8; arrowshape[1] = 10; arrowshape[2] = 3; /* Verrrrrry simple for now.... */ - if (argc < 6) { + if (objc < 6) { Tcl_AppendResult(interp, usage_message, (char *)NULL); return TCL_ERROR; } hDC = printDC; - polypoints = (POINT *)attemptckalloc((argc - 1) * sizeof(POINT)); + polypoints = (POINT *)attemptckalloc((objc - 1) * sizeof(POINT)); if (polypoints == 0) { Tcl_AppendResult(interp, "Out of memory in GdiLine", (char *)NULL); return TCL_ERROR; } - if ((Tcl_GetIntFromObj(interp, objv[2], (int *)&polypoints[0].x) != TCL_OK) - || (Tcl_GetIntFromObj(interp, objv[3], (int *)&polypoints[0].y) != TCL_OK) - || (Tcl_GetIntFromObj(interp, objv[4], (int *)&polypoints[1].x) != TCL_OK) - || (Tcl_GetIntFromObj(interp, objv[5], (int *)&polypoints[1].y) != TCL_OK) + if ((Tcl_GetDoubleFromObj(interp, objv[2], &p1x) != TCL_OK) + || (Tcl_GetDoubleFromObj(interp, objv[3], &p1y) != TCL_OK) + || (Tcl_GetDoubleFromObj(interp, objv[4], &p2x) != TCL_OK) + || (Tcl_GetDoubleFromObj(interp, objv[5], &p2y) != TCL_OK) ) { return TCL_ERROR; } - argc -= 6; + polypoints[0].x = floor(p1x+0.5); + polypoints[0].y = floor(p1y+0.5); + polypoints[1].x = floor(p2x+0.5); + polypoints[1].y = floor(p2y+0.5); + objc -= 6; objv += 6; npoly = 2; - while (argc >= 2) { + while (objc >= 2) { /* Check for a number. */ x = strtoul(Tcl_GetString(objv[0]), &strend, 0); if (strend > Tcl_GetString(objv[0])) { @@ -697,7 +702,7 @@ static int GdiLine( polypoints[npoly].x = x; polypoints[npoly].y = y; npoly++; - argc -= 2; + objc -= 2; objv += 2; } else { /* Only one number... Assume a usage error. */ @@ -717,7 +722,7 @@ static int GdiLine( doarrow = 1; } objv += 2; - argc -= 2; + objc -= 2; } else if (strcmp(Tcl_GetString(*objv), "-arrowshape") == 0) { /* List of 3 numbers--set arrowshape array. */ int a1, a2, a3; @@ -732,19 +737,19 @@ static int GdiLine( /* Else the argument was bad. */ objv += 2; - argc -= 2; + objc -= 2; } else if (strcmp(Tcl_GetString(*objv), "-capstyle") == 0) { objv += 2; - argc -= 2; + objc -= 2; } else if (strcmp(Tcl_GetString(*objv), "-fill") == 0) { if (GdiGetColor(objv[1], &linecolor)) { dolinecolor = 1; } objv += 2; - argc -= 2; + objc -= 2; } else if (strcmp(Tcl_GetString(*objv), "-joinstyle") == 0) { objv += 2; - argc -= 2; + objc -= 2; } else if (strcmp(Tcl_GetString(*objv), "-smooth") == 0) { /* Argument is true/false or 1/0 or bezier. */ if (Tcl_GetString(objv[1])) { @@ -759,35 +764,35 @@ static int GdiLine( break; } objv += 2; - argc -= 2; + objc -= 2; } } else if (strcmp(Tcl_GetString(*objv), "-splinesteps") == 0) { if (Tcl_GetIntFromObj(interp, objv[1], &nStep) != TCL_OK) { return TCL_ERROR; } objv += 2; - argc -= 2; + objc -= 2; } else if (strcmp(Tcl_GetString(*objv), "-dash") == 0) { if (Tcl_GetString(objv[1])) { dodash = 1; dashdata = Tcl_GetString(objv[1]); } objv += 2; - argc -= 2; + objc -= 2; } else if (strcmp(Tcl_GetString(*objv), "-dashoffset") == 0) { objv += 2; - argc -= 2; + objc -= 2; } else if (strcmp(Tcl_GetString(*objv), "-stipple") == 0) { objv += 2; - argc -= 2; + objc -= 2; } else if (strcmp(Tcl_GetString(*objv), "-width") == 0) { - if (Tcl_GetIntFromObj(interp, objv[1], &width) != TCL_OK) { + if (Tcl_GetDoubleFromObj(interp, objv[1], &width) != TCL_OK) { return TCL_ERROR; } objv += 2; - argc -= 2; + objc -= 2; } else { /* It's an unknown argument!. */ - argc--; + objc--; objv++; } /* Check for arguments @@ -806,15 +811,15 @@ static int GdiLine( if (dosmooth) { /* Use PolyBezier. */ int nbpoints; - POINT *bpoints = 0; + POINT *bpoints = NULL; - nbpoints = Bezierize(polypoints,npoly,nStep,bpoints); + nbpoints = Bezierize(polypoints,npoly,nStep,&bpoints); if (nbpoints > 0) { Polyline(hDC, bpoints, nbpoints); } else { Polyline(hDC, polypoints, npoly); /* Out of memory? Just draw a regular line. */ } - if (bpoints != 0) { + if (bpoints) { ckfree(bpoints); } } else { @@ -927,16 +932,16 @@ static int GdiLine( static int GdiOval( TCL_UNUSED(void *), Tcl_Interp *interp, - int argc, + int objc, Tcl_Obj *const *objv) { static const char usage_message[] = "::tk::print::_gdi oval hdc x1 y1 x2 y2 -fill color -outline color " "-stipple bitmap -width linewid"; - int x1, y1, x2, y2; + double x1, y1, x2, y2; HDC hDC; HPEN hPen; - int width = 0; + double width = 0.0; COLORREF linecolor = 0, fillcolor = 0; int dolinecolor = 0, dofillcolor = 0; HBRUSH hBrush = NULL; @@ -947,33 +952,33 @@ static int GdiOval( const char *dashdata = 0; /* Verrrrrry simple for now.... */ - if (argc < 6) { + if (objc < 6) { Tcl_AppendResult(interp, usage_message, (char *)NULL); return TCL_ERROR; } hDC = printDC; - if ((Tcl_GetIntFromObj(interp, objv[2], &x1) != TCL_OK) - || (Tcl_GetIntFromObj(interp, objv[3], &y1) != TCL_OK) - || (Tcl_GetIntFromObj(interp, objv[4], &x2) != TCL_OK) - || (Tcl_GetIntFromObj(interp, objv[5], &y2) != TCL_OK)) { + if ((Tcl_GetDoubleFromObj(interp, objv[2], &x1) != TCL_OK) + || (Tcl_GetDoubleFromObj(interp, objv[3], &y1) != TCL_OK) + || (Tcl_GetDoubleFromObj(interp, objv[4], &x2) != TCL_OK) + || (Tcl_GetDoubleFromObj(interp, objv[5], &y2) != TCL_OK)) { return TCL_ERROR; } if (x1 > x2) { - int x3 = x1; + double x3 = x1; x1 = x2; x2 = x3; } if (y1 > y2) { - int y3 = y1; + double y3 = y1; y1 = y2; y2 = y3; } - argc -= 6; + objc -= 6; objv += 6; - while (argc > 0) { + while (objc > 0) { /* Now handle any other arguments that occur. */ if (strcmp(Tcl_GetString(objv[0]), "-fill") == 0) { if (Tcl_GetString(objv[1]) && GdiGetColor(objv[1], &fillcolor)) { @@ -987,7 +992,7 @@ static int GdiOval( /* Not actually implemented */ } else if (strcmp(Tcl_GetString(objv[0]), "-width") == 0) { if (Tcl_GetString(objv[1])) { - if (Tcl_GetIntFromObj(interp, objv[1], &width) != TCL_OK) { + if (Tcl_GetDoubleFromObj(interp, objv[1], &width) != TCL_OK) { return TCL_ERROR; } } @@ -998,7 +1003,7 @@ static int GdiOval( } } objv += 2; - argc -= 2; + objc -= 2; } if (dofillcolor) { @@ -1016,7 +1021,7 @@ static int GdiOval( * earlier documentation, canvas rectangle does not. Thus, add 1 to right * and lower bounds to get appropriate behavior. */ - Ellipse(hDC, x1, y1, x2+1, y2+1); + Ellipse(hDC, floor(x1+0.5), floor(y1+0.5), floor(x2+1.5), floor(y2+1.5)); if (width || dolinecolor) { GdiFreePen(interp, hDC, hPen); @@ -1046,7 +1051,7 @@ static int GdiOval( static int GdiPolygon( TCL_UNUSED(void *), Tcl_Interp *interp, - int argc, + int objc, Tcl_Obj *const *objv) { static const char usage_message[] = @@ -1062,7 +1067,7 @@ static int GdiPolygon( int x, y; HDC hDC; HPEN hPen; - int width = 0; + double width = 0.0; COLORREF linecolor = 0, fillcolor = BS_NULL; int dolinecolor = 0, dofillcolor = 0; LOGBRUSH lbrush; @@ -1071,32 +1076,37 @@ static int GdiPolygon( int dodash = 0; const char *dashdata = 0; + double p1x, p1y, p2x, p2y; /* Verrrrrry simple for now.... */ - if (argc < 6) { + if (objc < 6) { Tcl_AppendResult(interp, usage_message, (char *)NULL); return TCL_ERROR; } hDC = printDC; - polypoints = (POINT *)attemptckalloc((argc - 1) * sizeof(POINT)); + polypoints = (POINT *)attemptckalloc((objc - 1) * sizeof(POINT)); if (polypoints == 0) { /* TODO: unreachable */ Tcl_AppendResult(interp, "Out of memory in GdiLine", (char *)NULL); return TCL_ERROR; } - if ((Tcl_GetIntFromObj(interp, objv[2], (int *)&polypoints[0].x) != TCL_OK) - || (Tcl_GetIntFromObj(interp, objv[3], (int *)&polypoints[0].y) != TCL_OK) - || (Tcl_GetIntFromObj(interp, objv[4], (int *)&polypoints[1].x) != TCL_OK) - || (Tcl_GetIntFromObj(interp, objv[5], (int *)&polypoints[1].y) != TCL_OK)) { + if ((Tcl_GetDoubleFromObj(interp, objv[2], &p1x) != TCL_OK) + || (Tcl_GetDoubleFromObj(interp, objv[3], &p1y) != TCL_OK) + || (Tcl_GetDoubleFromObj(interp, objv[4], &p2x) != TCL_OK) + || (Tcl_GetDoubleFromObj(interp, objv[5], &p2y) != TCL_OK)) { return TCL_ERROR; } - argc -= 6; + polypoints[0].x = floor(p1x + 0.5); + polypoints[0].y = floor(p1y + 0.5); + polypoints[1].x = floor(p2x + 0.5); + polypoints[1].y = floor(p2y + 0.5); + objc -= 6; objv += 6; npoly = 2; - while (argc >= 2) { + while (objc >= 2) { /* Check for a number */ x = strtoul(Tcl_GetString(objv[0]), &strend, 0); if (strend > Tcl_GetString(objv[0])) { @@ -1107,7 +1117,7 @@ static int GdiPolygon( polypoints[npoly].x = x; polypoints[npoly].y = y; npoly++; - argc -= 2; + objc -= 2; objv += 2; } else { /* Only one number... Assume a usage error. */ @@ -1151,7 +1161,7 @@ static int GdiPolygon( /* Not supported */ } else if (strcmp(Tcl_GetString(objv[0]), "-width") == 0) { if (Tcl_GetString(objv[1])) { - if (Tcl_GetIntFromObj(interp, objv[1], &width) != TCL_OK) { + if (Tcl_GetDoubleFromObj(interp, objv[1], &width) != TCL_OK) { return TCL_ERROR; } } @@ -1161,7 +1171,7 @@ static int GdiPolygon( dashdata = Tcl_GetString(objv[1]); } } - argc -= 2; + objc -= 2; objv += 2; } } @@ -1179,14 +1189,15 @@ static int GdiPolygon( if (dosmooth) { int nbpoints; - POINT *bpoints = 0; - nbpoints = Bezierize(polypoints,npoly,nStep,bpoints); + POINT *bpoints = NULL; + + nbpoints = Bezierize(polypoints, npoly, nStep, &bpoints); if (nbpoints > 0) { Polygon(hDC, bpoints, nbpoints); } else { Polygon(hDC, polypoints, npoly); } - if (bpoints != 0) { + if (bpoints) { ckfree(bpoints); } } else { @@ -1222,7 +1233,7 @@ static int GdiPolygon( static int GdiRectangle( TCL_UNUSED(void *), Tcl_Interp *interp, - int argc, + int objc, Tcl_Obj *const *objv) { static const char usage_message[] = @@ -1230,10 +1241,10 @@ static int GdiRectangle( "-fill color -outline color " "-stipple bitmap -width linewid"; - int x1, y1, x2, y2; + double x1, y1, x2, y2; HDC hDC; HPEN hPen; - int width = 0; + double width = 0.0; COLORREF linecolor = 0, fillcolor = BS_NULL; int dolinecolor = 0, dofillcolor = 0; LOGBRUSH lbrush; @@ -1244,34 +1255,34 @@ static int GdiRectangle( const char *dashdata = 0; /* Verrrrrry simple for now.... */ - if (argc < 6) { + if (objc < 6) { Tcl_AppendResult(interp, usage_message, (char *)NULL); return TCL_ERROR; } hDC = printDC; - if ((Tcl_GetIntFromObj(interp, objv[2], &x1) != TCL_OK) - || (Tcl_GetIntFromObj(interp, objv[3], &y1) != TCL_OK) - || (Tcl_GetIntFromObj(interp, objv[4], &x2) != TCL_OK) - || (Tcl_GetIntFromObj(interp, objv[5], &y2) != TCL_OK)) { + if ((Tcl_GetDoubleFromObj(interp, objv[2], &x1) != TCL_OK) + || (Tcl_GetDoubleFromObj(interp, objv[3], &y1) != TCL_OK) + || (Tcl_GetDoubleFromObj(interp, objv[4], &x2) != TCL_OK) + || (Tcl_GetDoubleFromObj(interp, objv[5], &y2) != TCL_OK)) { return TCL_ERROR; } if (x1 > x2) { - int x3 = x1; + double x3 = x1; x1 = x2; x2 = x3; } if (y1 > y2) { - int y3 = y1; + double y3 = y1; y1 = y2; y2 = y3; } - argc -= 6; + objc -= 6; objv += 6; /* Now handle any other arguments that occur. */ - while (argc > 1) { + while (objc > 1) { if (strcmp(Tcl_GetString(objv[0]), "-fill") == 0) { if (Tcl_GetString(objv[1]) && GdiGetColor(objv[1], &fillcolor)) { dofillcolor = 1; @@ -1284,7 +1295,7 @@ static int GdiRectangle( /* Not supported; ignored */ } else if (strcmp(Tcl_GetString(objv[0]), "-width") == 0) { if (Tcl_GetString(objv[1])) { - if (Tcl_GetIntFromObj(interp, objv[1], &width) != TCL_OK) { + if (Tcl_GetDoubleFromObj(interp, objv[1], &width) != TCL_OK) { return TCL_ERROR; } } @@ -1295,7 +1306,7 @@ static int GdiRectangle( } } - argc -= 2; + objc -= 2; objv += 2; } @@ -1320,7 +1331,7 @@ static int GdiRectangle( * earlier documentation, canvas rectangle does not. Thus, add 1 to * right and lower bounds to get appropriate behavior. */ - Rectangle(hDC, x1, y1, x2+1, y2+1); + Rectangle(hDC, floor(x1+0.5), floor(y1+0.5), floor(x2+1.5), floor(y2+1.5)); if (width || dolinecolor) { GdiFreePen(interp, hDC, hPen); @@ -1352,7 +1363,7 @@ static int GdiRectangle( static int GdiCharWidths( TCL_UNUSED(void *), Tcl_Interp *interp, - int argc, + int objc, Tcl_Obj *const *objv) { static const char usage_message[] = @@ -1374,19 +1385,19 @@ static int GdiCharWidths( int widths[256]; int retval; - if (argc < 2) { + if (objc < 2) { Tcl_AppendResult(interp, usage_message, (char *)NULL); return TCL_ERROR; } hDC = printDC; - argc -= 2; + objc -= 2; objv += 2; - while (argc > 0) { + while (objc > 0) { if (strcmp(Tcl_GetString(objv[0]), "-font") == 0) { - argc--; + objc--; objv++; if (GdiMakeLogFont(interp, Tcl_GetString(objv[0]), &lf, hDC)) { if ((hfont = CreateFontIndirectW(&lf)) != NULL) { @@ -1397,13 +1408,13 @@ static int GdiCharWidths( /* Else leave the font alone!. */ } else if (strcmp(Tcl_GetString(objv[0]), "-array") == 0) { objv++; - argc--; - if (argc > 0) { + objc--; + if (objc > 0) { aryvarname = Tcl_GetString(objv[0]); } } objv++; - argc--; + objc--; } /* Now, get the widths using the correct function for font type. */ @@ -1467,7 +1478,7 @@ static int GdiCharWidths( int GdiText( TCL_UNUSED(void *), Tcl_Interp *interp, - int argc, + int objc, Tcl_Obj *const *objv) { static const char usage_message[] = @@ -1478,7 +1489,7 @@ int GdiText( "-single -backfill"; HDC hDC; - int x, y; + double x, y; const char *string = 0; RECT sizerect; UINT format_flags = DT_EXPANDTABS|DT_NOPREFIX; /* Like the canvas. */ @@ -1496,7 +1507,7 @@ int GdiText( WCHAR *wstring; Tcl_DString tds; - if (argc < 4) { + if (objc < 4) { Tcl_AppendResult(interp, usage_message, (char *)NULL); return TCL_ERROR; } @@ -1505,27 +1516,27 @@ int GdiText( hDC = printDC; - if ((Tcl_GetIntFromObj(interp, objv[2], &x) != TCL_OK) - || (Tcl_GetIntFromObj(interp, objv[3], &y) != TCL_OK)) { + if ((Tcl_GetDoubleFromObj(interp, objv[2], &x) != TCL_OK) + || (Tcl_GetDoubleFromObj(interp, objv[3], &y) != TCL_OK)) { return TCL_ERROR; } - argc -= 4; + objc -= 4; objv += 4; - sizerect.left = sizerect.right = x; - sizerect.top = sizerect.bottom = y; + sizerect.left = sizerect.right = floor(x+0.5); + sizerect.top = sizerect.bottom = floor(y+0.5); - while (argc > 0) { + while (objc > 0) { if (strcmp(Tcl_GetString(objv[0]), "-anchor") == 0) { - argc--; + objc--; objv++; - if (argc > 0) { + if (objc > 0) { Tk_GetAnchor(interp, Tcl_GetString(objv[0]), &anchor); } } else if (strcmp(Tcl_GetString(objv[0]), "-justify") == 0) { - argc--; + objc--; objv++; - if (argc > 0) { + if (objc > 0) { if (strcmp(Tcl_GetString(objv[0]), "left") == 0) { format_flags |= DT_LEFT; } else if (strcmp(Tcl_GetString(objv[0]), "center") == 0) { @@ -1535,13 +1546,13 @@ int GdiText( } } } else if (strcmp(Tcl_GetString(objv[0]), "-text") == 0) { - argc--; + objc--; objv++; - if (argc > 0) { + if (objc > 0) { string = Tcl_GetString(objv[0]); } } else if (strcmp(Tcl_GetString(objv[0]), "-font") == 0) { - argc--; + objc--; objv++; if (GdiMakeLogFont(interp, Tcl_GetString(objv[0]), &lf, hDC)) { if ((hfont = CreateFontIndirectW(&lf)) != NULL) { @@ -1551,20 +1562,20 @@ int GdiText( } /* Else leave the font alone! */ } else if (strcmp(Tcl_GetString(objv[0]), "-stipple") == 0) { - argc--; + objc--; objv++; /* Not implemented yet. */ } else if (strcmp(Tcl_GetString(objv[0]), "-fill") == 0) { - argc--; + objc--; objv++; /* Get text color. */ if (GdiGetColor(objv[0], &textcolor)) { dotextcolor = 1; } } else if (strcmp(Tcl_GetString(objv[0]), "-width") == 0) { - argc--; + objc--; objv++; - if (argc > 0) { + if (objc > 0) { int value; if (Tcl_GetIntFromObj(interp, objv[0], &value) != TCL_OK) { return TCL_ERROR; @@ -1579,7 +1590,7 @@ int GdiText( dobgmode = 1; } - argc--; + objc--; objv++; } @@ -1822,7 +1833,7 @@ static const char *GdiModeToName( static int GdiMap( TCL_UNUSED(void *), Tcl_Interp *interp, - int argc, + int objc, Tcl_Obj *const *objv) { static const char usage_message[] = @@ -1846,7 +1857,7 @@ static int GdiMap( int use_mode = 0; /* Required parameter: HDC for printer. */ - if (argc < 2) { + if (objc < 2) { Tcl_AppendResult(interp, usage_message, (char *)NULL); return TCL_ERROR; } @@ -1860,14 +1871,14 @@ static int GdiMap( } /* Parse remaining arguments. */ - for (argno = 2; argno < argc; argno++) { + for (argno = 2; argno < objc; argno++) { if (strcmp(Tcl_GetString(objv[argno]), "-default") == 0) { vextent.cx = vextent.cy = wextent.cx = wextent.cy = 1; vorigin.x = vorigin.y = worigin.x = worigin.y = 0; mapmode = MM_TEXT; use_default = 1; } else if (strcmp(Tcl_GetString(objv[argno]), "-mode") == 0) { - if (argno + 1 >= argc) { + if (argno + 1 >= objc) { need_usage = 1; } else { mapmode = GdiNameToMode(Tcl_GetString(objv[argno + 1])); @@ -1875,7 +1886,7 @@ static int GdiMap( argno++; } } else if (strcmp(Tcl_GetString(objv[argno]), "-offset") == 0) { - if (argno + 1 >= argc) { + if (argno + 1 >= objc) { need_usage = 1; } else { /* It would be nice if this parsed units as well.... */ @@ -1888,7 +1899,7 @@ static int GdiMap( argno++; } } else if (strcmp(Tcl_GetString(objv[argno]), "-logical") == 0) { - if (argno + 1 >= argc) { + if (argno + 1 >= objc) { need_usage = 1; } else { int count; @@ -1910,7 +1921,7 @@ static int GdiMap( } } } else if (strcmp(Tcl_GetString(objv[argno]), "-physical") == 0) { - if (argno + 1 >= argc) { + if (argno + 1 >= objc) { need_usage = 1; } else { int count; @@ -2005,7 +2016,7 @@ static int GdiMap( static int GdiCopyBits( TCL_UNUSED(void *), Tcl_Interp *interp, - int argc, + int objc, Tcl_Obj *const *objv) { /* Goal: get the Tk_Window from the top-level @@ -2067,7 +2078,7 @@ static int GdiCopyBits( * Parse the arguments. */ /* HDC is required. */ - if (argc < 2) { + if (objc < 2) { Tcl_AppendResult(interp, usage_message, (char *)NULL); return TCL_ERROR; } @@ -2085,7 +2096,7 @@ static int GdiCopyBits( } /* Loop through the remaining arguments. */ - for (k=2; k<argc; k++) { + for (k=2; k<objc; k++) { if (strcmp(Tcl_GetString(objv[k]), "-window") == 0) { if (Tcl_GetString(objv[k+1]) && Tcl_GetString(objv[k+1])[0] == '.') { do_window = 1; @@ -2653,7 +2664,7 @@ static int GdiMakeLogFont( static int GdiMakePen( Tcl_Interp *interp, - int width, + double dwidth, int dashstyle, const char *dashstyledata, TCL_UNUSED(int), /* Ignored for now. */ @@ -2678,7 +2689,7 @@ static int GdiMakePen( * after first failure) may suffice for working around this. The * ExtCreatePen is not supported at all under Win32. */ - + int width = floor(dwidth + 0.5); HPEN hPen; LOGBRUSH lBrush; DWORD pStyle = PS_SOLID; /* -dash should override*/ @@ -3634,6 +3645,24 @@ static int PrintSelectPrinter( } else { localDevmode = NULL; } + } else { + unsigned int errorcode = CommDlgExtendedError(); + + /* + * The user cancelled, or there was an error + * The code on the Tcl side checks if the variable + * ::tk::print::printer_name is defined to determine + * that a valid selection was made. + * So we better unset this here, unconditionally. + */ + Tcl_UnsetVar(interp, "::tk::print::printer_name", 0); + if (errorcode != 0) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf("print failed: error %04x", + errorcode)); + Tcl_SetErrorCode(interp, "TK", "PRINT", "DIALOG", (char*)NULL); + return TCL_ERROR; + } + return TCL_OK; } if (pd.hDevMode != NULL) { @@ -3641,27 +3670,30 @@ static int PrintSelectPrinter( } /* - * Store print properties and link variables so they can be accessed from + * Store print properties in variables so they can be accessed from * script level. */ if (localPrinterName != NULL) { - char* varlink1 = (char*)ckalloc(100 * sizeof(char)); - char** varlink2 = (char**)ckalloc(sizeof(char*)); - *varlink2 = varlink1; - WideCharToMultiByte(CP_UTF8, 0, localPrinterName, -1, varlink1, 0, NULL, NULL); - - Tcl_LinkVar(interp, "::tk::print::printer_name", varlink2, - TCL_LINK_STRING | TCL_LINK_READ_ONLY); - Tcl_LinkVar(interp, "::tk::print::copies", &copies, - TCL_LINK_INT | TCL_LINK_READ_ONLY); - Tcl_LinkVar(interp, "::tk::print::dpi_x", &dpi_x, - TCL_LINK_INT | TCL_LINK_READ_ONLY); - Tcl_LinkVar(interp, "::tk::print::dpi_y", &dpi_y, - TCL_LINK_INT | TCL_LINK_READ_ONLY); - Tcl_LinkVar(interp, "::tk::print::paper_width", &paper_width, - TCL_LINK_INT | TCL_LINK_READ_ONLY); - Tcl_LinkVar(interp, "::tk::print::paper_height", &paper_height, - TCL_LINK_INT | TCL_LINK_READ_ONLY); + char *prname; + int size_needed = WideCharToMultiByte(CP_UTF8, 0, localPrinterName, + -1, NULL, 0, NULL, NULL); + + prname = (char*)ckalloc(size_needed); + WideCharToMultiByte(CP_UTF8, 0, localPrinterName, -1, prname, + size_needed, NULL, NULL); + Tcl_SetVar2Ex(interp, "::tk::print::printer_name", NULL, + Tcl_NewStringObj(prname, size_needed - 1), 0); + Tcl_SetVar2Ex(interp, "::tk::print::copies", NULL, + Tcl_NewIntObj(copies), 0); + Tcl_SetVar2Ex(interp, "::tk::print::dpi_x", NULL, + Tcl_NewIntObj(dpi_x), 0); + Tcl_SetVar2Ex(interp, "::tk::print::dpi_y", NULL, + Tcl_NewIntObj(dpi_y), 0); + Tcl_SetVar2Ex(interp, "::tk::print::paper_width", NULL, + Tcl_NewIntObj(paper_width), 0); + Tcl_SetVar2Ex(interp, "::tk::print::paper_height", NULL, + Tcl_NewIntObj(paper_height), 0); + ckfree(prname); } return TCL_OK; diff --git a/win/tkWinInt.h b/win/tkWinInt.h index 93b98ca..36aa6a4 100644 --- a/win/tkWinInt.h +++ b/win/tkWinInt.h @@ -14,18 +14,20 @@ #ifndef _TKWININT #define _TKWININT -#ifndef _TKINT -#include "tkInt.h" -#endif - /* - * Include platform specific public interfaces. + * Include platform specific public interfaces as the very first step. This is + * necessary because definitions provided by subsequent header files depend on + * the interface versions defined in tkWin.h */ #ifndef _TKWIN #include "tkWin.h" #endif +#ifndef _TKINT +#include "tkInt.h" +#endif + /* * Define constants missing from older Win32 SDK header files. */ |