path: root/tests/winDialog.test

# This file is a Tcl script to test the Windows specific behavior of
# the common dialog boxes.  It is organized in the standard
# fashion for Tcl tests.
#
# Copyright (c) 1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
# Copyright (c) 1998-1999 ActiveState Corporation.

package require tcltest 2.1
namespace import -force tcltest::configure
namespace import -force tcltest::testsDirectory
configure -testdir [file join [pwd] [file dirname [info script]]]
configure -loadfile [file join [testsDirectory] constraints.tcl]
tcltest::loadTestedCommands

testConstraint testwinevent [llength [info commands testwinevent]]

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

proc start {arg} {
    set ::tk_dialog 0
    set ::iter_after 0

    after 1 $arg
}

proc then {cmd} {
    set ::command $cmd
    set ::dialogresult {}

    afterbody
    vwait ::dialogresult
    return $::dialogresult
}

proc afterbody {} {
    if {$::tk_dialog == 0} {
	if {[incr ::iter_after] > 30} {
	    set ::dialogresult ">30 iterations waiting on tk_dialog"
	    return
	}
	after 150 {afterbody}
	return
    }
    uplevel #0 {set dialogresult [eval $command]}
}

proc Click {button} {
    testwinevent $::tk_dialog $button WM_LBUTTONDOWN 1 0x000a000b
    testwinevent $::tk_dialog $button WM_LBUTTONUP 0 0x000a000b
}

proc GetText {button} {
    return [testwinevent $::tk_dialog $button WM_GETTEXT]
}

proc SetText {button text} {
    return [testwinevent $::tk_dialog $button WM_SETTEXT $text]
}

test winDialog-3.1 {Tk_GetOpenFileObjCmd} -constraints {
    nt testwinevent
} -body {
    start {tk_getOpenFile}
    then {
	set x [GetText 2]
	Click 2
    }
    return $x
} -result {Cancel}


test winDialog-4.1 {Tk_GetSaveFileObjCmd} -constraints {
    nt testwinevent
} -body {
    start {tk_getSaveFile}
    then {
	set x [GetText 2]
	Click 2
    }
    return $x
} -result {Cancel}

