path: root/tests/winDialog.test

# This file is a Tcl script to test the Windows specific behavior of
# the common dialog boxes.
#
# Copyright © 1997 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# Copyright © 1998-1999 ActiveState Corporation.

# NOTES
#
# * This test file is specific for the MS Windows platform. Tests that are
#   platform-indifferent go into the test file dialog.test.
# * This test file is skipped entirely on non-windows platforms.
#

#
# TESTFILE INITIALIZATION
#

package require tcltest 2.2; # needed in mode -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)
source [file join [tcltest::configure -testdir] main.tcl]

# Ensure a pristine initial window state
resetWindows

# Import utility procs for specific functional areas
testutils import dialog
set applyFontCmd [list set testDialogFont]

if {[testConstraint testwinevent]} {
    catch {testwinevent debug 1}
}

#
# LOCAL UTILITY PROCS
#

proc GetText {id} {
    variable testDialog
    switch -exact -- $id {
	ok     { set id 1 }
	cancel { set id 2 }
    }
    return [testwinevent $testDialog $id WM_GETTEXT]
}

proc SetText {id text} {
    variable testDialog
    return [testwinevent $testDialog $id WM_SETTEXT $text]
}

#
# LOCAL TEST CONSTRAINTS
#

# Locale identifier LANG_ENGLISH is 0x09
testConstraint english [expr {
    [llength [info commands testwinlocale]]
    && (([testwinlocale] & 0xff) == 9)
}]

#
# COMMON TEST SETUP
#

set initialDir [tcltest::temporaryDirectory]

#
# TESTS
#

test winDialog-1.1 {Tk_ChooseColorObjCmd} -constraints {
    testwinevent
} -body {
    testDialog launch {tk_chooseColor}
    testDialog onDisplay {
	Click cancel
    }
} -result 0
test winDialog-1.2 {Tk_ChooseColorObjCmd} -constraints {
    testwinevent
} -body {
    testDialog launch {set clr [tk_chooseColor -initialcolor "#ff9933"]}
    testDialog onDisplay {
	set x [Click cancel]
    }
    list $x $clr
} -result {0 {}}
test winDialog-1.3 {Tk_ChooseColorObjCmd} -constraints {
    testwinevent
} -body {
    testDialog launch {set clr [tk_chooseColor -initialcolor "#ff9933"]}
    testDialog onDisplay {
	set x [Click ok]
    }
    list $x $clr
} -result [list 0 "#ff9933"]
test winDialog-1.4 {Tk_ChooseColorObjCmd: -title} -constraints {
    testwinevent
} -setup {
    catch {unset a x}
} -body {
    set x {}
    testDialog launch {set clr [tk_chooseColor -initialcolor "#ff9933" -title "Hello"]}
    testDialog onDisplay {
	if {[catch {
	    array set a [testgetwindowinfo $testDialog]
	    if {[info exists a(text)]} {lappend x $a(text)}
	} err]} { lappend x $err }
	lappend x [Click ok]
    }
    lappend x $clr
} -result [list Hello 0 "#ff9933"]
test winDialog-1.5 {Tk_ChooseColorObjCmd: -title} -constraints {
    testwinevent
} -setup {
    catch {unset a x}
} -body {
    set x {}
    testDialog launch {
	set clr [tk_chooseColor -initialcolor "#ff9933" \
		     -title "Привет"]
    }
    testDialog onDisplay {
	if {[catch {
	    array set a [testgetwindowinfo $testDialog]
	    if {[info exists a(text)]} {lappend x $a(text)}
	} err]} { lappend x $err }
	lappend x [Click ok]
    }
    lappend x $clr
} -result [list "Привет" 0 "#ff9933"]
test winDialog-1.6 {Tk_ChooseColorObjCmd: -parent} -constraints {
    testwinevent
} -setup {
    catch {unset a x}
} -body {
    testDialog launch {set clr [tk_chooseColor -initialcolor "#ff9933" -parent .]}
    set x {}
    testDialog onDisplay {
	if {[catch {
	    array set a [testgetwindowinfo $testDialog]
	    if {[info exists a(parent)]} {
		append x [expr {$a(parent) == [wm frame .]}]
	    }
	} err]} {lappend x $err}
	Click ok
    }
    list $x $clr
} -result [list 1 "#ff9933"]
test winDialog-1.7 {Tk_ChooseColorObjCmd: -parent} -constraints {
    testwinevent
} -body {
    tk_chooseColor -initialcolor "#ff9933" -parent .xyzzy12
} -returnCodes error -match glob -result {bad window path name*}


