Tk Source Code

name: Linux
on:
  push:
    branches:
    - "main"
    - "core-9-0-branch"
    - "simplify_test_file_init_for_singleproc_1"
    tags:
    - "core-**"
permissions:
  contents: read
defaults:
  run:
    shell: bash

name: macOS
on:
  push:
    branches:
    - "main"
    - "core-9-0-branch"
    - "simplify_test_file_init_for_singleproc_1"
    tags:
    - "core-**"
permissions:
  contents: read
env:
  ERROR_ON_FAILURES: 1
jobs:

name: Windows
on:
  push:
    branches:
    - "main"
    - "core-9-0-branch"
    - "simplify_test_file_init_for_singleproc_1"
    tags:
    - "core-**"
permissions:
  contents: read
env:
  ERROR_ON_FAILURES: 1
jobs:

# all.tcl --
#
# This file contains a top-level script to run all of the Tk
# tests. Execute it by invoking "source all.tcl" when running tktest
# in this directory.
#
# Copyright © 1998-1999 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.

#
# REQUIREMENTS
#
package require tk ;# This is the Tk test suite; fail early if no Tk!
package require tcltest 2.2

#
# TCLTEST CONFIGURATION
#

# Set defaults for the Tk test suite
tcltest::configure -singleproc 1

# Handle command line parameters
if {[expr {[llength $argv] & 1}]} {
    return -code error "the number of command line parameters must be even (name - value pairs)"
}
set fixedOptions [list -testdir -loadfile]
foreach {key value} $argv {
    if {$key in $fixedOptions} {
	return -code error "option \"$key\" is not user-configurable for the Tk test suite"
    }
}
unset fixedOptions
tcltest::configure {*}$argv

# Set tcltest options that are not user-configurable for the Tk test suite
tcltest::configure -testdir [file normalize [file dirname [info script]]]
if {[tcltest::configure -singleproc]} {
    #
    # All test files are evaluated in the current interpreter. We need to load
    # the file main.tcl only once.
    #
    source [file join [tcltest::testsDirectory] main.tcl]
} else {
    #
    # Each test file is evaluated in a separate process/interpreter. Each testfile
    # needs to load the file main.tcl into its interpreter.
    #
    tcltest::configure -loadfile \
	[file join [tcltest::testsDirectory] main.tcl]
}

#
# RUN ALL TESTS
#

# Note: the environment variable ERROR_ON_FAILURES is set by Github CI
if {[tcltest::runAllTests] && [info exists env(ERROR_ON_FAILURES)]} {
    exit 1
}

# This file is a Tcl script to test out Tk's "bell" command.

#
# Copyright © 1994 The Regents of the University of California.
# Copyright © 1998-2000 Scriptics Corporation.
# All rights reserved.

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
    package require tcltest 2.2


    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

#
# TESTS
#

test bell-1.1 {bell command} -body {
    bell a
} -returnCodes error -result {bad option "a": must be -displayof or -nice}

test bell-1.2 {bell command} -body {
    bell a b

    after 200
    bell -displayof .
    after 200
    bell -nice
    after 200
    bell
} -result {}

#
# TESTFILE CLEANUP
#

cleanupTests

# This file is a Tcl script to test the bgerror command.

#
# Copyright © 1997 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

# NOTE
#
# Some testing of the default error dialog would be needed too, but that's
# not easy at all to emulate.

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
    package require tcltest 2.2


    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

#
# TESTS
#

test bgerror-1.1 {bgerror / tkerror compat} -setup {
    set errRes {}
    proc tkerror {err} {
	global errRes;
	set errRes $err;
    }

    after 0 {error err3}
    update
    return $errRes;
} -cleanup {
    catch {rename tkerror {}}
} -result {err1}

#


# TESTFILE CLEANUP
#

cleanupTests

# This file is a Tcl script to test out Tk's "bind" and "bindtags"
# commands plus the procedures in tkBind.c.

#
# Copyright © 1994 The Regents of the University of California.
# Copyright © 1994-1995 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
    package require tcltest 2.2


    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

#
# COMMON TEST SETUP
#

tk useinputmethods 0

toplevel .t -width 100 -height 50
wm geom .t +0+0
update idletasks

foreach p [event info] {event delete $p}
foreach event [bind Test] {
    bind Test $event {}
}
foreach event [bind all] {
    bind all $event {}
}

# move the mouse pointer away of the testing area
# otherwise some spurious events may pollute the tests
toplevel .top
wm geometry .top 50x50-50-50
update
event generate .top <Button-1> -warp 1
controlPointerWarpTiming
destroy .top

#
# LOCAL UTILITY PROCS
#

proc testKey {window event type mods} {
    global keyInfo numericKeysym
    set keyInfo {}
    set numericKeysym {}
    bind $window <Key> {
	set keyInfo [format "%K,0x%%X,0x%%X,%A" %N %k]
	set numericKeysym %N
    }
    focus -force $window
    update
    event generate $window $event
    if {$keyInfo == {}} {
	vwait keyInfo
    }
    set save $keyInfo
    set keyInfo {}
    set injectcmd [list testinjectkeyevent $type $numericKeysym]
    foreach {option} $mods {
	lappend injectcmd $option
    }
    eval $injectcmd
    if {$keyInfo == {}} {
	vwait keyInfo
    }
    if {$save != $keyInfo} {
	return "[format "0x%x" $numericKeysym] ($mods): $save != $keyInfo"
    }
    return pass
}

proc testKeyWithMods {window keysym type} {
    set result [testKey $window "<$keysym>" $type {}]
    if {$result != {pass}} {
	return $result
    }
    set result [testKey $window "<Shift-$keysym>" $type {-shift}]
    if {$result != {pass}} {
	return $result
    }
    set result [testKey $window "<Option-$keysym>" $type {-option}]
    if {$result != {pass}} {
	return $result
    }
    set result [testKey $window "<Shift-Option-$keysym>" $type {-shift -option}]
    if {$result != {pass}} {
	return $result
    }
    return pass
}

proc unsetBindings {} {
    bind all <Enter> {}
    bind Test <Enter> {}
    bind Toplevel <Enter> {}
    bind xyz <Enter> {}
    bind {a b} <Enter> {}
    bind .t <Enter> {}
}








#
# TESTS
#

test bind-1.1 {bind command} -body {
    bind
} -returnCodes error -result {wrong # args: should be "bind window ?pattern? ?command?"}
test bind-1.2 {bind command} -body {
    bind a b c d
} -returnCodes error -result {wrong # args: should be "bind window ?pattern? ?command?"}

	    lappend res $dim
	}
    }
    set res
} -cleanup {
} -result {ok ok ok ok}



















































test bind-35.0 {Generated and real key events agree} -constraints {aqua} -body {
    foreach k {o O F2 Home Right Greek_sigma Greek_ALPHA} {
	set result [testKeyWithMods . $k press]
	if {$result != "pass"} {
	    return $result
	}
    }

    event generate .c <B1-Motion>
    event generate .c <ButtonRelease-1>
    event generate .c <B1-Motion>
} -cleanup {
    destroy .c
} -returnCodes ok -result {}  ; # shall not crash (assertion failed)

#
# TESTFILE CLEANUP
#

cleanupTests


# vi:set ts=4 sw=4 et:
# Local Variables:
# mode: tcl
# End:

# This file is a Tcl script to test out the procedures in the file
# tkBitmap.c.

#
# Copyright © 1998 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
    package require tcltest 2.2


    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

#
# TESTS
#

test bitmap-1.1 {Tk_AllocBitmapFromObj - converting internal reps} -constraints {
    testbitmap
} -body {
    set x gray25
    lindex $x 0
    button .b -bitmap $x

    set y bogus
    return $result
} -cleanup {
    rename copy {}
    destroy .b
} -result {{{1 3}} {{1 2}} {{1 1}} {}}

#
# TESTFILE CLEANUP
#

cleanupTests

# This file is a Tcl script to test out the procedures in the file
# tkBorder.c.
#
# Copyright © 1998 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
    package require tcltest 2.2


    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

#
# TESTS
#

test border-1.1 {Tk_AllocBorderFromObj - converting internal reps} -constraints {
    testborder
} -body {
    set x orange
    lindex $x 0
    button .b1 -bg $x -text .b1

} -result {sunken}
test border-4.7 {Tk_GetReliefFromObj - error} -body {
    button .b -relief upanddown
} -cleanup {
    destroy .b
} -returnCodes error -result {bad relief "upanddown": must be flat, groove, raised, ridge, solid, or sunken}

#
# TESTFILE CLEANUP
#

cleanupTests

# This file is a Tcl script to test out the tk busy command.
#
# Copyright © 1998-2000 Jos Decoster. All rights reserved.


#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
    package require tcltest 2.2

    tcltest::loadTestedCommands

}

# Ensure a pristine initial window state
resetWindows


#
# TESTS
#

