* 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]

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);