test winDialog-2.1 {ColorDlgHookProc} -constraints {emptyTest nt} -body {}

test winDialog-3.1 {Tk_GetOpenFileObjCmd} -constraints {
    nt testwinevent english
} -body {
    testDialog launch {tk_getOpenFile}
    testDialog onDisplay {
	set x [GetText cancel]
	Click cancel
    }
    return $x
} -result {Cancel}


test winDialog-4.1 {Tk_GetSaveFileObjCmd} -constraints {
    nt testwinevent english
} -body {
    testDialog launch {tk_getSaveFile}
    testDialog onDisplay {
	set x [GetText cancel]
	Click cancel
    }
    return $x
} -result {Cancel}

test winDialog-5.1 {GetFileName: no arguments} -constraints {
    nt testwinevent
} -body {
    testDialog launch {tk_getOpenFile -title Open}
    testDialog onDisplay {
	Click cancel
    }
} -result 0
test winDialog-5.2 {GetFileName: one argument} -constraints {
    nt
} -body {
    tk_getOpenFile -foo
} -returnCodes error -result {bad option "-foo": must be -defaultextension, -filetypes, -initialdir, -initialfile, -multiple, -parent, -title, or -typevariable}
test winDialog-5.3 {GetFileName: many arguments} -constraints {
    nt testwinevent
} -body {
    testDialog launch {tk_getOpenFile -initialdir $initialDir -parent . -title test -initialfile foo}
    testDialog onDisplay {
	Click cancel
    }
} -result 0
test winDialog-5.4 {GetFileName: Tcl_GetIndexFromObj() != TCL_OK} -constraints {
    nt
} -body {
    tk_getOpenFile -foo bar -abc
} -returnCodes error -result {bad option "-foo": must be -defaultextension, -filetypes, -initialdir, -initialfile, -multiple, -parent, -title, or -typevariable}
test winDialog-5.5 {GetFileName: Tcl_GetIndexFromObj() == TCL_OK} -constraints {
    nt testwinevent
} -body {
    testDialog launch {set x [tk_getOpenFile -title bar]}
    set y [testDialog onDisplay {
	Click cancel
    }]
    # Note this also tests fix for
    # https://core.tcl-lang.org/tk/tktview/4a0451f5291b3c9168cc560747dae9264e1d2ef6
    # $x is expected to be empty
    append x $y
} -result 0
test winDialog-5.6 {GetFileName: valid option, but missing value} -constraints {
    nt
} -body {
    tk_getOpenFile -initialdir bar -title
} -returnCodes error -result {value for "-title" missing}

test winDialog-5.7 {GetFileName: extension begins with .} -constraints {
    nt testwinevent
} -body {
    testDialog launch {set x [tk_getSaveFile -defaultextension .foo -title Save]}
    set msg {}
    testDialog onDisplay {
	if {[catch {SetText 0x3e9 bar} msg]} {
	    Click cancel
	} else {
	    Click ok
	}
    }
    set x "[file tail $x]$msg"
} -cleanup {
    unset msg
} -result bar.foo

test winDialog-5.7.1 {GetFileName: extension {} } -constraints {
    nt testwinevent
} -body {
    testDialog launch {set x [tk_getSaveFile -defaultextension {} -title Save]}
    set msg {}
    testDialog onDisplay {
	if {[catch {SetText 0x3e9 bar} msg]} {
	    Click cancel
	} else {
	    Click ok
	}
    }
    set x "[file tail $x]$msg"
} -cleanup {
    unset msg
} -result bar

