Tk Source Code

# 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]
    [file join [tcltest::testsDirectory] main.tcl]
tcltest::configure -singleproc 1
set ErrorOnFailures [info exists env(ERROR_ON_FAILURES)]
encoding system utf-8
if {[tcltest::runAllTests] && $ErrorOnFailures} {exit 1}

if {[namespace exists tk::test]} {
    deleteWindows
    wm geometry . {}
    raise .
    return
}

# constraints.tcl --
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
}

# This file holds test constraints that are used by several test files
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
# in the Tk test suite.
	# [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

# See the file "license.terms" for information on usage and redistribution
	# 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.
	# menubarheight deals with this issue but may not be available from the test
	# environment, therefore provide a fallback here
	if {[llength [info procs menubarheight]] == 0} {
	    if {[tk windowingsystem] ne "aqua"} {
		# Windows may overlap the menubar
		proc menubarheight {} {
		    return 0
		}
	    } else {
		# Windows may not overlap the menubar
		proc menubarheight {} {
		    return 30 ;  # arbitrary value known to be larger than the menubar height
		}
	    }
	    namespace export menubarheight
	}
    }
}

# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
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 {

	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

# EOF
deleteWindows
wm geometry . {}
raise .

# 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

# Import utility procs for specific functional areas
namespace import -force ::tk::test::scroll::*
# For xscrollcommand
set scrollInfo {}

set scrollCmdPrefix [list scrollInfo set]
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

    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 configure -font {Courier -12} -width 4 -xscrollcommand $scrollCmdPrefix
    .e insert end "01234567890"
    update
    set scrollInfo wrong
    scrollInfo set wrong
    .e configure -width 5
    update
    format {%.6f %.6f} {*}$scrollInfo
    format {%.6f %.6f} {*}[scrollInfo get]
} -cleanup {
    destroy .e
} -result {0.000000 0.454545}


test entry-5.8 {ConfigureEntry procedure} -constraints {
    fonts

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
    .e configure -textvariable contents -xscrollcommand $scrollCmdPrefix
    update
    set scrollInfo wrong
    scrollInfo set wrong
    .e insert 0 abcde
    .e insert 2 XXX
    update
    list [.e get] $contents [format {%.6f %.6f} {*}$scrollInfo]
    list [.e get] $contents [format {%.6f %.6f} {*}[scrollInfo get]]
} -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
    .e configure -textvariable contents -xscrollcommand $scrollCmdPrefix
    update
    set scrollInfo wrong
    scrollInfo set wrong
    .e insert 0 abcde
    .e insert 500 XXX
    update
    list [.e get] $contents [format {%.6f %.6f} {*}$scrollInfo]
    list [.e get] $contents [format {%.6f %.6f} {*}[scrollInfo get]]
} -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 {

} -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 configure -xscrollcommand $scrollCmdPrefix
    .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
    .e configure -textvariable contents -xscrollcommand $scrollCmdPrefix
    update
    set scrollInfo wrong
    scrollInfo set wrong
    .e insert 0 abcde
    .e delete 2 4
    update
    list [.e get] $contents [format {%.6f %.6f} {*}$scrollInfo]
    list [.e get] $contents [format {%.6f %.6f} {*}[scrollInfo get]]
} -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
    .e configure -textvariable contents -xscrollcommand $scrollCmdPrefix
    update
    set scrollInfo wrong
    scrollInfo set wrong
    .e insert 0 abcde
    .e delete {} 2
    update
    list [.e get] $contents [format {%.6f %.6f} {*}$scrollInfo]
    list [.e get] $contents [format {%.6f %.6f} {*}[scrollInfo get]]
} -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
    .e configure -textvariable contents -xscrollcommand $scrollCmdPrefix
    update
    set scrollInfo wrong
    scrollInfo set wrong
    .e insert 0 abcde
    .e delete 3 1000
    update
    list [.e get] $contents [format {%.6f %.6f} {*}$scrollInfo]
    list [.e get] $contents [format {%.6f %.6f} {*}[scrollInfo get]]
} -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

    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}
    entry .e -width 10 -xscrollcommand $scrollCmdPrefix -font {Courier -12}
    pack .e
    update
    set scrollInfo wrong
    scrollInfo set wrong
    .e delete 0 end
    .e insert 0 123
    update
    format {%.6f %.6f} {*}$scrollInfo
    format {%.6f %.6f} {*}[scrollInfo get]
} -cleanup {
    destroy .e
} -result {0.000000 1.000000}
test entry-17.2 {EntryUpdateScrollbar procedure} -body {
    entry .e -width 10 -xscrollcommand scroll -font {Courier -12}
    entry .e -width 10 -xscrollcommand $scrollCmdPrefix -font {Courier -12}
    pack .e
    update
    set scrollInfo wrong
    scrollInfo set wrong
    .e insert 0 0123456789abcdef
    .e xview 3
    update
    format {%.6f %.6f} {*}$scrollInfo
    format {%.6f %.6f} {*}[scrollInfo get]
} -cleanup {
    destroy .e
} -result {0.187500 0.812500}
test entry-17.3 {EntryUpdateScrollbar procedure} -body {
    entry .e -width 10 -xscrollcommand scroll -font {Courier -12}
    entry .e -width 10 -xscrollcommand $scrollCmdPrefix -font {Courier -12}
    pack .e
    update
    set scrollInfo wrong
    scrollInfo set wrong
    .e insert 0 abcdefghijklmnopqrs
    .e xview 6
    update
    format {%.6f %.6f} {*}$scrollInfo
    format {%.6f %.6f} {*}[scrollInfo get]
} -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
    scrollInfo set wrong
    .e configure -xscrollcommand thisisnotacommand
    update
    list $x $errorInfo
} -cleanup {
    destroy .e
    rename bgerror {}
} -result {{invalid command name "thisisnotacommand"} {invalid command name "thisisnotacommand"

# 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

#
# CLEANUP
#

# option clear
# cleanup
unset scrollCmdPrefix
namespace forget ::tk::test::scroll::*
cleanupTests
return

# main.tcl --
#
# This file is loaded by default by each test file. It performs an initial Tk
# setup for the root window, and loads definitions of global test items
# (utility procs, constraints, ...).
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.

#
# SETUP FOR APPLICATION AND ROOT WINDOW
#
if {[namespace exists tk::test]} {
    # reset windows
    deleteWindows
    wm geometry . {}
    raise .
    return
}

package require tk
tk appname tktest
wm title . tktest
# If the main window isn't already mapped (e.g. because the tests are
# being run automatically) , specify a precise size for it so that the
# user won't have to position it manually.

if {![winfo ismapped .]} {
    wm geometry . +0+0
    update
}

#
# LOAD AND CONFIGURE TEST HARNESS
#
package require tcltest 2.2
eval tcltest::configure $argv
namespace import -force tcltest::test
namespace import -force tcltest::makeFile
namespace import -force tcltest::removeFile
namespace import -force tcltest::makeDirectory
namespace import -force tcltest::removeDirectory
namespace import -force tcltest::interpreter
namespace import -force tcltest::testsDirectory
namespace import -force tcltest::cleanupTests

#
# SOURCE DEFINITIONS OF GLOBAL UTILITY PROCS AND CONSTRAINTS
#
# Note: the tcltest mechanism induces that [info script] at this place returns
#       the name of the test file calling [loadTestedCommands] instead of the
#       pathname invocation of this script. Apparently, [tcltest::loadTestedCommands]
#       doesn't use [source] to read and evaluate the script file. Therefore,
#       [info script] cannot be used to determine the main Tk test directory,
#       and we use [tcltest::configure -loadfile] instead.
#
set mainTestDir [file dirname [tcltest::configure -loadfile]]
source [file join $mainTestDir testutils.tcl]
source [file join $mainTestDir constraints.tcl]
unset mainTestDir

#
# RESET WINDOWS
#
deleteWindows
wm geometry . {}
raise .

# EOF

# 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
# Import utility procs for specific functional areas
namespace import -force ::tk::test::scroll::*
    set scrollInfo $args
}

set scrollCmdPrefix [list scrollInfo set]

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 {

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

scrollbar .s -orient vertical -command scroll -highlightthickness 2 -bd 2
scrollbar .s -orient vertical -command $scrollCmdPrefix -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

} -cleanup {
    destroy .top.s .top
} -result {}

catch {destroy .s}
catch {destroy .t}

#
# CLEANUP
#
# cleanup

unset scrollCmdPrefix
namespace forget ::tk::test::scroll::*
cleanupTests
return

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

# Import utility procs for specific functional areas
namespace import -force ::tk::test::select::*

testConstraint cliboardManagerPresent 0
if {![catch {selection get -selection CLIPBOARD_MANAGER -type TARGETS}]} {
    if {"SAVE_TARGETS" in [selection get -selection CLIPBOARD_MANAGER -type TARGETS]} {
	testConstraint cliboardManagerPresent 1
    }
}
testConstraint failsOnUbuntu [expr {![info exists ::env(CI)] || ![string match Linux $::tcl_platform(os)]}]

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

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

    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

#
# CLEANUP
#

namespace forget ::tk::test::select::*
cleanupTests
return

# Local Variables:
# mode: tcl
# End:

# 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

# Import utility procs for specific functional areas
namespace import -force ::tk::test::scroll::*
# For xscrollcommand
set scrollInfo {}

set scrollCmdPrefix [list scrollInfo set]
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

    destroy .e
} -result {1 5}

