Tk Source Code

	set S(W) $S(-parent).$windowName
    }

    # Now build the dialog
    if {![winfo exists $S(W)]} {
	toplevel $S(W) -class TkFontDialog
	if {[package provide tcltest] ne {}} {
	    set ::tk_dialog $S(W)
	}
	wm withdraw $S(W)
	wm title $S(W) $S(-title)
	wm transient $S(W) [winfo toplevel $S(-parent)]

	set outer [::ttk::frame $S(W).outer -padding {7.5p 7.5p}]
	::tk::AmpWidget ::ttk::label $S(W).font -text [::msgcat::mc "&Font:"]

	    #First, we select the printer.
	    _selectprinter

	    #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]
		}
	}

	# _print_data
	# This function prints multiple-page files, using a line-oriented
	# function, taking advantage of knowing the character widths.
	# Arguments:
	# data -       Text data for printing

	    # For normal windows, this may be fine--but for a canvas, one
	    # wants the canvas dimensions, and not the WINDOW dimensions.
	    if {[winfo class $wid] eq "Canvas"} {
		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]
		} else {
		    set window_x [lindex $sc 2]
		    set window_y [lindex $sc 3]
		}
	    } else {
		set window_x [winfo width $wid]
		set window_y [winfo height $wid]

	    # at character level, not words, so we do it by ourselves.
	    # compute usable page width in inches
	    set pw [dict get {a4 8.27 legal 8.5 letter 8.5} $media]
	    set pw [expr {
		$pw - ($option(margin-left) + $option(margin-right)) / 72.0
	    }]
	    # set the wrap length at 98% of computed page width in chars
	    # the 9.8 constant is the product 10.0 (default cpi) * 0.95
	    set wl [expr {int( 9.8 * $pw / $tzoom )}]
	    set data [encoding convertto utf-8 [_wrapLines [$w get 1.0 end] $wl]]
	}

	# launch the job in the background
	after idle [namespace code \
	    [list cups print $option(printer) $data {*}$printargs]]

	} else {
	    systemDialog = win;
	}
	if (winPtr && Tk_IsMapped(winPtr)) {
	    GenerateActivateEvents(winPtr, true);
	}
    }












}

- (void) windowBoundsChanged: (NSNotification *) notification
{
#ifdef TK_MAC_DEBUG_NOTIFICATIONS
    TKLog(@"-[%@(%p) %s] %@", [self class], self, sel_getName(_cmd), notification);
#endif

    // the window needs to be updated.  That is the purpose of this method.

#ifdef TK_MAC_DEBUG_NOTIFICATIONS
    TKLog(@"-[%@(%p) %s] %@", [self class], self, sel_getName(_cmd), notification);
#endif
    NSWindow *w = [notification object];
    TkWindow *winPtr = TkMacOSXGetTkWindow(w);





    if (winPtr && winPtr->wmInfoPtr->hints.initial_state != IconicState) {
	winPtr->wmInfoPtr->hints.initial_state = IconicState;


	TkWmUnmapWindow(winPtr);
    }
}

- (BOOL) windowShouldClose: (NSWindow *) w
{
#ifdef TK_MAC_DEBUG_NOTIFICATIONS

    observe(NSWindowDidBecomeKeyNotification, windowActivation:);
    observe(NSWindowDidResignKeyNotification, windowActivation:);
    observe(NSWindowWillCloseNotification, windowActivation:);
    observe(NSWindowDidMoveNotification, windowBoundsChanged:);
    observe(NSWindowDidResizeNotification, windowBoundsChanged:);
    observe(NSWindowDidDeminiaturizeNotification, windowExpanded:);
    observe(NSWindowDidMiniaturizeNotification, windowCollapsed:);

    observe(NSWindowWillOrderOnScreenNotification, windowMapped:);
    observe(NSWindowDidOrderOnScreenNotification, windowBecameVisible:);
    observe(NSWindowWillStartLiveResizeNotification, windowLiveResize:);
    observe(NSWindowDidEndLiveResizeNotification, windowLiveResize:);
    observe(NSWindowDidEnterFullScreenNotification, windowEnteredFullScreen:);
    observe(NSWindowDidExitFullScreenNotification, windowExitedFullScreen:);

#pragma mark TKApplication(TKApplicationEvent)

@implementation TKApplication(TKApplicationEvent)

- (void) applicationActivate: (NSNotification *) notification
{
    (void)notification;

#ifdef TK_MAC_DEBUG_NOTIFICATIONS
    TKLog(@"-[%@(%p) %s] %@", [self class], self, sel_getName(_cmd), notification);


#endif
    [NSApp tkCheckPasteboard];

    /*
     * When the application is activated with Command-Tab it will create a
     * zombie window for every Tk window which has been withdrawn.  So iterate
     * through the list of windows and order out any withdrawn window.

	    continue;
	}
	if (winPtr->wmInfoPtr->hints.initial_state == WithdrawnState) {
	    [win orderOut:NSApp];
	}
	if (winPtr->dispPtr->grabWinPtr == winPtr) {
	    Tcl_DoWhenIdle(RefocusGrabWindow, winPtr);







	} else {
	    [[self keyWindow] orderFront: self];
	}
    }
}

- (void) applicationDeactivate: (NSNotification *) notification
{
    (void)notification;

#ifdef TK_MAC_DEBUG_NOTIFICATIONS

	 * there is no choice for a new key window.  Moreover, if the host
	 * computer has a TouchBar then the TouchBar holds a reference to the
	 * key window which prevents it from being deallocated until it stops
	 * being the key window.  On these systems the only option for
	 * preventing zombies is to set the key window to nil.
	 */

	TkMacOSXAssignNewKeyWindow(Tk_Interp((Tk_Window) winPtr),
				   deadNSWindow);

	/*
	 * Prevent zombies on systems with a TouchBar.
	 */

	if (deadNSWindow == [NSApp keyWindow]) {
	    [NSApp _setKeyWindow:nil];
	    [NSApp _setMainWindow:nil];
	}








	/*
	 * Avoid redrawing the view after it is released.
	 */

	TKContentView *deadView = [deadNSWindow contentView];
	Tcl_CancelIdleCall(TkMacOSXRedrawViewIdleTask, (void *) deadView);

# of this file, and for a DISCLAIMER OF ALL WARRANTIES.

package require tk ;# This is the Tk test suite; fail early if no Tk!
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]
tcltest::configure -singleproc 1
set ErrorOnFailures [info exists env(ERROR_ON_FAILURES)]
encoding system utf-8
if {[tcltest::runAllTests] && $ErrorOnFailures} {exit 1}

# This file is a Tcl script to test labels, buttons, checkbuttons, and
# radiobuttons in Tk (i.e., all the widgets defined in tkButton.c).  It is
# organized in the standard fashion for Tcl tests.
#
# Copyright © 1994 The Regents of the University of California.
# Copyright © 1994-1996 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

package require tcltest 2.2
namespace import ::tcltest::*
eval tcltest::configure $argv
tcltest::loadTestedCommands
imageInit

proc bogusTrace args {
    error "trace aborted"
}


test button-1.1 {configuration option: "activebackground" for label} -setup {
    label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
    pack .l
    update
} -body {
    .l configure -activebackground #012345
    .l cget -activebackground

    }}}
    pack .b
    bind .b <Configure> {unset var}
    update
    destroy .b
} {}





imageFinish

cleanupTests
return

# Local variables:
# mode: tcl
# End:

# This file is a Tcl script to test out the procedures in tkCanvImg.c,
# which implement canvas "image" items.  It is organized in the standard
# fashion for Tcl tests.
#
# Copyright © 1994 The Regents of the University of California.
# Copyright © 1994-1996 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

package require tcltest 2.2
namespace import ::tcltest::*
eval tcltest::configure $argv
tcltest::loadTestedCommands




imageInit

# Canvas used in every test case of the whole file
canvas .c
pack .c
update

    after cancel $timer
    return $z
} -cleanup {
    .c delete all
    image delete foo2
} -result {{foo2 display 0 0 80 60}}




# cleanup
imageFinish

cleanupTests
return

# Local variables:
# mode: tcl
# End:

# This file is a Tcl script to test out procedures to write postscript
# for canvases to files and channels. It exercises the procedure
# TkCanvPostscriptCmd in generic/tkCanvPs.c
#
# Copyright © 1995 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

package require tcltest 2.2
namespace import ::tcltest::*
eval tcltest::configure $argv
tcltest::loadTestedCommands




imageInit

# canvas used in 1.* and 2.* test cases
canvas .c -width 400 -height 300 -bd 2 -relief sunken
.c create rectangle 20 20 80 80 -fill red
pack .c
update

    update
    .c create image 50 50 -image ::tk::icons::information
    .c postscript
} -cleanup {
    destroy .c
} -returnCodes ok -match glob -result *




# cleanup
unset -nocomplain foo bar
imageFinish

deleteWindows
cleanupTests
return

# Local variables:
# mode: tcl
# End:

# This file is a Tcl script to test out the procedures in tkCanvText.c,
# which implement canvas "text" items.  It is organized in the standard
# fashion for Tcl tests.
#
# Copyright © 1996-1997 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

package require tcltest 2.2
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
update

# Item used in 1.*  tests
.c create text 20 20 -tag test

test canvText-5.1 {ConfigureText procedure: adjust cursor} -body {
    .c create text 10 10 -tag x -fill blue -font "times 40" -stipple gray50 \
	-text "xyz"
    .c delete x
} -result {}


test canvText-6.1 {ComputeTextBbox procedure} -constraints {fonts failsOnXQuarz} -setup {
    .c delete test
} -body {
    set font "-adobe-times-medium-r-normal--*-200-*-*-*-*-*-*"
    set ay [font metrics $font -linespace]
    set ax [font measure $font 0]
    .c create text 0 0 -tag test
    .c itemconfig test -font $font -text 0

    .c create text 0 0 -tag test
    .c itemconfig test -font $font -text 0
    expr {[.c itemconfig test -anchor sw; .c bbox test] \
	      eq "-1 -$ay [expr $ax+1] 0"}
} -cleanup {
    .c delete test
} -result 1
test canvText-6.5 {ComputeTextBbox procedure} -constraints {fonts failsOnXQuarz} -setup {
    .c delete test
} -body {
    set font "-adobe-times-medium-r-normal--*-200-*-*-*-*-*-*"
    set ay [font metrics $font -linespace]
    set ax [font measure $font 0]
    .c create text 0 0 -tag test
    .c itemconfig test -font $font -text 0

    .c create text 0 0 -tag test
    .c itemconfig test -font $font -text 0
    expr {[.c itemconfig test -anchor ne; .c bbox test] \
	      eq "[expr -$ax-1] 0 1 $ay"}
} -cleanup {
    .c delete test
} -result 1
test canvText-6.9 {ComputeTextBbox procedure} -constraints {fonts failsOnXQuarz} -setup {
    .c delete test
} -body {
    set font "-adobe-times-medium-r-normal--*-200-*-*-*-*-*-*"
    set ay [font metrics $font -linespace]
    set ax [font measure $font 0]
    .c create text 0 0 -tag test
    .c itemconfig test -font $font -text 0

# This file is a Tcl script to test out the procedures in tkCanvas.c, which
# implements generic code for canvases. It is organized in the standard
# fashion for Tcl tests.
#
# Copyright © 1995-1996 Sun Microsystems, Inc.
# Copyright © 1998-2000 Ajuba Solutions.
# Copyright © 2008 Donal K. Fellows
# All rights reserved.

package require tcltest 2.2
eval tcltest::configure $argv
tcltest::loadTestedCommands




imageInit

# XXX - This test file is woefully incomplete. At present, only a few of the
# features are tested.

# Canvas used in 1.* test cases
canvas .c

	{#c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0} \
	{#c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0}}
} -cleanup {
    destroy .c
    image delete testimage
} -result 1




# cleanup
imageCleanup

cleanupTests
return

# Local Variables:
# mode: tcl
# End:

# This file is a Tcl script to test out Tk's "tk_chooseDir" and
# It is organized in the standard fashion for Tcl tests.
#
# Copyright © 1996 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

package require tcltest 2.2
namespace import ::tcltest::*
eval tcltest::configure $argv
tcltest::loadTestedCommands




#----------------------------------------------------------------------
#
# 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 {
	set w $parent.__tk_choosedir
    }
    upvar ::tk::dialog::file::__tk_choosedir data

    foreach dir $dirs {
	$data(ent) delete 0 end
	$data(ent) insert 0 $dir
	update
	SendButtonPress $parent ok mouse
	after 50
    }
}

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
#
#----------------------------------------------------------------------
# Make a dir for us to rely on for tests

	unix notAqua
} -body {
    ToEnterDirsByKey $parent [list "" $real $real]
    tk_chooseDirectory -title "Clear entry, Press OK; Enter $real, press OK" \
	    -parent $parent
} -result $real




# cleanup
removeDirectory choosedirTest

cleanupTests
return

# is grabbing the clipboard (e.g. an X server, or a VNC viewer) #
#################################################################

package require tcltest 2.2
namespace import ::tcltest::*
eval tcltest::configure $argv
tcltest::loadTestedCommands




# 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} {
    set j $i.1$i.2$i.3$i.4$i.5$i.6$i.7$i.8$i.9$i.10$i.11$i.12$i.13$i.14
    append longValue A$j B$j C$j D$j E$j F$j G$j H$j I$j K$j L$j M$j N$j
}

# Now we start the main body of the test code

test clipboard-1.1 {ClipboardHandler procedure} -setup {
    clipboard clear
} -body {
    clipboard append "test"
    clipboard get
} -cleanup {
    clipboard clear

	clipboard get
} -cleanup {
    clipboard clear
}  -returnCodes ok -result {first chunk second chunk}
test clipboard-6.2 {Tk_ClipboardAppend procedure} -constraints x11 -setup {
    clipboard clear
} -body {
    setupbg
    clipboard append -f INTEGER -t TEST "16"
    set result [dobg {clipboard get TEST}]
    return $result
} -cleanup {
    clipboard clear
    cleanupbg
}  -result {0x10 }
test clipboard-6.3 {Tk_ClipboardAppend procedure} -setup {
    clipboard clear
} -body {
    clipboard append -f INTEGER -t TEST "16"
    clipboard append -t TEST "test"
} -cleanup {

    clipboard clear
} -body {
    clipboard append -type
	selection get -selection CLIPBOARD
} -cleanup {
    clipboard clear
} -result {-type}




# cleanup

cleanupTests
return

# Local Variables:
# mode: tcl
# End:

# This file is a Tcl script to test out Tk's "tk_chooseColor" command.
# It is organized in the standard fashion for Tcl tests.
#
# Copyright © 1996 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

package require tcltest 2.2
eval tcltest::configure $argv
tcltest::loadTestedCommands
namespace import -force tcltest::test