test winDialog-5.7.2 {GetFileName: extension {} Bug 47af31bd3ac6fbbb33cde1a5bab1e756ff2a6e00 } -constraints {
    nt testwinevent
} -body {
    testDialog launch {set x [tk_getSaveFile -filetypes {{All *}} -defaultextension {} -title Save]}
    set msg {}
    testDialog onDisplay {
	if {[catch {SetText 0x3e9 bar} msg]} {
	    Click cancel
	} else {
	    Click ok
	}
    }
    set x "[file tail $x]$msg"
} -cleanup {
    unset msg
} -result bar

test winDialog-5.7.3 {GetFileName: extension {} Bug 47af31bd3ac6fbbb33cde1a5bab1e756ff2a6e00 } -constraints {
    nt testwinevent
} -body {
    testDialog launch {set x [tk_getSaveFile -filetypes {{All *}} -defaultextension {} -title Save]}
    set msg {}
    testDialog onDisplay {
	if {[catch {SetText 0x3e9 bar.c} msg]} {
	    Click cancel
	} else {
	    Click ok
	}
    }
    set x "[file tail $x]$msg"
} -cleanup {
    unset msg
} -result bar.c

test winDialog-5.7.4 {GetFileName: extension {} } -constraints {
    nt testwinevent
} -body {
    # Although the docs do not explicitly mention, -filetypes seems to
    # override -defaultextension
    testDialog launch {set x [tk_getSaveFile -filetypes {{C .c} {Tcl .tcl}} -defaultextension {foo} -title Save]}
    set msg {}
    testDialog onDisplay {
	if {[catch {SetText 0x3e9 bar} msg]} {
	    Click cancel
	} else {
	    Click ok
	}
    }
    set x "[file tail $x]$msg"
} -cleanup {
    unset msg
} -result bar.c

test winDialog-5.7.5 {GetFileName: extension {} } -constraints {
    nt testwinevent
} -body {
    # Although the docs do not explicitly mention, -filetypes seems to
    # override -defaultextension
    testDialog launch {set x [tk_getSaveFile -filetypes {{C .c} {Tcl .tcl}} -defaultextension {} -title Save]}
    set msg {}
    testDialog onDisplay {
	if {[catch {SetText 0x3e9 bar} msg]} {
	    Click cancel
	} else {
	    Click ok
	}
    }
    set x "[file tail $x]$msg"
} -cleanup {
    unset msg
} -result bar.c


test winDialog-5.7.6 {GetFileName: All/extension } -constraints {
    nt testwinevent
} -body {
    # In 8.6.4 this combination resulted in bar.aaa.aaa which is bad
    testDialog launch {set x [tk_getSaveFile -filetypes {{All *}} -defaultextension {aaa} -title Save]}
    set msg {}
    testDialog onDisplay {
	if {[catch {SetText 0x3e9 bar} msg]} {
	    Click cancel
	} else {
	    Click ok
	}
    }
    set x "[file tail $x]$msg"
} -cleanup {
    unset msg
} -result bar.aaa

test winDialog-5.7.7 {tk_getOpenFile: -defaultextension} -constraints {
    nt testwinevent
} -body {
    unset -nocomplain x
    tcltest::makeFile "" "5 7 7.aaa" $initialDir
    testDialog launch {set x [tk_getOpenFile \
		      -defaultextension aaa \
		      -initialdir [file nativename $initialDir] \
		      -initialfile "5 7 7" -title Foo]}
    testDialog onDisplay {
	Click ok
    }
    return $x
} -result [file join $initialDir "5 7 7.aaa"]

test winDialog-5.7.8 {tk_getOpenFile: -defaultextension} -constraints {
    nt testwinevent
} -body {
    unset -nocomplain x
    tcltest::makeFile "" "5 7 8.aaa" $initialDir
    testDialog launch {set x [tk_getOpenFile \
		      -defaultextension aaa \
		      -initialdir [file nativename $initialDir] \
		      -initialfile "5 7 8.aaa" -title Foo]}
    testDialog onDisplay {
	Click ok
    }
    return $x
} -result [file join $initialDir "5 7 8.aaa"]