test spinbox-5.7 {ConfigureSpinbox procedure} -setup {
    spinbox .e -font {Helvetica -12} -borderwidth 2 -highlightthickness 2
    pack .e
} -body {
    .e configure -font {Courier -12} -width 4 -xscrollcommand scroll
    .e configure -font {Courier -12} -width 4 -xscrollcommand $scrollCmdPrefix
    .e insert end "01234567890"
    update
    set scrollInfo wrong
    scrollInfo set wrong
    .e configure -width 5
    update
    format {%.6f %.6f} {*}$scrollInfo
    format {%.6f %.6f} {*}[scrollInfo get]
} -cleanup {
    destroy .e
} -result {0.000000 0.454545}

test spinbox-5.8 {ConfigureSpinbox procedure} -constraints {
    fonts
} -setup {

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

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

} -cleanup {
    destroy .e
} -result {2 6 2 5}
test spinbox-7.7 {InsertChars procedure} -setup {
    spinbox .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2
    pack .e
} -body {
    .e configure -xscrollcommand scroll
    .e configure -xscrollcommand $scrollCmdPrefix
    .e insert 0 0123456789
    .e icursor 4
    .e insert 4 XXX
    .e index insert
} -cleanup {
    destroy .e
} -result 7

test spinbox-8.1 {DeleteChars procedure} -setup {
    unset -nocomplain contents
    spinbox .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2
    pack .e
    focus .e
} -body {
    .e configure -textvariable contents -xscrollcommand scroll
    .e configure -textvariable contents -xscrollcommand $scrollCmdPrefix
    .e insert 0 abcde
    update
    set scrollInfo wrong
    scrollInfo set wrong
    .e delete 2 4
    update
    list [.e get] $contents [format {%.6f %.6f} {*}$scrollInfo]
    list [.e get] $contents [format {%.6f %.6f} {*}[scrollInfo get]]
} -cleanup {
    destroy .e
} -result {abe abe {0.000000 1.000000}}
test spinbox-8.2 {DeleteChars procedure} -setup {
    unset -nocomplain contents
    spinbox .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2
    pack .e
    focus .e
} -body {
    .e configure -textvariable contents -xscrollcommand scroll
    .e configure -textvariable contents -xscrollcommand $scrollCmdPrefix
    .e insert 0 abcde
    update
    set scrollInfo wrong
    scrollInfo set wrong
    .e delete {} 2
    update
    list [.e get] $contents [format {%.6f %.6f} {*}$scrollInfo]
    list [.e get] $contents [format {%.6f %.6f} {*}[scrollInfo get]]
} -cleanup {
    destroy .e
} -result {cde cde {0.000000 1.000000}}
test spinbox-8.3 {DeleteChars procedure} -setup {
    unset -nocomplain contents
    spinbox .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2
    pack .e
    focus .e
} -body {
    .e configure -textvariable contents -xscrollcommand scroll
    .e configure -textvariable contents -xscrollcommand $scrollCmdPrefix
    .e insert 0 abcde
    update
    set scrollInfo wrong
    scrollInfo set wrong
    .e delete 3 1000
    update
    list [.e get] $contents [format {%.6f %.6f} {*}$scrollInfo]
    list [.e get] $contents [format {%.6f %.6f} {*}[scrollInfo get]]
} -cleanup {
    destroy .e
} -result {abc abc {0.000000 1.000000}}
test spinbox-8.4 {DeleteChars procedure} -setup {
    spinbox .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2
    pack .e
    focus .e

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


test spinbox-17.1 {SpinboxUpdateScrollbar procedure} -body {
    spinbox .e -width 10 -xscrollcommand scroll -font {Courier -12}
    spinbox .e -width 10 -xscrollcommand $scrollCmdPrefix -font {Courier -12}
    pack .e
    update
    set scrollInfo wrong
    scrollInfo set wrong
    .e delete 0 end
    .e insert 0 123
    update
    format {%.6f %.6f} {*}$scrollInfo
    format {%.6f %.6f} {*}[scrollInfo get]
} -cleanup {
    destroy .e
} -result {0.000000 1.000000}
test spinbox-17.2 {SpinboxUpdateScrollbar procedure} -body {
    spinbox .e -width 10 -xscrollcommand scroll -font {Courier -12}
    spinbox .e -width 10 -xscrollcommand $scrollCmdPrefix -font {Courier -12}
    pack .e
    .e insert 0 0123456789abcdef
    update
    set scrollInfo wrong
    scrollInfo set wrong
    .e xview 3
    update
    format {%.6f %.6f} {*}$scrollInfo
    format {%.6f %.6f} {*}[scrollInfo get]
} -cleanup {
    destroy .e
} -result {0.187500 0.812500}
test spinbox-17.3 {SpinboxUpdateScrollbar procedure} -body {
    spinbox .e -width 10 -xscrollcommand scroll -font {Courier -12}
    spinbox .e -width 10 -xscrollcommand $scrollCmdPrefix -font {Courier -12}
    pack .e
    update
    set scrollInfo wrong
    scrollInfo set wrong
    .e insert 0 abcdefghijklmnopqrs
    .e xview
    update
    format {%.6f %.6f} {*}$scrollInfo
    format {%.6f %.6f} {*}[scrollInfo get]
} -cleanup {
    destroy .e
} -result {0.000000 0.526316}
test spinbox-17.4 {SpinboxUpdateScrollbar procedure} -setup {
    proc bgerror msg {
	global x
	set x $msg
}
} -body {
    spinbox .e -width 5
    pack .e
    update
    set scrollInfo wrong
    scrollInfo set wrong
    .e configure -xscrollcommand thisisnotacommand
    update
    list $x $errorInfo
} -cleanup {
    destroy .e
    rename bgerror {}
} -result {{invalid command name "thisisnotacommand"} {invalid command name "thisisnotacommand"

# Collected comments about lacks from the test
# XXX Still need to write tests for SpinboxBlinkProc, SpinboxFocusProc,
# and SpinboxTextVarProc.
# No tests for DisplaySpinbox.
# XXX Still need to write tests for SpinboxScanTo and SpinboxSelectTo.
# No tests for EventuallyRedraw

#
# CLEANUP
#

# option clear
# cleanup
unset scrollCmdPrefix
namespace forget ::tk::test::scroll::*
cleanupTests
return

# testutils.tcl --
#
# This file holds utility procs, each of which is used by several test files
# in the Tk test suite.
#
# The procs are defined per functional area of Tk (also called "domain"),
# similar to the names of test files:
# - generic utility procs that don't belong to a specific functional area go
#   into the namespace ::tk::test.
# - those that do belong to a specific functional area go into a child namespace
#   of ::tk::test that bears the name of that functional area.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.

#
# DEFINITIONS OF GENERIC UTILITY PROCS
#
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.
	# menubarheight deals with this issue but may not be available from the test
	# environment, therefore provide a fallback here
	if {[llength [info procs menubarheight]] == 0} {
	    if {[tk windowingsystem] ne "aqua"} {
		# Windows may overlap the menubar
		proc menubarheight {} {
		    return 0
		}
	    } else {
		# Windows may not overlap the menubar
		proc menubarheight {} {
		    return 30 ;  # arbitrary value known to be larger than the menubar height
		}
	    }
	    namespace export menubarheight
	}
    }
}

namespace import -force tk::test::*

#
# DEFINITIONS OF UTILITY PROCS PER FUNCTIONAL AREA
#
# Utility procs are defined and used per functional area of Tk as indicated by
# the names of test files. The namespace names below ::tk::test correspond to
# these functional areas.
#

namespace eval ::tk::test::scroll {

    # scrollInfo --
    #
    #	Used as the scrolling command for widgets, set with "-[xy]scrollcommand".
    #	It saves the scrolling information in, or retrieves it from a namespace
    #	variable "scrollInfo".
    #
    variable scrollInfo {}
    proc scrollInfo {mode args} {
	variable scrollInfo
	switch -- $mode {
	    get {
		return $scrollInfo
	    }
	    set {
		set scrollInfo $args
	    }
	}
    }

    namespace export *
}

namespace eval ::tk::test::select {

    proc errHandler args {
	error "selection handler aborted"
    }

    namespace export *
}

#
# TODO: RELOCATE UTILITY PROCS CATEGORY B. HERE
#       (As indicated by the spreadsheet file "relocate.ods")
#

# EOF

# This file is a Tcl script to test the code in the file tkTextDisp.c.
# This file 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
namespace import -force tcltest::test

# Import utility procs for specific functional areas
namespace import -force ::tk::test::scroll::*

set scrollCmdPrefix [list scrollInfo set]

# The delay procedure needs to wait long enough for the asynchronous updates
# performed by the text widget to run.
proc delay {} {
    update
    after 100
    update
}

# The procedure below is used as the scrolling command for the text;
# it just saves the scrolling information in a variable "scrollInfo".

proc scroll args {
    global scrollInfo
    set scrollInfo $args
}

# The procedure below is used to generate errors during scrolling commands.

proc scrollError args {
    error "scrolling error"
}

# Return 1 if the two given lists are the same, otherwise return the two lists.

is $fixedWidth pixels in width while the tests expect between 6 and 8 (inclusive) pixels.\
Some of the upcoming tests will probably fail."
}

# Option  -width 20  (characters) below is a fundamental assumption of many
# upcoming tests when wrapping enters in play
# Also  -height 10  (lines) is an important assumption
text .t -font $fixedFont -width 20 -height 10 -yscrollcommand scroll
text .t -font $fixedFont -width 20 -height 10 -yscrollcommand $scrollCmdPrefix
pack .t -expand 1 -fill both
.t tag configure big -font $bigFont
.t debug on

wm geometry . {}

# full border size of the text widget, i.e. first x or y coordinate inside the text widget

.t configure -bd 0
test textDisp-6.7 {DisplayText, vertical scrollbar updates} {
    .t configure -wrap char
    .t delete 1.0 end
    update
    .t count -update -ypixels 1.0 end
    update
    set scrollInfo
    scrollInfo get
} {0.0 1.0}
test textDisp-6.8 {DisplayText, vertical scrollbar updates} {
    .t configure -wrap char
    .t delete 1.0 end
    .t insert 1.0 "Line 1"
    update
    set scrollInfo "unchanged"
    scrollInfo set "unchanged"
    foreach i {2 3 4 5 6 7 8 9 10 11 12 13} {
	.t insert end "\nLine $i"
    }
    update
    .t count -update -ypixels 1.0 end ; update
    set scrollInfo
    scrollInfo get
} [list 0.0 [expr {10.0/13}]]
.t configure -yscrollcommand {} -xscrollcommand scroll
.t configure -yscrollcommand {} -xscrollcommand $scrollCmdPrefix
test textDisp-6.9 {DisplayText, horizontal scrollbar updates} {
    .t configure -wrap none
    .t delete 1.0 end
    update
    set scrollInfo unchanged
    scrollInfo set unchanged
    .t insert end xxxxxxxxx\n
    .t insert end xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx\n
    .t insert end xxxxxxxxxxxxxxxxxxxxxxxxxx
    update
    set scrollInfo
    scrollInfo get
} [list 0.0 [expr {4.0/11}]]
test textDisp-6.10 {DisplayText, redisplay embedded windows after scroll} {aqua} {
    # For this test to pass line 8 must be out of the text widget.
    # With macOS 14 this requires making the buttons a little larger.
    # So we set the pady option.  This may depend on the OS version.
    .t configure -wrap char
    update

    .t delete 2.19
    update
    set tk_textRedraw
} {2.0 2.20 eof}
test textDisp-8.11 {TkTextChanged, scrollbar notification when changes are off-screen} {
    .t delete 1.0 end
    .t insert end "1\n2\n3\n4\n5\n6\n7\n8\n9\n10\n11\n12\n"
    .t configure -yscrollcommand scroll
    .t configure -yscrollcommand $scrollCmdPrefix
    update
    set scrollInfo ""
    scrollInfo set ""
    .t insert end "a\nb\nc\n"
    # We need to wait for our asychronous callbacks to update the
    # scrollbar
    update
    .t count -update -ypixels 1.0 end
    update
    .t configure -yscrollcommand ""
    set scrollInfo
    scrollInfo get
} {0.0 0.625}
test textDisp-8.12 {TkTextChanged, moving the insert cursor redraws only past and new lines} {
    .t delete 1.0 end
    .t configure -wrap none
    for {set i 1} {$i < 25} {incr i} {
	.t insert end "Line $i Line $i\n"
    }

    update
    set x [.t index @0,0]
    lappend expected [.t index "$origin - [expr {int(ceil((50.0+70.0)/$fixedHeight))}] display lines"]
    .t scan dragto 0 72
    update
    lequal [list $x [.t index @0,0]] $expected
} {1}
.t configure -xscrollcommand scroll -yscrollcommand {}
.t configure -xscrollcommand $scrollCmdPrefix -yscrollcommand {}