if {[testConstraint defaultPseudocolor8]} {
    # let's soak up a bunch of colors...so that
    # machines with small color palettes still fail.
    # some tests will be skipped if there are no more colors
    set numcolors 32
    testConstraint colorsLeftover 1

test clrpick-1.6 {tk_chooseColor command} -body {
    tk_chooseColor -initialcolor badbadbaadcolor
} -returnCodes error -result {unknown color name "badbadbaadcolor"}
test clrpick-1.7 {tk_chooseColor command} -body {
    tk_chooseColor -initialcolor ##badbadbaadcolor
} -returnCodes error -result {invalid color name "##badbadbaadcolor"}


# tests 3.1 and 3.2 fail when individually run
# if there is no catch {tk_chooseColor -foo 1} msg
# before 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} {
	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

    update
    $data(red,entry)   delete 0 end
    $data(green,entry) delete 0 end
    $data(blue,entry)  delete 0 end

    $data(red,entry)   insert 0 $r
    $data(green,entry) insert 0 $g
    $data(blue,entry)  insert 0 $b

    # Manually force the refresh of the color values instead
    # of counting on the timing of the event stream to change
    # the values for us.
    tk::dialog::color::HandleRGBEntry $w

    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 {
    set verylongstring [string repeat longstring: 100]
} -body {
    ToPressButton . ok

} -body {
    after 50 {set ::scr [winfo screen .__tk__color]}
    ToPressButton . cancel
    tk_chooseColor -parent .
    set ::scr
} -result [winfo screen .]




# cleanup

cleanupTests
return

# This file is a Tcl script to test out the procedures in the file
# tkColor.c.  It is organized in the standard fashion for Tcl tests.
#
# Copyright © 1995-1998 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

package require tcltest 2.2
eval tcltest::configure $argv
tcltest::loadTestedCommands




# cname --
# Returns a proper name for a color, given its intensities.
#
# Arguments:
# r, g, b -	Intensities on a 0-255 scale.

proc cname {r g b} {

# vals -	List of intensities.

proc c255 {vals} {
    list [expr {[lindex $vals 0]/256}] [expr {[lindex $vals 1]/256}] \
	    [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
# substantial changes as far back as the fossil history goes. It might
# be from a time, when 256 color was the best you could get! :-o.
#
# The problem is, on machines with a fancy 24 truecolor display, the

    set result
} -cleanup {
    rename copy {}
} -result {{{1 3}} {{1 2}} {{1 1}} {}}

destroy .t




# cleanup

cleanupTests
return

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::*

namespace import -force tcltest::testConstraint




testConstraint notAqua [expr {[tk windowingsystem] ne "aqua"}]
testConstraint aqua [expr {[tk windowingsystem] eq "aqua"}]
testConstraint x11 [expr {[tk windowingsystem] eq "x11"}]
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]]

# constraints about what sort of fonts are available
testConstraint fonts 1
destroy .e
entry .e -width 0 -font {Helvetica -12} -bd 1 -highlightthickness 1
.e insert end a.bcd
if {([winfo reqwidth .e] != 37) || ([winfo reqheight .e] != 20)} {
    testConstraint fonts 0
}

set fixedFont {Courier 12}   ; # warning: must be consistent with the files using the constraint below!
set bigFont   {Helvetica 24} ; # ditto
testConstraint haveBigFontTwiceLargerThanTextFont [expr {
    [font actual $fixedFont -size] * 2 <= [font actual $bigFont -size]
}]
unset fixedFont bigFont

# constraints for the visuals available



testConstraint pseudocolor8 [expr {
    ([catch {
	toplevel .t -visual {pseudocolor 8} -colormap new
    }] == 0) && ([winfo depth .t] == 8)
}]
destroy .t
testConstraint haveTruecolor24 [expr {
    {truecolor 24} in [winfo visualsavailable .]
}]
testConstraint haveGrayscale8 [expr {
    {grayscale 8} in [winfo visualsavailable .]
}]
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










deleteWindows
wm geometry . {}
raise .

# This file is a Tcl script to test out Tk's "tk_dialog" command.
# It is organized in the standard fashion for Tcl tests.

package require tcltest 2.2
eval tcltest::configure $argv
tcltest::loadTestedCommands
namespace import -force tcltest::test




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 *"}
test dialog-1.2 {tk_dialog command} -body {
    tk_dialog foo foo foo foo foo
} -returnCodes error -result {bad window path name "foo"}
test dialog-1.3 {tk_dialog command} -body {
    tk_dialog .d foo foo fooBitmap foo
} -cleanup {
    destroy .d
} -returnCodes error -result {bitmap "fooBitmap" not defined}


test dialog-2.1 {tk_dialog operation} -setup {
    proc PressButton {btn} {

	if {![winfo ismapped $btn]} {
	    update
	}
	event generate $btn <Enter>
	event generate $btn <Button-1> -x 5 -y 5
	event generate $btn <ButtonRelease-1> -x 5 -y 5
    }
} -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
} -cleanup {
    destroy .d
} -result 0
test dialog-2.2 {tk_dialog operation} -setup {

    set res [tk_dialog .d foo foo info 0 click]
    after cancel $x
    return $res
} -cleanup {
    destroy .b
} -result -1






cleanupTests
return

# This file is a Tcl script to test entry widgets in Tk.  It is
# organized in the standard fashion for Tcl tests.
#
# Copyright © 1994 The Regents of the University of California.
# Copyright © 1994-1997 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

package require tcltest 2.2
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
}

# 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
}

set cy [font metrics {Courier -12} -linespace]


test entry-1.1 {configuration option: "background" for entry} -setup {
    entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
    pack .e ; update idletasks
    update

} -cleanup {
    destroy .e
} -result 0123457890
test entry-3.24 {EntryWidgetCmd procedure, "delete" widget command} -setup {
    entry .e
    pack .e ; update idletasks
    update
    set x {}
} -body {
# UTF
    .e insert end "01234乎67890"
    .e delete 6
    lappend x [.e get]
    .e delete 0 end
    .e insert end "012345乎7890"
    .e delete 6
    lappend x [.e get]
    .e delete 0 end
    .e insert end "0123456乎890"
    .e delete 6
    lappend x [.e get]
} -cleanup {
    destroy .e
} -result [list "01234乎7890" "0123457890" "012345乎890"]
test entry-3.25 {EntryWidgetCmd procedure, "delete" widget command} -setup {
    entry .e
    pack .e ; update idletasks
    update

    .e insert end "This is quite a long text string, so long that it "
    .e insert end "runs off the end of the window quite a bit."
    .e insert 10 乎
    update
# UTF
# If Tcl_NumUtfChars wasn't used, wrong answer would be:
# 0.106383 0.117021 0.117021
    set x {}
    .e xview moveto .1
    lappend x [format {%.6f} [lindex [.e xview] 0]]
    .e xview moveto .11
    lappend x [format {%.6f} [lindex [.e xview] 0]]
    .e xview moveto .12
    lappend x [format {%.6f} [lindex [.e xview] 0]]
} -cleanup {
    destroy .e
} -result {0.095745 0.106383 0.117021}

test entry-3.82 {EntryWidgetCmd procedure} -setup {
    entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2
    pack .e ; update idletasks
    update
} -body {
    .e gorp
} -cleanup {
    destroy .e
} -returnCodes error -result {bad option "gorp": must be bbox, cget, configure, delete, get, icursor, index, insert, scan, selection, validate, or xview}

# The test below doesn't actually check anything directly, but if run
# with Purify or some other memory-allocation-checking program it will
# ensure that resources get properly freed.

test entry-4.1 {DestroyEntry procedure} -body {
    entry .e -textvariable x -show *
    pack .e ; update idletasks
    .e insert end "Sample text"
    update
    destroy .e
} -result {}

test entry-5.1 {ConfigureEntry procedure, -textvariable} -body {
    set x 12345
    entry .e -textvariable x
    .e get
} -cleanup {
    destroy .e
} -result 12345
test entry-5.2 {ConfigureEntry procedure, -textvariable} -body {
    set x 12345
    entry .e -textvariable x
    set y abcde
    .e configure -textvariable y
    set x 54321
    .e get
} -cleanup {
    destroy .e
} -result {abcde}
test entry-5.3 {ConfigureEntry procedure, -textvariable} -setup {
    unset -nocomplain x
    entry .e
} -body {
    .e insert 0 "Some text"
    .e configure -textvariable x
    set x
} -cleanup {
    destroy .e
} -result {Some text}
test entry-5.4 {ConfigureEntry procedure, -textvariable} -setup {
    unset -nocomplain x
    entry .e
} -body {
    trace add variable x write override
    .e insert 0 "Some text"
    .e configure -textvariable x
    list $x [.e get]
} -cleanup {
    destroy .e
    trace remove variable x write override
    unset x;
} -result {12345 12345}

test entry-5.5 {ConfigureEntry procedure} -setup {
    set x {}
    entry .e1
    entry .e2
} -body {
    .e2 insert end "This is some sample text"
    .e1 configure -exportselection false
    .e1 insert end "0123456789"
    pack .e1 .e2 ; update idletasks
    .e2 select from 0
    .e2 select to 10
    lappend x [selection get]
    .e1 select from 1
    .e1 select to 5
    lappend x [selection get]
    .e1 configure -exportselection 1
    lappend x [selection get]
    set x
} -cleanup {
    destroy .e1 .e2
} -result {{This is so} {This is so} 1234}
test entry-5.6 {ConfigureEntry procedure} -setup {
    entry .e
    pack .e ; update idletasks
} -body {

    destroy .e
} -result {1 5}

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 insert end "01234567890"
    update
    set scrollInfo wrong
    .e configure -width 5
    update
    format {%.6f %.6f} {*}$scrollInfo
} -cleanup {

} -setup {
    entry .e -highlightthickness 2 -font {Helvetica -12}
    pack .e ; update idletasks
} -body {
    .e configure -bd 1 -relief raised -width 0 -show .
    .e insert 0 12345
    update
    set x [winfo reqwidth .e]
    .e configure -show X
    lappend x [winfo reqwidth .e]
    .e configure -show ""
    lappend x [winfo reqwidth .e]
} -cleanup {
    destroy .e
} -result {23 53 43}
test entry-6.11 {EntryComputeGeometry procedure} -constraints {
    win
} -setup {
    entry .e -highlightthickness 2
    pack .e ; update idletasks
} -body {
    .e configure -bd 1 -relief raised -width 0 -show . -font {helvetica 12}
    .e insert 0 12345
    update
    set x1 [winfo reqwidth .e]
	set x2 [expr {8+5*[font measure {helvetica 12} .]}]
	set x [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}]
    .e configure -show ""
	set x1 [winfo reqwidth .e]
	set x2 [expr {8+[font measure {helvetica 12} 12345]}]
    lappend x [expr {$x1 eq $x2}]
} -cleanup {
    destroy .e
} -result {1 1 1}
test entry-6.12 {EntryComputeGeometry procedure} -constraints {
    fonts
} -setup {
    catch {destroy .e}

test entry-7.1 {InsertChars procedure} -setup {
    unset -nocomplain contents
    entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2
    pack .e ; update idletasks
    focus .e
} -body {
    .e configure -textvariable contents -xscrollcommand scroll
    update
    set scrollInfo wrong
    .e insert 0 abcde
    .e insert 2 XXX
    update
    list [.e get] $contents [format {%.6f %.6f} {*}$scrollInfo]
} -cleanup {
    destroy .e
} -result {abXXXcde abXXXcde {0.000000 1.000000}}

test entry-7.2 {InsertChars procedure} -setup {
    unset -nocomplain contents
    entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2
    pack .e ; update idletasks
    focus .e
} -body {
    .e configure -textvariable contents -xscrollcommand scroll
    update
    set scrollInfo wrong
    .e insert 0 abcde
    .e insert 500 XXX
    update
    list [.e get] $contents [format {%.6f %.6f} {*}$scrollInfo]
} -cleanup {
    destroy .e
} -result {abcdeXXX abcdeXXX {0.000000 1.000000}}
test entry-7.3 {InsertChars procedure} -setup {
    entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2
    pack .e ; update idletasks
} -body {
    .e insert 0 0123456789
    .e select from 2
    .e select to 6
    .e insert 2 XXX
    set x "[.e index sel.first] [.e index sel.last]"
    .e select to 8
    lappend x [.e index sel.first] [.e index sel.last]
} -cleanup {
    destroy .e
} -result {5 9 5 8}
test entry-7.4 {InsertChars procedure} -setup {
    entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2
    pack .e ; update idletasks
} -body {
    .e insert 0 0123456789
    .e select from 2
    .e select to 6
    .e insert 3 XXX
    set x "[.e index sel.first] [.e index sel.last]"
    .e select to 8
    lappend x [.e index sel.first] [.e index sel.last]
} -cleanup {
    destroy .e
} -result {2 9 2 8}
test entry-7.5 {InsertChars procedure} -setup {
    entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2
    pack .e ; update idletasks
} -body {
    .e insert 0 0123456789
    .e select from 2
    .e select to 6
    .e insert 5 XXX
    set x "[.e index sel.first] [.e index sel.last]"
    .e select to 8
    lappend x [.e index sel.first] [.e index sel.last]
} -cleanup {
    destroy .e
} -result {2 9 2 8}
test entry-7.6 {InsertChars procedure} -setup {
    entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2
    pack .e ; update idletasks
} -body {
    .e insert 0 0123456789
    .e select from 2
    .e select to 6
    .e insert 6 XXX
    set x "[.e index sel.first] [.e index sel.last]"
    .e select to 5
    lappend x [.e index sel.first] [.e index sel.last]
} -cleanup {
    destroy .e
} -result {2 6 2 5}
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 insert 0 0123456789
    .e icursor 4
    .e insert 4 XXX
    .e index insert
} -cleanup {
    destroy .e
} -result 7

test entry-8.1 {DeleteChars procedure} -setup {
    unset -nocomplain contents
    entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2
    pack .e ; update idletasks
    focus .e
} -body {
    .e configure -textvariable contents -xscrollcommand scroll
    update
    set scrollInfo wrong
    .e insert 0 abcde
    .e delete 2 4
    update
    list [.e get] $contents [format {%.6f %.6f} {*}$scrollInfo]
} -cleanup {
    destroy .e
} -result {abe abe {0.000000 1.000000}}
test entry-8.2 {DeleteChars procedure} -setup {
    unset -nocomplain contents
    entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2
    pack .e ; update idletasks
    focus .e
} -body {
    .e configure -textvariable contents -xscrollcommand scroll
    update
    set scrollInfo wrong
    .e insert 0 abcde
    .e delete {} 2
    update
    list [.e get] $contents [format {%.6f %.6f} {*}$scrollInfo]
} -cleanup {
    destroy .e
} -result {cde cde {0.000000 1.000000}}
test entry-8.3 {DeleteChars procedure} -setup {
    unset -nocomplain contents
    entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2
    pack .e ; update idletasks
    focus .e
} -body {
    .e configure -textvariable contents -xscrollcommand scroll
    update
    set scrollInfo wrong
    .e insert 0 abcde
    .e delete 3 1000
    update
    list [.e get] $contents [format {%.6f %.6f} {*}$scrollInfo]
} -cleanup {
    destroy .e
} -result {abc abc {0.000000 1.000000}}
test entry-8.4 {DeleteChars procedure} -setup {
    entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2
    pack .e ; update idletasks
    focus .e
} -body {
    .e insert 0 0123456789abcde
    .e select from 3
    .e select to 8
    .e delete 1 3
    update
    set x "[.e index sel.first] [.e index sel.last]"
    .e select to 5
    lappend x [.e index sel.first] [.e index sel.last]
} -cleanup {
    destroy .e
} -result {1 6 1 5}
test entry-8.5 {DeleteChars procedure} -setup {
    entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2
    pack .e ; update idletasks
    focus .e
} -body {
    .e insert 0 0123456789abcde
    .e select from 3
    .e select to 8
    .e delete 1 4
    update
    set x "[.e index sel.first] [.e index sel.last]"
    .e select to 4
    lappend x [.e index sel.first] [.e index sel.last]
} -cleanup {
    destroy .e
} -result {1 5 1 4}
test entry-8.6 {DeleteChars procedure} -setup {
    entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2
    pack .e ; update idletasks
    focus .e
} -body {
    .e insert 0 0123456789abcde
    .e select from 3
    .e select to 8
    .e delete 1 7
    update
    set x "[.e index sel.first] [.e index sel.last]"
    .e select to 5
    lappend x [.e index sel.first] [.e index sel.last]
} -cleanup {
    destroy .e
} -result {1 2 1 5}
test entry-8.7 {DeleteChars procedure} -setup {
    entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2
    pack .e ; update idletasks
    focus .e

    focus .e
} -body {
    .e insert 0 0123456789abcde
    .e select from 3
    .e select to 8
    .e delete 3 7
    update
    set x "[.e index sel.first] [.e index sel.last]"
    .e select to 8
    lappend x [.e index sel.first] [.e index sel.last]
} -cleanup {
    destroy .e
} -result {3 4 3 8}
test entry-8.9 {DeleteChars procedure} -setup {
    entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2
    pack .e ; update idletasks
} -body {

    focus .e
} -body {
    .e insert 0 0123456789abcde
    .e select from 8
    .e select to 3
    .e delete 5 8
    update
    set x "[.e index sel.first] [.e index sel.last]"
    .e select to 8
    lappend x [.e index sel.first] [.e index sel.last]
} -cleanup {
    destroy .e
} -result {3 5 5 8}
test entry-8.11 {DeleteChars procedure} -setup {
    entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2
    pack .e ; update idletasks
    focus .e
} -body {
    .e insert 0 0123456789abcde
    .e select from 8
    .e select to 3
    .e delete 8 10
    update
    set x "[.e index sel.first] [.e index sel.last]"
    .e select to 4
    lappend x [.e index sel.first] [.e index sel.last]
} -cleanup {
    destroy .e
} -result {3 8 4 8}
test entry-8.12 {DeleteChars procedure} -setup {
    entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2
    pack .e ; update idletasks
    focus .e

    expr {[winfo reqwidth .e] == $expected}
} -cleanup {
    destroy .e
    unset XPAD expected
} -result {1}

