diff options
| -rw-r--r-- | ChangeLog | 6 | ||||
| -rw-r--r-- | library/dde/pkgIndex.tcl | 4 | ||||
| -rw-r--r-- | tests/winDde.test | 159 | ||||
| -rw-r--r-- | win/tclWinDde.c | 117 |
4 files changed, 246 insertions, 40 deletions
@@ -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); |