test winDialog-5.8 {GetFileName: extension doesn't begin with .} -constraints {
    nt testwinevent
} -body {
    testDialog launch {set x [tk_getSaveFile -defaultextension foo -title Save]}
    set msg {}
    testDialog onDisplay {
	if {[catch {SetText 0x3e9 bar} msg]} {
	    Click cancel
	} else {
	    Click ok
	}
    }
    set x "[file tail $x]$msg"
} -cleanup {
    unset msg
} -result bar.foo
test winDialog-5.9 {GetFileName: file types} -constraints {
    nt testwinevent knownBug
} -body {
    #
    # This test was used with MS Windows versions before Windows Vista.
    # Starting from that version, the test is not valid anymore because the
    # dialog's file types control has no control ID and we don't have a
    # mechanism to locate it.
    # The test remains at this place, with constraint knownBug, to serve as an
    # example/template in the event that the situation changes in the future
    # somehow.
    #
    testDialog launch {tk_getSaveFile -filetypes {{"foo files" .foo FOOF}} -title Foo}
    testDialog onDisplay {
	set x [GetText 0x470]
	Click cancel
    }
    return $x
} -result {foo files (*.foo)}
test winDialog-5.10 {GetFileName: file types: MakeFilter() fails} -constraints {
    nt
} -body {
#        if (MakeFilter(interp, string, &utfFilterString) != TCL_OK)

    tk_getSaveFile -filetypes {{"foo" .foo FOO}}
} -returnCodes error -result {bad Macintosh file type "FOO"}
test winDialog-5.11 {GetFileName: initial directory} -constraints {
    nt testwinevent
} -body {
#        case FILE_INITDIR:
    unset -nocomplain x
    testDialog launch {set x [tk_getSaveFile \
		      -initialdir $initialDir \
		      -initialfile "12x 455" -title Foo]}
    testDialog onDisplay {
	Click ok
    }
    return $x
} -result [file join $initialDir "12x 455"]

test winDialog-5.12.4 {tk_getSaveFile: initial directory: unicode} -constraints {
    nt testwinevent
} -body {
    set dir [tcltest::makeDirectory "ŧéŝŧ"]
    unset -nocomplain x
    testDialog launch {set x [tk_getSaveFile \
		      -initialdir $dir \
		      -initialfile "testfile" -title Foo]}
    testDialog onDisplay {
	Click ok
    }
    string equal $x [file join $dir testfile]
} -result 1

test winDialog-5.12.5 {tk_getSaveFile: initial directory: nativename} -constraints {
    nt testwinevent
} -body {
    unset -nocomplain x
    testDialog launch {set x [tk_getSaveFile \
		      -initialdir [file nativename $initialDir] \
		      -initialfile "5 12 5" -title Foo]}
    testDialog onDisplay {
	Click ok
    }
    return $x
} -result [file join $initialDir "5 12 5"]

test winDialog-5.12.6 {tk_getSaveFile: initial directory: relative} -constraints {
    nt testwinevent
} -body {
    # Windows remembers dirs from previous selections so use
    # a subdir for this test, not $initialDir itself
    set dir [tcltest::makeDirectory "5 12 6"]
    set cur [pwd]
    try {
	cd [file dirname $dir]
	unset -nocomplain x
	testDialog launch {set x [tk_getSaveFile \
			  -initialdir "5 12 6" \
			  -initialfile "testfile" -title Foo]}
	testDialog onDisplay {
	    Click ok
	}
    } finally {
	cd $cur
    }
    string equal $x [file join $dir testfile]
} -result 1

test winDialog-5.12.8 {tk_getOpenFile: initial directory: .} -constraints {
    nt testwinevent
} -body {
    # Windows remembers dirs from previous selections so use
    # a subdir for this test, not $initialDir itself
    set newdir [tcltest::makeDirectory "5 12 8"]
    set path [tcltest::makeFile "" "testfile" $newdir]
    set cur [pwd]
    try {
	cd $newdir
	unset -nocomplain x
	testDialog launch {set x [tk_getOpenFile \
			  -initialdir . \
			  -initialfile "testfile" -title Foo]}
	testDialog onDisplay {
	    Click ok
	}
    } finally {
	cd $cur
    }
    string equal $x $path
} -result 1