test busy-1.1 {Tk_BusyObjCmd} -returnCodes error -body {
    tk busy
} -result {wrong # args: should be "tk busy options ?arg ...?"}

test busy-2.1 {tk busy hold} -returnCodes error -body {
    tk busy hold

test busy-8.3 {tk busy busywindow with a nonexisting widget} -body {
    tk busy .
    tk busy busywindow .nonExistingWidget
} -cleanup {
    tk busy forget .
} -result {}

#
# TESTFILE CLEANUP
#

::tcltest::cleanupTests

# This file is a Tcl script to test labels, buttons, checkbuttons, and
# radiobuttons in Tk (i.e., all the widgets defined in tkButton.c).

#
# Copyright © 1994 The Regents of the University of California.
# Copyright © 1994-1996 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
    package require tcltest 2.2


    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

# Import utility procs for specific functional areas
testutils import button image

imageInit

#
# TESTS
#

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

} -body {
    .c configure -padx 0 -pady 0 -wraplength 0
    list [.c cget -padx] [.c cget -pady] [.c cget -borderwidth] [.c cget -highlightthickness] [.c cget -wraplength]
} -cleanup {
    destroy .c
} -result {0 0 0 0 0}


test button-2.1 {ButtonCreate - not enough arguments} -body {
    button
} -returnCodes error -result {wrong # args: should be "button pathName ?-option value ...?"}

test button-2.2 {ButtonCreate procedure - setting label class} -body {
    label .x
    winfo class .x

} -result {Button}

test button-2.7 {ButtonCreate - bad window name} -body {
    button foo
} -cleanup {
    destroy foo
} -returnCodes error -result {bad window path name "foo"}

test button-2.8 {ButtonCreate procedure - error in default option value} -body {
    option add *funny.background bogus
    button .funny
} -cleanup {
    option clear
    destroy .funny
} -returnCodes error -result {unknown color name "bogus"}

} -returnCodes error -result {unknown option "-gorp"}
test button-2.11 {ButtonCreate procedure - option error} -body {
    catch {button .x -gorp foo}
    winfo exists .x
}  -cleanup {
    destroy .x
} -result 0

test button-2.12 {ButtonCreate procedure - return value} -body {
    set x [button .abcd]
    return $x
} -cleanup {
    destroy .abcd
} -result {.abcd}


test button-3.1 {ButtonWidgetCmd - too few arguments} -body {
    button .b
    .b
} -cleanup {
    destroy .b
} -returnCodes error -result {wrong # args: should be ".b option ?arg ...?"}
test button-3.2 {ButtonWidgetCmd - bad option name} -body {

test button-3.12 {ButtonWidgetCmd procedure, "cget" option} -body {
    radiobutton .r
    .r cget -onvalue
} -cleanup {
    destroy .r
} -returnCodes error -result {unknown option "-onvalue"}


test button-3.13 {ButtonWidgetCmd procedure, "configure" option} -body {
    button .b -highlightthickness 3
    lindex [.b configure -highlightthickness] 4
} -cleanup {
    destroy .b
}  -result 3
test button-3.14 {ButtonWidgetCmd procedure, "configure" option} -body {

    destroy .r
    trace remove variable radiovar write bogusTrace
} -match glob -result {{*trace aborted
    while executing
*
".r select"} red}


test button-3.46 {ButtonWidgetCmd procedure, "toggle" option} -body {
    label .l
    .l toggle
} -cleanup {
    destroy .l
} -returnCodes error -result {bad option "toggle": must be cget or configure}
test button-3.47 {ButtonWidgetCmd procedure, "toggle" option} -body {

    set y From-y
    .b configure -textvariable y
    set x New
    lindex [.b configure -text] 4
} -cleanup {
    destroy .b
} -result {From-y}
test button-5.4 {ConfigureButton - variable trace} -body {
    checkbutton .c -variable x
    set x 1
    set y 1
    .c configure -textvariable y
    set x 0
    .c toggle
    return $y

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

#
# TESTFILE CLEANUP
#

imageFinish
testutils forget button image
cleanupTests


# Local variables:
# mode: tcl
# End:

# This file is a Tcl script to test out the procedures in tkCanvImg.c,
# which implement canvas "image" items.

#
# Copyright © 1994 The Regents of the University of California.
# Copyright © 1994-1996 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
    package require tcltest 2.2


    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

# Import utility procs for specific functional areas
testutils import image

imageInit

#
# COMMON TEST SETUP
#
# For every test case of the whole file
#
canvas .c
pack .c
update

#
# TESTS
#

test canvImg-1.1 {options for image items} -body {
    .c create image 50 50 -anchor nw -tags i1
    .c itemconfigure i1 -anchor
} -cleanup {
    .c delete all
} -result {-anchor {} {} center nw}

    .c delete all
    .c create image 50 100 -tags i1
    update
    .c create rect 55 110 65 115 -width 1 -outline black -fill white
    update
} -result {}

#
# COMMON TEST SETUP
#
# For tests canvImg-8.*
#
if {[testConstraint testImageType]} {
    image create test foo
}

test canvImg-8.1 {ImageToArea procedure} -constraints testImageType -setup {
	.c create image 50 100 -image foo -tags image -anchor nw
	.c create rect 10 10 20 20 -tags rect -fill black -width 0 -outline {}
} -body {
	.c coords rect 50 70 80 81
	.c gettags [.c find closest 70 90]
} -cleanup {

	.c create rect 10 10 20 20 -tags rect -fill black -width 0 -outline {}
} -body {
	.c coords rect {*}{60 70 71 111}
	.c gettags [.c find closest {*}{70 110}]
} -cleanup {
	.c delete all
} -result {rect}

#
# COMMON TEST CLEANUP
#
.c delete all

test canvImg-8.19 {ImageToArea procedure} -constraints testImageType -body {
    .c create image 50 100 -image foo -tags image -anchor nw
    .c gettags [.c find overlapping 60 0 70 99]
} -cleanup {
	.c delete all

} -result {}
test canvImg-8.44 {ImageToArea procedure} -constraints testImageType -body {
    .c create image 50 100 -image foo -tags image -anchor nw
    .c gettags [.c find enclosed 50 100 80 114]
} -cleanup {
	.c delete all
} -result {}

#
# COMMON TEST SETUP
#
if {[testConstraint testImageType]} {
	image delete foo
}


test canvImg-9.1 {DisplayImage procedure} -constraints testImageType -setup {
    .c delete all
	image create test foo
} -body {
    .c create image 50 100 -image foo -tags image -anchor nw
    .c scale image 25 0 2.0 1.5

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

#
# TESTFILE CLEANUP
#

imageFinish
testutils forget image
cleanupTests


# Local variables:
# mode: tcl
# End:

# This file is a Tcl script to test out the canvas "moveto" command. It is
# derived from canvRect.test.
#
# Copyright © 1994-1996 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# Copyright © 2004 Neil McKay.
# All rights reserved.

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
    package require tcltest 2.2

    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

#
# COMMON TEST SETUP
#
canvas .c -width 400 -height 300 -bd 2 -relief sunken
.c create rectangle 20 20 80 80 -tag {test rect1}
.c create rectangle 40 40 90 100 -tag {test rect2}

#
# TESTS
#

test canvMoveto-1.1 {Bad args handling for "moveto" command} -body {
    .c moveto test
} -returnCodes error -result {wrong # args: should be ".c moveto tagOrId x y"}
test canvMoveto-1.2 {Bad args handling for "moveto" command} -body {
    .c moveto rect
} -returnCodes error -result {wrong # args: should be ".c moveto tagOrId x y"}

} {150 150 222 232}
test canvMoveto-2.3 {Canvas "moveto" command, blank x coordinate} {
    .c moveto test 200 150
    .c moveto test {} 200
    .c bbox test
} {200 200 272 282}


#
# TESTFILE CLEANUP
#

.c delete withtag all
cleanupTests


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

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
    package require tcltest 2.2


    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

# Import utility procs for specific functional areas
testutils import image

imageInit

#
# TESTS
#

#
# COMMON TEST SETUP
#
# For tests canvas-1.* and canvas-2.*
#
canvas .c -width 400 -height 300 -bd 2 -relief sunken
.c create rectangle 20 20 80 80 -fill red
pack .c
update

test canvPs-1.1 {test writing to a file} -constraints {
    unixOrWin

	    set status broken
    }
    set status
} -cleanup {
    removeFile foo.ps
    removeFile bar.ps
} -result ok

#
# COMMON TEST CLEANUP
#
destroy .c

test canvPs-3.1 {test ps generation with an embedded window} -setup {
    set bar [makeFile {} bar.ps]
    file delete $bar
} -body {
    pack [canvas .c -width 200 -height 200 -background white]
    .c create rect 20 20 150 150 -tags rect0 -dash . -width 2

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

#
# TESTFILE CLEANUP
#

unset -nocomplain foo bar
imageFinish
testutils forget image
deleteWindows
cleanupTests


# Local variables:
# mode: tcl
# End:

# This file is a Tcl script to test out the procedures in tkRectOval.c,
# which implement canvas "rectangle" and "oval" items.

#
# Copyright © 1994-1996 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
    package require tcltest 2.2


    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

#
# COMMON TEST SETUP
#
# For every test case of the whole file
#
canvas .c -width 400 -height 300 -bd 2 -relief sunken
pack .c
update

#
# TESTS
#

#
# COMMON TEST SETUP
#
# For tests canvRect-1.*
#
.c create rectangle 20 20 80 80 -tag test

test canvRect-1.1 {configuration options: good value for -fill} -body {
    .c itemconfigure test -fill #ff0000
    list [.c itemcget test -fill] [lindex [.c itemconfigure test -fill] 4]
} -result {{#ff0000} #ff0000}
test canvRect-1.2 {configuration options: bad value for -fill} -body {
    .c itemconfigure test -fill non-existent
} -returnCodes error -result {unknown color name "non-existent"}

test canvRect-1.9 {configuration options: good value for -width} -body {
    .c itemconfigure test -width 6.0
    list [.c itemcget test -width] [lindex [.c itemconfigure test -width] 4]
} -result {6.0 6.0}
test canvRect-1.10 {configuration options: bad value for -width} -body {
    .c itemconfigure test -width abc
} -returnCodes error -result {expected screen distance but got "abc"}

#
# COMMON TEST CLEANUP
#
.c delete withtag all

test canvRect-2.1 {CreateRectOval procedure} -body {
    .c create rect
} -returnCodes error -result {wrong # args: should be ".c create rect coords ?arg ...?"}
test canvRect-2.2 {CreateRectOval procedure} -body {
    .c create oval x y z
} -returnCodes error -result {wrong # coordinates: expected 0 or 4, got 3}

	    lappend result [format %.1f $element]
    }
    set result
} -result {1.0 2.0 3.0 4.0}
test canvRect-2.8 {CreateRectOval procedure} -body {
    .c create rectangle 1 2 3 4 -gorp foo
} -returnCodes error -result {unknown option "-gorp"}

#
# COMMON TEST CLEANUP
#
.c delete withtag all

test canvRect-3.1 {RectOvalCoords procedure} -body {
    .c create rectangle 10 20 30 40 -tags x
    set result {}
    foreach element [.c coords x] {
	    lappend result [format %.1f $element]
    }

    .c bbox x
} -cleanup {
    .c delete withtag all
} -result {5 15 35 45}

# I can't come up with any good tests for DeleteRectOval.

test canvRect-5.1.1 {ComputeRectOvalBbox procedure} -constraints nonwin -body {
    .c create rectangle 10 20 30 40 -tags x -width 1 -outline {}
    .c coords x 20 15 10 5
    .c bbox x
} -cleanup {
    .c delete withtag all
} -result {10 5 20 15}
# On Windows the bbox of rectangle items is 1 pixel larger at each border due
# to the "bloat" implemented in ComputeRectOvalBbox() in case -outline is {}





test canvRect-5.1.2 {ComputeRectOvalBbox procedure} -constraints win32 -body {
    .c create rectangle 10 20 30 40 -tags x -width 1 -outline {}
    .c coords x 20 15 10 5
    .c bbox x
} -cleanup {
    .c delete withtag all
} -result {9 4 21 16}
test canvRect-5.2 {ComputeRectOvalBbox procedure} -body {
    .c create rectangle 10 20 30 40 -tags x -width 1 -outline {}
    .c coords x 10 20 30 10
    .c itemconfigure x -width 1 -outline red
    .c bbox x
} -cleanup {
    .c delete withtag all

restore showpage

%%Trailer
end
%%EOF
}




#
# TESTFILE CLEANUP
#

cleanupTests

# This file is a Tcl script to test out the procedures in tkCanvText.c,
# which implement canvas "text" items.

#
# Copyright © 1996-1997 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
    package require tcltest 2.2


    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

#
# TESTS
#

#
# COMMON TEST SETUP
#
# For tests canvas-1.* - 17.*
#
canvas .c -width 400 -height 300 -bd 2 -relief sunken
pack .c
update


.c create text 20 20 -tag test

test canvText-1.1 {configuration options: good value for "anchor"} -body {
    .c itemconfigure test -anchor nw
    list [lindex [.c itemconfigure test -anchor] 4] [.c itemcget test -anchor]
} -result {nw nw}
test canvasText-1.2 {configuration options: bad value for "anchor"} -body {
    .c itemconfigure test -anchor xyz
} -returnCodes error -result {bad anchor "xyz": must be n, ne, e, se, s, sw, w, nw, or center}

    .c itemconfigure test -angle 390
    set result [.c itemcget test -angle]
    .c itemconfigure test -angle -30
    lappend result [.c itemcget test -angle]
    .c itemconfigure test -angle -360
    lappend result [.c itemcget test -angle]
} -result {30.0 330.0 0.0}

#
# COMMON TEST CLEANUP
#
.c delete test

test canvText-2.1 {CreateText procedure: args} -body {
    .c create text
} -returnCodes error -result {wrong # args: should be ".c create text coords ?arg ...?"}
test canvText-2.2 {CreateText procedure: args} -body {
    .c create text xyz 0
} -cleanup {

    .c itemconfig test -font $font -text 0
    expr {[.c itemconfig test -anchor center; .c bbox test] \
	      eq "[expr -$ax/2-1] [expr -$ay/2] [expr $ax/2+1] [expr $ay/2]"}
} -cleanup {
    .c delete test
} -result 1

#
# COMMON TEST SETUP



#
focus .c
.c focus test
.c itemconfig test -text "abcd\nefghi\njklmnopq"

test canvText-7.1 {DisplayText procedure: stippling} -body {
    .c create text 20 20 -tag test
    .c itemconfig test -stipple gray50
    update
    .c itemconfig test -stipple {}
    update
} -cleanup {

} -body {
    .c itemconfig test -text "abcdefg"
    .c icursor test 3
    .c insert test 4 "xyz"
    .c index test insert
} -result 3

#
# COMMON TEST SETUP
#
# For tests canvasText-9.*
#
.c create text 20 20 -tag test

test canvText-9.1 {TextInsert procedure: before beginning/after end} -body {
    # Can't test this because GetTextIndex filters out those numbers.
} -result {}
test canvText-9.2 {TextInsert procedure: start > end} -body {
    .c itemconfig test -text "abcdefg"
    .c dchars test 4 2
    .c itemcget test -text

} -result 2
test canvText-9.15 {TextInsert procedure: cursor doesn't move} -body {
    .c itemconfig test -text "abcdefghijk"
    .c icursor test 5
    .c dchars test 7 9
    .c index test insert
} -result 5

#
# COMMON TEST CLEANUP
#
.c delete test

test canvText-10.1 {TextToPoint procedure} -body {
    .c create text 0 0 -tag test
    .c itemconfig test -text 0 -anchor center
    .c index test @0,0
} -cleanup {
	.c delete test

    .c select clear
    .c select from $id 0
    .c select to $id 8 ; update    ;  # used to crash on X11 (--disable-xft build only)
} -cleanup {
    destroy .c
} -result {}

#
# TESTFILE CLEANUP
#

cleanupTests

# This file is a Tcl script to test out the procedures in tkCanvWind.c,
# which implement canvas "window" items.

#
# Copyright © 1997 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
    package require tcltest 2.2


    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

#
# TESTS
#

test canvWind-1.1 {DisplayWinItem, windows off-screen vertically} -setup {
    destroy .t
} -body {
    toplevel .t
    canvas .t.c -scrollregion {0 0 1000 800} -width 250 -height 200 -bd 2 \
	    -relief sunken -xscrollincrement 1 -yscrollincrement 1 \

    bind .t.c.f <Configure> {destroy .t.c.f}
    .t.c coords $id 60 60 ;  # was crashing
    update
} -cleanup {
    destroy .t
} -result {}

#
# TESTFILE CLEANUP
#

cleanupTests

# This file is a Tcl script to test out the procedures in tkCanvas.c, which
# implements generic code for canvases.

#
# Copyright © 1995-1996 Sun Microsystems, Inc.
# Copyright © 1998-2000 Ajuba Solutions.
# Copyright © 2008 Donal K. Fellows
# All rights reserved.

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

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
    package require tcltest 2.2

    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

# Import utility procs for specific functional areas
testutils import image

imageInit

#
# LOCAL UTILITY PROCS
#

proc kill_canvas {w} {
    destroy $w
    pack [canvas $w -height 200 -width 200] -fill both -expand yes
    update idle
    $w create rectangle 80 80 120 120 -fill blue -tags blue
    # bind a button press to re-build the canvas
    $w bind blue <ButtonRelease-1> [subst {
	[lindex [info level 0] 0] $w
	append ::x ok
    }]
}

proc matchPixels {pixels expected} {
    set matched 1
    foreach pline $pixels eline $expected {
	foreach ppixel $pline epixel $eline {
	    if {$ppixel != $epixel} {
		set matched 0
		break
	    }
	}
    }
    return $matched
}

#
# TESTS
#

#
# COMMON TEST SETUP
#
# For tests canvas-1.*
#
canvas .c
pack .c
update

test canvas-1.1 {configuration options: good value for "background"} -body {
    .c configure -background #ff0000
    .c cget -background

    .c configure -gorp foo
} -returnCodes error -match glob -result {*}
test canvas-1.47 {configure throws error on bad option} -body {
    catch {.c configure -gorp foo}
    .c create rect 10 10 100 100
    .c configure -gorp foo
} -returnCodes error -match glob -result {*}

#
# COMMON TEST SETUP
#
# For tests canvas-2.*
#
catch {destroy .c}
canvas .c -width 60 -height 40 -scrollregion {0 0 200 150} -bd 0 \
	-highlightthickness 0
pack .c
update

test canvas-2.1 {CanvasWidgetCmd, bind option} -body {
    set i [.c create rect 10 10 100 100]

    .c raise aline noline
    .c raise bline aline
    .c lower aline noline
    .c lower bline aline
} -cleanup {
    .c delete aline
} -result {}

#
# COMMON TEST SETUP
#
# For tests canvas-3.*
#
catch {destroy .c}
canvas .c -width 60 -height 40 -scrollregion {0 0 200 80} \
	-borderwidth 0 -highlightthickness 0
pack .c
update

test canvas-3.1 {CanvasWidgetCmd, yview option} -body {
    .c configure -xscrollincrement 40 -yscrollincrement 5

    .c yview moveto 0
    update
    set x [list [.c yview]]
    .c yview scroll 2 units
    update
    lappend x [.c yview]
} -result {{0.0 0.5} {0.1 0.6}}

#
# COMMON TEST CLEANUP
#
destroy .c

test canvas-4.1 {ButtonEventProc procedure} -setup {
    deleteWindows
    set x {}
} -body {
    canvas .c1 -bg #543210

    canvas .c1
    rename .c1 {}
    list [info command .c*] [winfo children .]
} -cleanup {
    destroy .c1
} -result {{} {}}

#
# COMMON TEST SETUP
#
# For tests canvas-6.*
#
canvas .c -width 100 -height 50 -scrollregion {-200 -100 305 102} \
	-borderwidth 2 -highlightthickness 3
pack .c
update

test canvas-6.1 {CanvasSetOrigin procedure} -body {
    .c configure -xscrollincrement 0 -yscrollincrement 0

    .c canvasx 0
} -result {215.0}
test canvas-6.5 {CanvasSetOrigin procedure} -body {
    .c configure -xscrollincrement 20 -yscrollincrement 10
    .c yview moveto 1.0
    .c canvasy 0
} -result {55.0}

#
# COMMON TEST CLEANUP
#
deleteWindows

test canvas-7.1 {canvas widget vs hidden commands} -setup {
    canvas .c
} -body {
    interp hide {} .c
    destroy .c

    incr val
    # qx has type double and no string representation
    .c scale all $val 0 1 1
    # qx has now type MMRep and no string representation
    incr val
} -result 12













test canvas-13.1 {canvas delete during event, SF bug-228024} -body {
    kill_canvas .c
    set ::x {}
    # do this many times to improve chances of triggering the crash
    for {set i 0} {$i < 30} {incr i} {
	event generate .c <Button-1> -x 100 -y 100
	event generate .c <ButtonRelease-1> -x 100 -y 100

    destroy .c
    canvas .c
} -body {
    set id [.c create poly {0 0 50 50 100 50}]
    .c insert $id end {200 200}
    .c coords $id
} -result {0.0 0.0 50.0 50.0 100.0 50.0 200.0 200.0}

#
# COMMON TEST CLEANUP
#
destroy .c

test canvas-16.1 {arc coords check} -setup {
    canvas .c
} -body {
    set id [.c create arc {0 10 20 30} -start 33]
    .c itemcget $id -start

    set res [list [.c gettags 1]]
    .c dtag 1 tagA
    lappend res [.c gettags 1]
} -cleanup {
    destroy .c
} -result {{tagA tagA tagA tagA tagA tagA} {}}

#
# COMMON TEST CLEANUP
#
destroy .c

test canvas-21.1 {canvas rotate} -setup {
    pack [canvas .c]
} -body {
    .c create line 50 50 50 100 100 100
    .c rotate all 75 75 90
    lmap c [.c coords all] {format %.2f $c}
} -cleanup {

    list [lmap c [.c coords all] {format %.2f $c}] \
	[lmap o {} {.c itemcget all $o}] \
	[.c bbox all]
} -cleanup {
    destroy .c
} -result {{50.00 150.00} {} {25 125 50 150}}















test canvas-23.1 {canvas image} -setup {
    canvas .c
    image create photo testimage
} -body  {
    .c configure -background #c0c0c0 -scrollregion {0 0 9 9}
    .c create rectangle 0 0 0 9 -fill #000080 -outline #000080
    .c image testimage

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

#
# TESTFILE CLEANUP
#

imageCleanup
testutils forget image
cleanupTests


# Local Variables:
# mode: tcl
# End:

# This file is a Tcl script to test out Tk's "tk_chooseDir".

#
# Copyright © 1996 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
    package require tcltest 2.2


    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

# Import utility procs for specific functional areas
testutils import dialog


#

# LOCAL UTILITY PROCS
#






proc EnterDirsByKey {parent dirs} {
    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 ToEnterDirsByKey {parent dirs} {
    after 100 [list EnterDirsByKey $parent $dirs]
}

#
# COMMON TEST SETUP
#
set parent .

# Make a dir for us to rely on for tests
set real [makeDirectory choosedirTest]
set fake [file join [file dirname $real] non-existant]

#
# TESTS
#

test choosedir-1.1 {tk_chooseDirectory command} -body {
    tk_chooseDirectory -initialdir
} -returnCodes error -result {value for "-initialdir" missing}
test choosedir-1.2 {tk_chooseDirectory command} -body {
    tk_chooseDirectory -mustexist
} -returnCodes error -result {value for "-mustexist" missing}

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

#
# TESTFILE CLEANUP
#

unset fake parent real
removeDirectory choosedirTest
testutils forget dialog
cleanupTests

# This file is a Tcl script to test out Tk's clipboard management code,
# especially the "clipboard" command.

#
# Copyright © 1994 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

# NOTES
#
# * Multiple display clipboard handling will only be tested if the environment
#   variable TK_ALT_DISPLAY is set to an alternate display.
# * Some of these tests may fail if another application is grabbing the
#   clipboard (e.g. an X server, or a VNC viewer)

#
# TESTFILE INITIALIZATION
#




if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
    package require tcltest 2.2


    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

# Import utility procs for specific functional areas
testutils import child

#
# COMMON TEST SETUP
#

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


#
# TESTS
#

test clipboard-1.1 {ClipboardHandler procedure} -setup {
    clipboard clear
} -body {
    clipboard append "test"
    clipboard get
} -cleanup {

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

#
# TESTFILE CLEANUP
#

testutils forget child
cleanupTests


# Local Variables:
# mode: tcl
# End:

# This file is a Tcl script to test out Tk's "tk_chooseColor" command.

#
# Copyright © 1996 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
    package require tcltest 2.2

    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

# Import utility procs for specific functional areas
testutils import dialog

#
# LOCAL TEST CONSTRAINTS
#

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

	.c delete $i
	incr i
    }
    destroy .c
} else {
    testConstraint colorsLeftover 1
}

#
# LOCAL UTILITY PROCS
#

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 ToChooseColorByKey {parent r g b} {
    if {! $::dialogIsNative} {
	after 200 ChooseColorByKey . $r $g $b
    }
}

#
# TESTS
#

test clrpick-1.1 {tk_chooseColor command} -body {
    tk_chooseColor -foo
} -returnCodes error -result {bad option "-foo": must be -initialcolor, -parent, or -title}

test clrpick-1.2 {tk_chooseColor command } -body {
    tk_chooseColor -initialcolor

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




























test clrpick-2.1 {tk_chooseColor command} -constraints {
    nonUnixUserInteraction colorsLeftover
} -setup {
    set verylongstring [string repeat longstring: 100]
} -body {
    ToPressButton . ok
    tk_chooseColor -title "Press Ok $verylongstring" -initialcolor #404040 \

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

#
# TESTFILE CLEANUP
#

testutils forget dialog
cleanupTests

# This file is a Tcl script to test the [::tk::startOf|endOf]* functions in
# tk.tcl and tkIcu.c.
#
# Copyright © 1994 The Regents of the University of California.
# Copyright © 1994-1995 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
    package require tcltest 2.2

    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

#
# LOCAL TEST CONSTRAINTS
#
testConstraint needsICU [expr {[catch {info body ::tk::startOfCluster}]}]

#
# TESTS
#

test cluster-1.0 {::tk::startOfCluster} -body {
    ::tk::startOfCluster é -1
} -result {}
test cluster-1.1 {::tk::startOfCluster} -body {
    ::tk::startOfCluster é 0
} -result 0

} -returnCodes 1 -result {wrong # args: should be "::tk::endOfWord str start ?locale?"}
test cluster-8.5 {::tk::wordBreakBefore} -body {
    ::tk::wordBreakBefore a b c d
} -returnCodes 1 -result {wrong # args: should be "::tk::wordBreakBefore str start ?locale?"}
test cluster-8.6 {::tk::wordBreakAfter} -body {
    ::tk::wordBreakAfter a b c d
} -returnCodes 1 -result {wrong # args: should be "::tk::wordBreakAfter str start ?locale?"}

#
# TESTFILE CLEANUP
#

cleanupTests

# This file is a Tcl script to test the procedures in the file
# tkCmds.c.
#
# Copyright © 1996 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
    package require tcltest 2.2

    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

#
# COMMON TEST SETUP
#
update

#
# TESTS
#

test cmds-1.1 {tkwait visibility, argument errors} -body {
    tkwait visibility
} -returnCodes error -result {wrong # args: should be "tkwait variable|visibility|window name"}
test cmds-1.2 {tkwait visibility, argument errors} -body {
    tkwait visibility foo bar
} -returnCodes error -result {wrong # args: should be "tkwait variable|visibility|window name"}

    after 100 {set x deleted; destroy .f}
    catch {tkwait visibility .f.b}
    return $x
} -cleanup {
    destroy .f
} -result {deleted}

#
# TESTFILE CLEANUP
#

cleanupTests

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

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
    package require tcltest 2.2

    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

# Import utility procs for specific functional areas
testutils import colors

#
# LOCAL UTILITY PROCS
#

# c255  -
# Given a list of red, green, and blue intensities, scale them
# down to a 0-255 range.
#
# Arguments:
# vals -	List of intensities.

proc c255 {vals} {
    list [expr {[lindex $vals 0]/256}] [expr {[lindex $vals 1]/256}] \
	    [expr {[lindex $vals 2]/256}]
}

# closest -
# Given intensities between 0 and 255, return the closest intensities
# that the server can provide.
#
# Arguments:
# w -		Window in which to lookup color
# r, g, b -	Desired intensities, between 0 and 255.

proc closest {w r g b} {
    set vals [winfo rgb $w [cname $r $g $b]]
    list [expr [lindex $vals 0]/256] [expr [lindex $vals 1]/256] \
	    [expr [lindex $vals 2]/256]
}

# 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} {
    format #%02x%02x%02x $r $g $b
}
proc cname4 {r g b} {
    format #%04x%04x%04x $r $g $b
}

	    $c create rectangle [expr 10*$x] [expr 20*$y] \
		    [expr 10*$x + 10] [expr 20*$y + 20] -outline {} \
		    -fill $color
	}
    }
}




#



# LOCAL TEST CONSTRAINTS





#












# -- 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
# 'colorsFree' constraint doesn't get set, turning off pretty much every test
# in this file.
#
if {[testConstraint pseudocolor8]} {
    toplevel .t -visual {pseudocolor 8} -colormap new
    wm geom .t +0+0
    mkColors .t.c 40 6 0 0 0 0 6 0 0 0 40
    pack .t.c
    update

    testConstraint colorsFree [colorsFree .t.c 101 233 17]

    if {[testConstraint colorsFree]} {
	mkColors .t.c2 20 1 250 0 0 -10 0 0 0 0 0
	pack .t.c2
	testConstraint colorsFree [expr {![colorsFree .t.c]}]
    }
    destroy .t.c .t.c2
}

#
# TESTS
#

test color-1.1 {Tk_AllocColorFromObj - converting internal reps} colorsFree {
    set x green
    lindex $x 0
    destroy .b1
    button .b1 -foreground $x -text .b1
    lindex $x 0

    lappend result [testcolor purple]
    set y bogus
    set result
} -cleanup {
    rename copy {}
} -result {{{1 3}} {{1 2}} {{1 1}} {}}


#

# TESTFILE CLEANUP
#

destroy .t
testutils forget colors
cleanupTests

# This file is a Tcl script to test the procedures in tkConfig.c,
# which comprise the new new option configuration system.

#
# Copyright © 1997 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
    package require tcltest 2.2


    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

#
# LOCAL UTILITY PROCS
#

proc killTables {} {
    # Note: it's important to delete chain2 before chain1, because
    # chain2 depends on chain1.  If chain1 is deleted first, the
    # delete of chain2 will crash.
    deleteWindows
    foreach t {alltypes chain3 chain2 chain1 configerror internal
	    new notenoughparams twowindows} {
	    while {[testobjconfig info $t] != ""} {
		testobjconfig delete $t
	    }
    }
}

#
# TESTS
#

#
# COMMON TEST SETUP
#
option clear
deleteWindows
if {[testConstraint testobjconfig]} {
    killTables
}

test config-1.1 {Tk_CreateOptionTable - reference counts} -constraints {

test config-6.6 {GetOptionFromObj - synonym} -constraints testobjconfig -body {
    testobjconfig alltypes .b
    .b cget -synonym
} -cleanup {
    killTables
} -result red

#
# COMMON TEST SETUP
#
if {[testConstraint testobjconfig]} {
    testobjconfig alltypes .a
}

test config-7.1 {Tk_SetOptions - basics} -constraints testobjconfig -body {
    .a configure -color green -rel sunken
     list [.a cget -color] [.a cget -relief]
} -result {green sunken}
test config-7.2 {Tk_SetOptions - bogus option name} -constraints {
    testobjconfig
} -body {

} -body {
    catch {.a configure -custom bad}
    return $errorInfo
} -result {expected good value, got "BAD"
    (processing "-custom" option)
    invoked from within
".a configure -custom bad"}

#
# COMMON TEST CLEANUP
#
if {[testConstraint testobjconfig]} {
    killTables
}


test config-8.1 {Tk_RestoreSavedOptions - restore in proper order} -constraints {
    testobjconfig
} -body {
    testobjconfig alltypes .a
    .a csave -color green -color black -color blue \
	-color #ffff00 -color #ff00ff -color bogus \

    testobjconfig
} -body {
    catch {destroy .fpp}
    testobjconfig internal .foo
    .foo configure -custom "foobar"
    destroy .foo
} -result {}

#
# COMMON TEST CLEANUP
#
if {[testConstraint testobjconfig]} {
    killTables
}


test config-10.1 {Tk_GetOptionInfo - one item} -constraints testobjconfig -body {
    testobjconfig alltypes .foo
    .foo configure -anchor e
    .foo configure -anchor
} -cleanup {
    destroy .foo

} -result {{-boolean boolean Boolean {} {}} {-integer integer Integer 7 13563} {-double double Double 3.14159 3.14159} {-string string String foo foo} {-stringtable StringTable stringTable one one} {-stringtable2 StringTable2 stringTable2 two two} {-color color Color red red} {-font font Font {Helvetica 12} {Helvetica 18}} {-bitmap bitmap Bitmap gray50 gray50} {-border border Border blue blue} {-relief relief Relief {} {}} {-cursor cursor Cursor xterm xterm} {-justify {} {} left left} {-anchor anchor Anchor center center} {-pixel pixel Pixel 1 1} {-custom {} {} {} {}} {-synonym -color}}
test config-10.4 {Tk_GetOptionInfo - chaining through tables} -constraints testobjconfig -body {
    testobjconfig chain2 .foo -one asdf -three xyzzy
    .foo configure
} -cleanup {
    destroy .foo
} -result {{-three three Three three xyzzy} {-four four Four four four} {-two two Two {two and a half} {two and a half}} {-oneAgain oneAgain OneAgain {one again} {one again}} {-one one One one asdf} {-two two Two two {two and a half}}}



#
# COMMON TEST SETUP
#
if {[testConstraint testobjconfig]} {
    killTables
    testobjconfig alltypes .a
}

test config-11.1 {GetConfigList - synonym} -constraints testobjconfig -body {
    lindex [.a configure] end
} -result {-synonym -color}
test config-11.2 {GetConfigList - null database names} -constraints {
    testobjconfig
} -body {
    .a configure -justify
} -result {-justify {} {} left left}
test config-11.3 {GetConfigList - null default and current value} -constraints {
    testobjconfig
} -body {
    .a configure -relief
} -result {-relief relief Relief {} {}}



#
# COMMON TEST SETUP
#
if {[testConstraint testobjconfig]} {
    killTables
    testobjconfig internal .a
}

test config-12.1 {GetObjectForOption - boolean} -constraints testobjconfig -body {
    .a configure -boolean 0
    .a cget -boolean
} -result 0
test config-12.2 {GetObjectForOption - integer} -constraints testobjconfig -body {
    .a configure -integer 1247
    .a cget -integer

} -body {
    .a configure -string {} -color {} -font {} -bitmap {} -border {} \
	    -cursor {} -window {} -custom {}
    list [.a cget -string] [.a cget -color] [.a cget -font] \
	    [.a cget -bitmap] [.a cget -border] [.a cget -cursor] \
	    [.a cget -window] [.a cget -custom]
} -result {{} {} {} {} {} {} {} {}}

#
# COMMON TEST CLEANUP
#
if {[testConstraint testobjconfig]} {
    killTables
}


test config-13.1 {proper cleanup of options with widget destroy} -body {
    button .w -cursor crosshair
    destroy .w
} -result {}
test config-13.2 {proper cleanup of options with widget destroy} -body {
    canvas .w -cursor crosshair

	::foo::checkbutton .a
	::foo::checkbutton .b
	}
    ]
    destroy .a .b
} -result {}

#
# TESTFILE CLEANUP
#

deleteWindows
if {[testConstraint testobjconfig]} {
    killTables
}
cleanupTests

#
# WINDOWING SYSTEM AND DISPLAY
#
testConstraint notAqua [expr {[tk windowingsystem] ne "aqua"}]
testConstraint aqua [expr {[tk windowingsystem] eq "aqua"}]
testConstraint x11 [expr {[tk windowingsystem] eq "x11"}]
testConstraint win32 [expr {[tk windowingsystem] eq "win32"}]
testConstraint nonwin [expr {[tk windowingsystem] ne "win32"}]
testConstraint aquaOrWin32 [expr {
    ([tk windowingsystem] eq "win32") || [testConstraint aqua]
}]
testConstraint haveDISPLAY [expr {[info exists env(DISPLAY)] && [testConstraint x11]}]
testConstraint altDisplay  [info exists env(TK_ALT_DISPLAY)]

# This file is a Tcl script to test out the procedures in the file
# tkCursor.c.

#
# Copyright © 1998 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
    package require tcltest 2.2


    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows


#
# LOCAL UTILITY PROCS
#

# Tests 2.3 and 2.4 need a helper file with a very specific name and
# controlled format.
proc setWincur {wincurName} {
	upvar $wincurName wincur
	set wincur(data_octal) {
	    000 000 002 000 001 000 040 040 000 000 007 000 007 000 060 001

	foreach wincur(num) $wincur(data_octal) {
	    append wincur(data_binary) [binary format c [scan $wincur(num) %o]]
	}
	set wincur(dir) [makeDirectory {dir with spaces}]
	set wincur(file) [makeFile $wincur(data_binary) "test file.cur" $wincur(dir)]
}

#
# TESTS
#

test cursor-1.1 {Tk_AllocCursorFromObj - converting internal reps} -constraints {
    testcursor
} -body {
    set x watch
    lindex $x 0
    button .b -cursor $x

	button .b -text wait
} -body {
	.b configure -cursor wait
} -cleanup {
	destroy .b
} -result {}


#
# TESTFILE CLEANUP
#

cleanupTests

# This file is a Tcl script to test out Tk's "tk_dialog" command.

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
    package require tcltest 2.2

    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

# Import utility procs for specific functional areas
testutils import dialog

#
# TESTS
#

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

    after cancel $x
    return $res
} -cleanup {
    destroy .b
} -result -1

#
# TESTFILE CLEANUP
#

testutils forget dialog
cleanupTests

# This file is a Tcl script to test out embedded Windows.
#
# Copyright © 1996-1997 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
    package require tcltest 2.2


    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

#
# TESTS
#

test embed-1.1 {Tk_UseWindow procedure, bad window identifier} -setup {
    deleteWindows
} -body {
    toplevel .t -use xyz
} -cleanup {
    deleteWindows

} -body {
    frame .container
    toplevel .embd -use [winfo id .container]
} -cleanup {
    deleteWindows
} -returnCodes error -result {window ".container" doesn't have -container option set}

#
# TESTFILE CLEANUP

#

cleanupTests

# This file is a Tcl script to test entry widgets in Tk.

#
# Copyright © 1994 The Regents of the University of California.
# Copyright © 1994-1997 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

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

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
    package require tcltest 2.2


    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

# Import utility procs for specific functional areas
testutils import entry scroll

#
# COMMON TEST SETUP
#

foreach i {1 2 3} {
    set validateCmd$i [list validateCommand$i %W %d %i %P %s %S %v %V]
}
set cy [font metrics {Courier -12} -linespace]

#
# TESTS
#

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
} -body {
    .e configure -background #ff0000

    pack .e ; update idletasks
    update
    list [.e index @7] [.e index @8]
} -cleanup {
    destroy .e
} -result {0 1}

# Still need to write tests for EntryScanTo and EntrySelectTo.


test entry-14.1 {EntryFetchSelection procedure} -body {
    entry .e
    .e insert end "This is a test string"
    .e select from 1
    .e select to 18

    event generate .e <<NextWord>>  ; # shall move insert to index end
    .e delete 0 insert
    lappend res [.e get]
} -cleanup {
    destroy .e
} -result {{} {}}

#








# TESTFILE CLEANUP
#

# option clear
foreach i {1 2 3} {
    unset validateCmd$i
}
unset i
testutils forget entry scroll
cleanupTests

# This file is a Tcl script to test the code in tkEvent.c.

#
# Copyright © 1994 The Regents of the University of California.
# Copyright © 1994-1995 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

# NOTE



#
# This test file is woefully incomplete.  Right now it only tests
# a few of the procedures in tkEvent.c.  Please add more tests whenever
# possible.

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
    package require tcltest 2.2
    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

#
# LOCAL UTILITY PROCS
#

# _get_selection --
#
#    Return selection only if owned by the given widget
#
proc _get_selection {widget} {
    if {[string compare $widget [selection own]] != 0} {
	return ""
    }
    if {[catch {selection get} sel]} {
	return ""
    }
    return $sel
}

# _init_keypress_lookup --
#
#    Setup table used to query key events.
#
proc _init_keypress_lookup {} {
    global keypress_lookup

    # Characters with meaning to Tcl...
    array set keypress_lookup [list \
	    -    minus \
	    >    greater \

	    \}   braceright \
	    " "  space \
	    \xA0 nobreakspace \
	    "\n" Return \
	    "\t" Tab]
}













# _keypress --

#











#    Lookup and generate a pair of Key and KeyRelease events
#
proc _keypress {win key} {
    set keysym [_keypress_lookup $key]

    # Force focus to the window before delivering
    # each event so that a window manager using
    # 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
}

# _keypress_lookup --
#
#    Lookup an event in the keypress table.
#
#    For example:
#	 Q -> Q
#	 ; -> semicolon
#	 > -> greater
#	 Delete -> Delete
#	 Escape -> Escape
#
proc _keypress_lookup {char} {
    global keypress_lookup

    if {! [info exists keypress_lookup]} {
	_init_keypress_lookup
    }

    if {$char == ""} {
	error "empty char"
    }

    if {[info exists keypress_lookup($char)]} {
	return $keypress_lookup($char)
    } else {
	return $char
    }
}

# _keypress_string --
#
#    Call _keypress for each character in the given string
#
proc _keypress_string {win string} {
    foreach letter [split $string ""] {
	_keypress $win $letter
    }
}

# _text_ind_to_x_y --
#
#    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"
    }
    foreach {x1 y1 width height} $bbox break
    set middle_y [expr {$y1 + ($height / 2)}]
    return [list $x1 $middle_y]
}

proc create_and_pack_frames {{w {}}} {
    frame $w.f1 -bg blue -width 200 -height 200
    pack propagate $w.f1 0
    frame $w.f1.f2 -bg yellow -width 100 -height 100
    pack $w.f1.f2 $w.f1 -side bottom -anchor se
    update idletasks
}

# setup_win_mousepointer --
#
#    Position the window and the mouse pointer as an initial state for some tests.
#    The so-called "pointer window" is the $w window that will now contain the mouse pointer.
#
proc setup_win_mousepointer {w} {
    wm geometry . +700+400; # root window out of our way - must not cover windows from event-9.1*
    toplevel $w
    pack propagate $w 0
    wm geometry $w 300x300+100+100
    tkwait visibility $w
    update; # service remaining screen drawing events (e.g. <Expose>)
    set pointerWin [winfo containing [winfo pointerx $w] [winfo pointery $w]]
    event generate $w <Motion> -warp 1 -x 250 -y 250
    if {($pointerWin ne $w) && ([tk windowingsystem] ne "aqua")} {
	waitForWindowEvent $w <Enter>
    } else {
	controlPointerWarpTiming
    }
}

# waitForWindowEvent --
#
#    This proc is intended to overcome latency of windowing system
#    notifications when toplevel windows are involved. These latencies vary
#    considerably with the window manager in use, with the system load,
#    with configured scheduling priorities for processes, etc ...
#    Waiting for the corresponding window events evades the trouble that is
#    associated with the alternative: waiting or halting the Tk process for a
#    fixed amount of time (using "after ms"). With the latter strategy it's
#    always a gamble how much waiting time is enough on an end user's system.
#    It also leads to long fixed waiting times in order to be on the safe side.
#
proc waitForWindowEvent {w event {timeout 1000}} {

    variable _windowEvent

    # Use counter as a unique ID to prevent subsequent waits
    # from interfering with each other.
    set counter [incr _windowEvent(counter)]
    set _windowEvent($counter) 1
    set savedBinding [bind $w $event]
    bind $w $event [list +waitForWindowEvent.signal $counter]
    set afterID [after $timeout [list set _windowEvent($counter) -1]]
    vwait _windowEvent($counter)
    set late [expr {$_windowEvent($counter) == -1}]
    bind $w $event $savedBinding
    unset _windowEvent($counter)
    if {$late} {
	puts stderr "wait for $event event on $w timed out (> $timeout ms)"
    } else {
	after cancel $afterID
    }
}

# waitForWindowEvent.signal--
#
#    Helper proc that records the triggering of a window event.
#
proc waitForWindowEvent.signal {counter} {
    incr ::_windowEvent($counter)
}

#
# TESTS
#

test event-1.1 {Tk_HandleEvent procedure, filter events for dead windows} -setup {
	deleteWindows
    set x {}
} -body {
    button .b -text Test
    pack .b

    deleteWindows ; # destroy all children of ".", this already includes .top1
    if {$iconified} {
	wm deiconify .
	update
    }
} -result {.top1}






























































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

    set result
} -cleanup {
    bind all <Leave> {}
    bind all <Enter> {}
    unset result
} -result {|}

#
# TESTFILE 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 _text_ind_to_x_y {}
rename _get_selection {}
rename create_and_pack_frames {}
rename setup_win_mousepointer {}

cleanupTests

# This file is a Tcl script to test out Tk's "tk_getOpenFile" and
# "tk_getSaveFile" commands.

#
# Copyright © 1996 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.




#


# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #


    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
    package require tcltest 2.2

    tcltest::loadTestedCommands
}


# Ensure a pristine initial window state






resetWindows

# Import utility procs for specific functional areas





testutils import dialog

set tk_strictMotif_old $tk_strictMotif


#

# LOCAL UTILITY PROCS
#








proc EnterFileByKey {parent fileName fileDir} {
    global tk_strictMotif
    if {$parent == "."} {
	set w .__tk_filedialog
    } else {
	set w $parent.__tk_filedialog

	$data(ent) insert 0 $fileName
    }

    update
    SendButtonPress $parent ok mouse
}


proc ToEnterFileByKey {parent fileName fileDir} {
    if {! $::dialogIsNative} {
	after 100 EnterFileByKey $parent [list $fileName] [list $fileDir]
    }
}


#

# COMMON TEST SETUP
#






set unknownOptionsMsg(tk_getOpenFile,notAqua) {bad option "-foo": must be -defaultextension, -filetypes, -initialdir, -initialfile, -multiple, -parent, -title, or -typevariable}
set unknownOptionsMsg(tk_getOpenFile,aqua) {bad option "-foo": must be -command, -defaultextension, -filetypes, -initialdir, -initialfile, -message, -multiple, -parent, -title, or -typevariable}
set unknownOptionsMsg(tk_getSaveFile,notAqua) {bad option "-foo": must be -confirmoverwrite, -defaultextension, -filetypes, -initialdir, -initialfile, -parent, -title, or -typevariable}
set unknownOptionsMsg(tk_getSaveFile,aqua) {bad option "-foo": must be -command, -confirmoverwrite, -defaultextension, -filetypes, -initialdir, -initialfile, -message, -parent, -title, or -typevariable}

set tmpFile "filebox.tmp"

    }
    3 {
	{"Text files"		{.txt .doc}	TEXT}
	{"Foo"			{""}		TEXT}
    }
}

set parent .
set verylongstring [string repeat longstring: 16]

#
# TESTS
#

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"}}
test fileDialog-0.2 {GetFileName: file types: MakeFilter() fails} {
    # MacOS type that is too short, but looks ok in utf (4 bytes).

    set x [catch {tk_getSaveFile -filetypes {{"foo" .foo {\0\0}}}} msg]
    regsub -all "\0" $msg {\\0} msg
    list $x $msg
} {1 {bad Macintosh file type "\0\0"}}
# The next test must actually open a file dialog window, but it does
# not require human interaction to close the dialog because the Aqua
# port of tktest automatically closes every file dialog after a short
# timeout when tests are being run.
test fileDialog-0.3 {GetFileName: file types: bad filetype} \
-constraints aqua \
-body {
    # Checks for the Aqua crash reported in ticket 080a28104.
    set filename [tk_getOpenFile -filetypes {
	{"Invalid extension" {x.y}}
	{"All files" {*}}
    }]
} \
-result {}

# Test both the motif version and the "tk" version of the file dialog
# box on Unix.
#
# Note that this means that test names are unusually complex.
#
if {$tcl_platform(platform) eq "unix"} {
    set modes "0 1"
} else {
    set modes 1
}
foreach mode $modes {

    #
    # COMMON TEST SETUP
    #
    set addedExtensions {}
    if {$tcl_platform(platform) == "unix"} {
	set tk_strictMotif $mode
	# Extension adding is only done when using the non-motif file
	# box with an extension-less filename
	if {!$mode} {
	    set addedExtensions {NONE {} .txt .txt}

    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 ...?}?"}














    test filebox-2.1-$mode "tk_getOpenFile command" nonUnixUserInteraction {
	ToPressButton $parent cancel
	tk_getOpenFile -title "Press Cancel ($verylongstring)" -parent $parent
    } ""

    #
    # COMMON TEST SETUP
    #
    set fileName $tmpFile
    set fileDir [tcltest::temporaryDirectory]
    set pathName [file join $fileDir $fileName]

    test filebox-2.2-$mode "tk_getOpenFile command" nonUnixUserInteraction {
	ToPressButton $parent ok
	set choice [tk_getOpenFile -title "Press Ok" \

		-parent .t1 -initialdir $fileDir \
		-initialfile $fileName]
    } -result [list $pathName $pathName $pathName] -cleanup {
	destroy .t1
	destroy .t2
    }

    test fileDialog-2.7-$mode {"tk_getOpenFile: bad extension" -body {
	#ToPressButton $parent cancel
	set filename [tk_getOpenFile -filetypes {
	    {"Invalid extension" {x.y}}
	    {"All files" {*}}
	}]
	} -result {}
    }

    foreach x [lsort -integer [array names filters]] {
	test filebox-3.$x-$mode "tk_getOpenFile command" nonUnixUserInteraction {
	    ToPressButton $parent ok
	    set choice [tk_getOpenFile -title "Press Ok" \
		    -filetypes $filters($x) -parent $parent \
		    -initialfile $fileName -initialdir $fileDir]

    test filebox-4.1.2-$mode "tk_getSaveFile command" -constraints aqua -body {
	tk_getSaveFile -foo
    } -returnCodes error -result $unknownOptionsMsg(tk_getSaveFile,aqua)

    catch {tk_getSaveFile -foo 1} msg
    regsub -all ,      $msg "" options
    regsub \"-foo\" $options "" options

    foreach option $options {
	if {[string index $option 0] eq "-"} {
	    test filebox-4.2-$mode$option "tk_getSaveFile command" -body {
		tk_getSaveFile $option
	    } -returnCodes error -result "value for \"$option\" missing"
	}
    }

    } -returnCodes error -result {bad file type "Foo", should be "typeName {extension ?extensions ...?} ?{macType ?macTypes ...?}?"}

    test filebox-5.1-$mode "tk_getSaveFile command" nonUnixUserInteraction {
	ToPressButton $parent cancel
	tk_getSaveFile -title "Press Cancel ($verylongstring)" -parent $parent
    } ""

    #
    # COMMON TEST SETUP
    #
    set fileName "12x 455"
    set fileDir [pwd]
    set pathName [file join [pwd] $fileName]

    test filebox-5.2-$mode "tk_getSaveFile command" nonUnixUserInteraction {
	ToPressButton $parent ok
	set choice [tk_getSaveFile -title "Press Ok" \

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

#
# TESTFILE CLEANUP
#

set tk_strictMotif $tk_strictMotif_old
removeFile filebox.tmp
testutils forget dialog
cleanupTests

# This file is a Tcl script to test out the "focus" command and the
# other procedures in the file tkFocus.c.

#
# Copyright © 1994-1996 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
    package require tcltest 2.2

    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

# Import utility procs for specific functional areas
testutils import child


#
# LOCAL UTILITY PROCS

#




















# focusClear --
#
#    Ensures that there is no input focus in this application.  It does it by

#    arranging for another application to grab the focus.  The "after" and
#    "update" stuff is needed to wait long enough for pending actions to get
#    through the X server and possibly also the window manager.
#
if {[tk windowingsystem] eq "aqua"} {
    proc focusClear {} {
	childInterp eval {
	    focus -force .
	    set i 0
	    while {[focus] != "."} {
		after 100

    proc focusClear {} {
	childTkProcess eval {after 200; focus -force .; update}
	after 400
	update
    }
}

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
    }
    tkwait visibility .t.b4
}

proc focusSetupAlt {} {
    global env
    destroy .alt
    toplevel .alt -screen $env(TK_ALT_DISPLAY)
    foreach i {a b c d} {
	button .alt.$i -text .alt.$i -relief raised -bd 2
	pack .alt.$i
    }
    tkwait visibility .alt.d
}


#
# COMMON TEST SETUP
#

# childTkProcess exit will be after 4.3 test
childTkProcess create
update

if {[tk windowingsystem] eq "aqua"} {
    childTkInterp childInterp
}

focusSetup
if {[testConstraint altDisplay]} {
    focusSetupAlt
}

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

bind all <FocusIn> {
    append focusInfo "in %W %d\n"
}
bind all <FocusOut> {
    append focusInfo "out %W %d\n"
}
bind all <Key> {
    append focusInfo "press %W %K"
}

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

#
# TESTS
#

test focus-1.1 {Tk_FocusCmd procedure} -constraints unix -body {
    focusClear
    after 100
    focus
} -result {}
test focus-1.2 {Tk_FocusCmd procedure} -constraints {

    update
    focus -lastfor .t.b2
} -result {.t}
test focus-1.25 {Tk_FocusCmd procedure} -constraints unix -body {
    focus -unknown
} -returnCodes error -result {bad option "-unknown": must be -displayof, -force, or -lastfor}

#
# COMMON TEST SETUP
#
focusSetup

test focus-2.1 {TkFocusFilterEvent procedure} -constraints {
    unix nonPortable testwrapper
} -body {
    focusClear
    focus -force .b
    focusSetup
    update

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

#
# COMMON TEST CLEANUP
#
childTkProcess exit


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

    lappend result [focus]
    focus .t.b2
    update
    lappend result [focus]
} -cleanup {
    childTkProcess exit
} -result {.t {} {}}

#
# COMMON TEST CLEANUP
#
destroy .t
bind all <FocusIn> {}
bind all <FocusOut> {}
bind all <Key> {}
fixfocus


test focus-6.1 {miscellaneous - embedded application in same process} -constraints {
    unix  testwrapper
} -setup {
    eval interp delete [interp slaves]
} -body {
    toplevel .t
    wm geometry .t +0+0

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

#
# TESTFILE CLEANUP
#

deleteWindows
testutils forget child
cleanupTests
if {[tk windowingsystem] eq "aqua"} {
    interp delete childInterp
}

# This file is a Tcl script to test out the features of the script
# file focus.tcl, which includes the procedures tk_focusNext and
# tk_focusPrev, among other things.

#
# Copyright © 1995 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
    package require tcltest 2.2

    tcltest::loadTestedCommands

}

# Ensure a pristine initial window state
resetWindows


#
# LOCAL UTILITY PROCS
#

proc setup1 w {
    if {$w == "."} {
	set w ""
    }
    foreach i {a b c d} {
	destroy $w.$i

	destroy $w.$i
    }
    foreach i {x y z} {
	destroy $w.b.$i
    }
}

#
# COMMON TEST SETUP
#

option add *takeFocus 1
option add *highlightThickness 2
. configure -takefocus 1 -highlightthickness 2

#
# TESTS
#

test focusTcl-1.1 {tk_focusNext procedure, no children} -body {
    tk_focusNext .
} -result {.}

test focusTcl-1.2 {tk_focusNext procedure, basic tree traversal} -body {
    setup1 .

test focusTcl-3.9 {tk_focusPrev procedure, basic tree traversal} -body {
    setup1 .
    tk_focusPrev .a
} -cleanup {
    cleanup1 .
} -result {.}

#
# COMMON TEST SETUP
#

deleteWindows
setup1 .
toplevel .t
wm geom .t +0+0
toplevel .t2
wm geom .t2 -0+0
raise .t .a

test focusTcl-4.1 {tk_focusPrev procedure, toplevels} -setup {
    deleteWindows
} -body {
    setup1 .
    toplevel .t
    wm geom .t +0+0
    toplevel .t2

    bind Frame <Key> {foo}
    list [tk_focusNext .] [tk_focusNext .a]
} -cleanup {
    cleanup1 .
    bind Frame <Key> {}
} -result {.a .b}

#
# TESTFILE CLEANUP
#

. configure -takefocus 0 -highlightthickness 0
option clear


cleanupTests

# This file is a Tcl script to test out Tk's "font" command
# plus the procedures in tkFont.c.

#
# Copyright © 1996-1998 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
    package require tcltest 2.2


    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

#
# LOCAL UTILITY PROCS
#

proc clearnondefaultfonts {} {
    foreach afont [getnondefaultfonts] {
	font delete $afont
    }
}

proc csetup {{str ""}} {
    focus -force .t.c
    .t.c dchars text 0 end
    .t.c insert text 0 $str
    .t.c focus text
}

proc getnondefaultfonts {} {
    global defaultfontlist
    set nondeffonts [list ]
    foreach afont [font names] {
	if {$afont ni $defaultfontlist} {
	    lappend nondeffonts $afont
	}
    }
    set nondeffonts
}

proc psfontname {name} {
	destroy .t.c
	canvas .t.c -closeenough 0
	.t.c create text 0 0 -tags text -anchor nw -just left -font "Courier -12"
	pack .t.c
	update
    set a [.t.c itemcget text -font]
    .t.c itemconfig text -text "We need text" -font $name
    set post [.t.c postscript]
    .t.c itemconfig text -font $a
    set end [string first "findfont" $post]
    incr end -2
    set post [string range $post [expr $end-70] $end]
    set start [string first "gsave" $post]
	destroy .t.c
    return [string range $post [expr $start+7] end]
}

#
# COMMON TEST SETUP
#

set defaultfontlist [font names]

switch [tk windowingsystem] {
    x11		{set fixed "TkFixedFont"}
    win32	{set fixed "courier 12"}
    aqua	{set fixed "monaco 9"}
}

deleteWindows
# Toplevel used (in some tests) of the whole file
toplevel .t
wm geom .t +0+0
update idletasks






#
# TESTS







#

test font-1.1 {TkFontPkgInit} -setup {
    catch {interp delete foo}
} -body {
    interp create foo
    foo eval {
	load {} Tk

} -body {
    button .t.w1 -text abc
    entry .t.w2 -text abcd
    update
    destroy .t.w1 .t.w2
} -result {}




















test font-21.1 {Tk_PostscriptFontName procedure: native} -constraints {
	unix
} -body {
    set x [font actual {{itc avant garde} 10} -family]
    if {[string match *avant*garde $x]} {
		psfontname "{itc avant garde} 10"
    } else {

    .t.t tag config sel -underline 1
    .t.t tag add sel 1.0 end
    update
} -cleanup {
    destroy .t.t
} -result {}

#
# COMMON TEST SETUP
#
# For tests font-24.*
#

destroy .t.l
label .t.l -padx 0 -pady 0 -bd 0 -highlightthickness 0 -justify left \
	-text "0" -font "Courier -12"
pack .t.l
update
set ax [winfo reqwidth .t.l]
set ay [winfo reqheight .t.l]

test font-24.1 {Tk_ComputeTextLayout: empty string} -body {
    .t.l config -text ""
} -result {}
test font-24.2 {Tk_ComputeTextLayout: simple string} -body {
    .t.l config -text "000"
    update
    list [expr {[winfo reqwidth .t.l] eq [expr {$ax * 3}]}] \

    lappend x [expr {[winfo reqheight .t.l] eq $ay}]
    .t.l config -text "0000\n"
    update
    lappend x [expr {[winfo reqwidth .t.l] eq [expr {$ax * 4}]}]
    lappend x [expr {[winfo reqheight .t.l] eq [expr {$ay * 2}]}]
    set x
} -result {1 1 1 1}

#
# COMMON TEST CLEANUP
#
destroy .t.l

test font-24.15 {Tk_ComputeTextLayout: justification} -setup {
    set x {}
    destroy .t.c
    canvas .t.c -closeenough 0
    .t.c create text 0 0 -tags text -anchor nw -just left -font "Courier -12"

} -body {
    .t.f config -text foo
    .t.f config -text boo
} -cleanup {
    destroy .t.f
} -result {}

#
# COMMON TEST SETUP
#
# For tests font-26.*
#
destroy .t.c
canvas .t.c -closeenough 0
.t.c create text 0 0 -tags text -anchor nw -just left -font "Courier -12"
pack .t.c
update

test font-26.1 {Tk_DrawTextLayout procedure: auto-detect last char} -setup {
    destroy .t.f
    pack [label .t.f]
    update
} -body {
    .t.f config -text foo
} -cleanup {

    .t.c select to text 2
} -result {}
test font-26.6 {Tk_DrawTextLayout: draw subset of chunk: lastChar < numChars} -body {
    csetup "000\t00"
    .t.c select from text 4
    .t.c select to text 4
} -result {}

#
# COMMON TEST SETUP
#
# For tests font-27.*
#

destroy .t.c
destroy .t.f
pack [label .t.f]
update

test font-27.1 {Tk_UnderlineTextLayout procedure: no underline chosen} -body {
    .t.f config -text "foo" -underline {}
} -result {}
test font-27.2 {Tk_UnderlineTextLayout procedure: underline not visible} -body {
    .t.f config -text "000          00000" -wrap [expr $ax*7] -under 10
} -result {}
test font-27.3 {Tk_UnderlineTextLayout procedure: underline is visible} -body {
    .t.f config -text "000          00000" -wrap [expr $ax*7] -under 5
    .t.f config -wrap 0 -underline {}
} -result {}

#
# COMMON TEST SETUP
#
# For tests font-28.*
#

destroy .t.f
destroy .t.c
canvas .t.c -closeenough 0
.t.c create text 0 0 -tags text -anchor nw -just left -font "Courier -12"
pack .t.c
update

test font-28.1 {Tk_PointToChar procedure: above all lines} -body {
    csetup "000"
    .t.c index text @-1,0
} -result 0
test font-28.2 {Tk_PointToChar procedure: no chars} -body {
    # After fixing the following bug:
    #

    .t.c itemconfig text -width 0
    return $x
} -result 3
test font-28.11 {Tk_PointToChar procedure: below all chunks} -body {
    csetup "000 0000000"
    .t.c index text @0,1000000
} -result 11

#
# COMMON TEST SETUP
#
# For tests font-29.*
#

destroy .t.c
destroy .t.f
pack [label .t.f]
update

test font-29.1 {Tk_CharBBox procedure: index < 0} -body {
    .t.f config -text "000" -underline {}
} -result {}
test font-29.2 {Tk_CharBBox procedure: loop} -body {
    .t.f config -text "000\t000\t000\t000" -underline 9
} -result {}
test font-29.3 {Tk_CharBBox procedure: special char} -body {
    .t.f config -text "000\t000\t000" -underline 7
} -result {}
test font-29.4 {Tk_CharBBox procedure: normal char} -body {
    .t.f config -text "000" -underline 1
} -result {}
test font-29.5 {Tk_CharBBox procedure: right edge of bbox truncated} -body {
    .t.f config -text "0    0000" -wrap [expr $ax*4] -under 2
    .t.f config -wrap 0
} -result {}
test font-29.6 {Tk_CharBBox procedure: bbox pegged to right edge} -body {
    .t.f config -text "0    0000" -wrap [expr $ax*4] -under 3
    .t.f config -wrap 0
} -result {}

#
# COMMON TEST SETUP
#
# For tests font-30.*
#

destroy .t.f
destroy .t.c
canvas .t.c -closeenough 0
.t.c create text 0 0 -tags text -anchor nw -just left -font "Courier -12"
pack .t.c
update

test font-30.1 {Tk_DistanceToTextLayout procedure: loop once} -body {
    csetup "000\n000\n000"
    .t.c bind all <Enter> {lappend x [.t.c index current @%x,%y]}
    set x {}
    event generate .t.c <Leave>
    event generate .t.c <Enter> -x 0 -y 0
    return $x

    event generate .t.c <Leave>
    event generate .t.c <Enter> -x [expr $ax*5] -y $ay
    .t.c itemconfig text -width 0
    return $x
} -cleanup {
    bind all <Enter> {}
} -result {}

#
# COMMON TEST SETUP
#
.t.c itemconfig text -justify center

test font-30.7 {Tk_DistanceToTextLayout procedure: on left side} -body {
    csetup "0\n000"
    .t.c bind all <Enter> {lappend x [.t.c index current @%x,%y]}
    set x {}
    event generate .t.c <Leave>
    event generate .t.c <Enter> -x 0 -y 0
    return $x

    set x {}
    event generate .t.c <Leave>
    event generate .t.c <Enter> -x $ax -y $ay
    return $x
} -cleanup {
	bind all <Enter> {}
} -result 3

test font-30.13 {Tk_DistanceToTextLayout procedure: exact hit} -setup {
    .t.c itemconfig text -justify left
} -body {
    csetup "000"
    .t.c bind all <Enter> {lappend x [.t.c index current @%x,%y]}
    set x {}
    event generate .t.c <Leave>
    event generate .t.c <Enter> -x $ax -y 0
    return $x
} -cleanup {
    bind all <Enter> {}
} -result 1

#
# COMMON TEST SETUP
#
# For tests font-31.*
#
destroy .t.c
canvas .t.c -closeenough 0
.t.c create text 0 0 -tags text -anchor nw -just left -font "Courier -12"
pack .t.c
update

test font-31.1 {Tk_IntersectTextLayout procedure: loop once} -body {
    csetup "000\n000\n000"
    .t.c find overlapping 0 0 0 0
} -result [.t.c find withtag text]
test font-31.2 {Tk_IntersectTextLayout procedure: loop multiple} -body {
    csetup "000\t000\t000"
    .t.c find overlapping [expr $ax*10] 0 [expr $ax*10] 0

    # Coordinates of the rectangle to check can be hardcoded:
    # The goal of this test is to check whether the overlap detection algorithm
    # works when the rectangle is entirely included in a chunk of the text layout.
    # The text has been rotated 90 degrees around it's upper left corner,
    # so it's enough to check with a small rectangle with small negative y coords.
    .t.c find overlapping 5 -7 7 -5
} -result 1

#
# COMMON TEST CLEANUP
#
destroy .t.c

test font-32.1 {Tk_TextLayoutToPostscript: ensure buffer doesn't overflow} -setup {
    destroy .t.c
    canvas .t.c -closeenough 0
    .t.c create text 0 0 -tags text -anchor nw -just left -font "Courier -12"
    pack .t.c
    update

    apply $check $l
    set results
} -cleanup {
    destroy $l
    unset -nocomplain ::results
} -result {{1 1} {1 1} {1 1} {1 1}}




#
# TESTFILE CLEANUP
#

cleanupTests

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

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
    package require tcltest 2.2

    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

# Import utility procs for specific functional areas
testutils import dialog

set applyFontCmd [list set testDialogFont]

#
# LOCAL TEST CONSTRAINTS
#
catch {tk fontchooser -invalidOption}
testConstraint scriptImpl [llength [info proc ::tk::fontchooser::Configure]]

#
# TESTS
#

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}

test fontchooser-1.2 {tk fontchooser: usage} -returnCodes error -body {
    tk fontchooser configure -z

    tk fontchooser configure -visible
} -result 0

test fontchooser-1.9 {tk fontchooser: usage} -returnCodes error -body {
    tk fontchooser configure -visible 1
} -match glob -result {*}


#
# The remaining tests in this file are only relevant for the script
# 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.
#


test fontchooser-2.0 {fontchooser -title} -constraints scriptImpl -body {
    testDialog launch {
	tk::fontchooser::Configure -title "Hello"
	tk::fontchooser::Show
    }
    testDialog onDisplay {

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}

#
# TESTFILE CLEANUP
#

unset applyFontCmd
testutils forget dialog
cleanupTests


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

# This file is a Tcl script to test out the "frame", "labelframe" and
# "toplevel" commands of Tk.

#
# Copyright © 1994 The Regents of the University of California.
# Copyright © 1994-1996 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
    package require tcltest 2.2


    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

# Import utility procs for specific functional areas
testutils import colors

#
# LOCAL UTILITY PROCS
#

# optnames --
#
# Returns the option names out of a list of option details.
#
# Arguments:
# options -		The option detail list.
proc optnames {options} {
    lsort [lmap desc $options {lindex $desc 0}]
}

# uniq --
#
# Returns the unique items of a list in the order they first appear.
#
# Arguments:
# list -		The list to uniq-ify.
proc uniq {list} {
    set d {}
    foreach item $list {
	dict set d $item {}
    }
    return [dict keys $d]
}


#

# TESTS
#






test frame-1.1 {frame configuration options} -setup {
    deleteWindows
} -body {
    frame .f -class NewFrame
    .f configure -class
} -cleanup {

    }
    frame .g {*}$opts
} -cleanup {
    destroy .f .g
    deleteWindows
} -result .g

#
# COMMON TEST SETUP
#
destroy .f
frame .f

test frame-1.13 {frame configuration options} -body {
    .f configure -background #ff0000
    lindex [.f configure -background] 4
} -cleanup {
    .f configure -background [lindex [.f configure -background] 3]
} -result "#ff0000"
test frame-1.14 {frame configuration options} -body {

    lindex [.f configure -width] 4
} -cleanup {
    .f configure -width [lindex [.f configure -width] 3]
} -result 32
test frame-1.39 {frame configuration options} -body {
    .f configure -width badValue
} -returnCodes error -result {expected screen distance but got "badValue"}

#
# COMMON TEST CLEANUP
#
destroy .f

test frame-2.1 {toplevel configuration options} -setup {
    deleteWindows
} -body {
    toplevel .t -width 200 -height 100 -class NewClass
    wm geometry .t +0+0

test frame-2.14 {toplevel configuration options} -setup {
    deleteWindows
} -body {
    toplevel .t -width 200 -height 100 -visual who_knows?
} -returnCodes error -cleanup {
    deleteWindows
} -result {unknown or ambiguous visual name "who_knows?": class must be best, directcolor, grayscale, greyscale, pseudocolor, staticcolor, staticgray, staticgrey, truecolor, or default}




test frame-2.15 {toplevel configuration options} -constraints haveDISPLAY -setup {
    deleteWindows
} -body {
    toplevel .t -width 200 -height 100 -screen $env(DISPLAY)
    wm geometry .t +0+0
    .t configure -screen
} -cleanup {
    deleteWindows
} -result [expr {[tcltest::testConstraint haveDISPLAY]?[list -screen screen Screen {} $env(DISPLAY)]:""}]
test frame-2.16 {toplevel configuration options} -constraints haveDISPLAY -setup {
    deleteWindows
} -body {
    toplevel .t -width 200 -height 100 -screen $env(DISPLAY)
    wm geometry .t +0+0
    .t configure -screen another
} -returnCodes error -cleanup {

    }
    toplevel .g {*}$opts
} -cleanup {
    destroy .f .g
    deleteWindows
} -result .g

#
# COMMON TEST SETUP
#
destroy .t
toplevel .t -width 300 -height 150
wm geometry .t +0+0
update

test frame-2.20 {toplevel configuration options} -body {
    .t configure -background #ff0000
    lindex [.t configure -background] 4
} -result "#ff0000"
test frame-2.21 {toplevel configuration options} -body {
    .t configure -background non-existent
} -returnCodes error -result {unknown color name "non-existent"}

test frame-2.42 {toplevel configuration options} -body {
    .t configure -width 32
    lindex [.t configure -width] 4
} -result 32
test frame-2.43 {toplevel configuration options} -body {
    .t configure -width badValue
} -returnCodes error -result {expected screen distance but got "badValue"}

#
# COMMON TEST CLEANUP
#
destroy .t

test frame-3.1 {TkCreateFrame procedure} -returnCodes error -body {
    frame
} -result {wrong # args: should be "frame pathName ?-option value ...?"}
test frame-3.2 {TkCreateFrame procedure} -setup {
    deleteWindows

    list [expr {[winfo rootx .x] - [winfo rootx .t]}] \
	    [expr {[winfo rooty .x] - [winfo rooty .t]}] \
	    [winfo width .t] [winfo height .t]
} -cleanup {
    destroy .t
    option clear
} -result {0 0 140 300}

#
# COMMON TEST SETUP
#

# The tests below require specific display characteristics (i.e. that they are
# run on a pseudocolor display of depth 8).  Even so, they are non-portable:
# some machines don't seem to ever run out of colors.
if {[testConstraint defaultPseudocolor8]} {
    eatColors .t1
}

test frame-3.11 {TkCreateFrame procedure} -constraints {
    defaultPseudocolor8 nonPortable
} -setup {
    destroy .t
} -body {
    toplevel .t -width 300 -height 200 -bg #475601
    wm geometry .t +0+0

    toplevel .t -visual {grayscale 8} -width 300 -height 200 -bg #434343
    wm geometry .t +0+0
    update
    colorsFree .t 131 131 131
} -cleanup {
    destroy .t
} -result 1

#
# COMMON TEST CLEANUP
#
if {[testConstraint defaultPseudocolor8]} {
    destroy .t1
}

test frame-3.22 {TkCreateFrame procedure, default dimensions} -setup {
    deleteWindows
} -body {
    toplevel .t
    wm geometry .t +0+0
    update
    set result "[winfo reqwidth .t] [winfo reqheight .t]"

    deleteWindows
} -body {
    list [frame .f -width 200 -height 100] [winfo exists .f]
} -cleanup {
    deleteWindows
} -result {.f 1}

#
# COMMON TEST SETUP
#
frame .f -highlightcolor black

test frame-5.1 {FrameWidgetCommand procedure} -body {
    .f
} -returnCodes error -result {wrong # args: should be ".f option ?arg ...?"}
test frame-5.2 {FrameWidgetCommand procedure, cget option} -body {
    .f cget
} -returnCodes error -result {wrong # args: should be ".f cget option"}
test frame-5.3 {FrameWidgetCommand procedure, cget option} -body {

} -returnCodes error -result {value for "-height" missing}
test frame-5.12 {FrameWidgetCommand procedure} -body {
    .f swizzle
} -returnCodes error -result {bad option "swizzle": must be cget or configure}
test frame-5.13 {FrameWidgetCommand procedure, configure option} -body {
    optnames [. configure]
} -result {-background -backgroundimage -bd -bg -bgimg -borderwidth -class -colormap -container -cursor -height -highlightbackground -highlightcolor -highlightthickness -menu -padx -pady -relief -screen -takefocus -tile -use -visual -width}

#
# COMMON TEST CLEANUP
#
destroy .f

test frame-6.1 {ConfigureFrame procedure} -setup {
    deleteWindows
} -body {
    frame .f -width 150
    list [winfo reqwidth .f] [winfo reqheight .f]

    deleteWindows
} -body {
    labelframe .f
    .f configure -container 1
} -returnCodes error -cleanup {
    deleteWindows
} -result {can't modify -container option after widget is created}

#
# COMMON TEST SETUP
#

destroy .f
labelframe .f

test frame-13.10 {labelframe configuration options} -body {
    .f configure -background #ff0000
    lindex [.f configure -background] 4
} -cleanup {
    .f configure -background [lindex [.f configure -background] 3]
} -result "#ff0000"
test frame-13.11 {labelframe configuration options} -body {

    lindex [.f configure -width] 4
} -cleanup {
    .f configure -width [lindex [.f configure -width] 3]
} -result 32
test frame-13.44 {labelframe configuration options} -body {
    .f configure -width badValue
} -returnCodes error -result {expected screen distance but got "badValue"}

#
# COMMON TEST CLEANUP
#
destroy .f

test frame-14.1 {labelframe labelwidget option} -setup {
    deleteWindows
} -body {
    # Test that label is moved in stacking order
    label .l -text Mupp -font {helvetica 8}

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

#
# TESTFILE CLEANUP
#

deleteWindows
apply {cmds {foreach cmd $cmds {rename $cmd {}}}} {
    uniq optnames
}
testutils forget colors
cleanupTests


# 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).

#
# Copyright © 1994 The Regents of the University of California.
# Copyright © 1994 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
    package require tcltest 2.2

    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows


#
# COMMON TEST SETUP
#

wm geometry . 300x300
raise .
update

frame .f -bd 2 -relief raised
frame .f.f -bd 2 -relief sunken
frame .f.f.f -bd 2 -relief raised
button .b1 -text .b1
button .b2 -text .b2
button .b3 -text .b3
button .f.f.b4 -text .b4

#
# TESTS
#

test geometry-1.1 {Tk_ManageGeometry procedure} -setup {
	foreach w {.f .f.f .f.f.f .b1 .b2 .b3} {
	place forget $w
    }
} -body {
    place .b1 -x 120 -y 80

    wm deiconify .t
    update
    winfo ismapped .t.quit
} -cleanup {
    destroy .t
} -result 1

#
# TESTFILE CLEANUP
#

cleanupTests

# This file is a Tcl script to test out the procedures in the file
# tkGet.c.

#
# Copyright © 1998 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
    package require tcltest 2.2

    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

#
# TESTS
#

test get-1.1 {Tk_GetAnchorFromObj} -setup {
    button .b
} -body {
    .b configure -anchor n
    .b cget -anchor
} -cleanup {

test get-2.4 {Tk_GetJustifyFromObj - error} -setup {
    button .b
} -body {
    .b configure -justify stupid
} -cleanup {
    destroy .b
} -returnCodes error -result {bad justification "stupid": must be left, right, or center}

#
# TESTFILE CLEANUP
#

# cleanup
cleanupTests

# Tests for the grab command.
#




# Copyright © 1998-2000 Ajuba Solutions.
# All rights reserved.

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
    package require tcltest 2.2

    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

# The macOS test module includes the testpressbutton command to simulate a
# mouse button press event by injecting events into the NSApplication
# event queue.  On other platforms there is currently no way to test
# the actual grab effect, per se, in an automated test.  Therefore,
# this test suite only covers the interface to the grab command (ie,
# error messages, etc.) on platforms other than macOS.

#
# TESTS
#

test grab-1.1 {Tk_GrabObjCmd} -body {
    grab
} -returnCodes error -result {wrong # args: should be "grab ?-global? window" or "grab option ?arg ...?"}
test grab-1.2 {Tk_GrabObjCmd} -body {
    rename grab grabTest1.2
    grabTest1.2

    testpressbutton 250 250
    update
    return $result
} -cleanup {
    grab release .f
} -result {inside outside : outside : inside outside :}



#
# TESTFILE CLEANUP
#

cleanupTests

# This file is a Tcl script to test out the *NEW* "grid" command of Tk.

#
# Copyright © 1996 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
    package require tcltest 2.2

    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

#
# LOCAL UTILITY PROCS
#

# grid_reset --
#
#    Helper routine to return "." to a sane state after a test.
#    The variable GRID_VERBOSE can be used to "look" at the result of one or all
#    of the tests
#
proc grid_reset {{test ?} {top .}} {
    global GRID_VERBOSE
    if {[info exists GRID_VERBOSE]} {
	if {$GRID_VERBOSE eq "" || $GRID_VERBOSE eq $test} {
	    puts -nonewline "grid test $test: "
	    flush stdout
	    gets stdin

    for {set i 0} {$i <= $rows} {incr i} {
	grid rowconfigure . $i -weight 0 -minsize 0 -pad 0 -uniform ""
    }
    grid propagate . 1
    grid anchor . nw
    update
}

#
# COMMON TEST SETUP
#

grid_reset 0.0
wm geometry . {}

#
# TESTS
#

test grid-1.1 {basic argument checking} -body {
    grid
} -returnCodes error -result {wrong # args: should be "grid option arg ?arg ...?"}
test grid-1.2 {basic argument checking} -body {
    grid foo bar
} -returnCodes error -result {bad option "foo": must be anchor, bbox, columnconfigure, configure, content, forget, info, location, propagate, remove, rowconfigure, or size}
test grid-1.3 {basic argument checking} -body {

    grid .f.f
    append res [grid columnconfigure .f {.f.f} -weight 1]
    append res [grid columnconfigure .f {.f.f 1} -weight 1]
    append res [grid columnconfigure .f {2 .f.f} -weight 1]
    destroy .f
    return $res
} -cleanup {
    grid_reset 10.32
} -result {}
test grid-10.33 {column/row configure} -body {
    grid columnconfigure . all
} -cleanup {
    grid_reset 10.33
} -returnCodes error -result {expected integer but got "all" (when retrieving options only integer indices are allowed)}
test grid-10.34 {column/row configure} -body {
    grid columnconfigure . 100000
} -cleanup {
    grid_reset 10.34
} -result {-minsize 0 -pad 0 -uniform {} -weight 0}
test grid-10.35 {column/row configure} -body {
    # This is a test for bug 1423666 where a column >= 10000 caused
    # a crash in layout.  The update is needed to reach the layout stage.
    # Test different combinations of row/column overflow
    frame .f
    set res {}
    lappend res [catch {grid .f -row 10 -column 9999} msg] $msg ; update
    lappend res [catch {grid .f -row 9999 -column 10} msg] $msg ; update
    lappend res [catch {grid .f -columnspan 2 -column 9998} msg] $msg ; update
    lappend res [catch {grid .f -rowspan 2 -row 9998} msg] $msg ; update
    lappend res [catch {grid .f -column 9998 -columnspan 2} msg] $msg ; update
    lappend res [catch {grid .f -row 9998 -rowspan 2} msg] $msg ; update
    return $res
} -cleanup {
    destroy .f
    grid_reset 10.35
} -result [lrange {
    1 {column out of bounds}
    1 {row out of bounds}
    1 {column out of bounds}
    1 {row out of bounds}
    1 {column out of bounds}
    1 {row out of bounds}
} 0 end]

test grid-10.36 {column/row configure} -body {
    # Additional tests for row/column overflow
    frame .f
    frame .g
    set res {}
    grid .f -row 9998 -column 0
    lappend res [catch {grid ^ -in .} msg] $msg  ; update
    lappend res [catch {grid .g} msg] $msg  ; update
    grid forget .f .g
    lappend res [catch {grid .f - -column 9998} msg] $msg ; update
    grid forget .f .g
    lappend res [catch {eval grid [string repeat " x " 9999] .f} msg] $msg
    update
    return $res
} -cleanup {
    destroy .f .g
    grid_reset 10.36
} -result [lrange {
    1 {row out of bounds}
    1 {row out of bounds}
    1 {column out of bounds}
    1 {column out of bounds}
} 0 end]


# auto-placement tests
test grid-11.1 {default widget placement} -body {
    grid ^
} -cleanup {
    grid_reset 11.1
} -returnCodes error -result {can't use '^', can't find container window}

} -returnCodes error -result {bad window path name ".bad"}
test grid-13.4 {-in} -body {
    frame .f -bg red
    toplevel .top
    grid .f -in .top
} -cleanup {
    grid_reset 13.3

    destroy .top
} -returnCodes error -result {can't put ".f" inside ".top"}
test grid-13.5 {-ipadx} -body {
    frame .f -width 20 -height 20 -highlightthickness 0 -bg red
    grid .f -ipadx x
} -cleanup {
    grid_reset 13.4
} -returnCodes error -result {bad ipadx value "x": must be positive screen distance}
test grid-13.6 {-ipadx} -body {

} -result [list {37 20 225 150} {75 20 225 150} {75 60 225 150} {75 100 225 150} \
	   {37 100 225 150} {0 100 225 150} {0 60 225 150} {0 20 225 150} \
	   {37 60 225 150}]

test grid-22.1 {remove: basic argument checking} {
    list [catch {grid remove foo} msg] $msg
} {1 {bad window path name "foo"}}
test grid-22.2 {remove} -body {
    button .c
    grid [button .b]
    set a [grid content .]
    grid remove .b .c
    lappend a [grid content .]
    return $a
} -cleanup {
    grid_reset 22.2
} -result {.b {}}
test grid-22.3 {remove} -body {
    button .c
    grid .c -row 2 -column 2 -rowspan 2 -columnspan 2 -padx 3 -pady 4 -sticky ns
    grid remove .c
    grid .c -row 0 -column 0
    grid info .c
} -cleanup {
    grid_reset 22.3
} -result {-in . -column 0 -row 0 -columnspan 2 -rowspan 2 -ipadx 0 -ipady 0 -padx 3 -pady 4 -sticky ns}
test grid-22.3.1 {remove} -body {
    frame .a
    button .c
    grid .c -in .a -row 2 -column 2 -rowspan 2 -columnspan 2 -padx {3 5} -pady {4 7} -sticky ns
    grid remove .c
    grid .c -row 0 -column 0
    grid info .c
} -cleanup {
    grid_reset 22.3.1
} -result {-in .a -column 0 -row 0 -columnspan 2 -rowspan 2 -ipadx 0 -ipady 0 -padx {3 5} -pady {4 7} -sticky ns}
test grid-22.4 {remove, calling Tk_UnmaintainGeometry} -body {
    frame .f -bd 2 -relief raised
    place .f -x 10 -y 20 -width 200 -height 100
    frame .f2 -width 50 -height 30 -bg red
    grid .f2 -in .f
    update
    set x [winfo ismapped .f2]
    grid remove .f2
    place .f -x 30
    update
    lappend x [winfo ismapped .f2]
} -cleanup {
    grid_reset 22.4
} -result {1 0}
test grid-22.5 {remove} -body {
    frame .a
    button .c
    grid .c -in .a -row 2 -column 2 -rowspan 2 -columnspan 2 -padx {3 5} -pady {4 7} -sticky ns
    grid remove .c
    # If .a was destroyed while remembered by the removed .c, make sure it
    # is ignored.
    destroy .a
    grid .c -row 0 -column 0
    grid info .c
} -cleanup {
    grid_reset 22.5
} -result {-in . -column 0 -row 0 -columnspan 2 -rowspan 2 -ipadx 0 -ipady 0 -padx {3 5} -pady {4 7} -sticky ns}

test grid-23 {grid configure -in leaked from previous container window - bug
	      6aea69fccbb266b7f0437686379fbe5b55442958} -body {
    frame .f
    frame .g
    pack .f .g
    text .t
    grid .t -in .f
    pack forget .f
    update
    grid .t -in .g
    # .t is now managed by .g; following lines must have no effect on .t
    pack .f
    update
    pack forget .f
    update
    winfo ismapped .t ; # must return 1
} -cleanup {
    grid_reset 23
} -result 1

test grid-24.1 {<<NoManagedChild>> fires on last grid forget} -setup {
    global A
    unset -nocomplain A
} -body {
    grid [frame .1]
    update

    grid forget .1
    update
    info exists A
} -cleanup {
    bind . <<NoManagedChild>> {}
    grid_reset 24.8
} -result 0

#
# TESTFILE CLEANUP
#

cleanupTests


# Local Variables:
# mode: tcl
# End:

# This file is a Tcl script to test out the "image" command and the
# other procedures in the file tkImage.c.

#
# Copyright © 1994 The Regents of the University of California.
# Copyright © 1994 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
    package require tcltest 2.2


    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

# Import utility procs for specific functional areas
testutils import image

imageInit

#
# COMMON TEST SETUP
#

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

#
# TESTS
#

test image-1.1 {Tk_ImageCmd procedure, "create" option} -body {
    image
} -returnCodes error -result {wrong # args: should be "image option ?args?"}
test image-1.2 {Tk_ImageCmd procedure, "create" option} -body {
    image gorp
} -returnCodes error -result {bad option "gorp": must be create, delete, height, inuse, names, type, types, or width}

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

#
# TESTFILE CLEANUP
#

destroy .c
imageFinish
testutils forget image
cleanupTests


# 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).

#
# Copyright © 1994 The Regents of the University of California.
# Copyright © 1994-1995 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
    package require tcltest 2.2


    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

# Import utility procs for specific functional areas
testutils import image

imageInit

#
# LOCAL UTILITY PROCS
#

proc bgerror msg {
    global errMsg
    set errMsg $msg
}

#
# COMMON TEST SETUP
#

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[] = {
   0xff, 0xff, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81,

       0xff, 0x81, 0xff, 0xff, 0xff, 0xff, 0xff, 0x81, 0xff, 0x81, 0xff, 0x81,
       0xff, 0x81, 0xff, 0x81, 0xff, 0x81, 0xff, 0xff};
}
makeFile $data1 foo.bm
makeFile $data2 foo2.bm

imageCleanup










#
# TESTS
#

test imageBmap-1.1 {options for bitmap images} -body {
    image create bitmap i1 -background #123456
    lindex [i1 configure -background] 4
} -cleanup {
	image delete i1
} -result {#123456}

    image create bitmap i1 -file foo.bm -maskfile foo2.bm
    lindex [i1 configure -maskfile] 4
} -result foo2.bm
test imageBmap-1.12 {options for bitmap images} -body {
    list [catch {image create bitmap i1 -data $data1 -maskfile bogus} msg] \
	    [string tolower $msg]
} -result {1 {couldn't read bitmap file "bogus": no such file or directory}}

#
# COMMON TEST CLEANUP
#
rename bgerror {}

test imageBmap-2.1 {ImgBmapCreate procedure} -setup {
    imageCleanup
} -body {
    list [catch {image create bitmap -gorp dum} msg] $msg [imageNames]
} -result {1 {unknown option "-gorp"} {}}
test imageBmap-2.2 {ImgBmapCreate procedure} -setup {

    makeFile {1234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890} foo3.bm
    image create bitmap i1 -file foo3.bm
} -returnCodes error -result {format error in bitmap data}
test imageBmap-6.3 {NextBitmapWord procedure} -setup {imageCleanup} -body {
    makeFile {   } foo3.bm
    image create bitmap i1 -file foo3.bm
} -returnCodes error -result {format error in bitmap data}

#
# COMMON TEST SETUP
#
# For tests imageBmap-7.*
#
removeFile foo3.bm
imageCleanup

image create bitmap i1

test imageBmap-7.1 {ImgBmapCmd procedure} -body {
    i1
} -returnCodes error -result {wrong # args: should be "i1 option ?arg ...?"}
test imageBmap-7.2 {ImgBmapCmd procedure, "cget" option} -body {
    i1 cget
} -returnCodes error -result {wrong # args: should be "i1 cget option"}
test imageBmap-7.3 {ImgBmapCmd procedure, "cget" option} -body {

} -returnCodes error -result {unknown option "-gorp"}
test imageBmap-7.9 {ImgBmapCmd procedure} -body {
    i1 configure -foreground #221100 -background
} -returnCodes error -result {value for "-background" missing}
test imageBmap-7.10 {ImgBmapCmd procedure} -body {
    i1 gorp
} -returnCodes error -result {bad option "gorp": must be cget or configure}

#
# COMMON TEST CLEANUP
#
imageCleanup

test imageBmap-8.1 {ImgBmapGet/Free procedures, shared instances} -setup {
    destroy .c
    pack [canvas .c]
    update
} -body {

    .c create image 50 100 -image i1 -tags i1.1
    i1 configure -foreground bogus
    update
} -cleanup {
    image delete i1
    destroy .c
} -result {}

#
# COMMON TEST CLEANUP
#
if {[info exists bgerror]} {
    rename bgerror {}
}


test imageBmap-10.1 {ImgBmapFree procedure, resource freeing} -setup {
    destroy .c
    pack [canvas .c]
    update
} -body {
    imageCleanup

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

#
# TESTFILE CLEANUP
#

removeFile foo.bm
removeFile foo2.bm
imageFinish
testutils forget image
cleanupTests


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

# This file is a Tcl script to test out the default image data format
# ("list format") implementend in the file tkImgListFormat.c.

#
# Copyright © 2017 Simon Bachmann
# All rights reserved.
#
# Author: Simon Bachmann ([email protected])

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
    package require tcltest 2.2


    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

# Import utility procs for specific functional areas
testutils import image

imageInit

#
# TEST INITIALIZATION
#

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


#
# TESTS
#

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 {

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

#
# TESTFILE CLEANUP
#

imageFinish
testutils forget image
cleanupTests

# This file is a Tcl script to test out the code in tkImgFmtPNG.c, which reads
# and write PNG-format image files for photo widgets.

#
# Copyright © 1994-1997 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# Copyright © 1998 Willem van Schaik (images only)
# Copyright © 2008 Donal K. Fellows
# All rights reserved.

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
    package require tcltest 2.2


    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

# Import utility procs for specific functional areas
testutils import image

imageInit

#
# COMMON TEST SETUP
#

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
    # images.

r661tV1eju/ne8YJrkWtES0tmRe2VOviv2j2aBp5nHihiRaz/A4oCnsAsje/+AAAAAElFTkSuQmCC"
    dpi100aspect2
"iVBORw0KGgoAAAANSUhEUgAAAAIAAAACCAIAAAD91JpzAAAACXBIWXMAAA9hAAAewgEw8YEEAAAA
FklEQVR4nGP4+vXrP11lJgYGhj9xSQAzOwXsETZ69QAAAABJRU5ErkJggg=="
	}

# $encoded(basn0g08), $encoded(basn2c08), $encoded(basn3p08), $encoded(basn6a08)

#
# TESTS
#

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 {
    rename foo ""

    image create photo i1 -data $encoded(dpi100aspect2)
    i1 cget -metadata
} -cleanup {
    image delete i1
} -result {DPI 99.9998 aspect 2.0}

test imgPNG-4.2 {file image with metadata} -setup {
    set path [file join [tcltest::configure -tmpdir] test.png]
    set h [open $path "WRONLY BINARY CREAT"]
    puts -nonewline $h [binary decode base64 $encoded(dpi100aspect2)]
    close $h
} -body {
    image create photo i1 -file $path
    i1 cget -metadata
} -cleanup {

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

test imgPNG-4.4 {file output with metadata} -setup {
    image create photo i1 -data $encoded(dpi100aspect2)
    set path [file join [tcltest::configure -tmpdir] test.png]
} -body {
    i1 write $path -format png
    image delete i1
    image create photo i1 -file $path
    i1 cget -metadata
} -cleanup {
    image delete i1
    file delete $path
} -result {DPI 99.9998 aspect 2.0}

}

#
# TESTFILE CLEANUP
#

namespace delete png
imageFinish
testutils forget image
cleanupTests


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

#
# Copyright © 1994-1997 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
    package require tcltest 2.2


    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

# Import utility procs for specific functional areas
testutils import image

imageInit

#
# LOCAL UTILITY PROCS
#

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

#
# TESTS
#

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"

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

#
# TESTFILE CLEANUP
#

imageFinish
catch {file delete test.ppm}
testutils forget image
cleanupTests


# Local Variables:
# mode: tcl
# End:

# This file is a Tcl script to test out the "photo" image type and the other
# procedures in the file tkImgPhoto.c.

#
# Copyright © 1994 The Australian National University
# Copyright © 1994-1997 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# Copyright © 2002-2008 Donal K. Fellows
# All rights reserved.
#
# Author: Paul Mackerras ([email protected])

# NOTES
#
# This file is somewhat chaotic: the order of the tests does not
# really follow the order of the corresponding functions in
# tkImgPhoto.c. Probably, because early versions had only a few tests
# and over time test cases were added in bits and pieces.
# To be noted, also, that this file is not complete: large portions of
# code in tkImgPhoto.c have no test coverage.
#
# To help keeping the overview, the table below lists where to find
# tests for each of the functions in tkImgPhoto.c. The function are
# listed in the order as they appear in the source file.


#
# Function name                         Tests for function
#--------------------------------------------------------------------------
# PhotoFormatThreadExitProc             no tests
# Tk_Create*PhotoImageFormat            no tests
# ImgPhotoCreate                        imgPhoto-2.*
# ImgPhotoCmd                           imgPhoto-4.*, imgPhoto-17.*

# ImgGetPhoto:                          no tests
# Tk_PhotoGetImage                      no tests
# ImgPostscriptPhoto                    no tests
# Tk_PhotoGetMetadata:                  imgPhoto-21.*
# Tk_PhotoSetMetadata:                  imgPhoto-22.*
#--------------------------------------------------------------------------
#
#

# Some tests are not specific to a function in tkImgPhoto.c. They are:


#
# Test name(s)          Description
#--------------------------------------------------------------------------
# imgPhoto-5.*          Do not really belong to this file. ImgPhotoGet and
#                       ImgPhotoFree are defined in tkImgPhInstance.c.
# imgPhoto-6.*          Do not really belong to this file. ImgPhotoDisplay
#                       is defined in tkImgPhInstance.c.
# imgPhoto-7.*          Do not really belong to this file. ImgPhotoFree is
#                       defined in tkImgPhInstance.c.
# imgPhoto-13.*         Tests for separation in different interpreters
# imgPhoto-14.*         Test GIF format. Would belong to imgGIF.test
#                       - which does not exist.

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
    package require tcltest 2.2


    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

# Import utility procs for specific functional areas
testutils import image

#
# LOCAL UTILITY PROCS
#

proc checkImgTrans {img} {
    set result {}
    foreachPixel $img x y {
	if {[$img transparency get $x $y]} {
	    lappend result $x,$y
	}
    }
    return $result
}

proc checkImgTransLoop {img script1 script2} {
    set result {}
    foreachPixel $img x y {
	eval $script1
	lappend result {*}[checkImgTrans $img]
	append result :
	eval $script2
	lappend result {*}[checkImgTrans $img]
	append result .
    }
    return $result
}

#
# 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]
    for {set x 0} {$x<$width} {incr x} {
	for {set y 0} {$y<$height} {incr y} {
	    uplevel 1 $script
	}
    }
}





















#
# COMMON TEST SETUP
#

imageInit
set README [makeFile {
    README -- Tk test suite design document.
} README-imgPhoto]

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

#
# TESTS
#

test imgPhoto-1.1 {options for photo images} -body {
    image create photo photo1 -width 79 -height 83
    list [photo1 cget -width] [photo1 cget -height] \
	[image width photo1] [image height photo1]
} -cleanup {
    image delete photo1

} -body {
    photo1 configure -metadata {}
    photo1 cget -metadata
} -cleanup {
    catch {image delete photo1}
} -result {}

#
# COMMON TEST SETUP
#
# For tests imgPhoto-23.* : GIF images with metadata
#

# The following gif core data is used by the following data.
# N.B. this is the same image as test imgPhoto-18.10

# size 16x16, global color table size: 8
set gifstart "GIF89a\x10\x00\x10\x00\xc2\x07\x00"
# color table

test imgPhoto-23.2 {GIF file comment before image data (-file)} -setup {
    set data $::gifstart
    # Append a comment extension block with data "ABCD"
    append data "\x21\xfe\x04" "ABCD" "\x0"
    # Trailer
    append data $::gifdata $::gifend
    set path [file join [tcltest::configure -tmpdir] test.gif]
    set h [open $path "WRONLY BINARY CREAT"]
    puts -nonewline $h $data
    close $h
} -body {
    image create photo gif1 -file $path
    gif1 cget -metadata
} -cleanup {

test imgPhoto-23.4 {GIF comment after image data (-file)} -setup {
    set data $::gifstart
    append data $::gifdata
    # Append a comment extension block with data "ABCD"
    append data "\x21\xfe\x04" "ABCD" "\x0"
    # Trailer
    append data $::gifend
    set path [file join [tcltest::configure -tmpdir] test.gif]
    set h [open $path "WRONLY BINARY CREAT"]
    puts $h $data
    close $h
} -body {
    image create photo gif1 -file $path
    gif1 cget -metadata
} -cleanup {

    # Append a comment extension block with data "1234"
    append data "\x21\xfe\x04" "1234" "\x0"
    append data $::gifdata
    # Append a comment extension block with data "ABCD"
    append data "\x21\xfe\x04" "ABCD" "\x0"
    # Trailer
    append data $::gifend
    set path [file join [tcltest::configure -tmpdir] test.gif]
    set h [open $path "WRONLY BINARY CREAT"]
    puts $h $data
    close $h
} -body {
    image create photo gif1 -file $path
    gif1 cget -metadata
} -cleanup {

-setup {
    set data $::gifstart
    # Append a comment extension block with data "ABCD"
    append data "\x21\xfe\x04" "ABCD" "\x0"
    # Trailer
    append data $::gifdata $::gifend

    set path [file join [tcltest::configure -tmpdir] test.gif]
    set h [open $path "WRONLY BINARY CREAT"]
    puts $h $data
    close $h
} -body {
    set metadataDict [dict create A 1]
    set metadataDict2 $metadataDict
    image create photo gif1 -file $path -metadata $metadataDict

-setup {
    set data $::gifstart
    # Append a comment extension block with data "ABCD"
    append data "\x21\xfe\x04" "ABCD" "\x0"
    # Trailer
    append data $::gifdata $::gifend

    set path [file join [tcltest::configure -tmpdir] test.gif]
    set h [open $path "WRONLY BINARY CREAT"]
    puts $h $data
    close $h
} -body {
    image create photo gif1
    set metadataDict [dict create A 1]
    set metadataDict2 $metadataDict

-setup {
    set data $::gifstart
    # Append a comment extension block with data "ABCD"
    append data "\x21\xfe\x04" "ABCD" "\x0"
    # Trailer
    append data $::gifdata $::gifend

    set path [file join [tcltest::configure -tmpdir] test.gif]
    set h [open $path "WRONLY BINARY CREAT"]
    puts $h $data
    close $h
} -body {
    image create photo gif1 -data "$::gifstart$::gifdata$::gifend"
    set metadataDict [dict create A 1]
    set metadataDict2 $metadataDict

-setup {
    set data $::gifstart
    # Append a comment extension block with data "ABCD"
    append data "\x21\xfe\x04" "ABCD" "\x0"
    # Trailer
    append data $::gifdata $::gifend

    set path [file join [tcltest::configure -tmpdir] test.gif]
    set h [open $path "WRONLY BINARY CREAT"]
    puts $h $data
    close $h
} -body {
    image create photo gif1 -data "$::gifstart$::gifdata$::gifend"
    set metadataDict [dict create A 1]
    set metadataDict2 $metadataDict

} -cleanup {
    catch {image delete gif1}
} -match glob -result {*ABCD*}

test imgPhoto-23.17 {output file with comment (from -metadata property)}\
-setup {
    set data $::gifstart$::gifdata$::gifend
    set path [file join [tcltest::configure -tmpdir] test.gif]
} -body {
    image create photo gif1 -data $data
    gif1 configure -metadata [dict create comment ABCD]
    gif1 write $path -format gif
    image delete gif1
    image create photo gif1 -file $path
    dict get [gif1 cget -metadata] comment

} -cleanup {
    catch {image delete gif1}
} -result {comment ABCD}

test imgPhoto-23.19 {write: empty metadata parameter overwrites image metadata} -setup {
    image create photo gif1 -data $::gifstart$::gifdata$::gifend\
	    -metadata {comment bar}
    set path [file join [tcltest::configure -tmpdir] test.gif]
} -body {
    gif1 write $path -format gif -metadata {}
    image delete gif1
    image create photo gif1 -file $path
    dict size [gif1 cget -metadata]
} -cleanup {
    catch {image delete gif1}

} -body {
    image create photo gif1 -data $data -format "gif -index 1"
    gif1 cget -metadata
} -cleanup {
    catch {image delete gif1}
} -result {{update region} {0 0 16 16} {delay time} 4096 {disposal method} {do not dispose} {user interaction} 1}


#
# COMMON TEST SETUP
#
# For tests imgPhoto-24.*
#
unset -nocomplain gifstart gifdata gifend
set earthPhotoFile [file join [file dirname [info script]] earth.gif]

test imgPhoto-24.1 {Read GIF file with -from option - Bug [1576528]} -body {
    set earthPhotoFile [file join [file dirname [info script]] earth.gif]
    image create photo gif1
    gif1 read $earthPhotoFile -from 152 62 185 97
    list [lindex [lindex [gif1 data] 0] 0] [image width gif1] [image height gif1]
} -cleanup {
    catch {image delete gif1}

    set earthPhotoFile [file join [file dirname [info script]] earth.gif]
    image create photo gif1
    catch {gif1 read $earthPhotoFile -from 152 62 2000 1000} msg
    list $msg [image width gif1] [image height gif1]
} -cleanup {
    catch {image delete gif1}
} -result {{coordinates for -from option extend outside source image} 0 0}

#
# COMMON TEST SETUP
#
# For tests imgPhoto-25.*
#
unset earthPhotoFile
set ousterPhotoFile [file join [file dirname [info script]] ouster.png]

test imgPhoto-25.1 {Read PNG file with -from option - Bug [1576528]} -body {
    image create photo png1
    png1 read $ousterPhotoFile -from 102 62 135 97
    list [lindex [lindex [png1 data] 0] 0] [image width png1] [image height png1]
} -cleanup {
    catch {image delete png1}
} -result {{#c97962} 33 35}

test imgPhoto-25.6 {Read PNG file with -from option, read large region from small file} -body {
    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}


#
# TESTFILE CLEANUP
#

unset ousterPhotoFile
catch {rename foreachPixel {}}
catch {rename checkImgTrans {}}
catch {rename checkImgTransLoop {}}
imageFinish
removeFile README-imgPhoto

testutils forget image
cleanupTests


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

#
# Copyright © 2018 Rene Zaumseil
# All rights reserved.

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
    package require tcltest 2.2


    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

# Import utility procs for specific functional areas
testutils import image

imageInit

namespace eval svgnano {

    #
    # COMMON TEST SETUP
    #

    variable data

    set data(plus) {\
	    <svg xmlns="http://www.w3.org/2000/svg" width="100" height="100">
		<path fill="none" stroke="#000000" d="M0 0 h16 v16 h-16 z"/>
		<path fill="none" stroke="#000000" d="M8 4 v 8 M4 8 h 8"/>