Tcl Source Code

Artifact Content
Login
Bounty program for improvements to Tcl and certain Tcl packages.
Tcl 2019 Conference, Houston/TX, US, Nov 4-8
Send your abstracts to [email protected]
or submit via the online form by Sep 9.

Artifact 3d6568ba815c9b50b58062dc37f8e053de2d5c06:

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:
+  */