test winDialog-5.12.9 {tk_getOpenFile: initial directory: unicode} -constraints {
    nt testwinevent
} -body {
    set dir [tcltest::makeDirectory "ŧéŝŧ"]
    set path [tcltest::makeFile "" testfile $dir]
    unset -nocomplain x
    testDialog launch {set x [tk_getOpenFile \
		      -initialdir $dir \
		      -initialfile "testfile" -title Foo]}
    testDialog onDisplay {
	Click ok
    }
    string equal $x $path
} -result 1

test winDialog-5.12.10 {tk_getOpenFile: initial directory: nativename} -constraints {
    nt testwinevent
} -body {
    unset -nocomplain x
    tcltest::makeFile "" "5 12 10" $initialDir
    testDialog launch {set x [tk_getOpenFile \
		      -initialdir [file nativename $initialDir] \
		      -initialfile "5 12 10" -title Foo]}
    testDialog onDisplay {
	Click ok
    }
    return $x
} -result [file join $initialDir "5 12 10"]

test winDialog-5.12.11 {tk_getOpenFile: initial directory: relative} -constraints {
    nt testwinevent
} -body {
    # Windows remembers dirs from previous selections so use
    # a subdir for this test, not $initialDir itself
    set dir [tcltest::makeDirectory "5 12 11"]
    set path [tcltest::makeFile "" testfile $dir]
    set cur [pwd]
    try {
	cd [file dirname $dir]
	unset -nocomplain x
	testDialog launch {set x [tk_getOpenFile \
			  -initialdir [file tail $dir] \
			  -initialfile "testfile" -title Foo]}
	testDialog onDisplay {
	    Click ok
	}
    } finally {
	cd $cur
    }
    string equal $x $path
} -result 1

test winDialog-5.13 {GetFileName: initial file} -constraints {
    nt testwinevent
} -body {
#        case FILE_INITFILE:

    testDialog launch {set x [tk_getSaveFile -initialfile "12x 456" -title Foo]}
    testDialog onDisplay {
	Click ok
    }
    file tail $x
} -result "12x 456"

test winDialog-5.16 {GetFileName: parent} -constraints {
    nt
} -body {
#        case FILE_PARENT:

    toplevel .t
    set x 0
    testDialog launch {tk_getOpenFile -parent .t -title Parent; set x 1}
    testDialog onDisplay {
	destroy .t
    }
    return $x
} -result 1
test winDialog-5.17 {GetFileName: title} -constraints {
    nt testwinevent
} -body {
#        case FILE_TITLE:

    testDialog launch {tk_getOpenFile -title Narf}
    testDialog onDisplay {
	Click cancel
    }
} -result 0
# In the newer file dialogs, the file type widget does not even exist
# if no file types specified
test winDialog-5.18 {GetFileName: no filter specified} -constraints {
    nt testwinevent
} -body {
    #    if (ofn.lpstrFilter == NULL)
    testDialog launch {tk_getOpenFile -title Filter}
    testDialog onDisplay {
	catch {set x [GetText 0x470]} y
	Click cancel
    }
    return $y
} -result {Could not find control with id 1136}
test winDialog-5.19 {GetFileName: parent HWND doesn't yet exist} -constraints {
    nt
} -setup {
    destroy .t
} -body {
#    if (Tk_WindowId(parent) == None)

    toplevel .t
    testDialog launch {tk_getOpenFile -parent .t -title Open}
    testDialog onDisplay {
	destroy .t
    }
} -result {}
test winDialog-5.20 {GetFileName: parent HWND already exists} -constraints {
    nt
} -setup {
    destroy .t
} -body {
    toplevel .t
    update
    testDialog launch {tk_getOpenFile -parent .t -title Open}
    testDialog onDisplay {
	destroy .t
    }
} -result {}
test winDialog-5.21 {GetFileName: call GetOpenFileName} -constraints {
    nt testwinevent english
} -body {
#        winCode = GetOpenFileName(&ofn);

    testDialog launch {tk_getOpenFile -title Open}
    testDialog onDisplay {
	set x [GetText ok]
	Click cancel
    }
    return $x
} -result {&Open}
test winDialog-5.22 {GetFileName: call GetSaveFileName} -constraints {
    nt testwinevent english
} -body {
#        winCode = GetSaveFileName(&ofn);

    testDialog launch {tk_getSaveFile -title Save}
    testDialog onDisplay {
	set x [GetText ok]
	Click cancel
    }
    return $x
} -result {&Save}
test winDialog-5.23 {GetFileName: convert \ to /} -constraints {
    nt testwinevent
} -body {
    set msg {}
    testDialog launch {set x [tk_getSaveFile -title Back]}
    testDialog onDisplay {
	if {[catch {SetText 0x3e9 [file nativename \
		[file join $initialDir "12x 457"]]} msg]} {
	    Click cancel
	} else {
	    Click ok
	}
    }
    return $x$msg
} -cleanup {
    unset msg
} -result [file join $initialDir "12x 457"]
test winDialog-5.24 {GetFileName: file types: MakeFilter() succeeds} -constraints {
    nt
} -body {
    # MacOS type that is correct, but has embedded nulls.

    testDialog launch {set x [catch {tk_getSaveFile -filetypes {{"foo" .foo {\0\0\0\0}}}}]}
    testDialog onDisplay {
	Click cancel
    }
    return $x
} -result 0
test winDialog-5.25 {GetFileName: file types: MakeFilter() succeeds} -constraints {
    nt
} -body {
    # MacOS type that is correct, but has embedded high-bit chars.

    testDialog launch {set x [catch {tk_getSaveFile -filetypes {{"foo" .foo {••••}}}}]}
    testDialog onDisplay {
	Click cancel
    }
    return $x
} -result 0


