summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--library/dde/pkgIndex.tcl4
-rw-r--r--tests/winDde.test290
-rw-r--r--win/Makefile.in6
-rwxr-xr-xwin/configure8
-rw-r--r--win/configure.in4
-rw-r--r--win/makefile.bc4
-rw-r--r--win/makefile.vc4
-rw-r--r--win/tclWinDde.c583
-rw-r--r--win/tclWinReg.c32
9 files changed, 580 insertions, 355 deletions
diff --git a/library/dde/pkgIndex.tcl b/library/dde/pkgIndex.tcl
index 114dee6..065dc83 100644
--- a/library/dde/pkgIndex.tcl
+++ b/library/dde/pkgIndex.tcl
@@ -1,7 +1,7 @@
if {![package vsatisfies [package provide Tcl] 8]} return
if {[info sharedlibextension] != ".dll"} return
if {[info exists ::tcl_platform(debug)]} {
- package ifneeded dde 1.3.3 [list load [file join $dir tcldde13g.dll] dde]
+ package ifneeded dde 1.4.1 [list load [file join $dir tcldde14g.dll] dde]
} else {
- package ifneeded dde 1.3.3 [list load [file join $dir tcldde13.dll] dde]
+ package ifneeded dde 1.4.1 [list load [file join $dir tcldde14.dll] dde]
}
diff --git a/tests/winDde.test b/tests/winDde.test
index f0ef56c..1fa7e86 100644
--- a/tests/winDde.test
+++ b/tests/winDde.test
@@ -9,18 +9,19 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-if {[lsearch [namespace children] ::tcltest] == -1} {
+if {"::tcltest" ni [namespace children]} {
package require tcltest 2
#tcltest::configure -verbose {pass start}
namespace import -force ::tcltest::*
}
+testConstraint debug [::tcl::pkgconfig get debug]
testConstraint dde 0
if {[testConstraint win]} {
if {![catch {
::tcltest::loadTestedCommands
- package require dde
- set ::ddelib [lindex [package ifneeded dde 1.3.3] 1]}]} {
+ set ::ddever [package require dde 1.4.1]
+ set ::ddelib [lindex [package ifneeded dde $::ddever] 1]}]} {
testConstraint dde 1
}
}
@@ -32,7 +33,7 @@ if {[testConstraint win]} {
set scriptName [makeFile {} script1.tcl]
-proc createChildProcess {ddeServerName {handler {}}} {
+proc createChildProcess {ddeServerName args} {
file delete -force $::scriptName
set f [open $::scriptName w+]
@@ -41,11 +42,11 @@ proc createChildProcess {ddeServerName {handler {}}} {
puts $f {
# DDE child server -
#
- if {[lsearch [namespace children] ::tcltest] == -1} {
+ if {"::tcltest" ni [namespace children]} {
package require tcltest
namespace import -force ::tcltest::*
}
-
+
# If an error occurs during the tests, this process may end up not
# being closed down. To deal with this we create a 30s timeout.
proc ::DoTimeout {} {
@@ -55,16 +56,19 @@ proc createChildProcess {ddeServerName {handler {}}} {
flush stdout
}
set timeout [after 30000 ::DoTimeout]
-
+
# Define a restricted handler.
proc Handler1 {cmd} {
if {$cmd eq "stop"} {set ::done 1}
- puts $cmd ; flush stdout
+ if {$cmd == ""} {
+ set cmd "null data"
+ }
+ puts $cmd ; flush stdout
return
}
proc Handler2 {cmd} {
if {$cmd eq "stop"} {set ::done 1}
- puts [uplevel \#0 $cmd] ; flush stdout
+ puts [uplevel \#0 $cmd] ; flush stdout
return
}
proc Handler3 {prefix cmd} {
@@ -74,11 +78,7 @@ proc createChildProcess {ddeServerName {handler {}}} {
}
}
# set the dde server name to the supplied argument.
- if {$handler == {}} {
- puts $f [list dde servername $ddeServerName]
- } else {
- puts $f [list dde servername -handler $handler -- $ddeServerName]
- }
+ puts $f [list dde servername {*}$args -- $ddeServerName]
puts $f {
# run the server and handle final cleanup.
after 200;# give dde a chance to get going.
@@ -88,12 +88,12 @@ proc createChildProcess {ddeServerName {handler {}}} {
# allow enough time for the calling process to
# claim all results, to avoid spurious "server did
# not respond"
- after 200 { set reallyDone 1 }
+ after 200 {set reallyDone 1}
vwait reallyDone
exit
}
close $f
-
+
# run the child server script.
set f [open |[list [interpreter] $::scriptName] r]
fconfigure $f -buffering line
@@ -102,147 +102,184 @@ proc createChildProcess {ddeServerName {handler {}}} {
}
# -------------------------------------------------------------------------
+test winDde-1.0 {check if we are testing the right dll} {win dde} {
+ set ::ddever
+} {1.4.1}
-test winDde-1.1 {Settings the server's topic name} {win dde} {
+test winDde-1.1 {Settings the server's topic name} -constraints dde -body {
list [dde servername foobar] [dde servername] [dde servername self]
-} {foobar foobar self}
+} -result {foobar foobar self}
-test winDde-2.1 {Checking for other services} {win dde} {
+test winDde-2.1 {Checking for other services} -constraints dde -body {
expr [llength [dde services {} {}]] >= 0
-} 1
+} -result 1
test winDde-2.2 {Checking for existence, with service and topic specified} \
- {win dde} {
+ -constraints dde -body {
llength [dde services TclEval self]
-} 1
+} -result 1
test winDde-2.3 {Checking for existence, with only the service specified} \
- {win dde} {
+ -constraints dde -body {
expr [llength [dde services TclEval {}]] >= 1
-} 1
+} -result 1
test winDde-2.4 {Checking for existence, with only the topic specified} \
- {win dde} {
+ -constraints dde -body {
expr [llength [dde services {} self]] >= 1
-} 1
+} -result 1
# -------------------------------------------------------------------------
-test winDde-3.1 {DDE execute locally} {win dde} {
- set a ""
- dde execute TclEval self {set a "foo"}
- set a
-} foo
-test winDde-3.2 {DDE execute -async locally} {win dde} {
- set a ""
- dde execute -async TclEval self {set a "foo"}
+test winDde-3.1 {DDE execute locally} -constraints dde -body {
+ set \xe1 ""
+ dde execute TclEval self [list set \xe1 foo]
+ set \xe1
+} -result foo
+test winDde-3.2 {DDE execute -async locally} -constraints dde -body {
+ set \xe1 ""
+ dde execute -async TclEval self [list set \xe1 foo]
update
- set a
-} foo
-test winDde-3.3 {DDE request locally} {win dde} {
- set a ""
- dde execute TclEval self {set a "foo"}
- dde request TclEval self a
-} foo
-test winDde-3.4 {DDE eval locally} {win dde} {
- set a ""
- dde eval self set a "foo"
-} foo
-test winDde-3.5 {DDE request locally} {win dde} {
- set a ""
- dde execute TclEval self {set a "foo"}
- dde request -binary TclEval self a
-} "foo\x00"
+ set \xe1
+} -result foo
+test winDde-3.3 {DDE request locally} -constraints dde -body {
+ set \xe1 ""
+ dde execute TclEval self [list set \xe1 foo]
+ dde request TclEval self \xe1
+} -result foo
+test winDde-3.4 {DDE eval locally} -constraints dde -body {
+ set \xe1 ""
+ dde eval self set \xe1 foo
+} -result foo
+test winDde-3.5 {DDE request locally} -constraints dde -body {
+ set \xe1 ""
+ dde execute TclEval self [list set \xe1 foo]
+ dde request -binary TclEval self \xe1
+} -result "foo\x00"
+# Set variable a to A with diaeresis (unicode C4) by relying on the fact
+# that utf8 is sent (e.g. "c3 84" on the wire)
+test winDde-3.6 {DDE request utf8} -constraints dde -body {
+ set \xe1 "not set"
+ dde execute TclEval self "set \xe1 \xc4"
+ scan [set \xe1] %c
+} -result 196
+# Set variable a to A with diaeresis (unicode C4) using binary execute
+# and compose utf-8 (e.g. "c3 84" ) manualy
+test winDde-3.7 {DDE request binary} -constraints dde -body {
+ set \xe1 "not set"
+ dde execute -binary TclEval self [list set \xc3\xa1 \xc3\x84\x00]
+ scan [set \xe1] %c
+} -result 196
+test winDde-3.8 {DDE poke locally} -constraints {dde debug} -body {
+ set \xe1 ""
+ dde poke TclEval self \xe1 \xc4
+ dde request TclEval self \xe1
+} -result \xc4
+test winDde-3.9 {DDE poke -binary locally} -constraints {dde debug} -body {
+ set \xe1 ""
+ dde poke -binary TclEval self \xe1 \xc3\x84\x00
+ dde request TclEval self \xe1
+} -result \xc4
# -------------------------------------------------------------------------
-test winDde-4.1 {DDE execute remotely} {stdio win dde} {
- set a ""
- set name child-4.1
+test winDde-4.1 {DDE execute remotely} -constraints {dde stdio} -body {
+ set \xe1 ""
+ set name ch\xEDld-4.1
set child [createChildProcess $name]
- dde execute TclEval $name {set a "foo"}
+ dde execute TclEval $name [list set \xe1 foo]
dde execute TclEval $name {set done 1}
update
- set a
-} ""
-test winDde-4.2 {DDE execute async remotely} {stdio win dde} {
- set a ""
- set name child-4.2
+ set \xe1
+} -result ""
+test winDde-4.2 {DDE execute async remotely} -constraints {dde stdio} -body {
+ set \xe1 ""
+ set name ch\xEDld-4.2
set child [createChildProcess $name]
- dde execute -async TclEval $name {set a "foo"}
+ dde execute -async TclEval $name [list set \xe1 foo]
update
dde execute TclEval $name {set done 1}
update
- set a
-} ""
-test winDde-4.3 {DDE request remotely} {stdio win dde} {
- set a ""
- set name chile-4.3
+ set \xe1
+} -result ""
+test winDde-4.3 {DDE request remotely} -constraints {dde stdio} -body {
+ set \xe1 ""
+ set name ch\xEDld-4.3
+ set child [createChildProcess $name]
+ dde execute TclEval $name [list set \xe1 foo]
+ set \xe1 [dde request TclEval $name \xe1]
+ dde execute TclEval $name {set done 1}
+ update
+ set \xe1
+} -result foo
+test winDde-4.4 {DDE eval remotely} -constraints {dde stdio} -body {
+ set \xe1 ""
+ set name ch\xEDld-4.4
set child [createChildProcess $name]
- dde execute TclEval $name {set a "foo"}
- set a [dde request TclEval $name a]
+ set \xe1 [dde eval $name set \xe1 foo]
dde execute TclEval $name {set done 1}
update
- set a
-} foo
-test winDde-4.4 {DDE eval remotely} {stdio win dde} {
- set a ""
- set name child-4.4
+ set \xe1
+} -result foo
+test winDde-4.5 {DDE poke remotely} -constraints {dde debug stdio} -body {
+ set \xe1 ""
+ set name ch\xEDld-4.5
set child [createChildProcess $name]
- set a [dde eval $name set a "foo"]
+ dde poke TclEval $name \xe1 foo
+ set \xe1 [dde request TclEval $name \xe1]
dde execute TclEval $name {set done 1}
update
- set a
-} foo
+ set \xe1
+} -result foo
# -------------------------------------------------------------------------
-test winDde-5.1 {check for bad arguments} -constraints {win dde} -body {
+test winDde-5.1 {check for bad arguments} -constraints dde -body {
dde execute "" "" "" ""
-} -returnCodes error -result {wrong # args: should be "dde execute ?-async? serviceName topicName value"}
-test winDde-5.2 {check for bad arguments} -constraints {win dde} -body {
- dde execute "" "" ""
+} -returnCodes error -result {wrong # args: should be "dde execute ?-async? ?-binary? serviceName topicName value"}
+test winDde-5.2 {check for bad arguments} -constraints dde -body {
+ dde execute -binary "" "" ""
} -returnCodes error -result {cannot execute null data}
-test winDde-5.3 {check for bad arguments} -constraints {win dde} -body {
+test winDde-5.3 {check for bad arguments} -constraints dde -body {
dde execute -foo "" "" ""
-} -returnCodes error -result {wrong # args: should be "dde execute ?-async? serviceName topicName value"}
-test winDde-5.4 {DDE eval bad arguments} -constraints {win dde} -body {
+} -returnCodes error -result {wrong # args: should be "dde execute ?-async? ?-binary? serviceName topicName value"}
+test winDde-5.4 {DDE eval bad arguments} -constraints dde -body {
dde eval "" "foo"
} -returnCodes error -result {invalid service name ""}
# -------------------------------------------------------------------------
-test winDde-6.1 {DDE servername bad arguments} -constraints {win dde} -body {
+test winDde-6.1 {DDE servername bad arguments} -constraints dde -body {
dde servername -z -z -z
} -returnCodes error -result {bad option "-z": must be -force, -handler, or --}
-test winDde-6.2 {DDE servername set name} -constraints {win dde} -body {
+test winDde-6.2 {DDE servername set name} -constraints dde -body {
dde servername -- winDde-6.2
} -result {winDde-6.2}
-test winDde-6.3 {DDE servername set exact name} -constraints {win dde} -body {
+test winDde-6.3 {DDE servername set exact name} -constraints dde -body {
dde servername -force winDde-6.3
} -result {winDde-6.3}
-test winDde-6.4 {DDE servername set exact name} -constraints {win dde} -body {
+test winDde-6.4 {DDE servername set exact name} -constraints dde -body {
dde servername -force -- winDde-6.4
} -result {winDde-6.4}
-test winDde-6.5 {DDE remote servername collision} -constraints {stdio win dde} -setup {
- set name child-6.5
+test winDde-6.5 {DDE remote servername collision} -constraints {dde stdio} -setup {
+ set name ch\xEDld-6.5
set child [createChildProcess $name]
} -body {
dde servername -- $name
} -cleanup {
dde execute TclEval $name {set done 1}
update
-} -result "child-6.5 #2"
-test winDde-6.6 {DDE remote servername collision force} -constraints {stdio win dde} -setup {
- set name child-6.6
+} -result "ch\xEDld-6.5 #2"
+test winDde-6.6 {DDE remote servername collision force} -constraints {dde stdio} -setup {
+ set name ch\xEDld-6.6
set child [createChildProcess $name]
} -body {
dde servername -force -- $name
} -cleanup {
dde execute TclEval $name {set done 1}
update
-} -result {child-6.6}
+} -result "ch\xEDld-6.6"
# -------------------------------------------------------------------------
-test winDde-7.1 {Load DDE in slave interpreter } -constraints {win dde} -setup {
+test winDde-7.1 {Load DDE in slave interpreter} -constraints dde -setup {
interp create slave
} -body {
slave eval [list load $::ddelib Dde]
@@ -250,7 +287,7 @@ test winDde-7.1 {Load DDE in slave interpreter } -constraints {win dde} -setup {
} -cleanup {
interp delete slave
} -result {dde-interp-7.1}
-test winDde-7.2 {DDE slave cleanup} -constraints {win dde} -setup {
+test winDde-7.2 {DDE slave cleanup} -constraints dde -setup {
interp create slave
slave eval [list load $::ddelib Dde]
slave eval [list dde servername -- dde-interp-7.5]
@@ -259,11 +296,11 @@ test winDde-7.2 {DDE slave cleanup} -constraints {win dde} -setup {
dde services TclEval {}
set s [dde services TclEval {}]
set m [list [list TclEval dde-interp-7.5]]
- if {[lsearch -exact $s $m] != -1} {
+ if {$m in $s} {
set s
}
} -result {}
-test winDde-7.3 {DDE present in slave interp} -constraints {win dde} -setup {
+test winDde-7.3 {DDE present in slave interp} -constraints dde -setup {
interp create slave
slave eval [list load $::ddelib Dde]
slave eval [list dde servername -- dde-interp-7.3]
@@ -272,7 +309,7 @@ test winDde-7.3 {DDE present in slave interp} -constraints {win dde} -setup {
} -cleanup {
interp delete slave
} -result {{TclEval dde-interp-7.3}}
-test winDde-7.4 {interp name collision with -force} -constraints {win dde} -setup {
+test winDde-7.4 {interp name collision with -force} -constraints dde -setup {
interp create slave
slave eval [list load $::ddelib Dde]
slave eval [list dde servername -- dde-interp-7.4]
@@ -281,7 +318,7 @@ test winDde-7.4 {interp name collision with -force} -constraints {win dde} -setu
} -cleanup {
interp delete slave
} -result {dde-interp-7.4}
-test winDde-7.5 {interp name collision without -force} -constraints {win dde} -setup {
+test winDde-7.5 {interp name collision without -force} -constraints dde -setup {
interp create slave
slave eval [list load $::ddelib Dde]
slave eval [list dde servername -- dde-interp-7.5]
@@ -293,7 +330,7 @@ test winDde-7.5 {interp name collision without -force} -constraints {win dde} -s
# -------------------------------------------------------------------------
-test winDde-8.1 {Safe DDE load} -constraints {win dde} -setup {
+test winDde-8.1 {Safe DDE load} -constraints dde -setup {
interp create -safe slave
slave invokehidden load $::ddelib Dde
} -body {
@@ -301,20 +338,20 @@ test winDde-8.1 {Safe DDE load} -constraints {win dde} -setup {
} -cleanup {
interp delete slave
} -returnCodes error -result {invalid command name "dde"}
-test winDde-8.2 {Safe DDE set servername} -constraints {win dde} -setup {
+test winDde-8.2 {Safe DDE set servername} -constraints dde -setup {
interp create -safe slave
slave invokehidden load $::ddelib Dde
} -body {
slave invokehidden dde servername slave
} -cleanup {interp delete slave} -result {slave}
-test winDde-8.3 {Safe DDE check handler required for eval} -constraints {win dde} -setup {
+test winDde-8.3 {Safe DDE check handler required for eval} -constraints dde -setup {
interp create -safe slave
slave invokehidden load $::ddelib Dde
slave invokehidden dde servername slave
} -body {
catch {dde eval slave set a 1} msg
} -cleanup {interp delete slave} -result {1}
-test winDde-8.4 {Safe DDE check that execute is denied} -constraints {win dde} -setup {
+test winDde-8.4 {Safe DDE check that execute is denied} -constraints dde -setup {
interp create -safe slave
slave invokehidden load $::ddelib Dde
slave invokehidden dde servername slave
@@ -323,7 +360,7 @@ test winDde-8.4 {Safe DDE check that execute is denied} -constraints {win dde} -
dde execute TclEval slave {set a 2}
slave eval set a
} -cleanup {interp delete slave} -result 1
-test winDde-8.5 {Safe DDE check that request is denied} -constraints {win dde} -setup {
+test winDde-8.5 {Safe DDE check that request is denied} -constraints dde -setup {
interp create -safe slave
slave invokehidden load $::ddelib Dde
slave invokehidden dde servername slave
@@ -333,14 +370,14 @@ test winDde-8.5 {Safe DDE check that request is denied} -constraints {win dde} -
} -cleanup {
interp delete slave
} -returnCodes error -result {remote server cannot handle this command}
-test winDde-8.6 {Safe DDE assign handler procedure} -constraints {win dde} -setup {
+test winDde-8.6 {Safe DDE assign handler procedure} -constraints dde -setup {
interp create -safe slave
slave invokehidden load $::ddelib Dde
slave eval {proc DDEACCEPT {cmd} {set ::DDECMD $cmd}}
} -body {
slave invokehidden dde servername -handler DDEACCEPT slave
} -cleanup {interp delete slave} -result slave
-test winDde-8.7 {Safe DDE check simple command} -constraints {win dde} -setup {
+test winDde-8.7 {Safe DDE check simple command} -constraints dde -setup {
interp create -safe slave
slave invokehidden load $::ddelib Dde
slave eval {proc DDEACCEPT {cmd} {set ::DDECMD $cmd}}
@@ -348,7 +385,7 @@ test winDde-8.7 {Safe DDE check simple command} -constraints {win dde} -setup {
} -body {
dde eval slave set x 1
} -cleanup {interp delete slave} -result {set x 1}
-test winDde-8.8 {Safe DDE check non-list command} -constraints {win dde} -setup {
+test winDde-8.8 {Safe DDE check non-list command} -constraints dde -setup {
interp create -safe slave
slave invokehidden load $::ddelib Dde
slave eval {proc DDEACCEPT {cmd} {set ::DDECMD $cmd}}
@@ -358,16 +395,16 @@ test winDde-8.8 {Safe DDE check non-list command} -constraints {win dde} -setup
dde eval slave $s
string equal [slave eval set DDECMD] $s
} -cleanup {interp delete slave} -result 1
-test winDde-8.9 {Safe DDE check command evaluation} -constraints {win dde} -setup {
+test winDde-8.9 {Safe DDE check command evaluation} -constraints dde -setup {
interp create -safe slave
slave invokehidden load $::ddelib Dde
slave eval {proc DDEACCEPT {cmd} {set ::DDECMD [uplevel \#0 $cmd]}}
slave invokehidden dde servername -handler DDEACCEPT slave
} -body {
- dde eval slave set x 1
- slave eval set x
+ dde eval slave set \xe1 1
+ slave eval set \xe1
} -cleanup {interp delete slave} -result 1
-test winDde-8.10 {Safe DDE check command evaluation (2)} -constraints {win dde} -setup {
+test winDde-8.10 {Safe DDE check command evaluation (2)} -constraints dde -setup {
interp create -safe slave
slave invokehidden load $::ddelib Dde
slave eval {proc DDEACCEPT {cmd} {set ::DDECMD [uplevel \#0 $cmd]}}
@@ -376,7 +413,7 @@ test winDde-8.10 {Safe DDE check command evaluation (2)} -constraints {win dde}
dde eval slave [list set x 1]
slave eval set x
} -cleanup {interp delete slave} -result 1
-test winDde-8.11 {Safe DDE check command evaluation (3)} -constraints {win dde} -setup {
+test winDde-8.11 {Safe DDE check command evaluation (3)} -constraints dde -setup {
interp create -safe slave
slave invokehidden load $::ddelib Dde
slave eval {proc DDEACCEPT {cmd} {set ::DDECMD [uplevel \#0 $cmd]}}
@@ -388,9 +425,9 @@ test winDde-8.11 {Safe DDE check command evaluation (3)} -constraints {win dde}
# -------------------------------------------------------------------------
-test winDde-9.1 {External safe DDE check string passing} -constraints {win dde stdio} -setup {
- set name child-9.1
- set child [createChildProcess $name Handler1]
+test winDde-9.1 {External safe DDE check string passing} -constraints {dde stdio} -setup {
+ set name ch\xEDld-9.1
+ set child [createChildProcess $name -handler Handler1]
file copy -force script1.tcl dde-script.tcl
} -body {
dde eval $name set x 1
@@ -401,9 +438,9 @@ test winDde-9.1 {External safe DDE check string passing} -constraints {win dde s
update
file delete -force -- dde-script.tcl
} -result {set x 1}
-test winDde-9.2 {External safe DDE check command evaluation} -constraints {win dde stdio} -setup {
- set name child-9.2
- set child [createChildProcess $name Handler2]
+test winDde-9.2 {External safe DDE check command evaluation} -constraints {dde stdio} -setup {
+ set name ch\xEDld-9.2
+ set child [createChildProcess $name -handler Handler2]
file copy -force script1.tcl dde-script.tcl
} -body {
dde eval $name set x 1
@@ -414,9 +451,9 @@ test winDde-9.2 {External safe DDE check command evaluation} -constraints {win d
update
file delete -force -- dde-script.tcl
} -result 1
-test winDde-9.3 {External safe DDE check prefixed arguments} -constraints {win dde stdio} -setup {
- set name child-9.3
- set child [createChildProcess $name [list Handler3 ARG]]
+test winDde-9.3 {External safe DDE check prefixed arguments} -constraints {dde stdio} -setup {
+ set name ch\xEDld-9.3
+ set child [createChildProcess $name -handler [list Handler3 ARG]]
file copy -force script1.tcl dde-script.tcl
} -body {
dde eval $name set x 1
@@ -427,6 +464,19 @@ test winDde-9.3 {External safe DDE check prefixed arguments} -constraints {win d
update
file delete -force -- dde-script.tcl
} -result {ARG {set x 1}}
+test winDde-9.4 {External safe DDE check null data passing} -constraints {dde stdio} -setup {
+ set name ch\xEDld-9.4
+ set child [createChildProcess $name -handler Handler1]
+ file copy -force script1.tcl dde-script.tcl
+} -body {
+ dde execute TclEval $name ""
+ gets $child line
+ set line
+} -cleanup {
+ dde execute TclEval $name stop
+ update
+ file delete -force -- dde-script.tcl
+} -result {null data}
# -------------------------------------------------------------------------
diff --git a/win/Makefile.in b/win/Makefile.in
index 6d1ce95..7fc415d 100644
--- a/win/Makefile.in
+++ b/win/Makefile.in
@@ -498,7 +498,7 @@ tclWinReg.${OBJEXT} : tclWinReg.c
$(CC) -c $(CC_SWITCHES) -DUNICODE -D_UNICODE -DUSE_TCL_STUBS @DEPARG@ $(CC_OBJNAME)
tclWinDde.${OBJEXT} : tclWinDde.c
- $(CC) -c $(CC_SWITCHES) -DUSE_TCL_STUBS @DEPARG@ $(CC_OBJNAME)
+ $(CC) -c $(CC_SWITCHES) -DUNICODE -D_UNICODE -DUSE_TCL_STUBS @DEPARG@ $(CC_OBJNAME)
# TIP #59, embedding of configuration information into the binary library.
#
@@ -709,13 +709,13 @@ install-private-headers: libraries
test: binaries $(TCLTEST)
TCL_LIBRARY="$(LIBRARY_DIR)"; export TCL_LIBRARY; \
./$(TCLTEST) "$(ROOT_DIR_NATIVE)/tests/all.tcl" $(TESTFLAGS) \
- -load "package ifneeded dde 1.3.3 [list load [file normalize ${DDE_DLL_FILE}] dde]; \
+ -load "package ifneeded dde 1.4.1 [list load [file normalize ${DDE_DLL_FILE}] dde]; \
package ifneeded registry 1.3.3 [list load [file normalize ${REG_DLL_FILE}] registry]" | ./$(CAT32)
# Useful target to launch a built tcltest with the proper path,...
runtest: binaries $(TCLTEST)
@TCL_LIBRARY="$(LIBRARY_DIR)"; export TCL_LIBRARY; \
- ./$(TCLTEST) $(TESTFLAGS) -load "package ifneeded dde 1.3.3 [list load [file normalize ${DDE_DLL_FILE}] dde]; \
+ ./$(TCLTEST) $(TESTFLAGS) -load "package ifneeded dde 1.4.1 [list load [file normalize ${DDE_DLL_FILE}] dde]; \
package ifneeded registry 1.3.3 [list load [file normalize ${REG_DLL_FILE}] registry]" $(SCRIPT)
# This target can be used to run tclsh from the build directory via
diff --git a/win/configure b/win/configure
index 3fe89bf..3a77f00 100755
--- a/win/configure
+++ b/win/configure
@@ -1314,14 +1314,14 @@ TCL_MINOR_VERSION=5
TCL_PATCH_LEVEL=".19"
VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION
-TCL_DDE_VERSION=1.3
+TCL_DDE_VERSION=1.4
TCL_DDE_MAJOR_VERSION=1
-TCL_DDE_MINOR_VERSION=3
+TCL_DDE_MINOR_VERSION=4
DDEVER=$TCL_DDE_MAJOR_VERSION$TCL_DDE_MINOR_VERSION
-TCL_REG_VERSION=1.2
+TCL_REG_VERSION=1.3
TCL_REG_MAJOR_VERSION=1
-TCL_REG_MINOR_VERSION=2
+TCL_REG_MINOR_VERSION=3
REGVER=$TCL_REG_MAJOR_VERSION$TCL_REG_MINOR_VERSION
#------------------------------------------------------------------------
diff --git a/win/configure.in b/win/configure.in
index fa75e5b..12c81ed 100644
--- a/win/configure.in
+++ b/win/configure.in
@@ -17,9 +17,9 @@ TCL_MINOR_VERSION=5
TCL_PATCH_LEVEL=".19"
VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION
-TCL_DDE_VERSION=1.3
+TCL_DDE_VERSION=1.4
TCL_DDE_MAJOR_VERSION=1
-TCL_DDE_MINOR_VERSION=3
+TCL_DDE_MINOR_VERSION=4
DDEVER=$TCL_DDE_MAJOR_VERSION$TCL_DDE_MINOR_VERSION
TCL_REG_VERSION=1.3
diff --git a/win/makefile.bc b/win/makefile.bc
index 20d89bc..577c865 100644
--- a/win/makefile.bc
+++ b/win/makefile.bc
@@ -127,8 +127,8 @@ STUBPREFIX = $(NAMEPREFIX)stub
DOTVERSION = 8.5
VERSION = 85
-DDEVERSION = 13
-DDEDOTVERSION = 1.3
+DDEVERSION = 14
+DDEDOTVERSION = 1.4
REGVERSION = 13
REGDOTVERSION = 1.3
diff --git a/win/makefile.vc b/win/makefile.vc
index c330fcd..62a4d67 100644
--- a/win/makefile.vc
+++ b/win/makefile.vc
@@ -538,13 +538,13 @@ test-core: setup $(TCLTEST) dlls $(CAT32)
set TCL_LIBRARY=$(ROOT:\=/)/library
!if "$(OS)" == "Windows_NT" || "$(MSVCDIR)" == "IDE"
$(DEBUGGER) $(TCLTEST) "$(ROOT:\=/)/tests/all.tcl" $(TESTFLAGS) -loadfile <<
- package ifneeded dde 1.3.3 [list load "$(TCLDDELIB:\=/)" dde]
+ package ifneeded dde 1.4.1 [list load "$(TCLDDELIB:\=/)" dde]
package ifneeded registry 1.3.3 [list load "$(TCLREGLIB:\=/)" registry]
<<
!else
@echo Please wait while the tests are collected...
$(TCLTEST) "$(ROOT:\=/)/tests/all.tcl" $(TESTFLAGS) -loadfile << > tests.log
- package ifneeded dde 1.3.3 "$(TCLDDELIB:\=/)" dde]
+ package ifneeded dde 1.4.1 "$(TCLDDELIB:\=/)" dde]
package ifneeded registry 1.3.3 "$(TCLREGLIB:\=/)" registry]
<<
type tests.log | more
diff --git a/win/tclWinDde.c b/win/tclWinDde.c
index eef5caa..38f1d88 100644
--- a/win/tclWinDde.c
+++ b/win/tclWinDde.c
@@ -10,20 +10,20 @@
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
+#undef STATIC_BUILD
+#ifndef USE_TCL_STUBS
+# define USE_TCL_STUBS
+#endif
#include "tclInt.h"
-#include "tclPort.h"
#include <dde.h>
#include <ddeml.h>
+#include <tchar.h>
-/*
- * TCL_STORAGE_CLASS is set unconditionally to DLLEXPORT because the Dde_Init
- * declaration is in the source file itself, which is only accessed when we
- * are building a library. DO NOT MOVE BEFORE ANY #include LINES. ONLY USE
- * EXTERN TO INDICATE EXPORTED FUNCTIONS FROM NOW ON.
- */
-
-#undef TCL_STORAGE_CLASS
-#define TCL_STORAGE_CLASS DLLEXPORT
+#if !defined(NDEBUG)
+ /* test POKE server Implemented for debug mode only */
+# undef CBF_FAIL_POKES
+# define CBF_FAIL_POKES 0
+#endif
/*
* The following structure is used to keep track of the interpreters
@@ -34,7 +34,7 @@ typedef struct RegisteredInterp {
struct RegisteredInterp *nextPtr;
/* The next interp this application knows
* about. */
- char *name; /* Interpreter's name (malloc-ed). */
+ TCHAR *name; /* Interpreter's name (malloc-ed). */
Tcl_Obj *handlerPtr; /* The server handler command */
Tcl_Interp *interp; /* The interpreter attached to this name. */
} RegisteredInterp;
@@ -51,7 +51,7 @@ typedef struct Conversation {
Tcl_Obj *returnPackagePtr; /* The result package for this conversation. */
} Conversation;
-typedef struct DdeEnumServices {
+typedef struct {
Tcl_Interp *interp;
int result;
ATOM service;
@@ -59,7 +59,7 @@ typedef struct DdeEnumServices {
HWND hwnd;
} DdeEnumServices;
-typedef struct ThreadSpecificData {
+typedef struct {
Conversation *currentConversations;
/* A list of conversations currently being
* processed. */
@@ -79,9 +79,10 @@ static DWORD ddeInstance; /* The application instance handle given to us
* by DdeInitialize. */
static int ddeIsServer = 0;
+#define TCL_DDE_VERSION "1.4.1"
#define TCL_DDE_PACKAGE_NAME "dde"
-#define TCL_DDE_SERVICE_NAME "TclEval"
-#define TCL_DDE_EXECUTE_RESULT "$TCLEVAL$EXECUTE$RESULT"
+#define TCL_DDE_SERVICE_NAME TEXT("TclEval")
+#define TCL_DDE_EXECUTE_RESULT TEXT("$TCLEVAL$EXECUTE$RESULT")
#define DDE_FLAG_ASYNC 1
#define DDE_FLAG_BINARY 2
@@ -95,12 +96,12 @@ TCL_DECLARE_MUTEX(ddeMutex)
static LRESULT CALLBACK DdeClientWindowProc(HWND hwnd, UINT uMsg,
WPARAM wParam, LPARAM lParam);
-static int DdeCreateClient(struct DdeEnumServices *es);
+static int DdeCreateClient(DdeEnumServices *es);
static BOOL CALLBACK DdeEnumWindowsCallback(HWND hwndTarget,
LPARAM lParam);
static void DdeExitProc(ClientData clientData);
static int DdeGetServicesList(Tcl_Interp *interp,
- const char *serviceName, const char *topicName);
+ const TCHAR *serviceName, const TCHAR *topicName);
static HDDEDATA CALLBACK DdeServerProc(UINT uType, UINT uFmt, HCONV hConv,
HSZ ddeTopic, HSZ ddeItem, HDDEDATA hData,
DWORD dwData1, DWORD dwData2);
@@ -110,14 +111,15 @@ static void DeleteProc(ClientData clientData);
static Tcl_Obj * ExecuteRemoteObject(RegisteredInterp *riPtr,
Tcl_Obj *ddeObjectPtr);
static int MakeDdeConnection(Tcl_Interp *interp,
- const char *name, HCONV *ddeConvPtr);
+ const TCHAR *name, HCONV *ddeConvPtr);
static void SetDdeError(Tcl_Interp *interp);
static int DdeObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
-EXTERN int Dde_Init(Tcl_Interp *interp);
-EXTERN int Dde_SafeInit(Tcl_Interp *interp);
+
+DLLEXPORT int Dde_Init(Tcl_Interp *interp);
+DLLEXPORT int Dde_SafeInit(Tcl_Interp *interp);
/*
*----------------------------------------------------------------------
@@ -145,7 +147,7 @@ Dde_Init(
Tcl_CreateObjCommand(interp, "dde", DdeObjCmd, NULL, NULL);
Tcl_CreateExitHandler(DdeExitProc, NULL);
- return Tcl_PkgProvide(interp, TCL_DDE_PACKAGE_NAME, "1.3.3");
+ return Tcl_PkgProvide(interp, TCL_DDE_PACKAGE_NAME, TCL_DDE_VERSION);
}
/*
@@ -229,7 +231,7 @@ Initialize(void)
ddeIsServer = 1;
Tcl_CreateExitHandler(DdeExitProc, NULL);
ddeServiceGlobal = DdeCreateStringHandle(ddeInstance,
- TCL_DDE_SERVICE_NAME, 0);
+ TCL_DDE_SERVICE_NAME, CP_WINUNICODE);
DdeNameService(ddeInstance, ddeServiceGlobal, 0L, DNS_REGISTER);
} else {
ddeIsServer = 0;
@@ -263,10 +265,10 @@ Initialize(void)
*----------------------------------------------------------------------
*/
-static const char *
+static const TCHAR *
DdeSetServerName(
Tcl_Interp *interp,
- const char *name, /* The name that will be used to refer to the
+ const TCHAR *name, /* The name that will be used to refer to the
* interpreter in later "send" commands. Must
* be globally unique. */
int flags, /* DDE_FLAG_FORCE or 0 */
@@ -276,7 +278,7 @@ DdeSetServerName(
int suffix, offset;
RegisteredInterp *riPtr, *prevPtr;
Tcl_DString dString;
- const char *actualName;
+ const TCHAR *actualName;
Tcl_Obj *srvListPtr = NULL, **srvPtrPtr = NULL;
int n, srvCount = 0, lastSuffix, r = TCL_OK;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
@@ -314,7 +316,7 @@ DdeSetServerName(
* current interp, but it doesn't have a name.
*/
- return "";
+ return TEXT("");
}
/*
@@ -335,7 +337,9 @@ DdeSetServerName(
&srvPtrPtr);
}
if (r != TCL_OK) {
- OutputDebugString(Tcl_GetStringResult(interp));
+ Tcl_WinUtfToTChar(Tcl_GetStringResult(interp), -1, &dString);
+ OutputDebugString((TCHAR *) Tcl_DStringValue(&dString));
+ Tcl_DStringFree(&dString);
return NULL;
}
@@ -352,13 +356,14 @@ DdeSetServerName(
lastSuffix = suffix;
if (suffix > 1) {
if (suffix == 2) {
- Tcl_DStringAppend(&dString, name, -1);
- Tcl_DStringAppend(&dString, " #", 2);
+ Tcl_DStringAppend(&dString, (char *)name, _tcslen(name) * sizeof(TCHAR));
+ Tcl_DStringAppend(&dString, (char *)TEXT(" #"), 2 * sizeof(TCHAR));
offset = Tcl_DStringLength(&dString);
- Tcl_DStringSetLength(&dString, offset + TCL_INTEGER_SPACE);
- actualName = Tcl_DStringValue(&dString);
+ Tcl_DStringSetLength(&dString, offset + sizeof(TCHAR) * TCL_INTEGER_SPACE);
+ actualName = (TCHAR *) Tcl_DStringValue(&dString);
}
- sprintf(Tcl_DStringValue(&dString) + offset, "%d", suffix);
+ _sntprintf((TCHAR *) (Tcl_DStringValue(&dString) + offset),
+ TCL_INTEGER_SPACE, TEXT("%d"), suffix);
}
/*
@@ -367,39 +372,41 @@ DdeSetServerName(
for (n = 0; n < srvCount; ++n) {
Tcl_Obj* namePtr;
+ Tcl_DString ds;
Tcl_ListObjIndex(interp, srvPtrPtr[n], 1, &namePtr);
- if (strcmp(actualName, Tcl_GetString(namePtr)) == 0) {
+ Tcl_WinUtfToTChar(Tcl_GetString(namePtr), -1, &ds);
+ if (_tcscmp(actualName, (TCHAR *)Tcl_DStringValue(&ds)) == 0) {
suffix++;
+ Tcl_DStringFree(&ds);
break;
}
+ Tcl_DStringFree(&ds);
}
}
- Tcl_DStringSetLength(&dString,
- offset + (int)strlen(Tcl_DStringValue(&dString)+offset));
}
/*
* We have found a unique name. Now add it to the registry.
*/
- riPtr = (RegisteredInterp *) ckalloc(sizeof(RegisteredInterp));
+ riPtr = (RegisteredInterp *) Tcl_Alloc(sizeof(RegisteredInterp));
riPtr->interp = interp;
- riPtr->name = ckalloc((unsigned int) strlen(actualName) + 1);
+ riPtr->name = (TCHAR *) Tcl_Alloc((_tcslen(actualName) + 1) * sizeof(TCHAR));
riPtr->nextPtr = tsdPtr->interpListPtr;
riPtr->handlerPtr = handlerPtr;
if (riPtr->handlerPtr != NULL) {
Tcl_IncrRefCount(riPtr->handlerPtr);
}
tsdPtr->interpListPtr = riPtr;
- strcpy(riPtr->name, actualName);
+ _tcscpy(riPtr->name, actualName);
if (Tcl_IsSafe(interp)) {
Tcl_ExposeCommand(interp, "dde", "dde");
}
Tcl_CreateObjCommand(interp, "dde", DdeObjCmd,
- (ClientData) riPtr, DeleteProc);
+ riPtr, DeleteProc);
if (Tcl_IsSafe(interp)) {
Tcl_HideCommand(interp, "dde", "dde");
}
@@ -486,7 +493,7 @@ DeleteProc(
prevPtr->nextPtr = searchPtr->nextPtr;
}
}
- ckfree(riPtr->name);
+ Tcl_Free((char *) riPtr->name);
if (riPtr->handlerPtr) {
Tcl_DecrRefCount(riPtr->handlerPtr);
}
@@ -524,10 +531,11 @@ ExecuteRemoteObject(
Tcl_Obj *returnPackagePtr;
int result = TCL_OK;
- if (riPtr->handlerPtr == NULL && Tcl_IsSafe(riPtr->interp)) {
+ if ((riPtr->handlerPtr == NULL) && Tcl_IsSafe(riPtr->interp)) {
Tcl_SetObjResult(riPtr->interp, Tcl_NewStringObj("permission denied: "
"a handler procedure must be defined for use in a safe "
"interp", -1));
+ Tcl_SetErrorCode(riPtr->interp, "TCL", "DDE", "SECURITY_CHECK", NULL);
result = TCL_ERROR;
}
@@ -605,9 +613,9 @@ DdeServerProc(
/* Transaction-dependent data. */
{
Tcl_DString dString;
- int len;
+ size_t len;
DWORD dlen;
- char *utilString;
+ TCHAR *utilString;
Tcl_Obj *ddeObjectPtr;
HDDEDATA ddeReturn = NULL;
RegisteredInterp *riPtr;
@@ -621,16 +629,16 @@ DdeServerProc(
* sure we have a valid topic.
*/
- len = DdeQueryString(ddeInstance, ddeTopic, NULL, 0, 0);
+ len = DdeQueryString(ddeInstance, ddeTopic, NULL, 0, CP_WINUNICODE);
Tcl_DStringInit(&dString);
- Tcl_DStringSetLength(&dString, len);
- utilString = Tcl_DStringValue(&dString);
+ Tcl_DStringSetLength(&dString, (len + 1) * sizeof(TCHAR) - 1);
+ utilString = (TCHAR *) Tcl_DStringValue(&dString);
DdeQueryString(ddeInstance, ddeTopic, utilString, (DWORD) len + 1,
- CP_WINANSI);
+ CP_WINUNICODE);
for (riPtr = tsdPtr->interpListPtr; riPtr != NULL;
riPtr = riPtr->nextPtr) {
- if (stricmp(utilString, riPtr->name) == 0) {
+ if (_tcsicmp(utilString, riPtr->name) == 0) {
Tcl_DStringFree(&dString);
return (HDDEDATA) TRUE;
}
@@ -646,16 +654,16 @@ DdeServerProc(
* result to return in an XTYP_REQUEST.
*/
- len = DdeQueryString(ddeInstance, ddeTopic, NULL, 0, 0);
+ len = DdeQueryString(ddeInstance, ddeTopic, NULL, 0, CP_WINUNICODE);
Tcl_DStringInit(&dString);
- Tcl_DStringSetLength(&dString, len);
- utilString = Tcl_DStringValue(&dString);
+ Tcl_DStringSetLength(&dString, (len + 1) * sizeof(TCHAR) - 1);
+ utilString = (TCHAR *) Tcl_DStringValue(&dString);
DdeQueryString(ddeInstance, ddeTopic, utilString, (DWORD) len + 1,
- CP_WINANSI);
+ CP_WINUNICODE);
for (riPtr = tsdPtr->interpListPtr; riPtr != NULL;
riPtr = riPtr->nextPtr) {
- if (stricmp(riPtr->name, utilString) == 0) {
- convPtr = (Conversation *) ckalloc(sizeof(Conversation));
+ if (_tcsicmp(riPtr->name, utilString) == 0) {
+ convPtr = (Conversation *) Tcl_Alloc(sizeof(Conversation));
convPtr->nextPtr = tsdPtr->currentConversations;
convPtr->returnPackagePtr = NULL;
convPtr->hConv = hConv;
@@ -685,7 +693,7 @@ DdeServerProc(
if (convPtr->returnPackagePtr != NULL) {
Tcl_DecrRefCount(convPtr->returnPackagePtr);
}
- ckfree((char *) convPtr);
+ Tcl_Free((char *) convPtr);
break;
}
}
@@ -711,22 +719,24 @@ DdeServerProc(
}
if (convPtr != NULL) {
+ Tcl_DString dsBuf;
char *returnString;
- len = DdeQueryString(ddeInstance, ddeItem, NULL, 0, CP_WINANSI);
+ len = DdeQueryString(ddeInstance, ddeItem, NULL, 0, CP_WINUNICODE);
Tcl_DStringInit(&dString);
- Tcl_DStringSetLength(&dString, len);
- utilString = Tcl_DStringValue(&dString);
+ Tcl_DStringInit(&dsBuf);
+ Tcl_DStringSetLength(&dString, (len + 1) * sizeof(TCHAR) - 1);
+ utilString = (TCHAR *) Tcl_DStringValue(&dString);
DdeQueryString(ddeInstance, ddeItem, utilString, (DWORD) len + 1,
- CP_WINANSI);
- if (stricmp(utilString, TCL_DDE_EXECUTE_RESULT) == 0) {
- if (uFmt == CF_TEXT) {
- returnString =
- Tcl_GetStringFromObj(convPtr->returnPackagePtr, &len);
- } else {
- returnString = (char *)
- Tcl_GetUnicodeFromObj(convPtr->returnPackagePtr, &len);
- len = 2 * len + 1;
+ CP_WINUNICODE);
+ if (_tcsicmp(utilString, TCL_DDE_EXECUTE_RESULT) == 0) {
+ returnString =
+ Tcl_GetString(convPtr->returnPackagePtr);
+ len = convPtr->returnPackagePtr->length;
+ if (uFmt != CF_TEXT) {
+ Tcl_WinUtfToTChar(returnString, len, &dsBuf);
+ returnString = Tcl_DStringValue(&dsBuf);
+ len = Tcl_DStringLength(&dsBuf) + sizeof(TCHAR) - 1;
}
ddeReturn = DdeCreateDataHandle(ddeInstance, (BYTE *)returnString,
(DWORD) len+1, 0, ddeItem, uFmt, 0);
@@ -734,17 +744,20 @@ DdeServerProc(
if (Tcl_IsSafe(convPtr->riPtr->interp)) {
ddeReturn = NULL;
} else {
- Tcl_Obj *variableObjPtr = Tcl_GetVar2Ex(
- convPtr->riPtr->interp, utilString, NULL,
+ Tcl_DString ds;
+ Tcl_Obj *variableObjPtr;
+
+ Tcl_WinTCharToUtf(utilString, -1, &ds);
+ variableObjPtr = Tcl_GetVar2Ex(
+ convPtr->riPtr->interp, Tcl_DStringValue(&ds), NULL,
TCL_GLOBAL_ONLY);
if (variableObjPtr != NULL) {
- if (uFmt == CF_TEXT) {
- returnString = Tcl_GetStringFromObj(
- variableObjPtr, &len);
- } else {
- returnString = (char *) Tcl_GetUnicodeFromObj(
- variableObjPtr, &len);
- len = 2 * len + 1;
+ returnString = Tcl_GetString(variableObjPtr);
+ len = variableObjPtr->length;
+ if (uFmt != CF_TEXT) {
+ Tcl_WinUtfToTChar(returnString, len, &dsBuf);
+ returnString = Tcl_DStringValue(&dsBuf);
+ len = Tcl_DStringLength(&dsBuf) + sizeof(TCHAR) - 1;
}
ddeReturn = DdeCreateDataHandle(ddeInstance,
(BYTE *)returnString, (DWORD) len+1, 0, ddeItem,
@@ -752,12 +765,65 @@ DdeServerProc(
} else {
ddeReturn = NULL;
}
+ Tcl_DStringFree(&ds);
}
}
+ Tcl_DStringFree(&dsBuf);
+ Tcl_DStringFree(&dString);
+ }
+ return ddeReturn;
+
+#if !CBF_FAIL_POKES
+ case XTYP_POKE:
+ /*
+ * This is a poke for a Tcl variable, only implemented in
+ * debug/UNICODE mode.
+ */
+ ddeReturn = DDE_FNOTPROCESSED;
+
+ if ((uFmt != CF_TEXT) && (uFmt != CF_UNICODETEXT)) {
+ return ddeReturn;
+ }
+
+ for (convPtr = tsdPtr->currentConversations; (convPtr != NULL)
+ && (convPtr->hConv != hConv); convPtr = convPtr->nextPtr) {
+ /*
+ * Empty loop body.
+ */
+ }
+
+ if (convPtr && !Tcl_IsSafe(convPtr->riPtr->interp)) {
+ Tcl_DString ds, ds2;
+ Tcl_Obj *variableObjPtr;
+ DWORD len2;
+
+ Tcl_DStringInit(&dString);
+ Tcl_DStringInit(&ds2);
+ len = DdeQueryString(ddeInstance, ddeItem, NULL, 0, CP_WINUNICODE);
+ Tcl_DStringSetLength(&dString, (len + 1) * sizeof(TCHAR) - 1);
+ utilString = (TCHAR *) Tcl_DStringValue(&dString);
+ DdeQueryString(ddeInstance, ddeItem, utilString, (DWORD) len + 1,
+ CP_WINUNICODE);
+ Tcl_WinTCharToUtf(utilString, -1, &ds);
+ utilString = (TCHAR *) DdeAccessData(hData, &len2);
+ len = len2;
+ if (uFmt != CF_TEXT) {
+ Tcl_WinTCharToUtf(utilString, -1, &ds2);
+ utilString = (TCHAR *) Tcl_DStringValue(&ds2);
+ }
+ variableObjPtr = Tcl_NewStringObj((char *)utilString, -1);
+
+ Tcl_SetVar2Ex(convPtr->riPtr->interp, Tcl_DStringValue(&ds), NULL,
+ variableObjPtr, TCL_GLOBAL_ONLY);
+
+ Tcl_DStringFree(&ds2);
+ Tcl_DStringFree(&ds);
Tcl_DStringFree(&dString);
+ ddeReturn = (HDDEDATA) DDE_FACK;
}
return ddeReturn;
+#endif
case XTYP_EXECUTE: {
/*
* Execute this script. The results will be saved into a list object
@@ -765,7 +831,7 @@ DdeServerProc(
*/
Tcl_Obj *returnPackagePtr;
- Tcl_UniChar *uniStr;
+ char *string;
for (convPtr = tsdPtr->currentConversations; (convPtr != NULL)
&& (convPtr->hConv != hConv); convPtr = convPtr->nextPtr) {
@@ -778,21 +844,25 @@ DdeServerProc(
return (HDDEDATA) DDE_FNOTPROCESSED;
}
- utilString = (char *) DdeAccessData(hData, &dlen);
- uniStr = (Tcl_UniChar *) utilString;
+ utilString = (TCHAR *) DdeAccessData(hData, &dlen);
+ string = (char *) utilString;
if (!dlen) {
/* Empty binary array. */
ddeObjectPtr = Tcl_NewObj();
- } else if ((dlen & 1) || uniStr[(dlen>>1)-1]) {
+ } else if ((dlen & 1) || utilString[(dlen>>1)-1]) {
/* Cannot be unicode, so assume utf-8 */
- if (!utilString[dlen-1]) {
+ if (!string[dlen-1]) {
dlen--;
}
- ddeObjectPtr = Tcl_NewStringObj(utilString, dlen);
+ ddeObjectPtr = Tcl_NewStringObj(string, dlen);
} else {
/* unicode */
- dlen >>= 1;
- ddeObjectPtr = Tcl_NewUnicodeObj(uniStr, dlen - 1);
+ Tcl_DString dsBuf;
+
+ Tcl_WinTCharToUtf(utilString, dlen - sizeof(TCHAR), &dsBuf);
+ ddeObjectPtr = Tcl_NewStringObj(Tcl_DStringValue(&dsBuf),
+ Tcl_DStringLength(&dsBuf));
+ Tcl_DStringFree(&dsBuf);
}
Tcl_IncrRefCount(ddeObjectPtr);
DdeUnaccessData(hData);
@@ -845,9 +915,9 @@ DdeServerProc(
for (i = 0, riPtr = tsdPtr->interpListPtr; i < numItems;
i++, riPtr = riPtr->nextPtr) {
returnPtr[i].hszSvc = DdeCreateStringHandle(ddeInstance,
- TCL_DDE_SERVICE_NAME, CP_WINANSI);
+ TCL_DDE_SERVICE_NAME, CP_WINUNICODE);
returnPtr[i].hszTopic = DdeCreateStringHandle(ddeInstance,
- riPtr->name, CP_WINANSI);
+ riPtr->name, CP_WINUNICODE);
}
returnPtr[i].hszSvc = NULL;
returnPtr[i].hszTopic = NULL;
@@ -905,14 +975,14 @@ DdeExitProc(
static int
MakeDdeConnection(
Tcl_Interp *interp, /* Used to report errors. */
- const char *name, /* The connection to use. */
+ const TCHAR *name, /* The connection to use. */
HCONV *ddeConvPtr)
{
HSZ ddeTopic, ddeService;
HCONV ddeConv;
- ddeService = DdeCreateStringHandle(ddeInstance, TCL_DDE_SERVICE_NAME, 0);
- ddeTopic = DdeCreateStringHandle(ddeInstance, name, 0);
+ ddeService = DdeCreateStringHandle(ddeInstance, TCL_DDE_SERVICE_NAME, CP_WINUNICODE);
+ ddeTopic = DdeCreateStringHandle(ddeInstance, name, CP_WINUNICODE);
ddeConv = DdeConnect(ddeInstance, ddeService, ddeTopic, NULL);
DdeFreeStringHandle(ddeInstance, ddeService);
@@ -920,8 +990,13 @@ MakeDdeConnection(
if (ddeConv == (HCONV) NULL) {
if (interp != NULL) {
- Tcl_AppendResult(interp, "no registered server named \"",
- name, "\"", NULL);
+ Tcl_DString dString;
+
+ Tcl_WinTCharToUtf(name, -1, &dString);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "no registered server named \"%s\"", Tcl_DStringValue(&dString)));
+ Tcl_DStringFree(&dString);
+ Tcl_SetErrorCode(interp, "TCL", "DDE", "NO_SERVER", NULL);
}
return TCL_ERROR;
}
@@ -952,17 +1027,17 @@ MakeDdeConnection(
static int
DdeCreateClient(
- struct DdeEnumServices *es)
+ DdeEnumServices *es)
{
WNDCLASSEX wc;
- static const char *szDdeClientClassName = "TclEval client class";
- static const char *szDdeClientWindowName = "TclEval client window";
+ static const TCHAR *szDdeClientClassName = TEXT("TclEval client class");
+ static const TCHAR *szDdeClientWindowName = TEXT("TclEval client window");
memset(&wc, 0, sizeof(wc));
wc.cbSize = sizeof(wc);
wc.lpfnWndProc = DdeClientWindowProc;
wc.lpszClassName = szDdeClientClassName;
- wc.cbWndExtra = sizeof(struct DdeEnumServices *);
+ wc.cbWndExtra = sizeof(DdeEnumServices *);
/*
* Register and create the callback window.
@@ -984,8 +1059,8 @@ DdeClientWindowProc(
switch (uMsg) {
case WM_CREATE: {
LPCREATESTRUCT lpcs = (LPCREATESTRUCT) lParam;
- struct DdeEnumServices *es =
- (struct DdeEnumServices *) lpcs->lpCreateParams;
+ DdeEnumServices *es =
+ (DdeEnumServices *) lpcs->lpCreateParams;
#ifdef _WIN64
SetWindowLongPtr(hwnd, GWLP_USERDATA, (LONG_PTR) es);
@@ -1010,24 +1085,29 @@ DdeServicesOnAck(
HWND hwndRemote = (HWND)wParam;
ATOM service = (ATOM)LOWORD(lParam);
ATOM topic = (ATOM)HIWORD(lParam);
- struct DdeEnumServices *es;
- char sz[255];
+ DdeEnumServices *es;
+ TCHAR sz[255];
+ Tcl_DString dString;
#ifdef _WIN64
- es = (struct DdeEnumServices *) GetWindowLongPtr(hwnd, GWLP_USERDATA);
+ es = (DdeEnumServices *) GetWindowLongPtr(hwnd, GWLP_USERDATA);
#else
- es = (struct DdeEnumServices *) GetWindowLong(hwnd, GWL_USERDATA);
+ es = (DdeEnumServices *) GetWindowLong(hwnd, GWL_USERDATA);
#endif
- if ((es->service == (ATOM)0 || es->service == service)
- && (es->topic == (ATOM)0 || es->topic == topic)) {
+ if (((es->service == (ATOM)0) || (es->service == service))
+ && ((es->topic == (ATOM)0) || (es->topic == topic))) {
Tcl_Obj *matchPtr = Tcl_NewListObj(0, NULL);
Tcl_Obj *resultPtr = Tcl_GetObjResult(es->interp);
GlobalGetAtomName(service, sz, 255);
- Tcl_ListObjAppendElement(NULL, matchPtr, Tcl_NewStringObj(sz, -1));
+ Tcl_WinTCharToUtf(sz, -1, &dString);
+ Tcl_ListObjAppendElement(NULL, matchPtr, Tcl_NewStringObj(Tcl_DStringValue(&dString), -1));
+ Tcl_DStringFree(&dString);
GlobalGetAtomName(topic, sz, 255);
- Tcl_ListObjAppendElement(NULL, matchPtr, Tcl_NewStringObj(sz, -1));
+ Tcl_WinTCharToUtf(sz, -1, &dString);
+ Tcl_ListObjAppendElement(NULL, matchPtr, Tcl_NewStringObj(Tcl_DStringValue(&dString), -1));
+ Tcl_DStringFree(&dString);
/*
* Adding the hwnd as a third list element provides a unique
@@ -1063,7 +1143,7 @@ DdeEnumWindowsCallback(
LPARAM lParam)
{
DWORD_PTR dwResult = 0;
- struct DdeEnumServices *es = (struct DdeEnumServices *) lParam;
+ DdeEnumServices *es = (DdeEnumServices *) lParam;
SendMessageTimeout(hwndTarget, WM_DDE_INITIATE, (WPARAM)es->hwnd,
MAKELONG(es->service, es->topic), SMTO_ABORTIFHUNG, 1000,
@@ -1074,10 +1154,10 @@ DdeEnumWindowsCallback(
static int
DdeGetServicesList(
Tcl_Interp *interp,
- const char *serviceName,
- const char *topicName)
+ const TCHAR *serviceName,
+ const TCHAR *topicName)
{
- struct DdeEnumServices es;
+ DdeEnumServices es;
es.interp = interp;
es.result = TCL_OK;
@@ -1122,25 +1202,30 @@ static void
SetDdeError(
Tcl_Interp *interp) /* The interp to put the message in. */
{
- const char *errorMessage;
+ const char *errorMessage, *errorCode;
switch (DdeGetLastError(ddeInstance)) {
case DMLERR_DATAACKTIMEOUT:
case DMLERR_EXECACKTIMEOUT:
case DMLERR_POKEACKTIMEOUT:
errorMessage = "remote interpreter did not respond";
+ errorCode = "TIMEOUT";
break;
case DMLERR_BUSY:
errorMessage = "remote server is busy";
+ errorCode = "BUSY";
break;
case DMLERR_NOTPROCESSED:
errorMessage = "remote server cannot handle this command";
+ errorCode = "NOCANDO";
break;
default:
errorMessage = "dde command failed";
+ errorCode = "FAILED";
}
Tcl_SetObjResult(interp, Tcl_NewStringObj(errorMessage, -1));
+ Tcl_SetErrorCode(interp, "TCL", "DDE", errorCode, NULL);
}
/*
@@ -1167,34 +1252,43 @@ DdeObjCmd(
int objc, /* Number of arguments */
Tcl_Obj *const *objv) /* The arguments */
{
- static const char *ddeCommands[] = {
+ static const char *const ddeCommands[] = {
"servername", "execute", "poke", "request", "services", "eval",
(char *) NULL};
enum DdeSubcommands {
DDE_SERVERNAME, DDE_EXECUTE, DDE_POKE, DDE_REQUEST, DDE_SERVICES,
DDE_EVAL
};
- static const char *ddeSrvOptions[] = {
+ static const char *const ddeSrvOptions[] = {
"-force", "-handler", "--", NULL
};
enum DdeSrvOptions {
DDE_SERVERNAME_EXACT, DDE_SERVERNAME_HANDLER, DDE_SERVERNAME_LAST,
};
- static const char *ddeExecOptions[] = {
+ static const char *const ddeExecOptions[] = {
+ "-async", "-binary", NULL
+ };
+ enum DdeExecOptions {
+ DDE_EXEC_ASYNC, DDE_EXEC_BINARY
+ };
+ static const char *const ddeEvalOptions[] = {
"-async", NULL
};
- static const char *ddeReqOptions[] = {
+ static const char *const ddeReqOptions[] = {
"-binary", NULL
};
- int index, i, length, argIndex;
+ int index, i, argIndex;
+ int length;
int flags = 0, result = TCL_OK, firstArg = 0;
HSZ ddeService = NULL, ddeTopic = NULL, ddeItem = NULL, ddeCookie = NULL;
HDDEDATA ddeData = NULL, ddeItemData = NULL, ddeReturn;
HCONV hConv = NULL;
- const char *serviceName = NULL, *topicName = NULL, *string;
+ const TCHAR *serviceName = NULL, *topicName = NULL;
+ const char *string;
DWORD ddeResult;
Tcl_Obj *objPtr, *handlerPtr = NULL;
+ Tcl_DString serviceBuf, topicBuf, itemBuf;
/*
* Initialize DDE server/client
@@ -1210,6 +1304,9 @@ DdeObjCmd(
return TCL_ERROR;
}
+ Tcl_DStringInit(&serviceBuf);
+ Tcl_DStringInit(&topicBuf);
+ Tcl_DStringInit(&itemBuf);
switch ((enum DdeSubcommands) index) {
case DDE_SERVERNAME:
for (i = 2; i < objc; i++) {
@@ -1259,38 +1356,53 @@ DdeObjCmd(
if (objc == 5) {
firstArg = 2;
break;
- } else if (objc == 6) {
- if (Tcl_GetIndexFromObj(NULL, objv[2], ddeExecOptions, "option", 0,
- &argIndex) == TCL_OK) {
- flags |= DDE_FLAG_ASYNC;
- firstArg = 3;
- break;
+ } else if ((objc >= 6) && (objc <= 7)) {
+ firstArg = objc - 3;
+ for (i = 2; i < firstArg; i++) {
+ if (Tcl_GetIndexFromObj(interp, objv[i], ddeExecOptions,
+ "option", 0, &argIndex) != TCL_OK) {
+ goto wrongDdeExecuteArgs;
+ }
+ if (argIndex == DDE_EXEC_ASYNC) {
+ flags |= DDE_FLAG_ASYNC;
+ } else {
+ flags |= DDE_FLAG_BINARY;
+ }
}
+ break;
}
/* otherwise... */
+ wrongDdeExecuteArgs:
Tcl_WrongNumArgs(interp, 2, objv,
- "?-async? serviceName topicName value");
+ "?-async? ?-binary? serviceName topicName value");
return TCL_ERROR;
case DDE_POKE:
- if (objc != 6) {
- Tcl_WrongNumArgs(interp, 2, objv,
- "serviceName topicName item value");
- return TCL_ERROR;
+ if (objc == 6) {
+ firstArg = 2;
+ break;
+ } else if ((objc == 7) && (Tcl_GetIndexFromObj(NULL, objv[2],
+ ddeReqOptions, "option", 0, &argIndex) == TCL_OK)) {
+ flags |= DDE_FLAG_BINARY;
+ firstArg = 3;
+ break;
}
- firstArg = 2;
- break;
+
+ /*
+ * Otherwise...
+ */
+
+ Tcl_WrongNumArgs(interp, 2, objv,
+ "?-binary? serviceName topicName item value");
+ return TCL_ERROR;
case DDE_REQUEST:
if (objc == 5) {
firstArg = 2;
break;
- } else if (objc == 6) {
- int dummy;
- if (Tcl_GetIndexFromObj(NULL, objv[2], ddeReqOptions, "option", 0,
- &dummy) == TCL_OK) {
- flags |= DDE_FLAG_BINARY;
- firstArg = 3;
- break;
- }
+ } else if ((objc == 6) && (Tcl_GetIndexFromObj(NULL, objv[2],
+ ddeReqOptions, "option", 0, &argIndex) == TCL_OK)) {
+ flags |= DDE_FLAG_BINARY;
+ firstArg = 3;
+ break;
}
/*
@@ -1314,7 +1426,7 @@ DdeObjCmd(
return TCL_ERROR;
} else {
firstArg = 2;
- if (Tcl_GetIndexFromObj(NULL, objv[2], ddeExecOptions, "option",
+ if (Tcl_GetIndexFromObj(NULL, objv[2], ddeEvalOptions, "option",
0, &argIndex) == TCL_OK) {
if (objc < 5) {
goto wrongDdeEvalArgs;
@@ -1329,7 +1441,12 @@ DdeObjCmd(
Initialize();
if (firstArg != 1) {
- serviceName = Tcl_GetStringFromObj(objv[firstArg], &length);
+ const char *src = Tcl_GetString(objv[firstArg]);
+
+ length = objv[firstArg]->length;
+ Tcl_WinUtfToTChar(src, length, &serviceBuf);
+ serviceName = (TCHAR *) Tcl_DStringValue(&serviceBuf);
+ length = Tcl_DStringLength(&serviceBuf) / sizeof(TCHAR);
} else {
length = 0;
}
@@ -1338,16 +1455,20 @@ DdeObjCmd(
serviceName = NULL;
} else if ((index != DDE_SERVERNAME) && (index != DDE_EVAL)) {
ddeService = DdeCreateStringHandle(ddeInstance, (void *) serviceName,
- CP_WINANSI);
+ CP_WINUNICODE);
}
if ((index != DDE_SERVERNAME) && (index != DDE_EVAL)) {
- topicName = Tcl_GetStringFromObj(objv[firstArg + 1], &length);
+ const char *src = Tcl_GetString(objv[firstArg + 1]);
+
+ length = objv[firstArg + 1]->length;
+ topicName = Tcl_WinUtfToTChar(src, length, &topicBuf);
+ length = Tcl_DStringLength(&topicBuf) / sizeof(TCHAR);
if (length == 0) {
topicName = NULL;
} else {
ddeTopic = DdeCreateStringHandle(ddeInstance, (void *) topicName,
- CP_WINANSI);
+ CP_WINUNICODE);
}
}
@@ -1356,7 +1477,12 @@ DdeObjCmd(
serviceName = DdeSetServerName(interp, serviceName, flags,
handlerPtr);
if (serviceName != NULL) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(serviceName, -1));
+ Tcl_DString dsBuf;
+
+ Tcl_WinTCharToUtf(serviceName, -1, &dsBuf);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_DStringValue(&dsBuf),
+ Tcl_DStringLength(&dsBuf)));
+ Tcl_DStringFree(&dsBuf);
} else {
Tcl_ResetResult(interp);
}
@@ -1364,12 +1490,28 @@ DdeObjCmd(
case DDE_EXECUTE: {
int dataLength;
- BYTE *dataString = (BYTE *) Tcl_GetStringFromObj(
- objv[firstArg + 2], &dataLength);
+ const void *dataString;
+ Tcl_DString dsBuf;
+
+ Tcl_DStringInit(&dsBuf);
+ if (flags & DDE_FLAG_BINARY) {
+ dataString =
+ Tcl_GetByteArrayFromObj(objv[firstArg + 2], &dataLength);
+ } else {
+ const char *src;
+
+ src = Tcl_GetString(objv[firstArg + 2]);
+ dataLength = objv[firstArg + 2]->length;
+ dataString = (const TCHAR *)
+ Tcl_WinUtfToTChar(src, dataLength, &dsBuf);
+ dataLength = Tcl_DStringLength(&dsBuf) + sizeof(TCHAR);
+ }
- if (dataLength == 0) {
+ if (dataLength + 1 < 2) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("cannot execute null data", -1));
+ Tcl_DStringFree(&dsBuf);
+ Tcl_SetErrorCode(interp, "TCL", "DDE", "NULL", NULL);
result = TCL_ERROR;
break;
}
@@ -1378,21 +1520,22 @@ DdeObjCmd(
DdeFreeStringHandle(ddeInstance, ddeTopic);
if (hConv == NULL) {
+ Tcl_DStringFree(&dsBuf);
SetDdeError(interp);
result = TCL_ERROR;
break;
}
- ddeData = DdeCreateDataHandle(ddeInstance, dataString,
- (DWORD) dataLength+1, 0, 0, CF_TEXT, 0);
+ ddeData = DdeCreateDataHandle(ddeInstance, (BYTE *) dataString,
+ (DWORD) dataLength, 0, 0, (flags & DDE_FLAG_BINARY) ? CF_TEXT : CF_UNICODETEXT, 0);
if (ddeData != NULL) {
if (flags & DDE_FLAG_ASYNC) {
DdeClientTransaction((LPBYTE) ddeData, 0xFFFFFFFF, hConv, 0,
- CF_TEXT, XTYP_EXECUTE, TIMEOUT_ASYNC, &ddeResult);
+ (flags & DDE_FLAG_BINARY) ? CF_TEXT : CF_UNICODETEXT, XTYP_EXECUTE, TIMEOUT_ASYNC, &ddeResult);
DdeAbandonTransaction(ddeInstance, hConv, ddeResult);
} else {
ddeReturn = DdeClientTransaction((LPBYTE) ddeData, 0xFFFFFFFF,
- hConv, 0, CF_TEXT, XTYP_EXECUTE, 30000, NULL);
+ hConv, 0, (flags & DDE_FLAG_BINARY) ? CF_TEXT : CF_UNICODETEXT, XTYP_EXECUTE, 30000, NULL);
if (ddeReturn == 0) {
SetDdeError(interp);
result = TCL_ERROR;
@@ -1403,15 +1546,22 @@ DdeObjCmd(
SetDdeError(interp);
result = TCL_ERROR;
}
+ Tcl_DStringFree(&dsBuf);
break;
}
case DDE_REQUEST: {
- const char *itemString = Tcl_GetStringFromObj(objv[firstArg + 2],
- &length);
+ const TCHAR *itemString;
+ const char *src;
+
+ src = Tcl_GetString(objv[firstArg + 2]);
+ length = objv[firstArg + 2]->length;
+ itemString = Tcl_WinUtfToTChar(src, length, &itemBuf);
+ length = Tcl_DStringLength(&itemBuf) / sizeof(TCHAR);
if (length == 0) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("cannot request value of null data", -1));
+ Tcl_SetErrorCode(interp, "TCL", "DDE", "NULL", NULL);
result = TCL_ERROR;
goto cleanup;
}
@@ -1424,27 +1574,33 @@ DdeObjCmd(
result = TCL_ERROR;
} else {
Tcl_Obj *returnObjPtr;
- ddeItem = DdeCreateStringHandle(ddeInstance, (void *)itemString,
- CP_WINANSI);
+ ddeItem = DdeCreateStringHandle(ddeInstance, (void *) itemString,
+ CP_WINUNICODE);
if (ddeItem != NULL) {
ddeData = DdeClientTransaction(NULL, 0, hConv, ddeItem,
- CF_TEXT, XTYP_REQUEST, 5000, NULL);
+ (flags & DDE_FLAG_BINARY) ? CF_TEXT : CF_UNICODETEXT, XTYP_REQUEST, 5000, NULL);
if (ddeData == NULL) {
SetDdeError(interp);
result = TCL_ERROR;
} else {
DWORD tmp;
- const char *dataString = (const char *) DdeAccessData(ddeData, &tmp);
+ TCHAR *dataString = (TCHAR *) DdeAccessData(ddeData, &tmp);
if (flags & DDE_FLAG_BINARY) {
returnObjPtr =
- Tcl_NewByteArrayObj((BYTE *) dataString, (int) tmp);
+ Tcl_NewByteArrayObj((BYTE *) dataString, tmp);
} else {
- if (tmp && !dataString[tmp-1]) {
- --tmp;
+ Tcl_DString dsBuf;
+
+ if ((tmp >= sizeof(TCHAR))
+ && !dataString[tmp / sizeof(TCHAR) - 1]) {
+ tmp -= sizeof(TCHAR);
}
- returnObjPtr = Tcl_NewStringObj(dataString,
- (int) tmp);
+ Tcl_WinTCharToUtf(dataString, tmp, &dsBuf);
+ returnObjPtr =
+ Tcl_NewStringObj(Tcl_DStringValue(&dsBuf),
+ Tcl_DStringLength(&dsBuf));
+ Tcl_DStringFree(&dsBuf);
}
DdeUnaccessData(ddeData);
DdeFreeDataHandle(ddeData);
@@ -1455,22 +1611,37 @@ DdeObjCmd(
result = TCL_ERROR;
}
}
-
break;
}
case DDE_POKE: {
- const char *itemString = Tcl_GetStringFromObj(objv[firstArg + 2],
- &length);
+ Tcl_DString dsBuf;
+ const TCHAR *itemString;
BYTE *dataString;
+ const char *src;
+ src = Tcl_GetString(objv[firstArg + 2]);
+ length = objv[firstArg + 2]->length;
+ itemString = Tcl_WinUtfToTChar(src, length, &itemBuf);
+ length = Tcl_DStringLength(&itemBuf) / sizeof(TCHAR);
if (length == 0) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("cannot have a null item", -1));
+ Tcl_SetErrorCode(interp, "TCL", "DDE", "NULL", NULL);
result = TCL_ERROR;
goto cleanup;
}
- dataString = (BYTE *) Tcl_GetStringFromObj(objv[firstArg + 3],
- &length);
+ Tcl_DStringInit(&dsBuf);
+ if (flags & DDE_FLAG_BINARY) {
+ dataString = (BYTE *)
+ Tcl_GetByteArrayFromObj(objv[firstArg + 3], &length);
+ } else {
+ const char *data =
+ Tcl_GetString(objv[firstArg + 3]);
+ length = objv[firstArg + 3]->length;
+ dataString = (BYTE *)
+ Tcl_WinUtfToTChar(data, length, &dsBuf);
+ length = Tcl_DStringLength(&dsBuf) + sizeof(TCHAR);
+ }
hConv = DdeConnect(ddeInstance, ddeService, ddeTopic, NULL);
DdeFreeStringHandle(ddeInstance, ddeService);
@@ -1481,10 +1652,10 @@ DdeObjCmd(
result = TCL_ERROR;
} else {
ddeItem = DdeCreateStringHandle(ddeInstance, (void *) itemString,
- CP_WINANSI);
+ CP_WINUNICODE);
if (ddeItem != NULL) {
- ddeData = DdeClientTransaction(dataString, (DWORD) length+1,
- hConv, ddeItem, CF_TEXT, XTYP_POKE, 5000, NULL);
+ ddeData = DdeClientTransaction(dataString, (DWORD) length,
+ hConv, ddeItem, (flags & DDE_FLAG_BINARY) ? CF_TEXT : CF_UNICODETEXT, XTYP_POKE, 5000, NULL);
if (ddeData == NULL) {
SetDdeError(interp);
result = TCL_ERROR;
@@ -1494,6 +1665,7 @@ DdeObjCmd(
result = TCL_ERROR;
}
}
+ Tcl_DStringFree(&dsBuf);
break;
}
@@ -1508,6 +1680,7 @@ DdeObjCmd(
if (serviceName == NULL) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("invalid service name \"\"", -1));
+ Tcl_SetErrorCode(interp, "TCL", "DDE", "NO_SERVER", NULL);
result = TCL_ERROR;
goto cleanup;
}
@@ -1526,7 +1699,7 @@ DdeObjCmd(
for (riPtr = tsdPtr->interpListPtr; riPtr != NULL;
riPtr = riPtr->nextPtr) {
- if (stricmp(serviceName, riPtr->name) == 0) {
+ if (_tcsicmp(serviceName, riPtr->name) == 0) {
break;
}
}
@@ -1539,9 +1712,9 @@ DdeObjCmd(
* server.
*/
- Tcl_Preserve((ClientData) riPtr);
+ Tcl_Preserve(riPtr);
sendInterp = riPtr->interp;
- Tcl_Preserve((ClientData) sendInterp);
+ Tcl_Preserve(sendInterp);
/*
* Don't exchange objects between interps. The target interp would
@@ -1551,10 +1724,12 @@ DdeObjCmd(
* referring to deallocated objects.
*/
- if (Tcl_IsSafe(riPtr->interp) && riPtr->handlerPtr == NULL) {
- Tcl_SetResult(riPtr->interp, "permission denied: "
- "a handler procedure must be defined for use in "
- "a safe interp", TCL_STATIC);
+ if (Tcl_IsSafe(riPtr->interp) && (riPtr->handlerPtr == NULL)) {
+ Tcl_SetObjResult(riPtr->interp, Tcl_NewStringObj(
+ "permission denied: a handler procedure must be"
+ " defined for use in a safe interp", -1));
+ Tcl_SetErrorCode(interp, "TCL", "DDE", "SECURITY_CHECK",
+ NULL);
result = TCL_ERROR;
}
@@ -1594,8 +1769,7 @@ DdeObjCmd(
objPtr = Tcl_GetVar2Ex(sendInterp, "errorInfo", NULL,
TCL_GLOBAL_ONLY);
if (objPtr) {
- string = Tcl_GetStringFromObj(objPtr, &length);
- Tcl_AddObjErrorInfo(interp, string, length);
+ Tcl_AppendObjToErrorInfo(interp, objPtr);
}
objPtr = Tcl_GetVar2Ex(sendInterp, "errorCode", NULL,
@@ -1606,9 +1780,11 @@ DdeObjCmd(
}
Tcl_SetObjResult(interp, Tcl_GetObjResult(sendInterp));
}
- Tcl_Release((ClientData) riPtr);
- Tcl_Release((ClientData) sendInterp);
+ Tcl_Release(riPtr);
+ Tcl_Release(sendInterp);
} else {
+ Tcl_DString dsBuf;
+
/*
* This is a non-local request. Send the script to the server and
* poll it for a result.
@@ -1617,31 +1793,36 @@ DdeObjCmd(
if (MakeDdeConnection(interp, serviceName, &hConv) != TCL_OK) {
invalidServerResponse:
Tcl_SetObjResult(interp,
- Tcl_NewStringObj("invalid data returned from server",
- -1));
+ Tcl_NewStringObj("invalid data returned from server", -1));
+ Tcl_SetErrorCode(interp, "TCL", "DDE", "BAD_RESPONSE", NULL);
result = TCL_ERROR;
goto cleanup;
}
objPtr = Tcl_ConcatObj(objc, objv);
- string = Tcl_GetStringFromObj(objPtr, &length);
- ddeItemData = DdeCreateDataHandle(ddeInstance,
- (BYTE *) string, (DWORD) length+1, 0, 0, CF_TEXT, 0);
+ string = Tcl_GetString(objPtr);
+ length = objPtr->length;
+ Tcl_WinUtfToTChar(string, length, &dsBuf);
+ string = Tcl_DStringValue(&dsBuf);
+ length = Tcl_DStringLength(&dsBuf) + sizeof(TCHAR);
+ ddeItemData = DdeCreateDataHandle(ddeInstance, (BYTE *) string,
+ (DWORD) length, 0, 0, CF_UNICODETEXT, 0);
+ Tcl_DStringFree(&dsBuf);
if (flags & DDE_FLAG_ASYNC) {
ddeData = DdeClientTransaction((LPBYTE) ddeItemData,
0xFFFFFFFF, hConv, 0,
- CF_TEXT, XTYP_EXECUTE, TIMEOUT_ASYNC, &ddeResult);
+ CF_UNICODETEXT, XTYP_EXECUTE, TIMEOUT_ASYNC, &ddeResult);
DdeAbandonTransaction(ddeInstance, hConv, ddeResult);
} else {
ddeData = DdeClientTransaction((LPBYTE) ddeItemData,
0xFFFFFFFF, hConv, 0,
- CF_TEXT, XTYP_EXECUTE, 30000, NULL);
+ CF_UNICODETEXT, XTYP_EXECUTE, 30000, NULL);
if (ddeData != 0) {
ddeCookie = DdeCreateStringHandle(ddeInstance,
- TCL_DDE_EXECUTE_RESULT, CP_WINANSI);
+ TCL_DDE_EXECUTE_RESULT, CP_WINUNICODE);
ddeData = DdeClientTransaction(NULL, 0, hConv, ddeCookie,
- CF_TEXT, XTYP_REQUEST, 30000, NULL);
+ CF_UNICODETEXT, XTYP_REQUEST, 30000, NULL);
}
}
@@ -1650,10 +1831,12 @@ DdeObjCmd(
if (ddeData == 0) {
SetDdeError(interp);
result = TCL_ERROR;
+ goto cleanup;
}
if (!(flags & DDE_FLAG_ASYNC)) {
Tcl_Obj *resultPtr;
+ TCHAR *ddeDataString;
/*
* The return handle has a two or four element list in it. The
@@ -1664,12 +1847,17 @@ DdeObjCmd(
* variable "errorInfo".
*/
- resultPtr = Tcl_NewObj();
length = DdeGetData(ddeData, NULL, 0, 0);
- Tcl_SetObjLength(resultPtr, length);
- string = Tcl_GetString(resultPtr);
- DdeGetData(ddeData, (BYTE *) string, (DWORD) length, 0);
- Tcl_SetObjLength(resultPtr, (int) strlen(string));
+ ddeDataString = (TCHAR *) Tcl_Alloc(length);
+ DdeGetData(ddeData, (BYTE *) ddeDataString, (DWORD) length, 0);
+ if (length > sizeof(TCHAR)) {
+ length -= sizeof(TCHAR);
+ }
+ Tcl_WinTCharToUtf(ddeDataString, length, &dsBuf);
+ resultPtr = Tcl_NewStringObj(Tcl_DStringValue(&dsBuf),
+ Tcl_DStringLength(&dsBuf));
+ Tcl_DStringFree(&dsBuf);
+ Tcl_Free((char *) ddeDataString);
if (Tcl_ListObjIndex(NULL, resultPtr, 0, &objPtr) != TCL_OK) {
Tcl_DecrRefCount(resultPtr);
@@ -1687,9 +1875,7 @@ DdeObjCmd(
Tcl_DecrRefCount(resultPtr);
goto invalidServerResponse;
}
- length = -1;
- string = Tcl_GetStringFromObj(objPtr, &length);
- Tcl_AddObjErrorInfo(interp, string, length);
+ Tcl_AppendObjToErrorInfo(interp, objPtr);
Tcl_ListObjIndex(NULL, resultPtr, 2, &objPtr);
Tcl_SetObjErrorCode(interp, objPtr);
@@ -1721,6 +1907,9 @@ DdeObjCmd(
if (hConv != NULL) {
DdeDisconnect(hConv);
}
+ Tcl_DStringFree(&itemBuf);
+ Tcl_DStringFree(&topicBuf);
+ Tcl_DStringFree(&serviceBuf);
return result;
}
diff --git a/win/tclWinReg.c b/win/tclWinReg.c
index f3d7a07..0d2cd94 100644
--- a/win/tclWinReg.c
+++ b/win/tclWinReg.c
@@ -492,7 +492,6 @@ DeleteValue(
{
HKEY key;
char *valueName;
- size_t length;
DWORD result;
Tcl_DString ds;
@@ -506,8 +505,7 @@ DeleteValue(
}
valueName = Tcl_GetString(valueNameObj);
- length = valueNameObj->length;
- Tcl_WinUtfToTChar(valueName, length, &ds);
+ Tcl_WinUtfToTChar(valueName, valueNameObj->length, &ds);
result = RegDeleteValue(key, (const TCHAR *)Tcl_DStringValue(&ds));
Tcl_DStringFree(&ds);
if (result != ERROR_SUCCESS) {
@@ -647,7 +645,6 @@ GetType(
Tcl_DString ds;
const char *valueName;
const TCHAR *nativeValue;
- size_t length;
/*
* Attempt to open the key for reading.
@@ -663,8 +660,7 @@ GetType(
*/
valueName = Tcl_GetString(valueNameObj);
- length = valueNameObj->length;
- nativeValue = Tcl_WinUtfToTChar(valueName, length, &ds);
+ nativeValue = Tcl_WinUtfToTChar(valueName, valueNameObj->length, &ds);
result = RegQueryValueEx(key, nativeValue, NULL, &type,
NULL, NULL);
Tcl_DStringFree(&ds);
@@ -720,7 +716,6 @@ GetValue(
const TCHAR *nativeValue;
DWORD result, length, type;
Tcl_DString data, buf;
- size_t nameLen;
/*
* Attempt to open the key for reading.
@@ -746,8 +741,7 @@ GetValue(
length = TCL_DSTRING_STATIC_SIZE/sizeof(TCHAR) - 1;
valueName = Tcl_GetString(valueNameObj);
- nameLen = valueNameObj->length;
- nativeValue = Tcl_WinUtfToTChar(valueName, nameLen, &buf);
+ nativeValue = Tcl_WinUtfToTChar(valueName, valueNameObj->length, &buf);
result = RegQueryValueEx(key, nativeValue, NULL, &type,
(BYTE *) Tcl_DStringValue(&data), &length);
@@ -936,13 +930,11 @@ OpenKey(
HKEY *keyPtr) /* Returned HKEY. */
{
char *keyName, *buffer, *hostName;
- size_t length;
HKEY rootKey;
DWORD result;
keyName = Tcl_GetString(keyNameObj);
- length = keyNameObj->length;
- buffer = Tcl_Alloc(length + 1);
+ buffer = Tcl_Alloc(keyNameObj->length + 1);
strcpy(buffer, keyName);
result = ParseKeyName(interp, buffer, &hostName, &rootKey, &keyName);
@@ -1244,7 +1236,6 @@ SetValue(
REGSAM mode) /* Mode flags to pass. */
{
int type;
- size_t length;
DWORD result;
HKEY key;
const char *valueName;
@@ -1265,8 +1256,7 @@ SetValue(
}
valueName = Tcl_GetString(valueNameObj);
- length = valueNameObj->length;
- valueName = (char *) Tcl_WinUtfToTChar(valueName, length, &nameBuf);
+ valueName = (char *) Tcl_WinUtfToTChar(valueName, valueNameObj->length, &nameBuf);
if (type == REG_DWORD || type == REG_DWORD_BIG_ENDIAN) {
int value;
@@ -1301,8 +1291,7 @@ SetValue(
for (i = 0; i < objc; i++) {
const char *bytes = Tcl_GetString(objv[i]);
- length = objv[i]->length;
- Tcl_DStringAppend(&data, bytes, length);
+ Tcl_DStringAppend(&data, bytes, objv[i]->length);
/*
* Add a null character to separate this value from the next.
@@ -1322,18 +1311,16 @@ SetValue(
Tcl_DString buf;
const char *data = Tcl_GetString(dataObj);
- length = dataObj->length;
- data = (char *) Tcl_WinUtfToTChar(data, length, &buf);
+ data = (char *) Tcl_WinUtfToTChar(data, dataObj->length, &buf);
/*
* Include the null in the length, padding if needed for WCHAR.
*/
Tcl_DStringSetLength(&buf, Tcl_DStringLength(&buf)+1);
- length = Tcl_DStringLength(&buf) + 1;
result = RegSetValueEx(key, (TCHAR *) valueName, 0,
- (DWORD) type, (BYTE *) data, (DWORD) length);
+ (DWORD) type, (BYTE *) data, (DWORD) Tcl_DStringLength(&buf) + 1);
Tcl_DStringFree(&buf);
} else {
BYTE *data;
@@ -1404,8 +1391,7 @@ BroadcastValue(
}
str = Tcl_GetString(objv[0]);
- len = objv[0]->length;
- wstr = (WCHAR *) Tcl_WinUtfToTChar(str, len, &ds);
+ wstr = (WCHAR *) Tcl_WinUtfToTChar(str, objv[0]->length, &ds);
if (Tcl_DStringLength(&ds) == 0) {
wstr = NULL;
}
generated by cgit v0.12 at 2024-10-21 20:55:16 (GMT)