summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--ChangeLog6
-rw-r--r--library/dde/pkgIndex.tcl4
-rw-r--r--tests/winDde.test159
-rw-r--r--win/tclWinDde.c117
4 files changed, 246 insertions, 40 deletions
diff --git a/ChangeLog b/ChangeLog
index 01a0378..9d43b7e 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,9 @@
+2003-05-16 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * library/dde/pkgIndex.tcl: Applied TIP #130 which provides
+ * tests/winDde.test: for unique dde server names. Added
+ * win/tclWinDde.c: some more tests. Fixes [Bug 219293]
+
2003-05-16 Kevin B. Kenny <kennykb@hippolyta>
* unix/Makefile.in: Removed one excess source file tclDToA.c
diff --git a/library/dde/pkgIndex.tcl b/library/dde/pkgIndex.tcl
index dca0f21..c12e3a1 100644
--- a/library/dde/pkgIndex.tcl
+++ b/library/dde/pkgIndex.tcl
@@ -1,6 +1,6 @@
if {![package vsatisfies [package provide Tcl] 8]} {return}
if {[info exists ::tcl_platform(debug)]} {
- package ifneeded dde 1.2.2 [list load [file join $dir tcldde12g.dll] dde]
+ package ifneeded dde 1.2.3 [list load [file join $dir tcldde12g.dll] dde]
} else {
- package ifneeded dde 1.2.2 [list load [file join $dir tcldde12.dll] dde]
+ package ifneeded dde 1.2.3 [list load [file join $dir tcldde12.dll] dde]
}
diff --git a/tests/winDde.test b/tests/winDde.test
index bcf0c9b..a1a8dab 100644
--- a/tests/winDde.test
+++ b/tests/winDde.test
@@ -9,7 +9,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: winDde.test,v 1.14 2003/03/22 23:01:22 patthoyts Exp $
+# RCS: @(#) $Id: winDde.test,v 1.15 2003/05/16 17:29:49 patthoyts Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
@@ -28,17 +28,24 @@ if {$tcl_platform(platform) == "windows"} {
}
}
-set scriptName script1.tcl
+# -------------------------------------------------------------------------
+# Setup a script for a test server
+#
+
+set scriptName [makeFile {} script1.tcl]
proc createChildProcess { ddeServerName } {
file delete -force $::scriptName
set f [open $::scriptName w+]
puts $f {
+ # DDE child server -
+ #
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
+ # Load the dde package to test.
if [catch {
set lib [lindex [glob -directory \
[file join [pwd] [file dirname [info nameofexecutable]]] \
@@ -49,9 +56,20 @@ proc createChildProcess { ddeServerName } {
::tcltest::cleanupTests
return
}
+
+ # If an error occurs during the tests, this process may end up not
+ # being closed down. To deal with this we create a 30s timeout.
+ proc DoTimeout {} {
+ global done
+ puts stderr "winDde.test child process $ddeServerName timed out."
+ set done 1
+ }
+ set timeout [after 30000 DoTimeout]
}
+ # set the dde server name to the supplied argument.
puts $f [list dde servername $ddeServerName]
puts $f {
+ # run the server and handle final cleanup.
puts ready
flush stdout
vwait done
@@ -60,12 +78,15 @@ proc createChildProcess { ddeServerName } {
}
close $f
+ # run the child server script.
set f [open |[list [interpreter] $::scriptName] r]
fconfigure $f -buffering line
gets $f line
return $f
}
+# -------------------------------------------------------------------------
+
test winDde-1.1 {Settings the server's topic name} {pcOnly} {
list [dde servername foobar] [dde servername] [dde servername self]
} {foobar foobar self}
@@ -89,6 +110,8 @@ test winDde-2.4 {Checking for existence, with only the topic specified} \
expr [llength [dde services {} self]] >= 1
} 1
+# -------------------------------------------------------------------------
+
test winDde-3.1 {DDE execute locally} {pcOnly} {
set a ""
dde execute TclEval self {set a "foo"}
@@ -119,43 +142,51 @@ test winDde-3.5 {DDE request locally} {pcOnly} {
dde request -binary TclEval self a
} "foo\x00"
+# -------------------------------------------------------------------------
+
test winDde-4.1 {DDE execute remotely} {stdio pcOnly} {
set a ""
- set child [createChildProcess child]
- dde execute TclEval child {set a "foo"}
- dde execute TclEval child {set done 1}
-
+ set name child-4.1
+ set child [createChildProcess $name]
+ dde execute TclEval $name {set a "foo"}
+ dde execute TclEval $name {set done 1}
+ update
set a
} ""
test winDde-4.2 {DDE execute async remotely} {stdio pcOnly} {
set a ""
- set child [createChildProcess child]
- dde execute -async TclEval child {set a "foo"}
- dde execute TclEval child {set done 1}
-
+ set name child-4.2
+ set child [createChildProcess $name]
+ dde execute -async TclEval $name {set a "foo"}
+ dde execute TclEval $name {set done 1}
+ update
set a
} ""
test winDde-4.3 {DDE request remotely} {stdio pcOnly} {
set a ""
- set child [createChildProcess child]
- dde execute TclEval child {set a "foo"}
- set a [dde request TclEval child a]
- dde execute TclEval child {set done 1}
-
+ set name chile-4.3
+ set child [createChildProcess $name]
+ dde execute TclEval $name {set a "foo"}
+ set a [dde request TclEval $name a]
+ dde execute TclEval $name {set done 1}
+ update
set a
} foo
test winDde-4.4 {DDE eval remotely} {stdio pcOnly} {
set a ""
- set child [createChildProcess child]
- set a [dde eval child set a "foo"]
- dde execute TclEval child {set done 1}
-
+ set name child-4.4
+ set child [createChildProcess $name]
+ set a [dde eval $name set a "foo"]
+ dde execute TclEval $name {set done 1}
+ update
set a
} foo
+# -------------------------------------------------------------------------
+
test winDde-5.1 {check for bad arguments} {pcOnly} {
catch {dde execute "" "" "" ""} result
set result
@@ -175,7 +206,97 @@ test winDde-5.4 {DDE eval bad arguments} {pcOnly} {
list [catch {dde eval "" "foo"} msg] $msg
} {1 {invalid service name ""}}
+# -------------------------------------------------------------------------
+
+test winDde-6.1 {DDE servername bad arguments} {pcOnly} {
+ list [catch {dde servername -z -z -z} msg] $msg
+} {1 {wrong # args: should be "dde servername ?-exact? ?--? ?serverName?"}}
+
+test winDde-6.2 {DDE servername set name} {pcOnly} {
+ list [catch {dde servername -- winDde-6.2} msg] $msg
+} {0 winDde-6.2}
+
+test winDde-6.3 {DDE servername set exact name} {pcOnly} {
+ list [catch {dde servername -exact winDde-6.3} msg] $msg
+} {0 winDde-6.3}
+
+test winDde-6.4 {DDE servername set exact name} {pcOnly} {
+ list [catch {dde servername -exact -- winDde-6.4} msg] $msg
+} {0 winDde-6.4}
+
+test winDde-6.5 {DDE remote servername collision} {stdio pcOnly} {
+ set a ""
+ set name child-6.5
+ set child [createChildProcess $name]
+ list [catch {
+ set a [dde servername -- $name]
+ dde execute TclEval $name {set done 1}
+ update
+ set a
+ } r] $r
+} {0 {child-6.5 #2}}
+
+test winDde-6.6 {DDE remote servername collision force} {stdio pcOnly} {
+ set a ""
+ set name child-6.6
+ set child [createChildProcess $name]
+ list [catch {
+ set a [dde servername -exact -- $name]
+ dde execute TclEval $name {set done 1}
+ update
+ set a
+ } r] $r
+} {0 child-6.6}
+
+# -------------------------------------------------------------------------
+
+test winDde-7.1 {DDE in slave interpreter} {pcOnly} {
+ global slave
+ set name slave-7.1
+ list [catch {
+ set slave [interp create $name]
+ $slave eval [list load $lib dde]
+ $slave eval [list dde servername $name]
+ } msg] $msg
+} {0 slave-7.1}
+
+test winDde-7.2 {DDE present in slave interp} {pcOnly} {
+ global slave
+ list [catch {
+ dde services TclEval $slave
+ } msg] $msg
+} [list 0 [list [list TclEval $slave]]]
+
+test winDde-7.3 {DDE slave servername collision force} {pcOnly} {
+ global slave
+ list [catch {dde servername -exact -- $slave} msg] $msg
+} [list 0 $slave]
+
+test winDde-7.4 {DDE slave servername collision} {pcOnly} {
+ global slave
+ list [catch {dde servername -- $slave} msg] $msg
+} [list 0 [list $slave "#2"]]
+
+test winDde-7.5 {DDE slave cleanup} {pcOnly} {
+ global slave
+ list [catch {
+ interp delete $slave
+ set s [dde services TclEval {}]
+ set m [list [list TclEval $slave]]
+ if {[lsearch -exact $s $m] != -1} {
+ set s
+ }
+ } msg] $msg
+} {0 {}}
+
+# -------------------------------------------------------------------------
+
#cleanup
+catch {interp delete $slave}; # ensure we clean up the slave.
file delete -force $::scriptName
::tcltest::cleanupTests
return
+
+# Local Variables:
+# mode: tcl
+# End:
diff --git a/win/tclWinDde.c b/win/tclWinDde.c
index 08298fd..def845b 100644
--- a/win/tclWinDde.c
+++ b/win/tclWinDde.c
@@ -10,7 +10,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclWinDde.c,v 1.14 2003/03/22 23:01:23 patthoyts Exp $
+ * RCS: @(#) $Id: tclWinDde.c,v 1.15 2003/05/16 17:29:49 patthoyts Exp $
*/
#include "tclPort.h"
@@ -70,7 +70,7 @@ static DWORD ddeInstance; /* The application instance handle given
* to us by DdeInitialize. */
static int ddeIsServer = 0;
-#define TCL_DDE_VERSION "1.2.2"
+#define TCL_DDE_VERSION "1.2.3"
#define TCL_DDE_PACKAGE_NAME "dde"
#define TCL_DDE_SERVICE_NAME "TclEval"
@@ -231,16 +231,21 @@ Initialize(void)
static char *
DdeSetServerName(
Tcl_Interp *interp,
- char *name /* The name that will be used to
+ char *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 */
)
{
int suffix, offset;
RegisteredInterp *riPtr, *prevPtr;
Tcl_DString dString;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+ char *actualName;
+ Tcl_Obj *srvListPtr = NULL;
+ Tcl_Obj **srvPtrPtr = NULL;
+ int n, srvCount = 0, lastSuffix, r = TCL_OK;
/*
* See if the application is already registered; if so, remove its
@@ -279,16 +284,61 @@ DdeSetServerName(
return "";
}
- /*
- * Pick a name to use for the application. Use "name" if it's not
- * already in use. Otherwise add a suffix such as " #2", trying
- * larger and larger numbers until we eventually find one that is
- * unique.
+ /*
+ * Get the list of currently registered Tcl interpreters by calling
+ * the internal implementation of the 'dde services' command.
*/
-
- suffix = 1;
- offset = 0;
Tcl_DStringInit(&dString);
+ actualName = name;
+
+ if (! exactName )
+ {
+ r = DdeGetServicesList(interp, "TclEval", NULL);
+ if (r == TCL_OK)
+ srvListPtr = Tcl_GetObjResult(interp);
+ if (r == TCL_OK)
+ r = Tcl_ListObjGetElements(interp, srvListPtr, &srvCount, &srvPtrPtr);
+ if (r != TCL_OK) {
+ OutputDebugString(Tcl_GetStringResult(interp));
+ return NULL;
+ }
+
+ /*
+ * Pick a name to use for the application. Use "name" if it's not
+ * already in use. Otherwise add a suffix such as " #2", trying
+ * larger and larger numbers until we eventually find one that is
+ * unique.
+ */
+
+ offset = lastSuffix = 0;
+ suffix = 1;
+
+ while (suffix != lastSuffix) {
+ lastSuffix = suffix;
+ if (suffix > 1) {
+ if (suffix == 2) {
+ Tcl_DStringAppend(&dString, name, -1);
+ Tcl_DStringAppend(&dString, " #", 2);
+ offset = Tcl_DStringLength(&dString);
+ Tcl_DStringSetLength(&dString, offset + TCL_INTEGER_SPACE);
+ actualName = Tcl_DStringValue(&dString);
+ }
+ sprintf(Tcl_DStringValue(&dString) + offset, "%d", suffix);
+ }
+
+ /* see if the name is already in use, if so increment suffix */
+ for (n = 0; n < srvCount; ++n) {
+ Tcl_Obj* namePtr;
+
+ Tcl_ListObjIndex(interp, srvPtrPtr[n], 1, &namePtr);
+ if (strcmp(actualName, Tcl_GetString(namePtr)) == 0)
+ {
+ suffix++;
+ break;
+ }
+ }
+ }
+ }
/*
* We have found a unique name. Now add it to the registry.
@@ -296,10 +346,10 @@ DdeSetServerName(
riPtr = (RegisteredInterp *) ckalloc(sizeof(RegisteredInterp));
riPtr->interp = interp;
- riPtr->name = ckalloc(strlen(name) + 1);
+ riPtr->name = ckalloc(strlen(actualName) + 1);
riPtr->nextPtr = tsdPtr->interpListPtr;
tsdPtr->interpListPtr = riPtr;
- strcpy(riPtr->name, name);
+ strcpy(riPtr->name, actualName);
Tcl_CreateObjCommand(interp, "dde", Tcl_DdeObjCmd,
(ClientData) riPtr, DeleteProc);
@@ -989,13 +1039,19 @@ Tcl_DdeObjCmd(
DDE_EVAL
};
+ enum {
+ DDE_SERVERNAME_EXACT,
+ DDE_SERVERNAME_LAST,
+ };
+
static CONST char *ddeCommands[] = {"servername", "execute", "poke",
"request", "services", "eval",
(char *) NULL};
static CONST char *ddeOptions[] = {"-async", (char *) NULL};
static CONST char *ddeReqOptions[] = {"-binary", (char *) NULL};
- int index, argIndex;
- int async = 0, binary = 0;
+ static CONST char *ddeSrvOptions[] = {"-exact", "--", (char *) NULL};
+ int index, argIndex, i;
+ int async = 0, binary = 0, exact = 0;
int result = TCL_OK;
HSZ ddeService = NULL;
HSZ ddeTopic = NULL;
@@ -1031,11 +1087,34 @@ Tcl_DdeObjCmd(
switch (index) {
case DDE_SERVERNAME:
- if ((objc != 3) && (objc != 2)) {
- Tcl_WrongNumArgs(interp, 1, objv, "servername ?serverName?");
+ for (i = 2; i < objc; i++) {
+ if (Tcl_GetIndexFromObj(interp, objv[i], ddeSrvOptions,
+ "option", 0, &argIndex) != TCL_OK) {
+ break;
+ } else if (argIndex == DDE_SERVERNAME_EXACT) {
+ exact = 1;
+ } else if (argIndex == DDE_SERVERNAME_LAST) {
+ i++;
+ break;
+ } else {
+ Tcl_ResetResult(interp);
+ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
+ "bad option \"", Tcl_GetString(objv[i]),
+ "\": must be -exact, or --",
+ (char*)NULL);
+ return TCL_ERROR;
+ }
+ }
+
+ if ((objc - i) > 1) {
+ Tcl_ResetResult(interp);
+ Tcl_WrongNumArgs(interp, 1, objv,
+ "servername ?-exact? ?--?"
+ " ?serverName?");
return TCL_ERROR;
}
- firstArg = (objc - 1);
+
+ firstArg = (objc == i) ? 1 : i;
break;
case DDE_EXECUTE:
if ((objc < 5) || (objc > 6)) {
@@ -1157,7 +1236,7 @@ Tcl_DdeObjCmd(
switch (index) {
case DDE_SERVERNAME: {
- serviceName = DdeSetServerName(interp, serviceName);
+ serviceName = DdeSetServerName(interp, serviceName, exact);
if (serviceName != NULL) {
Tcl_SetStringObj(Tcl_GetObjResult(interp),
serviceName, -1);