test textDisp-18.1 {GetXView procedure} {
    .t configure -wrap none
    .t delete 1.0 end
    .t insert end xxxxxxxxx\n
    .t insert end xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx\n
    .t insert end xxxxxxxxxxxxxxxxxxxxxxxxxx
    update
    set scrollInfo
    scrollInfo get
} [list 0.0 [expr {4.0/11}]]
test textDisp-18.2 {GetXView procedure} {
    .t configure -wrap char
    .t delete 1.0 end
    .t insert end xxxxxxxxx\n
    .t insert end xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx\n
    .t insert end xxxxxxxxxxxxxxxxxxxxxxxxxx
    update
    set scrollInfo
    scrollInfo get
} {0.0 1.0}
test textDisp-18.3 {GetXView procedure} {
    .t configure -wrap none
    .t delete 1.0 end
    update
    set scrollInfo
    scrollInfo get
} {0.0 1.0}
test textDisp-18.4 {GetXView procedure} {
    .t configure -wrap none
    .t delete 1.0 end
    .t insert end xxxxxxxxx\n
    .t insert end xxxxxx\n
    .t insert end xxxxxxxxxxxxxxxxx
    update
    set scrollInfo
    scrollInfo get
} {0.0 1.0}
test textDisp-18.5 {GetXView procedure} {
    .t configure -wrap none
    .t delete 1.0 end
    .t insert end xxxxxxxxx\n
    .t insert end xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx\n
    .t insert end xxxxxxxxxxxxxxxxxxxxxxxxxx
    .t xview scroll 31 units
    update
    set scrollInfo
    scrollInfo get
} [list [expr {31.0/55}] [expr {51.0/55}]]
test textDisp-18.6 {GetXView procedure} {
    .t configure -wrap none
    .t delete 1.0 end
    .t insert end xxxxxxxxx\n
    .t insert end "xxxxx xxxxxxxxxxx xxxx xxxxxxxxxxxxxxxxxxxx xxxxxxxxxxxx\n"
    .t insert end "xxxx xxxxxxxxx xxxxxxxxxxxxx"
    .t xview moveto 0
    .t xview scroll 31 units
    update
    set x {}
    lappend x $scrollInfo
    lappend x [scrollInfo get]
    .t configure -wrap char
    update
    lappend x $scrollInfo
    lappend x [scrollInfo get]
    .t configure -wrap word
    update
    lappend x $scrollInfo
    lappend x [scrollInfo get]
    .t configure -wrap none
    update
    lappend x $scrollInfo
    lappend x [scrollInfo get]
} [list [list [expr {31.0/56}] [expr {51.0/56}]] {0.0 1.0} {0.0 1.0} [list 0.0 [expr {5.0/14}]]]
test textDisp-18.7 {GetXView procedure} {
    .t configure -wrap none
    .t delete 1.0 end
    update
    set scrollInfo unchanged
    scrollInfo set unchanged
    .t insert end xxxxxx\n
    .t insert end xxx
    update
    set scrollInfo
    scrollInfo get
} {unchanged}
test textDisp-18.8 {GetXView procedure} {
    proc bgerror msg {
	global x errorInfo
	set x [list $msg $errorInfo]
    }
    proc bogus args {

    (procedure "scrollError" line 2)
    invoked from within
"scrollError 0.0 1.0"
    (horizontal scrolling command executed by text)}}
catch {rename bgerror {}}
catch {rename bogus {}}

.t configure -xscrollcommand {} -yscrollcommand scroll
.t configure -xscrollcommand {} -yscrollcommand $scrollCmdPrefix
test textDisp-19.1 {GetYView procedure} {
    .t configure -wrap char
    .t delete 1.0 end
    update
    set scrollInfo
    scrollInfo get
} {0.0 1.0}
test textDisp-19.2 {GetYView procedure} {
    .t configure -wrap char
    .t delete 1.0 end
    update
    set scrollInfo "unchanged"
    scrollInfo set "unchanged"
    .t insert 1.0 "Line1\nLine2"
    update
    set scrollInfo
    scrollInfo get
} {unchanged}
test textDisp-19.3 {GetYView procedure} {
    .t configure -wrap char
    .t delete 1.0 end
    update
    set scrollInfo "unchanged"
    scrollInfo set "unchanged"
    .t insert 1.0 "Line 1\nLine 2 is so long that it wraps around\nLine 3"
    update
    set scrollInfo
    scrollInfo get
} {unchanged}
test textDisp-19.4 {GetYView procedure} {
    .t configure -wrap char
    .t delete 1.0 end
    .t insert 1.0 "Line 1"
    update
    set scrollInfo "unchanged"
    scrollInfo set "unchanged"
    foreach i {2 3 4 5 6 7 8 9 10 11 12 13} {
	.t insert end "\nLine $i"
    }
    update
    set scrollInfo
    scrollInfo get
} [list 0.0 [expr {70.0/91}]]
test textDisp-19.5 {GetYView procedure} {
    .t configure -wrap char
    .t delete 1.0 end
    .t insert 1.0 "Line 1"
    foreach i {2 3 4 5 6 7 8 9 10 11 12 13} {
	.t insert end "\nLine $i"
    }
    .t insert 2.end " is really quite long; in fact it's so long that it wraps three times"
    update
    set x $scrollInfo
    set x [scrollInfo get]
} {0.0 0.625}
test textDisp-19.6 {GetYView procedure} {
    .t configure -wrap char
    .t delete 1.0 end
    .t insert 1.0 "Line 1"
    foreach i {2 3 4 5 6 7 8 9 10 11 12 13} {
	.t insert end "\nLine $i"
    }
    .t insert 2.end " is really quite long; in fact it's so long that it wraps three times"
    .t yview 4.0
    update
    set x $scrollInfo
    set x [scrollInfo get]
} {0.375 1.0}
test textDisp-19.7 {GetYView procedure} {
    .t configure -wrap char
    .t delete 1.0 end
    .t insert 1.0 "Line 1"
    foreach i {2 3 4 5 6 7 8 9 10 11 12 13} {
	.t insert end "\nLine $i"
    }
    .t insert 2.end " is really quite long; in fact it's so long that it wraps three times"
    .t yview 2.26
    update
    set x $scrollInfo
    set x [scrollInfo get]
} {0.125 0.75}
test textDisp-19.8 {GetYView procedure} {
    .t configure -wrap char
    .t delete 1.0 end
    .t insert 1.0 "Line 1"
    foreach i {2 3 4 5 6 7 8 9 10 11 12 13} {
	.t insert end "\nLine $i"
    }
    .t insert 10.end " is really quite long; in fact it's so long that it wraps three times"
    .t yview 2.0
    update
    .t count -update -ypixels 1.0 end
    set x $scrollInfo
    set x [scrollInfo get]
} {0.0625 0.6875}
test textDisp-19.9 {GetYView procedure} {
    .t configure -wrap char
    .t delete 1.0 end
    .t insert 1.0 "Line 1"
    foreach i {2 3 4 5 6 7 8 9 10 11 12 13 14 15} {
	.t insert end "\nLine $i"
    }
    .t yview 3.0
    update
    set scrollInfo
    scrollInfo get
} [list [expr {4.0/30}] 0.8]
test textDisp-19.10 {GetYView procedure} {
    .t configure -wrap char
    .t delete 1.0 end
    .t insert 1.0 "Line 1"
    foreach i {2 3 4 5 6 7 8 9 10 11 12 13 14 15} {
	.t insert end "\nLine $i"
    }
    .t yview 11.0
    update
    set scrollInfo
    scrollInfo get
} [list [expr {1.0/3}] 1.0]
test textDisp-19.10.1 {Widget manipulation causes height miscount} {
    .t configure -wrap char
    .t delete 1.0 end
    .t insert 1.0 "Line 1"
    foreach i {2 3 4 5 6 7 8 9 10 11 12 13 14 15} {
	.t insert end "\nLine $i"

	.t insert end "\nLine $i"
    }
    .t insert end "\nThis last line wraps around four "
    .t insert end "times with a little bit left on the last line."
    .t yview insert
    update
    .t count -update -ypixels 1.0 end
    set scrollInfo
    scrollInfo get
} {0.5 1.0}
test textDisp-19.11 {GetYView procedure} {
    .t configure -wrap word
    .t delete 1.0 end
    .t insert 1.0 "Line 1"
    foreach i {2 3 4 5 6 7 8 9 10 11 12 13 14 15} {
	.t insert end "\nLine $i"
    }
    .t insert end "\nThis last line wraps around four "
    .t insert end "times with a little bit left on the last line."
    .t yview insert
    update
    .t count -update -ypixels 1.0 end
    set scrollInfo
    scrollInfo get
} {0.5 1.0}
test textDisp-19.11.2 {TextWidgetCmd procedure, "count -displaylines"} {
    .t count -displaylines 1.0 end
} 20
test textDisp-19.11.3 {TextWidgetCmd procedure, "count -displaylines"} {
    .t count -displaylines end 1.0
} -20

    }
    .t insert end "\nThis last line wraps around four "
    .t insert end "times with a little bit left on the last line."
    # Need to update so everything is calculated.
    update
    .t count -update -ypixels 1.0 end
    delay
    set scrollInfo "unchanged"
    scrollInfo set "unchanged"
    .t mark set insert 3.0
    .t tag configure x -background red
    .t tag add x 1.0 5.0
    update
    .t tag delete x
    set scrollInfo
    scrollInfo get
} {unchanged}
test textDisp-19.15 {GetYView procedure} {
    .t configure -wrap word
    .t delete 1.0 end
    .t insert 1.0 "Line 1"
    foreach i {2 3 4 5 6 7 8 9 10 11 12 13 14 15} {
	.t insert end "\nLine $i"
    }
    .t insert end "\nThis last line wraps around four "
    .t insert end "times with a bit little left on the last line."
    update
    .t configure -yscrollcommand scrollError
    proc bgerror args {
	global x errorInfo errorCode
	set x [list $args $errorInfo $errorCode]
    }
    .t delete 1.0 end
    update
    rename bgerror {}
    .t configure -yscrollcommand scroll
    .t configure -yscrollcommand $scrollCmdPrefix
    set x
} {{{scrolling error}} {scrolling error
    while executing
"error "scrolling error""
    (procedure "scrollError" line 2)
    invoked from within
"scrollError 0.0 1.0"

   update
   # wish now panics: "CalculateDisplayLineHeight called with bad indexPtr"
   .t1 yview scroll -1 pixels
} -cleanup {
    destroy .t1
} -result {}

#
# CLEANUP
#

unset scrollCmdPrefix
namespace forget ::tk::test::scroll::*
deleteWindows
option clear

# cleanup
cleanupTests
return

# 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 [file dirname [tcltest::testsDirectory]] constraints.tcl]
    [file join [file dirname [tcltest::testsDirectory]] main.tcl]
tcltest::configure -singleproc 1
set ErrorOnFailures [info exists env(ERROR_ON_FAILURES)]
encoding system utf-8
if {[tcltest::runAllTests] && $ErrorOnFailures} {exit 1}

# 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
namespace import ::tcltest::*
tcltest::configure {*}$argv
tcltest::loadTestedCommands

# Import utility procs for specific functional areas
namespace import -force ::tk::test::select::*

testConstraint failsOnXQuarz [expr {$tcl_platform(os) ne "Darwin" || [tk windowingsystem] ne "x11" }]

global longValue selValue selInfo

set selValue {}
set selInfo {}

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

    set selValue "This is the selection value"
    selection own .l
    selection get -type UTF8_STRING
} -cleanup {
    destroy .l
} -result {This is the selection value}

#
# CLEANUP
#
# cleanup

namespace forget ::tk::test::select::*
cleanupTests
return