summaryrefslogtreecommitdiffstats
path: root/tests/winDialog.test
diff options
context:
space:
mode:
Diffstat (limited to 'tests/winDialog.test')
-rw-r--r--tests/winDialog.test420
1 files changed, 307 insertions, 113 deletions
diff --git a/tests/winDialog.test b/tests/winDialog.test
index bb515af..b7847a5 100644
--- a/tests/winDialog.test
+++ b/tests/winDialog.test
@@ -7,8 +7,9 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# Copyright (c) 1998-1999 ActiveState Corporation.
-package require tcltest 2.1
-eval tcltest::configure $argv
+package require tcltest 2.2
+namespace import ::tcltest::*
+tcltest::configure {*}$argv
tcltest::loadTestedCommands
if {[testConstraint testwinevent]} {
@@ -21,9 +22,26 @@ testConstraint english [expr {
&& (([testwinlocale] & 0xff) == 9)
}]
+proc vista? {{prevista 0} {postvista 1}} {
+ lassign [split $::tcl_platform(osVersion) .] major
+ return [expr {$major >= 6 ? $postvista : $prevista}]
+}
+
+# What directory to use in initialdir tests. Old code used to use
+# c:/. However, on Vista/later that is a protected directory if you
+# are not running privileged. Moreover, not everyone has a drive c:
+# but not having a TEMP would break a lot Windows programs
+proc initialdir {} {
+ # file join to return in Tcl canonical format (/ separator, not \)
+ #return [file join $::env(TEMP)]
+ return [tcltest::temporaryDirectory]
+}
+
+
proc start {arg} {
set ::tk_dialog 0
set ::iter_after 0
+ set ::dialogclass "#32770"
after 1 $arg
}
@@ -31,20 +49,37 @@ proc start {arg} {
proc then {cmd} {
set ::command $cmd
set ::dialogresult {}
+ set ::testfont {}
- afterbody
+ # Do not make the delay too short. The newer Vista dialogs take
+ # time to come up. Even if the testforwindow returns true, the
+ # controls are not ready to accept messages
+ after 500 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
+ # On Vista and later, using the new file dialogs we have to find
+ # the window using its title as tk_dialog will not be set at the C level
+ if {[vista?]} {
+ if {[catch {testfindwindow "" $::dialogclass} ::tk_dialog]} {
+ if {[incr ::iter_after] > 30} {
+ set ::dialogresult ">30 iterations waiting on tk_dialog"
+ return
+ }
+ after 150 {afterbody}
+ return
+ }
+ } else {
+ 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]}
}
@@ -70,6 +105,12 @@ proc SetText {id text} {
return [testwinevent $::tk_dialog $id WM_SETTEXT $text]
}
+proc ApplyFont {font} {
+ set ::testfont $font
+}
+
+# ----------------------------------------------------------------------
+
test winDialog-1.1 {Tk_ChooseColorObjCmd} -constraints {
testwinevent
} -body {
@@ -156,13 +197,15 @@ test winDialog-1.7 {Tk_ChooseColorObjCmd: -parent} -constraints {
} -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 {
start {tk_getOpenFile}
then {
- set x [GetText cancel]
- Click cancel
+ set x [GetText cancel]
+ Click cancel
}
return $x
} -result {Cancel}
@@ -173,8 +216,8 @@ test winDialog-4.1 {Tk_GetSaveFileObjCmd} -constraints {
} -body {
start {tk_getSaveFile}
then {
- set x [GetText cancel]
- Click cancel
+ set x [GetText cancel]
+ Click cancel
}
return $x
} -result {Cancel}
@@ -184,7 +227,7 @@ test winDialog-5.1 {GetFileName: no arguments} -constraints {
} -body {
start {tk_getOpenFile -title Open}
then {
- Click cancel
+ Click cancel
}
} -result {0}
test winDialog-5.2 {GetFileName: one argument} -constraints {
@@ -195,9 +238,9 @@ test winDialog-5.2 {GetFileName: one argument} -constraints {
test winDialog-5.3 {GetFileName: many arguments} -constraints {
nt testwinevent
} -body {
- start {tk_getOpenFile -initialdir c:/ -parent . -title test -initialfile foo}
+ start {tk_getOpenFile -initialdir [initialdir] -parent . -title test -initialfile foo}
then {
- Click cancel
+ Click cancel
}
} -result {0}
test winDialog-5.4 {GetFileName: Tcl_GetIndexFromObj() != TCL_OK} -constraints {
@@ -208,10 +251,14 @@ test winDialog-5.4 {GetFileName: Tcl_GetIndexFromObj() != TCL_OK} -constraints {
test winDialog-5.5 {GetFileName: Tcl_GetIndexFromObj() == TCL_OK} -constraints {
nt testwinevent
} -body {
- start {tk_getOpenFile -title bar}
- then {
- Click cancel
- }
+ start {set x [tk_getOpenFile -title bar]}
+ set y [then {
+ Click cancel
+ }]
+ # Note this also tests fix for
+ # http://core.tcl.tk/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
@@ -221,145 +268,169 @@ test winDialog-5.6 {GetFileName: valid option, but missing value} -constraints {
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]} {
+ if {[catch {SetText [vista? 0x47C 0x3e9] bar} msg]} {
Click cancel
} else {
Click ok
}
}
- return [string totitle $x]$msg
+ set x "[file tail $x]$msg"
} -cleanup {
unset msg
-} -result [string totitle [file join [pwd] bar.foo]]
+} -result 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]} {
+ if {[catch {SetText [vista? 0x47C 0x3e9] bar} msg]} {
Click cancel
} else {
Click ok
}
}
- return [string totitle $x]$msg
+ set x "[file tail $x]$msg"
} -cleanup {
unset msg
-} -result [string totitle [file join [pwd] bar.foo]]
+} -result bar.foo
test winDialog-5.9 {GetFileName: file types} -constraints {
nt testwinevent
} -body {
-# case FILE_TYPES:
-
+ # 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)}
+ # XXX - currently disabled for vista style dialogs because the file
+ # types control has no control ID and we don't have a mechanism to
+ # locate it.
+ if {[vista?]} {
+ then {
+ Click cancel
+ }
+ return 1
+ } else {
+ then {
+ set x [GetText 0x470]
+ Click cancel
+ }
+ return [string equal $x {foo files (*.foo)}]
+ }
+} -result 1
test winDialog-5.10 {GetFileName: file types: MakeFilter() fails} -constraints {
nt
} -body {
-# if (MakeFilter(interp, string, &utfFilterString) != TCL_OK)
+# 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:
-
+# case FILE_INITDIR:
+ unset -nocomplain x
start {set x [tk_getSaveFile \
- -initialdir [file normalize $::env(TEMP)] \
+ -initialdir [initialdir] \
-initialfile "12x 455" -title Foo]}
then {
- Click ok
+ Click ok
}
return $x
-} -result [file join [file normalize $::env(TEMP)] "12x 455"]
-}
+} -result [file join [initialdir] "12x 455"]
test winDialog-5.12 {GetFileName: initial directory: Tcl_TranslateFilename()} -constraints {
nt
} -body {
-# if (Tcl_TranslateFileName(interp, string, &ds) == NULL)
+# 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:
+# case FILE_INITFILE:
start {set x [tk_getSaveFile -initialfile "12x 456" -title Foo]}
then {
- Click ok
+ Click ok
}
- string totitle $x
-} -result [string totitle [file join [pwd] "12x 456"]]
+ file tail $x
+} -result "12x 456"
test winDialog-5.14 {GetFileName: initial file: Tcl_TranslateFileName()} -constraints {
nt
} -body {
-# if (Tcl_TranslateFileName(interp, string, &ds) == NULL)
+# 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 ok
- }
- list $dialogresult [string match "invalid filename *" $x]
-} -result {1 1}
+if {![vista?]} {
+ # XXX - disabled for Vista because the new dialogs allow long file
+ # names to be specified but force the user to change it.
+ 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 ok
+ }
+ list $dialogresult [string match "invalid filename *" $x]
+ } -result {1 1}
+}
test winDialog-5.16 {GetFileName: parent} -constraints {
nt
} -body {
-# case FILE_PARENT:
+# case FILE_PARENT:
toplevel .t
set x 0
start {tk_getOpenFile -parent .t -title Parent; set x 1}
then {
- destroy .t
+ destroy .t
}
return $x
} -result {1}
test winDialog-5.17 {GetFileName: title} -constraints {
nt testwinevent
} -body {
-# case FILE_TITLE:
-
+# case FILE_TITLE:
+
start {tk_getOpenFile -title Narf}
then {
- Click cancel
+ Click cancel
}
} -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 cancel
- }
- return $x
-} -result {All Files (*.*)}
+if {[vista?]} {
+ # 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)
+ start {tk_getOpenFile -title Filter}
+ then {
+ catch {set x [GetText 0x470]} y
+ Click cancel
+ }
+ return $y
+ } -result {Could not find control with id 1136}
+} else {
+ 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 cancel
+ }
+ return $x
+ } -result {All Files (*.*)}
+}
test winDialog-5.19 {GetFileName: parent HWND doesn't yet exist} -constraints {
nt
} -setup {
@@ -370,7 +441,7 @@ test winDialog-5.19 {GetFileName: parent HWND doesn't yet exist} -constraints {
toplevel .t
start {tk_getOpenFile -parent .t -title Open}
then {
- destroy .t
+ destroy .t
}
} -result {}
test winDialog-5.20 {GetFileName: parent HWND already exists} -constraints {
@@ -382,42 +453,41 @@ test winDialog-5.20 {GetFileName: parent HWND already exists} -constraints {
update
start {tk_getOpenFile -parent .t -title Open}
then {
- destroy .t
+ destroy .t
}
} -result {}
test winDialog-5.21 {GetFileName: call GetOpenFileName} -constraints {
nt testwinevent english
} -body {
-# winCode = GetOpenFileName(&ofn);
-
+# winCode = GetOpenFileName(&ofn);
+
start {tk_getOpenFile -title Open}
then {
- set x [GetText ok]
- Click cancel
+ 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);
+# winCode = GetSaveFileName(&ofn);
start {tk_getSaveFile -title Save}
then {
- set x [GetText ok]
- Click cancel
+ set x [GetText ok]
+ Click cancel
}
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]} {
+ if {[catch {SetText [vista? 0x47C 0x3e9] [file nativename \
+ [file join [initialdir] "12x 457"]]} msg]} {
Click cancel
} else {
Click ok
@@ -426,8 +496,7 @@ test winDialog-5.23 {GetFileName: convert \ to /} -constraints {
return $x$msg
} -cleanup {
unset msg
-} -result [file join [file normalize $::env(TEMP)] "12x 457"]
-}
+} -result [file join [initialdir] "12x 457"]
test winDialog-5.24 {GetFileName: file types: MakeFilter() succeeds} -constraints {
nt
} -body {
@@ -435,7 +504,7 @@ test winDialog-5.24 {GetFileName: file types: MakeFilter() succeeds} -constraint
start {set x [catch {tk_getSaveFile -filetypes {{"foo" .foo {\0\0\0\0}}}}]}
then {
- Click cancel
+ Click cancel
}
return $x
} -result {0}
@@ -446,11 +515,21 @@ test winDialog-5.25 {GetFileName: file types: MakeFilter() succeeds} -constraint
start {set x [catch {tk_getSaveFile -filetypes {{"foo" .foo {\u2022\u2022\u2022\u2022}}}}]}
then {
- Click cancel
+ 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.
@@ -458,10 +537,12 @@ test winDialog-5.25 {GetFileName: file types: MakeFilter() succeeds} -constraint
test winDialog-9.1 {Tk_ChooseDirectoryObjCmd: no arguments} -constraints {
nt testwinevent
} -body {
- start {tk_chooseDirectory}
- then {
- Click cancel
- }
+ start {set x [tk_chooseDirectory]}
+ set y [then {
+ Click cancel
+ }]
+ # $x should be "" on a Cancel
+ append x $y
} -result {0}
test winDialog-9.2 {Tk_ChooseDirectoryObjCmd: one argument} -constraints {
nt
@@ -472,10 +553,10 @@ test winDialog-9.3 {Tk_ChooseDirectoryObjCmd: many arguments} -constraints {
nt testwinevent
} -body {
start {
- tk_chooseDirectory -initialdir c:/ -mustexist 1 -parent . -title test
+ tk_chooseDirectory -initialdir [initialdir] -mustexist 1 -parent . -title test
}
then {
- Click cancel
+ Click cancel
}
} -result {0}
test winDialog-9.4 {Tk_ChooseDirectoryObjCmd: Tcl_GetIndexFromObj() != TCL_OK} -constraints {
@@ -488,7 +569,7 @@ test winDialog-9.5 {Tk_ChooseDirectoryObjCmd: Tcl_GetIndexFromObj() == TCL_OK} -
} -body {
start {tk_chooseDirectory -title bar}
then {
- Click cancel
+ Click cancel
}
} -result {0}
test winDialog-9.6 {Tk_ChooseDirectoryObjCmd: valid option, but missing value} -constraints {
@@ -499,23 +580,135 @@ test winDialog-9.6 {Tk_ChooseDirectoryObjCmd: valid option, but missing value} -
test winDialog-9.7 {Tk_ChooseDirectoryObjCmd: -initialdir} -constraints {
nt testwinevent
} -body {
-# case DIR_INITIAL:
+# case DIR_INITIAL:
- start {set x [tk_chooseDirectory -initialdir c:/ -title Foo]}
+ start {set x [tk_chooseDirectory -initialdir [initialdir] -title Foo]}
then {
- Click ok
+ Click ok
}
string tolower [set x]
-} -result {c:/}
+} -result [string tolower [initialdir]]
test winDialog-9.8 {Tk_ChooseDirectoryObjCmd: initial directory: Tcl_TranslateFilename()} -constraints {
nt
} -body {
-# if (Tcl_TranslateFileName(interp, string,
-# &utfDirString) == NULL)
-
+# if (Tcl_TranslateFileName(interp, string,
+# &utfDirString) == NULL)
+
tk_chooseDirectory -initialdir ~12x/455
} -returnCodes error -result {user "12x" doesn't exist}
+
+test winDialog-10.1 {Tk_FontchooserObjCmd: no arguments} -constraints {
+ nt testwinevent
+} -body {
+ start {tk fontchooser show}
+ list [then {
+ Click cancel
+ }] $::testfont
+} -result {0 {}}
+test winDialog-10.2 {Tk_FontchooserObjCmd: -initialfont} -constraints {
+ nt testwinevent
+} -body {
+ start {
+ tk fontchooser configure -command ApplyFont -font system
+ tk fontchooser show
+ }
+ list [then {
+ Click cancel
+ }] $::testfont
+} -result {0 {}}
+test winDialog-10.3 {Tk_FontchooserObjCmd: -initialfont} -constraints {
+ nt testwinevent
+} -body {
+ start {
+ tk fontchooser configure -command ApplyFont -font system
+ tk fontchooser show
+ }
+ list [then {
+ Click 1
+ }] [expr {[llength $::testfont] ne {}}]
+} -result {0 1}
+test winDialog-10.4 {Tk_FontchooserObjCmd: -title} -constraints {
+ nt testwinevent
+} -body {
+ start {
+ tk fontchooser configure -command ApplyFont -title "tk test"
+ tk fontchooser show
+ }
+ list [then {
+ Click cancel
+ }] $::testfont
+} -result {0 {}}
+test winDialog-10.5 {Tk_FontchooserObjCmd: -parent} -constraints {
+ nt testwinevent
+} -setup {
+ array set a {parent {}}
+} -body {
+ start {
+ tk fontchooser configure -command ApplyFont -parent .
+ tk fontchooser show
+ }
+ then {
+ array set a [testgetwindowinfo $::tk_dialog]
+ Click cancel
+ }
+ list [expr {$a(parent) == [wm frame .]}] $::testfont
+} -result {1 {}}
+test winDialog-10.6 {Tk_FontchooserObjCmd: -apply} -constraints {
+ nt testwinevent
+} -body {
+ start {
+ tk fontchooser configure -command FooBarBaz
+ tk fontchooser show
+ }
+ then {
+ Click cancel
+ }
+} -result 0
+test winDialog-10.7 {Tk_FontchooserObjCmd: -apply} -constraints {
+ nt testwinevent
+} -body {
+ start {
+ tk fontchooser configure -command ApplyFont -parent .
+ tk fontchooser show
+ }
+ list [then {
+ Click [expr {0x0402}] ;# value from XP
+ Click cancel
+ }] [expr {[llength $::testfont] > 0}]
+} -result {0 1}
+test winDialog-10.8 {Tk_FontchooserObjCmd: -title} -constraints {
+ nt testwinevent
+} -setup {
+ array set a {text failed}
+} -body {
+ start {
+ tk fontchooser configure -command ApplyFont -title "Hello"
+ tk fontchooser show
+ }
+ then {
+ array set a [testgetwindowinfo $::tk_dialog]
+ Click cancel
+ }
+ set a(text)
+} -result "Hello"
+test winDialog-10.9 {Tk_FontchooserObjCmd: -title} -constraints {
+ nt testwinevent
+} -setup {
+ array set a {text failed}
+} -body {
+ start {
+ tk fontchooser configure -command ApplyFont \
+ -title "\u041f\u0440\u0438\u0432\u0435\u0442"
+ tk fontchooser show
+ }
+ then {
+ array set a [testgetwindowinfo $::tk_dialog]
+ Click cancel
+ }
+ set a(text)
+} -result "\u041f\u0440\u0438\u0432\u0435\u0442"
+
if {[testConstraint testwinevent]} {
catch {testwinevent debug 0}
}
@@ -527,3 +720,4 @@ return
# Local variables:
# mode: tcl
# End:
+
generated by cgit v0.12 at 2024-07-22 03:36:15 (GMT)