Attachment "TIP120-2.patch" to
ticket [649859ffff]
added by
patthoyts
2003-05-21 04:43:02.
Index: doc/dde.n
===================================================================
RCS file: /cvsroot/tcl/tcl/doc/dde.n,v
retrieving revision 1.9
diff -c -r1.9 dde.n
*** doc/dde.n 16 May 2003 22:00:47 -0000 1.9
--- doc/dde.n 20 May 2003 21:24:51 -0000
***************
*** 17,23 ****
.sp
\fBpackage require dde 1.2\fR
.sp
! \fBdde \fIservername\fR ?\fI-exact\fR? ?\fI--\fR? ?\fItopic\fR?
.sp
\fBdde \fIexecute\fR ?\fI\-async\fR? \fIservice topic \fR?\fIdata\fR?
.sp
--- 17,23 ----
.sp
\fBpackage require dde 1.2\fR
.sp
! \fBdde \fIservername\fR ?\fI-exact\fR? ?\fI-handler proc\fR? ?\fI--\fR? ?\fItopic\fR?
.sp
\fBdde \fIexecute\fR ?\fI\-async\fR? \fIservice topic \fR?\fIdata\fR?
.sp
***************
*** 50,56 ****
The following commands are a subset of the full Dynamic Data Exchange
set of commands.
.TP
! \fBdde servername \fR?\fI-exact\fR? ?\fI--\fR? ?\fItopic\fR?
\fBdde servername\fR registers the interpreter as a DDE server with
the service name \fBTclEval\fR and the topic name specified by \fItopic\fR.
If no \fItopic\fR is given, \fBdde servername\fR returns the name
--- 50,56 ----
The following commands are a subset of the full Dynamic Data Exchange
set of commands.
.TP
! \fBdde servername \fR?\fI-exact\fR? ?\fI-handler proc\fR? ?\fI--\fR? ?\fItopic\fR?
\fBdde servername\fR registers the interpreter as a DDE server with
the service name \fBTclEval\fR and the topic name specified by \fItopic\fR.
If no \fItopic\fR is given, \fBdde servername\fR returns the name
***************
*** 60,65 ****
--- 60,71 ----
unique. The command's result will be the name actually used. The
\fI-exact\fR option is used to force registration of precisely the
given \fItopic\fR name.
+ .IP
+ The \fI-handler\fR option specifies a tcl procedure that will be called to
+ process calls to the dde server. If the package has been loaded into a
+ safe interpreter then a \fI-handler\fR procedure must be defined. The
+ procedure is called with all the arguments provided by the remote
+ call.
.TP
\fBdde execute\fR ?\fI\-async\fR? \fIservice topic data\fR
\fBdde execute\fR takes the \fIdata\fR and sends it to the server indicated
Index: library/dde/pkgIndex.tcl
===================================================================
RCS file: /cvsroot/tcl/tcl/library/dde/pkgIndex.tcl,v
retrieving revision 1.12
diff -c -r1.12 pkgIndex.tcl
*** library/dde/pkgIndex.tcl 16 May 2003 17:29:49 -0000 1.12
--- library/dde/pkgIndex.tcl 20 May 2003 21:24:51 -0000
***************
*** 1,6 ****
if {![package vsatisfies [package provide Tcl] 8]} {return}
if {[info exists ::tcl_platform(debug)]} {
! package ifneeded dde 1.2.3 [list load [file join $dir tcldde12g.dll] dde]
} else {
! package ifneeded dde 1.2.3 [list load [file join $dir tcldde12.dll] dde]
}
--- 1,6 ----
if {![package vsatisfies [package provide Tcl] 8]} {return}
if {[info exists ::tcl_platform(debug)]} {
! package ifneeded dde 1.2.4 [list load [file join $dir tcldde12g.dll] dde]
} else {
! package ifneeded dde 1.2.4 [list load [file join $dir tcldde12.dll] dde]
}
Index: tests/winDde.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/winDde.test,v
retrieving revision 1.16
diff -c -r1.16 winDde.test
*** tests/winDde.test 16 May 2003 22:00:47 -0000 1.16
--- tests/winDde.test 20 May 2003 21:24:51 -0000
***************
*** 2,8 ****
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
! # generates output for errors. No output means no errors were found.
#
# Copyright (c) 1999 by Scriptics Corporation.
#
--- 2,8 ----
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
! # generates output for errors. No output means no errors were found.
#
# Copyright (c) 1999 by Scriptics Corporation.
#
***************
*** 13,18 ****
--- 13,19 ----
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
+ #tcltest::configure -verbose {pass start}
namespace import -force ::tcltest::*
}
***************
*** 34,43 ****
set scriptName [makeFile {} script1.tcl]
! proc createChildProcess { ddeServerName } {
file delete -force $::scriptName
set f [open $::scriptName w+]
puts $f {
# DDE child server -
#
--- 35,45 ----
set scriptName [makeFile {} script1.tcl]
! proc createChildProcess { ddeServerName {handler {}}} {
file delete -force $::scriptName
set f [open $::scriptName w+]
+ puts $f [list set ddeServerName $ddeServerName]
puts $f {
# DDE child server -
#
***************
*** 59,73 ****
# 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.
after 200;# give dde a chance to get going.
--- 61,97 ----
# 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 ddeServerName
set done 1
+ puts "winDde.test child process $ddeServerName timed out."
+ flush stdout
+ }
+ set timeout [after 30000 ::DoTimeout]
+
+ # Define a restricted handler.
+ proc Handler1 {cmd} {
+ if {$cmd eq "stop"} {set ::done 1}
+ puts $cmd ; flush stdout
+ return
+ }
+ proc Handler2 {cmd} {
+ if {$cmd eq "stop"} {set ::done 1}
+ puts [uplevel \#0 $cmd] ; flush stdout
+ return
+ }
+ proc Handler3 {prefix cmd} {
+ if {$cmd eq "stop"} {set ::done 1}
+ puts [list $prefix $cmd] ; flush stdout
+ return
}
}
# set the dde server name to the supplied argument.
! if {$handler == {}} {
! puts $f [list dde servername $ddeServerName]
! } else {
! puts $f [list dde servername -handler $handler -- $ddeServerName]
! }
puts $f {
# run the server and handle final cleanup.
after 200;# give dde a chance to get going.
***************
*** 212,218 ****
test winDde-6.1 {DDE servername bad arguments} \
-constraints pcOnly \
-body {list [catch {dde servername -z -z -z} msg] $msg} \
! -result {1 {wrong # args: should be "dde servername ?-exact? ?--? ?serverName?"}}
test winDde-6.2 {DDE servername set name} \
-constraints pcOnly \
--- 236,242 ----
test winDde-6.1 {DDE servername bad arguments} \
-constraints pcOnly \
-body {list [catch {dde servername -z -z -z} msg] $msg} \
! -result {1 {wrong # args: should be "dde servername ?-exact? ?-handler proc? ?--? ?serverName?"}}
test winDde-6.2 {DDE servername set name} \
-constraints pcOnly \
***************
*** 338,348 ****
} \
-result "dde-interp-7.5 #2"
# -------------------------------------------------------------------------
#cleanup
! catch {interp delete $slave}; # ensure we clean up the slave.
file delete -force $::scriptName
::tcltest::cleanupTests
return
--- 362,592 ----
} \
-result "dde-interp-7.5 #2"
+ # -------------------------------------------------------------------------
+
+ test winDde-8.1 {Safe DDE load} \
+ -constraints pcOnly \
+ -setup {
+ interp create -safe slave
+ slave invokehidden load $lib dde
+ } \
+ -body {
+ list [catch {slave eval dde servername slave} msg] $msg
+ } \
+ -cleanup {interp delete slave} \
+ -result {1 {invalid command name "dde"}}
+
+ test winDde-8.2 {Safe DDE set servername} \
+ -constraints pcOnly \
+ -setup {
+ interp create -safe slave
+ slave invokehidden load $lib dde
+ } \
+ -body {
+ slave invokehidden dde servername slave
+ } \
+ -cleanup {interp delete slave} \
+ -result {slave}
+
+ test winDde-8.3 {Safe DDE check handler required for eval} \
+ -constraints pcOnly \
+ -setup {
+ interp create -safe slave
+ slave invokehidden load $lib dde
+ slave invokehidden dde servername slave
+ } \
+ -body {
+ catch {dde eval slave set a 1} msg
+ } \
+ -cleanup {interp delete slave} \
+ -result {1}
+
+ test winDde-8.4 {Safe DDE check that execute is denied} \
+ -constraints pcOnly \
+ -setup {
+ interp create -safe slave
+ slave invokehidden load $lib dde
+ slave invokehidden dde servername slave
+ } \
+ -body {
+ slave eval set a 1
+ list [catch {
+ dde execute TclEval slave {set a 2}
+ slave eval set a
+ } msg] $msg
+ } \
+ -cleanup {interp delete slave} \
+ -result {0 1}
+
+ test winDde-8.5 {Safe DDE check that request is denied} \
+ -constraints pcOnly \
+ -setup {
+ interp create -safe slave
+ slave invokehidden load $lib dde
+ slave invokehidden dde servername slave
+ } \
+ -body {
+ slave eval set a 1
+ list [catch {dde request TclEval slave a} msg] $msg
+ } \
+ -cleanup {interp delete slave} \
+ -result {1 {remote server cannot handle this command}}
+
+ test winDde-8.6 {Safe DDE assign handler procedure} \
+ -constraints pcOnly \
+ -setup {
+ interp create -safe slave
+ slave invokehidden load $lib dde
+ slave eval {proc DDEACCEPT {cmd} {set ::DDECMD $cmd}}
+ } \
+ -body {
+ slave invokehidden dde servername -handler DDEACCEPT slave
+ } \
+ -cleanup {interp delete slave} \
+ -result slave
+
+ test winDde-8.7 {Safe DDE check simple command} \
+ -constraints pcOnly \
+ -setup {
+ interp create -safe slave
+ slave invokehidden load $lib dde
+ slave eval {proc DDEACCEPT {cmd} {set ::DDECMD $cmd}}
+ slave invokehidden dde servername -handler DDEACCEPT slave
+ } \
+ -body {
+ list [catch {
+ dde eval slave set x 1
+ } msg] $msg
+ } \
+ -cleanup {interp delete slave} \
+ -result {0 {set x 1}}
+
+ test winDde-8.8 {Safe DDE check non-list command} \
+ -constraints pcOnly \
+ -setup {
+ interp create -safe slave
+ slave invokehidden load $lib dde
+ slave eval {proc DDEACCEPT {cmd} {set ::DDECMD $cmd}}
+ slave invokehidden dde servername -handler DDEACCEPT slave
+ } \
+ -body {
+ list [catch {
+ set s "c:\\Program Files\\Microsoft Visual Studio\\"
+ dde eval slave $s
+ string compare [slave eval set DDECMD] $s
+ } msg] $msg
+ } \
+ -cleanup {interp delete slave} \
+ -result {0 0}
+
+ test winDde-8.9 {Safe DDE check command evaluation} \
+ -constraints pcOnly \
+ -setup {
+ interp create -safe slave
+ slave invokehidden load $lib dde
+ slave eval {proc DDEACCEPT {cmd} {set ::DDECMD [uplevel #0 $cmd]}}
+ slave invokehidden dde servername -handler DDEACCEPT slave
+ } \
+ -body {
+ list [catch {
+ dde eval slave set x 1
+ slave eval set x
+ } msg] $msg
+ } \
+ -cleanup {interp delete slave} \
+ -result {0 1}
+
+ test winDde-8.10 {Safe DDE check command evaluation (2)} \
+ -constraints pcOnly \
+ -setup {
+ interp create -safe slave
+ slave invokehidden load $lib dde
+ slave eval {proc DDEACCEPT {cmd} {set ::DDECMD [uplevel #0 $cmd]}}
+ slave invokehidden dde servername -handler DDEACCEPT slave
+ } \
+ -body {
+ list [catch {
+ dde eval slave [list set x 1]
+ slave eval set x
+ } msg] $msg
+ } \
+ -cleanup {interp delete slave} \
+ -result {0 1}
+
+ test winDde-8.11 {Safe DDE check command evaluation (3)} \
+ -constraints pcOnly \
+ -setup {
+ interp create -safe slave
+ slave invokehidden load $lib dde
+ slave eval {proc DDEACCEPT {cmd} {set ::DDECMD [uplevel #0 $cmd]}}
+ slave invokehidden dde servername -handler DDEACCEPT slave
+ } \
+ -body {
+ list [catch {
+ dde eval slave [list [list set x 1]]
+ slave eval set x
+ } msg] $msg
+ } \
+ -cleanup {interp delete slave} \
+ -result {1 {invalid command name "set x 1"}}
+
+ # -------------------------------------------------------------------------
+
+ test winDde-9.1 {External safe DDE check string passing} \
+ -constraints {pcOnly stdio} \
+ -setup {
+ set name child-9.1
+ set child [createChildProcess $name Handler1]
+ file copy -force script1.tcl dde-script.tcl
+ } \
+ -body {
+ list [catch {
+ dde eval $name set x 1
+ gets $child line
+ set line
+ } msg] $msg
+ } \
+ -cleanup {dde execute TclEval $name stop ; update} \
+ -result {0 {set x 1}}
+
+ test winDde-9.2 {External safe DDE check command evaluation} \
+ -constraints {pcOnly stdio} \
+ -setup {
+ set name child-9.2
+ set child [createChildProcess $name Handler2]
+ file copy -force script1.tcl dde-script.tcl
+ } \
+ -body {
+ list [catch {
+ dde eval $name set x 1
+ gets $child line
+ set line
+ } msg] $msg
+ } \
+ -cleanup {dde execute TclEval $name stop ; update} \
+ -result {0 1}
+
+ test winDde-9.3 {External safe DDE check prefixed arguments} \
+ -constraints {pcOnly stdio} \
+ -setup {
+ set name child-9.3
+ set child [createChildProcess $name [list Handler3 ARG]]
+ file copy -force script1.tcl dde-script.tcl
+ } \
+ -body {
+ list [catch {
+ dde eval $name set x 1
+ gets $child line
+ set line
+ } msg] $msg
+ } \
+ -cleanup {dde execute TclEval $name stop ; update} \
+ -result {0 {ARG {set x 1}}}
# -------------------------------------------------------------------------
#cleanup
! #catch {interp delete $slave}; # ensure we clean up the slave.
file delete -force $::scriptName
::tcltest::cleanupTests
return
Index: win/tclWinDde.c
===================================================================
RCS file: /cvsroot/tcl/tcl/win/tclWinDde.c,v
retrieving revision 1.15
diff -c -r1.15 tclWinDde.c
*** win/tclWinDde.c 16 May 2003 17:29:49 -0000 1.15
--- win/tclWinDde.c 20 May 2003 21:24:52 -0000
***************
*** 36,41 ****
--- 36,42 ----
/* The next interp this application knows
* about. */
char *name; /* Interpreter's name (malloc-ed). */
+ Tcl_Obj *handlerPtr; /* The server handler command */
Tcl_Interp *interp; /* The interpreter attached to this name. */
} RegisteredInterp;
***************
*** 70,76 ****
* to us by DdeInitialize. */
static int ddeIsServer = 0;
! #define TCL_DDE_VERSION "1.2.3"
#define TCL_DDE_PACKAGE_NAME "dde"
#define TCL_DDE_SERVICE_NAME "TclEval"
--- 71,77 ----
* to us by DdeInitialize. */
static int ddeIsServer = 0;
! #define TCL_DDE_VERSION "1.2.4"
#define TCL_DDE_PACKAGE_NAME "dde"
#define TCL_DDE_SERVICE_NAME "TclEval"
***************
*** 102,107 ****
--- 103,109 ----
Tcl_Obj *CONST objv[]); /* The arguments */
EXTERN int Dde_Init(Tcl_Interp *interp);
+ EXTERN int Dde_SafeInit(Tcl_Interp *interp);
/*
*----------------------------------------------------------------------
***************
*** 141,146 ****
--- 143,175 ----
/*
*----------------------------------------------------------------------
*
+ * Dde_SafeInit --
+ *
+ * This procedure initializes the dde command within a safe interp
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+ int
+ Dde_SafeInit(
+ Tcl_Interp *interp)
+ {
+ int result = Dde_Init(interp);
+ if (result == TCL_OK) {
+ Tcl_HideCommand(interp, "dde", "dde");
+ }
+ return result;
+ }
+
+ /*
+ *----------------------------------------------------------------------
+ *
* Initialize --
*
* Initialize the global DDE instance.
***************
*** 235,241 ****
* 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;
--- 264,272 ----
* refer to the interpreter in later
* "send" commands. Must be globally
* unique. */
! int exactName, /* Should we make a unique name? 0 = unique */
! Tcl_Obj *handlerPtr /* Name of the optional proc/command to handle
! * incoming Dde eval's */
)
{
int suffix, offset;
***************
*** 348,356 ****
--- 379,394 ----
riPtr->interp = interp;
riPtr->name = ckalloc(strlen(actualName) + 1);
riPtr->nextPtr = tsdPtr->interpListPtr;
+ riPtr->handlerPtr = handlerPtr;
+ if (riPtr->handlerPtr != NULL)
+ Tcl_IncrRefCount(riPtr->handlerPtr);
tsdPtr->interpListPtr = riPtr;
strcpy(riPtr->name, actualName);
+ if (Tcl_IsSafe(interp)) {
+ Tcl_ExposeCommand(interp, "dde", "dde");
+ }
+
Tcl_CreateObjCommand(interp, "dde", Tcl_DdeObjCmd,
(ClientData) riPtr, DeleteProc);
if (Tcl_IsSafe(interp)) {
***************
*** 369,374 ****
--- 407,445 ----
/*
*--------------------------------------------------------------
*
+ * DdeGetRegistrationPtr
+ *
+ * Retrieve the registration info for an interpreter.
+ *
+ * Results:
+ * Returns a pointer to the registration structure or NULL
+ *
+ * Side effects:
+ * None
+ *
+ *--------------------------------------------------------------
+ */
+
+ static RegisteredInterp *
+ DdeGetRegistrationPtr(
+ Tcl_Interp *interp
+ )
+ {
+ RegisteredInterp *riPtr;
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+
+ for (riPtr = tsdPtr->interpListPtr; riPtr != NULL;
+ riPtr = riPtr->nextPtr) {
+ if (riPtr->interp == interp) {
+ break;
+ }
+ }
+ return riPtr;
+ }
+
+ /*
+ *--------------------------------------------------------------
+ *
* DeleteProc
*
* This procedure is called when the command "dde" is destroyed.
***************
*** 407,412 ****
--- 478,485 ----
}
}
ckfree(riPtr->name);
+ if (riPtr->handlerPtr)
+ Tcl_DecrRefCount(riPtr->handlerPtr);
Tcl_EventuallyFree(clientData, TCL_DYNAMIC);
}
***************
*** 441,449 ****
{
Tcl_Obj *errorObjPtr;
Tcl_Obj *returnPackagePtr;
! int result;
- result = Tcl_EvalObjEx(riPtr->interp, ddeObjectPtr, TCL_EVAL_GLOBAL);
returnPackagePtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
Tcl_ListObjAppendElement(NULL, returnPackagePtr,
Tcl_NewIntObj(result));
--- 514,540 ----
{
Tcl_Obj *errorObjPtr;
Tcl_Obj *returnPackagePtr;
! int result = TCL_OK;
!
! if (riPtr->handlerPtr == NULL && Tcl_IsSafe(riPtr->interp)) {
! Tcl_SetObjResult(riPtr->interp, Tcl_NewStringObj("permission denied:"
! " a handler procedure must be defined for use in a safe interp", -1));
! result = TCL_ERROR;
! }
!
! if (riPtr->handlerPtr != NULL) {
! /* add the dde request data to the handler proc list */
! Tcl_Obj *cmdPtr = Tcl_DuplicateObj(riPtr->handlerPtr);
! result = Tcl_ListObjAppendElement(riPtr->interp, cmdPtr, ddeObjectPtr);
! if (result == TCL_OK) {
! ddeObjectPtr = cmdPtr;
! }
! }
!
! if (result == TCL_OK) {
! result = Tcl_EvalObjEx(riPtr->interp, ddeObjectPtr, TCL_EVAL_GLOBAL);
! }
returnPackagePtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
Tcl_ListObjAppendElement(NULL, returnPackagePtr,
Tcl_NewIntObj(result));
***************
*** 452,461 ****
if (result == TCL_ERROR) {
errorObjPtr = Tcl_GetVar2Ex(riPtr->interp, "errorCode", NULL,
TCL_GLOBAL_ONLY);
! Tcl_ListObjAppendElement(NULL, returnPackagePtr, errorObjPtr);
errorObjPtr = Tcl_GetVar2Ex(riPtr->interp, "errorInfo", NULL,
TCL_GLOBAL_ONLY);
! Tcl_ListObjAppendElement(NULL, returnPackagePtr, errorObjPtr);
}
return returnPackagePtr;
--- 543,554 ----
if (result == TCL_ERROR) {
errorObjPtr = Tcl_GetVar2Ex(riPtr->interp, "errorCode", NULL,
TCL_GLOBAL_ONLY);
! if (errorObjPtr)
! Tcl_ListObjAppendElement(NULL, returnPackagePtr, errorObjPtr);
errorObjPtr = Tcl_GetVar2Ex(riPtr->interp, "errorInfo", NULL,
TCL_GLOBAL_ONLY);
! if (errorObjPtr)
! Tcl_ListObjAppendElement(NULL, returnPackagePtr, errorObjPtr);
}
return returnPackagePtr;
***************
*** 625,641 ****
returnString, (DWORD) len+1, 0, ddeItem, CF_TEXT,
0);
} else {
! Tcl_Obj *variableObjPtr = Tcl_GetVar2Ex(
! convPtr->riPtr->interp, utilString, NULL,
! TCL_GLOBAL_ONLY);
! if (variableObjPtr != NULL) {
! returnString = Tcl_GetStringFromObj(variableObjPtr,
! &len);
! ddeReturn = DdeCreateDataHandle(ddeInstance,
! returnString, (DWORD) len+1, 0, ddeItem,
! CF_TEXT, 0);
! } else {
ddeReturn = NULL;
}
}
Tcl_DStringFree(&dString);
--- 718,738 ----
returnString, (DWORD) len+1, 0, ddeItem, CF_TEXT,
0);
} else {
! if (Tcl_IsSafe(convPtr->riPtr->interp)) {
ddeReturn = NULL;
+ } else {
+ Tcl_Obj *variableObjPtr = Tcl_GetVar2Ex(
+ convPtr->riPtr->interp, utilString, NULL,
+ TCL_GLOBAL_ONLY);
+ if (variableObjPtr != NULL) {
+ returnString = Tcl_GetStringFromObj(variableObjPtr,
+ &len);
+ ddeReturn = DdeCreateDataHandle(ddeInstance,
+ returnString, (DWORD) len+1, 0, ddeItem,
+ CF_TEXT, 0);
+ } else {
+ ddeReturn = NULL;
+ }
}
}
Tcl_DStringFree(&dString);
***************
*** 1041,1046 ****
--- 1138,1144 ----
enum {
DDE_SERVERNAME_EXACT,
+ DDE_SERVERNAME_HANDLER,
DDE_SERVERNAME_LAST,
};
***************
*** 1049,1055 ****
(char *) NULL};
static CONST char *ddeOptions[] = {"-async", (char *) NULL};
static CONST char *ddeReqOptions[] = {"-binary", (char *) NULL};
! static CONST char *ddeSrvOptions[] = {"-exact", "--", (char *) NULL};
int index, argIndex, i;
int async = 0, binary = 0, exact = 0;
int result = TCL_OK;
--- 1147,1153 ----
(char *) NULL};
static CONST char *ddeOptions[] = {"-async", (char *) NULL};
static CONST char *ddeReqOptions[] = {"-binary", (char *) NULL};
! static CONST char *ddeSrvOptions[] = {"-exact", "-handler", "--", (char *) NULL};
int index, argIndex, i;
int async = 0, binary = 0, exact = 0;
int result = TCL_OK;
***************
*** 1067,1073 ****
HDDEDATA ddeReturn;
RegisteredInterp *riPtr;
Tcl_Interp *sendInterp;
! Tcl_Obj *objPtr;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
/*
--- 1165,1171 ----
HDDEDATA ddeReturn;
RegisteredInterp *riPtr;
Tcl_Interp *sendInterp;
! Tcl_Obj *objPtr, *handlerPtr = NULL;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
/*
***************
*** 1093,1098 ****
--- 1191,1207 ----
break;
} else if (argIndex == DDE_SERVERNAME_EXACT) {
exact = 1;
+ } else if (argIndex == DDE_SERVERNAME_HANDLER) {
+ if ((objc - i) == 1) { /* return current handler */
+ RegisteredInterp *riPtr = DdeGetRegistrationPtr(interp);
+ if (riPtr && riPtr->handlerPtr) {
+ Tcl_SetObjResult(interp, riPtr->handlerPtr);
+ } else {
+ Tcl_ResetResult(interp);
+ }
+ return TCL_OK;
+ }
+ handlerPtr = objv[++i];
} else if (argIndex == DDE_SERVERNAME_LAST) {
i++;
break;
***************
*** 1100,1106 ****
Tcl_ResetResult(interp);
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"bad option \"", Tcl_GetString(objv[i]),
! "\": must be -exact, or --",
(char*)NULL);
return TCL_ERROR;
}
--- 1209,1215 ----
Tcl_ResetResult(interp);
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"bad option \"", Tcl_GetString(objv[i]),
! "\": must be -exact, -handler or --",
(char*)NULL);
return TCL_ERROR;
}
***************
*** 1109,1115 ****
if ((objc - i) > 1) {
Tcl_ResetResult(interp);
Tcl_WrongNumArgs(interp, 1, objv,
! "servername ?-exact? ?--?"
" ?serverName?");
return TCL_ERROR;
}
--- 1218,1224 ----
if ((objc - i) > 1) {
Tcl_ResetResult(interp);
Tcl_WrongNumArgs(interp, 1, objv,
! "servername ?-exact? ?-handler proc? ?--?"
" ?serverName?");
return TCL_ERROR;
}
***************
*** 1236,1242 ****
switch (index) {
case DDE_SERVERNAME: {
! serviceName = DdeSetServerName(interp, serviceName, exact);
if (serviceName != NULL) {
Tcl_SetStringObj(Tcl_GetObjResult(interp),
serviceName, -1);
--- 1345,1352 ----
switch (index) {
case DDE_SERVERNAME: {
! serviceName = DdeSetServerName(interp, serviceName,
! exact, handlerPtr);
if (serviceName != NULL) {
Tcl_SetStringObj(Tcl_GetObjResult(interp),
serviceName, -1);
***************
*** 1415,1428 ****
* be referring to deallocated objects.
*/
! if (objc == 1) {
! result = Tcl_EvalObjEx(sendInterp, objv[0],
! TCL_EVAL_GLOBAL);
! } else {
! objPtr = Tcl_ConcatObj(objc, objv);
Tcl_IncrRefCount(objPtr);
! result = Tcl_EvalObjEx(sendInterp, objPtr,
! TCL_EVAL_GLOBAL);
Tcl_DecrRefCount(objPtr);
}
if (interp != sendInterp) {
--- 1525,1555 ----
* be referring to deallocated objects.
*/
! if (Tcl_IsSafe(riPtr->interp) && riPtr->handlerPtr == NULL) {
! Tcl_SetResult(riPtr->interp, "permission denied: "
! "a handler procedure must be defined for use in a safe interp", TCL_STATIC);
! result = TCL_ERROR;
! }
!
! if (result == TCL_OK) {
! if (objc == 1)
! objPtr = objv[0];
! else {
! objPtr = Tcl_ConcatObj(objc, objv);
! }
! if (riPtr->handlerPtr != NULL) {
! /* add the dde request data to the handler proc list */
! /*result = Tcl_ListObjReplace(sendInterp, objPtr, 0, 0, 1, &(riPtr->handlerPtr));*/
! Tcl_Obj *cmdPtr = Tcl_DuplicateObj(riPtr->handlerPtr);
! result = Tcl_ListObjAppendElement(sendInterp, cmdPtr, objPtr);
! if (result == TCL_OK) {
! objPtr = cmdPtr;
! }
! }
! }
! if (result == TCL_OK) {
Tcl_IncrRefCount(objPtr);
! result = Tcl_EvalObjEx(sendInterp, objPtr, TCL_EVAL_GLOBAL);
Tcl_DecrRefCount(objPtr);
}
if (interp != sendInterp) {
***************
*** 1436,1447 ****
Tcl_ResetResult(interp);
objPtr = Tcl_GetVar2Ex(sendInterp, "errorInfo", NULL,
TCL_GLOBAL_ONLY);
! string = Tcl_GetStringFromObj(objPtr, &length);
! Tcl_AddObjErrorInfo(interp, string, length);
objPtr = Tcl_GetVar2Ex(sendInterp, "errorCode", NULL,
TCL_GLOBAL_ONLY);
! Tcl_SetObjErrorCode(interp, objPtr);
}
Tcl_SetObjResult(interp, Tcl_GetObjResult(sendInterp));
}
--- 1563,1577 ----
Tcl_ResetResult(interp);
objPtr = Tcl_GetVar2Ex(sendInterp, "errorInfo", NULL,
TCL_GLOBAL_ONLY);
! if (objPtr) {
! string = Tcl_GetStringFromObj(objPtr, &length);
! Tcl_AddObjErrorInfo(interp, string, length);
! }
objPtr = Tcl_GetVar2Ex(sendInterp, "errorCode", NULL,
TCL_GLOBAL_ONLY);
! if (objPtr)
! Tcl_SetObjErrorCode(interp, objPtr);
}
Tcl_SetObjResult(interp, Tcl_GetObjResult(sendInterp));
}
***************
*** 1580,1582 ****
--- 1710,1720 ----
}
return TCL_ERROR;
}
+
+ /*
+ * Local variables:
+ * mode: c
+ * indent-tabs-mode: t
+ * tab-width: 8
+ * End:
+ */