test entry-9.1 {EntryValueChanged procedure} -setup {
    unset -nocomplain x
} -body {
    trace add variable x write override
    entry .e -textvariable x -width 0
    .e insert 0 foo
    list $x [.e get]
} -cleanup {
    destroy .e
    trace remove variable x write override
    unset x
} -result {12345 12345}


test entry-10.1 {EntrySetValue procedure} -constraints fonts -body {
    set x 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 y
    update
    list [.e get] [winfo reqwidth .e]
} -cleanup {
    destroy .e
} -result {ab 24}
test entry-10.2 {EntrySetValue procedure, updating selection} -setup {
    unset -nocomplain x
    entry .e -font {Helvetica -12} -highlightthickness 2 -bd 2
    pack .e ; update idletasks
} -body {
    .e configure -textvariable x
    .e insert 0 "abcdefghjklmnopqrstu"
    .e selection range 4 10
    set x "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
    entry .e -font {Helvetica -12} -highlightthickness 2 -bd 2
    pack .e ; update idletasks
} -body {
    .e configure -textvariable x
    .e insert 0 "abcdefghjklmnopqrstu"
    .e selection range 4 10
    set x "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
    entry .e -font {Helvetica -12} -highlightthickness 2 -bd 2
    pack .e ; update idletasks
} -body {
    .e configure -textvariable x
    .e insert 0 "abcdefghjklmnopqrstu"
    .e selection range 4 10
    set x "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
    entry .e -highlightthickness 2 -bd 2
    pack .e ; update idletasks
} -body {
    .e configure -width 10 -font {Courier -12} -textvariable x
    .e insert 0 "abcdefghjklmnopqrstuvwxyz"
    .e xview 10
    update
    set x "abcdefg"
    update
    .e index @0
} -cleanup {
    destroy .e
} -result 0
test entry-10.6 {EntrySetValue procedure, updating display position} -setup {
    unset -nocomplain x
    entry .e -highlightthickness 2 -bd 2
    pack .e ; update idletasks
} -body {
    .e configure -width 10 -font {Courier -12} -textvariable x
    pack .e ; update idletasks
    .e insert 0 "abcdefghjklmnopqrstuvwxyz"
    .e xview 10
    update
    set x "1234567890123456789012"
    update
    .e index @0
} -cleanup {
    destroy .e
} -result 10
test entry-10.7 {EntrySetValue procedure, updating insertion cursor} -setup {
    unset -nocomplain x
    entry .e -highlightthickness 2 -bd 2
    pack .e ; update idletasks
    update
} -body {
    .e configure -width 10 -font {Courier -12} -textvariable x
    pack .e ; update idletasks
    .e insert 0 "abcdefghjklmnopqrstuvwxyz"
    .e icursor 5
    set x "123"
    .e index insert
} -cleanup {
    destroy .e
} -result 3
test entry-10.8 {EntrySetValue procedure, updating insertion cursor} -setup {
    unset -nocomplain x
    entry .e -highlightthickness 2 -bd 2
    pack .e ; update idletasks
} -body {
    .e configure -width 10 -font {Courier -12} -textvariable x
    pack .e ; update idletasks
    .e insert 0 "abcdefghjklmnopqrstuvwxyz"
    .e icursor 5
    set x "123456"
    .e index insert
} -cleanup {
    destroy .e
} -result 5

test entry-11.1 {EntryEventProc procedure} -setup {
    entry .e -highlightthickness 2 -bd 2 -font {Helvetica -12}
    pack .e ; update idletasks
} -body {
    .e insert 0 abcdefg
    destroy .e
    update
} -cleanup {
    destroy .e
} -result {}
test entry-11.2 {EntryEventProc procedure} -setup {
    set x {}
} -body {
    entry .e1 -fg #112233
    rename .e1 .e2
    lappend x [winfo children .]
    lappend x [.e2 cget -fg]
    destroy .e1
    lappend x [info command .e*] [winfo children .]
} -cleanup {
    destroy .e1
} -result {.e1 #112233 {} {}}

test entry-12.1 {EntryCmdDeletedProc procedure} -body {
    button .b -text "xyz_123"
    rename .b {}

    .e select from 1
    .e select to 18
    selection get
} -cleanup {
    destroy .e
} -result {*****************}
test entry-14.3 {EntryFetchSelection procedure} -setup {
    set x {}
    for {set i 1} {$i <= 500} {incr i} {
	append x "This is line $i, out of 500\n"
}
} -body {
    entry .e
    .e insert end $x
    .e select from 0
    .e select to end
    string compare [selection get] $x
} -cleanup {
    destroy .e
} -result 0

test entry-15.1 {EntryLostSelection} -body {
    entry .e
    .e insert 0 "Text"

    format {%.6f %.6f} {*}[.e xview]
} -cleanup {
    destroy .e
} -result {0.000000 1.000000}


test entry-17.1 {EntryUpdateScrollbar procedure} -body {
    entry .e -width 10 -xscrollcommand scroll -font {Courier -12}
    pack .e
    update
    set scrollInfo wrong
    .e delete 0 end
    .e insert 0 123
    update
    format {%.6f %.6f} {*}$scrollInfo
} -cleanup {
    destroy .e
} -result {0.000000 1.000000}
test entry-17.2 {EntryUpdateScrollbar procedure} -body {
    entry .e -width 10 -xscrollcommand scroll -font {Courier -12}
    pack .e
    update
    set scrollInfo wrong
    .e insert 0 0123456789abcdef
    .e xview 3
    update
    format {%.6f %.6f} {*}$scrollInfo
} -cleanup {
    destroy .e
} -result {0.187500 0.812500}
test entry-17.3 {EntryUpdateScrollbar procedure} -body {
    entry .e -width 10 -xscrollcommand scroll -font {Courier -12}
    pack .e
    update
    set scrollInfo wrong
    .e insert 0 abcdefghijklmnopqrs
    .e xview 6
    update
    format {%.6f %.6f} {*}$scrollInfo
} -cleanup {
    destroy .e
} -result {0.315789 0.842105}
test entry-17.4 {EntryUpdateScrollbar procedure} -setup {
    proc bgerror msg {
	global x
	set x $msg
}
} -body {
    entry .e -width 5
    pack .e
    update
    set scrollInfo wrong
    .e configure -xscrollcommand thisisnotacommand
    update
    list $x $errorInfo
} -cleanup {
    destroy .e
    rename bgerror {}
} -result {{invalid command name "thisisnotacommand"} {invalid command name "thisisnotacommand"
    while executing
"thisisnotacommand 0.0 1.0"
    (horizontal scrolling command executed by .e)}}

# failures aren't good
#

# 19.* test cases in previous version highly depended on the previous
# 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
} -body {
    entry .e -validate all \
	-validatecommand [list doval %W %d %i %P %s %S %v %V] \
	-invalidcommand bell \
	-textvariable ::e \
	-background red -foreground white
    pack .e ; update idletasks
    .e insert 0 a
    set ::vVals
} -cleanup {
    destroy .e
} -result {.e 1 0 a {} a all key}

test entry-19.2 {entry widget validation} -setup {
    unset -nocomplain ::e ::vVals
} -body {
    entry .e -validate all \
	-validatecommand [list doval %W %d %i %P %s %S %v %V] \
	-invalidcommand bell \
	-textvariable ::e \
	-background red -foreground white
    pack .e ; update idletasks
    .e insert 0 a   ;# previous settings
    .e insert 1 b
    return $::vVals
} -cleanup {
    destroy .e
} -result {.e 1 1 ab a b all key}

test entry-19.3 {entry widget validation} -setup {
    unset -nocomplain ::e ::vVals
} -body {
    entry .e -validate all \
	-validatecommand [list doval %W %d %i %P %s %S %v %V] \
	-invalidcommand bell \
	-textvariable ::e \
	-background red -foreground white
    pack .e ; update idletasks
    .e insert 0 ab   ;# previous settings
    .e insert end c
    set ::vVals
} -cleanup {
    destroy .e
} -result {.e 1 2 abc ab c all key}

test entry-19.4 {entry widget validation} -setup {
    unset -nocomplain ::e ::vVals
} -body {
    entry .e -validate all \
	-validatecommand [list doval %W %d %i %P %s %S %v %V] \
	-invalidcommand bell \
	-textvariable ::e \
	-background red -foreground white
    pack .e ; update idletasks
    .e insert 0 abc   ;# previous settings
    .e insert 1 123
    list $::vVals $::e
} -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
} -body {
    entry .e -validate all \
	-validatecommand [list doval %W %d %i %P %s %S %v %V] \
	-invalidcommand bell \
	-textvariable ::e \
	-background red -foreground white
    pack .e ; update idletasks
    .e insert 0 a123bc   ;# previous settings
    .e delete 2
    set ::vVals
} -cleanup {
    destroy .e
} -result {.e 0 2 a13bc a123bc 2 all key}

test entry-19.6 {entry widget validation} -setup {
    unset -nocomplain ::e ::vVals
} -body {
    entry .e -validate all \
	-validatecommand [list doval %W %d %i %P %s %S %v %V] \
	-invalidcommand bell \
	-textvariable ::e \
	-background red -foreground white
    pack .e ; update idletasks
    .e insert 0 a13bc   ;# previous settings
    .e configure -validate key
    .e delete 1 3
    set ::vVals
} -cleanup {
    destroy .e
} -result {.e 0 1 abc a13bc 13 key key}

test entry-19.7 {entry widget validation} -setup {
    unset -nocomplain ::e ::vVals
} -body {
    entry .e -validate focus \
	-validatecommand [list doval %W %d %i %P %s %S %v %V] \
	-invalidcommand bell \
	-textvariable ::e \
	-background red -foreground white
    pack .e ; update idletasks
    .e insert end abc                 ;# previous settings
    set ::vVals {}
    .e insert end d
    set ::vVals
} -cleanup {
    destroy .e
} -result {}

test entry-19.8 {entry widget validation} -setup {
    unset -nocomplain ::e ::vVals
} -body {
    entry .e -validate all \
	-validatecommand [list doval %W %d %i %P %s %S %v %V] \
	-invalidcommand bell \
	-textvariable ::e \
	-background red -foreground white
    pack .e ; update idletasks
    .e configure -validate focus    ;# previous settings
    .e insert end abcd              ;# previous settings
    focus -force .e
# update necessary to process FocusIn event
    update
    set ::vVals
} -cleanup {
    destroy .e
} -result {.e -1 -1 abcd abcd {} focus focusin}

test entry-19.9 {entry widget validation} -setup {
    unset -nocomplain ::e ::vVals
} -body {
    entry .e -validate focus \
	-validatecommand [list doval %W %d %i %P %s %S %v %V] \
	-invalidcommand bell \
	-textvariable ::e \
	-background red -foreground white
    pack .e ; update idletasks
    .e insert end abcd      ;# previous settings
    focus -force .e         ;# previous settings
    update                  ;# previous settings
# update necessary to process FocusIn event
    focus -force .
# update necessary to process FocusOut event
    update
    set ::vVals
} -cleanup {
    destroy .e
} -result {.e -1 -1 abcd abcd {} focus focusout}

test entry-19.10 {entry widget validation} -setup {
    unset -nocomplain ::e ::vVals
} -body {
    entry .e -validate all \
	-validatecommand [list doval %W %d %i %P %s %S %v %V] \
	-invalidcommand bell \
	-textvariable ::e \
	-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
} -cleanup {
    destroy .e
} -result {.e -1 -1 abcd abcd {} all focusin}

test entry-19.11 {entry widget validation} -setup {
    unset -nocomplain ::e ::vVals
} -body {
    entry .e -validate all \
	-validatecommand [list doval %W %d %i %P %s %S %v %V] \
	-invalidcommand bell \
	-textvariable ::e \
	-background red -foreground white
    pack .e ; update idletasks
    .e insert end abcd          ;# 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
} -cleanup {
    destroy .e
} -result {.e -1 -1 abcd abcd {} all focusout}

test entry-19.12 {entry widget validation} -setup {
    unset -nocomplain ::e ::vVals
} -body {
    entry .e -validate focusin \
	-validatecommand [list doval %W %d %i %P %s %S %v %V] \
	-invalidcommand bell \
	-textvariable ::e \
	-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
} -cleanup {
    destroy .e
} -result {.e -1 -1 abcd abcd {} focusin focusin}

test entry-19.13 {entry widget validation} -setup {
    unset -nocomplain ::e ::vVals
} -body {
    entry .e -validate focusin \
	-validatecommand [list doval %W %d %i %P %s %S %v %V] \
	-invalidcommand bell \
	-textvariable ::e \
	-background red -foreground white
    pack .e ; update idletasks
    .e insert end abcd              ;# previous settings
    set ::vVals {}
    focus -force .
# update necessary to process FocusOut event
    update
    set ::vVals
} -cleanup {
    destroy .e
} -result {}

test entry-19.14 {entry widget validation} -setup {
    unset -nocomplain ::e ::vVals
} -body {
    entry .e -validate focuso \
	-validatecommand [list doval %W %d %i %P %s %S %v %V] \
	-invalidcommand bell \
	-textvariable ::e \
	-background red -foreground white
    pack .e ; update idletasks
    .e insert end abcd              ;# previous settings
    set ::vVals {}                  ;# previous settings
    focus -force .e
# update necessary to process FocusIn event
    update
    set ::vVals
} -cleanup {
    destroy .e
} -result {}

test entry-19.15 {entry widget validation} -setup {
    unset -nocomplain ::e ::vVals
} -body {
    entry .e -validate focuso \
	-validatecommand [list doval %W %d %i %P %s %S %v %V] \
	-invalidcommand bell \
	-textvariable ::e \
	-background red -foreground white
    pack .e ; update idletasks
    .e insert end abcd              ;# previous settings
    set ::vVals {}                  ;# 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
} -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
} -body {
    entry .e -validate focuso \
	-validatecommand [list doval %W %d %i %P %s %S %v %V] \
	-invalidcommand bell \
	-textvariable ::e \
	-background red -foreground white
    pack .e ; update idletasks
    .e insert end abcd              ;# previous settings
    set ::vVals {}                  ;# 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
} -cleanup {
    destroy .e
} -result {1 {.e -1 -1 abcd abcd {} all forced}}


test entry-19.17 {entry widget validation} -setup {
    unset -nocomplain ::e ::vVals
} -body {
    entry .e -validate focuso \
	-validatecommand [list doval %W %d %i %P %s %S %v %V] \
	-invalidcommand bell \
	-textvariable ::e \
	-background red -foreground white
    pack .e ; update idletasks
    .e insert end abcd              ;# previous settings
    set ::e newdata
    list [.e cget -validate] $::vVals
} -cleanup {
    destroy .e
} -result {focusout {.e -1 -1 newdata abcd {} focusout forced}}


# proc doval changed - returns 0
test entry-19.18 {entry widget validation} -setup {
    unset -nocomplain ::e ::vVals
} -body {
    entry .e -validate all \
	-validatecommand [list doval3 %W %d %i %P %s %S %v %V] \
	-invalidcommand bell \
	-textvariable ::e \
	-background red -foreground white
    pack .e ; update idletasks
    set ::e newdata                 ;# previous settings
    .e configure -validate all
    set ::e nextdata
    list [.e cget -validate] $::vVals
} -cleanup {
    destroy .e
} -result {none {.e -1 -1 nextdata newdata {} all forced}}

## 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
# proc doval2 used
test entry-19.19 {entry widget validation} -setup {
    unset -nocomplain ::e ::vVals
} -body {
    entry .e -validate all \
	-validatecommand [list doval3 %W %d %i %P %s %S %v %V] \
	-invalidcommand bell \
	-textvariable ::e \
	-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]
    .e validate
    list [.e cget -validate] [.e get] $::vVals
} -cleanup {
    destroy .e
} -result {none nextdata {.e -1 -1 nextdata nextdata {} all forced}}