test winDialog-6.1 {MakeFilter} -constraints {emptyTest nt} -body {}


test winDialog-7.1 {Tk_MessageBoxObjCmd} -constraints {emptyTest nt} -body {}


test winDialog-8.1 {OFNHookProc} -constraints {emptyTest nt} -body {}


## The Tk_ChooseDirectoryObjCmd hang on the static build of Windows
## because somehow the GetOpenFileName ends up a noop in the static
## build.
##
test winDialog-9.1 {Tk_ChooseDirectoryObjCmd: no arguments} -constraints {
    nt testwinevent
} -body {
    testDialog launch {set x [tk_chooseDirectory]}
    set y [testDialog onDisplay {
	Click cancel
    }]
    # $x should be "" on a Cancel
    append x $y
} -result 0
test winDialog-9.2 {Tk_ChooseDirectoryObjCmd: one argument} -constraints {
    nt
} -body {
    tk_chooseDirectory -foo
} -returnCodes error -result {bad option "-foo": must be -initialdir, -mustexist, -parent, or -title}
test winDialog-9.3 {Tk_ChooseDirectoryObjCmd: many arguments} -constraints {
    nt testwinevent
} -body {
    testDialog launch {
	tk_chooseDirectory -initialdir $initialDir -mustexist 1 -parent . -title test
    }
    testDialog onDisplay {
	Click cancel
    }
} -result 0
test winDialog-9.4 {Tk_ChooseDirectoryObjCmd: Tcl_GetIndexFromObj() != TCL_OK} -constraints {
    nt
} -body {
    tk_chooseDirectory -foo bar -abc
} -returnCodes error -result {bad option "-foo": must be -initialdir, -mustexist, -parent, or -title}
test winDialog-9.5 {Tk_ChooseDirectoryObjCmd: Tcl_GetIndexFromObj() == TCL_OK} -constraints {
    nt testwinevent
} -body {
    testDialog launch {tk_chooseDirectory -title bar}
    testDialog onDisplay {
	Click cancel
    }
} -result 0
test winDialog-9.6 {Tk_ChooseDirectoryObjCmd: valid option, but missing value} -constraints {
    nt
} -body {
    tk_chooseDirectory -initialdir bar -title
} -returnCodes error -result {value for "-title" missing}
test winDialog-9.7 {Tk_ChooseDirectoryObjCmd: -initialdir} -constraints {
    nt testwinevent
} -body {
#        case DIR_INITIAL:

    testDialog launch {set x [tk_chooseDirectory -initialdir $initialDir -title Foo]}
    testDialog onDisplay {
	Click ok
    }
    string tolower [set x]
} -result [string tolower $initialDir]


