From edc0b0eed5666acae801e952c5cd3c6bcd5fca8a Mon Sep 17 00:00:00 2001 From: patthoyts Date: Mon, 23 Jun 2003 21:27:56 +0000 Subject: * doc/dde.n: Committed TIP #120 which provides the * win/tclWinDde.c: dde package for safe interpreters. * tests/winDde.test: Incremented package version to 1.2.4 * library/dde/pkgIndex.tcl: --- ChangeLog | 7 ++ doc/dde.n | 12 ++- library/dde/pkgIndex.tcl | 4 +- tests/winDde.test | 264 +++++++++++++++++++++++++++++++++++++++++++++-- win/tclWinDde.c | 202 ++++++++++++++++++++++++++++++------ 5 files changed, 442 insertions(+), 47 deletions(-) diff --git a/ChangeLog b/ChangeLog index e50f9da..9110c81 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,10 @@ +2003-06-23 Pat Thoyts + + * doc/dde.n: Committed TIP #120 which provides the + * win/tclWinDde.c: dde package for safe interpreters. + * tests/winDde.test: Incremented package version to 1.2.4 + * library/dde/pkgIndex.tcl: + 2003-06-23 Vince Darley * generic/tclFCmd.c: fix to bad error message when trying to diff --git a/doc/dde.n b/doc/dde.n index c28c26f..b826732 100644 --- a/doc/dde.n +++ b/doc/dde.n @@ -5,7 +5,7 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: dde.n,v 1.9 2003/05/16 22:00:47 patthoyts Exp $ +'\" RCS: @(#) $Id: dde.n,v 1.10 2003/06/23 21:27:56 patthoyts Exp $ '\" .so man.macros .TH dde n 1.2 dde "Tcl Bundled Packages" @@ -17,7 +17,7 @@ dde \- Execute a Dynamic Data Exchange command .sp \fBpackage require dde 1.2\fR .sp -\fBdde \fIservername\fR ?\fI-exact\fR? ?\fI--\fR? ?\fItopic\fR? +\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,7 +50,7 @@ The \fBeval\fR and \fBexecute\fR commands accept the option \fB\-async\fR: 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?\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,6 +60,12 @@ suffix of the form ' #2' or ' #3' is appended to the name to make it 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 diff --git a/library/dde/pkgIndex.tcl b/library/dde/pkgIndex.tcl index c12e3a1..b5d65a5 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.3 [list load [file join $dir tcldde12g.dll] dde] + package ifneeded dde 1.2.4 [list load [file join $dir tcldde12g.dll] dde] } else { - package ifneeded dde 1.2.3 [list load [file join $dir tcldde12.dll] dde] + package ifneeded dde 1.2.4 [list load [file join $dir tcldde12.dll] dde] } diff --git a/tests/winDde.test b/tests/winDde.test index 06dab25..a23650d 100644 --- a/tests/winDde.test +++ b/tests/winDde.test @@ -2,17 +2,18 @@ # # 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. +# generates output for errors. No output means no errors were found. # # Copyright (c) 1999 by Scriptics Corporation. # # 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.16 2003/05/16 22:00:47 patthoyts Exp $ +# RCS: @(#) $Id: winDde.test,v 1.17 2003/06/23 21:27:56 patthoyts Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest + #tcltest::configure -verbose {pass start} namespace import -force ::tcltest::* } @@ -34,10 +35,11 @@ if {$tcl_platform(platform) == "windows"} { set scriptName [makeFile {} script1.tcl] -proc createChildProcess { ddeServerName } { +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,15 +61,37 @@ proc createChildProcess { ddeServerName } { # 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." + 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 timeout [after 30000 DoTimeout] } # set the dde server name to the supplied argument. - puts $f [list dde servername $ddeServerName] + 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,7 +236,7 @@ test winDde-5.4 {DDE eval bad arguments} {pcOnly} { 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?"}} + -result {1 {wrong # args: should be "dde servername ?-exact? ?-handler proc? ?--? ?serverName?"}} test winDde-6.2 {DDE servername set name} \ -constraints pcOnly \ @@ -338,11 +362,231 @@ test winDde-7.5 {interp name collision without -exact} \ } \ -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. +#catch {interp delete $slave}; # ensure we clean up the slave. file delete -force $::scriptName ::tcltest::cleanupTests return diff --git a/win/tclWinDde.c b/win/tclWinDde.c index def845b..d6d36cf 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.15 2003/05/16 17:29:49 patthoyts Exp $ + * RCS: @(#) $Id: tclWinDde.c,v 1.16 2003/06/23 21:27:56 patthoyts Exp $ */ #include "tclPort.h" @@ -36,6 +36,7 @@ typedef struct RegisteredInterp { /* 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,7 +71,7 @@ static DWORD ddeInstance; /* The application instance handle given * to us by DdeInitialize. */ static int ddeIsServer = 0; -#define TCL_DDE_VERSION "1.2.3" +#define TCL_DDE_VERSION "1.2.4" #define TCL_DDE_PACKAGE_NAME "dde" #define TCL_DDE_SERVICE_NAME "TclEval" @@ -102,6 +103,7 @@ int Tcl_DdeObjCmd(ClientData clientData, /* Used only for deletion */ Tcl_Obj *CONST objv[]); /* The arguments */ EXTERN int Dde_Init(Tcl_Interp *interp); +EXTERN int Dde_SafeInit(Tcl_Interp *interp); /* *---------------------------------------------------------------------- @@ -141,6 +143,33 @@ Dde_Init( /* *---------------------------------------------------------------------- * + * 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,7 +264,9 @@ DdeSetServerName( * refer to the interpreter in later * "send" commands. Must be globally * unique. */ - int exactName /* Should we make a unique name? 0 = 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,9 +379,16 @@ DdeSetServerName( 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,6 +407,39 @@ DdeSetServerName( /* *-------------------------------------------------------------- * + * 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,6 +478,8 @@ DeleteProc(clientData) } } ckfree(riPtr->name); + if (riPtr->handlerPtr) + Tcl_DecrRefCount(riPtr->handlerPtr); Tcl_EventuallyFree(clientData, TCL_DYNAMIC); } @@ -441,9 +514,27 @@ ExecuteRemoteObject( { Tcl_Obj *errorObjPtr; Tcl_Obj *returnPackagePtr; - int result; + 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); + } - result = Tcl_EvalObjEx(riPtr->interp, ddeObjectPtr, TCL_EVAL_GLOBAL); returnPackagePtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); Tcl_ListObjAppendElement(NULL, returnPackagePtr, Tcl_NewIntObj(result)); @@ -452,10 +543,12 @@ ExecuteRemoteObject( if (result == TCL_ERROR) { errorObjPtr = Tcl_GetVar2Ex(riPtr->interp, "errorCode", NULL, TCL_GLOBAL_ONLY); - Tcl_ListObjAppendElement(NULL, returnPackagePtr, errorObjPtr); + if (errorObjPtr) + Tcl_ListObjAppendElement(NULL, returnPackagePtr, errorObjPtr); errorObjPtr = Tcl_GetVar2Ex(riPtr->interp, "errorInfo", NULL, TCL_GLOBAL_ONLY); - Tcl_ListObjAppendElement(NULL, returnPackagePtr, errorObjPtr); + if (errorObjPtr) + Tcl_ListObjAppendElement(NULL, returnPackagePtr, errorObjPtr); } return returnPackagePtr; @@ -625,17 +718,21 @@ DdeServerProc ( 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 { + 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,6 +1138,7 @@ Tcl_DdeObjCmd( enum { DDE_SERVERNAME_EXACT, + DDE_SERVERNAME_HANDLER, DDE_SERVERNAME_LAST, }; @@ -1049,7 +1147,7 @@ Tcl_DdeObjCmd( (char *) NULL}; static CONST char *ddeOptions[] = {"-async", (char *) NULL}; static CONST char *ddeReqOptions[] = {"-binary", (char *) NULL}; - static CONST char *ddeSrvOptions[] = {"-exact", "--", (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,7 +1165,7 @@ Tcl_DdeObjCmd( HDDEDATA ddeReturn; RegisteredInterp *riPtr; Tcl_Interp *sendInterp; - Tcl_Obj *objPtr; + Tcl_Obj *objPtr, *handlerPtr = NULL; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); /* @@ -1093,6 +1191,17 @@ Tcl_DdeObjCmd( 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,7 +1209,7 @@ Tcl_DdeObjCmd( Tcl_ResetResult(interp); Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "bad option \"", Tcl_GetString(objv[i]), - "\": must be -exact, or --", + "\": must be -exact, -handler or --", (char*)NULL); return TCL_ERROR; } @@ -1109,7 +1218,7 @@ Tcl_DdeObjCmd( if ((objc - i) > 1) { Tcl_ResetResult(interp); Tcl_WrongNumArgs(interp, 1, objv, - "servername ?-exact? ?--?" + "servername ?-exact? ?-handler proc? ?--?" " ?serverName?"); return TCL_ERROR; } @@ -1236,7 +1345,8 @@ Tcl_DdeObjCmd( switch (index) { case DDE_SERVERNAME: { - serviceName = DdeSetServerName(interp, serviceName, exact); + serviceName = DdeSetServerName(interp, serviceName, + exact, handlerPtr); if (serviceName != NULL) { Tcl_SetStringObj(Tcl_GetObjResult(interp), serviceName, -1); @@ -1415,14 +1525,31 @@ Tcl_DdeObjCmd( * be referring to deallocated objects. */ - if (objc == 1) { - result = Tcl_EvalObjEx(sendInterp, objv[0], - TCL_EVAL_GLOBAL); - } else { - objPtr = Tcl_ConcatObj(objc, objv); + 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); + result = Tcl_EvalObjEx(sendInterp, objPtr, TCL_EVAL_GLOBAL); Tcl_DecrRefCount(objPtr); } if (interp != sendInterp) { @@ -1436,12 +1563,15 @@ Tcl_DdeObjCmd( Tcl_ResetResult(interp); objPtr = Tcl_GetVar2Ex(sendInterp, "errorInfo", NULL, TCL_GLOBAL_ONLY); - string = Tcl_GetStringFromObj(objPtr, &length); - Tcl_AddObjErrorInfo(interp, string, length); + if (objPtr) { + string = Tcl_GetStringFromObj(objPtr, &length); + Tcl_AddObjErrorInfo(interp, string, length); + } objPtr = Tcl_GetVar2Ex(sendInterp, "errorCode", NULL, TCL_GLOBAL_ONLY); - Tcl_SetObjErrorCode(interp, objPtr); + if (objPtr) + Tcl_SetObjErrorCode(interp, objPtr); } Tcl_SetObjResult(interp, Tcl_GetObjResult(sendInterp)); } @@ -1580,3 +1710,11 @@ Tcl_DdeObjCmd( } return TCL_ERROR; } + +/* + * Local variables: + * mode: c + * indent-tabs-mode: t + * tab-width: 8 + * End: + */ -- cgit v0.12