## This leaves validate alone because we trigger validation through the
## textvar (a write trace), and the write during validation triggers
## nothing (by definition of avoiding loops on var traces).  This is
## 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
} -body {
    entry .e -validate all \
	-validatecommand [list doval %W %d %i %P %s %S %v %V] \
	-invalidcommand bell \
	-textvariable ::e \
	-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
    .e validate                     ;# previous settings

    .e configure -validate all
    set ::e testdata
    list [.e cget -validate] [.e get] $::e $::vVals
} -cleanup {
    destroy .e
} -result {all testdata mydata {.e -1 -1 testdata mydata {} all forced}}

## This leaves validate alone because we trigger validation through the
## textvar (a write trace), and the write during validation triggers
## nothing (by definition of avoiding loops on var traces).  This is
## 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
} -body {
    entry .e -validate key \
	-validatecommand [list doval2 %W %d %i %P %s %S %v %V] \
	-textvariable ::e
    pack .e ; update idletasks
    set ::e origdata
    .e insert 0 A
    list [.e cget -validate] [.e get] $::e $::vVals
} -cleanup {
    destroy .e
} -result {none origdata mydata {.e 1 0 Aorigdata origdata A key key}}

##
## End validation tests
##

# Gathered comments about lacks
# XXX Still need to write tests for EntryBlinkProc, EntryFocusProc,
# and EntryTextVarProc.
# No tests for DisplayEntry.
# XXX Still need to write tests for EntryScanTo and EntrySelectTo.
# No tests for EventuallyRedraw





# option clear
# cleanup




cleanupTests
return

    # a focus follows mouse will not steal away
    # the focus if the mouse is moved around.

    if {[focus] != $win} {
	focus -force $win
    }
    event generate $win <Key-$keysym>
    _pause 50
    if {[focus] != $win} {
	focus -force $win
    }
    event generate $win <KeyRelease-$keysym>
    _pause 50
}

# Call _keypress for each character in the given string

proc _keypress_string {win string} {
    foreach letter [split $string ""] {
	_keypress $win $letter
    }
}

# 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} {
    set bbox [$text bbox $ind]
    if {[llength $bbox] != 4} {
	error "got bbox \{$bbox\} from $text, index $ind"
    }

    tkwait visibility $e
    _keypress_string $e JUMP

    set result [$e get]

    event generate $e <Enter>
    for {set i 0} {$i < 3} {incr i} {
	_pause 100
	event generate $e <Button-1>
	_pause 100
	event generate $e <ButtonRelease-1>
    }

    _keypress $e Delete
    _keypress_string $e UP
    lappend result [$e get]
} -cleanup {

    tkwait visibility $e
    _keypress_string $e JUMP

    set result [$e get 1.0 1.end]

    event generate $e <Enter>
    for {set i 0} {$i < 3} {incr i} {
	_pause 100
	event generate $e <Button-1>
	_pause 100
	event generate $e <ButtonRelease-1>
    }

    _keypress $e Delete
    _keypress_string $e UP
    lappend result [$e get 1.0 1.end]
} -cleanup {

    # Now drag until selend is highlighted, then click up

    set current $anchor
    while {[$e compare $current <= $selend]} {
	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
    }

    event generate $e <ButtonRelease-1> -x $current_x -y $current_y
    _pause 200

    # Save the position of the insert cursor
    lappend result [$e index insert]

    # Save the highlighted text
    lappend result [_get_selection $e]

    # Now click and click and drag to the left, over "Tcl/Tk selection"

    event generate $e <Button-1> -x $current_x -y $current_y

    while {[$e compare $current >= [list $anchor - 4 char]]} {
	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
    }

    event generate $e <ButtonRelease-1> -x $current_x -y $current_y
    _pause 200

    # Save the position of the insert cursor
    lappend result [$e index insert]

    # Save the highlighted text
    lappend result [_get_selection $e]

    # Now drag until selend is highlighted, then click up

    set current $anchor
    while {$current <= $selend} {
	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
    }

    event generate $e <ButtonRelease-1> -x $current_x -y $current_y
    _pause 200

    # Save the position of the insert cursor
    lappend result [$e index insert]

    # Save the highlighted text
    lappend result [_get_selection $e]

    # Now click and click and drag to the left, over "Tcl/Tk selection"

    event generate $e <Button-1> -x $current_x -y $current_y

    while {$current >= ($anchor - 4)} {
	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
    }

    event generate $e <ButtonRelease-1> -x $current_x -y $current_y
    _pause 200

    # Save the position of the insert cursor
    lappend result [$e index insert]

    # Save the highlighted text
    lappend result [_get_selection $e]

    # Get the x,y coords of the second e in "select"
    foreach {anchor_x anchor_y} [_text_ind_to_x_y $e $anchor] break

    # Click down, release, then click down again
    event generate $e <Enter>
    event generate $e <Button-1> -x $anchor_x -y $anchor_y
    _pause 50
    event generate $e <ButtonRelease-1> -x $anchor_x -y $anchor_y
    _pause 50
    event generate $e <Button-1> -x $anchor_x -y $anchor_y
    _pause 50

    # Save the highlighted text
    set result [list]
    lappend result [_get_selection $e]

    # Insert cursor should be at beginning of "select"
    lappend result [$e index insert]

    # Move mouse one character to the left
    set current [$e index [list $anchor - 1 char]]
    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

    # Insert cursor should be before the l in "select"
    lappend result [$e index insert]

    # Selection should still be the word "select"
    lappend result [_get_selection $e]

    # Move mouse to the space before the word "select"
    set current [$e index [list $current - 3 char]]

    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

    lappend result [$e index insert]
    lappend result [_get_selection $e]

    # Move mouse to the r in "Word"
    set current 1.2
    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

    # Selection should now be "Word select"
    lappend result [_get_selection $e]

    # Insert cursor should be before the r in "Word"
    lappend result [$e index insert]

    # Get the x,y coords of the second e in "select"
    foreach {anchor_x anchor_y} [_text_ind_to_x_y $e $anchor] break

    # Click down, release, then click down again
    event generate $e <Enter>
    event generate $e <Button-1> -x $anchor_x -y $anchor_y
    _pause 50
    event generate $e <ButtonRelease-1> -x $anchor_x -y $anchor_y
    _pause 50
    event generate $e <Button-1> -x $anchor_x -y $anchor_y
    _pause 50

    set result [list]
    lappend result [_get_selection $e]

    # Insert cursor should be at the end of "select"
    lappend result [$e index insert]

    # Move mouse one character to the left
    set current [expr {$anchor - 1}]
    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

    # Insert cursor should be before the l in "select"
    lappend result [$e index insert]

    # Selection should still be the word "select"
    lappend result [_get_selection $e]

    # Move mouse to the space before the word "select"
    set current [expr {$current - 3}]
    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

    lappend result [$e index insert]
    lappend result [_get_selection $e]

    # Move mouse to the r in "Word"
    set current [expr {$current - 2}]
    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

    # Selection should now be "Word select"
    lappend result [_get_selection $e]

    # Insert cursor should be before the r in "Word"
    lappend result [$e index insert]

    # Triple click one third line leaving mouse down

    foreach {anchor_x anchor_y} [_text_ind_to_x_y $e $anchor] break

    event generate $e <Enter>

    event generate $e <Button-1> -x $anchor_x -y $anchor_y
    _pause 50
    event generate $e <ButtonRelease-1> -x $anchor_x -y $anchor_y
    _pause 50

    event generate $e <Button-1> -x $anchor_x -y $anchor_y
    _pause 50
    event generate $e <ButtonRelease-1> -x $anchor_x -y $anchor_y
    _pause 50

    event generate $e <Button-1> -x $anchor_x -y $anchor_y
    _pause 50

    set result [list]
    lappend result [_get_selection $e]

    # Drag up to second line

    set current [$e index [list $anchor - 1 line]]
    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

    lappend result [_get_selection $e]

    # Drag up to first line

    set current [$e index [list $current - 1 line]]
    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

    lappend result [_get_selection $e]

    return $result
} -cleanup {
    deleteWindows
} -result [list "LINE THREE\n" "LINE TWO\nLINE THREE\n" \

    set right_x [expr {($x1 + $width) - 2}]
    set right_y $middle_y

    # Double click near left hand egde of the letter A

    event generate $e <Enter>
    event generate $e <Button-1> -x $left_x -y $left_y
    _pause 50
    event generate $e <ButtonRelease-1> -x $left_x -y $left_y
    _pause 50
    event generate $e <Button-1> -x $left_x -y $left_y
    _pause 50
    event generate $e <ButtonRelease-1> -x $left_x -y $left_y
    _pause 50

    set result [list]
    lappend result [$e index insert]
    lappend result [_get_selection $e]

    # Clear selection by clicking at 0,0

    event generate $e <Button-1> -x 0 -y 0
    _pause 50
    event generate $e <ButtonRelease-1> -x 0 -y 0
    _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
    event generate $e <ButtonRelease-1> -x $right_x -y $right_y
    _pause 50
    event generate $e <Button-1> -x $right_x -y $right_y
    _pause 50
    event generate $e <ButtonRelease-1> -x $right_x -y $right_y
    _pause 50

    lappend result [$e index insert]
    lappend result [_get_selection $e]

    return $result
} -cleanup {
    deleteWindows

    set right_x [expr {($x1 + $width) - 2}]
    set right_y $middle_y

    # Double click near left hand egde of the letter A

    event generate $e <Enter>
    event generate $e <Button-1> -x $left_x -y $left_y
    _pause 50
    event generate $e <ButtonRelease-1> -x $left_x -y $left_y
    _pause 50
    event generate $e <Button-1> -x $left_x -y $left_y
    _pause 50
    event generate $e <ButtonRelease-1> -x $left_x -y $left_y
    _pause 50

    set result [list]
    lappend result [$e index insert]
    lappend result [_get_selection $e]

    # Clear selection by clicking at 0,0

    event generate $e <Button-1> -x 0 -y 0
    _pause 50
    event generate $e <ButtonRelease-1> -x 0 -y 0
    _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
    event generate $e <ButtonRelease-1> -x $right_x -y $right_y
    _pause 50
    event generate $e <Button-1> -x $right_x -y $right_y
    _pause 50
    event generate $e <ButtonRelease-1> -x $right_x -y $right_y
    _pause 50

    lappend result [$e index insert]
    lappend result [_get_selection $e]

    return $result
} -cleanup {
    deleteWindows

} -result {OK}

test event-9.1 {enter . window by destroying a toplevel - bug b1d115fa60} -setup {
    set EnterBind [bind . <Enter>]
} -body {
    wm geometry . 200x200+300+300
    wm deiconify .
    _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
    event generate .top2 <Motion> -warp 1 -x 50 -y 50
    _pause 100
    bind . <Enter> {lappend res %W}
    set res [list ]
    destroy .top2
    update idletasks
    _pause 200
    set res
} -cleanup {
    deleteWindows
    bind . <Enter> $EnterBind
} -result {.}

# This test fails sporadically when run on the macOS CI runner. It does

	update
	set iconified true
    }
} -body {
    toplevel .top1
    wm geometry .top1 200x200+300+300
    wm deiconify .top1
    _pause 200
    toplevel .top2 -width 200 -height 200
    wm geometry .top2 +[expr {[winfo rootx .top1]+50}]+[expr {[winfo rooty .top1]+50}]
    _pause 200
    wm deiconify .top2
    update idletasks
    raise .top2
    _pause 400
    event generate .top2 <Motion> -warp 1 -x 50 -y 50
    _pause 100
    bind .top1 <Enter> {lappend res %W}
    set res [list ]
    destroy .top2
    _pause 200
    set res
} -cleanup {
    deleteWindows ; # destroy all children of ".", this already includes .top1
    if {$iconified} {
	wm deiconify .
	update
    }

test event-9.11 {pointer window container = parent} -setup {
    setup_win_mousepointer .one
    wm withdraw .one
    create_and_pack_frames .one
    wm deiconify .one
    tkwait visibility .one.f1.f2
    _pause 200; # needed for Windows
    update idletasks; # finish display of window
    set result "|"
} -body {
    bind all <Leave> {append result "<Leave> %d %W|"}
    bind all <Enter> {append result "<Enter> %d %W|"}
    destroy .one.f1.f2
    update

    wm withdraw .one
    create_and_pack_frames .one
    pack propagate .one.f1.f2 0
    pack [frame .one.g -bg orange -width 80 -height 80] -anchor se -side bottom -in .one.f1.f2
    wm deiconify .one
    tkwait visibility .one.g
    event generate .one <Motion> -warp 1 -x 250 -y 250
    _pause 200; # needed for Windows
    set result "|"
} -body {
    bind all <Leave> {append result "<Leave> %d %W|"}
    bind all <Enter> {append result "<Enter> %d %W|"}
    destroy .one.g
    update
    set result

    # TkPointerDeadWindow() and subsequent reading in GenerateEnterLeave().
    setup_win_mousepointer .one
    wm withdraw .one
    create_and_pack_frames .one
    wm deiconify .one
    tkwait visibility .one.f1.f2
    update idletasks; # finish displaying window
    _pause 200; # needed for Windows
    set result "|"
} -body {
    bind all <Leave> {append result "<Leave> %d %W|"}
    bind all <Enter> {append result "<Enter> %d %W|"}
    destroy .one.f1
    update
    set result

    # TkPointerDeadWindow() and subsequent reading in GenerateEnterLeave().
    setup_win_mousepointer .one
    wm withdraw .one
    create_and_pack_frames .one
    wm deiconify .one
    tkwait visibility .one.f1.f2
    update idletasks; # finish displaying window
    _pause 200; # needed for Windows
    set result "|"
} -body {
    bind all <Leave> {append result "<Leave> %d %W|"}
    bind all <Enter> {append result "<Enter> %d %W|"}
    destroy .one.f1.f2
    update; # make sure window is gone
    destroy .one.f1

    bind all <Enter> {}
    unset result
} -result {|}

# cleanup
# macOS sometimes has trouble deleting the test window,
# causing a failure in focus.test.
_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 {}
rename setup_win_mousepointer {}

cleanupTests
return

# This file is a Tcl script to test out Tk's "tk_getOpenFile" and
# "tk_getSaveFile" commands. It is organized in the standard fashion
# for Tcl tests.
#
# Copyright © 1996 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

package require tcltest 2.2
eval tcltest::configure $argv
tcltest::loadTestedCommands




test fileDialog-0.1 {GetFileName: file types: MakeFilter() fails} {
    # MacOS type that is too long

    set res [list [catch {tk_getSaveFile -filetypes {{"foo" .foo {\0\0\0\0\0}}}} msg] $msg]
    regsub -all "\0" $res {\\0}
} {1 {bad Macintosh file type "\0\0\0\0\0"}}

#----------------------------------------------------------------------
#
# Procedures needed by this test file
#
#----------------------------------------------------------------------

proc ToPressButton {parent btn} {
    global isNative
    if {!$isNative} {
	after 100 SendButtonPress $parent $btn mouse
    }
}

proc ToEnterFileByKey {parent fileName fileDir} {
    global isNative
    if {!$isNative} {
	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 == "."} {
	set w .__tk_filedialog
    } else {
	set w $parent.__tk_filedialog
    }
    upvar ::tk::dialog::file::__tk_filedialog data

    if {$tk_strictMotif} {
	$data(sEnt) delete 0 end
	$data(sEnt) insert 0 [file join $fileDir $fileName]
    } else {
	$data(ent) delete 0 end
	$data(ent) insert 0 $fileName
    }

    update
    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
#
#----------------------------------------------------------------------

    test filebox-1.5-$mode "tk_getOpenFile command" -body {
	tk_getOpenFile -parent foo.bar
    } -returnCodes error -result {bad window path name "foo.bar"}
    test filebox-1.6-$mode "tk_getOpenFile command" -body {
	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:
    set verylongstring $verylongstring$verylongstring
    set verylongstring $verylongstring$verylongstring
    set verylongstring $verylongstring$verylongstring
    set verylongstring $verylongstring$verylongstring

    test filebox-4.5-$mode "tk_getSaveFile command" -body {
	tk_getSaveFile -parent foo.bar
    } -returnCodes error -result {bad window path name "foo.bar"}
    test filebox-4.6-$mode "tk_getSaveFile command" -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
    } ""

    set fileName "12x 455"
    set fileDir [pwd]

    # The rest of the tests need to be executed on Unix only.
    # They test whether the dialog box widgets were implemented correctly.
    # These tests are not
    # needed on the other platforms because they use native file dialogs.
}

set tk_strictMotif $tk_strictMotif_old



# cleanup

removeFile filebox.tmp

cleanupTests
return

# This file is a Tcl script to test out the "focus" command and the
# other procedures in the file tkFocus.c.  It is organized in the
# standard fashion for Tcl tests.
#
# Copyright © 1994-1996 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

package require tcltest 2.2
eval tcltest::configure $argv
tcltest::loadTestedCommands
namespace import -force tcltest::test
if {[tk windowingsystem] eq "aqua"} {
    interp create childInterp
    load {} Tk 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
    wm geom .t +0+0
    foreach i {b1 b2 b3 b4} {
	button .t.$i -text .t.$i -relief raised -bd 2
	pack .t.$i

		    break
		}
	    }
	}
    }
} else {
    proc focusClear {} {
	dobg {after 200; focus -force .; update}
	after 400
	update
    }
}


# Button used in some tests in the whole test file
button .b -text .b -relief raised -bd 2
pack .b

# Make sure the window manager knows who has focus
catch {fixfocus}

# cleanupbg will be after 4.3 test
setupbg
update
bind all <FocusIn> {
    append focusInfo "in %W %d\n"
}
bind all <FocusOut> {
    append focusInfo "out %W %d\n"
}

    unix
} -body {
    focus -displayof .lousy
} -returnCodes error -result {bad window path name ".lousy"}
test focus-1.12 {Tk_FocusCmd procedure, -displayof option} -constraints {
    unix
} -body {
    # Move focus to the root window in the child or bg interpreter.
    focusClear
    # The main application does not have focus, so this has no effect now.
    focus .t
    focus -displayof .t.b3
}  -result {}
test focus-1.13 {Tk_FocusCmd procedure, -displayof option} -constraints {
    unix

    list $focusInfo [focus]
} -result {{out . NotifyNonlinear
in .t NotifyNonlinearVirtual
in .t.b1 NotifyNonlinear
} .t.b1}

test focus-2.6 {TkFocusFilterEvent procedure, FocusIn events} -constraints {
    unix  testwrapper failsOnUbuntu failsOnXQuarz
} -body {
    focus .t.b1
    focus .
    update
    event gen [testwrapper .t] <FocusIn> -detail NotifyAncestor
    set focusInfo {}
    set x [focus]
    event gen . <x>
    list $x $focusInfo
} -result {.t.b1 {press .t.b1 x}}
test focus-2.7 {TkFocusFilterEvent procedure, FocusOut events} -constraints {
    unix  testwrapper failsOnUbuntu failsOnXQuarz
} -body {
    set result {}
    foreach detail {NotifyAncestor NotifyInferior NotifyNonlinear
	    NotifyNonlinearVirtual NotifyPointer NotifyPointerRoot
	    NotifyVirtual} {
	focus -force .t.b1
	event gen [testwrapper .t] <FocusOut> -detail $detail
	update
	lappend result [focus]
    }
    return $result
} -result {{} .t.b1 {} {} .t.b1 .t.b1 {}}
test focus-2.8 {TkFocusFilterEvent procedure, FocusOut events} -constraints {
    unix  testwrapper
} -body {
    focus -force .t.b1
    event gen .t.b1 <FocusOut> -detail NotifyAncestor
    focus
} -result {.t.b1}
test focus-2.9 {TkFocusFilterEvent procedure, FocusOut events} -constraints {
    unix  testwrapper failsOnUbuntu failsOnXQuarz
} -body {
    focus .t.b1
    event gen [testwrapper .] <FocusOut> -detail NotifyAncestor
    focus
} -result {}
test focus-2.10 {TkFocusFilterEvent procedure, Enter events} -constraints {
    unix  testwrapper

} -body {
    focusSetup
    focus -force .t.b2
    update
    destroy .t.b2
    focus
} -result {.t}
cleanupbg


# I don't know how to test most of the remaining procedures of this file
# explicitly;  they've already been exercised by the preceding tests.

# 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
} -body {
    setupbg
    focusSetup
    focus -force .t
    update
    set result [focus]
    send [dobg {tk appname}] {focus -force .; update}
    lappend result [focus]
    focus .t.b2
    update
    lappend result [focus]
} -cleanup {
    cleanupbg
} -result {.t {} {}}
destroy .t
bind all <FocusIn> {}
bind all <FocusOut> {}
bind all <Key> {}

    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}}}

test focus-6.2 {miscellaneous - embedded application in different process} -constraints {
    unix  testwrapper
} -body {
    setupbg
    toplevel .t
    wm geometry .t +0+0
    frame .t.f1 -container 1
    frame .t.f2
    pack .t.f1 .t.f2
    entry .t.f2.e1 -bg red
    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 {
	entry .e1 -bg lightBlue
	pack .e1
	bind all <FocusIn> {lappend x "focus in %W %d"}
	bind all <FocusOut> {lappend x "focus out %W %d"}
	set x {}
    }

    # Claim the focus and wait long enough for it to really arrive.

    focus -force .t.f2.e1
    after 300 {set timer 1}
    vwait timer
    set x {}
    lappend x [focus] [dobg focus]

    # See if a "focus" command will move the focus to the embedded
    # application.

    dobg {focus .e1}
    after 300 {set timer 1}
    vwait timer
    lappend x |
    dobg {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}]]
    return $result
} -cleanup {
    destroy .t
    cleanupbg
    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}}}

test focus-7.1 {TkSetFocusWin procedure, unmapped windows} -setup {
    # TkSetFocusWin handles the case of not yet mapped windows
    # by not setting the focus on them right at the time it is

	update
	focus -force .l;  # This line segfaulted *with xvfb*
	set res Reached
    }
    crashit
} -result {Reached}

deleteWindows



# cleanup


cleanupTests
if {[tk windowingsystem] eq "aqua"} {
    interp delete childInterp
}
return

# Test the "tk::fontchooser" command
#
# Copyright © 2008 Pat Thoyts

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
}

# -------------------------------------------------------------------------

test fontchooser-1.1 {tk fontchooser: usage} -returnCodes error -body {
    tk fontchooser -z
} -result {unknown or ambiguous subcommand "-z": must be configure, hide, or show}

# implementation. They can be tested by sourcing the script file but
# the Tk tests are run with -singleproc 1 and doing this affects the
# result of later attempts to test the native implementations.
#
testConstraint scriptImpl [llength [info proc ::tk::fontchooser::Configure]]

test fontchooser-2.0 {fontchooser -title} -constraints scriptImpl -body {
    start {
	tk::fontchooser::Configure -title "Hello"
	tk::fontchooser::Show
    }
    then {
	set x [wm title $::tk_dialog]
	Click cancel
    }
    set x
} -result {Hello}

test fontchooser-2.1 {fontchooser -title (cyrillic)} -constraints scriptImpl -body {
    start {
	tk::fontchooser::Configure \
	    -title "Привет"
	tk::fontchooser::Show
    }
    then {
	set x [wm title $::tk_dialog]
	Click cancel
    }
    set x
} -result "Привет"

test fontchooser-3.0 {fontchooser -parent} -constraints scriptImpl -body {
    start {
	tk::fontchooser::Configure -parent .
	tk::fontchooser::Show
    }
    then {
	set x [winfo parent $::tk_dialog]
	Click cancel
    }
    set x
} -result {.}

test fontchooser-3.1 {fontchooser -parent (invalid)} -constraints scriptImpl -body {
    tk::fontchooser::Configure -parent junk
} -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
	tk::fontchooser::Show
    }
    then {
	Click cancel
    }
    set ::testfont
} -result {}

test fontchooser-4.1 {fontchooser -font} -constraints scriptImpl -body {
    start {
	tk::fontchooser::Configure -command ApplyFont -font courier
	tk::fontchooser::Show
    }
    then {
	Click ok
    }
    expr {$::testfont ne {}}
} -result 1

test fontchooser-4.2 {fontchooser -font} -constraints scriptImpl -body {
    start {
	tk::fontchooser::Configure -command ApplyFont -font TkDefaultFont
	tk::fontchooser::Show
    }
    then {
	Click ok
    }
    expr {$::testfont ne {}}
} -result 1

test fontchooser-4.3 {fontchooser -font} -constraints scriptImpl -body {
    start {
	tk::fontchooser::Configure -command ApplyFont -font {times 14 bold}
	tk::fontchooser::Show
    }
    then {
	Click ok
    }
    expr {$::testfont ne {}}
} -result 1

test fontchooser-4.4 {fontchooser -font} -constraints {scriptImpl havePointsize14BoldFont} -body {
    start {
	tk::fontchooser::Configure -command ApplyFont -font {times 14 bold}
	tk::fontchooser::Show
    }
    then {
	Click ok
    }
    lrange $::testfont 1 end
} -result {14 bold}

test fontchooser-5.1 {fontchooser multiple configure} -constraints {scriptImpl} -body {
    tk fontchooser configure -title TestTitle -command foo
    tk fontchooser configure -command bar
    tk fontchooser configure -title
} -result {TestTitle}

# -------------------------------------------------------------------------






cleanupTests
return

# Local Variables:
# mode: tcl
# indent-tabs-mode: nil
# End:

# All rights reserved.

package require tcltest 2.2
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)}
}

# uniq --
#
# Returns the unique items of a list in the order they first appear.
#
# Arguments:
# list -		The list to uniq-ify.

   }
    after cancel $timer
    return [uniq $result]
} -cleanup {
    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
deleteWindows
apply {cmds {foreach cmd $cmds {rename $cmd {}}}} {
    eatColors colorsFree uniq optnames
}

cleanupTests
return

# Local Variables:
# mode: tcl
# End:

# This file is a Tcl script to test the procedures in the file
# tkGeometry.c (generic support for geometry managers).  It is
# organized in the standard fashion for Tcl tests.
#
# Copyright © 1994 The Regents of the University of California.
# Copyright © 1994 Sun Microsystems, Inc.
# 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
namespace import -force tcltest::test


wm geometry . 300x300

# All rights reserved.

package require tcltest 2.2
namespace import ::tcltest::*
eval tcltest::configure $argv
tcltest::loadTestedCommands




imageInit

# Canvas used in some tests in the whole file
canvas .c -highlightthickness 2
pack .c
update

    lappend x [imageNames]
    image create photo foo -width 20 -height 20
    lappend x [.c bbox i1] [imageNames]
} -cleanup {
    .c delete all
    imageCleanup
} -result {10 10 20 20 foo {} {10 10 30 30} foo}





destroy .c
imageFinish

# cleanup
cleanupTests
return

# Local variables:
# mode: tcl
# End:

# This file is a Tcl script to test out images of type "bitmap" (i.e.,
# the procedures in the file tkImgBmap.c).  It is organized in the
# standard fashion for Tcl tests.
#
# Copyright © 1994 The Regents of the University of California.
# Copyright © 1994-1995 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

package require tcltest 2.2
namespace import ::tcltest::*
eval tcltest::configure $argv
tcltest::loadTestedCommands




imageInit

set data1 {#define foo_width 16
#define foo_height 16
#define foo_x_hot 3
#define foo_y_hot 3
static unsigned char foo_bits[] = {

test imageBmap-12.1 {ImgBmapCmdDeletedProc procedure} -body {
    image create bitmap i2 -file foo.bm -maskfile foo2.bm
    rename i2 {}
    list [expr {"i2" in [imageNames]}] [catch {i2 foo} msg] $msg
} -result {0 1 {invalid command name "i2"}}





removeFile foo.bm
removeFile foo2.bm
imageFinish

# cleanup
cleanupTests
return

# Local Variables:
# mode: tcl
# fill-column: 78
# End:

# Author: Simon Bachmann ([email protected])

package require tcltest 2.2
namespace import ::tcltest::*
tcltest::configure {*}$argv
tcltest::loadTestedCommands




imageInit

set teapotPhotoFile [file join [file dirname [info script]] teapot.ppm]
set transpTeapotPhotoFile [file join [file dirname [info script]] teapotTransparent.png]

# ---------------------------------------------------------------------


test imgListFormat-1.1 {ParseFormatOptions: default values} -setup {
    image create photo photo1
} -body {
    photo1 put {{red green} {blue black}}
    lindex [photo1 data] 1 1
} -cleanup {
    imageCleanup

    lappend result [photo1 data -format {default -colorformat rgba}]
    lappend result [photo1 data -format {default -colorformat list}]
    set result
} -cleanup {
    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)
} -returnCodes error -result {unmatched open quote in list}
# empty data case tested with imgPhoto-4.95 (imgPhoto.test)
test imgListFormat-3.2 {StringMatchDef: \
	list element not a proper list} -body {

		{yellow magenta}
		{#000000 #FFFFFFFF}}
    list [image width photo1] [image height photo1] \
	[photo1 get 0 2 -withalpha]
} -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 {
    image create photo photo1
} -body {
    photo1 put white -format "default"
    photo1 get 0 0

    photo2 put #FF0000 -to 0 0 50 50
    photo2 put [photo1 data -format {default -colorformat rgba}] -to 10 10 40 40
    list [photo2 get 0 0 -withalpha] [photo2 get 20 25 -withalpha] \
	[photo2 get 49 49 -withalpha]
} -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 {
    photo1 data -format {default " bogus}
    # "
} -cleanup {
    imageCleanup

    lappend result [lindex $imgData 203 157]
    set result
} -cleanup {
    unset imgData
    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 {}
} -body {
    photo1 put {{"" ""} {"" ""}}
    lappend result [image width photo1]
    lappend result [image height photo1]

    unset result
} -result \
{{255 250 250 128} {255 250 250 128} {255 250 250 136} {255 250 250 128}\
{255 250 250 136} {255 250 250 128} {255 250 250 128} {255 250 250 136}\
{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.
test imgListFormat-7.1 {ParseColorAsList: invalid list} -setup {
    image create photo photo1
} -body {
    photo1 put {{{123 45 67 89} {123 45 " 67}}}

	image create photo photo1
} -body {
	photo1 put {{"111 222 33 44"}}
	photo1 get 0 0 -withalpha
} -cleanup {
	imageCleanup
} -result {111 222 33 44}

test imgListFormat-8.1 {ParseColorAsHex: RGB format} -setup {
    image create photo photo1
} -body {
    photo1 put {{#010 #001100}}
    photo1 data
} -cleanup {
    imageCleanup

    image create photo photo1
} -body {
    photo1 put {{#9bd5020d #7acF}}
    list [photo1 get 0 0 -withalpha] [photo1 get 1 0 -withalpha]
} -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
    set result {}
} -body {
    photo1 put {{[email protected] #114433#C} {#8D4#1A magenta}}
    lappend result [photo1 get 0 0 -withalpha]

    image create photo photo1
} -body {
    photo1 put {#1111 #1111#1}
} -cleanup {
    imageCleanup
} -returnCodes error -result {invalid color name "#1111#1"}


# ---------------------------------------------------------------------


imageFinish

# cleanup
cleanupTests
return

# Copyright © 2008 Donal K. Fellows
# All rights reserved.

package require tcltest 2.2
namespace import ::tcltest::*
eval tcltest::configure $argv
tcltest::loadTestedCommands




imageInit

namespace eval png {
    variable encoded
    # Key names are from the names of the source images, which come from
    #    http://www.schaik.com/pngsuite/pngsuite.html
    # The exception is "BadX", which is used to test handling badly compressed

fBcxKuQMrzfLdBoz29fX9led5v6u1XnBJW7vnr/YlrXEoNo22LRYOYlxZ1S6rkOfDcLvPAY/hGmWC7
H68uFI+x0oSPg2MAN/L5/M/vtqSED/T5cMu9J4Wf7HMGsB/4TEv/DFwe3Y/NPN57VXh+5BWApwFLlh
r661tV1eju/ne8YJrkWtES0tmRe2VOviv2j2aBp5nHihiRaz/A4oCnsAsje/+AAAAAElFTkSuQmCC"
    dpi100aspect2
"iVBORw0KGgoAAAANSUhEUgAAAAIAAAACCAIAAAD91JpzAAAACXBIWXMAAA9hAAAewgEw8YEEAAAA
FklEQVR4nGP4+vXrP11lJgYGhj9xSQAzOwXsETZ69QAAAABJRU5ErkJggg=="
	}

# $encoded(basn0g08), $encoded(basn2c08), $encoded(basn3p08), $encoded(basn6a08)
test imgPNG-1.1 {reading basic images; grayscale} -setup {
    catch {rename foo ""}
} -body {
    image create photo foo -data $encoded(basn0g08)
    list [image width foo] [image height foo]
} -cleanup {

    i1 cget -metadata
} -cleanup {
    image delete i1
    file delete $path
} -result {DPI 99.9998 aspect 2.0}

}





namespace delete png
imageFinish

cleanupTests
return

# Local Variables:
# mode: tcl
# fill-column: 78
# End:

# This file is a Tcl script to test out the code in tkImgFmtPPM.c,
# which reads and write PPM-format image files for photo widgets.
# The files is organized in the standard fashion for Tcl tests.
#
# Copyright © 1994-1997 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

package require tcltest 2.2
namespace import ::tcltest::*
eval tcltest::configure $argv
tcltest::loadTestedCommands




imageInit

# Note that we do not use [tcltest::makeFile] because it is
# only suitable for text files
proc put {file data} {
    set f [open $file w]
    fconfigure $f -translation lf
    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
} -returnCodes error -result {PPM image file "test.ppm" has dimension(s) <= 0}
test imgPPM-1.2 {FileReadPPM procedure} -body {
    put test.ppm "P6\n-2 256\n255\nabcdef"
    image create photo p1 -file test.ppm

    image create photo ppm
} -body {
    ppm put "P6\n5 4\n150\n012345678901234567890123456789012345678901234567890123456789"
    list [image width ppm] [image height ppm]
} -cleanup {
    image delete ppm
} -result {5 4}

imageFinish



# cleanup

catch {file delete test.ppm}

cleanupTests
return

# Local Variables:
# mode: tcl
# End:

#

package require tcltest 2.2
namespace import ::tcltest::*
tcltest::configure {*}$argv
tcltest::loadTestedCommands




#
# Used for imgPhoto-4.65 - imgPhoto-4.73
#
proc foreachPixel {img xVar yVar script} {
    upvar 1 $xVar x $yVar y
    set width [image width $img]
    set height [image height $img]

    photo1 get 1 0 -withalpha
} -cleanup {
    imageCleanup
} -result {0 128 0 255}
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 {
    catch {image create photo -blah blah}
    imageNames
} -result {}
test imgPhoto-2.2 {ImgPhotoCreate procedure} -setup {

    image create photo photo2
} -body {
    photo2 configure -data [photo1 data -from 80 90 100 110]
    list [image width photo2] [image height photo2]
} -cleanup {
    imageCleanup
} -result {20 20}

test imgPhoto-4.1 {ImgPhotoCmd procedure} -setup {
    image create photo photo1
} -body {
    photo1
} -returnCodes error -cleanup {
    image delete photo1
} -result {wrong # args: should be "photo1 option ?arg ...?"}

    }
    set result
} -cleanup {
    unset imgData
    unset result
    imageCleanup
} -result {}

test imgPhoto-5.1 {ImgPhotoGet/Free procedures, shared instances} -setup {
    destroy .c
    pack [canvas .c]
    imageCleanup
} -body {
    image create photo photo1 -file $teapotPhotoFile
    .c create image 0 0 -image photo1 -tags photo1.1

} -body {
    photo1 read $f -format default
} -cleanup {
    imageCleanup
    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 {
    photo1 put {{red blue red} {yellow green yellow}} -format default
    list [image width photo1] [image height photo1]
} -cleanup {
    imageCleanup

    image create photo png1
    catch {png1 read $ousterPhotoFile -from 102 62 2000 1000} msg
    list $msg [image width png1] [image height png1]
} -cleanup {
    catch {image delete png1}
} -result {{coordinates for -from option extend outside source image} 0 0}
unset ousterPhotoFile





catch {rename foreachPixel {}}
catch {rename checkImgTrans {}}
catch {rename checkImgTransLoop {}}
imageFinish


# cleanup
removeFile README-imgPhoto
cleanupTests
return

# Local variables:
# mode: tcl
# End:

# This file is a Tcl script to test out the code in tkImgSVGnano.c, which reads
# and write SVG-format image files for photo widgets. The files is organized
# in the standard fashion for Tcl tests.
#
# Copyright © 2018 Rene Zaumseil
# All rights reserved.

package require tcltest 2.2
namespace import ::tcltest::*
eval tcltest::configure $argv
tcltest::loadTestedCommands




imageInit

namespace eval svgnano {

    variable data

    set data(plus) {\

			</g></svg>}
} -returnCodes error -result {couldn't recognize image data}

    tcltest::removeFile plus.svg
    tcltest::removeFile bad.svg

};# end of namespace svgnano





namespace delete svgnano
imageFinish

cleanupTests
return

# Local Variables:
# mode: tcl
# fill-column: 78
# End:

    }}}
    pack .b
    bind .b <Configure> {unset -nocomplain var}
    update
    destroy .b
    unset new
} {}





resetGridInfo
deleteWindows
option clear

# cleanup
cleanupTests
return

# This file is a Tcl script to test menus in Tk.  It is
# organized in the standard fashion for Tcl tests.
#
# Copyright © 1995-1997 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

package require tcltest 2.2
namespace import ::tcltest::*
eval tcltest::configure $argv
tcltest::loadTestedCommands




imageInit


test menu-1.1 {Tk_MenuCmd procedure} -body {
    menu
} -returnCodes error -result {wrong # args: should be "menu pathName ?-option value ...?"}
test menu-1.2 {Tk_MenuCmd procedure} -body {

    .m add command -label 2
    .m add command -label 3
    .m index last
} -cleanup {
    destroy .m
} -result {2}




# cleanup
imageFinish
deleteWindows

cleanupTests
return

# Local variables:
# mode: tcl
# End:

# This file is a Tcl script to test drawing of menus in Tk.  It is
# organized in the standard fashion for Tcl tests.
#
# Copyright © 1996-1997 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

package require tcltest 2.2
eval tcltest::configure $argv
tcltest::loadTestedCommands
namespace import -force tcltest::test




imageInit

test menuDraw-1.1 {TkMenuInitializeDrawingFields} -setup {
    deleteWindows
} -body {
    menu .m1
} -cleanup {

    .m2 add command -label "Hit ESCAPE to make this menu go away"
    set tearoff [tk::TearOffMenu .m1 40 40]
    $tearoff postcascade 0
} -cleanup {
    deleteWindows
} -result {}




# cleanup
imageFinish
deleteWindows

cleanupTests
return

# Local variables:
# mode: tcl
# End:

# XXX of a procedure has tests then the whole procedure has tests,
# XXX but many procedures have no tests.

package require tcltest 2.2
eval tcltest::configure $argv
tcltest::loadTestedCommands
namespace import -force tcltest::test




imageInit

# Create entries in the option database to be sure that geometry options
# like border width have predictable values.

option add *Menubutton.borderWidth 2
option add *Menubutton.highlightThickness 2

    pack .b
    bind .b <Configure> {unset -nocomplain var}
    update
    destroy .b
    unset new
} {}





deleteWindows
option clear
imageFinish

# cleanup
cleanupTests
return

# Local variables:
# mode: tcl
# End:

# This file is a Tcl script to test out Tk's "tk_messageBox" command.
# It is organized in the standard fashion for Tcl tests.
#
# Copyright © 1996 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

package require tcltest 2.2
eval tcltest::configure $argv
tcltest::loadTestedCommands
namespace import -force tcltest::test




test msgbox-1.1.1 {tk_messageBox command} -constraints notAqua -body {
    tk_messageBox -foo
} -returnCodes error -result {bad option "-foo": must be -default, -detail, -icon, -message, -parent, -title, or -type}
test msgbox-1.1.2 {tk_messageBox command} -constraints aqua -body {
    tk_messageBox -foo
} -returnCodes error -result {bad option "-foo": must be -default, -detail, -icon, -message, -parent, -title, -type, or -command}

} -returnCodes error -result {bad -icon value "foo": must be error, info, question, or warning}

test msgbox-1.19 {tk_messageBox command} -body {
    tk_messageBox -parent foo.bar
} -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
    }
}

proc ChooseMsgByKey {parent btn} {
    global isNative
    if {!$isNative} {
	after 100 SendEventToMsg $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).
#
test msgbox-2.1 {tk_messageBox command} -constraints {
    nonUnixUserInteraction
} -body {

    ChooseMsg . "ok"
    tk_messageBox -title Hi -message "Please press ok" \
	    -type ok -default ok
} -cleanup {
    wm deiconify .
} -result {ok}




# cleanup

cleanupTests
return

# This file is a Tcl script to test out the "pack" command of Tk.  It is
# organized in the standard fashion for Tcl tests.
#
# Copyright © 1993 The Regents of the University of California.
# Copyright © 1994 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

package require tcltest 2.2
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
toplevel .pack
wm geom .pack 300x200+0+0
wm minsize .pack 1 1
update idletasks

    winfo manager .pack.a
    winfo geometry .pack.a
    pack info .pack.a
} -returnCodes error -result {window ".pack.a" isn't packed}

# 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
# 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
# waiting for the MapNotify event that should show up when running
# 'wm iconify'. The timeout delay (2s) is exceeded without the unmapping
# having happened. The cause for this is unknown (see comments in WaitForMapNotify).

# account on window remapping.
#
# While these tests pass on macOS, one can see by watching the tests
# that the window .pack is sometimes black, even though the frame is
# 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
} -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
    # as the screen (screen switch causes scale and other tests to fail).
    wm geometry .pack +100+100
} -body {

    update
    wm deiconify .pack
    update
    lappend result [winfo width .pack.a] [winfo height .pack.a]
    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 {
    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
    # as the screen (screen switch causes scale and other tests to fail).
    wm geometry .pack +100+100
} -body {
    frame .pack.a -relief raised -bd 2 -bg green

    pack forget .1
    update
    info exists A
} -cleanup {
    bind . <<NoManagedChild>> {}
    destroy .1
} -result 0

# cleanup
cleanupTests
return

# Local Variables:
# mode: tcl
# End:

namespace import ::tcltest::*
eval tcltest::configure $argv
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.

# Widgets used in tests 1.* - 8.*
toplevel .t -width 300 -height 200 -bd 0
wm geom .t +0+0
frame .t.f -width 154 -height 84 -bd 2 -relief raised

    place .t.f2 -width {} -relwidth {} -height {} -relheight {}
    update
    list [winfo width .t.f2] [winfo height .t.f2]
} -result {30 60}

# 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
# 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
# waiting for the MapNotify event that should show up when running
# '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 {
    place forget .t.f2
    place forget .t.f
} -body {
    place .t.f2 -relx 1.0 -rely 1.0 -anchor sw
    update
    set result [winfo ismapped .t.f2]
    wm iconify .t
    lappend result [winfo ismapped .t.f2]
    place .t.f2 -x 40 -y 30 -relx 0 -rely 0 -anchor nw
    update
    lappend result [winfo x .t.f2] [winfo y .t.f2] [winfo ismapped .t.f2]
    wm deiconify .t
    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 {
    place forget .t.f2
    place forget .t.f
} -body {
    place .t.f -x 0 -y 0 -width 200 -height 100
    place .t.f2 -in .t.f -relx 1.0 -rely 1.0 -anchor sw -width 50 -height 20
    update
    set result [winfo ismapped .t.f2]

# This file is a Tcl script to test out scrollbar widgets and
# the "scrollbar" command of Tk.  It is organized in the standard
# fashion for Tcl tests.
#
# Copyright © 1994 The Regents of the University of California.
# Copyright © 1994-1997 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

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]
	if [string match v* [$w cget -orient]] {
	    return [expr {[winfo height $w] - 2*[testmetrics cyvscroll $w]}]
	} else {
	    return [expr {[winfo width $w] - 2*[testmetrics cxhscroll $w]}]

    catch {destroy .s}
} -body {
    scrollbar .s
} -cleanup {
    destroy .s
} -result .s

scrollbar .s -orient vertical -command scroll -highlightthickness 2 -bd 2
pack .s -side right -fill y
update
test scrollbar-3.1 {ScrollbarWidgetCmd procedure} {
    list [catch {.s} msg] $msg
} {1 {wrong # args: should be ".s option ?arg ...?"}}
test scrollbar-3.2 {ScrollbarWidgetCmd procedure, "cget" option} {
    list [catch {.s cget} msg] $msg

#
# Note: Multiple display selection handling will only be tested if the
# environment variable TK_ALT_DISPLAY is set to an alternate display.
#

package require tcltest 2.2
namespace import ::tcltest::*
namespace import ::tk::test:loadTkCommand
eval tcltest::configure $argv
tcltest::loadTestedCommands




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} {
    set j $i.1$i.2$i.3$i.4$i.5$i.6$i.7$i.8$i.9$i.10$i.11$i.12$i.13$i.14
    append longValue A$j B$j C$j D$j E$j F$j G$j H$j I$j K$j L$j M$j N$j
}

# Now we start the main body of the test code

test select-1.1 {Tk_CreateSelHandler procedure} -setup {
    setup
} -body {
    lsort [selection get TARGETS]
} -result {MULTIPLE TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW}
test select-1.2 {Tk_CreateSelHandler procedure} -setup {
    setup
} -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
} -body {
    selection handle .f1 {handler TEST} TEST
    set selValue "Test value"
    set selInfo ""
    list [selection get TEST] $selInfo
} -result {{Test value} {TEST 0 4000}}
test select-1.4.1 {Tk_CreateSelHandler procedure} -constraints unix -setup {
    setup
} -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
} -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
} -body {
    selection handle .f1 {handler TEST} TEST
    selection handle .f1 {handler STRING}
    set selValue ""
    set selInfo ""
    list [selection get] $selInfo
} -result {{} {STRING 0 4000}}
test select-1.6.1 {Tk_CreateSelHandler procedure} -constraints unix -setup {
    global selValue selInfo
    setup
} -body {
    selection handle .f1 {handler TEST} TEST
    selection handle .f1 {handler STRING}
    set selValue ""
    set selInfo ""
    selection get
    selection get -type TEST
    selection handle .f1 {handler TEST2} TEST
    selection get -type TEST
    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
} -body {
    selection handle .f1 {handler TEST} TEST
    selection handle .f1 {handler STRING}
    set selValue ""
    set selInfo ""
    selection get
    selection get -type TEST
    selection handle .f1 {handler TEST2} TEST
    selection get -type TEST
    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
} -body {
    selection own -selection CLIPBOARD .f1
    selection handle -selection CLIPBOARD .f1 {handler TEST} TEST
    selection handle -selection PRIMARY .f1 {handler TEST2} STRING
    list [lsort [selection get -selection PRIMARY TARGETS]] \
	[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
} -body {
    selection own -selection CLIPBOARD .f1
    selection handle -selection CLIPBOARD .f1 {handler TEST} TEST
    selection handle -selection PRIMARY .f1 {handler TEST2} STRING
    list [lsort [selection get -selection PRIMARY TARGETS]] \
	[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
} -body {
    selection handle -format INTEGER -type TEST .f1 {handler TEST}
    lsort [selection get TARGETS]
} -result {MULTIPLE TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW}

##############################################################################

test select-2.1 {Tk_DeleteSelHandler procedure} -constraints unix -setup {
    setup
} -body {
    selection handle .f1 {handler STRING}
    selection handle -type TEST .f1 {handler TEST}
    selection handle -type USER .f1 {handler USER}
    set result [list [lsort [selection get TARGETS]]]
    selection handle -type TEST .f1 {}
    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
} -body {
    selection handle .f1 {handler STRING}
    selection handle -type TEST .f1 {handler TEST}
    selection handle -type USER .f1 {handler USER}
    set result [list [lsort [selection get TARGETS]]]
    selection handle -type USER .f1 {}
    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
} -body {
    selection own -selection CLIPBOARD .f1
    selection handle -selection PRIMARY .f1 {handler STRING}
    selection handle -selection CLIPBOARD .f1 {handler STRING}
    selection handle -selection CLIPBOARD .f1 {}
    list [lsort [selection get TARGETS]] \
	[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
} -body {
    selection handle .f1 {handler STRING}
    selection handle -type TEST .f1 {handler TEST}
    selection handle -type USER .f1 {handler USER}
    set result [list [lsort [selection get TARGETS]]]
    selection handle -type TEST .f1 {}
    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
} -body {
    selection handle .f1 {handler STRING}
    selection handle -type TEST .f1 {handler TEST}
    selection handle -type USER .f1 {handler USER}
    set result [list [lsort [selection get TARGETS]]]
    selection handle -type USER .f1 {}
    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
} -body {
    selection own -selection CLIPBOARD .f1
    selection handle -selection PRIMARY .f1 {handler STRING}
    selection handle -selection CLIPBOARD .f1 {handler STRING}
    selection handle -selection CLIPBOARD .f1 {}
    list [lsort [selection get TARGETS]] \
	[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
} -body {
    selection handle .f1 {handler STRING}
    list [selection handle .f1 {}] [selection handle .f1 {}]
} -result {{} {}}

##############################################################################

test select-3.1 {Tk_OwnSelection procedure} -setup {
    setup
} -body {
    selection own
} -result {.f1}
test select-3.2 {Tk_OwnSelection procedure} -body {
    setup .f1
    set result [selection own]
    setup .f2
    lappend result [selection own]
} -result {.f1 .f2}
test select-3.3 {Tk_OwnSelection procedure} -setup {
    setup .f1
    setup .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
} -body {
    set lostSel {owned}
    selection own -command { set lostSel {lost} } .f1
    selection clear .f1
    set lostSel
} -result {lost}
test select-3.5 {Tk_OwnSelection procedure} -setup {
    global lostSel
    setup .f1
    setup .f2
} -body {
    set lostSel {owned}
    selection own -command { set lostSel {lost1} } .f1
    selection own -command { set lostSel {lost2} } .f2
    list $lostSel [selection own]
} -result {lost1 .f2}
test select-3.6 {Tk_OwnSelection procedure} -setup {
    global lostSel
    setup
} -body {
    set lostSel {owned}
    selection own -command { set lostSel {lost1} } .f1
    selection own -command { set lostSel {lost2} } .f1
    set result $lostSel
    selection clear .f1
    lappend result $lostSel
} -result {owned lost2}
test select-3.7 {Tk_OwnSelection procedure} -constraints x11 -setup {
    global lostSel
    setup
    setupbg
} -body {
    set lostSel {owned}
    selection own -command { set lostSel {lost1} } .f1
    update
    set result {}
    lappend result [dobg { selection own . }]
    lappend result [dobg {selection own}]
    update
    cleanupbg
    lappend result $lostSel
} -result {{} . lost1}
# check reentrancy on selection replacement
test select-3.8 {Tk_OwnSelection procedure} -setup {
    setup
} -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
} -body {
    selection own -selection CLIPBOARD -command { destroy .f2 } .f1
    selection own -selection CLIPBOARD .f2
} -result {}
# multiple display tests
test select-3.10 {Tk_OwnSelection procedure} -constraints {
    altDisplay
} -body {
    setup .f1
    setup .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
    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 [selection own -displayof .f1] \
	    [selection own -displayof .f2]
} -cleanup {
    cleanupbg
} -result {{} .f1 {}}

##############################################################################

test select-4.1 {Tk_ClearSelection procedure} -setup {
    setup
} -body {
    set result [selection own]
    selection clear .f1
    lappend result [selection own]
} -result {.f1 {}}
test select-4.2 {Tk_ClearSelection procedure} -setup {
    setup
} -body {
    selection own -selection CLIPBOARD .f1
    selection clear .f1
    selection own -selection CLIPBOARD
} -result {.f1}
test select-4.3 {Tk_ClearSelection procedure} -setup {
    setup
} -body {
    list [selection clear .f1] [selection clear .f1]
} -result {{} {}}
test select-4.4 {Tk_ClearSelection procedure} -constraints x11 -setup {
    global lostSel
    setup
    setupbg
} -body {
    set lostSel {owned}
    selection own -command { set lostSel {lost1} } .f1
    update
    set result {}
    lappend result [dobg {selection clear; update}]
    update
    cleanupbg
    lappend result [selection own]
} -result {{} {}}
# multiple display tests
test select-4.5 {Tk_ClearSelection procedure} -constraints {
    altDisplay
} -setup {
    global lostSel lostSel2
    setup .f1
    setup .f2 $env(TK_ALT_DISPLAY)
} -body {
    set lostSel {owned}
    set lostSel2 {owned2}
    selection own -command { set lostSel {lost1} } .f1
    selection own -command { set lostSel2 {lost2} } .f2
    update
    selection clear -displayof .f2
    update
    list $lostSel $lostSel2
} -result {owned lost2}
test select-4.6 {Tk_ClearSelection procedure} -constraints {
    x11 altDisplay
} -setup {
    setup .f1
    setup .f2 $env(TK_ALT_DISPLAY)
    setupbg
} -body {
    set lostSel {owned}
    set lostSel2 {owned2}
    selection own -command { set lostSel {lost1} } .f1
    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 [selection own -displayof .f1] \
	    [selection own -displayof .f2] $lostSel $lostSel2
    cleanupbg
    set result
} -result {{} .f1 {} owned lost2}

##############################################################################

test select-5.1 {Tk_GetSelection procedure} -returnCodes error -setup {
    setup
} -body {
    selection get TEST
} -result {PRIMARY selection doesn't exist or form "TEST" not defined}
test select-5.2 {Tk_GetSelection procedure} -setup {
    setup
} -body {
    selection get TK_WINDOW
} -result {.f1}
test select-5.3 {Tk_GetSelection procedure} -setup {
    setup
} -body {
    selection handle -selection PRIMARY .f1 {handler TEST} TEST
    set selValue "Test value"
    set selInfo ""
    list [selection get TEST] $selInfo
} -result {{Test value} {TEST 0 4000}}
test select-5.4 {Tk_GetSelection procedure} -setup {
    setup
} -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
} -body {
    set selValue $longValue
    set selInfo ""
    selection handle .f1 {handler STRING}
    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
} -returnCodes error -body {
    set selValue $longValue
    set selInfo ""
    selection handle .f1 {apply {{type offset count} {
	selection handle .f1 {}
	handler $type $offset $count
    }} STRING}
    selection get
} -result {PRIMARY selection doesn't exist or form "STRING" not defined}
test select-5.7 {Tk_GetSelection procedure} -setup {
    setup
} -returnCodes error -body {
    set selValue "Test Value"
    set selInfo ""
    selection handle .f1 {apply {{type offset count} {
	destroy .f1
	handler $type $offset $count
    }} STRING}
    selection get
} -result {PRIMARY selection doesn't exist or form "STRING" not defined}
test select-5.8 {Tk_GetSelection procedure} -setup {
    setup
} -body {
    set selValue $longValue
    set selInfo ""
    selection handle .f1 {apply {{type offset count} {
	selection clear
	handler $type $offset $count
    }} STRING}
    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
} -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 $selInfo
} -result {{Test value} {TEST 0 4000}}
test select-5.10 {Tk_GetSelection procedure} -constraints x11 -setup {
    setup
    setupbg
} -body {
    selection handle -selection PRIMARY .f1 {handler TEST} TEST
    update
    set selValue "Test value"
    set selInfo ""
    selection own .f1
    set result ""
    lappend result [dobg {selection get TEST} 1]
    cleanupbg
    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)
} -body {
    selection handle -selection PRIMARY .f1 {handler TEST} TEST
    selection handle -selection PRIMARY .f2 {handler TEST2} TEST
    set selValue "Test value"
    set selInfo ""
    set result [list [selection get TEST] $selInfo]
    set selValue "Test value2"
    set selInfo ""
    lappend result [selection get -displayof .f2 TEST] $selInfo
} -result {{Test value} {TEST 0 4000} {Test value2} {TEST2 0 4000}}
test select-5.12 {Tk_GetSelection procedure} -constraints {
    altDisplay
} -setup {
    global lostSel lostSel2
    setup .f1
    setup .f2 $env(TK_ALT_DISPLAY)
} -body {
    selection handle -selection PRIMARY .f1 {handler TEST} TEST
    selection handle -selection PRIMARY .f2 {} TEST
    set selValue "Test value"
    set selInfo ""
    set result [list [catch {selection get TEST} msg] $msg $selInfo]
    set selValue "Test value2"
    set selInfo ""
    lappend result [catch {selection get -displayof .f2 TEST} msg] $msg \
	    $selInfo
} -result {0 {Test value} {TEST 0 4000} 1 {PRIMARY selection doesn't exist or form "TEST" not defined} {}}
test select-5.13 {Tk_GetSelection procedure} -constraints {
    x11 altDisplay
} -setup {
    setup .f1
    setup .f2 $env(TK_ALT_DISPLAY)
    setupbg
} -body {
    selection handle -selection PRIMARY .f1 {handler TEST} TEST
    selection own .f1
    selection handle -selection PRIMARY .f2 {handler TEST2} TEST
    selection own .f2
    set selValue "Test value"
    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"]
    set selValue "Test value2"
    lappend result [dobg "selection get TEST"]
    cleanupbg
    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
} -body {
    selection handle -selection PRIMARY .f1 {handler TEST} TEST
    selection own .f1
    selection handle -selection PRIMARY .f2 {} TEST
    selection own .f2
    set selValue "Test value"
    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"]
    set selValue "Test value2"
    lappend result [dobg "selection get TEST"]
    cleanupbg
    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
    if {[llength [info command ::bgerror]]} {
	rename ::bgerror ::TMPbgerror
    }
    set ::bgerrors {}
} -body {
    proc ::bgerror msg {lappend ::bgerrors $msg}
    selection handle -type ERROR .f1 errHandler

    selection
} -result {wrong # args: should be "selection option ?arg ...?"}
# selection clear
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
} -body {
    selection own .
    set result [selection own]
    selection clear -displayof .f1
    lappend result [selection own]
} -result {. {}}
test select-6.4 {Tk_SelectionCmd procedure} -setup {
    setup
} -body {
    selection own -selection CLIPBOARD .f1
    set result [list [selection own] [selection own -selection CLIPBOARD]]
    selection clear -selection CLIPBOARD .f1
    lappend result [selection own] [selection own -selection CLIPBOARD]
} -result {.f1 .f1 .f1 {}}
test select-6.5 {Tk_SelectionCmd procedure} -setup {
    setup
} -body {
    selection own -selection CLIPBOARD .
    set result [list [selection own] [selection own -selection CLIPBOARD]]
    selection clear -selection CLIPBOARD -displayof .f1
    lappend result [selection own] [selection own -selection CLIPBOARD]
} -result {.f1 . .f1 {}}
test select-6.6 {Tk_SelectionCmd procedure} -returnCodes error -body {

    selection clear -displayof .f2
} -returnCodes error -result {bad window path name ".f2"}
test select-6.9 {Tk_SelectionCmd procedure} -body {
    destroy .f2
    selection clear .f2
} -returnCodes error -result {bad window path name ".f2"}
test select-6.10 {Tk_SelectionCmd procedure} -setup {
    setup
} -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
} -body {
    selection own -selection CLIPBOARD .f1
    set result [selection own -selection CLIPBOARD]
    selection clear -selection CLIPBOARD
    lappend result [selection own -selection CLIPBOARD]
} -result {.f1 {}}
test select-6.12 {Tk_SelectionCmd procedure} -returnCodes error -body {
    selection clear foo bar
} -result {wrong # args: should be "selection clear ?-option value ...?"}
# selection get
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
} -body {
    selection handle .f1 {handler TEST}
    set selValue "Test value"
    set selInfo ""
    list [selection get -displayof .f1] $selInfo
} -result {{Test value} {TEST 0 4000}}
test select-6.15 {Tk_SelectionCmd procedure} -setup {
    global selValue selInfo
    setup
} -body {
    selection handle .f1 {handler STRING}
    selection handle -selection CLIPBOARD .f1 {handler TEST}
    selection own -selection CLIPBOARD .f1
    set selValue "Test value"
    set selInfo ""
    list [selection get -selection CLIPBOARD] $selInfo
} -result {{Test value} {TEST 0 4000}}
test select-6.16 {Tk_SelectionCmd procedure} -setup {
    global selValue selInfo
    setup
} -body {
    selection handle -type TEST .f1 {handler TEST}
    selection handle -type STRING .f1 {handler STRING}
    set selValue "Test value"
    set selInfo ""
    list [selection get -type TEST] $selInfo
} -result {{Test value} {TEST 0 4000}}

    catch { destroy .f2 }
    selection get -displayof .f2
} -returnCodes error -result {bad window path name ".f2"}
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
} -body {
    selection handle -type TEST .f1 {handler TEST}
    selection handle -type STRING .f1 {handler STRING}
    set selValue "Test value"
    set selInfo ""
    list [selection get TEST] $selInfo
} -result {{Test value} {TEST 0 4000}}
# selection handle
# most of the handle section has been covered earlier
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
} -body {
    set selValue "Test value"
    set selInfo ""
    list [selection handle -format INTEGER .f1 {handler TEST}] [selection get -displayof .f1] $selInfo
} -result {{} {Test value} {TEST 0 4000}}
test select-6.24 {Tk_SelectionCmd procedure} -returnCodes error -body {
    selection handle -badopt foo

    selection handle .f2 dummy
} -returnCodes error -result {bad window path name ".f2"}
# selection own
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
} -body {
    selection own .
    selection own -displayof .f1
} -result {.}
test select-6.32 {Tk_SelectionCmd procedure} -setup {
    setup
} -body {
    selection own .
    selection own -selection CLIPBOARD .f1
    list [selection own] [selection own -selection CLIPBOARD]
} -result {. .f1}
test select-6.33 {Tk_SelectionCmd procedure} -setup {
    global lostSel
    setup
} -body {
    set lostSel owned
    selection own -command { set lostSel lost } .
    selection own -selection CLIPBOARD .f1
    set result $lostSel
    selection own .f1
    lappend result $lostSel

##############################################################################

# This test is non-portable because some old X11/News servers ignore a
# selection request when the window doesn't exist, which causes a different
# error message.
test select-7.1 {TkSelDeadWindow procedure} -constraints nonPortable -setup {
    setup
} -body {
    selection handle .f1 { handler TEST }
    set result [selection own]
    destroy .f1
    lappend result [selection own] [catch {selection get} msg] $msg
} -result {.f1 {} 1 {PRIMARY selection doesn't exist or form "STRING" not defined}}

##############################################################################

# Check reentrancy on losing selection
test select-8.1 {TkSelEventProc procedure} -constraints x11 -setup {
    setup
    setupbg
} -body {
    selection own -selection CLIPBOARD -command {destroy .f1} .f1
    update
    dobg {selection own -selection CLIPBOARD .}
    winfo children .
} -cleanup {
    cleanupbg
} -result {}

##############################################################################

test select-9.1 {SelCvtToX and SelCvtFromX procedures} -setup {
    setup
    setupbg
} -constraints x11 -body {
    set selValue "1024"
    set selInfo ""
    selection handle -selection PRIMARY -format INTEGER -type TEST \
	.f1 {handler TEST}
    update
    set result ""
    lappend result [dobg {selection get TEST}]
    cleanupbg
    lappend result $selInfo
} -result {{0x400 } {TEST 0 4000}}
test select-9.2 {SelCvtToX and SelCvtFromX procedures} -setup {
    setup
    setupbg
} -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 $selInfo
} -result {{0x400 0xffff 0x800 0xfffffffe } {TEST 0 4000}}
test select-9.3 {SelCvtToX and SelCvtFromX procedures} -setup {
    setup
    setupbg
} -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 $selInfo
} -result {{ } {TEST 0 4000}}
test select-9.4 {SelCvtToX and SelCvtFromX procedures} -setup {
    setup
    setupbg
} -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 $selInfo
} -result {{0x10 0x0 0x20 } {TEST 0 4000}}
test select-9.5 {SelCvtToX and SelCvtFromX procedures} -setup {
    setup
    setupbg
} -constraints x11 -body {
    # Ensure that lists of atoms are constructed correctly, even when the
    # atom names have spaces in. [Bug 1353414]
    set selValue "foo bar"
    set selInfo ""
    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}]
} -cleanup {
    cleanupbg
} -result {MULTIPLE TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW {text/x-tk-test;detail="foo bar"}}

##############################################################################
# note, we are not testing MULTIPLE style selections

# most control paths have been exercised above
test select-10.1 {ConvertSelection procedure, race with selection clear} -constraints {
    x11
} -setup {
    setup
} -body {
    proc Ready {fd} {
	variable x
	lappend x [gets $fd]
    }
    set fd [open "|[list [interpreter] -geometry +0+0 -name tktest]" r+]
    puts $fd "puts foo; [loadTkCommand]; flush stdout"

    flush $fd
    # Don't understand why, but the [loadTkCommand] above causes
    # a "broken pipe" error when Tk was actually [load]ed in the child.
    catch {close $fd}
    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
} -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 $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
} -body {
    selection handle .f1 ERROR errHandler
    dobg {selection get ERROR}
} -cleanup {
    cleanupbg
} -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
} -body {
    set selValue $longValue
    set selInfo ""
    selection handle .f1 {errIncrHandler STRING}
    set result ""
    set pass 0
    lappend result [dobg {selection get}]
    cleanupbg
    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
} -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 $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
} -body {
    proc weirdHandler {type offset count} {
	destroy .f1
	handler $type $offset $count
    }
    set selValue $longValue
    set selInfo ""
    selection handle .f1 {weirdHandler STRING}
    set result ""
    lappend result [dobg {selection get}]
    cleanupbg
    lappend result $selInfo
} -cleanup {
    rename weirdHandler {}
} -result {{PRIMARY selection doesn't exist or form "STRING" not defined} {STRING 0 4000}}

##############################################################################

# testing reentrancy
test select-11.1 {TkSelPropProc procedure} -constraints {x11 failsOnUbuntu} -setup {
    setup
    setupbg
} -body {
    set selValue $longValue
    set selInfo ""
    selection handle -type TEST .f1 { handler TEST }
    selection handle -type STRING .f1 { reallyBadHandler .f1 STRING }
    set result ""
    set pass 0
    lappend result [dobg {selection get}]
    cleanupbg
    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}}

##############################################################################

# Note, this assumes we are using CurrentTtime
test select-12.1 {DefaultSelection procedure} -constraints x11 -body {
    setup
    set result [selection get -type TIMESTAMP]
    setupbg
    lappend result [dobg {selection get -type TIMESTAMP}]
    cleanupbg
    set result
} -result {0x0 {0x0 }}
test select-12.2 {DefaultSelection procedure} -constraints x11 -body {
    setup
    set result [lsort [list [selection get -type TARGETS]]]
    setupbg
    lappend result [dobg {lsort [selection get -type TARGETS]}]
    cleanupbg
    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
    selection handle .f1 {handler TEST} TEST
    set result [list [lsort [selection get -type TARGETS]]]
    setupbg
    lappend result [dobg {lsort [selection get -type TARGETS]}]
    cleanupbg
    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
    set result ""
} -body {
    lappend result [selection get -type TK_APPLICATION]
    setupbg
    lappend result [dobg {selection get -type TK_APPLICATION}]
    cleanupbg
    set result
} -result [list [winfo name .] [winfo name .]]
test select-12.5 {DefaultSelection procedure} -constraints x11 -body {
    setup
    set result [selection get -type TK_WINDOW]
    setupbg
    lappend result [dobg {selection get -type TK_WINDOW}]
    cleanupbg
    set result
} -result {.f1 .f1}
test select-12.6 {DefaultSelection procedure} -body {
    setup
    selection handle .f1 {handler TARGETS.f1} TARGETS
    set selValue "Targets value"
    set selInfo ""
    set result [list [selection get TARGETS] $selInfo]
    selection handle .f1 {} TARGETS
    lappend result [selection get TARGETS]
} -result {{Targets value} {TARGETS.f1 0 4000} {MULTIPLE TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW}}

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}]
    }
    set selValue $longValue
    set selInfo ""
    selection handle .f1 {badHandler .f1 STRING}
    set result ""
    set abortCount 2
    lappend result [dobg {selection get}]
    cleanupbg

    lappend result $selInfo
} -result {{PRIMARY selection doesn't exist or form "STRING" not defined} {.f1 STRING 0 4000 .f1 STRING 4000 4000}}

test select-14.1 {Bug [73ba07efcd]: Use correct property type when handling MULTIPLE conversion requests} -constraints {
    cliboardManagerPresent
} -setup {
    proc get_clip {offset maxChars} {return abcd}
} -body {
    selection handle -selection CLIPBOARD . get_clip
    selection own -selection CLIPBOARD .
    selection get -selection CLIPBOARD_MANAGER -type SAVE_TARGETS
    clipboard get
} -cleanup {
    rename get_clip {}
} -result {abcd}




# cleanup

cleanupTests
return

# Local Variables:
# mode: tcl
# End:

# 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

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.

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
}

set name [tk appname]
set commId ""
catch {
    set registry [testsend prop root InterpRegistry]
    set commId [lindex [testsend prop root InterpRegistry] 0]
}

    winfo interps
} {test}

if {[testConstraint nonPortable] && [testConstraint xhost]} {
    winfo interps
    tk appname tktest
    update
    setupbg
    set x [split [exec xhost] \n]
    foreach i [lrange $x 1 end]  {
	exec xhost - $i
    }
}

test send-6.1 {ServerSecure procedure} {nonPortable secureserver} {
    set a 44
    list [dobg [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
} {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
} {new new}
cleanupbg

test send-7.1 {Tk_SetAppName procedure} {secureserver testsend} {
    testsend prop root InterpRegistry ""
    tk appname newName
    list [tk appname oldName] [testsend prop root InterpRegistry]
} "oldName {$commId oldName\n}"
test send-7.2 {Tk_SetAppName procedure, name not in use} {secureserver testsend} {

    tk appname name1
    testsend prop root InterpRegistry "$id foo\n$id foo #2\n$id foo #3\n"
    list [tk appname foo] [testsend prop root InterpRegistry]
} "{foo #4} {$commId foo #4\n$id foo\n$id foo #2\n$id foo #3\n}"

#macOS does not send to other processes
test send-8.1 {Tk_SendCmd procedure, options} {secureserver notAqua} {
    setupbg
    set app [dobg {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
    lappend result $a
} {66 77}
test send-8.2 {Tk_SendCmd procedure, options} {secureserver altDisplay} {
    setupbg -display $env(TK_ALT_DISPLAY)
    tk appname xyzgorp
    set a homeDisplay
    set result [dobg "
    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
    set result
} {altDisplay homeDisplay}
# Since macOS has no registry of interpreters, 8.3 and 8.10 will fail.
test send-8.3 {Tk_SendCmd procedure, options} {secureserver notAqua} {
    list [catch {send -- -async foo bar baz} msg] $msg
} {1 {no application named "-async"}}
test send-8.4 {Tk_SendCmd procedure, options} {secureserver} {

    invoked from within
"send [tk appname] open bad_file"} {posix enoent {no such file or directory}}}
test send-8.10 {Tk_SendCmd procedure, no such interpreter} {secureserver notAqua} {
    list [catch {send bogus_name bogus_command} msg] $msg
} {1 {no application named "bogus_name"}}

catch {
    newApp "" t_s_1 Test
    t_s_1 eval wm withdraw .
}

test send-8.11 {Tk_SendCmd procedure, local execution, different interp} {secureserver testsend} {
    set a us
    send t_s_1 set a them
    list $a [send t_s_1 set a]
} {us them}
test send-8.12 {Tk_SendCmd procedure, local execution, different interp} {secureserver testsend} {
    set a us
    send t_s_1 {set a them}
    list $a [send t_s_1 {set a}]
} {us them}
test send-8.13 {Tk_SendCmd procedure, local execution, different interp} {secureserver testsend} {
    set a us
    send t_s_1 {set a them}
    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
    list [catch {send t_s_2 {destroy .; concat result}} msg] $msg
} {0 result}

catch {interp delete t_s_2}

test send-8.15 {Tk_SendCmd procedure, local interp, error info} {secureserver testsend failsOnUbuntu} {
    catch {error foo}
    list [catch {send t_s_1 {if 1 {open bogus_file_name}}} msg] $msg $errorInfo $errorCode
} {1 {couldn't open "bogus_file_name": no such file or directory} {couldn't open "bogus_file_name": no such file or directory
    while executing
"open bogus_file_name"
    invoked from within
"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} {
    testsend prop root InterpRegistry "10234 bogus\n"
    set result [list [catch {send bogus bogus command} msg] $msg]
    winfo interps
    tk appname tktest
    set result
} {1 {no application named "bogus"}}

catch {interp delete t_s_1}

test send-8.17 {Tk_SendCmd procedure, deferring events} {secureserver nonPortable} {
    # Non-portable because some window managers ignore "raise"
    # 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}]
    raise .		; # Don't want new app obscuring .f
    catch {destroy .f}
    frame .f
    place .f -x 0 -y 0
    bind .f <Expose> {set a exposed}
    set a {no event yet}
    set result ""
    lappend result [send $app send [list [tk appname]] set a]
    lappend result $a
    update
    cleanupbg
    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}]
    set result [string tolower [list [catch {send $app open bad_name} msg] \
	    $msg $errorInfo $errorCode]]
    cleanupbg
    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
"open bad_name"
    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}]
    set x no
    set result ""
    after 0 {set x yes}
    lappend result [send $app {concat x y z}]
    lappend result $x
    update
    cleanupbg
    lappend result $x
} {{x y z} no yes}

tk appname tktest
catch {destroy .f}
frame .f
set id [string range [winfo id .f] 2 end]

    testsend prop comm Comm \
	    "r\n-i test1\n-e test2\n-c 4\n-s [testsend serial]\n"
    set errorCode oldErrorCode
    set errorInfo oldErrorInfo
    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}
    set x [list [catch {send t_s_3 destroy .} msg] $msg]
    cleanupbg
    set x
} {0 {}}
test send-10.19 {SendEventProc procedure, send exits} {secureserver testsend} {
    setupbg
    dobg {tk appname t_s_3}
    set x [list [catch {send t_s_3 exit} msg] $msg]
    cleanupbg
    set x
} {1 {target application died}}

