summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--ChangeLog136
-rw-r--r--doc/expr.n6
-rw-r--r--generic/tcl.decls4
-rw-r--r--generic/tclCmdAH.c42
-rw-r--r--generic/tclCmdMZ.c8
-rw-r--r--generic/tclPlatDecls.h28
-rw-r--r--generic/tclStubInit.c10
-rw-r--r--library/dde/pkgIndex.tcl4
-rw-r--r--library/safe.tcl123
-rw-r--r--tests/dict.test8
-rw-r--r--tests/safe.test155
-rw-r--r--tests/switch.test22
-rw-r--r--tests/zlib.test16
-rw-r--r--tools/genStubs.tcl4
-rwxr-xr-xunix/configure5
-rw-r--r--unix/configure.in5
-rwxr-xr-xwin/configure13
-rw-r--r--win/configure.in9
-rw-r--r--win/tclWinDde.c236
19 files changed, 546 insertions, 288 deletions
diff --git a/ChangeLog b/ChangeLog
index 6b02b23..e8cecb8 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,48 @@
+2012-05-17 Donal K. Fellows <dkf@users.sf.net>
+
+ * generic/tclCmdMZ.c (Tcl_SwitchObjCmd): [Bug 3106532]: Corrected
+ resulting indexes from -indexvar option to be usable with [string
+ range]; this was always the intention (and is consistent with [regexp
+ -indices] too).
+ ***POTENTIAL INCOMPATIBILITY***
+ Uses of [switch -regexp -indexvar] that previously compensated for the
+ wrong offsets (by subtracting 1 from the end indices) now do not need
+ to do so as the value is correct.
+
+ * library/safe.tcl (safe::InterpInit): Ensure that the module path is
+ constructed in the correct order.
+ (safe::AliasGlob): [Bug 2964715]: More extensive handling of what
+ globbing is required to support package loading.
+
+ * doc/expr.n: [Bug 3525462]: Corrected statement about what happens
+ when comparing "0y" and "0x12"; the previously documented behavior was
+ actually a subtle bug (now long-corrected).
+
+2012-05-16 Donal K. Fellows <dkf@users.sf.net>
+
+ * generic/tclCmdAH.c (TclMakeFileCommandSafe): [Bug 3445787]: Improve
+ the compatibility of safe interpreters' version of 'file' with that of
+ unsafe interpreters.
+ * library/safe.tcl (::safe::InterpInit): Teach the safe-interp scripts
+ about how to expose 'file' properly.
+
+2012-05-13 Jan Nijtmans <nijtmans@users.sf.net>
+
+ * win/tclWinDde.c: Protect against receiving strings without ending
+ \0, as external applications (or Tcl with TIP #106) could generate
+ that.
+
+2012-05-10 Jan Nijtmans <nijtmans@users.sf.net>
+
+ * win/tclWinDde.c: [Bug 473946]: Special characters not correctly sent
+ * library/dde/pkgIndex.tcl: Increase version to 1.3.3
+
+2012-05-10 Alexandre Ferrieux <ferrieux@users.sourceforge.net>
+
+ * {win,unix}/configure{,.in}: [Bug 2812981]: Clean up bundled
+ packages' build directory from within Tcl's ./configure, to avoid
+ stale configuration.
+
2012-05-09 Andreas Kupries <andreask@activestate.com>
* generic/tclIORChan.c [Bug 3522560]: Fixed the crash, enabled the
@@ -5,7 +50,7 @@
event(s) into the owner thread's event queue for execution in the
correct context. Renamed the ForwardOpTo...Thread() function to
match with our terminology.
-
+
* tests/ioCmd.test [Bug 3522560]: Added a test which crashes the
core if it were not disabled as knownBug. For a reflected channel
transfered to a different thread the [chan postevent] run in the
@@ -19,29 +64,30 @@
2012-05-03 Jan Nijtmans <nijtmans@users.sf.net>
- * compat/zlib/*: Upgrade to zlib 1.2.7 (pre-built dll is still 1.2.5,
+ * compat/zlib/*: Upgrade to zlib 1.2.7 (pre-built dll is still 1.2.5,
will be upgraded as soon as the official build is available)
2012-05-03 Don Porter <dgp@users.sourceforge.net>
- * tests/socket.test: [Bug 3428754] Test socket-14.2 tolerate
+ * tests/socket.test: [Bug 3428754]: Test socket-14.2 tolerate
[socket -async] connection that connects synchronously.
- * unix/tclUnixSock.c: [Bug 3428753] Fix [socket -async] connections
+ * unix/tclUnixSock.c: [Bug 3428753]: Fix [socket -async] connections
that manage to connect synchronously.
2012-05-02 Jan Nijtmans <nijtmans@users.sf.net>
- * generic/configure.in: Better detection and implementation for cpuid
- * generic/configure: instruction on Intel-derived processors, both
- * generic/tclUnixCompat.c: 32-bit and 64-bit.
- * generic/tclTest.c: Move cpuid testcase from win-specific to generic
- * win/tclWinTest.c: tests, as it should work on all Intel-related
- * tests/platform.test: platforms now
+ * generic/configure.in: Better detection and implementation for
+ * generic/configure: cpuid instruction on Intel-derived
+ * generic/tclUnixCompat.c: processors, both 32-bit and 64-bit.
+ * generic/tclTest.c: Move cpuid testcase from win-specific to
+ * win/tclWinTest.c: generic tests, as it should work on all
+ * tests/platform.test: Intel-related platforms now.
2012-04-30 Alexandre Ferrieux <ferrieux@users.sourceforge.net>
- * tests/ioCmd.test: Tame deadlocks in broken refchan tests [Bug 3522560]
+ * tests/ioCmd.test: [Bug 3522560]: Tame deadlocks in broken refchan
+ tests.
2012-04-28 Alexandre Ferrieux <ferrieux@users.sourceforge.net>
@@ -84,10 +130,11 @@
2012-04-24 Jan Nijtmans <nijtmans@users.sf.net>
- * generic/tclInt.decls: [Bug 3508771] load tclreg.dll in cygwin tclsh
- * generic/tclIntPlatDecls.h: Implement TclWinGetSockOpt, TclWinGetServByName
- * generic/tclStubInit.c: and TclWinCPUID for Cygwin
- * generic/tclUnixCompat.c:
+ * generic/tclInt.decls: [Bug 3508771]: load tclreg.dll in cygwin
+ tclsh
+ * generic/tclIntPlatDecls.h: Implement TclWinGetSockOpt,
+ * generic/tclStubInit.c: TclWinGetServByName and TclWinCPUID for
+ * generic/tclUnixCompat.c: Cygwin.
* unix/configure.in:
* unix/configure:
* unix/tclUnixCompat.c:
@@ -497,10 +544,10 @@
* generic/tcl.h: [Bug 3474726]: Eliminate detection of struct
* generic/tclWinPort.h: _stat32i64, just use _stati64 in combination
- * generic/tclFCmd.c: with _USE_32BIT_TIME_T, which is the same then.
- * generic/tclTest.c: Only keep _stat32i64 usage for cygwin, so it
- * win/configure.in: will not conflict with cygwin's own struct stat.
- * win/configure:
+ * generic/tclFCmd.c: with _USE_32BIT_TIME_T, which is the same
+ * generic/tclTest.c: then. Only keep _stat32i64 usage for cygwin,
+ * win/configure.in: so it will not conflict with cygwin's own
+ * win/configure: struct stat.
2012-01-21 Don Porter <dgp@users.sourceforge.net>
@@ -523,9 +570,9 @@
2012-01-09 Jan Nijtmans <nijtmans@users.sf.net>
- * generic/tclUtf.c: [Bug 3464428]: string is graph \u0120 is wrong
- * generic/regc_locale.c: Add table for Unicode [:cntrl:] class
- * tools/uniClass.tcl: Generate Unicode [:cntrl:] class table
+ * generic/tclUtf.c: [Bug 3464428]: [string is graph \u0120] was
+ * generic/regc_locale.c: wrong. Add table for Unicode [:cntrl:] class.
+ * tools/uniClass.tcl: Generate Unicode [:cntrl:] class table.
* tests/utf.test:
2012-01-08 Kevin B. Kenny <kennykb@acm.org>
@@ -549,7 +596,7 @@
2011-12-23 Jan Nijtmans <nijtmans@users.sf.net>
- * generic/tclUtf.c: [Bug 3464428]: string is graph \u0120 is wrong.
+ * generic/tclUtf.c: [Bug 3464428]: [string is graph \u0120] is wrong.
* generic/tclUniData.c:
* generic/regc_locale.c:
* tests/utf.test:
@@ -1337,7 +1384,8 @@
2011-06-13 Don Porter <dgp@users.sourceforge.net>
- * generic/tclStrToD.c: [Bug 3315098]: Mem leak fix from Gustaf Neumann.
+ * generic/tclStrToD.c: [Bug 3315098]: Mem leak fix from Gustaf
+ Neumann.
2011-06-08 Andreas Kupries <andreask@activestate.com>
@@ -2073,9 +2121,9 @@
* generic/tclPreserve.c: Don't miss 64-bit address bits in panic
message.
- * win/tclWinChan.c: Fix various gcc-4.5.2 64-bit warning messages
- * win/tclWinConsole.c e.g. by using full 64-bits for socket fd's
- * win/tclWinDde.c
+ * win/tclWinChan.c: Fix various gcc-4.5.2 64-bit warning
+ * win/tclWinConsole.c: messages, e.g. by using full 64-bits for
+ * win/tclWinDde.c: socket fd's
* win/tclWinPipe.c
* win/tclWinReg.c
* win/tclWinSerial.c
@@ -2484,8 +2532,8 @@
* win/cat.c: to reality. See for what's missing:
* win/tcl.m4: <https://sourceforge.net/apps/trac/mingw-w64/wiki/Unicode%20apps>
* win/configure: (re-generated)
- * win/tclWinPort.h:[Bug #3110161]: Extensions using TCHAR don't compile
- on VS2005 SP1
+ * win/tclWinPort.h: [Bug #3110161]: Extensions using TCHAR don't
+ compile on VS2005 SP1
2010-11-15 Andreas Kupries <andreask@activestate.com>
@@ -2636,9 +2684,9 @@
[dogeen-assembler-branch]
* generic/tclAssembly.c:
- * tests/assembly.test (assemble-17.15): Reworked branch handling so that
- forward branches can use jump1 (jumpTrue1, jumpFalse1). Added test
- cases that the forward branches will expand to jump4, jumpTrue4,
+ * tests/assembly.test (assemble-17.15): Reworked branch handling so
+ that forward branches can use jump1 (jumpTrue1, jumpFalse1). Added
+ test cases that the forward branches will expand to jump4, jumpTrue4,
jumpFalse4 when needed.
2010-10-23 Kevin B. Kenny <kennykb@acm.org>
@@ -2743,7 +2791,8 @@
* win/tclWinReg.c:
* win/tclWinTest.c: More cleanups
* win/tclWinFile.c: Add netapi32 to the link line, so we no longer
- * win/tcl.m4: have to use LoadLibrary to access those functions.
+ * win/tcl.m4: have to use LoadLibrary to access those
+ functions.
* win/makefile.vc:
* win/configure: (Re-generate with autoconf-2.59)
* win/rules.vc Update for VS10
@@ -3464,8 +3513,8 @@
2010-07-02 Jan Nijtmans <nijtmans@users.sf.net>
- * generic/tclInt.decls: [Bug 803489]: Tcl_FindNamespace problem in the
- * generic/tclIntDecls.h: Stubs table
+ * generic/tclInt.decls: [Bug 803489]: Tcl_FindNamespace problem in
+ * generic/tclIntDecls.h: the Stubs table
* generic/tclStubInit.c:
2010-07-02 Donal K. Fellows <dkf@users.sf.net>
@@ -5666,10 +5715,11 @@
For 32-bit builds where "long" and "int" are two names for the same
thing, this is no change at all. For 64-bit builds, though, this
causes the dp[] array of an mp_int to be made up of 32-bit elements
- instead of 64-bit elements. This is a huge improvement because details
- elsewhere in the mp_int implementation cause only 28 bits of each
- element to be actually used storing number data. Without this change
- bignums are over 50% wasted space on 64-bit systems. [Bug 2800740].
+ instead of 64-bit elements. This is a huge improvement because
+ details elsewhere in the mp_int implementation cause only 28 bits of
+ each element to be actually used storing number data. Without this
+ change bignums are over 50% wasted space on 64-bit systems. [Bug
+ 2800740].
***POTENTIAL INCOMPATIBILITY***
For 64-bit builds, callers of routines with (mp_digit) or (mp_digit *)
@@ -5795,10 +5845,10 @@
2009-10-18 Joe Mistachkin <joe@mistachkin.com>
* tests/thread.test (thread-4.[345]): [Bug 1565466]: Correct tests to
- save their error state before the final call to threadReap just in case
- it triggers an "invalid thread id" error. This error can occur if one
- or more of the target threads has exited prior to the attempt to send
- it an asynchronous exit command.
+ save their error state before the final call to threadReap just in
+ case it triggers an "invalid thread id" error. This error can occur
+ if one or more of the target threads has exited prior to the attempt
+ to send it an asynchronous exit command.
2009-10-17 Donal K. Fellows <dkf@users.sf.net>
diff --git a/doc/expr.n b/doc/expr.n
index 2ecd501..7b29f81 100644
--- a/doc/expr.n
+++ b/doc/expr.n
@@ -326,6 +326,7 @@ returns \fB4.0\fR, not \fB4\fR.
String values may be used as operands of the comparison operators,
although the expression evaluator tries to do comparisons as integer
or floating-point when it can,
+i.e., when all arguments to the operator allow numeric interpretations,
except in the case of the \fBeq\fR and \fBne\fR operators.
If one of the operands of a comparison is a string and the other
has a numeric value, a canonical string representation of the numeric
@@ -337,12 +338,11 @@ is that produced by the \fB%g\fR format specifier of Tcl's
.PP
.CS
\fBexpr\fR {"0x03" > "2"}
-\fBexpr\fR {"0y" < "0x12"}
+\fBexpr\fR {"0y" > "0x12"}
.CE
.PP
both return 1. The first comparison is done using integer
-comparison, and the second is done using string comparison after
-the second operand is converted to the string \fB18\fR.
+comparison, and the second is done using string comparison.
Because of Tcl's tendency to treat values as numbers whenever
possible, it is not generally a good idea to use operators like \fB==\fR
when you really want string comparison and the values of the
diff --git a/generic/tcl.decls b/generic/tcl.decls
index 8355d99..8ab9a7c 100644
--- a/generic/tcl.decls
+++ b/generic/tcl.decls
@@ -2346,12 +2346,12 @@ declare 1 win {
################################
# Mac OS X specific functions
-declare 0 {unix macosx} {
+declare 0 macosx {
int Tcl_MacOSXOpenBundleResources(Tcl_Interp *interp,
const char *bundleName, int hasResourceFile,
int maxPathLen, char *libraryPath)
}
-declare 1 {unix macosx} {
+declare 1 macosx {
int Tcl_MacOSXOpenVersionedBundleResources(Tcl_Interp *interp,
const char *bundleName, const char *bundleVersion,
int hasResourceFile, int maxPathLen, char *libraryPath)
diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c
index 70aef8d..4292224 100644
--- a/generic/tclCmdAH.c
+++ b/generic/tclCmdAH.c
@@ -61,6 +61,7 @@ static Tcl_NRPostProc ForPostNextCallback;
static Tcl_NRPostProc ForeachLoopStep;
static Tcl_NRPostProc EvalCmdErrMsg;
+static Tcl_ObjCmdProc BadFileSubcommand;
static Tcl_ObjCmdProc FileAttrAccessTimeCmd;
static Tcl_ObjCmdProc FileAttrIsDirectoryCmd;
static Tcl_ObjCmdProc FileAttrIsExecutableCmd;
@@ -581,7 +582,7 @@ Tcl_EncodingObjCmd(
break;
}
case ENC_DIRS:
- return EncodingDirsObjCmd(dummy, interp, objc-1, objv+1);
+ return EncodingDirsObjCmd(dummy, interp, objc, objv);
case ENC_NAMES:
if (objc > 2) {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
@@ -628,10 +629,12 @@ EncodingDirsObjCmd(
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- if (objc > 2) {
+ if (objc > 3) {
Tcl_WrongNumArgs(interp, 1, objv, "?dirList?");
return TCL_ERROR;
}
+ objc -= 1;
+ objv += 1;
if (objc == 1) {
Tcl_SetObjResult(interp, Tcl_GetEncodingSearchPath());
return TCL_OK;
@@ -1057,6 +1060,8 @@ TclMakeFileCommandSafe(
unsafeInfo[i].cmdName,
Tcl_GetString(Tcl_GetObjResult(interp)));
}
+ Tcl_CreateObjCommand(interp, oldName, BadFileSubcommand,
+ (ClientData) unsafeInfo[i].cmdName, NULL);
}
}
Tcl_DStringFree(&oldBuf);
@@ -1078,6 +1083,39 @@ TclMakeFileCommandSafe(
/*
*----------------------------------------------------------------------
*
+ * BadFileSubcommand --
+ *
+ * Command used to act as a backstop implementation when subcommands of
+ * "file" are unsafe (the real implementations of the subcommands are
+ * hidden). The clientData is always the full official subcommand name.
+ *
+ * Results:
+ * A standard Tcl result (always a TCL_ERROR).
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+BadFileSubcommand(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ const char *subcommandName = (const char *) clientData;
+
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "not allowed to invoke subcommand %s of file", subcommandName));
+ Tcl_SetErrorCode(interp, "TCL", "SAFE", "SUBCOMMAND", NULL);
+ return TCL_ERROR;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* FileAttrAccessTimeCmd --
*
* This function is invoked to process the "file atime" Tcl command. See
diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c
index c5bb72d..7e94d9f 100644
--- a/generic/tclCmdMZ.c
+++ b/generic/tclCmdMZ.c
@@ -3758,8 +3758,12 @@ TclNRSwitchObjCmd(
if (indexVarObj != NULL) {
Tcl_Obj *rangeObjAry[2];
- rangeObjAry[0] = Tcl_NewLongObj(info.matches[j].start);
- rangeObjAry[1] = Tcl_NewLongObj(info.matches[j].end);
+ if (info.matches[j].end > 0) {
+ rangeObjAry[0] = Tcl_NewLongObj(info.matches[j].start);
+ rangeObjAry[1] = Tcl_NewLongObj(info.matches[j].end-1);
+ } else {
+ rangeObjAry[0] = rangeObjAry[1] = Tcl_NewIntObj(-1);
+ }
/*
* Never fails; the object is always clean at this point.
diff --git a/generic/tclPlatDecls.h b/generic/tclPlatDecls.h
index 2ed5fed..48ad390 100644
--- a/generic/tclPlatDecls.h
+++ b/generic/tclPlatDecls.h
@@ -46,19 +46,7 @@
* Exported function declarations:
*/
-#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */
-/* 0 */
-EXTERN int Tcl_MacOSXOpenBundleResources(Tcl_Interp *interp,
- const char *bundleName, int hasResourceFile,
- int maxPathLen, char *libraryPath);
-/* 1 */
-EXTERN int Tcl_MacOSXOpenVersionedBundleResources(
- Tcl_Interp *interp, const char *bundleName,
- const char *bundleVersion,
- int hasResourceFile, int maxPathLen,
- char *libraryPath);
-#endif /* UNIX */
-#ifdef __WIN32__ /* WIN */
+#if defined(__WIN32__) || defined(__CYGWIN__) /* WIN */
/* 0 */
EXTERN TCHAR * Tcl_WinUtfToTChar(const char *str, int len,
Tcl_DString *dsPtr);
@@ -83,11 +71,7 @@ typedef struct TclPlatStubs {
int magic;
const struct TclPlatStubHooks *hooks;
-#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */
- int (*tcl_MacOSXOpenBundleResources) (Tcl_Interp *interp, const char *bundleName, int hasResourceFile, int maxPathLen, char *libraryPath); /* 0 */
- int (*tcl_MacOSXOpenVersionedBundleResources) (Tcl_Interp *interp, const char *bundleName, const char *bundleVersion, int hasResourceFile, int maxPathLen, char *libraryPath); /* 1 */
-#endif /* UNIX */
-#ifdef __WIN32__ /* WIN */
+#if defined(__WIN32__) || defined(__CYGWIN__) /* WIN */
TCHAR * (*tcl_WinUtfToTChar) (const char *str, int len, Tcl_DString *dsPtr); /* 0 */
char * (*tcl_WinTCharToUtf) (const TCHAR *str, int len, Tcl_DString *dsPtr); /* 1 */
#endif /* WIN */
@@ -111,13 +95,7 @@ extern const TclPlatStubs *tclPlatStubsPtr;
* Inline function declarations:
*/
-#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */
-#define Tcl_MacOSXOpenBundleResources \
- (tclPlatStubsPtr->tcl_MacOSXOpenBundleResources) /* 0 */
-#define Tcl_MacOSXOpenVersionedBundleResources \
- (tclPlatStubsPtr->tcl_MacOSXOpenVersionedBundleResources) /* 1 */
-#endif /* UNIX */
-#ifdef __WIN32__ /* WIN */
+#if defined(__WIN32__) || defined(__CYGWIN__) /* WIN */
#define Tcl_WinUtfToTChar \
(tclPlatStubsPtr->tcl_WinUtfToTChar) /* 0 */
#define Tcl_WinTCharToUtf \
diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c
index 8864a56..fdade56 100644
--- a/generic/tclStubInit.c
+++ b/generic/tclStubInit.c
@@ -165,10 +165,6 @@ Tcl_WinTCharToUtf(
string, len, dsPtr);
}
-#define Tcl_MacOSXOpenBundleResources (int (*) ( \
- Tcl_Interp *, const char *, int, int, char *)) Tcl_WinUtfToTChar
-#define Tcl_MacOSXOpenVersionedBundleResources (int (*) ( \
- Tcl_Interp *, const char *, const char *, int, int, char *)) Tcl_WinTCharToUtf
#define TclMacOSXGetFileAttribute (int (*) (Tcl_Interp *, \
int, Tcl_Obj *, Tcl_Obj **)) TclpCreateProcess
#define TclMacOSXMatchType (int (*) (Tcl_Interp *, const char *, \
@@ -594,11 +590,7 @@ static const TclIntPlatStubs tclIntPlatStubs = {
static const TclPlatStubs tclPlatStubs = {
TCL_STUB_MAGIC,
0,
-#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */
- Tcl_MacOSXOpenBundleResources, /* 0 */
- Tcl_MacOSXOpenVersionedBundleResources, /* 1 */
-#endif /* UNIX */
-#ifdef __WIN32__ /* WIN */
+#if defined(__WIN32__) || defined(__CYGWIN__) /* WIN */
Tcl_WinUtfToTChar, /* 0 */
Tcl_WinTCharToUtf, /* 1 */
#endif /* WIN */
diff --git a/library/dde/pkgIndex.tcl b/library/dde/pkgIndex.tcl
index 9e62ac8..ce92028 100644
--- a/library/dde/pkgIndex.tcl
+++ b/library/dde/pkgIndex.tcl
@@ -1,7 +1,7 @@
if {![package vsatisfies [package provide Tcl] 8.5]} return
if {[string compare [info sharedlibextension] .dll]} return
if {[::tcl::pkgconfig get debug]} {
- package ifneeded dde 1.3.2 [list load [file join $dir tcldde13g.dll] dde]
+ package ifneeded dde 1.3.3 [list load [file join $dir tcldde13g.dll] dde]
} else {
- package ifneeded dde 1.3.2 [list load [file join $dir tcldde13.dll] dde]
+ package ifneeded dde 1.3.3 [list load [file join $dir tcldde13.dll] dde]
}
diff --git a/library/safe.tcl b/library/safe.tcl
index 95db3b2..52f6e85 100644
--- a/library/safe.tcl
+++ b/library/safe.tcl
@@ -465,8 +465,18 @@ proc ::safe::InterpInit {
# This alias lets the slave have access to a subset of the 'file'
# command functionality.
- AliasSubset $slave file \
- file dir.* join root.* ext.* tail path.* split
+ ::interp expose $slave file
+ foreach subcommand {dirname extension rootname tail} {
+ ::interp alias $slave ::tcl::file::$subcommand {} file $subcommand
+ }
+ foreach subcommand {
+ atime attributes copy delete executable exists isdirectory isfile
+ link lstat mtime mkdir nativename normalize owned readable readlink
+ rename size stat tempfile type volumes writable
+ } {
+ ::interp alias $slave ::tcl::file::$subcommand {} \
+ ::safe::BadSubcommand $slave file $subcommand
+ }
# Subcommands of info
foreach {subcommand alias} {
@@ -499,7 +509,8 @@ proc ::safe::InterpInit {
# now, after tm.tcl was loaded.
namespace upvar ::safe S$slave state
if {[llength $state(tm_path_slave)] > 0} {
- ::interp eval $slave [list ::tcl::tm::add {*}$state(tm_path_slave)]
+ ::interp eval $slave [list \
+ ::tcl::tm::add {*}[lreverse $state(tm_path_slave)]]
}
return $slave
}
@@ -679,9 +690,9 @@ proc ::safe::AliasGlob {slave args} {
}
if {$::tcl_platform(platform) eq "windows"} {
- set dirPartRE {^(.*)[\\/]}
+ set dirPartRE {^(.*)[\\/]([^\\/]*)$}
} else {
- set dirPartRE {^(.*)/}
+ set dirPartRE {^(.*)/([^/]*)$}
}
set dir {}
@@ -734,9 +745,7 @@ proc ::safe::AliasGlob {slave args} {
DirInAccessPath $slave $dir
} on error msg {
Log $slave $msg
- if {$got(-nocomplain)} {
- return
- }
+ if {$got(-nocomplain)} return
return -code error "permission denied"
}
lappend cmd -directory $dir
@@ -749,20 +758,31 @@ proc ::safe::AliasGlob {slave args} {
# Process remaining pattern arguments
set firstPattern [llength $cmd]
- while {$at < [llength $args]} {
- set opt [lindex $args $at]
- incr at
- if {[regexp $dirPartRE $opt -> thedir]} {
- try {
- set thedir [file join $virtualdir $thedir]
- DirInAccessPath $slave [TranslatePath $slave $thedir]
- } on error msg {
- Log $slave $msg
- if {$got(-nocomplain)} {
- continue
+ foreach opt [lrange $args $at end] {
+ if {![regexp $dirPartRE $opt -> thedir thefile]} {
+ set thedir .
+ }
+ if {$thedir eq "*" &&
+ ($thefile eq "pkgIndex.tcl" || $thefile eq "*.tm")} {
+ set mapped 0
+ foreach d [glob -directory [TranslatePath $slave $virtualdir] \
+ -types d -tails *] {
+ catch {
+ DirInAccessPath $slave \
+ [TranslatePath $slave [file join $virtualdir $d]]
+ lappend cmd [file join $d $thefile]
+ set mapped 1
}
- return -code error "permission denied"
}
+ if {$mapped} continue
+ }
+ try {
+ DirInAccessPath $slave [TranslatePath $slave \
+ [file join $virtualdir $thedir]]
+ } on error msg {
+ Log $slave $msg
+ if {$got(-nocomplain)} continue
+ return -code error "permission denied"
}
lappend cmd $opt
}
@@ -779,7 +799,7 @@ proc ::safe::AliasGlob {slave args} {
return -code error "script error"
}
- Log $slave "GLOB @ $entries" NOTICE
+ Log $slave "GLOB < $entries" NOTICE
# Translate path back to what the slave should see.
set res {}
@@ -791,7 +811,7 @@ proc ::safe::AliasGlob {slave args} {
lappend res $p
}
- Log $slave "GLOB @ $res" NOTICE
+ Log $slave "GLOB > $res" NOTICE
return $res
}
@@ -980,58 +1000,33 @@ proc ::safe::DirInAccessPath {slave dir} {
}
}
-# This procedure enables access from a safe interpreter to only a subset
-# of the subcommands of a command:
+# This procedure is used to report an attempt to use an unsafe member of an
+# ensemble command.
-proc ::safe::Subset {slave command okpat args} {
- set subcommand [lindex $args 0]
- if {[regexp $okpat $subcommand]} {
- return [$command {*}$args]
- }
+proc ::safe::BadSubcommand {slave command subcommand args} {
set msg "not allowed to invoke subcommand $subcommand of $command"
Log $slave $msg
- return -code error $msg
-}
-
-# This procedure installs an alias in a slave that invokes "safesubset" in
-# the master to execute allowed subcommands. It precomputes the pattern of
-# allowed subcommands; you can use wildcards in the pattern if you wish to
-# allow subcommand abbreviation.
-#
-# Syntax is: AliasSubset slave alias target subcommand1 subcommand2...
-
-proc ::safe::AliasSubset {slave alias target args} {
- set pat "^([join $args |])\$"
- ::interp alias $slave $alias {}\
- [namespace current]::Subset $slave $target $pat
+ return -code error -errorcode {TCL SAFE SUBCOMMAND} $msg
}
# AliasEncoding is the target of the "encoding" alias in safe interpreters.
proc ::safe::AliasEncoding {slave option args} {
- # Careful; do not want empty option to get through to the [string equal]
- if {[regexp {^(name.*|convert.*|)$} $option]} {
- return [::interp invokehidden $slave encoding $option {*}$args]
- }
-
- if {[string equal -length [string length $option] $option "system"]} {
- if {![llength $args]} {
- # passed all the tests , lets source it:
- try {
- return [::interp invokehidden $slave encoding system]
- } on error msg {
- Log $slave $msg
- return -code error "script error"
- }
+ # Note that [encoding dirs] is not supported in safe slaves at all
+ set subcommands {convertfrom convertto names system}
+ try {
+ set option [tcl::prefix match -error [list -level 1 -errorcode \
+ [list TCL LOOKUP INDEX option $option]] $subcommands $option]
+ # Special case: [encoding system] ok, but [encoding system foo] not
+ if {$option eq "system" && [llength $args]} {
+ return -code error -errorcode {TCL WRONGARGS} \
+ "wrong # args: should be \"encoding system\""
}
- set msg "wrong # args: should be \"encoding system\""
- set code {TCL WRONGARGS}
- } else {
- set msg "bad option \"$option\": must be convertfrom, convertto, names, or system"
- set code [list TCL LOOKUP INDEX option $option]
+ } on error {msg options} {
+ Log $slave $msg
+ return -options $options $msg
}
- Log $slave $msg
- return -code error -errorcode $code $msg
+ tailcall ::interp invokehidden $slave encoding $option {*}$args
}
# Various minor hiding of platform features. [Bug 2913625]
diff --git a/tests/dict.test b/tests/dict.test
index 5277cf6..77bacf6 100644
--- a/tests/dict.test
+++ b/tests/dict.test
@@ -1475,7 +1475,7 @@ proc linenumber {} {
dict get [info frame -1] line
}
test dict-23.1 {dict compilation crash: Bug 3487626} {
- apply {n {
+ apply {{} {apply {n {
set e {}
set k {}
dict for {a b} {c {d {e {f g}}}} {
@@ -1487,14 +1487,14 @@ test dict-23.1 {dict compilation crash: Bug 3487626} {
}
}
}
- }} [linenumber]
+ }} [linenumber]}}
} 5
test dict-23.2 {dict compilation crash: Bug 3487626} knownBug {
# Something isn't quite right in line number and continuation line
# tracking; at time of writing, this test produces 7, not 5, which
# indicates that the extra newlines in the non-script argument are
# confusing things.
- apply {n {
+ apply {{} {apply {n {
set e {}
set k {}
dict for {a {
@@ -1518,7 +1518,7 @@ j
}
}
}
- }} [linenumber]
+ }} [linenumber]}}
} 5
rename linenumber {}
diff --git a/tests/safe.test b/tests/safe.test
index 2d7f476..98d4543 100644
--- a/tests/safe.test
+++ b/tests/safe.test
@@ -27,9 +27,7 @@ set ::auto_path [info library]
# Force actual loading of the safe package because we use un exported (and
# thus un-autoindexed) APIs in this test result arguments:
catch {safe::interpConfigure}
-
-proc equiv {x} {return $x}
-
+
# testing that nested and statics do what is advertised (we use a static
# package - Tcltest - but it might be absent if we're in standard tclsh)
@@ -94,7 +92,7 @@ test safe-3.2 {calling safe::interpCreate on trusted interp} -setup {
lsort [a aliases]
} -cleanup {
safe::interpDelete a
-} -result {::tcl::info::nameofexecutable clock encoding exit file glob load source}
+} -result {::tcl::file::atime ::tcl::file::attributes ::tcl::file::copy ::tcl::file::delete ::tcl::file::dirname ::tcl::file::executable ::tcl::file::exists ::tcl::file::extension ::tcl::file::isdirectory ::tcl::file::isfile ::tcl::file::link ::tcl::file::lstat ::tcl::file::mkdir ::tcl::file::mtime ::tcl::file::nativename ::tcl::file::normalize ::tcl::file::owned ::tcl::file::readable ::tcl::file::readlink ::tcl::file::rename ::tcl::file::rootname ::tcl::file::size ::tcl::file::stat ::tcl::file::tail ::tcl::file::tempfile ::tcl::file::type ::tcl::file::volumes ::tcl::file::writable ::tcl::info::nameofexecutable clock encoding exit glob load source}
test safe-3.3 {calling safe::interpCreate on trusted interp} -setup {
catch {safe::interpDelete a}
} -body {
@@ -538,11 +536,154 @@ test safe-12.7 {glob is restricted} -setup {
set i [safe::interpCreate]
} -body {
$i eval glob *
+} -returnCodes error -cleanup {
+ safe::interpDelete $i
+} -result {permission denied}
+
+proc buildEnvironment {filename} {
+ upvar 1 testdir testdir testdir2 testdir2 testfile testfile
+ set testdir [makeDirectory deletethisdir]
+ set testdir2 [makeDirectory deletemetoo $testdir]
+ set testfile [makeFile {} $filename $testdir2]
+}
+#### New tests for Safe base glob, with patches @ Bug 2964715
+test safe-13.1 {glob is restricted [Bug 2964715]} -setup {
+ set i [safe::interpCreate]
+} -body {
+ $i eval glob *
+} -returnCodes error -cleanup {
+ safe::interpDelete $i
+} -result {permission denied}
+test safe-13.2 {mimic the valid glob call by ::tcl::tm::UnknownHandler [Bug 2964715]} -setup {
+ set i [safe::interpCreate]
+ buildEnvironment deleteme.tm
+} -body {
+ ::safe::interpAddToAccessPath $i $testdir2
+ set result [$i eval glob -nocomplain -directory $testdir2 *.tm]
+ if {$result eq [list $testfile]} {
+ return "glob match"
+ } else {
+ return "no match: $result"
+ }
+} -cleanup {
+ safe::interpDelete $i
+ removeDirectory $testdir
+} -result {glob match}
+test safe-13.3 {cf 13.2 but test glob failure when -directory is outside access path [Bug 2964715]} -setup {
+ set i [safe::interpCreate]
+ buildEnvironment deleteme.tm
+} -body {
+ $i eval glob -directory $testdir2 *.tm
+} -returnCodes error -cleanup {
+ safe::interpDelete $i
+ removeDirectory $testdir
+} -result {permission denied}
+test safe-13.4 {another valid glob call [Bug 2964715]} -setup {
+ set i [safe::interpCreate]
+ buildEnvironment deleteme.tm
+} -body {
+ ::safe::interpAddToAccessPath $i $testdir
+ ::safe::interpAddToAccessPath $i $testdir2
+ set result [$i eval \
+ glob -nocomplain -directory $testdir [file join deletemetoo *.tm]]
+ if {$result eq [list $testfile]} {
+ return "glob match"
+ } else {
+ return "no match: $result"
+ }
+} -cleanup {
+ safe::interpDelete $i
+ removeDirectory $testdir
+} -result {glob match}
+test safe-13.5 {as 13.4 but test glob failure when -directory is outside access path [Bug 2964715]} -setup {
+ set i [safe::interpCreate]
+ buildEnvironment deleteme.tm
+} -body {
+ ::safe::interpAddToAccessPath $i $testdir2
+ $i eval \
+ glob -directory $testdir [file join deletemetoo *.tm]
+} -returnCodes error -cleanup {
+ safe::interpDelete $i
+ removeDirectory $testdir
+} -result {permission denied}
+test safe-13.6 {as 13.4 but test silent failure when result is outside access_path [Bug 2964715]} -setup {
+ set i [safe::interpCreate]
+ buildEnvironment deleteme.tm
+} -body {
+ ::safe::interpAddToAccessPath $i $testdir
+ $i eval \
+ glob -nocomplain -directory $testdir [file join deletemetoo *.tm]
+} -cleanup {
+ safe::interpDelete $i
+ removeDirectory $testdir
+} -result {}
+test safe-13.7 {mimic the glob call by tclPkgUnknown which gives a deliberate error in a safe interpreter [Bug 2964715]} -setup {
+ set i [safe::interpCreate]
+ buildEnvironment pkgIndex.tcl
+} -body {
+ set safeTD [::safe::interpAddToAccessPath $i $testdir]
+ ::safe::interpAddToAccessPath $i $testdir2
+ string map [list $safeTD EXPECTED] [$i eval [list \
+ glob -directory $safeTD -join * pkgIndex.tcl]]
+} -cleanup {
+ safe::interpDelete $i
+ removeDirectory $testdir
+} -result {{EXPECTED/deletemetoo/pkgIndex.tcl}}
+# Note the extra {} around the result above; that's *expected* because of the
+# format of virtual path roots.
+test safe-13.8 {mimic the glob call by tclPkgUnknown without the deliberate error that is specific to pkgIndex.tcl [Bug 2964715]} -setup {
+ set i [safe::interpCreate]
+ buildEnvironment notIndex.tcl
+} -body {
+ set safeTD [::safe::interpAddToAccessPath $i $testdir]
+ ::safe::interpAddToAccessPath $i $testdir2
+ $i eval [list glob -directory $safeTD -join -nocomplain * notIndex.tcl]
+} -cleanup {
+ safe::interpDelete $i
+ removeDirectory $testdir
+} -result {}
+test safe-13.9 {as 13.8 but test glob failure when -directory is outside access path [Bug 2964715]} -setup {
+ set i [safe::interpCreate]
+ buildEnvironment notIndex.tcl
+} -body {
+ ::safe::interpAddToAccessPath $i $testdir2
+ set result [$i eval \
+ glob -directory $testdir -join -nocomplain * notIndex.tcl]
+ if {$result eq [list $testfile]} {
+ return {glob match}
+ } else {
+ return "no match: $result"
+ }
+} -cleanup {
+ safe::interpDelete $i
+ removeDirectory $testdir
+} -result {no match: }
+test safe-13.10 {as 13.8 but test silent failure when result is outside access_path [Bug 2964715]} -setup {
+ set i [safe::interpCreate]
+ buildEnvironment notIndex.tcl
+} -body {
+ ::safe::interpAddToAccessPath $i $testdir
+ $i eval glob -directory $testdir -join -nocomplain * notIndex.tcl
+} -cleanup {
+ safe::interpDelete $i
+ removeDirectory $testdir
+} -result {}
+rename buildEnvironment {}
+
+#### Test for the module path
+test safe-14.1 {Check that module path is the same as in the master interpreter [Bug 2964715]} -setup {
+ set i [safe::interpCreate]
+} -body {
+ set tm {}
+ foreach token [$i eval ::tcl::tm::path list] {
+ lappend tm [dict get [set ::safe::S${i}(access_path,map)] $token]
+ }
+ return $tm
} -cleanup {
safe::interpDelete $i
-} -match glob -result *
+} -result [::tcl::tm::path list]
-test safe-13.1 {safe file ensemble does not surprise code} -setup {
+test safe-15.1 {safe file ensemble does not surprise code} -setup {
set i [interp create -safe]
} -body {
set result [expr {"file" in [interp hidden $i]}]
@@ -556,7 +697,7 @@ test safe-13.1 {safe file ensemble does not surprise code} -setup {
lappend result [catch {interp eval $i {file isdirectory .}} msg] $msg
} -cleanup {
interp delete $i
-} -result {1 {a b c} 1 {a b c} 1 {invalid command name "file"} 1 0 {a b c} 1 {invalid command name "::tcl::file::isdirectory"}}
+} -result {1 {a b c} 1 {a b c} 1 {invalid command name "file"} 1 0 {a b c} 1 {not allowed to invoke subcommand isdirectory of file}}
set ::auto_path $saveAutoPath
# cleanup
diff --git a/tests/switch.test b/tests/switch.test
index 255be00..a03948b 100644
--- a/tests/switch.test
+++ b/tests/switch.test
@@ -536,7 +536,7 @@ test switch-11.6 {-matchvar unwritable} {
test switch-12.1 {regexp matching with -indexvar} {
switch -regexp -indexvar x -- abc {.(.). {set x}}
-} {{0 3} {1 2}}
+} {{0 2} {1 1}}
test switch-12.2 {regexp matching with -indexvar} {
set x GOOD
switch -regexp -indexvar x -- abc {.(.).. {list $x z}}
@@ -544,7 +544,7 @@ test switch-12.2 {regexp matching with -indexvar} {
} GOOD
test switch-12.3 {regexp matching with -indexvar} {
switch -regexp -indexvar x -- "a b c" {.(.). {set x}}
-} {{0 3} {1 2}}
+} {{0 2} {1 1}}
test switch-12.4 {regexp matching with -indexvar} {
set x BAD
switch -regexp -indexvar x -- "a b c" {
@@ -560,22 +560,32 @@ test switch-12.6 {-indexvar unwritable} {
set x {}
list [catch {switch -regexp -indexvar x(x) -- abc . {set x}} msg] $x $msg
} {1 {} {can't set "x(x)": variable isn't array}}
+test switch-12.7 {[Bug 3106532] -indexvar should be directly usable with [string range]} {
+ set str abcdef
+ switch -regexp -indexvar x -- $str ^... {string range $str {*}[lindex $x 0]}
+} abc
+test switch-12.8 {-indexvar and matched empty strings} {
+ switch -regexp -indexvar x -- abcdef ^...(x?) {return $x}
+} {{0 2} {3 2}}
+test switch-12.9 {-indexvar and unmatched strings} {
+ switch -regexp -indexvar x -- abcdef ^...(x)? {return $x}
+} {{0 2} {-1 -1}}
test switch-13.1 {-indexvar -matchvar combinations} {
switch -regexp -indexvar x -matchvar y abc {
. {list $x $y}
}
-} {{{0 1}} a}
+} {{{0 0}} a}
test switch-13.2 {-indexvar -matchvar combinations} {
switch -regexp -indexvar x -matchvar y abc {
.$ {list $x $y}
}
-} {{{2 3}} c}
+} {{{2 2}} c}
test switch-13.3 {-indexvar -matchvar combinations} {
switch -regexp -indexvar x -matchvar y abc {
(.)(.)(.) {list $x $y}
}
-} {{{0 3} {0 1} {1 2} {2 3}} {abc a b c}}
+} {{{0 2} {0 0} {1 1} {2 2}} {abc a b c}}
test switch-13.4 {-indexvar -matchvar combinations} {
set x -
set y -
@@ -597,7 +607,7 @@ test switch-13.6 {-indexvar -matchvar combinations} {
list [catch {
switch -regexp -indexvar x -matchvar y(y) abc {. {list $x $y}}
} msg] $x $y $msg
-} {1 {{0 1}} - {can't set "y(y)": variable isn't array}}
+} {1 {{0 0}} - {can't set "y(y)": variable isn't array}}
test switch-14.1 {-regexp -- compilation [Bug 1854399]} {
switch -regexp -- 0 {
diff --git a/tests/zlib.test b/tests/zlib.test
index 3aaca29..d8d710a 100644
--- a/tests/zlib.test
+++ b/tests/zlib.test
@@ -147,6 +147,7 @@ test zlib-8.3 {zlib transformation and fileevent} -constraints zlib -setup {
set ::total [expr {$e eq {} ? $c : $e}]
}}}
vwait total
+ after cancel {set total timeout}
} finally {
close $sin
}
@@ -226,6 +227,7 @@ test zlib-9.3 "socket fcopy bg (identity)" -constraints {tempNotWin zlib} -setup
set ::total [expr {$e eq {} ? $c : $e}]
}}}
vwait ::total
+ after cancel {set ::total timeout}
close $sin; close $fout
list read $::total size [file size $file]
} -cleanup {
@@ -251,6 +253,7 @@ test zlib-9.4 "socket fcopy bg (gzip)" -constraints zlib -setup {
set ::total [expr {$e eq {} ? $c : $e}]
}}}
vwait ::total
+ after cancel {set ::total timeout}
close $sin; close $fout
list read $::total size [file size $file]
} -cleanup {
@@ -284,6 +287,7 @@ test zlib-9.5 "socket fcopy incremental (gzip)" -constraints zlib -setup {
after 1000 {set ::total timeout}
fcopy $sin $fout -size 8192 -command [list zlib95copy $sin $fout 0]
vwait ::total
+ after cancel {set ::total timeout}
close $sin; close $fout
list $::total size [file size $file]
} -cleanup {
@@ -312,6 +316,7 @@ test zlib-9.6 "bug #2818131 (gzip)" -constraints zlib -setup {
}
}} $s]
vwait ::total
+ after cancel {set ::total timeout}
close $s
set ::total
} -cleanup {
@@ -339,6 +344,7 @@ test zlib-9.7 "bug #2818131 (compress)" -constraints zlib -setup {
}
}} $s]
vwait ::total
+ after cancel {set ::total timeout}
close $s
set ::total
} -cleanup {
@@ -366,6 +372,7 @@ test zlib-9.8 "bug #2818131 (deflate)" -constraints zlib -setup {
}
}} $s]
vwait ::total
+ after cancel {set ::total timeout}
close $s
set ::total
} -cleanup {
@@ -396,6 +403,7 @@ test zlib-9.9 "bug #2818131 (gzip mismatch)" -constraints zlib -setup {
}} $s]
vwait ::total
} finally {
+ after cancel {set ::total timeout}
close $s
}
set ::total
@@ -428,6 +436,7 @@ test zlib-9.10 "bug #2818131 (compress mismatch)" -constraints zlib -setup {
}} $s]
vwait ::total
} finally {
+ after cancel {set ::total timeout}
close $s
}
set ::total
@@ -460,6 +469,7 @@ test zlib-9.11 "bug #2818131 (deflate mismatch)" -constraints zlib -setup {
}} $s]
vwait ::total
} finally {
+ after cancel {set ::total timeout}
close $s
}
set ::total
@@ -502,6 +512,8 @@ test zlib-10.0 "bug #2818131 (close with null interp)" -constraints {
after 100 {set ::total done}
}} $s]
vwait ::total
+ after cancel {set ::total timeout}
+ after cancel {set ::total done}
set ::total
} -cleanup {
close $srv
@@ -538,6 +550,8 @@ test zlib-10.1 "bug #2818131 (mismatch read)" -constraints {
after 100 {set ::total done}
}} $s]
vwait ::total
+ after cancel {set ::total timeout}
+ after cancel {set ::total done}
set ::total
} -cleanup {
close $srv
@@ -576,6 +590,8 @@ test zlib-10.2 "bug #2818131 (mismatch gets)" -constraints {
after 100 {set ::total done}
}} $s]
vwait ::total
+ after cancel {set ::total timeout}
+ after cancel {set ::total done}
set ::total
} -cleanup {
close $srv
diff --git a/tools/genStubs.tcl b/tools/genStubs.tcl
index 163a354..e654bf4 100644
--- a/tools/genStubs.tcl
+++ b/tools/genStubs.tcl
@@ -568,8 +568,8 @@ proc genStubs::makeSlot {name decl index} {
append text $rtype " *" $lfname "; /* $index */\n"
return $text
}
- if {[string range $rtype end-7 end] eq "CALLBACK"} {
- append text [string trim [string range $rtype 0 end-8]] " (CALLBACK *" $lfname ") "
+ if {[string range $rtype end-8 end] eq "__stdcall"} {
+ append text [string trim [string range $rtype 0 end-9]] " (__stdcall *" $lfname ") "
} else {
append text $rtype " (*" $lfname ") "
}
diff --git a/unix/configure b/unix/configure
index 8f25c08..1151497 100755
--- a/unix/configure
+++ b/unix/configure
@@ -1353,6 +1353,11 @@ if test -r "$cache_file" -a -f "$cache_file"; then
fi
#------------------------------------------------------------------------
+# Empty slate for bundled packages, to avoid stale configuration
+#------------------------------------------------------------------------
+rm -Rf pkgs
+
+#------------------------------------------------------------------------
# Handle the --prefix=... option
#------------------------------------------------------------------------
diff --git a/unix/configure.in b/unix/configure.in
index 066a84f..4fc93dd 100644
--- a/unix/configure.in
+++ b/unix/configure.in
@@ -43,6 +43,11 @@ if test -r "$cache_file" -a -f "$cache_file"; then
fi
#------------------------------------------------------------------------
+# Empty slate for bundled packages, to avoid stale configuration
+#------------------------------------------------------------------------
+rm -Rf pkgs
+
+#------------------------------------------------------------------------
# Handle the --prefix=... option
#------------------------------------------------------------------------
diff --git a/win/configure b/win/configure
index f3bd0d9..5edf012 100755
--- a/win/configure
+++ b/win/configure
@@ -309,7 +309,7 @@ ac_includes_default="\
# include <unistd.h>
#endif"
-ac_subst_vars='SHELL PATH_SEPARATOR PACKAGE_NAME PACKAGE_TARNAME PACKAGE_VERSION PACKAGE_STRING PACKAGE_BUGREPORT exec_prefix prefix program_transform_name bindir sbindir libexecdir datadir sysconfdir sharedstatedir localstatedir libdir includedir oldincludedir infodir mandir build_alias host_alias target_alias DEFS ECHO_C ECHO_N ECHO_T LIBS CC CFLAGS LDFLAGS CPPFLAGS ac_ct_CC EXEEXT OBJEXT CPP EGREP AR ac_ct_AR RANLIB ac_ct_RANLIB RC ac_ct_RC SET_MAKE TCL_THREADS CYGPATH CELIB_DIR DL_LIBS CFLAGS_DEBUG CFLAGS_OPTIMIZE CFLAGS_WARNING ZLIB_DLL_FILE ZLIB_LIBS ZLIB_OBJS CFLAGS_DEFAULT LDFLAGS_DEFAULT VC_MANIFEST_EMBED_DLL VC_MANIFEST_EMBED_EXE TCL_VERSION TCL_MAJOR_VERSION TCL_MINOR_VERSION TCL_PATCH_LEVEL PKG_CFG_ARGS TCL_EXE TCL_LIB_FILE TCL_LIB_FLAG TCL_STATIC_LIB_FILE TCL_STATIC_LIB_FLAG TCL_IMPORT_LIB_FILE TCL_IMPORT_LIB_FLAG TCL_LIB_SPEC TCL_STUB_LIB_FILE TCL_STUB_LIB_FLAG TCL_STUB_LIB_SPEC TCL_STUB_LIB_PATH TCL_INCLUDE_SPEC TCL_BUILD_STUB_LIB_SPEC TCL_BUILD_STUB_LIB_PATH TCL_DLL_FILE TCL_SRC_DIR TCL_BIN_DIR TCL_DBGX CFG_TCL_SHARED_LIB_SUFFIX CFG_TCL_UNSHARED_LIB_SUFFIX CFG_TCL_EXPORT_FILE_SUFFIX EXTRA_CFLAGS DEPARG CC_OBJNAME CC_EXENAME LDFLAGS_DEBUG LDFLAGS_OPTIMIZE LDFLAGS_CONSOLE LDFLAGS_WINDOW STLIB_LD SHLIB_LD SHLIB_LD_LIBS SHLIB_CFLAGS SHLIB_SUFFIX TCL_SHARED_BUILD LIBS_GUI DLLSUFFIX LIBPREFIX LIBSUFFIX EXESUFFIX LIBRARIES MAKE_LIB POST_MAKE_LIB MAKE_DLL MAKE_EXE TCL_BUILD_LIB_SPEC TCL_LD_SEARCH_FLAGS TCL_NEEDS_EXP_FILE TCL_BUILD_EXP_FILE TCL_EXP_FILE TCL_LIB_VERSIONS_OK TCL_PACKAGE_PATH TCL_DDE_VERSION TCL_DDE_MAJOR_VERSION TCL_DDE_MINOR_VERSION TCL_DDE_PATCH_LEVEL TCL_REG_VERSION TCL_REG_MAJOR_VERSION TCL_REG_MINOR_VERSION TCL_REG_PATCH_LEVEL RC_OUT RC_TYPE RC_INCLUDE RC_DEFINE RC_DEFINES RES LIBOBJS LTLIBOBJS'
+ac_subst_vars='SHELL PATH_SEPARATOR PACKAGE_NAME PACKAGE_TARNAME PACKAGE_VERSION PACKAGE_STRING PACKAGE_BUGREPORT exec_prefix prefix program_transform_name bindir sbindir libexecdir datadir sysconfdir sharedstatedir localstatedir libdir includedir oldincludedir infodir mandir build_alias host_alias target_alias DEFS ECHO_C ECHO_N ECHO_T LIBS CC CFLAGS LDFLAGS CPPFLAGS ac_ct_CC EXEEXT OBJEXT CPP EGREP AR ac_ct_AR RANLIB ac_ct_RANLIB RC ac_ct_RC SET_MAKE TCL_THREADS CYGPATH CELIB_DIR DL_LIBS CFLAGS_DEBUG CFLAGS_OPTIMIZE CFLAGS_WARNING ZLIB_DLL_FILE ZLIB_LIBS ZLIB_OBJS CFLAGS_DEFAULT LDFLAGS_DEFAULT VC_MANIFEST_EMBED_DLL VC_MANIFEST_EMBED_EXE TCL_VERSION TCL_MAJOR_VERSION TCL_MINOR_VERSION TCL_PATCH_LEVEL PKG_CFG_ARGS TCL_EXE TCL_LIB_FILE TCL_LIB_FLAG TCL_STATIC_LIB_FILE TCL_STATIC_LIB_FLAG TCL_IMPORT_LIB_FILE TCL_IMPORT_LIB_FLAG TCL_LIB_SPEC TCL_STUB_LIB_FILE TCL_STUB_LIB_FLAG TCL_STUB_LIB_SPEC TCL_STUB_LIB_PATH TCL_INCLUDE_SPEC TCL_BUILD_STUB_LIB_SPEC TCL_BUILD_STUB_LIB_PATH TCL_DLL_FILE TCL_SRC_DIR TCL_BIN_DIR TCL_DBGX CFG_TCL_SHARED_LIB_SUFFIX CFG_TCL_UNSHARED_LIB_SUFFIX CFG_TCL_EXPORT_FILE_SUFFIX EXTRA_CFLAGS DEPARG CC_OBJNAME CC_EXENAME LDFLAGS_DEBUG LDFLAGS_OPTIMIZE LDFLAGS_CONSOLE LDFLAGS_WINDOW STLIB_LD SHLIB_LD SHLIB_LD_LIBS SHLIB_CFLAGS SHLIB_SUFFIX TCL_SHARED_BUILD LIBS_GUI DLLSUFFIX LIBPREFIX LIBSUFFIX EXESUFFIX LIBRARIES MAKE_LIB POST_MAKE_LIB MAKE_DLL MAKE_EXE TCL_BUILD_LIB_SPEC TCL_LD_SEARCH_FLAGS TCL_NEEDS_EXP_FILE TCL_BUILD_EXP_FILE TCL_EXP_FILE TCL_LIB_VERSIONS_OK TCL_PACKAGE_PATH TCL_DDE_VERSION TCL_DDE_MAJOR_VERSION TCL_DDE_MINOR_VERSION TCL_REG_VERSION TCL_REG_MAJOR_VERSION TCL_REG_MINOR_VERSION RC_OUT RC_TYPE RC_INCLUDE RC_DEFINE RC_DEFINES RES LIBOBJS LTLIBOBJS'
ac_subst_files=''
# Initialize some variables set by options.
@@ -1317,18 +1317,21 @@ VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION
TCL_DDE_VERSION=1.3
TCL_DDE_MAJOR_VERSION=1
TCL_DDE_MINOR_VERSION=3
-TCL_DDE_PATCH_LEVEL="2"
DDEVER=$TCL_DDE_MAJOR_VERSION$TCL_DDE_MINOR_VERSION
TCL_REG_VERSION=1.3
TCL_REG_MAJOR_VERSION=1
TCL_REG_MINOR_VERSION=3
-TCL_REG_PATCH_LEVEL="0"
REGVER=$TCL_REG_MAJOR_VERSION$TCL_REG_MINOR_VERSION
PKG_CFG_ARGS=$@
#------------------------------------------------------------------------
+# Empty slate for bundled packages, to avoid stale configuration
+#------------------------------------------------------------------------
+rm -Rf pkgs
+
+#------------------------------------------------------------------------
# Handle the --prefix=... option
#------------------------------------------------------------------------
@@ -5250,8 +5253,6 @@ fi
-
-
ac_config_files="$ac_config_files Makefile tclConfig.sh tcl.hpj"
cat >confcache <<\_ACEOF
# This file is a shell script that caches the results of configure
@@ -5980,11 +5981,9 @@ s,@TCL_PACKAGE_PATH@,$TCL_PACKAGE_PATH,;t t
s,@TCL_DDE_VERSION@,$TCL_DDE_VERSION,;t t
s,@TCL_DDE_MAJOR_VERSION@,$TCL_DDE_MAJOR_VERSION,;t t
s,@TCL_DDE_MINOR_VERSION@,$TCL_DDE_MINOR_VERSION,;t t
-s,@TCL_DDE_PATCH_LEVEL@,$TCL_DDE_PATCH_LEVEL,;t t
s,@TCL_REG_VERSION@,$TCL_REG_VERSION,;t t
s,@TCL_REG_MAJOR_VERSION@,$TCL_REG_MAJOR_VERSION,;t t
s,@TCL_REG_MINOR_VERSION@,$TCL_REG_MINOR_VERSION,;t t
-s,@TCL_REG_PATCH_LEVEL@,$TCL_REG_PATCH_LEVEL,;t t
s,@RC_OUT@,$RC_OUT,;t t
s,@RC_TYPE@,$RC_TYPE,;t t
s,@RC_INCLUDE@,$RC_INCLUDE,;t t
diff --git a/win/configure.in b/win/configure.in
index 0ed8f89..f4e10ee 100644
--- a/win/configure.in
+++ b/win/configure.in
@@ -20,18 +20,21 @@ VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION
TCL_DDE_VERSION=1.3
TCL_DDE_MAJOR_VERSION=1
TCL_DDE_MINOR_VERSION=3
-TCL_DDE_PATCH_LEVEL="2"
DDEVER=$TCL_DDE_MAJOR_VERSION$TCL_DDE_MINOR_VERSION
TCL_REG_VERSION=1.3
TCL_REG_MAJOR_VERSION=1
TCL_REG_MINOR_VERSION=3
-TCL_REG_PATCH_LEVEL="0"
REGVER=$TCL_REG_MAJOR_VERSION$TCL_REG_MINOR_VERSION
PKG_CFG_ARGS=$@
#------------------------------------------------------------------------
+# Empty slate for bundled packages, to avoid stale configuration
+#------------------------------------------------------------------------
+rm -Rf pkgs
+
+#------------------------------------------------------------------------
# Handle the --prefix=... option
#------------------------------------------------------------------------
@@ -425,11 +428,9 @@ AC_SUBST(TCL_PACKAGE_PATH)
AC_SUBST(TCL_DDE_VERSION)
AC_SUBST(TCL_DDE_MAJOR_VERSION)
AC_SUBST(TCL_DDE_MINOR_VERSION)
-AC_SUBST(TCL_DDE_PATCH_LEVEL)
AC_SUBST(TCL_REG_VERSION)
AC_SUBST(TCL_REG_MAJOR_VERSION)
AC_SUBST(TCL_REG_MINOR_VERSION)
-AC_SUBST(TCL_REG_PATCH_LEVEL)
AC_SUBST(RC)
AC_SUBST(RC_OUT)
diff --git a/win/tclWinDde.c b/win/tclWinDde.c
index 71b03a9..d508c02 100644
--- a/win/tclWinDde.c
+++ b/win/tclWinDde.c
@@ -11,13 +11,19 @@
*/
#undef STATIC_BUILD
-#ifndef USE_TCL_STUBS
-# define USE_TCL_STUBS
-#endif
+#undef USE_TCL_STUBS
+#define USE_TCL_STUBS
+#undef UNICODE
+#undef _UNICODE
#include "tclInt.h"
#include <dde.h>
#include <ddeml.h>
+#ifndef UNICODE
+# undef CP_WINUNICODE
+# define CP_WINUNICODE CP_WINANSI
+#endif
+
/*
* 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
@@ -37,7 +43,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 +57,7 @@ typedef struct Conversation {
/* The next conversation in the list. */
RegisteredInterp *riPtr; /* The info we know about the conversation. */
HCONV hConv; /* The DDE handle for this conversation. */
- Tcl_Obj *returnPackagePtr; /* The result package for this conversation */
+ Tcl_Obj *returnPackagePtr; /* The result package for this conversation. */
} Conversation;
typedef struct DdeEnumServices {
@@ -79,13 +85,13 @@ static Tcl_ThreadDataKey dataKey;
static HSZ ddeServiceGlobal = 0;
static DWORD ddeInstance; /* The application instance handle given to us
- * by DdeInitializeA. */
+ * by DdeInitialize. */
static int ddeIsServer = 0;
-#define TCL_DDE_VERSION "1.3.2"
+#define TCL_DDE_VERSION "1.3.3"
#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")
TCL_DECLARE_MUTEX(ddeMutex)
@@ -100,7 +106,7 @@ 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,7 +116,7 @@ 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,
@@ -215,7 +221,7 @@ Initialize(void)
if (ddeInstance == 0) {
Tcl_MutexLock(&ddeMutex);
if (ddeInstance == 0) {
- if (DdeInitializeA(&ddeInstance, (PFNCALLBACK) DdeServerProc,
+ if (DdeInitialize(&ddeInstance, (PFNCALLBACK) DdeServerProc,
CBF_SKIP_REGISTRATIONS | CBF_SKIP_UNREGISTRATIONS
| CBF_FAIL_POKES, 0) != DMLERR_NO_ERROR) {
ddeInstance = 0;
@@ -228,7 +234,7 @@ Initialize(void)
if ((ddeServiceGlobal == 0) && (nameFound != 0)) {
ddeIsServer = 1;
Tcl_CreateExitHandler(DdeExitProc, NULL);
- ddeServiceGlobal = DdeCreateStringHandleA(ddeInstance,
+ ddeServiceGlobal = DdeCreateStringHandle(ddeInstance,
TCL_DDE_SERVICE_NAME, 0);
DdeNameService(ddeInstance, ddeServiceGlobal, 0L, DNS_REGISTER);
} else {
@@ -263,10 +269,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 exactName, /* Should we make a unique name? 0 = unique */
@@ -276,7 +282,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,15 +320,16 @@ DdeSetServerName(
* current interp, but it doesn't have a name.
*/
- return "";
+ return TEXT("");
}
+ Tcl_DStringInit(&dString);
+
/*
* Get the list of currently registered Tcl interpreters by calling the
* internal implementation of the 'dde services' command.
*/
- Tcl_DStringInit(&dString);
actualName = name;
if (!exactName) {
@@ -335,7 +342,7 @@ DdeSetServerName(
&srvPtrPtr);
}
if (r != TCL_OK) {
- OutputDebugStringA(Tcl_GetStringResult(interp));
+ OutputDebugString(Tcl_GetStringResult(interp));
return NULL;
}
@@ -355,7 +362,7 @@ DdeSetServerName(
Tcl_DStringAppend(&dString, name, -1);
Tcl_DStringAppend(&dString, " #", 2);
offset = Tcl_DStringLength(&dString);
- Tcl_DStringSetLength(&dString, offset+TCL_INTEGER_SPACE);
+ Tcl_DStringSetLength(&dString, offset + TCL_INTEGER_SPACE);
actualName = Tcl_DStringValue(&dString);
}
sprintf(Tcl_DStringValue(&dString) + offset, "%d", suffix);
@@ -369,7 +376,7 @@ DdeSetServerName(
Tcl_Obj* namePtr;
Tcl_ListObjIndex(interp, srvPtrPtr[n], 1, &namePtr);
- if (strcmp(actualName, Tcl_GetString(namePtr)) == 0) {
+ if (_tcscmp(actualName, Tcl_GetString(namePtr)) == 0) {
suffix++;
break;
}
@@ -385,14 +392,14 @@ DdeSetServerName(
riPtr = ckalloc(sizeof(RegisteredInterp));
riPtr->interp = interp;
- riPtr->name = ckalloc(strlen(actualName) + 1);
+ riPtr->name = ckalloc((_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");
@@ -472,7 +479,7 @@ DeleteProc(
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
for (searchPtr = tsdPtr->interpListPtr, prevPtr = NULL;
- searchPtr != NULL && searchPtr != riPtr;
+ (searchPtr != NULL) && (searchPtr != riPtr);
prevPtr = searchPtr, searchPtr = searchPtr->nextPtr) {
/*
* Empty loop body.
@@ -552,7 +559,8 @@ ExecuteRemoteObject(
returnPackagePtr = Tcl_NewListObj(0, NULL);
- Tcl_ListObjAppendElement(NULL, returnPackagePtr, Tcl_NewIntObj(result));
+ Tcl_ListObjAppendElement(NULL, returnPackagePtr,
+ Tcl_NewIntObj(result));
Tcl_ListObjAppendElement(NULL, returnPackagePtr,
Tcl_GetObjResult(riPtr->interp));
@@ -607,7 +615,7 @@ DdeServerProc(
Tcl_DString dString;
int 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 = DdeQueryStringA(ddeInstance, ddeTopic, NULL, 0, 0);
+ len = DdeQueryString(ddeInstance, ddeTopic, NULL, 0, 0);
Tcl_DStringInit(&dString);
- Tcl_DStringSetLength(&dString, len);
- utilString = Tcl_DStringValue(&dString);
- DdeQueryStringA(ddeInstance, ddeTopic, utilString, (DWORD) len + 1,
- CP_WINANSI);
+ Tcl_DStringSetLength(&dString, (len + 1) * sizeof(TCHAR) - 1);
+ utilString = (TCHAR *) Tcl_DStringValue(&dString);
+ DdeQueryString(ddeInstance, ddeTopic, utilString, (DWORD) len + 1,
+ CP_WINUNICODE);
for (riPtr = tsdPtr->interpListPtr; riPtr != NULL;
riPtr = riPtr->nextPtr) {
- if (strcasecmp(utilString, riPtr->name) == 0) {
+ if (_tcsicmp(utilString, riPtr->name) == 0) {
Tcl_DStringFree(&dString);
return (HDDEDATA) TRUE;
}
@@ -646,15 +654,15 @@ DdeServerProc(
* result to return in an XTYP_REQUEST.
*/
- len = DdeQueryStringA(ddeInstance, ddeTopic, NULL, 0, 0);
+ len = DdeQueryString(ddeInstance, ddeTopic, NULL, 0, 0);
Tcl_DStringInit(&dString);
- Tcl_DStringSetLength(&dString, len);
- utilString = Tcl_DStringValue(&dString);
- DdeQueryStringA(ddeInstance, ddeTopic, utilString, (DWORD) len + 1,
- CP_WINANSI);
+ Tcl_DStringSetLength(&dString, (len + 1) * sizeof(TCHAR) - 1);
+ utilString = (TCHAR *) Tcl_DStringValue(&dString);
+ DdeQueryString(ddeInstance, ddeTopic, utilString, (DWORD) len + 1,
+ CP_WINUNICODE);
for (riPtr = tsdPtr->interpListPtr; riPtr != NULL;
riPtr = riPtr->nextPtr) {
- if (strcasecmp(riPtr->name, utilString) == 0) {
+ if (_tcsicmp(riPtr->name, utilString) == 0) {
convPtr = ckalloc(sizeof(Conversation));
convPtr->nextPtr = tsdPtr->currentConversations;
convPtr->returnPackagePtr = NULL;
@@ -698,7 +706,7 @@ DdeServerProc(
* execute.
*/
- if (uFmt != CF_TEXT) {
+ if ((uFmt != CF_TEXT) && (uFmt != CF_UNICODETEXT)) {
return (HDDEDATA) FALSE;
}
@@ -711,19 +719,25 @@ DdeServerProc(
}
if (convPtr != NULL) {
- BYTE *returnString;
+ char *returnString;
- len = DdeQueryStringA(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);
- DdeQueryStringA(ddeInstance, ddeItem, utilString, (DWORD) len + 1,
- CP_WINANSI);
- if (strcasecmp(utilString, TCL_DDE_EXECUTE_RESULT) == 0) {
- returnString = (BYTE *)
- Tcl_GetStringFromObj(convPtr->returnPackagePtr, &len);
- ddeReturn = DdeCreateDataHandle(ddeInstance, returnString,
- (DWORD) len+1, 0, ddeItem, CF_TEXT, 0);
+ 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 = 2 * len + 1;
+ }
+ ddeReturn = DdeCreateDataHandle(ddeInstance, (BYTE *)returnString,
+ (DWORD) len+1, 0, ddeItem, uFmt, 0);
} else {
if (Tcl_IsSafe(convPtr->riPtr->interp)) {
ddeReturn = NULL;
@@ -732,11 +746,17 @@ DdeServerProc(
convPtr->riPtr->interp, utilString, NULL,
TCL_GLOBAL_ONLY);
if (variableObjPtr != NULL) {
- returnString = (BYTE *) Tcl_GetStringFromObj(
- variableObjPtr, &len);
+ if (uFmt == CF_TEXT) {
+ returnString = Tcl_GetStringFromObj(
+ variableObjPtr, &len);
+ } else {
+ returnString = (char *) Tcl_GetUnicodeFromObj(
+ variableObjPtr, &len);
+ len = 2 * len + 1;
+ }
ddeReturn = DdeCreateDataHandle(ddeInstance,
- returnString, (DWORD) len+1, 0, ddeItem,
- CF_TEXT, 0);
+ (BYTE *)returnString, (DWORD) len+1, 0, ddeItem,
+ uFmt, 0);
} else {
ddeReturn = NULL;
}
@@ -765,9 +785,12 @@ DdeServerProc(
return (HDDEDATA) DDE_FNOTPROCESSED;
}
- utilString = (char *) DdeAccessData(hData, &dlen);
+ utilString = (TCHAR *) DdeAccessData(hData, &dlen);
len = dlen;
- ddeObjectPtr = Tcl_NewStringObj(utilString, -1);
+ if (len && !utilString[len-1]) {
+ len--;
+ }
+ ddeObjectPtr = Tcl_NewStringObj(utilString, len);
Tcl_IncrRefCount(ddeObjectPtr);
DdeUnaccessData(hData);
if (convPtr->returnPackagePtr != NULL) {
@@ -818,10 +841,10 @@ DdeServerProc(
len = dlen;
for (i = 0, riPtr = tsdPtr->interpListPtr; i < numItems;
i++, riPtr = riPtr->nextPtr) {
- returnPtr[i].hszSvc = DdeCreateStringHandleA(ddeInstance,
- TCL_DDE_SERVICE_NAME, CP_WINANSI);
- returnPtr[i].hszTopic = DdeCreateStringHandleA(ddeInstance,
- riPtr->name, CP_WINANSI);
+ returnPtr[i].hszSvc = DdeCreateStringHandle(ddeInstance,
+ TCL_DDE_SERVICE_NAME, CP_WINUNICODE);
+ returnPtr[i].hszTopic = DdeCreateStringHandle(ddeInstance,
+ riPtr->name, CP_WINUNICODE);
}
returnPtr[i].hszSvc = NULL;
returnPtr[i].hszTopic = NULL;
@@ -879,14 +902,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 = DdeCreateStringHandleA(ddeInstance, TCL_DDE_SERVICE_NAME, 0);
- ddeTopic = DdeCreateStringHandleA(ddeInstance, (void *) name, 0);
+ ddeService = DdeCreateStringHandle(ddeInstance, TCL_DDE_SERVICE_NAME, 0);
+ ddeTopic = DdeCreateStringHandle(ddeInstance, name, 0);
ddeConv = DdeConnect(ddeInstance, ddeService, ddeTopic, NULL);
DdeFreeStringHandle(ddeInstance, ddeService);
@@ -929,9 +952,9 @@ static int
DdeCreateClient(
struct DdeEnumServices *es)
{
- WNDCLASSEXA wc;
- static const char *szDdeClientClassName = "TclEval client class";
- static const char *szDdeClientWindowName = "TclEval client window";
+ WNDCLASSEX wc;
+ 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);
@@ -943,8 +966,8 @@ DdeCreateClient(
* Register and create the callback window.
*/
- RegisterClassExA(&wc);
- es->hwnd = CreateWindowExA(0, szDdeClientClassName, szDdeClientWindowName,
+ RegisterClassEx(&wc);
+ es->hwnd = CreateWindowEx(0, szDdeClientClassName, szDdeClientWindowName,
WS_POPUP, 0, 0, 0, 0, NULL, NULL, NULL, (LPVOID)es);
return TCL_OK;
}
@@ -956,7 +979,6 @@ DdeClientWindowProc(
WPARAM wParam,
LPARAM lParam) /* (Potentially) our local handle */
{
-
switch (uMsg) {
case WM_CREATE: {
LPCREATESTRUCT lpcs = (LPCREATESTRUCT) lParam;
@@ -964,17 +986,16 @@ DdeClientWindowProc(
(struct DdeEnumServices *) lpcs->lpCreateParams;
#ifdef _WIN64
- SetWindowLongPtr(hwnd, GWLP_USERDATA, (LONG_PTR)es);
+ SetWindowLongPtr(hwnd, GWLP_USERDATA, (LONG_PTR) es);
#else
- SetWindowLongA(hwnd, GWL_USERDATA, (long)es);
+ SetWindowLong(hwnd, GWL_USERDATA, (LONG) es);
#endif
return (LRESULT) 0L;
}
case WM_DDE_ACK:
return DdeServicesOnAck(hwnd, wParam, lParam);
- break;
default:
- return DefWindowProcA(hwnd, uMsg, wParam, lParam);
+ return DefWindowProc(hwnd, uMsg, wParam, lParam);
}
}
@@ -988,12 +1009,12 @@ DdeServicesOnAck(
ATOM service = (ATOM)LOWORD(lParam);
ATOM topic = (ATOM)HIWORD(lParam);
struct DdeEnumServices *es;
- char sz[255];
+ TCHAR sz[255];
#ifdef _WIN64
es = (struct DdeEnumServices *) GetWindowLongPtr(hwnd, GWLP_USERDATA);
#else
- es = (struct DdeEnumServices *) GetWindowLongA(hwnd, GWL_USERDATA);
+ es = (struct DdeEnumServices *) GetWindowLong(hwnd, GWL_USERDATA);
#endif
if ((es->service == (ATOM)0 || es->service == service)
@@ -1001,9 +1022,9 @@ DdeServicesOnAck(
Tcl_Obj *matchPtr = Tcl_NewListObj(0, NULL);
Tcl_Obj *resultPtr = Tcl_GetObjResult(es->interp);
- GlobalGetAtomNameA(service, sz, 255);
+ GlobalGetAtomName(service, sz, 255);
Tcl_ListObjAppendElement(NULL, matchPtr, Tcl_NewStringObj(sz, -1));
- GlobalGetAtomNameA(topic, sz, 255);
+ GlobalGetAtomName(topic, sz, 255);
Tcl_ListObjAppendElement(NULL, matchPtr, Tcl_NewStringObj(sz, -1));
/*
@@ -1030,7 +1051,7 @@ DdeServicesOnAck(
* Tell the server we are no longer interested.
*/
- PostMessageA(hwndRemote, WM_DDE_TERMINATE, (WPARAM)hwnd, 0L);
+ PostMessage(hwndRemote, WM_DDE_TERMINATE, (WPARAM)hwnd, 0L);
return 0L;
}
@@ -1042,7 +1063,7 @@ DdeEnumWindowsCallback(
DWORD_PTR dwResult = 0;
struct DdeEnumServices *es = (struct DdeEnumServices *) lParam;
- SendMessageTimeoutA(hwndTarget, WM_DDE_INITIATE, (WPARAM)es->hwnd,
+ SendMessageTimeout(hwndTarget, WM_DDE_INITIATE, (WPARAM)es->hwnd,
MAKELONG(es->service, es->topic), SMTO_ABORTIFHUNG, 1000,
&dwResult);
return TRUE;
@@ -1051,16 +1072,16 @@ DdeEnumWindowsCallback(
static int
DdeGetServicesList(
Tcl_Interp *interp,
- const char *serviceName,
- const char *topicName)
+ const TCHAR *serviceName,
+ const TCHAR *topicName)
{
struct DdeEnumServices es;
es.interp = interp;
es.result = TCL_OK;
es.service = (serviceName == NULL)
- ? (ATOM)0 : GlobalAddAtomA(serviceName);
- es.topic = (topicName == NULL) ? (ATOM)0 : GlobalAddAtomA(topicName);
+ ? (ATOM)0 : GlobalAddAtom(serviceName);
+ es.topic = (topicName == NULL) ? (ATOM)0 : GlobalAddAtom(topicName);
Tcl_ResetResult(interp); /* our list is to be appended to result. */
DdeCreateClient(&es);
@@ -1147,12 +1168,11 @@ DdeObjCmd(
ClientData clientData, /* Used only for deletion */
Tcl_Interp *interp, /* The interp we are sending from */
int objc, /* Number of arguments */
- Tcl_Obj *const * objv) /* The arguments */
+ Tcl_Obj *const *objv) /* The arguments */
{
static const char *const ddeCommands[] = {
"servername", "execute", "poke", "request", "services", "eval",
- (char *) NULL
- };
+ (char *) NULL};
enum DdeSubcommands {
DDE_SERVERNAME, DDE_EXECUTE, DDE_POKE, DDE_REQUEST, DDE_SERVICES,
DDE_EVAL
@@ -1176,8 +1196,8 @@ DdeObjCmd(
HSZ ddeService = NULL, ddeTopic = NULL, ddeItem = NULL, ddeCookie = NULL;
HDDEDATA ddeData = NULL, ddeItemData = NULL, ddeReturn;
HCONV hConv = NULL;
- const char *serviceName = NULL, *topicName = NULL;
- char *string;
+ const TCHAR *serviceName = NULL, *topicName = NULL;
+ const char *string;
DWORD ddeResult;
Tcl_Obj *objPtr, *handlerPtr = NULL;
@@ -1326,8 +1346,8 @@ DdeObjCmd(
if (length == 0) {
serviceName = NULL;
} else if ((index != DDE_SERVERNAME) && (index != DDE_EVAL)) {
- ddeService = DdeCreateStringHandleA(ddeInstance, (void *) serviceName,
- CP_WINANSI);
+ ddeService = DdeCreateStringHandle(ddeInstance, (void *) serviceName,
+ CP_WINUNICODE);
}
if ((index != DDE_SERVERNAME) && (index != DDE_EVAL)) {
@@ -1335,8 +1355,8 @@ DdeObjCmd(
if (length == 0) {
topicName = NULL;
} else {
- ddeTopic = DdeCreateStringHandleA(ddeInstance, (void *) topicName,
- CP_WINANSI);
+ ddeTopic = DdeCreateStringHandle(ddeInstance, (void *) topicName,
+ CP_WINUNICODE);
}
}
@@ -1415,8 +1435,8 @@ DdeObjCmd(
result = TCL_ERROR;
} else {
Tcl_Obj *returnObjPtr;
- ddeItem = DdeCreateStringHandleA(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);
@@ -1425,13 +1445,17 @@ DdeObjCmd(
result = TCL_ERROR;
} else {
DWORD tmp;
- const BYTE *dataString = DdeAccessData(ddeData, &tmp);
+ const char *dataString = (const char *) DdeAccessData(ddeData, &tmp);
if (binary) {
- returnObjPtr = Tcl_NewByteArrayObj(dataString,
+ returnObjPtr = Tcl_NewByteArrayObj((BYTE *) dataString,
(int) tmp);
} else {
- returnObjPtr = Tcl_NewStringObj((char*)dataString,-1);
+ if (tmp && !dataString[tmp-1]) {
+ --tmp;
+ }
+ returnObjPtr = Tcl_NewStringObj(dataString,
+ (int) tmp);
}
DdeUnaccessData(ddeData);
DdeFreeDataHandle(ddeData);
@@ -1468,8 +1492,8 @@ DdeObjCmd(
SetDdeError(interp);
result = TCL_ERROR;
} else {
- ddeItem = DdeCreateStringHandleA(ddeInstance, (void *) itemString,
- CP_WINANSI);
+ ddeItem = DdeCreateStringHandle(ddeInstance, (void *) itemString,
+ CP_WINUNICODE);
if (ddeItem != NULL) {
ddeData = DdeClientTransaction(dataString, (DWORD) length+1,
hConv, ddeItem, CF_TEXT, XTYP_POKE, 5000, NULL);
@@ -1515,7 +1539,7 @@ DdeObjCmd(
for (riPtr = tsdPtr->interpListPtr; riPtr != NULL;
riPtr = riPtr->nextPtr) {
- if (strcasecmp(serviceName, riPtr->name) == 0) {
+ if (_tcsicmp(serviceName, riPtr->name) == 0) {
break;
}
}
@@ -1608,8 +1632,7 @@ 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;
@@ -1618,7 +1641,7 @@ DdeObjCmd(
objPtr = Tcl_ConcatObj(objc, objv);
string = Tcl_GetStringFromObj(objPtr, &length);
ddeItemData = DdeCreateDataHandle(ddeInstance,
- (BYTE *) string, (DWORD) length+1, 0, 0, CF_TEXT, 0);
+ (BYTE *) string, (DWORD) length+1, 0, 0, CF_TEXT, 0);
if (async) {
ddeData = DdeClientTransaction((LPBYTE) ddeItemData,
@@ -1630,8 +1653,8 @@ DdeObjCmd(
0xFFFFFFFF, hConv, 0,
CF_TEXT, XTYP_EXECUTE, 30000, NULL);
if (ddeData != 0) {
- ddeCookie = DdeCreateStringHandleA(ddeInstance,
- TCL_DDE_EXECUTE_RESULT, CP_WINANSI);
+ ddeCookie = DdeCreateStringHandle(ddeInstance,
+ TCL_DDE_EXECUTE_RESULT, CP_WINUNICODE);
ddeData = DdeClientTransaction(NULL, 0, hConv, ddeCookie,
CF_TEXT, XTYP_REQUEST, 30000, NULL);
}
@@ -1642,6 +1665,7 @@ DdeObjCmd(
if (ddeData == 0) {
SetDdeError(interp);
result = TCL_ERROR;
+ goto cleanup;
}
if (async == 0) {
@@ -1658,7 +1682,7 @@ DdeObjCmd(
resultPtr = Tcl_NewObj();
length = DdeGetData(ddeData, NULL, 0, 0);
- Tcl_SetObjLength(resultPtr, length);
+ Tcl_SetObjLength(resultPtr, (length + 1) * sizeof(TCHAR) - 1);
string = Tcl_GetString(resultPtr);
DdeGetData(ddeData, (BYTE *) string, (DWORD) length, 0);
Tcl_SetObjLength(resultPtr, (int) strlen(string));
generated by cgit v0.12 at 2024-11-18 03:17:44 (GMT)