Attachment "TIP120.patch" to
ticket [649859ffff]
added by
patthoyts
2003-05-18 05:28:50.
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 17 May 2003 22:20:36 -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 17 May 2003 22:20:36 -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 17 May 2003 22:20:36 -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.
#
***************
*** 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 \
--- 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? ?-handler proc? ?--? ?serverName?"}}
test winDde-6.2 {DDE servername set name} \
-constraints pcOnly \
***************
*** 338,343 ****
--- 338,412 ----
} \
-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}}
# -------------------------------------------------------------------------
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 17 May 2003 22:20:37 -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,537 ----
{
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) {
! /* prefix the passed in arguments with the handler command */
! result = Tcl_ListObjReplace(riPtr->interp, ddeObjectPtr, 0, 0, 1,
! &(riPtr->handlerPtr));
! }
!
! 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;
--- 540,551 ----
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);
--- 715,735 ----
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 ****
--- 1135,1141 ----
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;
--- 1144,1150 ----
(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);
/*
--- 1162,1168 ----
HDDEDATA ddeReturn;
RegisteredInterp *riPtr;
Tcl_Interp *sendInterp;
! Tcl_Obj *objPtr, *handlerPtr = NULL;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
/*
***************
*** 1093,1098 ****
--- 1188,1204 ----
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;
}
--- 1206,1212 ----
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;
}
--- 1215,1221 ----
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);
--- 1342,1349 ----
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) {
--- 1522,1545 ----
* 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)
! result = Tcl_ListObjReplace(sendInterp, objPtr, 0, 0, 1, &(riPtr->handlerPtr));
! }
! 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));
}
--- 1553,1567 ----
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 ****
--- 1700,1710 ----
}
return TCL_ERROR;
}
+
+ /*
+ * Local variables:
+ * mode: c
+ * indent-tabs-mode: t
+ * tab-width: 8
+ * End:
+ */
