summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authordgp <dgp@users.sourceforge.net>2018-10-29 15:37:07 (GMT)
committerdgp <dgp@users.sourceforge.net>2018-10-29 15:37:07 (GMT)
commitf7dfeb706fb75bccd0aae6cd6119fccdfb6bd8d0 (patch)
treeadc5bd58d36d1e644901db91fda9cae4929e9168
parentf338047c195aac7e3ac7bb3485da02b33fd868a2 (diff)
parent78ef9a971b84f12fb89a8351cf5328961bee8088 (diff)
downloadtcl-f7dfeb706fb75bccd0aae6cd6119fccdfb6bd8d0.zip
tcl-f7dfeb706fb75bccd0aae6cd6119fccdfb6bd8d0.tar.gz
tcl-f7dfeb706fb75bccd0aae6cd6119fccdfb6bd8d0.tar.bz2
merge 8.7
Diffstat
-rw-r--r--doc/tcltest.n14
-rw-r--r--library/dde/pkgIndex.tcl4
-rw-r--r--library/init.tcl2
-rw-r--r--library/tcltest/pkgIndex.tcl2
-rw-r--r--library/tcltest/tcltest.tcl45
-rw-r--r--library/tzdata/Africa/Casablanca280
-rw-r--r--library/tzdata/Africa/El_Aaiun256
-rw-r--r--library/tzdata/Pacific/Honolulu5
-rw-r--r--tests/all.tcl4
-rw-r--r--tests/assemble.test13
-rw-r--r--tests/dict.test14
-rw-r--r--tests/ioCmd.test6
-rw-r--r--tests/source.test11
-rw-r--r--tests/tcltest.test6
-rw-r--r--tests/winDde.test4
-rw-r--r--unix/Makefile.in4
-rw-r--r--win/Makefile.in4
-rw-r--r--win/makefile.vc2
-rw-r--r--win/tclWinDde.c238
-rw-r--r--win/tclWinReg.c32
20 files changed, 345 insertions, 601 deletions
diff --git a/doc/tcltest.n b/doc/tcltest.n
index 05c1922..b161a2b 100644
--- a/doc/tcltest.n
+++ b/doc/tcltest.n
@@ -8,7 +8,7 @@
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
-.TH "tcltest" n 2.3 tcltest "Tcl Bundled Packages"
+.TH "tcltest" n 2.5 tcltest "Tcl Bundled Packages"
.so man.macros
.BS
'\" Note: do not modify the .SH NAME line immediately below!
@@ -16,7 +16,7 @@
tcltest \- Test harness support code and utilities
.SH SYNOPSIS
.nf
-\fBpackage require tcltest\fR ?\fB2.3\fR?
+\fBpackage require tcltest\fR ?\fB2.5\fR?
\fBtcltest::test \fIname description\fR ?\fI\-option value ...\fR?
\fBtcltest::test \fIname description\fR ?\fIconstraints\fR? \fIbody result\fR
@@ -454,6 +454,7 @@ The valid options for \fBtest\fR are summarized:
?\fB\-output \fIexpectedOutput\fR?
?\fB\-errorOutput \fIexpectedError\fR?
?\fB\-returnCodes \fIcodeList\fR?
+ ?\fB\-errorCode \fIexpectedErrorCode\fR?
?\fB\-match \fImode\fR?
.CE
.PP
@@ -577,6 +578,15 @@ return codes known to \fBreturn\fR, in both numeric and symbolic
form, including extended return codes, are acceptable elements in
the \fIexpectedCodeList\fR. Default value is
.QW "\fBok return\fR" .
+.TP
+\fB\-errorCode \fIexpectedErrorCode\fR
+.
+The optional \fB\-errorCode\fR attribute supplies \fIexpectedErrorCode\fR,
+a glob pattern that should match the error code reported from evaluation of the
+\fB\-body\fR script. If evaluation of the \fB\-body\fR script returns
+a code not matching \fIexpectedErrorCode\fR, the test fails. Default value is
+.QW "\fB*\fR" .
+If \fB\-returnCodes\fR does not include \fBerror\fR it is set to \fBerror\fR.
.PP
To pass, a test must successfully evaluate its \fB\-setup\fR, \fB\-body\fR,
and \fB\-cleanup\fR scripts. The return code of the \fB\-body\fR script and
diff --git a/library/dde/pkgIndex.tcl b/library/dde/pkgIndex.tcl
index 4cf73d0..7aa67fa 100644
--- a/library/dde/pkgIndex.tcl
+++ b/library/dde/pkgIndex.tcl
@@ -1,7 +1,7 @@
if {([info commands ::tcl::pkgconfig] eq "")
|| ([info sharedlibextension] ne ".dll")} return
if {[::tcl::pkgconfig get debug]} {
- package ifneeded dde 1.4.0 [list load [file join $dir tcldde14g.dll] dde]
+ package ifneeded dde 1.4.1 [list load [file join $dir tcldde14g.dll] dde]
} else {
- package ifneeded dde 1.4.0 [list load [file join $dir tcldde14.dll] dde]
+ package ifneeded dde 1.4.1 [list load [file join $dir tcldde14.dll] dde]
}
diff --git a/library/init.tcl b/library/init.tcl
index 51339d0..1221e61 100644
--- a/library/init.tcl
+++ b/library/init.tcl
@@ -810,7 +810,7 @@ foreach {safe package version file} {
1 opt 0.4.7 {opt optparse.tcl}
0 platform 1.0.14 {platform platform.tcl}
0 platform::shell 1.1.4 {platform shell.tcl}
- 1 tcltest 2.4.1 {tcltest tcltest.tcl}
+ 1 tcltest 2.5.0 {tcltest tcltest.tcl}
} {
if {$isafe && !$safe} continue
package ifneeded $package $version [list source [file join $dir {*}$file]]
diff --git a/library/tcltest/pkgIndex.tcl b/library/tcltest/pkgIndex.tcl
index eadb1bd..fde3ffe 100644
--- a/library/tcltest/pkgIndex.tcl
+++ b/library/tcltest/pkgIndex.tcl
@@ -9,4 +9,4 @@
# full path name of this file's directory.
if {![package vsatisfies [package provide Tcl] 8.5-]} {return}
-package ifneeded tcltest 2.4.1 [list source [file join $dir tcltest.tcl]]
+package ifneeded tcltest 2.5.0 [list source [file join $dir tcltest.tcl]]
diff --git a/library/tcltest/tcltest.tcl b/library/tcltest/tcltest.tcl
index f1b6082..410aa24 100644
--- a/library/tcltest/tcltest.tcl
+++ b/library/tcltest/tcltest.tcl
@@ -22,7 +22,7 @@ namespace eval tcltest {
# When the version number changes, be sure to update the pkgIndex.tcl file,
# and the install directory in the Makefiles. When the minor version
# changes (new feature) be sure to update the man page as well.
- variable Version 2.4.1
+ variable Version 2.5.0
# Compatibility support for dumb variables defined in tcltest 1
# Do not use these. Call [package provide Tcl] and [info patchlevel]
@@ -1841,6 +1841,9 @@ proc tcltest::SubstArguments {argList} {
# is optional; default is {}.
# returnCodes - Expected return codes. This attribute is
# optional; default is {0 2}.
+# errorCode - Expected error code. This attribute is
+# optional; default is {*}. It is a glob pattern.
+# If given, returnCodes defaults to {1}.
# setup - Code to run before $script (above). This
# attribute is optional; default is {}.
# cleanup - Code to run after $script (above). This
@@ -1882,7 +1885,7 @@ proc tcltest::test {name description args} {
# Pre-define everything to null except output and errorOutput. We
# determine whether or not to trap output based on whether or not
# these variables (output & errorOutput) are defined.
- lassign {} constraints setup cleanup body result returnCodes match
+ lassign {} constraints setup cleanup body result returnCodes errorCode match
# Set the default match mode
set match exact
@@ -1892,6 +1895,9 @@ proc tcltest::test {name description args} {
# 'return' being used in the test script).
set returnCodes [list 0 2]
+ # Set the default error code pattern
+ set errorCode "*"
+
# The old test format can't have a 3rd argument (constraints or
# script) that starts with '-'.
if {[string match -* [lindex $args 0]] || ([llength $args] <= 1)} {
@@ -1901,7 +1907,7 @@ proc tcltest::test {name description args} {
set testAttributes($element) $value
}
foreach item {constraints match setup body cleanup \
- result returnCodes output errorOutput} {
+ result returnCodes errorCode output errorOutput} {
if {[info exists testAttributes(-$item)]} {
set testAttributes(-$item) [uplevel 1 \
::concat $testAttributes(-$item)]
@@ -1912,7 +1918,7 @@ proc tcltest::test {name description args} {
}
set validFlags {-setup -cleanup -body -result -returnCodes \
- -match -output -errorOutput -constraints}
+ -errorCode -match -output -errorOutput -constraints}
foreach flag [array names testAttributes] {
if {$flag ni $validFlags} {
@@ -1944,6 +1950,10 @@ proc tcltest::test {name description args} {
foreach {strcode numcode} {ok 0 normal 0 error 1 return 2 break 3 continue 4} {
set returnCodes [string map -nocase [list $strcode $numcode] $returnCodes]
}
+ # errorCode without returnCode 1 is meaningless
+ if {$errorCode ne "*" && 1 ni $returnCodes} {
+ set returnCodes 1
+ }
} else {
# This is parsing for the old test command format; it is here
# for backward compatibility.
@@ -1976,7 +1986,7 @@ proc tcltest::test {name description args} {
set code [catch {uplevel 1 $setup} setupMsg]
if {$code == 1} {
set errorInfo(setup) $::errorInfo
- set errorCode(setup) $::errorCode
+ set errorCodeRes(setup) $::errorCode
}
set setupFailure [expr {$code != 0}]
@@ -2003,7 +2013,7 @@ proc tcltest::test {name description args} {
lassign $testResult actualAnswer returnCode
if {$returnCode == 1} {
set errorInfo(body) $::errorInfo
- set errorCode(body) $::errorCode
+ set errorCodeRes(body) $::errorCode
}
}
@@ -2012,6 +2022,11 @@ proc tcltest::test {name description args} {
if {!$setupFailure && ($returnCode ni $returnCodes)} {
set codeFailure 1
}
+ set errorCodeFailure 0
+ if {!$setupFailure && !$codeFailure && $returnCode == 1 && \
+ ![string match $errorCode $errorCodeRes(body)]} {
+ set errorCodeFailure 1
+ }
# If expected output/error strings exist, we have to compare
# them. If the comparison fails, then so did the test.
@@ -2055,7 +2070,7 @@ proc tcltest::test {name description args} {
set code [catch {uplevel 1 $cleanup} cleanupMsg]
if {$code == 1} {
set errorInfo(cleanup) $::errorInfo
- set errorCode(cleanup) $::errorCode
+ set errorCodeRes(cleanup) $::errorCode
}
set cleanupFailure [expr {$code != 0}]
@@ -2106,7 +2121,7 @@ proc tcltest::test {name description args} {
variable numTests
if {!($setupFailure || $cleanupFailure || $coreFailure
|| $outputFailure || $errorFailure || $codeFailure
- || $scriptFailure)} {
+ || $errorCodeFailure || $scriptFailure)} {
if {$testLevel == 1} {
incr numTests(Passed)
if {[IsVerbose pass]} {
@@ -2159,7 +2174,7 @@ proc tcltest::test {name description args} {
failed:\n$setupMsg"
if {[info exists errorInfo(setup)]} {
puts [outputChannel] "---- errorInfo(setup): $errorInfo(setup)"
- puts [outputChannel] "---- errorCode(setup): $errorCode(setup)"
+ puts [outputChannel] "---- errorCode(setup): $errorCodeRes(setup)"
}
}
if {$scriptFailure} {
@@ -2171,6 +2186,10 @@ proc tcltest::test {name description args} {
($match matching):\n$result"
}
}
+ if {$errorCodeFailure} {
+ puts [outputChannel] "---- Error code was: '$errorCodeRes(body)'"
+ puts [outputChannel] "---- Error code should have been: '$errorCode'"
+ }
if {$codeFailure} {
switch -- $returnCode {
0 { set msg "Test completed normally" }
@@ -2186,7 +2205,7 @@ proc tcltest::test {name description args} {
if {[IsVerbose error]} {
if {[info exists errorInfo(body)] && (1 ni $returnCodes)} {
puts [outputChannel] "---- errorInfo: $errorInfo(body)"
- puts [outputChannel] "---- errorCode: $errorCode(body)"
+ puts [outputChannel] "---- errorCode: $errorCodeRes(body)"
}
}
}
@@ -2212,7 +2231,7 @@ proc tcltest::test {name description args} {
puts [outputChannel] "---- Test cleanup failed:\n$cleanupMsg"
if {[info exists errorInfo(cleanup)]} {
puts [outputChannel] "---- errorInfo(cleanup): $errorInfo(cleanup)"
- puts [outputChannel] "---- errorCode(cleanup): $errorCode(cleanup)"
+ puts [outputChannel] "---- errorCode(cleanup): $errorCodeRes(cleanup)"
}
}
if {$coreFailure} {
@@ -2722,7 +2741,7 @@ proc tcltest::GetMatchingDirectories {rootdir} {
# shell being tested
#
# Results:
-# None.
+# Whether there were any failures.
#
# Side effects:
# None.
@@ -2868,7 +2887,7 @@ proc tcltest::runAllTests { {shell ""} } {
puts [outputChannel] ""
puts [outputChannel] [string repeat ~ 44]
}
- return
+ return [info exists testFileFailures]
}
#####################################################################
diff --git a/library/tzdata/Africa/Casablanca b/library/tzdata/Africa/Casablanca
index 33ad99b..3207e59 100644
--- a/library/tzdata/Africa/Casablanca
+++ b/library/tzdata/Africa/Casablanca
@@ -2,229 +2,59 @@
set TZData(:Africa/Casablanca) {
{-9223372036854775808 -1820 0 LMT}
- {-1773012580 0 0 WET}
- {-956361600 3600 1 WEST}
- {-950490000 0 0 WET}
- {-942019200 3600 1 WEST}
- {-761187600 0 0 WET}
- {-617241600 3600 1 WEST}
- {-605149200 0 0 WET}
- {-81432000 3600 1 WEST}
- {-71110800 0 0 WET}
- {141264000 3600 1 WEST}
- {147222000 0 0 WET}
- {199756800 3600 1 WEST}
- {207702000 0 0 WET}
- {231292800 3600 1 WEST}
- {244249200 0 0 WET}
- {265507200 3600 1 WEST}
- {271033200 0 0 WET}
- {448243200 3600 0 CET}
- {504918000 0 0 WET}
- {1212278400 3600 1 WEST}
- {1220223600 0 0 WET}
- {1243814400 3600 1 WEST}
- {1250809200 0 0 WET}
- {1272758400 3600 1 WEST}
- {1281222000 0 0 WET}
- {1301788800 3600 1 WEST}
- {1312066800 0 0 WET}
- {1335664800 3600 1 WEST}
- {1342749600 0 0 WET}
- {1345428000 3600 1 WEST}
- {1348970400 0 0 WET}
- {1367114400 3600 1 WEST}
- {1373162400 0 0 WET}
- {1376100000 3600 1 WEST}
- {1382839200 0 0 WET}
- {1396144800 3600 1 WEST}
- {1403920800 0 0 WET}
- {1406944800 3600 1 WEST}
- {1414288800 0 0 WET}
- {1427594400 3600 1 WEST}
- {1434247200 0 0 WET}
- {1437271200 3600 1 WEST}
- {1445738400 0 0 WET}
- {1459044000 3600 1 WEST}
- {1465092000 0 0 WET}
- {1468116000 3600 1 WEST}
- {1477792800 0 0 WET}
- {1490493600 3600 1 WEST}
- {1495332000 0 0 WET}
- {1498960800 3600 1 WEST}
- {1509242400 0 0 WET}
- {1521943200 3600 1 WEST}
- {1526176800 0 0 WET}
- {1529200800 3600 1 WEST}
- {1540692000 0 0 WET}
- {1553997600 3600 1 WEST}
- {1557021600 0 0 WET}
- {1560045600 3600 1 WEST}
- {1572141600 0 0 WET}
- {1585447200 3600 1 WEST}
- {1587261600 0 0 WET}
- {1590285600 3600 1 WEST}
- {1603591200 0 0 WET}
- {1616896800 3600 1 WEST}
- {1618106400 0 0 WET}
- {1621130400 3600 1 WEST}
- {1635645600 0 0 WET}
- {1651975200 3600 1 WEST}
- {1667095200 0 0 WET}
- {1682215200 3600 1 WEST}
- {1698544800 0 0 WET}
- {1713060000 3600 1 WEST}
- {1729994400 0 0 WET}
- {1743904800 3600 1 WEST}
- {1761444000 0 0 WET}
- {1774749600 3600 1 WEST}
- {1792893600 0 0 WET}
- {1806199200 3600 1 WEST}
- {1824948000 0 0 WET}
- {1837648800 3600 1 WEST}
- {1856397600 0 0 WET}
- {1869098400 3600 1 WEST}
- {1887847200 0 0 WET}
- {1901152800 3600 1 WEST}
- {1919296800 0 0 WET}
- {1932602400 3600 1 WEST}
- {1950746400 0 0 WET}
- {1964052000 3600 1 WEST}
- {1982800800 0 0 WET}
- {1995501600 3600 1 WEST}
- {2014250400 0 0 WET}
- {2026951200 3600 1 WEST}
- {2045700000 0 0 WET}
- {2058400800 3600 1 WEST}
- {2077149600 0 0 WET}
- {2090455200 3600 1 WEST}
- {2107994400 0 0 WET}
- {2108602800 0 0 WET}
- {2121904800 3600 1 WEST}
- {2138234400 0 0 WET}
- {2140052400 0 0 WET}
- {2153354400 3600 1 WEST}
- {2172103200 0 0 WET}
- {2184804000 3600 1 WEST}
- {2203552800 0 0 WET}
- {2216253600 3600 1 WEST}
- {2235002400 0 0 WET}
- {2248308000 3600 1 WEST}
- {2266452000 0 0 WET}
- {2279757600 3600 1 WEST}
- {2297901600 0 0 WET}
- {2311207200 3600 1 WEST}
- {2329351200 0 0 WET}
- {2342656800 3600 1 WEST}
- {2361405600 0 0 WET}
- {2374106400 3600 1 WEST}
- {2392855200 0 0 WET}
- {2405556000 3600 1 WEST}
- {2424304800 0 0 WET}
- {2437610400 3600 1 WEST}
- {2455754400 0 0 WET}
- {2469060000 3600 1 WEST}
- {2487204000 0 0 WET}
- {2500509600 3600 1 WEST}
- {2519258400 0 0 WET}
- {2531959200 3600 1 WEST}
- {2550708000 0 0 WET}
- {2563408800 3600 1 WEST}
- {2582157600 0 0 WET}
- {2595463200 3600 1 WEST}
- {2613607200 0 0 WET}
- {2626912800 3600 1 WEST}
- {2645056800 0 0 WET}
- {2658362400 3600 1 WEST}
- {2676506400 0 0 WET}
- {2689812000 3600 1 WEST}
- {2708560800 0 0 WET}
- {2721261600 3600 1 WEST}
- {2740010400 0 0 WET}
- {2752711200 3600 1 WEST}
- {2771460000 0 0 WET}
- {2784765600 3600 1 WEST}
- {2802909600 0 0 WET}
- {2816215200 3600 1 WEST}
- {2834359200 0 0 WET}
- {2847664800 3600 1 WEST}
- {2866413600 0 0 WET}
- {2879114400 3600 1 WEST}
- {2897863200 0 0 WET}
- {2910564000 3600 1 WEST}
- {2929312800 0 0 WET}
- {2942013600 3600 1 WEST}
- {2960762400 0 0 WET}
- {2974068000 3600 1 WEST}
- {2992212000 0 0 WET}
- {3005517600 3600 1 WEST}
- {3023661600 0 0 WET}
- {3036967200 3600 1 WEST}
- {3055716000 0 0 WET}
- {3068416800 3600 1 WEST}
- {3087165600 0 0 WET}
- {3099866400 3600 1 WEST}
- {3118615200 0 0 WET}
- {3131920800 3600 1 WEST}
- {3150064800 0 0 WET}
- {3163370400 3600 1 WEST}
- {3181514400 0 0 WET}
- {3194820000 3600 1 WEST}
- {3212964000 0 0 WET}
- {3226269600 3600 1 WEST}
- {3245018400 0 0 WET}
- {3257719200 3600 1 WEST}
- {3276468000 0 0 WET}
- {3289168800 3600 1 WEST}
- {3307917600 0 0 WET}
- {3321223200 3600 1 WEST}
- {3339367200 0 0 WET}
- {3352672800 3600 1 WEST}
- {3370816800 0 0 WET}
- {3384122400 3600 1 WEST}
- {3402871200 0 0 WET}
- {3415572000 3600 1 WEST}
- {3434320800 0 0 WET}
- {3447021600 3600 1 WEST}
- {3465770400 0 0 WET}
- {3479076000 3600 1 WEST}
- {3497220000 0 0 WET}
- {3510525600 3600 1 WEST}
- {3528669600 0 0 WET}
- {3541975200 3600 1 WEST}
- {3560119200 0 0 WET}
- {3573424800 3600 1 WEST}
- {3592173600 0 0 WET}
- {3604874400 3600 1 WEST}
- {3623623200 0 0 WET}
- {3636324000 3600 1 WEST}
- {3655072800 0 0 WET}
- {3668378400 3600 1 WEST}
- {3686522400 0 0 WET}
- {3699828000 3600 1 WEST}
- {3717972000 0 0 WET}
- {3731277600 3600 1 WEST}
- {3750026400 0 0 WET}
- {3762727200 3600 1 WEST}
- {3781476000 0 0 WET}
- {3794176800 3600 1 WEST}
- {3812925600 0 0 WET}
- {3825626400 3600 1 WEST}
- {3844375200 0 0 WET}
- {3857680800 3600 1 WEST}
- {3875824800 0 0 WET}
- {3889130400 3600 1 WEST}
- {3907274400 0 0 WET}
- {3920580000 3600 1 WEST}
- {3939328800 0 0 WET}
- {3952029600 3600 1 WEST}
- {3970778400 0 0 WET}
- {3983479200 3600 1 WEST}
- {4002228000 0 0 WET}
- {4015533600 3600 1 WEST}
- {4033677600 0 0 WET}
- {4046983200 3600 1 WEST}
- {4065127200 0 0 WET}
- {4078432800 3600 1 WEST}
- {4096576800 0 0 WET}
+ {-1773012580 0 0 +00}
+ {-956361600 3600 1 +00}
+ {-950490000 0 0 +00}
+ {-942019200 3600 1 +00}
+ {-761187600 0 0 +00}
+ {-617241600 3600 1 +00}
+ {-605149200 0 0 +00}
+ {-81432000 3600 1 +00}
+ {-71110800 0 0 +00}
+ {141264000 3600 1 +00}
+ {147222000 0 0 +00}
+ {199756800 3600 1 +00}
+ {207702000 0 0 +00}
+ {231292800 3600 1 +00}
+ {244249200 0 0 +00}
+ {265507200 3600 1 +00}
+ {271033200 0 0 +00}
+ {448243200 3600 0 +01}
+ {504918000 0 0 +00}
+ {1212278400 3600 1 +00}
+ {1220223600 0 0 +00}
+ {1243814400 3600 1 +00}
+ {1250809200 0 0 +00}
+ {1272758400 3600 1 +00}
+ {1281222000 0 0 +00}
+ {1301788800 3600 1 +00}
+ {1312066800 0 0 +00}
+ {1335664800 3600 1 +00}
+ {1342749600 0 0 +00}
+ {1345428000 3600 1 +00}
+ {1348970400 0 0 +00}
+ {1367114400 3600 1 +00}
+ {1373162400 0 0 +00}
+ {1376100000 3600 1 +00}
+ {1382839200 0 0 +00}
+ {1396144800 3600 1 +00}
+ {1403920800 0 0 +00}
+ {1406944800 3600 1 +00}
+ {1414288800 0 0 +00}
+ {1427594400 3600 1 +00}
+ {1434247200 0 0 +00}
+ {1437271200 3600 1 +00}
+ {1445738400 0 0 +00}
+ {1459044000 3600 1 +00}
+ {1465092000 0 0 +00}
+ {1468116000 3600 1 +00}
+ {1477792800 0 0 +00}
+ {1490493600 3600 1 +00}
+ {1495332000 0 0 +00}
+ {1498960800 3600 1 +00}
+ {1509242400 0 0 +00}
+ {1521943200 3600 1 +00}
+ {1526176800 0 0 +00}
+ {1529200800 3600 1 +00}
+ {1540598400 3600 0 +01}
}
diff --git a/library/tzdata/Africa/El_Aaiun b/library/tzdata/Africa/El_Aaiun
index 7bdc496..e0f5e1c 100644
--- a/library/tzdata/Africa/El_Aaiun
+++ b/library/tzdata/Africa/El_Aaiun
@@ -3,217 +3,47 @@
set TZData(:Africa/El_Aaiun) {
{-9223372036854775808 -3168 0 LMT}
{-1136070432 -3600 0 -01}
- {198291600 0 0 WET}
- {199756800 3600 1 WEST}
- {207702000 0 0 WET}
- {231292800 3600 1 WEST}
- {244249200 0 0 WET}
- {265507200 3600 1 WEST}
- {271033200 0 0 WET}
- {1212278400 3600 1 WEST}
- {1220223600 0 0 WET}
- {1243814400 3600 1 WEST}
- {1250809200 0 0 WET}
- {1272758400 3600 1 WEST}
- {1281222000 0 0 WET}
- {1301788800 3600 1 WEST}
- {1312066800 0 0 WET}
- {1335664800 3600 1 WEST}
- {1342749600 0 0 WET}
- {1345428000 3600 1 WEST}
- {1348970400 0 0 WET}
- {1367114400 3600 1 WEST}
- {1373162400 0 0 WET}
- {1376100000 3600 1 WEST}
- {1382839200 0 0 WET}
- {1396144800 3600 1 WEST}
- {1403920800 0 0 WET}
- {1406944800 3600 1 WEST}
- {1414288800 0 0 WET}
- {1427594400 3600 1 WEST}
- {1434247200 0 0 WET}
- {1437271200 3600 1 WEST}
- {1445738400 0 0 WET}
- {1459044000 3600 1 WEST}
- {1465092000 0 0 WET}
- {1468116000 3600 1 WEST}
- {1477792800 0 0 WET}
- {1490493600 3600 1 WEST}
- {1495332000 0 0 WET}
- {1498960800 3600 1 WEST}
- {1509242400 0 0 WET}
- {1521943200 3600 1 WEST}
- {1526176800 0 0 WET}
- {1529200800 3600 1 WEST}
- {1540692000 0 0 WET}
- {1553997600 3600 1 WEST}
- {1557021600 0 0 WET}
- {1560045600 3600 1 WEST}
- {1572141600 0 0 WET}
- {1585447200 3600 1 WEST}
- {1587261600 0 0 WET}
- {1590285600 3600 1 WEST}
- {1603591200 0 0 WET}
- {1616896800 3600 1 WEST}
- {1618106400 0 0 WET}
- {1621130400 3600 1 WEST}
- {1635645600 0 0 WET}
- {1651975200 3600 1 WEST}
- {1667095200 0 0 WET}
- {1682215200 3600 1 WEST}
- {1698544800 0 0 WET}
- {1713060000 3600 1 WEST}
- {1729994400 0 0 WET}
- {1743904800 3600 1 WEST}
- {1761444000 0 0 WET}
- {1774749600 3600 1 WEST}
- {1792893600 0 0 WET}
- {1806199200 3600 1 WEST}
- {1824948000 0 0 WET}
- {1837648800 3600 1 WEST}
- {1856397600 0 0 WET}
- {1869098400 3600 1 WEST}
- {1887847200 0 0 WET}
- {1901152800 3600 1 WEST}
- {1919296800 0 0 WET}
- {1932602400 3600 1 WEST}
- {1950746400 0 0 WET}
- {1964052000 3600 1 WEST}
- {1982800800 0 0 WET}
- {1995501600 3600 1 WEST}
- {2014250400 0 0 WET}
- {2026951200 3600 1 WEST}
- {2045700000 0 0 WET}
- {2058400800 3600 1 WEST}
- {2077149600 0 0 WET}
- {2090455200 3600 1 WEST}
- {2107994400 0 0 WET}
- {2108602800 0 0 WET}
- {2121904800 3600 1 WEST}
- {2138234400 0 0 WET}
- {2140052400 0 0 WET}
- {2153354400 3600 1 WEST}
- {2172103200 0 0 WET}
- {2184804000 3600 1 WEST}
- {2203552800 0 0 WET}
- {2216253600 3600 1 WEST}
- {2235002400 0 0 WET}
- {2248308000 3600 1 WEST}
- {2266452000 0 0 WET}
- {2279757600 3600 1 WEST}
- {2297901600 0 0 WET}
- {2311207200 3600 1 WEST}
- {2329351200 0 0 WET}
- {2342656800 3600 1 WEST}
- {2361405600 0 0 WET}
- {2374106400 3600 1 WEST}
- {2392855200 0 0 WET}
- {2405556000 3600 1 WEST}
- {2424304800 0 0 WET}
- {2437610400 3600 1 WEST}
- {2455754400 0 0 WET}
- {2469060000 3600 1 WEST}
- {2487204000 0 0 WET}
- {2500509600 3600 1 WEST}
- {2519258400 0 0 WET}
- {2531959200 3600 1 WEST}
- {2550708000 0 0 WET}
- {2563408800 3600 1 WEST}
- {2582157600 0 0 WET}
- {2595463200 3600 1 WEST}
- {2613607200 0 0 WET}
- {2626912800 3600 1 WEST}
- {2645056800 0 0 WET}
- {2658362400 3600 1 WEST}
- {2676506400 0 0 WET}
- {2689812000 3600 1 WEST}
- {2708560800 0 0 WET}
- {2721261600 3600 1 WEST}
- {2740010400 0 0 WET}
- {2752711200 3600 1 WEST}
- {2771460000 0 0 WET}
- {2784765600 3600 1 WEST}
- {2802909600 0 0 WET}
- {2816215200 3600 1 WEST}
- {2834359200 0 0 WET}
- {2847664800 3600 1 WEST}
- {2866413600 0 0 WET}
- {2879114400 3600 1 WEST}
- {2897863200 0 0 WET}
- {2910564000 3600 1 WEST}
- {2929312800 0 0 WET}
- {2942013600 3600 1 WEST}
- {2960762400 0 0 WET}
- {2974068000 3600 1 WEST}
- {2992212000 0 0 WET}
- {3005517600 3600 1 WEST}
- {3023661600 0 0 WET}
- {3036967200 3600 1 WEST}
- {3055716000 0 0 WET}
- {3068416800 3600 1 WEST}
- {3087165600 0 0 WET}
- {3099866400 3600 1 WEST}
- {3118615200 0 0 WET}
- {3131920800 3600 1 WEST}
- {3150064800 0 0 WET}
- {3163370400 3600 1 WEST}
- {3181514400 0 0 WET}
- {3194820000 3600 1 WEST}
- {3212964000 0 0 WET}
- {3226269600 3600 1 WEST}
- {3245018400 0 0 WET}
- {3257719200 3600 1 WEST}
- {3276468000 0 0 WET}
- {3289168800 3600 1 WEST}
- {3307917600 0 0 WET}
- {3321223200 3600 1 WEST}
- {3339367200 0 0 WET}
- {3352672800 3600 1 WEST}
- {3370816800 0 0 WET}
- {3384122400 3600 1 WEST}
- {3402871200 0 0 WET}
- {3415572000 3600 1 WEST}
- {3434320800 0 0 WET}
- {3447021600 3600 1 WEST}
- {3465770400 0 0 WET}
- {3479076000 3600 1 WEST}
- {3497220000 0 0 WET}
- {3510525600 3600 1 WEST}
- {3528669600 0 0 WET}
- {3541975200 3600 1 WEST}
- {3560119200 0 0 WET}
- {3573424800 3600 1 WEST}
- {3592173600 0 0 WET}
- {3604874400 3600 1 WEST}
- {3623623200 0 0 WET}
- {3636324000 3600 1 WEST}
- {3655072800 0 0 WET}
- {3668378400 3600 1 WEST}
- {3686522400 0 0 WET}
- {3699828000 3600 1 WEST}
- {3717972000 0 0 WET}
- {3731277600 3600 1 WEST}
- {3750026400 0 0 WET}
- {3762727200 3600 1 WEST}
- {3781476000 0 0 WET}
- {3794176800 3600 1 WEST}
- {3812925600 0 0 WET}
- {3825626400 3600 1 WEST}
- {3844375200 0 0 WET}
- {3857680800 3600 1 WEST}
- {3875824800 0 0 WET}
- {3889130400 3600 1 WEST}
- {3907274400 0 0 WET}
- {3920580000 3600 1 WEST}
- {3939328800 0 0 WET}
- {3952029600 3600 1 WEST}
- {3970778400 0 0 WET}
- {3983479200 3600 1 WEST}
- {4002228000 0 0 WET}
- {4015533600 3600 1 WEST}
- {4033677600 0 0 WET}
- {4046983200 3600 1 WEST}
- {4065127200 0 0 WET}
- {4078432800 3600 1 WEST}
- {4096576800 0 0 WET}
+ {198291600 0 0 +00}
+ {199756800 3600 1 +00}
+ {207702000 0 0 +00}
+ {231292800 3600 1 +00}
+ {244249200 0 0 +00}
+ {265507200 3600 1 +00}
+ {271033200 0 0 +00}
+ {1212278400 3600 1 +00}
+ {1220223600 0 0 +00}
+ {1243814400 3600 1 +00}
+ {1250809200 0 0 +00}
+ {1272758400 3600 1 +00}
+ {1281222000 0 0 +00}
+ {1301788800 3600 1 +00}
+ {1312066800 0 0 +00}
+ {1335664800 3600 1 +00}
+ {1342749600 0 0 +00}
+ {1345428000 3600 1 +00}
+ {1348970400 0 0 +00}
+ {1367114400 3600 1 +00}
+ {1373162400 0 0 +00}
+ {1376100000 3600 1 +00}
+ {1382839200 0 0 +00}
+ {1396144800 3600 1 +00}
+ {1403920800 0 0 +00}
+ {1406944800 3600 1 +00}
+ {1414288800 0 0 +00}
+ {1427594400 3600 1 +00}
+ {1434247200 0 0 +00}
+ {1437271200 3600 1 +00}
+ {1445738400 0 0 +00}
+ {1459044000 3600 1 +00}
+ {1465092000 0 0 +00}
+ {1468116000 3600 1 +00}
+ {1477792800 0 0 +00}
+ {1490493600 3600 1 +00}
+ {1495332000 0 0 +00}
+ {1498960800 3600 1 +00}
+ {1509242400 0 0 +00}
+ {1521943200 3600 1 +00}
+ {1526176800 0 0 +00}
+ {1529200800 3600 1 +00}
+ {1540598400 3600 0 +01}
}
diff --git a/library/tzdata/Pacific/Honolulu b/library/tzdata/Pacific/Honolulu
index 5e70598..7d03b45 100644
--- a/library/tzdata/Pacific/Honolulu
+++ b/library/tzdata/Pacific/Honolulu
@@ -4,8 +4,9 @@ set TZData(:Pacific/Honolulu) {
{-9223372036854775808 -37886 0 LMT}
{-2334101314 -37800 0 HST}
{-1157283000 -34200 1 HDT}
- {-1155436200 -37800 0 HST}
- {-880198200 -34200 1 HDT}
+ {-1155436200 -34200 0 HST}
+ {-880201800 -34200 1 HWT}
+ {-769395600 -34200 1 HPT}
{-765376200 -37800 0 HST}
{-712150200 -36000 0 HST}
}
diff --git a/tests/all.tcl b/tests/all.tcl
index e14bd9c..89a4f1a 100644
--- a/tests/all.tcl
+++ b/tests/all.tcl
@@ -22,5 +22,7 @@ if {[singleProcess]} {
interp debug {} -frame 1
}
-runAllTests
+set ErrorOnFailures [info exists env(ERROR_ON_FAILURES)]
+unset -nocomplain env(ERROR_ON_FAILURES)
+if {[runAllTests] && $ErrorOnFailures} {exit 1}
proc exit args {}
diff --git a/tests/assemble.test b/tests/assemble.test
index d7c47a9..05c1f9b 100644
--- a/tests/assemble.test
+++ b/tests/assemble.test
@@ -12,7 +12,7 @@
# Commands covered: assemble
if {"::tcltest" ni [namespace children]} {
- package require tcltest 2.2
+ package require tcltest 2.5
namespace import -force ::tcltest::*
}
namespace eval tcl::unsupported {namespace export assemble}
@@ -852,10 +852,11 @@ test assemble-8.5 {bad context} {
-body {
namespace eval assem {
set x 1
- list [catch {assemble {load x}} result opts] $result [dict get $opts -errorcode]
+ assemble {load x}
}
}
- -result {1 {cannot use this instruction to create a variable in a non-proc context} {TCL ASSEM LVT}}
+ -result {cannot use this instruction to create a variable in a non-proc context}
+ -errorCode {TCL ASSEM LVT}
-cleanup {namespace delete assem}
}
test assemble-8.6 {load1} {
@@ -1110,10 +1111,10 @@ test assemble-9.6 {concat} {
}
test assemble-9.7 {concat} {
-body {
- list [catch {assemble {concat 0}} result] $result $::errorCode
+ assemble {concat 0}
}
- -result {1 {operand must be positive} {TCL ASSEM POSITIVE}}
- -cleanup {unset result}
+ -result {operand must be positive}
+ -errorCode {TCL ASSEM POSITIVE}
}
# assemble-10 -- eval and expr
diff --git a/tests/dict.test b/tests/dict.test
index a6b0cb4..904ec53 100644
--- a/tests/dict.test
+++ b/tests/dict.test
@@ -10,7 +10,7 @@
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
- package require tcltest 2
+ package require tcltest 2.5
namespace import -force ::tcltest::*
}
@@ -175,11 +175,7 @@ test dict-4.12 {dict replace command: canonicality is forced} {
} {a e c d}
test dict-4.13 {dict replace command: type check is mandatory} -body {
dict replace { a b c d e }
-} -returnCodes error -result {missing value to go with key}
-test dict-4.13a {dict replace command: type check is mandatory} {
- catch {dict replace { a b c d e }} -> opt
- dict get $opt -errorcode
-} {TCL VALUE DICTIONARY}
+} -errorCode {TCL VALUE DICTIONARY} -result {missing value to go with key}
test dict-4.14 {dict replace command: type check is mandatory} -body {
dict replace { a b {}c d }
} -returnCodes error -result {dict element in braces followed by "c" instead of space}
@@ -203,11 +199,7 @@ test dict-4.16a {dict replace command: type check is mandatory} {
} {TCL VALUE DICTIONARY QUOTE}
test dict-4.17 {dict replace command: type check is mandatory} -body {
dict replace " a b \{c d "
-} -returnCodes error -result {unmatched open brace in dict}
-test dict-4.17a {dict replace command: type check is mandatory} {
- catch {dict replace " a b \{c d "} -> opt
- dict get $opt -errorcode
-} {TCL VALUE DICTIONARY BRACE}
+} -errorCode {TCL VALUE DICTIONARY BRACE} -result {unmatched open brace in dict}
test dict-4.18 {dict replace command: canonicality forcing doesn't leak} {
set example { a b c d }
list $example [dict replace $example]
diff --git a/tests/ioCmd.test b/tests/ioCmd.test
index 948671e..68bc542 100644
--- a/tests/ioCmd.test
+++ b/tests/ioCmd.test
@@ -14,7 +14,7 @@
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
- package require tcltest 2
+ package require tcltest 2.5
namespace import -force ::tcltest::*
}
@@ -154,10 +154,10 @@ test iocmd-4.11 {read command} {
test iocmd-4.12 {read command} -setup {
set f [open $path(test1)]
} -body {
- list [catch {read $f 12z} msg] $msg $::errorCode
+ read $f 12z
} -cleanup {
close $f
-} -result {1 {expected non-negative integer but got "12z"} {TCL VALUE NUMBER}}
+} -result {expected non-negative integer but got "12z"} -errorCode {TCL VALUE NUMBER}
test iocmd-5.1 {seek command} -returnCodes error -body {
seek
diff --git a/tests/source.test b/tests/source.test
index 0235bd1..8b146d3 100644
--- a/tests/source.test
+++ b/tests/source.test
@@ -12,8 +12,8 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-if {[catch {package require tcltest 2.1}]} {
- puts stderr "Skipping tests in [info script]. tcltest 2.1 required."
+if {[catch {package require tcltest 2.5}]} {
+ puts stderr "Skipping tests in [info script]. tcltest 2.5 required."
return
}
@@ -103,10 +103,9 @@ test source-2.6 {source error conditions} -setup {
set sourcefile [makeFile {} _non_existent_]
removeFile _non_existent_
} -body {
- list [catch {source $sourcefile} msg] $msg $::errorCode
-} -match listGlob -result [list 1 \
- {couldn't read file "*_non_existent_": no such file or directory} \
- {POSIX ENOENT {no such file or directory}}]
+ source $sourcefile
+} -match glob -result {couldn't read file "*_non_existent_": no such file or directory} \
+ -errorCode {POSIX ENOENT {no such file or directory}}
test source-2.7 {utf-8 with BOM} -setup {
set sourcefile [makeFile {} source.file]
} -body {
diff --git a/tests/tcltest.test b/tests/tcltest.test
index 1487865..ca720ee 100644
--- a/tests/tcltest.test
+++ b/tests/tcltest.test
@@ -1207,7 +1207,7 @@ test tcltest-21.2 {force a test command failure} {
} {1}
}
-returnCodes 1
- -result {bad option "1": must be -body, -cleanup, -constraints, -errorOutput, -match, -output, -result, -returnCodes, or -setup}
+ -result {bad option "1": must be -body, -cleanup, -constraints, -errorCode, -errorOutput, -match, -output, -result, -returnCodes, or -setup}
}
test tcltest-21.3 {test command with setup} {
@@ -1300,7 +1300,7 @@ test tcltest-21.7 {test command - bad flag} {
}
}
-returnCodes 1
- -result {bad option "-foobar": must be -body, -cleanup, -constraints, -errorOutput, -match, -output, -result, -returnCodes, or -setup}
+ -result {bad option "-foobar": must be -body, -cleanup, -constraints, -errorCode, -errorOutput, -match, -output, -result, -returnCodes, or -setup}
}
# alternate test command format (these are the same as 21.1-21.6, with the
@@ -1320,7 +1320,7 @@ test tcltest-21.8 {force a test command failure} \
} \
-returnCodes 1 \
-cleanup {set ::tcltest::currentFailure $fail} \
- -result {bad option "1": must be -body, -cleanup, -constraints, -errorOutput, -match, -output, -result, -returnCodes, or -setup}
+ -result {bad option "1": must be -body, -cleanup, -constraints, -errorCode, -errorOutput, -match, -output, -result, -returnCodes, or -setup}
test tcltest-21.9 {test command with setup} \
-setup {set foo 1} \
diff --git a/tests/winDde.test b/tests/winDde.test
index f04fb45..1fa7e86 100644
--- a/tests/winDde.test
+++ b/tests/winDde.test
@@ -20,7 +20,7 @@ testConstraint dde 0
if {[testConstraint win]} {
if {![catch {
::tcltest::loadTestedCommands
- set ::ddever [package require dde 1.4.0]
+ set ::ddever [package require dde 1.4.1]
set ::ddelib [lindex [package ifneeded dde $::ddever] 1]}]} {
testConstraint dde 1
}
@@ -104,7 +104,7 @@ proc createChildProcess {ddeServerName args} {
# -------------------------------------------------------------------------
test winDde-1.0 {check if we are testing the right dll} {win dde} {
set ::ddever
-} {1.4.0}
+} {1.4.1}
test winDde-1.1 {Settings the server's topic name} -constraints dde -body {
list [dde servername foobar] [dde servername] [dde servername self]
diff --git a/unix/Makefile.in b/unix/Makefile.in
index b2ea458..b4fd97a 100644
--- a/unix/Makefile.in
+++ b/unix/Makefile.in
@@ -932,9 +932,9 @@ install-libraries: libraries
@echo "Installing package msgcat 1.7.0 as a Tcl Module"
@$(INSTALL_DATA) $(TOP_DIR)/library/msgcat/msgcat.tcl \
"$(MODULE_INSTALL_DIR)"/tcl8/8.7/msgcat-1.7.0.tm
- @echo "Installing package tcltest 2.4.1 as a Tcl Module"
+ @echo "Installing package tcltest 2.5.0 as a Tcl Module"
@$(INSTALL_DATA) $(TOP_DIR)/library/tcltest/tcltest.tcl \
- "$(MODULE_INSTALL_DIR)"/tcl8/8.5/tcltest-2.4.1.tm
+ "$(MODULE_INSTALL_DIR)"/tcl8/8.5/tcltest-2.5.0.tm
@echo "Installing package platform 1.0.14 as a Tcl Module"
@$(INSTALL_DATA) $(TOP_DIR)/library/platform/platform.tcl \
"$(MODULE_INSTALL_DIR)"/tcl8/8.4/platform-1.0.14.tm
diff --git a/win/Makefile.in b/win/Makefile.in
index 2148e3e..8199a40 100644
--- a/win/Makefile.in
+++ b/win/Makefile.in
@@ -868,7 +868,7 @@ test-tcl: binaries $(TCLSH) $(CAT32) $(TEST_DLL_FILE)
$(WINE) ./$(TCLSH) "$(ROOT_DIR_NATIVE)/tests/all.tcl" $(TESTFLAGS) \
-load "package ifneeded Tcltest ${VERSION}@TCL_PATCH_LEVEL@ [list load [file normalize ${TEST_DLL_FILE}] Tcltest]; \
package ifneeded tcltests 0.1 \"[list source [file normalize $(ROOT_DIR_NATIVE)/tests/tcltests.tcl]];package provide tcltests 0.1\"; \
- package ifneeded dde 1.4.0 [list load [file normalize ${DDE_DLL_FILE}] dde]; \
+ 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]" | $(WINE) ./$(CAT32)
# Useful target to launch a built tclsh with the proper path,...
@@ -876,7 +876,7 @@ runtest: binaries $(TCLSH) $(TEST_DLL_FILE)
@TCL_LIBRARY="$(LIBRARY_DIR)"; export TCL_LIBRARY; \
$(WINE) ./$(TCLSH) $(TESTFLAGS) -load "package ifneeded Tcltest ${VERSION}@TCL_PATCH_LEVEL@ [list load [file normalize ${TEST_DLL_FILE}] Tcltest]; \
package ifneeded tcltests 0.1 \"[list source [file normalize $(ROOT_DIR_NATIVE)/tests/tcltests.tcl]];package provide tcltests 0.1\"; \
- package ifneeded dde 1.4.0 [list load [file normalize ${DDE_DLL_FILE}] dde]; \
+ 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/makefile.vc b/win/makefile.vc
index 392e6b4..1278a41 100644
--- a/win/makefile.vc
+++ b/win/makefile.vc
@@ -392,7 +392,7 @@ test: test-core test-pkgs
test-core: setup $(TCLTEST) dlls
set TCL_LIBRARY=$(ROOT:\=/)/library
$(DEBUGGER) $(TCLTEST) "$(ROOT:\=/)/tests/all.tcl" $(TESTFLAGS) -loadfile <<
- package ifneeded dde 1.4.0 [list load "$(TCLDDELIB:\=/)" dde]
+ package ifneeded dde 1.4.1 [list load "$(TCLDDELIB:\=/)" dde]
package ifneeded registry 1.3.3 [list load "$(TCLREGLIB:\=/)" registry]
<<
diff --git a/win/tclWinDde.c b/win/tclWinDde.c
index 52bcd42..38f1d88 100644
--- a/win/tclWinDde.c
+++ b/win/tclWinDde.c
@@ -17,6 +17,7 @@
#include "tclInt.h"
#include <dde.h>
#include <ddeml.h>
+#include <tchar.h>
#if !defined(NDEBUG)
/* test POKE server Implemented for debug mode only */
@@ -50,13 +51,13 @@ typedef struct Conversation {
Tcl_Obj *returnPackagePtr; /* The result package for this conversation. */
} Conversation;
-struct DdeEnumServices {
+typedef struct {
Tcl_Interp *interp;
int result;
ATOM service;
ATOM topic;
HWND hwnd;
-};
+} DdeEnumServices;
typedef struct {
Conversation *currentConversations;
@@ -78,7 +79,7 @@ static DWORD ddeInstance; /* The application instance handle given to us
* by DdeInitialize. */
static int ddeIsServer = 0;
-#define TCL_DDE_VERSION "1.4.0"
+#define TCL_DDE_VERSION "1.4.1"
#define TCL_DDE_PACKAGE_NAME "dde"
#define TCL_DDE_SERVICE_NAME TEXT("TclEval")
#define TCL_DDE_EXECUTE_RESULT TEXT("$TCLEVAL$EXECUTE$RESULT")
@@ -95,7 +96,7 @@ 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);
@@ -116,8 +117,9 @@ static int DdeObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
-DLLEXPORT int Dde_Init(Tcl_Interp *interp);
-DLLEXPORT int Dde_SafeInit(Tcl_Interp *interp);
+
+DLLEXPORT int Dde_Init(Tcl_Interp *interp);
+DLLEXPORT int Dde_SafeInit(Tcl_Interp *interp);
/*
*----------------------------------------------------------------------
@@ -388,9 +390,9 @@ DdeSetServerName(
* We have found a unique name. Now add it to the registry.
*/
- riPtr = ckalloc(sizeof(RegisteredInterp));
+ riPtr = (RegisteredInterp *) Tcl_Alloc(sizeof(RegisteredInterp));
riPtr->interp = interp;
- riPtr->name = ckalloc((_tcslen(actualName) + 1) * sizeof(TCHAR));
+ riPtr->name = (TCHAR *) Tcl_Alloc((_tcslen(actualName) + 1) * sizeof(TCHAR));
riPtr->nextPtr = tsdPtr->interpListPtr;
riPtr->handlerPtr = handlerPtr;
if (riPtr->handlerPtr != NULL) {
@@ -491,7 +493,7 @@ DeleteProc(
prevPtr->nextPtr = searchPtr->nextPtr;
}
}
- ckfree(riPtr->name);
+ Tcl_Free((char *) riPtr->name);
if (riPtr->handlerPtr) {
Tcl_DecrRefCount(riPtr->handlerPtr);
}
@@ -529,7 +531,7 @@ 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));
@@ -611,7 +613,7 @@ DdeServerProc(
/* Transaction-dependent data. */
{
Tcl_DString dString;
- int len;
+ size_t len;
DWORD dlen;
TCHAR *utilString;
Tcl_Obj *ddeObjectPtr;
@@ -661,7 +663,7 @@ DdeServerProc(
for (riPtr = tsdPtr->interpListPtr; riPtr != NULL;
riPtr = riPtr->nextPtr) {
if (_tcsicmp(riPtr->name, utilString) == 0) {
- convPtr = ckalloc(sizeof(Conversation));
+ convPtr = (Conversation *) Tcl_Alloc(sizeof(Conversation));
convPtr->nextPtr = tsdPtr->currentConversations;
convPtr->returnPackagePtr = NULL;
convPtr->hConv = hConv;
@@ -691,7 +693,7 @@ DdeServerProc(
if (convPtr->returnPackagePtr != NULL) {
Tcl_DecrRefCount(convPtr->returnPackagePtr);
}
- ckfree(convPtr);
+ Tcl_Free((char *) convPtr);
break;
}
}
@@ -717,22 +719,24 @@ DdeServerProc(
}
if (convPtr != NULL) {
+ Tcl_DString dsBuf;
char *returnString;
len = DdeQueryString(ddeInstance, ddeItem, NULL, 0, CP_WINUNICODE);
Tcl_DStringInit(&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_WINUNICODE);
if (_tcsicmp(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 = sizeof(TCHAR) * len + 1;
+ 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);
@@ -742,18 +746,18 @@ DdeServerProc(
} else {
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 = sizeof(TCHAR) * 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,
@@ -764,6 +768,7 @@ DdeServerProc(
Tcl_DStringFree(&ds);
}
}
+ Tcl_DStringFree(&dsBuf);
Tcl_DStringFree(&dString);
}
return ddeReturn;
@@ -788,26 +793,30 @@ DdeServerProc(
}
if (convPtr && !Tcl_IsSafe(convPtr->riPtr->interp)) {
- Tcl_DString ds;
+ Tcl_DString ds, ds2;
Tcl_Obj *variableObjPtr;
+ DWORD len2;
- len = DdeQueryString(ddeInstance, ddeItem, NULL, 0, CP_WINUNICODE);
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, &dlen);
- if (uFmt == CF_TEXT) {
- variableObjPtr = Tcl_NewStringObj((char *)utilString, -1);
- } else {
- variableObjPtr = Tcl_NewUnicodeObj(utilString, -1);
+ 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;
@@ -848,8 +857,12 @@ DdeServerProc(
ddeObjectPtr = Tcl_NewStringObj(string, dlen);
} else {
/* unicode */
- dlen >>= 1;
- ddeObjectPtr = Tcl_NewUnicodeObj((Tcl_UniChar *)utilString, 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);
@@ -1014,7 +1027,7 @@ MakeDdeConnection(
static int
DdeCreateClient(
- struct DdeEnumServices *es)
+ DdeEnumServices *es)
{
WNDCLASSEX wc;
static const TCHAR *szDdeClientClassName = TEXT("TclEval client class");
@@ -1024,7 +1037,7 @@ DdeCreateClient(
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.
@@ -1046,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);
@@ -1072,18 +1085,18 @@ DdeServicesOnAck(
HWND hwndRemote = (HWND)wParam;
ATOM service = (ATOM)LOWORD(lParam);
ATOM topic = (ATOM)HIWORD(lParam);
- struct DdeEnumServices *es;
+ 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);
@@ -1130,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,
@@ -1144,7 +1157,7 @@ DdeGetServicesList(
const TCHAR *serviceName,
const TCHAR *topicName)
{
- struct DdeEnumServices es;
+ DdeEnumServices es;
es.interp = interp;
es.result = TCL_OK;
@@ -1265,7 +1278,8 @@ DdeObjCmd(
"-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;
@@ -1274,6 +1288,7 @@ DdeObjCmd(
const char *string;
DWORD ddeResult;
Tcl_Obj *objPtr, *handlerPtr = NULL;
+ Tcl_DString serviceBuf, topicBuf, itemBuf;
/*
* Initialize DDE server/client
@@ -1289,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++) {
@@ -1338,7 +1356,7 @@ DdeObjCmd(
if (objc == 5) {
firstArg = 2;
break;
- } else if (objc >= 6 && objc <= 7) {
+ } else if ((objc >= 6) && (objc <= 7)) {
firstArg = objc - 3;
for (i = 2; i < firstArg; i++) {
if (Tcl_GetIndexFromObj(interp, objv[i], ddeExecOptions,
@@ -1423,7 +1441,12 @@ DdeObjCmd(
Initialize();
if (firstArg != 1) {
- serviceName = Tcl_GetUnicodeFromObj(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;
}
@@ -1436,7 +1459,11 @@ DdeObjCmd(
}
if ((index != DDE_SERVERNAME) && (index != DDE_EVAL)) {
- topicName = (TCHAR *) Tcl_GetUnicodeFromObj(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 {
@@ -1450,7 +1477,12 @@ DdeObjCmd(
serviceName = DdeSetServerName(interp, serviceName, flags,
handlerPtr);
if (serviceName != NULL) {
- Tcl_SetObjResult(interp, Tcl_NewUnicodeObj((Tcl_UniChar *) 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);
}
@@ -1458,20 +1490,27 @@ DdeObjCmd(
case DDE_EXECUTE: {
int dataLength;
- const Tcl_UniChar *dataString;
+ const void *dataString;
+ Tcl_DString dsBuf;
+ Tcl_DStringInit(&dsBuf);
if (flags & DDE_FLAG_BINARY) {
- dataString = (const Tcl_UniChar *)
+ dataString =
Tcl_GetByteArrayFromObj(objv[firstArg + 2], &dataLength);
} else {
- dataString =
- Tcl_GetUnicodeFromObj(objv[firstArg + 2], &dataLength);
- dataLength = (dataLength + 1) * sizeof(Tcl_UniChar);
+ 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;
@@ -1481,6 +1520,7 @@ DdeObjCmd(
DdeFreeStringHandle(ddeInstance, ddeTopic);
if (hConv == NULL) {
+ Tcl_DStringFree(&dsBuf);
SetDdeError(interp);
result = TCL_ERROR;
break;
@@ -1506,11 +1546,17 @@ DdeObjCmd(
SetDdeError(interp);
result = TCL_ERROR;
}
+ Tcl_DStringFree(&dsBuf);
break;
}
case DDE_REQUEST: {
- const TCHAR *itemString = (TCHAR *) Tcl_GetUnicodeFromObj(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,
@@ -1538,18 +1584,23 @@ DdeObjCmd(
result = TCL_ERROR;
} else {
DWORD tmp;
- const Tcl_UniChar *dataString = (const Tcl_UniChar *) 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 {
- tmp >>= 1;
- if (tmp && !dataString[(tmp-1)]) {
- --tmp;
+ Tcl_DString dsBuf;
+
+ if ((tmp >= sizeof(TCHAR))
+ && !dataString[tmp / sizeof(TCHAR) - 1]) {
+ tmp -= sizeof(TCHAR);
}
- returnObjPtr = Tcl_NewUnicodeObj(dataString,
- (int) tmp);
+ Tcl_WinTCharToUtf(dataString, tmp, &dsBuf);
+ returnObjPtr =
+ Tcl_NewStringObj(Tcl_DStringValue(&dsBuf),
+ Tcl_DStringLength(&dsBuf));
+ Tcl_DStringFree(&dsBuf);
}
DdeUnaccessData(ddeData);
DdeFreeDataHandle(ddeData);
@@ -1560,14 +1611,18 @@ DdeObjCmd(
result = TCL_ERROR;
}
}
-
break;
}
case DDE_POKE: {
- const TCHAR *itemString = (TCHAR *) Tcl_GetUnicodeFromObj(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));
@@ -1575,13 +1630,17 @@ DdeObjCmd(
result = TCL_ERROR;
goto cleanup;
}
+ 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_GetUnicodeFromObj(objv[firstArg + 3], &length);
- length = 2 * length + 1;
+ Tcl_WinUtfToTChar(data, length, &dsBuf);
+ length = Tcl_DStringLength(&dsBuf) + sizeof(TCHAR);
}
hConv = DdeConnect(ddeInstance, ddeService, ddeTopic, NULL);
@@ -1606,6 +1665,7 @@ DdeObjCmd(
result = TCL_ERROR;
}
}
+ Tcl_DStringFree(&dsBuf);
break;
}
@@ -1664,7 +1724,7 @@ DdeObjCmd(
* referring to deallocated objects.
*/
- if (Tcl_IsSafe(riPtr->interp) && riPtr->handlerPtr == NULL) {
+ 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));
@@ -1723,6 +1783,8 @@ DdeObjCmd(
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.
@@ -1738,9 +1800,14 @@ DdeObjCmd(
}
objPtr = Tcl_ConcatObj(objc, objv);
- string = (const char *) Tcl_GetUnicodeFromObj(objPtr, &length);
- ddeItemData = DdeCreateDataHandle(ddeInstance,
- (BYTE *) string, (DWORD) 2*length+2, 0, 0, CF_UNICODETEXT, 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,
@@ -1769,7 +1836,7 @@ DdeObjCmd(
if (!(flags & DDE_FLAG_ASYNC)) {
Tcl_Obj *resultPtr;
- Tcl_UniChar *ddeDataString;
+ TCHAR *ddeDataString;
/*
* The return handle has a two or four element list in it. The
@@ -1780,13 +1847,17 @@ DdeObjCmd(
* variable "errorInfo".
*/
- resultPtr = Tcl_NewObj();
length = DdeGetData(ddeData, NULL, 0, 0);
- ddeDataString = ckalloc(length);
+ ddeDataString = (TCHAR *) Tcl_Alloc(length);
DdeGetData(ddeData, (BYTE *) ddeDataString, (DWORD) length, 0);
- length = (length >> 1) - 1;
- resultPtr = Tcl_NewUnicodeObj(ddeDataString, length);
- ckfree(ddeDataString);
+ 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);
@@ -1836,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-09-28 15:39:56 (GMT)