test winDialog-5.1 {GetFileName: no arguments} -constraints {
    nt testwinevent
} -body {
    start {tk_getOpenFile -title Open}
    then {
	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, or -title}
test winDialog-5.3 {GetFileName: many arguments} -constraints {
    nt testwinevent
} -body {
    start {tk_getOpenFile -initialdir c:/ -parent . -title test -initialfile foo}
    then {
	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, or -title}
test winDialog-5.5 {GetFileName: Tcl_GetIndexFromObj() == TCL_OK} -constraints {
    nt testwinevent
} -body {
    start {tk_getOpenFile -title bar}
    then {
	Click cancel
    }
} -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 {
#    if (string[0] == '.') {
#	string++;
#    }

    start {set x [tk_getSaveFile -defaultextension .foo -title Save]}
    set msg {}
    then {
	if {[catch {SetText 0x47C bar} msg]} {
	    Click 2
	} else {
	    Click 1
	}
    }
    return [string totitle $x]$msg
} -cleanup {
    unset msg
} -result [string totitle [file join [pwd] bar.foo]]
test winDialog-5.8 {GetFileName: extension doesn't begin with .} -constraints {
    nt testwinevent
} -body {
    start {set x [tk_getSaveFile -defaultextension foo -title Save]}
    set msg {}
    then {
	if {[catch {SetText 0x47C bar} msg]} {
	    Click 2
	} else {
	    Click 1
	}
    }
    return [string totitle $x]$msg
} -cleanup {
    unset msg
} -result [string totitle [file join [pwd] bar.foo]]
test winDialog-5.9 {GetFileName: file types} -constraints {
    nt testwinevent
} -body {
#	case FILE_TYPES:

    start {tk_getSaveFile -filetypes {{"foo files" .foo FOOF}} -title Foo}
    then {
	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"}
if {[info exists ::env(TEMP)]} {
test winDialog-5.11 {GetFileName: initial directory} -constraints {
    nt testwinevent
} -body {
#	case FILE_INITDIR:

    start {set x [tk_getSaveFile \
                      -initialdir [file normalize $::env(TEMP)] \
                      -initialfile "12x 455" -title Foo]}
    then {
	Click 1
    }
    return $x
} -result [file join [file normalize $::env(TEMP)] "12x 455"]
}
test winDialog-5.12 {GetFileName: initial directory: Tcl_TranslateFilename()} -constraints {
    nt
} -body {
#	if (Tcl_TranslateFileName(interp, string, &ds) == NULL)

    tk_getOpenFile -initialdir ~12x/455
} -returnCodes error -result {user "12x" doesn't exist}
test winDialog-5.13 {GetFileName: initial file} -constraints {
    nt testwinevent
} -body {
#	case FILE_INITFILE:

    start {set x [tk_getSaveFile -initialfile "12x 456" -title Foo]}
    then {
	Click 1
    }
    string totitle $x
} -result [string totitle [file join [pwd] "12x 456"]]
test winDialog-5.14 {GetFileName: initial file: Tcl_TranslateFileName()} -constraints {
    nt
} -body {
#	if (Tcl_TranslateFileName(interp, string, &ds) == NULL)
    tk_getOpenFile -initialfile ~12x/455
} -returnCodes error -result {user "12x" doesn't exist}
test winDialog-5.15 {GetFileName: initial file: long name} -constraints {
    nt testwinevent
} -body {
    start {
	set dialogresult [catch {
	    tk_getSaveFile -initialfile [string repeat a 1024] -title Long
	} x]
    }
    then {
	Click 1
    }
    list $dialogresult [string match "invalid filename *" $x]
} -result {1 1}
test winDialog-5.16 {GetFileName: parent} -constraints {
    nt
} -body {
#	case FILE_PARENT:

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

    start {tk_getOpenFile -title Narf}
    then {
	Click 2
    }
} -result {0}
test winDialog-5.18 {GetFileName: no filter specified} -constraints {
    nt testwinevent
} -body {
#    if (ofn.lpstrFilter == NULL)

    start {tk_getOpenFile -title Filter}
    then {
	set x [GetText 0x470]
	Click 2
    }
    return $x
} -result {All Files (*.*)}
test winDialog-5.19 {GetFileName: parent HWND doesn't yet exist} -constraints {
    nt
} -setup {
    destroy .t
} -body {
#    if (Tk_WindowId(parent) == None)

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

    start {tk_getOpenFile -title Open}
    then {
	set x [GetText 1]
	Click 2
    }
    return $x
} -result {&Open}
test winDialog-5.22 {GetFileName: call GetSaveFileName} -constraints {
    nt testwinevent
} -body {
#	winCode = GetSaveFileName(&ofn);

    start {tk_getSaveFile -title Save}
    then {
	set x [GetText 1]
	Click 2
    }
    return $x
} -result {&Save}
if {[info exists ::env(TEMP)]} {
test winDialog-5.23 {GetFileName: convert \ to /} -constraints {
    nt testwinevent
} -body {
    set msg {}
    start {set x [tk_getSaveFile -title Back]}
    then {
	if {[catch {SetText 0x47C [file nativename \
		[file join [file normalize $::env(TEMP)] "12x 457"]]} msg]} {
	    Click 2
	} else {
	    Click 1
	}
    }
    return $x$msg
} -cleanup {
    unset msg
} -result [file join [file normalize $::env(TEMP)] "12x 457"]
}
## 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 {
    start {tk_chooseDirectory}
    then {
	Click cancel
    }
} -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 {
    start {
	tk_chooseDirectory -initialdir c:/ -mustexist 1 -parent . -title test
    }
    then {
	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 {
    start {tk_chooseDirectory -title bar}
    then {
	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:

    start {set x [tk_chooseDirectory -initialdir c:/ -title Foo]}
    then {
	Click 1
    }
    string tolower [set x]
} -result {c:/}
test winDialog-9.8 {Tk_ChooseDirectoryObjCmd: initial directory: Tcl_TranslateFilename()} -constraints {
    nt
} -body {
#	if (Tcl_TranslateFileName(interp, string,
#		&utfDirString) == NULL)

    tk_chooseDirectory -initialdir ~12x/455
} -returnCodes error -result {user "12x" doesn't exist}

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

# cleanup
::tcltest::cleanupTests
return

# Local variables:
# mode: tcl
# End: