summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorjan.nijtmans <nijtmans@users.sourceforge.net>2012-11-13 10:15:16 (GMT)
committerjan.nijtmans <nijtmans@users.sourceforge.net>2012-11-13 10:15:16 (GMT)
commit66e1785645916a104217fc67b81b75cbc73e2e26 (patch)
treec797f0615d95feaa509b6066e2a1442c4b724f2f
parent48578cf487ec03f503d5b57a50be25e52e3b1a90 (diff)
parent33c21b13cccb585c96fb2b77a27cf0b89f66a547 (diff)
downloadtk-66e1785645916a104217fc67b81b75cbc73e2e26.zip
tk-66e1785645916a104217fc67b81b75cbc73e2e26.tar.gz
tk-66e1785645916a104217fc67b81b75cbc73e2e26.tar.bz2
[Bug 3585396]: winDialog.test requires user interaction.
<p>Renumber test-cases as in Tk 8.6, and convert various to tcltest-2 style.
-rw-r--r--ChangeLog6
-rw-r--r--tests/winDialog.test382
-rw-r--r--win/tkWinTest.c79
3 files changed, 289 insertions, 178 deletions
diff --git a/ChangeLog b/ChangeLog
index a1e88e9..8237eed 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,9 @@
+2012-11-13 Jan Nijtmans <nijtmans@users.sf.net>
+
+ * win/tkWinTest.c: [Bug 3585396]: winDialog.test requires user
+ * tests/winDialog.test: interaction. Renumber test-cases as in
+ Tk 8.6, and convert various to tcltest-2 style.
+
2012-11-09 Don Porter <dgp@users.sourceforge.net>
*** 8.5.13 TAGGED FOR RELEASE ***
diff --git a/tests/winDialog.test b/tests/winDialog.test
index 80eb297..bb515af 100644
--- a/tests/winDialog.test
+++ b/tests/winDialog.test
@@ -70,7 +70,7 @@ proc SetText {id text} {
return [testwinevent $::tk_dialog $id WM_SETTEXT $text]
}
-test winDialog-1.1.0 {Tk_ChooseColorObjCmd} -constraints {
+test winDialog-1.1 {Tk_ChooseColorObjCmd} -constraints {
testwinevent
} -body {
start {tk_chooseColor}
@@ -78,7 +78,7 @@ test winDialog-1.1.0 {Tk_ChooseColorObjCmd} -constraints {
Click cancel
}
} -result {0}
-test winDialog-1.1.1 {Tk_ChooseColorObjCmd} -constraints {
+test winDialog-1.2 {Tk_ChooseColorObjCmd} -constraints {
testwinevent
} -body {
start {set clr [tk_chooseColor -initialcolor "#ff9933"]}
@@ -87,7 +87,7 @@ test winDialog-1.1.1 {Tk_ChooseColorObjCmd} -constraints {
}
list $x $clr
} -result {0 {}}
-test winDialog-1.1.2 {Tk_ChooseColorObjCmd} -constraints {
+test winDialog-1.3 {Tk_ChooseColorObjCmd} -constraints {
testwinevent
} -body {
start {set clr [tk_chooseColor -initialcolor "#ff9933"]}
@@ -96,9 +96,11 @@ test winDialog-1.1.2 {Tk_ChooseColorObjCmd} -constraints {
}
list $x $clr
} -result [list 0 "#ff9933"]
-test winDialog-1.1.3 {Tk_ChooseColorObjCmd: -title} -constraints {
+test winDialog-1.4 {Tk_ChooseColorObjCmd: -title} -constraints {
testwinevent
-} -setup {unset -nocomplain a x} -body {
+} -setup {
+ catch {unset a x}
+} -body {
set x {}
start {set clr [tk_chooseColor -initialcolor "#ff9933" -title "Hello"]}
then {
@@ -110,9 +112,11 @@ test winDialog-1.1.3 {Tk_ChooseColorObjCmd: -title} -constraints {
}
lappend x $clr
} -result [list Hello 0 "#ff9933"]
-test winDialog-1.1.4 {Tk_ChooseColorObjCmd: -title} -constraints {
+test winDialog-1.5 {Tk_ChooseColorObjCmd: -title} -constraints {
testwinevent
-} -setup {unset -nocomplain a x} -body {
+} -setup {
+ catch {unset a x}
+} -body {
set x {}
start {
set clr [tk_chooseColor -initialcolor "#ff9933" \
@@ -127,9 +131,11 @@ test winDialog-1.1.4 {Tk_ChooseColorObjCmd: -title} -constraints {
}
lappend x $clr
} -result [list "\u041f\u0440\u0438\u0432\u0435\u0442" 0 "#ff9933"]
-test winDialog-1.1.5 {Tk_ChooseColorObjCmd: -parent} -constraints {
+test winDialog-1.6 {Tk_ChooseColorObjCmd: -parent} -constraints {
testwinevent
-} -setup {unset -nocomplain a x} -body {
+} -setup {
+ catch {unset a x}
+} -body {
start {set clr [tk_chooseColor -initialcolor "#ff9933" -parent .]}
set x {}
then {
@@ -143,98 +149,135 @@ test winDialog-1.1.5 {Tk_ChooseColorObjCmd: -parent} -constraints {
}
list $x $clr
} -result [list 1 "#ff9933"]
-test winDialog-1.1.6 {Tk_ChooseColorObjCmd: -parent} -constraints {
+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} {emptyTest nt} {
-} {}
-test winDialog-3.1 {Tk_GetOpenFileObjCmd} {nt testwinevent english} {
+test winDialog-3.1 {Tk_GetOpenFileObjCmd} -constraints {
+ nt testwinevent english
+} -body {
start {tk_getOpenFile}
then {
set x [GetText cancel]
Click cancel
}
- set x
-} {Cancel}
+ return $x
+} -result {Cancel}
-test winDialog-4.1 {Tk_GetSaveFileObjCmd} {nt testwinevent english} {
+
+test winDialog-4.1 {Tk_GetSaveFileObjCmd} -constraints {
+ nt testwinevent english
+} -body {
start {tk_getSaveFile}
then {
set x [GetText cancel]
Click cancel
}
- set x
-} {Cancel}
+ return $x
+} -result {Cancel}
-test winDialog-5.1 {GetFileName: no arguments} {nt testwinevent} {
+test winDialog-5.1 {GetFileName: no arguments} -constraints {
+ nt testwinevent
+} -body {
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} {
+} -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 {
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} {
+} -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 {
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 knownBug} {
+} -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 {
- SetText 0x480 bar
- Click ok
+ if {[catch {SetText 0x47C bar} msg]} {
+ Click cancel
+ } else {
+ Click ok
+ }
}
- string totitle $x
-} [string totitle [file join [pwd] bar.foo]]
-test winDialog-5.9 {GetFileName: extension doesn't begin with .} {nt testwinevent knownBug} {
+ 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 {
- SetText 0x480 bar
- Click ok
+ if {[catch {SetText 0x47C bar} msg]} {
+ Click cancel
+ } else {
+ Click ok
+ }
}
- string totitle $x
-} [string totitle [file join [pwd] bar.foo]]
-test winDialog-5.10 {GetFileName: file types} {nt testwinevent} {
-# case FILE_TYPES:
+ 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
}
- set x
-} {foo files (*.foo)}
-test winDialog-5.11 {GetFileName: file types: MakeFilter() fails} {nt} {
-# if (MakeFilter(interp, string, &utfFilterString) != TCL_OK)
+ 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)
- list [catch {tk_getSaveFile -filetypes {{"foo" .foo FOO}}} msg] $msg
-} {1 {bad Macintosh file type "FOO"}}
+ tk_getSaveFile -filetypes {{"foo" .foo FOO}}
+} -returnCodes error -result {bad Macintosh file type "FOO"}
if {[info exists ::env(TEMP)]} {
-test winDialog-5.12 {GetFileName: initial directory} {nt testwinevent} {
-# case FILE_INITDIR:
+test winDialog-5.11 {GetFileName: initial directory} -constraints {
+ nt testwinevent
+} -body {
+# case FILE_INITDIR:
start {set x [tk_getSaveFile \
-initialdir [file normalize $::env(TEMP)] \
@@ -242,41 +285,50 @@ test winDialog-5.12 {GetFileName: initial directory} {nt testwinevent} {
then {
Click ok
}
- set x
-} [file join [file normalize $::env(TEMP)] "12x 455"]
+ return $x
+} -result [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:
+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 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} {
+} -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]
+ 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:
+} -result {1 1}
+test winDialog-5.16 {GetFileName: parent} -constraints {
+ nt
+} -body {
+# case FILE_PARENT:
toplevel .t
set x 0
@@ -284,151 +336,185 @@ test winDialog-5.17 {GetFileName: parent} {nt} {
then {
destroy .t
}
- set x
-} {1}
-test winDialog-5.18 {GetFileName: title} {nt testwinevent} {
-# case FILE_TITLE:
-
+ return $x
+} -result {1}
+test winDialog-5.17 {GetFileName: title} -constraints {
+ nt testwinevent
+} -body {
+# 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)
+} -result {0}
+test winDialog-5.18 {GetFileName: no filter specified} -constraints {
+ nt testwinevent
+} -body {
+# if (ofn.lpstrFilter == NULL)
- start {tk_getOpenFile -title Filter}
+ 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)
+ 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
}
-} {}
-test winDialog-5.21 {GetFileName: parent HWND already exists} {nt} {
+} -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
}
-} {}
-test winDialog-5.22 {GetFileName: call GetOpenFileName} {nt testwinevent english} {
-# winCode = GetOpenFileName(&ofn);
-
+} -result {}
+test winDialog-5.21 {GetFileName: call GetOpenFileName} -constraints {
+ nt testwinevent english
+} -body {
+# 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);
+ return $x
+} -result {&Open}
+test winDialog-5.22 {GetFileName: call GetSaveFileName} -constraints {
+ nt testwinevent english
+} -body {
+# winCode = GetSaveFileName(&ofn);
start {tk_getSaveFile -title Save}
then {
set x [GetText ok]
Click cancel
}
- set x
-} {&Save}
+ return $x
+} -result {&Save}
if {[info exists ::env(TEMP)]} {
-test winDialog-5.24 {GetFileName: convert \ to /} {nt testwinevent knownBug} {
+test winDialog-5.23 {GetFileName: convert \ to /} -constraints {
+ nt testwinevent
+} -body {
+ set msg {}
start {set x [tk_getSaveFile -title Back]}
then {
- SetText 0x480 [file nativename \
- [file join [file normalize $::env(TEMP)] "12x 457"]]
- Click ok
+ if {[catch {SetText 0x47C [file nativename \
+ [file join [file normalize $::env(TEMP)] "12x 457"]]} msg]} {
+ Click cancel
+ } else {
+ Click ok
+ }
}
- set x
-} [file join [file normalize $::env(TEMP)] "12x 457"]
+ return $x$msg
+} -cleanup {
+ unset msg
+} -result [file join [file normalize $::env(TEMP)] "12x 457"]
}
-test winDialog-5.25 {GetFileName: file types: MakeFilter() succeeds} {nt} {
+test winDialog-5.24 {GetFileName: file types: MakeFilter() succeeds} -constraints {
+ nt
+} -body {
# 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} {
+ 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.
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} {} {}
+ return $x
+} -result {0}
## 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} {
+test winDialog-9.1 {Tk_ChooseDirectoryObjCmd: no arguments} -constraints {
+ nt testwinevent
+} -body {
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} {
+} -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
}
-} {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} {
+} -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
}
-} {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:
+} -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 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}}
+} -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}
@@ -437,3 +523,7 @@ if {[testConstraint testwinevent]} {
# cleanup
cleanupTests
return
+
+# Local variables:
+# mode: tcl
+# End:
diff --git a/win/tkWinTest.c b/win/tkWinTest.c
index d361ad7..2498864 100644
--- a/win/tkWinTest.c
+++ b/win/tkWinTest.c
@@ -22,21 +22,20 @@ HWND tkWinCurrentDialog;
static int TestclipboardObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
- Tcl_Obj *CONST objv[]);
+ Tcl_Obj *const objv[]);
static int TestwineventCmd(ClientData clientData,
- Tcl_Interp *interp, int argc, CONST char **argv);
+ Tcl_Interp *interp, int argc, const char **argv);
static int TestfindwindowObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
- Tcl_Obj *CONST objv[]);
+ Tcl_Obj *const objv[]);
static int TestgetwindowinfoObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
- Tcl_Obj *CONST objv[]);
+ Tcl_Obj *const objv[]);
static int TestwinlocaleObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
MODULE_SCOPE int TkplatformtestInit(Tcl_Interp *interp);
-
/*
*----------------------------------------------------------------------
*
@@ -99,11 +98,14 @@ AppendSystemError(
{
int length;
WCHAR *wMsgPtr, **wMsgPtrPtr = &wMsgPtr;
- char *msg;
+ const char *msg;
char id[TCL_INTEGER_SPACE], msgBuf[24 + TCL_INTEGER_SPACE];
Tcl_DString ds;
Tcl_Obj *resultPtr = Tcl_GetObjResult(interp);
+ if (Tcl_IsShared(resultPtr)) {
+ resultPtr = Tcl_DuplicateObj(resultPtr);
+ }
length = FormatMessageW(FORMAT_MESSAGE_FROM_SYSTEM
| FORMAT_MESSAGE_ALLOCATE_BUFFER, NULL, error,
MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), (WCHAR *) wMsgPtrPtr,
@@ -124,36 +126,41 @@ AppendSystemError(
}
if (length == 0) {
if (error == ERROR_CALL_NOT_IMPLEMENTED) {
- msg = "function not supported under Win32s";
+ strcpy(msgBuf, "function not supported under Win32s");
} else {
sprintf(msgBuf, "unknown error: %ld", error);
- msg = msgBuf;
}
+ msg = msgBuf;
} else {
Tcl_Encoding encoding;
+ char *msgPtr;
encoding = Tcl_GetEncoding(NULL, "unicode");
- msg = Tcl_ExternalToUtfDString(encoding, (char *) wMsgPtr, -1, &ds);
+ Tcl_ExternalToUtfDString(encoding, (char *) wMsgPtr, -1, &ds);
Tcl_FreeEncoding(encoding);
LocalFree(wMsgPtr);
+ msgPtr = Tcl_DStringValue(&ds);
length = Tcl_DStringLength(&ds);
/*
* Trim the trailing CR/LF from the system message.
*/
- if (msg[length-1] == '\n') {
- msg[--length] = 0;
+ if (msgPtr[length-1] == '\n') {
+ --length;
}
- if (msg[length-1] == '\r') {
- msg[--length] = 0;
+ if (msgPtr[length-1] == '\r') {
+ --length;
}
+ msgPtr[length] = 0;
+ msg = msgPtr;
}
sprintf(id, "%ld", error);
Tcl_SetErrorCode(interp, "WINDOWS", id, msg, NULL);
Tcl_AppendToObj(resultPtr, msg, length);
+ Tcl_SetObjResult(interp, resultPtr);
if (length != 0) {
Tcl_DStringFree(&ds);
@@ -182,7 +189,7 @@ TestclipboardObjCmd(
ClientData clientData, /* Main window for application. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
- Tcl_Obj *CONST objv[]) /* Argument values. */
+ Tcl_Obj *const objv[]) /* Argument values. */
{
HGLOBAL handle;
char *data;
@@ -194,11 +201,11 @@ TestclipboardObjCmd(
}
if (OpenClipboard(NULL)) {
/*
- * We could consider using CF_UNICODETEXT on NT, but then we would
- * have to convert it from External. Instead we'll just take this and
- * do "bytestring" at the Tcl level for Unicode inclusive text
+ * We could consider using CF_UNICODETEXT on NT, but then we
+ * would have to convert it from External. Instead we'll just
+ * take this and do "bytestring" at the Tcl level for Unicode
+ * inclusive text
*/
-
handle = GetClipboardData(CF_TEXT);
if (handle != NULL) {
data = GlobalLock(handle);
@@ -240,7 +247,7 @@ TestwineventCmd(
ClientData clientData, /* Main window for application. */
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
- CONST char **argv) /* Argument strings. */
+ const char **argv) /* Argument strings. */
{
HWND hwnd = 0;
HWND child = 0;
@@ -273,7 +280,7 @@ TestwineventCmd(
return TCL_ERROR;
}
- hwnd = (HWND) INT2PTR(strtol(argv[1], &rest, 0));
+ hwnd = INT2PTR(strtol(argv[1], &rest, 0));
if (rest == argv[1]) {
hwnd = FindWindow(NULL, argv[1]);
if (hwnd == NULL) {
@@ -326,10 +333,16 @@ TestwineventCmd(
}
case WM_SETTEXT: {
Tcl_DString ds;
+ BOOL result;
Tcl_UtfToExternalDString(NULL, argv[4], -1, &ds);
- SetDlgItemText(hwnd, id, Tcl_DStringValue(&ds));
+ result = SetDlgItemText(hwnd, id, Tcl_DStringValue(&ds));
Tcl_DStringFree(&ds);
+ if (result == 0) {
+ Tcl_SetResult(interp, "failed to send text to dialog: ", TCL_STATIC);
+ AppendSystemError(interp, GetLastError());
+ return TCL_ERROR;
+ }
break;
}
case WM_COMMAND: {
@@ -357,7 +370,7 @@ TestwineventCmd(
/*
* testfindwindow title ?class?
* Find a Windows window using the FindWindow API call. This takes the window
- * title and optionally the window class and if found returns the HWND and
+ * title and optionally the window class and if found returns the HWND and
* raises an error if the window is not found.
* eg: testfindwindow Console TkTopLevel
* Can find the console window if it is visible.
@@ -370,7 +383,7 @@ TestfindwindowObjCmd(
ClientData clientData, /* Main window for application. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
- Tcl_Obj *CONST objv[]) /* Argument values. */
+ Tcl_Obj *const objv[]) /* Argument values. */
{
const char *title = NULL, *class = NULL;
HWND hwnd = NULL;
@@ -393,13 +406,15 @@ TestfindwindowObjCmd(
Tcl_SetObjResult(interp, Tcl_NewLongObj(PTR2INT(hwnd)));
}
return r;
-
}
static BOOL CALLBACK
-EnumChildrenProc(HWND hwnd, LPARAM lParam)
+EnumChildrenProc(
+ HWND hwnd,
+ LPARAM lParam)
{
- Tcl_Obj *listObj = (Tcl_Obj *)lParam;
+ Tcl_Obj *listObj = (Tcl_Obj *) lParam;
+
Tcl_ListObjAppendElement(NULL, listObj, Tcl_NewLongObj(PTR2INT(hwnd)));
return TRUE;
}
@@ -409,7 +424,7 @@ TestgetwindowinfoObjCmd(
ClientData clientData,
Tcl_Interp *interp,
int objc,
- Tcl_Obj *CONST objv[])
+ Tcl_Obj *const objv[])
{
long hwnd;
Tcl_Obj *resObj = NULL, *classObj = NULL, *textObj = NULL;
@@ -424,7 +439,7 @@ TestgetwindowinfoObjCmd(
if (Tcl_GetLongFromObj(interp, objv[1], &hwnd) != TCL_OK)
return TCL_ERROR;
-
+
if (tkWinProcs->useWide) {
cch = GetClassNameW(INT2PTR(hwnd), (LPWSTR)buf, sizeof(buf)/sizeof(WCHAR));
classObj = Tcl_NewUnicodeObj((LPWSTR)buf, cch);
@@ -436,14 +451,14 @@ TestgetwindowinfoObjCmd(
Tcl_SetResult(interp, "failed to get class name: ", TCL_STATIC);
AppendSystemError(interp, GetLastError());
return TCL_ERROR;
- }
+ }
resObj = Tcl_NewListObj(0, NULL);
Tcl_ListObjAppendElement(interp, resObj, Tcl_NewStringObj("class", -1));
Tcl_ListObjAppendElement(interp, resObj, classObj);
Tcl_ListObjAppendElement(interp, resObj, Tcl_NewStringObj("id", -1));
- Tcl_ListObjAppendElement(interp, resObj,
+ Tcl_ListObjAppendElement(interp, resObj,
Tcl_NewLongObj(GetWindowLong(INT2PTR(hwnd), GWL_ID)));
cch = tkWinProcs->getWindowText(INT2PTR(hwnd), (LPTSTR)buf, cchBuf);
@@ -456,7 +471,7 @@ TestgetwindowinfoObjCmd(
Tcl_ListObjAppendElement(interp, resObj, Tcl_NewStringObj("text", -1));
Tcl_ListObjAppendElement(interp, resObj, textObj);
Tcl_ListObjAppendElement(interp, resObj, Tcl_NewStringObj("parent", -1));
- Tcl_ListObjAppendElement(interp, resObj,
+ Tcl_ListObjAppendElement(interp, resObj,
Tcl_NewLongObj(PTR2INT(GetParent(INT2PTR(hwnd)))));
childrenObj = Tcl_NewListObj(0, NULL);
@@ -466,7 +481,7 @@ TestgetwindowinfoObjCmd(
Tcl_SetObjResult(interp, resObj);
return TCL_OK;
-}
+}
static int
TestwinlocaleObjCmd(