test send-11.1 {AppendPropCarefully and AppendErrorProc procedures} -constraints {secureserver testsend} -body {
    testsend prop root InterpRegistry "0x21447 dummy\n"
    send dummy foo
} -returnCodes 1 -match regexp -result {^(target application died|no application named "dummy")$}

catch {testsend prop root InterpRegistry ""}

#macOS does not send to other processes
test send-12.2 {TimeoutProc procedure} {secureserver notAqua} {
    winfo interps
    tk appname tktest
    update
    setupbg
    set app [dobg {
	after 10 {after 10 {after 5000; exit}}
	tk appname
    }]
    after 200
    set result [list [catch {send $app foo} msg] $msg]
    cleanupbg
    set result
} {1 {target application died}}

#macOS does not send to other processes
winfo interps
tk appname tktest
test send-13.1 {DeleteProc procedure} {secureserver notAqua} {
    setupbg
    set app [dobg {rename send {}; tk appname}]
    set result [list [catch {send $app foo} msg] $msg [winfo interps]]
    cleanupbg
    set result
} {1 {no application named "tktest #2"} tktest}
test send-13.2 {DeleteProc procedure} {secureserver notAqua} {
    winfo interps
    tk appname tktest
    rename send {}
    set result {}
    lappend result [winfo interps] [info commands send]
    tk appname foo
    lappend result [winfo interps] [info commands send]
} {{} {} foo send}

test send-14.1 {SendRestrictProc procedure, sends crossing from different displays} {secureserver altDisplay} {
    setupbg -display $env(TK_ALT_DISPLAY)
    set result [dobg "
    toplevel .t -screen [winfo screen .]
    wm geometry .t +0+0
    tk appname xyzgorp1
    set x child
    "]
    toplevel .t -screen $env(TK_ALT_DISPLAY)
    wm geometry .t +0+0
    tk appname xyzgorp2
    update
    set y parent
    set result [send -displayof .t xyzgorp1 {list $x [send -displayof .t xyzgorp2 set y]}]
    destroy .t
    cleanupbg
    set result
} {child parent}

catch {
    testsend prop root InterpRegister $registry
    tk appname tktest
}
test send-15.1 {UpdateCommWindow procedure} {secureserver testsend} {
    set x [list [testsend prop comm TK_APPLICATION]]
    newApp "" t_s_1 Test
    send t_s_1 wm withdraw .
    newApp "" t_s_2 Test
    send t_s_2 wm withdraw .
    lappend x [testsend prop comm TK_APPLICATION]
    interp delete t_s_1
    lappend x [testsend prop comm TK_APPLICATION]
    interp delete t_s_2
    lappend x [testsend prop comm TK_APPLICATION]
} {tktest {t_s_2 t_s_1 tktest} {t_s_2 tktest} tktest}





catch {
    tk appname $name
    testsend prop root InterpRegistry $registry
    testdeleteapps
}
rename newApp {}

# cleanup
cleanupTests
return

# This file is a Tcl script to test spinbox widgets in Tk.  It is
# organized in the standard fashion for Tcl tests.
#
# Copyright © 1994 The Regents of the University of California.
# Copyright © 1994-1997 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

package require tcltest 2.2
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
}

# 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
}

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
    pack .e
    update
} -body {

} -cleanup {
    destroy .e
} -result 0123457890
test spinbox-3.24 {SpinboxWidgetCmd procedure, "delete" widget command} -setup {
    spinbox .e
    pack .e
    update
    set x {}
} -body {
# UTF
    .e insert end "01234乎67890"
    .e delete 6
    lappend x [.e get]
    .e delete 0 end
    .e insert end "012345乎7890"
    .e delete 6
    lappend x [.e get]
    .e delete 0 end
    .e insert end "0123456乎890"
    .e delete 6
    lappend x [.e get]
} -cleanup {
    destroy .e
} -result [list "01234乎7890" "0123457890" "012345乎890"]
test spinbox-3.25 {SpinboxWidgetCmd procedure, "delete" widget command} -setup {
    spinbox .e
    pack .e
    update

    .e insert end "This is quite a long text string, so long that it "
    .e insert end "runs off the end of the window quite a bit."
    .e insert 10 乎
    update
# UTF
# If Tcl_NumUtfChars wasn't used, wrong answer would be:
# 0.106383 0.117021 0.117021
    set x {}
    .e xview moveto .1
    lappend x [format {%.6f} [lindex [.e xview] 0]]
    .e xview moveto .11
    lappend x [format {%.6f} [lindex [.e xview] 0]]
    .e xview moveto .12
    lappend x [format {%.6f} [lindex [.e xview] 0]]
} -cleanup {
    destroy .e
} -result {0.095745 0.106383 0.117021}

test spinbox-3.82 {SpinboxWidgetCmd procedure} -setup {
    spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2
    pack .e
    update
} -body {
    .e gorp
} -cleanup {
    destroy .e
} -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
    .e get
} -cleanup {
    destroy .e
} -result 12345
test spinbox-5.2 {ConfigureSpinbox procedure, -textvariable} -body {
    set x 12345
    spinbox .e -textvariable x
    set y abcde
    .e configure -textvariable y
    set x 54321
    .e get
} -cleanup {
    destroy .e
} -result {abcde}
test spinbox-5.3 {ConfigureSpinbox procedure, -textvariable} -setup {
    unset -nocomplain x
    spinbox .e
} -body {
    .e insert 0 "Some text"
    .e configure -textvariable x
    set x
} -cleanup {
    destroy .e
} -result {Some text}
test spinbox-5.4 {ConfigureSpinbox procedure, -textvariable} -setup {
    unset -nocomplain x
    spinbox .e
} -body {
    trace add variable x write override
    .e insert 0 "Some text"
    .e configure -textvariable x
    list $x [.e get]
} -cleanup {
    destroy .e
    trace remove variable x write override
} -result {12345 12345}

test spinbox-5.5 {ConfigureSpinbox procedure} -setup {
    set x {}
    spinbox .e1
    spinbox .e2
} -body {
    .e2 insert end "This is some sample text"
    .e1 configure -exportselection false
    .e1 insert end "0123456789"
    pack .e1 .e2
    .e2 select from 0
    .e2 select to 10
    lappend x [selection get]
    .e1 select from 1
    .e1 select to 5
    lappend x [selection get]
    .e1 configure -exportselection 1
    lappend x [selection get]
    set x
} -cleanup {
    destroy .e1 .e2
} -result {{This is so} {This is so} 1234}
test spinbox-5.6 {ConfigureSpinbox procedure} -setup {
    spinbox .e
    pack .e
} -body {