# -*- tcl -*- # 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. # # RCS: @(#) $Id: winDialog.test,v 1.15.2.3 2009/11/13 23:32:05 patthoyts Exp $ package require tcltest 2.1 eval tcltest::configure $argv tcltest::loadTestedCommands if {[testConstraint testwinevent]} { catch {testwinevent debug 1} } # Locale identifier LANG_ENGLISH is 0x09 testConstraint english [expr { [llength [info commands testwinlocale]] && (([testwinlocale] & 0xff) == 9) }] 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} { switch -exact -- $button { ok { set button 1 } cancel { set button 2 } } testwinevent $::tk_dialog $button WM_LBUTTONDOWN 1 0x000a000b testwinevent $::tk_dialog $button WM_LBUTTONUP 0 0x000a000b } proc GetText {id} { switch -exact -- $id { ok { set id 1 } cancel { set id 2 } } return [testwinevent $::tk_dialog $id WM_GETTEXT] } proc SetText {id text} { return [testwinevent $::tk_dialog $id WM_SETTEXT $text] } test winDialog-1.1.0 {Tk_ChooseColorObjCmd} -constraints { testwinevent } -body { start {tk_chooseColor} then { Click cancel } } -result {0} test winDialog-1.1.1 {Tk_ChooseColorObjCmd} -constraints { testwinevent } -body { start {set clr [tk_chooseColor -initialcolor "#ff9933"]} then { set x [Click cancel] } list $x $clr } -result {0 {}} test winDialog-1.1.2 {Tk_ChooseColorObjCmd} -constraints { testwinevent } -body { start {set clr [tk_chooseColor -initialcolor "#ff9933"]} then { set x [Click ok] } list $x $clr } -result [list 0 "#ff9933"] test winDialog-1.1.3 {Tk_ChooseColorObjCmd: -title} -constraints { testwinevent } -setup {unset -nocomplain a x} -body { set x {} start {set clr [tk_chooseColor -initialcolor "#ff9933" -title "Hello"]} then { if {[catch { array set a [testgetwindowinfo $::tk_dialog] 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.1.4 {Tk_ChooseColorObjCmd: -title} -constraints { testwinevent } -setup {unset -nocomplain a x} -body { set x {} start { set clr [tk_chooseColor -initialcolor "#ff9933" \ -title "\u041f\u0440\u0438\u0432\u0435\u0442"] } then { if {[catch { array set a [testgetwindowinfo $::tk_dialog] if {[info exists a(text)]} {lappend x $a(text)} } err]} { lappend x $err } lappend x [Click ok] } lappend x $clr } -result [list "\u041f\u0440\u0438\u0432\u0435\u0442" 0 "#ff9933"] test winDialog-1.1.5 {Tk_ChooseColorObjCmd: -parent} -constraints { testwinevent } -setup {unset -nocomplain a x} -body { start {set clr [tk_chooseColor -initialcolor "#ff9933" -parent .]} set x {} then { if {[catch { array set a [testgetwindowinfo $::tk_dialog] 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.1.6 {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} {emptyTest nt} { } {} test winDialog-3.1 {Tk_GetOpenFileObjCmd} {nt testwinevent english} { start {tk_getOpenFile} then { set x [GetText cancel] Click cancel } set x } {Cancel} test winDialog-4.1 {Tk_GetSaveFileObjCmd} {nt testwinevent english} { start {tk_getSaveFile} then { set x [GetText cancel] Click cancel } set x } {Cancel} test winDialog-5.1 {GetFileName: no arguments} {nt testwinevent} { start {tk_getOpenFile -title Open} then { Click cancel } } {0} test winDialog-5.2 {GetFileName: one argument} {nt} { list [catch {tk_getOpenFile -foo} msg] $msg } {1 {bad option "-foo": must be -defaultextension, -filetypes, -initialdir, -initialfile, -multiple, -parent, -title, or -typevariable}} test winDialog-5.4 {GetFileName: many arguments} {nt testwinevent} { start {tk_getOpenFile -initialdir c:/ -parent . -title test -initialfile foo} then { Click cancel } } {0} test winDialog-5.5 {GetFileName: Tcl_GetIndexFromObj() != TCL_OK} {nt} { list [catch {tk_getOpenFile -foo bar -abc} msg] $msg } {1 {bad option "-foo": must be -defaultextension, -filetypes, -initialdir, -initialfile, -multiple, -parent, -title, or -typevariable}} test winDialog-5.6 {GetFileName: Tcl_GetIndexFromObj() == TCL_OK} {nt testwinevent} { start {tk_getOpenFile -title bar} then { Click cancel } } {0} test winDialog-5.7 {GetFileName: valid option, but missing value} {nt} { list [catch {tk_getOpenFile -initialdir bar -title} msg] $msg } {1 {value for "-title" missing}} test winDialog-5.8 {GetFileName: extension begins with .} {nt testwinevent} { # if (string[0] == '.') { # string++; # } start {set x [tk_getSaveFile -defaultextension .foo -title Save]} then { SetText 0x480 bar Click ok } string totitle $x } [string totitle [file join [pwd] bar.foo]] test winDialog-5.9 {GetFileName: extension doesn't begin with .} {nt testwinevent} { start {set x [tk_getSaveFile -defaultextension foo -title Save]} then { SetText 0x480 bar Click ok } string totitle $x } [string totitle [file join [pwd] bar.foo]] test winDialog-5.10 {GetFileName: file types} {nt testwinevent} { # case FILE_TYPES: start {tk_getSaveFile -filetypes {{"foo files" .foo FOOF}} -title Foo} then { set x [GetText 0x470] Click cancel } set x } {foo files (*.foo)} test winDialog-5.11 {GetFileName: file types: MakeFilter() fails} {nt} { # if (MakeFilter(interp, string, &utfFilterString) != TCL_OK) list [catch {tk_getSaveFile -filetypes {{"foo" .foo FOO}}} msg] $msg } {1 {bad Macintosh file type "FOO"}} if {[info exists ::env(TEMP)]} { test winDialog-5.12 {GetFileName: initial directory} {nt testwinevent} { # case FILE_INITDIR: start {set x [tk_getSaveFile \ -initialdir [file normalize $::env(TEMP)] \ -initialfile "12x 455" -title Foo]} then { Click ok } set x } [file join [file normalize $::env(TEMP)] "12x 455"] } test winDialog-5.13 {GetFileName: initial directory: Tcl_TranslateFilename()} \ {nt} { # if (Tcl_TranslateFileName(interp, string, &ds) == NULL) list [catch {tk_getOpenFile -initialdir ~12x/455} msg] $msg } {1 {user "12x" doesn't exist}} test winDialog-5.14 {GetFileName: initial file} {nt testwinevent} { # case FILE_INITFILE: start {set x [tk_getSaveFile -initialfile "12x 456" -title Foo]} then { Click ok } string totitle $x } [string totitle [file join [pwd] "12x 456"]] test winDialog-5.15 {GetFileName: initial file: Tcl_TranslateFileName()} {nt} { # if (Tcl_TranslateFileName(interp, string, &ds) == NULL) list [catch {tk_getOpenFile -initialfile ~12x/455} msg] $msg } {1 {user "12x" doesn't exist}} test winDialog-5.16 {GetFileName: initial file: long name} {nt testwinevent} { start { set dialogresult [catch { tk_getSaveFile -initialfile [string repeat a 1024] -title Long } x] } then { Click ok } list $dialogresult [string match "invalid filename *" $x] } {1 1} test winDialog-5.17 {GetFileName: parent} {nt} { # case FILE_PARENT: toplevel .t set x 0 start {tk_getOpenFile -parent .t -title Parent; set x 1} then { destroy .t } set x } {1} test winDialog-5.18 {GetFileName: title} {nt testwinevent} { # case FILE_TITLE: start {tk_getOpenFile -title Narf} then { Click cancel } } {0} test winDialog-5.19 {GetFileName: no filter specified} {nt testwinevent} { # if (ofn.lpstrFilter == NULL) start {tk_getOpenFile -title Filter} then { set x [GetText 0x470] Click cancel } set x } {All Files (*.*)} test winDialog-5.20 {GetFileName: parent HWND doesn't yet exist} {nt} { # if (Tk_WindowId(parent) == None) toplevel .t start {tk_getOpenFile -parent .t -title Open} then { destroy .t } } {} test winDialog-5.21 {GetFileName: parent HWND already exists} {nt} { toplevel .t update start {tk_getOpenFile -parent .t -title Open} then { destroy .t } } {} test winDialog-5.22 {GetFileName: call GetOpenFileName} {nt testwinevent english} { # winCode = GetOpenFileName(&ofn); start {tk_getOpenFile -title Open} then { set x [GetText ok] Click cancel } set x } {&Open} test winDialog-5.23 {GetFileName: call GetSaveFileName} {nt testwinevent english} { # winCode = GetSaveFileName(&ofn); start {tk_getSaveFile -title Save} then { set x [GetText ok] Click cancel } set x } {&Save} if {[info exists ::env(TEMP)]} { test winDialog-5.24 {GetFileName: convert \ to /} {nt testwinevent} { start {set x [tk_getSaveFile -title Back]} then { SetText 0x480 [file nativename \ [file join [file normalize $::env(TEMP)] "12x 457"]] Click ok } set x } [file join [file normalize $::env(TEMP)] "12x 457"] } test winDialog-5.25 {GetFileName: file types: MakeFilter() succeeds} {nt} { # MacOS type that is correct, but has embedded nulls. start {set x [catch {tk_getSaveFile -filetypes {{"foo" .foo {\0\0\0\0}}}}]} then { Click cancel } set x } {0} test winDialog-5.26 {GetFileName: file types: MakeFilter() succeeds} {nt} { # MacOS type that is correct, but has embedded high-bit chars. start {set x [catch {tk_getSaveFile -filetypes {{"foo" .foo {\u2022\u2022\u2022\u2022}}}}]} then { Click cancel } set x } {0} test winDialog-6.1 {MakeFilter} {emptyTest nt} {} {} test winDialog-7.1 {Tk_MessageBoxObjCmd} {emptyTest nt} {} {} test winDialog-8.1 {OFNHookProc} {emptyTest nt} {} {} ## 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} {nt testwinevent} { start {tk_chooseDirectory} then { Click cancel } } {0} test winDialog-9.2 {Tk_ChooseDirectoryObjCmd: one argument} {nt} { list [catch {tk_chooseDirectory -foo} msg] $msg } {1 {bad option "-foo": must be -initialdir, -mustexist, -parent, or -title}} test winDialog-9.3 {Tk_ChooseDirectoryObjCmd: many arguments} {nt testwinevent} { start { tk_chooseDirectory -initialdir c:/ -mustexist 1 -parent . -title test } then { Click cancel } } {0} test winDialog-9.4 {Tk_ChooseDirectoryObjCmd:\ Tcl_GetIndexFromObj() != TCL_OK} {nt} { list [catch {tk_chooseDirectory -foo bar -abc} msg] $msg } {1 {bad option "-foo": must be -initialdir, -mustexist, -parent, or -title}} test winDialog-9.5 {Tk_ChooseDirectoryObjCmd:\ Tcl_GetIndexFromObj() == TCL_OK} {nt testwinevent} { start {tk_chooseDirectory -title bar} then { Click cancel } } {0} test winDialog-9.6 {Tk_ChooseDirectoryObjCmd:\ valid option, but missing value} {nt} { list [catch {tk_chooseDirectory -initialdir bar -title} msg] $msg } {1 {value for "-title" missing}} test winDialog-9.7 {Tk_ChooseDirectoryObjCmd: -initialdir} {nt testwinevent} { # case DIR_INITIAL: start {set x [tk_chooseDirectory -initialdir c:/ -title Foo]} then { Click ok } string tolower [set x] } {c:/} test winDialog-9.8 {Tk_ChooseDirectoryObjCmd:\ initial directory: Tcl_TranslateFilename()} {nt} { # if (Tcl_TranslateFileName(interp, string, # &utfDirString) == NULL) list [catch {tk_chooseDirectory -initialdir ~12x/455} msg] $msg } {1 {user "12x" doesn't exist}} if {[testConstraint testwinevent]} { catch {testwinevent debug 0} } # cleanup cleanupTests return