test winDialog-10.1 {Tk_FontchooserObjCmd: no arguments} -constraints {
    nt testwinevent
} -body {
    testDialog launch {tk fontchooser show}
    list [testDialog onDisplay {
	Click cancel
    }] $testDialogFont
} -result {0 {}}
test winDialog-10.2 {Tk_FontchooserObjCmd: -initialfont} -constraints {
    nt testwinevent
} -body {
    testDialog launch {
	tk fontchooser configure -command $applyFontCmd -font system
	tk fontchooser show
    }
    list [testDialog onDisplay {
	Click cancel
    }] $testDialogFont
} -result {0 {}}
test winDialog-10.3 {Tk_FontchooserObjCmd: -initialfont} -constraints {
    nt testwinevent
} -body {
    testDialog launch {
	tk fontchooser configure -command $applyFontCmd -font system
	tk fontchooser show
    }
    list [testDialog onDisplay {
	Click 1
    }] [expr {[llength $testDialogFont] > 0}]
} -result {0 1}
test winDialog-10.4 {Tk_FontchooserObjCmd: -title} -constraints {
    nt testwinevent
} -body {
    testDialog launch {
	tk fontchooser configure -command $applyFontCmd -title "tk test"
	tk fontchooser show
    }
    list [testDialog onDisplay {
	Click cancel
    }] $testDialogFont
} -result {0 {}}
test winDialog-10.5 {Tk_FontchooserObjCmd: -parent} -constraints {
    nt testwinevent
} -setup {
    array set a {parent {}}
} -body {
    testDialog launch {
	tk fontchooser configure -command $applyFontCmd -parent .
	tk fontchooser show
    }
    testDialog onDisplay {
	array set a [testgetwindowinfo $testDialog]
	Click cancel
    }
    list [expr {$a(parent) == [wm frame .]}] $testDialogFont
} -result {1 {}}
test winDialog-10.6 {Tk_FontchooserObjCmd: -apply} -constraints {
    nt testwinevent
} -body {
    testDialog launch {
	tk fontchooser configure -command FooBarBaz
	tk fontchooser show
    }
    testDialog onDisplay {
	Click cancel
    }
} -result 0
test winDialog-10.7 {Tk_FontchooserObjCmd: -apply} -constraints {
    nt testwinevent
} -body {
    testDialog launch {
	tk fontchooser configure -command $applyFontCmd -parent .
	tk fontchooser show
    }
    list [testDialog onDisplay {
	Click [expr {0x0402}] ;# value from XP
	Click cancel
    }] [expr {[llength $testDialogFont] > 0}]
} -result {0 1}
test winDialog-10.8 {Tk_FontchooserObjCmd: -title} -constraints {
    nt testwinevent
} -setup {
    array set a {text failed}
} -body {
    testDialog launch {
	tk fontchooser configure -command $applyFontCmd -title "Hello"
	tk fontchooser show
    }
    testDialog onDisplay {
	array set a [testgetwindowinfo $testDialog]
	Click cancel
    }
    set a(text)
} -result "Hello"
test winDialog-10.9 {Tk_FontchooserObjCmd: -title} -constraints {
    nt testwinevent
} -setup {
    array set a {text failed}
} -body {
    testDialog launch {
	tk fontchooser configure -command $applyFontCmd \
	    -title  "Привет"
	tk fontchooser show
    }
    testDialog onDisplay {
	array set a [testgetwindowinfo $testDialog]
	Click cancel
    }
    set a(text)
} -result "Привет"

#
# TESTFILE CLEANUP
#

if {[testConstraint testwinevent]} {
    catch {testwinevent debug 0}
}

unset applyFontCmd initialDir
testutils forget dialog
cleanupTests

# Local variables:
# mode: tcl
# End: